steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor into unicode 

Conflicts:

	core/io/files/files-docs.factor
	core/io/files/files-tests.factor
	core/io/files/files.factor
	core/listener/listener.factor
	extra/benchmark/sum-file/sum-file.factor
	extra/bootstrap/image/upload/upload.factor
	extra/http/server/templating/templating.factor
	extra/logging/server/server.factor
	extra/smtp/smtp.factor
	extra/tools/deploy/macosx/macosx.factor
	extra/tools/disassembler/disassembler.factor
	extra/webapps/file/file.factor
db4
Daniel Ehrenberg 2008-02-29 01:20:44 -06:00
parent 51ccd3417e ad2d06806b
commit efb3367c45
174 changed files with 2587 additions and 1286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/compiler/compiler.factor
View File

@ -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

5
core/bootstrap/primitives.factor
View File

@ -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

13
core/bootstrap/stage1.factor
View File

@ -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

104
core/bootstrap/stage2.factor
View File

@ -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

10
core/continuations/continuations-docs.factor
View File

@ -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." } ;

20
core/continuations/continuations.factor
View File

@ -6,6 +6,7 @@ IN: continuations
SYMBOL: error
SYMBOL: error-continuation
SYMBOL: error-thread
SYMBOL: restarts
<PRIVATE
@ -24,6 +25,8 @@ SYMBOL: restarts
#! with a declaration.
f { object } declare ;
: init-catchstack V{ } clone 1 setenv ;
PRIVATE>
: 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
[ <restart> ] curry { } assoc>map
append ;
<PRIVATE
: init-error-handler ( -- )
V{ } clone set-catchstack
! VM calls on error
[
continuation error-continuation set-global rethrow
] 5 setenv
! VM adds this to kernel errors, so that user-space
! can identify them
"kernel-error" 6 setenv ;
PRIVATE>

8
core/debugger/debugger-docs.factor
View File

@ -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." } ;

69
core/debugger/debugger.factor
View File

@ -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 ;
<PRIVATE
: init-debugger ( -- )
V{ } clone set-catchstack
! VM calls on error
[
self error-thread set-global
continuation error-continuation set-global
rethrow
] 5 setenv
! VM adds this to kernel errors, so that user-space
! can identify them
"kernel-error" 6 setenv ;
PRIVATE>
[ init-debugger ] "debugger" add-init-hook

7
core/init/init-tests.factor Normal file
View File

@ -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

2
core/init/init.factor
View File

@ -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 ;

1
core/io/encodings/authors.txt
View File

@ -1 +1,2 @@
Daniel Ehrenberg
Slava Pestov

1
core/io/encodings/tags.txt Normal file
View File

@ -0,0 +1 @@
text

201
core/io/files/files-docs.factor
View File

@ -1,46 +1,119 @@
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 <file-reader> }
{ $subsection <file-writer> }
{ $subsection <file-appender> }
"Utility combinators:"
{ $subsection with-file-reader }
{ $subsection with-file-writer }
{ $subsection with-file-appender }
{ $subsection file-contents }
{ $subsection file-lines }
{ $subsection file-lines } ;
ARTICLE: "pathnames" "Pathname manipulation"
"Pathname manipulation:"
{ $subsection parent-directory }
{ $subsection file-name }
{ $subsection last-path-separator }
{ $subsection path+ }
"File system meta-data:"
"Pathnames relative to Factor's install directory:"
{ $subsection resource-path }
{ $subsection ?resource-path }
"Pathnames relative to Factor's temporary files directory:"
{ $subsection temp-directory }
{ $subsection temp-file }
"Pathname presentations:"
{ $subsection pathname }
{ $subsection <pathname> } ;
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 <pathname> }
{ $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" }
{ $subsection "unique" }
{ $see-also "os" } ;
ABOUT: "file-streams"
ABOUT: "io.files"
HELP: path-separator?
{ $values { "ch" "a code point" } { "?" "a boolean" } }
{ $description "Tests if the code point is a platform-specific path separator." }
{ $examples
"On Unix:"
{ $example "USING: io.files prettyprint ;" "CHAR: / path-separator? ." "t" }
} ;
HELP: parent-directory
{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
{ $description "Strips the last component off a pathname." }
{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
HELP: file-name
{ $values { "path" "a pathname string" } { "string" string } }
{ $description "Outputs the last component of a pathname string." }
{ $examples
{ "\"/usr/bin/gcc\" file-name ." "\"gcc\"" }
{ "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
} ;
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptors" }
@ -93,7 +166,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" } }
@ -124,6 +202,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." } ;
@ -132,19 +215,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." } ;
@ -184,7 +254,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." } ;

97
core/io/files/files-tests.factor
View File

@ -6,63 +6,118 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ ] [
"test-foo.txt" resource-path ascii [
"test-foo.txt" temp-file ascii [
"Hello world." print
] with-file-writer
] unit-test
[ ] [
"test-foo.txt" resource-path ascii [
"test-foo.txt" temp-file ascii [
"Hello appender." print
] with-file-appender
] unit-test
[ ] [
"test-bar.txt" resource-path ascii [
"test-bar.txt" temp-file ascii [
"Hello appender." print
] with-file-appender
] unit-test
[ "Hello world.\nHello appender.\n" ] [
"test-foo.txt" resource-path ascii file-contents
"test-foo.txt" temp-file ascii file-contents
] unit-test
[ "Hello appender.\n" ] [
"test-bar.txt" resource-path ascii file-contents
"test-bar.txt" temp-file ascii file-contents
] unit-test
[ ] [ "test-foo.txt" resource-path delete-file ] unit-test
[ ] [ "test-foo.txt" temp-file delete-file ] unit-test
[ ] [ "test-bar.txt" resource-path delete-file ] unit-test
[ ] [ "test-bar.txt" temp-file delete-file ] unit-test
[ f ] [ "test-foo.txt" resource-path exists? ] unit-test
[ f ] [ "test-foo.txt" temp-file exists? ] unit-test
[ f ] [ "test-bar.txt" resource-path exists? ] unit-test
[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
[ ] [ "test-blah" resource-path make-directory ] unit-test
[ ] [ "test-blah" temp-file make-directory ] unit-test
[ ] [
"test-blah/fooz" resource-path ascii <file-writer> dispose
"test-blah/fooz" temp-file ascii <file-writer> 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 ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" resource-path delete-file ] unit-test
[ ] [ "test-quux.txt" temp-file delete-file ] unit-test
[ ] [ "test-quux.txt" resource-path ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test
[ t ] [ "quux-test.txt" resource-path exists? ] unit-test
[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" resource-path delete-file ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test
[ ] [
"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

182
core/io/files/files.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
IN: io.files
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary ;
IN: io.files
HOOK: cd io-backend ( path -- )
@ -33,12 +33,9 @@ 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 ;
@ -49,33 +46,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 -- * )
@ -99,15 +78,43 @@ TUPLE: no-parent-directory path ;
{ [ t ] [ drop ] }
} cond ;
: resource-path ( path -- newpath )
\ resource-path get [ image parent-directory ] unless*
swap path+ ;
TUPLE: file-info type size permissions modified ;
: ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ;
HOOK: file-info io-backend ( path -- info )
: resource-exists? ( path -- ? )
?resource-path exists? ;
SYMBOL: +regular-file+
SYMBOL: +directory+
SYMBOL: +character-device+
SYMBOL: +block-device+
SYMBOL: +fifo+
SYMBOL: +symbolic-link+
SYMBOL: +socket+
SYMBOL: +unknown+
! File metadata
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
: file-length ( path -- n ) stat drop 2nip ;
: file-modified ( path -- n ) stat >r 3drop r> ;
: file-permissions ( path -- perm ) stat 2drop nip ;
: exists? ( path -- ? ) file-modified >boolean ;
: directory? ( path -- ? ) stat 3drop ;
! Current working directory
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
: with-directory ( path quot -- )
swap cd cwd [ cd ] curry [ ] cleanup ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
normalize-pathname right-trim-separators {
@ -121,6 +128,49 @@ 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
@ -131,19 +181,49 @@ M: object copy-file
] with-disposal
] with-disposal ;
: copy-directory ( from to -- )
dup make-directories
>r dup directory swap r> [
>r >r first r> over path+ r> rot path+ copy-file
] 2curry each ;
: copy-file-to ( from to -- )
to-directory copy-file ;
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
} cond ;
: copy-files-to ( files to -- )
[ copy-file-to ] curry each ;
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> pathname
@ -172,3 +252,11 @@ M: pathname <=> [ pathname-string ] compare ;
when ;
: temp-file ( name -- path ) temp-directory swap path+ ;
! Home directory
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
} cond ;

68
core/io/io-docs.factor
View File

@ -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\" <file-reader>"
"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\" <file-reader> ["
" 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\" <file-reader> ["
" 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 ;

4
core/kernel/kernel-docs.factor
View File

@ -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." } ;

2
core/kernel/kernel.factor
View File

@ -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

10
core/libc/libc.factor Normal file → Executable file
View File

@ -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
<PRIVATE
@ -25,28 +25,22 @@ PRIVATE>
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 ;
<PRIVATE
[ H{ } clone mallocs set-global ] "mallocs" add-init-hook
[ H{ } clone mallocs set-global ] "libc" add-init-hook
: add-malloc ( alien -- )
dup mallocs get-global set-at ;

3
core/listener/listener-docs.factor
View File

@ -38,9 +38,6 @@ HELP: listen
{ $description "Prompts for an expression on the " { $link stdio } " stream and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
{ $errors "If the expression input by the user throws an error, the error is printed to the " { $link stdio } " stream and the word returns normally." } ;
HELP: print-banner
{ $description "Print Factor version, operating system, and CPU architecture." } ;
HELP: listener
{ $description "Prompts for expressions on the " { $link stdio } " stream and evaluates them until end of file is reached." } ;

10
core/listener/listener.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math memory namespaces
parser sequences strings io.styles
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles io.streams.lines
io.streams.duplex vectors words generic system combinators
tuples continuations debugger definitions compiler.units ;
IN: listener
@ -62,11 +62,7 @@ M: duplex-stream stream-read-quot
[ quit-flag off ]
[ listen until-quit ] if ; inline
: print-banner ( -- )
"Factor " write version write
" on " write os write "/" write cpu print ;
: listener ( -- )
print-banner [ until-quit ] with-interactive-vocabs ;
[ until-quit ] with-interactive-vocabs ;
MAIN: listener

5
core/math/math.factor
View File

@ -17,6 +17,11 @@ MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline
: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline
: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline
: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable

6
core/parser/parser-tests.factor
View File

@ -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

4
core/parser/parser.factor
View File

@ -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" ;
@ -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 ;

1
core/parser/test/assert-depth.factor Executable file
View File

@ -0,0 +1 @@
1 2 3

4
core/sequences/sequences-docs.factor
View File

@ -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 )" } } }

2
core/sorting/sorting-tests.factor Normal file → Executable file
View File

@ -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

2
core/sorting/sorting.factor
View File

@ -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

4
core/strings/strings-tests.factor
View File

@ -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

2
core/syntax/syntax-docs.factor
View File

@ -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."

2
core/syntax/syntax.factor
View File

@ -107,7 +107,7 @@ IN: bootstrap.syntax
] define-syntax
":" [
CREATE dup reset-generic parse-definition define
(:) define
] define-syntax
"GENERIC:" [

4
core/system/system-docs.factor
View File

@ -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"

28
core/threads/threads.factor
View File

@ -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>
: <thread> ( quot name error-handler -- thread )
: <thread> ( quot name -- thread )
\ thread counter <box> [ ] {
set-thread-quot
set-thread-name
set-thread-error-handler
set-thread-id
set-thread-continuation
set-thread-exit-handler
@ -179,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 ] <thread> [ (spawn) ] keep ;
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
>r [ [ ] [ ] while ] curry r> spawn ;
@ -202,6 +188,8 @@ M: real sleep
[ >r set-namestack set-datastack r> call ] 3curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
<PRIVATE
: init-threads ( -- )
@ -209,13 +197,13 @@ M: real sleep
<dlist> 42 setenv
<min-heap> 43 setenv
initial-thread global
[ drop f "Initial" [ die ] <thread> ] cache
[ drop f "Initial" <thread> ] cache
<box> 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>

4
extra/alarms/alarms-docs.factor
View File

@ -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

6
extra/alarms/alarms.factor
View File

@ -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 ;

10
extra/benchmark/crc32/crc32.factor Normal file
View File

@ -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

6
extra/benchmark/fasta/fasta.factor
View File

@ -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 +

7
extra/benchmark/md5/md5.factor Normal file
View File

@ -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

14
extra/benchmark/random/random.factor Normal file
View File

@ -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

5
extra/benchmark/sort/sort.factor
View File

@ -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

5
extra/benchmark/sum-file/sum-file.factor
View File

@ -1,4 +1,5 @@
USING: io io.files math math.parser kernel prettyprint io.encodings.ascii ;
USING: io io.files math math.parser kernel prettyprint
benchmark.random io.encodings.ascii ;
IN: benchmark.sum-file
: sum-file-loop ( n -- n' )
@ -8,6 +9,6 @@ IN: benchmark.sum-file
ascii [ 0 sum-file-loop ] with-file-reader . ;
: sum-file-main ( -- )
home "sum-file-in.txt" path+ sum-file ;
random-numbers-path sum-file ;
MAIN: sum-file-main

8
extra/bootstrap/image/upload/upload.factor
View File

@ -6,16 +6,20 @@ bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ;
: destination "slava@factorcode.org:www/images/latest/" ;
: checksums "checksums.txt" temp-file ;
: boot-image-names images [ boot-image-name ] map ;
: compute-checksums ( -- )
"checksums.txt" ascii [
checksums ascii [
boot-image-names [ dup write bl file>md5str print ] each
] with-file-writer ;
: upload-images ( -- )
[
"scp" , boot-image-names % "checksums.txt" , destination ,
"scp" ,
boot-image-names %
"temp/checksums.txt" , destination ,
] { } make try-process ;
: new-images ( -- )

2
extra/builder/util/util.factor
View File

@ -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

4
extra/bunny/model/model.factor
View File

@ -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

2
extra/calendar/authors.txt
View File

@ -1 +1 @@
Slava Pestov
Doug Coleman

263
extra/calendar/calendar-tests.factor
View File

@ -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 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 23 59 60 0 <timestamp> 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 <timestamp> 1 seconds time+
2006 10 10 0 0 1 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
2006 10 10 0 1 40 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
2006 10 9 23 58 20 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
2006 10 11 0 0 0 0 <timestamp> = ] 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 <timestamp> 10 minutes time+
2006 10 10 0 10 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
2006 10 10 0 10 30 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
2006 10 10 0 0 45 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
2006 10 9 23 59 15 0 <timestamp> = ] 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 <timestamp> 7200 minutes time+
2006 10 15 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
2006 10 9 23 50 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
2006 10 9 22 20 0 0 <timestamp> = ] 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 <timestamp> 1 hours time+
2006 1 1 1 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
2006 1 1 12 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
2006 1 4 0 0 0 0 <timestamp> = ] 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 <timestamp> 1 days time+
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
2004 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
2005 1 1 0 0 0 0 <timestamp> = ] 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 <timestamp> 11 months time+
2006 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
2008 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
2007 2 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
2006 2 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
2005 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
2005 11 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
2004 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
2004 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
2005 3 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
2003 3 1 0 0 0 0 <timestamp> = ] 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 <timestamp> 0 years time+
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
1906 1 1 0 0 0 0 <timestamp> = ] unit-test
! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
! 2003 2 28 0 0 0 0 <timestamp> = ] 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 <timestamp> 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 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] 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 <timestamp> day-of-year ] unit-test
[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> 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 <timestamp> dup = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
2009 1 1 0 0 10 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
1998 12 31 23 59 50 0 <timestamp> = ] 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 <timestamp> 0 convert-timezone
2004 1 1 11 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
2004 1 1 16 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
2004 1 1 13 30 0 0 <timestamp> = ] 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 <timestamp>
2004 1 1 12 30 0 -1 <timestamp> <=> ] 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 <timestamp>
2004 1 1 12 30 0 0 <timestamp> <=> ] 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 <timestamp>
2004 1 1 13 30 0 0 <timestamp> <=> ] 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 <timestamp>
2004 1 1 13 30 0 0 <timestamp> <=> ] 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

434
extra/calendar/calendar.factor
View File

@ -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> timestamp
TUPLE: dt year month day hour minute second ;
: <date> ( year month day -- timestamp )
0 0 0 gmt-offset <timestamp> ;
C: <dt> dt
TUPLE: duration year month day hour minute second ;
C: <duration> duration
: month-names
{
@ -36,9 +37,14 @@ C: <dt> 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
<PRIVATE
SYMBOL: a
SYMBOL: b
@ -48,6 +54,8 @@ SYMBOL: e
SYMBOL: y
SYMBOL: m
PRIVATE>
: 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 ( -- <dt> ) 0 0 0 0 0 0 <dt> ;
: 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 <duration> ;
: 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 <timestamp> ;
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? ;
<PRIVATE
GENERIC: +year ( timestamp x -- timestamp )
GENERIC: +month ( timestamp x -- timestamp )
@ -116,96 +117,119 @@ GENERIC: +second ( timestamp x -- timestamp )
: /rem ( f n -- q r )
#! q is positive or negative, r is positive from 0 <= r < n
[ /f floor >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 )
<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 <duration>
] 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
<duration> ;
M: duration time-
before time+ ;
: <zero> 0 0 0 0 0 0 0 <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
clone 0 >>gmt-offset
dup <zero> time- <zero> time+ = ;
: unix-1970 ( -- timestamp )
1970 1 1 0 0 0 0 <timestamp> ;
1970 1 1 0 0 0 0 <timestamp> ; 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 <date> >r <date> 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 " " <repetition> 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
<timestamp> ;
: 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" ] }

22
extra/calendar/format/format-tests.factor Executable file
View File

@ -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

138
extra/calendar/format/format.factor Executable file
View File

@ -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 " " <repetition> 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
<timestamp> ;
: 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 ;

1
extra/calendar/format/summary.txt Normal file
View File

@ -0,0 +1 @@
Formatting dates and times

1
extra/calendar/model/summary.txt Normal file
View File

@ -0,0 +1 @@
Timestamp model updated every second

2
extra/calendar/summary.txt
View File

@ -1 +1 @@
Timestamp model updated every second
Operations on timestamps and durations

13
extra/calendar/unix/unix-tests.factor
View File

@ -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

2
extra/channels/examples/examples.factor
View File

@ -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 [ <channel> ] |
p prime to

1
extra/cocoa/plists/plists.factor
View File

@ -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 )

6
extra/combinators/lib/lib.factor
View File

@ -3,7 +3,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
arrays.lib shuffle macros bake combinators.cleave ;
arrays.lib shuffle macros bake combinators.cleave
continuations ;
IN: combinators.lib
@ -167,3 +168,6 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
: and? ( obj quot1 quot2 -- ? )
>r keep r> rot [ call ] [ 2drop f ] if ; inline
: retry ( quot n -- )
swap [ drop ] swap compose attempt-all ; inline

2
extra/concurrency/combinators/combinators-tests.factor
View File

@ -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

2
extra/concurrency/exchangers/exchangers-tests.factor
View File

@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
concurrency.count-downs concurrency.promises locals kernel
threads ;
:: exchanger-test | |
:: exchanger-test ( -- )
[let |
ex [ <exchanger> ]
c [ 2 <count-down> ]

9
extra/concurrency/flags/flags-docs.factor
View File

@ -14,6 +14,10 @@ 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." } ;
@ -21,13 +25,14 @@ HELP: lower-flag
ARTICLE: "concurrency.flags" "Flags"
"A " { $emphasis "flag" } " is a condition notification device which can be in one of two states: " { $emphasis "lowered" } " (the initial state) or " { $emphasis "raised" } "."
$nl
"The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if the flag has not been raised, it first waits for it to be raised."
"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? }
"Raising and lowering flags:"
"Waiting for a flag to be raised:"
{ $subsection raise-flag }
{ $subsection wait-for-flag }
{ $subsection lower-flag } ;
ABOUT: "concurrency.flags"

7
extra/concurrency/flags/flags.factor
View File

@ -13,9 +13,14 @@ TUPLE: flag value? thread ;
[ 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?
] [
[ flag-thread >box ] curry "flag" suspend drop
wait-for-flag
] if ;

12
extra/concurrency/locks/locks-tests.factor
View File

@ -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 <count-down> ] |
@ -27,7 +27,7 @@ threads sequences calendar ;
v
] ;
:: lock-test-1 | |
:: lock-test-1 ( -- )
[let | v [ V{ } clone ]
l [ <lock> ]
c [ 2 <count-down> ] |
@ -79,7 +79,7 @@ threads sequences calendar ;
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
:: rw-lock-test-1 | |
:: rw-lock-test-1 ( -- )
[let | l [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 1 <count-down> ]
@ -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 [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 2 <count-down> ]
@ -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 [ <lock> ] |
[
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

21
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -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> linked
: <linked-error> ( 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
[ <linked-error> ] keep
linked-thread-supervisor mailbox-put ;
: <linked-thread> ( quot name mailbox -- thread' )
>r <thread> linked-thread construct-delegate r>
over set-linked-thread-supervisor ;
: spawn-linked-to ( quot name mailbox -- thread )
[ >r <linked> r> mailbox-put ] curry <thread>
[ (spawn) ] keep ;
<linked-thread> [ (spawn) ] keep ;

2
extra/concurrency/messaging/messaging-tests.factor
View File

@ -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

2
extra/concurrency/messaging/messaging.factor
View File

@ -32,7 +32,7 @@ M: thread send ( message thread -- )
my-mailbox swap mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked> r> send ;
>r <linked-error> r> send ;
: spawn-linked ( quot name -- thread )
my-mailbox spawn-linked-to ;

4
extra/concurrency/semaphores/semaphores-docs.factor
View File

@ -9,7 +9,7 @@ HELP: <semaphore>
{ $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

2
extra/crypto/md5/md5.factor
View File

@ -33,7 +33,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+

33
extra/db/db.factor
View File

@ -5,29 +5,36 @@ namespaces sequences sequences.lib tuples words strings
tools.walker ;
IN: db
TUPLE: db handle ;
! TUPLE: db handle insert-statements update-statements delete-statements ;
TUPLE: db
handle
insert-statements
update-statements
delete-statements ;
: <db> ( handle -- obj )
! H{ } clone H{ } clone H{ } clone
H{ } clone H{ } clone H{ } clone
db construct-boa ;
GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db ) construct-empty make-db* ;
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- )
[ dispose drop ] assoc-each ;
: dispose-db ( db -- )
dup db [
! dup db-insert-statements dispose-statements
! dup db-update-statements dispose-statements
! dup db-delete-statements dispose-statements
dup db-insert-statements dispose-statements
dup db-update-statements dispose-statements
dup db-delete-statements dispose-statements
db-handle db-close
] with-variable ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
TUPLE: result-set sql params handle n max ;
: <statement> ( sql in out -- statement )
{
set-statement-sql
@ -35,17 +42,11 @@ TUPLE: statement handle sql in-params out-params bind-params bound? ;
set-statement-out-params
} statement construct ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: bind-statement* ( statement -- )
GENERIC: bind-tuple ( tuple statement -- )
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
@ -61,9 +62,8 @@ GENERIC: more-rows? ( result-set -- ? )
] if ;
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
[ set-statement-bind-params ] keep
[ bind-statement* ] keep
t swap set-statement-bound? ;
: init-result-set ( result-set -- )
@ -104,7 +104,6 @@ GENERIC: more-rows? ( result-set -- ? )
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
SYMBOL: in-transaction
HOOK: begin-transaction db ( -- )
HOOK: commit-transaction db ( -- )

5
extra/db/postgresql/postgresql.factor
View File

@ -38,10 +38,7 @@ M: postgresql-db db-open ( db -- )
M: postgresql-db dispose ( db -- )
db-handle PQfinish ;
M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-bind-params ;
M: postgresql-statement reset-statement ( statement -- )
M: postgresql-statement bind-statement* ( statement -- )
drop ;
M: postgresql-statement bind-tuple ( tuple statement -- )

55
extra/db/sqlite/sqlite.factor
View File

@ -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 combinators tools.walker ;
words combinators.lib db.types combinators tools.walker
combinators.cleave ;
IN: db.sqlite
TUPLE: sqlite-db path ;
C: <sqlite-db> 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 <db>
@ -19,9 +22,6 @@ M: sqlite-db db-close ( handle -- )
M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- )
>r <sqlite-db> r> with-db ; inline
TUPLE: sqlite-statement ;
TUPLE: sqlite-result-set has-more? ;
@ -30,14 +30,13 @@ M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle
{
set-statement-sql
set-statement-in-params
set-statement-out-params
set-statement-handle
} statement construct
dup statement-handle over statement-sql sqlite-prepare
db get db-handle over statement-sql sqlite-prepare
over set-statement-handle
sqlite-statement construct-delegate ;
M: sqlite-statement dispose ( statement -- )
@ -46,21 +45,32 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
: sqlite-bind ( specs handle -- )
break
swap [ sqlite-bind-type ] with each ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( obj 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-tuple* ( tuple statement -- )
M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
@ -80,7 +90,6 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
break
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
@ -129,7 +138,7 @@ M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ;
find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
@ -137,7 +146,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
0%
" set " 0%
dup remove-id
[ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave
[ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
where-primary-key%
] sqlite-make ;
@ -146,7 +155,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
"delete from " 0% 0%
" where " 0%
find-primary-key
sql-spec-column-name dup 0% " = " 0% bind%
dup sql-spec-column-name 0% " = " 0% bind%
] sqlite-make ;
! : select-interval ( interval name -- ) ;
@ -154,8 +163,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
M: sqlite-db bind% ( spec -- )
dup 1, sql-spec-column-name ":" swap append 0% ;
! dup 1, sql-spec-column-name
! dup 0% " = " 0% ":" swap append 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
@ -203,7 +210,3 @@ M: sqlite-db type-table ( -- assoc )
M: sqlite-db create-type-table
type-table ;
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {
! "INTEGER" get-integer-column } ... } case ;

27
extra/db/tuples/tuples-tests.factor
View File

@ -22,8 +22,9 @@ SYMBOL: the-person2
: test-tuples ( -- )
[ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test
[ person create-table ] must-fail
[ ] [ the-person1 get insert-tuple ] unit-test
[ ] [ the-person1 get insert-tuple ] unit-test
[ 1 ] [ the-person1 get person-the-id ] unit-test
@ -66,8 +67,8 @@ person "PERSON"
"billy" 10 3.14 <person> the-person1 set
"johnny" 10 3.14 <person> the-person2 set
! test-sqlite
test-postgresql
test-sqlite
! test-postgresql
person "PERSON"
{
@ -80,8 +81,8 @@ person "PERSON"
1 "billy" 10 3.14 <assigned-person> the-person1 set
2 "johnny" 10 3.14 <assigned-person> the-person2 set
! test-sqlite
test-postgresql
test-sqlite
! test-postgresql
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
@ -108,11 +109,11 @@ annotation "ANNOTATION"
{ "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
! { "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

49
extra/db/tuples/tuples.factor
View File

@ -26,14 +26,14 @@ IN: db.tuples
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
HOOK: <insert-native-statement> db ( tuple -- obj )
HOOK: <insert-assigned-statement> db ( tuple -- obj )
HOOK: <insert-native-statement> db ( class -- obj )
HOOK: <insert-assigned-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( tuple -- obj )
HOOK: <update-tuples-statement> db ( tuple -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <update-tuples-statement> db ( class -- obj )
HOOK: <delete-tuple-statement> db ( tuple -- obj )
HOOK: <delete-tuples-statement> db ( tuple -- obj )
HOOK: <delete-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( class -- obj )
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
@ -63,15 +63,27 @@ HOOK: insert-tuple* db ( tuple statement -- )
: sql-props ( class -- columns table )
dup db-columns swap db-table ;
: create-table ( class -- ) create-sql-statement execute-statement ;
: drop-table ( class -- ) drop-sql-statement execute-statement ;
: with-disposals ( seq quot -- )
over sequence? [
[ with-disposal ] curry each
] [
with-disposal
] if ;
: create-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ;
: drop-table ( class -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: insert-native ( tuple -- )
dup class <insert-native-statement>
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
: insert-assigned ( tuple -- )
dup class <insert-assigned-statement>
dup class
db get db-insert-statements [ <insert-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
@ -82,19 +94,18 @@ HOOK: insert-tuple* db ( tuple statement -- )
] if ;
: update-tuple ( tuple -- )
dup class <update-tuple-statement>
dup class
db get db-update-statements [ <update-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: update-tuples ( seq -- )
<update-tuples-statement> execute-statement ;
: delete-tuple ( tuple -- )
dup class <delete-tuple-statement>
dup class
db get db-delete-statements [ <delete-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: setup-select ( tuple -- statement )
dup dup class <select-by-slots-statement>
[ bind-tuple ] keep ;
: select-tuples ( tuple -- tuple )
dup dup class <select-by-slots-statement> [
[ bind-tuple ] keep query-tuples
] with-disposal ;
: select-tuples ( tuple -- tuple ) setup-select query-tuples ;
: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

2
extra/farkup/authors.factor Normal file
View File

@ -0,0 +1,2 @@
Doug Coleman
Slava Pestov

1
extra/farkup/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

6
extra/farkup/farkup-docs.factor Normal file
View File

@ -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." } ;

42
extra/farkup/farkup-tests.factor Normal file
View File

@ -0,0 +1,42 @@
USING: farkup kernel tools.test ;
IN: temporary
[ "<ul><li>foo</li></ul>" ] [ "-foo" parse-farkup ] unit-test
[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" parse-farkup ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" parse-farkup ] unit-test
[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" parse-farkup ] unit-test
[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" parse-farkup ] unit-test
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" parse-farkup ] unit-test
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" parse-farkup ] unit-test
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" parse-farkup ] unit-test
[ "<p>*</p>" ] [ "*" parse-farkup ] unit-test
[ "<p>*</p>" ] [ "\\*" parse-farkup ] unit-test
[ "<p>**</p>" ] [ "\\**" parse-farkup ] unit-test
[ "" ] [ "\n\n" parse-farkup ] unit-test
[ "\n" ] [ "\n\n\n" parse-farkup ] unit-test
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" parse-farkup ] unit-test
[ "\n<p>bar\n</p>" ] [ "\nbar\n" parse-farkup ] unit-test
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" parse-farkup ] unit-test
[ "" ] [ "" parse-farkup ] unit-test
[ "<p>|a</p>" ]
[ "|a" parse-farkup ] unit-test
[ "<p>|a|</p>" ]
[ "|a|" parse-farkup ] unit-test
[ "<table><tr><td>a</td><td>b</td></tr></table>" ]
[ "a|b" parse-farkup ] unit-test
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>" ]
[ "a|b\nc|d" parse-farkup ] unit-test
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>\n" ]
[ "a|b\nc|d\n" parse-farkup ] unit-test

148
extra/farkup/farkup.factor Normal file
View File

@ -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 <foo> swap </foo> 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
[ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } 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?
[ "<p>" swap "</p>" 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 ;

1
extra/farkup/summary.txt Normal file
View File

@ -0,0 +1 @@
Simple markup language for generating HTML

1
extra/farkup/tags.txt Normal file
View File

@ -0,0 +1 @@
text

11
extra/hello-world/deploy.factor
View File

@ -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 }
}

2
extra/help/cookbook/cookbook.factor
View File

@ -197,7 +197,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
{ $code
"\"data.bin\" binary [ 1024 read ] with-file-reader"
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:"
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
"\"mydata.dat\" dup file-length ["
" 4 <sliced-groups> [ reverse-here ] change-each"

16
extra/help/handbook/handbook.factor
View File

@ -171,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"
@ -198,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" }

17
extra/help/help.factor
View File

@ -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? [

14
extra/help/lint/lint-docs.factor
View File

@ -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"

51
extra/help/lint/lint.factor
View File

@ -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 [ <help-error> , ] recover ; inline
flush [ <help-error> , ] 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

9
extra/http/server/templating/templating.factor
View File

@ -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 utf8 file-contents
[ eval-template ] [ html-error. drop ] recover
] keep
! so that reload works properly
dup source-file file set
dup ?resource-path utf8 file-contents
[ eval-template ] [ html-error. drop ] recover
] with-file-vocabs
] assert-depth drop ;

5
extra/io/files/unique/backend/backend.factor Normal file
View File

@ -0,0 +1,5 @@
USING: io.backend ;
IN: io.files.unique.backend
HOOK: (make-unique-file) io-backend ( prefix suffix -- stream path )
HOOK: temporary-path io-backend ( -- path )

50
extra/io/files/unique/unique-docs.factor Normal file
View File

@ -0,0 +1,50 @@
USING: help.markup help.syntax io io.nonblocking kernel math
io.files.unique.private math.parser io.files ;
IN: io.files.unique
ARTICLE: "unique" "Making and using unique files"
"Files:"
{ $subsection make-unique-file }
{ $subsection with-unique-file }
{ $subsection with-temporary-file }
"Directories:"
{ $subsection make-unique-directory }
{ $subsection with-unique-directory }
{ $subsection with-temporary-directory } ;
ABOUT: "unique"
HELP: make-unique-file ( prefix suffix -- path stream )
{ $values { "prefix" "a string" } { "suffix" "a string" }
{ "path" "a pathname string" } { "stream" "an output stream" } }
{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname and a " { $link <writer> } " stream." }
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-file } ;
HELP: make-unique-directory ( -- path )
{ $values { "path" "a pathname string" } }
{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-directory } ;
HELP: with-unique-file ( quot -- path )
{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. Returns the full pathname after the stream has been closed." }
{ $notes "The unique file will remain after calling this word." }
{ $see-also with-temporary-file } ;
HELP: with-unique-directory ( quot -- path )
{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. Returns the full pathname after the quotation has been called." }
{ $notes "The directory will remain after calling this word." }
{ $see-also with-temporary-directory } ;
HELP: with-temporary-file ( quot -- )
{ $values { "quot" "a quotation" } }
{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. The file is deleted after the quotation returns." }
{ $see-also with-unique-file } ;
HELP: with-temporary-directory ( quot -- )
{ $values { "quot" "a quotation" } }
{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. The directory is deleted after the quotation returns." }
{ $see-also with-unique-directory } ;

48
extra/io/files/unique/unique.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitfields combinators.lib math.parser
random sequences sequences.lib continuations namespaces
io.files io.backend io.nonblocking io arrays
io.files.unique.backend system combinators vocabs.loader ;
IN: io.files.unique
<PRIVATE
: random-letter ( -- ch )
26 random { CHAR: a CHAR: A } random + ;
: random-ch ( -- ch )
{ t f } random
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string )
[ drop random-ch ] "" map-as ;
: unique-length ( -- n ) 10 ; inline
: unique-retries ( -- n ) 10 ; inline
PRIVATE>
: make-unique-file ( prefix suffix -- path stream )
temporary-path -rot
[
unique-length random-name swap 3append path+
dup (make-unique-file)
] 3curry unique-retries retry ;
: with-unique-file ( quot -- path )
>r f f make-unique-file r> with-stream ; inline
: with-temporary-file ( quot -- )
with-unique-file delete-file ; inline
: make-unique-directory ( -- path )
[
temporary-path unique-length random-name path+
dup make-directory
] unique-retries retry ;
: with-unique-directory ( quot -- path )
>r make-unique-directory r>
[ with-directory ] curry keep ; inline
: with-temporary-directory ( quot -- )
with-unique-directory delete-tree ; inline

2
extra/io/launcher/launcher-docs.factor
View File

@ -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." } ;

2
extra/io/launcher/summary.txt
View File

@ -1 +1 @@
Support for launching OS processes
Launching operating system processes

17
extra/io/monitors/monitors.factor
View File

@ -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
<PRIVATE
@ -32,7 +32,11 @@ M: monitor dispose
! Simple monitor; used on Linux and Mac OS X. On Windows,
! monitors are full-fledged ports.
TUPLE: simple-monitor handle callback ;
TUPLE: simple-monitor handle callback timeout ;
M: simple-monitor timeout simple-monitor-timeout ;
M: simple-monitor set-timeout set-simple-monitor-timeout ;
: <simple-monitor> ( handle -- simple-monitor )
f (monitor) <box> {
@ -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 -- )

22
extra/io/paths/paths.factor
View File

@ -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 <directory-iterator> r> [ keep and ] curry ; inline
: find-file ( path bfs? quot -- path/f )
prepare-find-file iterate-directory ;
>r <directory-iterator> r>
[ keep and ] curry iterate-directory ; inline
: each-file ( path bfs? quot -- )
>r <directory-iterator> 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 <directory-iterator> r>
pusher >r iterate-directory drop r> ; inline
: recursive-directory ( path bfs? -- paths )
<directory-iterator>
[ dup next-file dup ] [ ] [ drop ] unfold nip ;
[ ] accumulator >r each-file r> ;

1
extra/io/server/summary.txt Normal file
View File

@ -0,0 +1 @@
TCP/IP and UDP/IP servers

1
extra/io/timeouts/summary.txt Normal file
View File

@ -0,0 +1 @@
Low-level support for setting timeouts on I/O operations

4
extra/io/timeouts/timeouts-docs.factor
View File

@ -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

47
extra/io/unix/files/files.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.nonblocking io.unix.backend io.files io
unix kernel math continuations math.bitfields byte-arrays
alien ;
unix unix.stat kernel math continuations math.bitfields byte-arrays
alien combinators combinators.cleave calendar ;
IN: io.unix.files
M: unix-io cwd
@ -37,7 +38,15 @@ M: unix-io (file-writer) ( path -- stream )
M: unix-io (file-appender) ( path -- stream )
open-append <writer> ;
M: unix-io rename-file ( from to -- )
: touch-mode
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
M: unix-io touch-file ( path -- )
touch-mode file-mode open
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
close ;
M: unix-io move-file ( from to -- )
rename io-error ;
M: unix-io delete-file ( path -- )
@ -48,3 +57,35 @@ M: unix-io make-directory ( path -- )
M: unix-io delete-directory ( path -- )
rmdir io-error ;
: (copy-file) ( from to -- )
dup parent-directory make-directories
<file-writer> [
swap <file-reader> [
swap stream-copy
] with-disposal
] with-disposal ;
M: unix-io copy-file ( from to -- )
>r dup file-permissions over r> (copy-file) chmod io-error ;
: stat>type ( stat -- type )
stat-st_mode {
{ [ dup S_ISREG ] [ +regular-file+ ] }
{ [ dup S_ISDIR ] [ +directory+ ] }
{ [ dup S_ISCHR ] [ +character-device+ ] }
{ [ dup S_ISBLK ] [ +block-device+ ] }
{ [ dup S_ISFIFO ] [ +fifo+ ] }
{ [ dup S_ISLNK ] [ +symbolic-link+ ] }
{ [ dup S_ISSOCK ] [ +socket+ ] }
{ [ t ] [ +unknown+ ] }
} cond nip ;
M: unix-io file-info ( path -- info )
stat* {
[ stat>type ]
[ stat-st_size ]
[ stat-st_mode ]
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
} cleave
\ file-info construct-boa ;

12
extra/io/unix/files/unique/unique.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel io.nonblocking io.unix.backend math.bitfields
unix io.files.unique.backend ;
IN: io.unix.files.unique
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
M: unix-io (make-unique-file) ( path -- duplex-stream )
open-unique-flags file-mode open dup io-error
<writer> ;
M: unix-io temporary-path ( -- path ) "/tmp" ;

17
extra/io/unix/linux/linux.factor
View File

@ -22,10 +22,12 @@ TUPLE: inotify watches ;
: wd>monitor ( wd -- monitor ) watches at ;
: <inotify> ( -- port )
: <inotify> ( -- port/f )
H{ } clone
inotify_init dup io-error inotify <buffered-port>
{ set-inotify-watches set-delegate } inotify construct ;
inotify_init dup 0 < [ 2drop f ] [
inotify <buffered-port>
{ 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 <monitor> ( 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 <input-task> ;
: init-inotify ( mx -- )
<inotify>
dup inotify set-global
<inotify> dup inotify set-global
<inotify-task> swap register-io-task ;
M: inotify-task do-io-task ( task -- )

4
extra/io/unix/unix.factor
View File

@ -1,6 +1,6 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader sequences ;
io.unix.launcher io.unix.mmap io.backend io.files.unique
combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require

8
extra/io/windows/files/unique/unique.factor Normal file
View File

@ -0,0 +1,8 @@
USING: kernel system ;
IN: io.windows.files.unique
M: windows-io (make-unique-file) ( path -- stream )
GENERIC_WRITE CREATE_NEW 0 open-file 0 <writer> ;
M: windows-io temporary-path ( -- path )
"TEMP" os-env ;

Some files were not shown because too many files have changed in this diff Show More