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

Fix conflict

db4
Slava Pestov 2008-02-28 03:28:26 -06:00
parent a2aa718cd4 e79772fce4
commit 5e3aa52a75
210 changed files with 3611 additions and 1809 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -145,7 +145,8 @@ wince-arm:
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
install_name_tool \

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

4
core/compiler/tests/curry.factor
View File

@ -1,5 +1,5 @@
USING: tools.test compiler quotations math kernel sequences
assocs namespaces ;
USING: tools.test quotations math kernel sequences
assocs namespaces compiler.units ;
IN: temporary
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test

2
core/compiler/tests/float.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: compiler kernel kernel.private memory math
USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test

13
core/compiler/tests/intrinsics.factor
View File

@ -1,10 +1,11 @@
IN: temporary
USING: arrays compiler kernel kernel.private math math.constants
math.private sequences strings tools.test words continuations
sequences.private hashtables.private byte-arrays strings.private
system random layouts vectors.private sbufs.private
strings.private slots.private alien alien.accessors
alien.c-types alien.syntax namespaces libc sequences.private ;
USING: arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien
alien.accessors alien.c-types alien.syntax namespaces libc
sequences.private ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test

2
core/compiler/tests/simple.factor
View File

@ -1,4 +1,4 @@
USING: compiler tools.test kernel kernel.private
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory ;
IN: temporary

2
core/compiler/tests/tuples.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: kernel tools.test compiler ;
USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ;

9
core/compiler/units/units.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words
vocabs definitions hashtables ;
vocabs definitions hashtables init ;
IN: compiler.units
SYMBOL: old-definitions
@ -37,12 +37,13 @@ SYMBOL: recompile-hook
SYMBOL: definition-observers
definition-observers global [ V{ } like ] change-at
GENERIC: definitions-changed ( assoc obj -- )
[ V{ } clone definition-observers set-global ]
"compiler.units" add-init-hook
: add-definition-observer ( obj -- )
definition-observers get push-new ;
definition-observers get push ;
: remove-definition-observer ( obj -- )
definition-observers get delete ;

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

2
core/inference/state/state-tests.factor
View File

@ -1,5 +1,5 @@
IN: temporary
USING: tools.test inference.state ;
USING: tools.test inference.state words ;
SYMBOL: a
SYMBOL: b

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,41 +1,116 @@
USING: help.markup help.syntax io io.styles strings
io.backend io.files.private ;
io.backend io.files.private quotations ;
IN: io.files
ARTICLE: "file-streams" "Reading and writing files"
"File streams:"
{ $subsection <file-reader> }
{ $subsection <file-writer> }
{ $subsection <file-appender> }
"Utility combinators:"
{ $subsection with-file-reader }
{ $subsection with-file-writer }
{ $subsection with-file-appender } ;
ARTICLE: "pathnames" "Pathname manipulation"
"Pathname manipulation:"
{ $subsection parent-directory }
{ $subsection file-name }
{ $subsection last-path-separator }
{ $subsection path+ }
"File system meta-data:"
"Pathnames relative to Factor's install directory:"
{ $subsection resource-path }
{ $subsection ?resource-path }
"Pathnames relative to Factor's temporary files directory:"
{ $subsection temp-directory }
{ $subsection temp-file }
"Pathname presentations:"
{ $subsection pathname }
{ $subsection <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" }
{ $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" } { "stream" "an input stream" } }
@ -77,7 +152,12 @@ HELP: cd
{ $description "Changes the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
{ cd cwd } related-words
{ cd cwd with-directory } related-words
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Changes the current working directory for the duration of a quotation's execution." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
HELP: stat ( path -- directory? permissions length modified )
{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } }
@ -108,6 +188,11 @@ HELP: directory
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
HELP: directory*
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ path dir? }" } " pairs" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
HELP: file-length
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
@ -116,19 +201,6 @@ HELP: file-modified
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
HELP: parent-directory
{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
{ $description "Strips the last component off a pathname." }
{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
HELP: file-name
{ $values { "path" "a pathname string" } { "string" string } }
{ $description "Outputs the last component of a pathname string." }
{ $examples
{ "\"/usr/bin/gcc\" file-name ." "\"gcc\"" }
{ "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
} ;
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
@ -168,7 +240,72 @@ HELP: make-directory
{ $description "Creates a directory." }
{ $errors "Throws an error if the directory could not be created." } ;
HELP: make-directories
{ $values { "path" "a pathname string" } }
{ $description "Creates a directory and any parent directories which do not yet exist." }
{ $errors "Throws an error if the directories could not be created." } ;
HELP: delete-directory
{ $values { "path" "a pathname string" } }
{ $description "Deletes a directory. The directory must be empty." }
{ $errors "Throws an error if the directory could not be deleted." } ;
HELP: touch-file
{ $values { "path" "a pathname string" } }
{ $description "Updates the modification time of a file or directory. If the file does not exist, creates a new, empty file." }
{ $errors "Throws an error if the file could not be touched." } ;
HELP: delete-tree
{ $values { "path" "a pathname string" } }
{ $description "Deletes a file or directory, recursing into subdirectories." }
{ $errors "Throws an error if the deletion fails." }
{ $warning "Misuse of this word can lead to catastrophic data loss." } ;
HELP: move-file
{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
{ $description "Moves or renames a file." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: move-file-to
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Moves a file to another directory without renaming it." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: move-files-to
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Moves a set of files to another directory." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: copy-file
{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
{ $description "Copies a file." }
{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-file-to
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a file to another directory." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-files-to
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of files to another directory." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-tree
{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
{ $description "Copies a directory tree recursively." }
{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." }
{ $errors "Throws an error if the copy operation fails." } ;
HELP: copy-tree-to
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a directory tree to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ;
HELP: copy-trees-to
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of directory trees to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ;

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

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

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

@ -5,30 +5,9 @@ USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations ;
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
HOOK: <file-reader> io-backend ( path -- stream )
HOOK: <file-writer> io-backend ( path -- stream )
HOOK: <file-appender> io-backend ( path -- stream )
HOOK: delete-file io-backend ( path -- )
HOOK: rename-file io-backend ( from to -- )
HOOK: make-directory io-backend ( path -- )
HOOK: delete-directory io-backend ( path -- )
! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
HOOK: root-directory? io-backend ( path -- ? )
M: object root-directory? ( path -- ? ) path-separator? ;
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
@ -39,33 +18,15 @@ M: object root-directory? ( path -- ? ) path-separator? ;
>r right-trim-separators "/" r>
left-trim-separators 3append ;
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
: file-length ( path -- n ) stat 4array third ;
: file-modified ( path -- n ) stat >r 3drop r> ; inline
: exists? ( path -- ? ) file-modified >boolean ;
: directory? ( path -- ? ) stat 3drop ;
: special-directory? ( name -- ? )
{ "." ".." } member? ;
: fixup-directory ( path seq -- newseq )
[
dup string?
[ tuck path+ directory? 2array ] [ nip ] if
] with map
[ first special-directory? not ] subset ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last* ;
HOOK: root-directory? io-backend ( path -- ? )
M: object root-directory? ( path -- ? ) path-separator? ;
: special-directory? ( name -- ? ) { "." ".." } member? ;
TUPLE: no-parent-directory path ;
: no-parent-directory ( path -- * )
@ -89,15 +50,30 @@ TUPLE: no-parent-directory path ;
{ [ t ] [ drop ] }
} cond ;
: resource-path ( path -- newpath )
\ resource-path get [ image parent-directory ] unless*
swap path+ ;
! File metadata
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
: ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ;
: file-length ( path -- n ) stat drop 2nip ;
: resource-exists? ( path -- ? )
?resource-path exists? ;
: file-modified ( path -- n ) stat >r 3drop r> ;
: file-permissions ( path -- perm ) stat 2drop nip ;
: exists? ( path -- ? ) file-modified >boolean ;
: directory? ( path -- ? ) stat 3drop ;
! Current working directory
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
: with-directory ( path quot -- )
swap cd cwd [ cd ] curry [ ] cleanup ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
normalize-pathname right-trim-separators {
@ -111,35 +87,107 @@ TUPLE: no-parent-directory path ;
] }
} cond drop ;
! Directory listings
: fixup-directory ( path seq -- newseq )
[
dup string?
[ tuck path+ directory? 2array ] [ nip ] if
] with map
[ first special-directory? not ] subset ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;
: directory* ( path -- seq )
dup directory [ first2 >r path+ r> 2array ] with map ;
! Touching files
HOOK: touch-file io-backend ( path -- )
! Deleting files
HOOK: delete-file io-backend ( path -- )
HOOK: delete-directory io-backend ( path -- )
: (delete-tree) ( path dir? -- )
[
dup directory* [ (delete-tree) ] assoc-each
delete-directory
] [ delete-file ] if ;
: delete-tree ( path -- )
dup directory? (delete-tree) ;
: to-directory over file-name path+ ;
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )
: move-file-to ( from to -- )
to-directory move-file ;
: move-files-to ( files to -- )
[ move-file-to ] curry each ;
! Copying files
HOOK: copy-file io-backend ( from to -- )
M: object copy-file
dup parent-directory make-directories
<file-writer> [
swap <file-reader> [
swap stream-copy
] with-disposal
] with-disposal ;
: copy-file-to ( from to -- )
to-directory copy-file ;
: copy-directory ( from to -- )
dup make-directories
>r dup directory swap r> [
>r >r first r> over path+ r> rot path+ copy-file
] 2curry each ;
: copy-files-to ( files to -- )
[ copy-file-to ] curry each ;
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
} cond ;
DEFER: copy-tree-to
: copy-tree ( from to -- )
over directory? [
>r dup directory swap r> [
>r swap first path+ r> copy-tree-to
] 2curry each
] [
copy-file
] if ;
: copy-tree-to ( from to -- )
to-directory copy-tree ;
: copy-trees-to ( files to -- )
[ copy-tree-to ] curry each ;
! Special paths
: resource-path ( path -- newpath )
\ resource-path get [ image parent-directory ] unless*
swap path+ ;
: ?resource-path ( path -- newpath )
"resource:" ?head [ resource-path ] when ;
: resource-exists? ( path -- ? )
?resource-path exists? ;
: temp-directory ( -- path )
"temp" resource-path
dup exists? not
[ dup make-directory ]
when ;
: temp-file ( name -- path ) temp-directory swap path+ ;
! Pathname presentations
TUPLE: pathname string ;
C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
! Streams
HOOK: <file-reader> io-backend ( path -- stream )
HOOK: <file-writer> io-backend ( path -- stream )
HOOK: <file-appender> io-backend ( path -- stream )
: file-lines ( path -- seq ) <file-reader> lines ;
: file-contents ( path -- str )
@ -155,10 +203,10 @@ M: pathname <=> [ pathname-string ] compare ;
: with-file-appender ( path quot -- )
>r <file-appender> r> with-stream ; inline
: temp-directory ( -- path )
"temp" resource-path
dup exists? not
[ dup make-directory ]
when ;
: temp-file ( name -- path ) temp-directory swap path+ ;
! Home directory
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
} cond ;

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 io.streams.lines
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles io.streams.lines
io.streams.duplex vectors words generic system combinators
tuples continuations debugger definitions compiler.units ;
IN: listener
@ -62,11 +62,7 @@ M: duplex-stream stream-read-quot
[ quit-flag off ]
[ listen until-quit ] if ; inline
: print-banner ( -- )
"Factor " write version write
" on " write os write "/" write cpu print ;
: listener ( -- )
print-banner [ until-quit ] with-interactive-vocabs ;
[ until-quit ] with-interactive-vocabs ;
MAIN: listener

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

2
core/optimizer/optimizer-tests.factor
View File

@ -1,4 +1,4 @@
USING: arrays compiler generic hashtables inference kernel
USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private

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

6
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" ;
@ -468,7 +470,7 @@ SYMBOL: interactive-vocabs
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2 diff
[ nip define-symbol ] assoc-each ;
[ nip dup reset-generic define-symbol ] assoc-each ;
: forget-smudged ( -- )
smudged-usage forget-all
@ -507,7 +509,7 @@ SYMBOL: interactive-vocabs
] recover ;
: run-file ( file -- )
[ [ parse-file call ] keep ] assert-depth drop ;
[ dup parse-file call ] assert-depth drop ;
: ?run-file ( path -- )
dup resource-exists? [ run-file ] [ drop ] if ;

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"

65
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
@ -86,6 +84,13 @@ PRIVATE>
f over set-thread-state
check-registered 2array run-queue push-front ;
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] }
} cond ;
<PRIVATE
: schedule-sleep ( thread ms -- )
@ -106,23 +111,27 @@ PRIVATE>
[ ] while
drop ;
: next ( -- )
: next ( -- * )
expire-sleep-loop
run-queue pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with ;
run-queue dup dlist-empty? [
! We should never be in a state where the only threads
! are sleeping; the I/O wait thread is always runnable.
! However, if it dies, we handle this case
! semi-gracefully.
!
! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF.
drop sleep-time [ die 0 ] unless* (sleep) next
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with
] if ;
PRIVATE>
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] }
} cond ;
: stop ( -- )
self dup thread-exit-handler call
unregister-thread next ;
@ -168,20 +177,8 @@ M: real sleep
] 1 (throw)
] "spawn" suspend 2drop ;
: default-thread-error-handler ( error thread -- )
global [
"Error in thread " write
dup thread-id pprint
" (" write
dup thread-name pprint ")" print
"spawned to call " write
thread-quot short.
nl
print-error flush
] bind ;
: spawn ( quot name -- thread )
[ default-thread-error-handler ] <thread> [ (spawn) ] keep ;
<thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
>r [ [ ] [ ] while ] curry r> spawn ;
@ -191,6 +188,8 @@ M: real sleep
[ >r set-namestack set-datastack r> call ] 3curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
<PRIVATE
: init-threads ( -- )
@ -198,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>

41
core/vocabs/loader/loader.factor
View File

@ -153,16 +153,18 @@ SYMBOL: load-help?
[ load-error. nl ] each ;
SYMBOL: blacklist
SYMBOL: failures
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
V{ } clone failures set
[
[ require ]
[ >r vocab-name r> 2array blacklist get push ]
[ swap vocab-name failures get set-at ]
recover
] each
blacklist get
failures get
] with-compiler-errors ;
: do-refresh ( modified-sources modified-docs -- )
@ -176,12 +178,17 @@ SYMBOL: blacklist
: refresh-all ( -- ) "" refresh ;
GENERIC: (load-vocab) ( name -- vocab )
!
: add-to-blacklist ( error vocab -- )
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
M: vocab (load-vocab)
dup vocab-root [
dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
] when ;
[
dup vocab-root [
dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
] when
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ;
@ -189,24 +196,14 @@ M: string (load-vocab)
M: vocab-link (load-vocab)
vocab-name (load-vocab) ;
TUPLE: blacklisted-vocab name ;
: blacklisted-vocab ( name -- * )
\ blacklisted-vocab construct-boa throw ;
M: blacklisted-vocab error.
"This vocabulary depends on the " write
blacklisted-vocab-name write
" vocabulary which failed to load" print ;
[
dup vocab-name blacklist get key? [
vocab-name blacklisted-vocab
dup vocab-name blacklist get at* [
rethrow
] [
[
dup vocab [ ] [ ] ?if (load-vocab)
] with-compiler-errors
drop
[ dup vocab swap or (load-vocab) ] with-compiler-errors
] if
] load-vocab-hook set-global
: vocab-where ( vocab -- loc )

8
core/words/words-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations tuples compiler.units ;
vocabs continuations tuples compiler.units io.streams.string ;
IN: temporary
[ 4 ] [
@ -156,11 +156,13 @@ SYMBOL: quot-uses-b
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
[ ] [
"IN: temporary GENERIC: symbol-generic" eval
"IN: temporary GENERIC: symbol-generic" <string-reader>
"symbol-generic-test" parse-stream drop
] unit-test
[ ] [
"IN: temporary TUPLE: symbol-generic ;" eval
"IN: temporary TUPLE: symbol-generic ;" <string-reader>
"symbol-generic-test" parse-stream drop
] unit-test
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test

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 ;
USING: io io.files math math.parser kernel prettyprint
benchmark.random ;
IN: benchmark.sum-file
: sum-file-loop ( n -- n' )
@ -8,6 +9,6 @@ IN: benchmark.sum-file
[ 0 sum-file-loop ] with-file-reader . ;
: sum-file-main ( -- )
home "sum-file-in.txt" path+ sum-file ;
random-numbers-path sum-file ;
MAIN: sum-file-main

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

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

30
extra/builder/builder.factor
View File

@ -65,15 +65,8 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: factor-binary ( -- name )
os
{ { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
{ "winnt" [ "./factor-nt.exe" ] }
[ drop "./factor" ] }
case ;
: bootstrap-cmd ( -- cmd )
{ factor-binary { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
: bootstrap ( -- desc )
<process*>
@ -85,7 +78,7 @@ IN: builder
>desc ;
: builder-test-cmd ( -- cmd )
{ factor-binary "-run=builder.test" } to-strings ;
{ "./factor" "-run=builder.test" } to-strings ;
: builder-test ( -- desc )
<process*>
@ -147,7 +140,11 @@ SYMBOL: build-status
show-benchmark-deltas
"../benchmarks" "../../benchmarks" copy-file
"../benchmarks" "../../benchmarks" copy-file
".." cd
maybe-release
] with-file-writer
@ -168,7 +165,7 @@ SYMBOL: builder-recipients
builder-from get >>from
builder-recipients get >>to
subject >>subject
"../report" file>string >>body
"./report" file>string >>body
send ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -177,11 +174,11 @@ SYMBOL: builder-recipients
{ "bzip2" my-boot-image-name } to-strings run-process drop ;
: build ( -- )
[ (build) ] [ drop ] recover
maybe-release
[ (build) ] failsafe
builds cd stamp> cd
[ send-builder-email ] [ drop "not sending mail" . ] recover
".." cd { "rm" "-rf" "factor" } run-process drop
[ compress-image ] [ drop ] recover ;
{ "rm" "-rf" "factor" } run-process drop
[ compress-image ] failsafe ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -216,8 +213,7 @@ USE: bootstrap.image.download
[ build ]
when
]
[ drop ]
recover
failsafe
5 minutes sleep
build-loop ;

10
extra/builder/release/release.factor
View File

@ -64,6 +64,8 @@ USING: system sequences splitting ;
: linux-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
@ -78,6 +80,8 @@ USING: system sequences splitting ;
: windows-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
@ -92,6 +96,8 @@ USING: system sequences splitting ;
: macosx-release ( -- )
"factor" cd
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
@ -120,8 +126,8 @@ USING: system sequences splitting ;
: release? ( -- ? )
{
"../load-everything-vocabs"
"../test-all-vocabs"
"./load-everything-vocabs"
"./test-all-vocabs"
}
[ eval-file empty? ]
all? ;

8
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
@ -104,4 +104,8 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
USE: prettyprint
: to-file ( object file -- ) [ . ] with-file-writer ;
: to-file ( object file -- ) [ . ] with-file-writer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: failsafe ( quot -- ) [ drop ] recover ;

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

3
extra/cocoa/cocoa-tests.factor
View File

@ -1,6 +1,7 @@
IN: temporary
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory ;
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units ;
CLASS: {
{ +superclass+ "NSObject" }

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 )

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/conditions/conditions.factor
View File

@ -8,7 +8,7 @@ IN: concurrency.conditions
dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-all ( dlist -- )
[ resume-now ] dlist-slurp yield ;
[ resume-now ] dlist-slurp ;
: queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the

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

38
extra/concurrency/flags/flags-docs.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: concurrency.flags
HELP: flag
{ $class-description "A flag allows one thread to notify another when a condition is satisfied." } ;
HELP: <flag>
{ $values { "flag" flag } }
{ $description "Creates a new flag." } ;
HELP: raise-flag
{ $values { "flag" flag } }
{ $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ;
HELP: wait-for-flag
{ $values { "flag" flag } }
{ $description "Waits for a flag to be raised. If the flag has already been raised, returns immediately." } ;
HELP: lower-flag
{ $values { "flag" flag } }
{ $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ;
ARTICLE: "concurrency.flags" "Flags"
"A " { $emphasis "flag" } " is a condition notification device which can be in one of two states: " { $emphasis "lowered" } " (the initial state) or " { $emphasis "raised" } "."
$nl
"The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if it has not been raised yet will wait for another thread to raise the flag."
$nl
"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
{ $subsection flag }
{ $subsection flag? }
"Waiting for a flag to be raised:"
{ $subsection raise-flag }
{ $subsection wait-for-flag }
{ $subsection lower-flag } ;
ABOUT: "concurrency.flags"

26
extra/concurrency/flags/flags.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: boxes kernel threads ;
IN: concurrency.flags
TUPLE: flag value? thread ;
: <flag> ( -- flag ) f <box> flag construct-boa ;
: raise-flag ( flag -- )
dup flag-value? [
dup flag-thread ?box
[ resume ] [ drop t over set-flag-value? ] if
] unless drop ;
: wait-for-flag ( flag -- )
dup flag-value? [ drop ] [
[ flag-thread >box ] curry "flag" suspend drop
] if ;
: lower-flag ( flag -- )
dup flag-value? [
f swap set-flag-value?
] [
wait-for-flag
] if ;

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

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

@ -15,7 +15,7 @@ TUPLE: mailbox threads data ;
: mailbox-put ( obj mailbox -- )
[ mailbox-data push-front ] keep
mailbox-threads notify-all ;
mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
@ -65,12 +65,23 @@ TUPLE: mailbox threads data ;
: mailbox-get? ( pred mailbox -- obj )
f mailbox-get-timeout? ; inline
TUPLE: linked error thread ;
TUPLE: linked-error thread ;
C: <linked> 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

@ -32,7 +32,7 @@ SYMBOL: old-d
old-c c update-old-new
old-d d update-old-new ;
:: (ABCD) | x s i k func a b c d |
:: (ABCD) ( x s i k func a b c d -- )
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
a [
b get c get d get func call w+

65
extra/db/db.factor
View File

@ -1,16 +1,24 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words strings ;
namespaces sequences sequences.lib tuples words strings
tools.walker ;
IN: db
TUPLE: db handle insert-statements update-statements delete-statements ;
TUPLE: db
handle
insert-statements
update-statements
delete-statements ;
: <db> ( handle -- obj )
H{ } clone H{ } clone H{ } clone
db construct-boa ;
GENERIC: make-db* ( seq class -- db )
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- )
[ dispose drop ] assoc-each ;
@ -23,18 +31,22 @@ HOOK: db-close db ( handle -- )
db-handle db-close
] with-variable ;
TUPLE: statement sql params handle bound? slot-names ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
HOOK: <simple-statement> db ( str -- statement )
HOOK: <prepared-statement> db ( str -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: insert-statement ( statement -- id )
TUPLE: result-set sql params handle n max ;
: <statement> ( sql in out -- statement )
{
set-statement-sql
set-statement-in-params
set-statement-out-params
} statement construct ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( statement -- )
GENERIC: bind-tuple ( tuple statement -- )
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
@ -42,12 +54,16 @@ GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
: execute-statement ( statement -- ) query-results dispose ;
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
query-results dispose
] if ;
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
[ set-statement-params ] keep
[ set-statement-bind-params ] keep
[ bind-statement* ] keep
t swap set-statement-bound? ;
: init-result-set ( result-set -- )
@ -55,7 +71,7 @@ GENERIC: more-rows? ( result-set -- ? )
0 swap set-result-set-n ;
: <result-set> ( query handle tuple -- result-set )
>r >r { statement-sql statement-params } get-slots r>
>r >r { statement-sql statement-in-params } get-slots r>
{
set-result-set-sql
set-result-set-params
@ -75,22 +91,19 @@ GENERIC: more-rows? ( result-set -- ? )
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
: with-db ( db quot -- )
[
over db-open
[ db swap with-variable ] curry with-disposal
] with-scope ;
: with-db ( db seq quot -- )
>r make-db dup db-open db r>
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: do-query ( query -- result-set )
: default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
: do-bound-query ( obj query -- rows )
[ bind-statement ] keep do-query ;
[ bind-statement ] keep default-query ;
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
SYMBOL: in-transaction
HOOK: begin-transaction db ( -- )
HOOK: commit-transaction db ( -- )
@ -105,11 +118,11 @@ HOOK: rollback-transaction db ( -- )
] with-variable ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
f f <simple-statement> [ default-query ] with-disposal ;
: sql-command ( sql -- )
dup string? [
<simple-statement> [ execute-statement ] with-disposal
f f <simple-statement> [ execute-statement ] with-disposal
] [
! [
[ sql-command ] each

18
extra/db/postgresql/lib/lib.factor Normal file → Executable file
View File

@ -2,21 +2,25 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types ;
db.types tools.walker ascii splitting ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
dup zero? [
drop f
] [
PQresultErrorMessage [ CHAR: \n = ] right-trim
PQresultErrorMessage [ blank? ] trim
] if ;
: postgres-result-error ( res -- )
postgresql-result-error-message [ throw ] when* ;
: (postgresql-error-message) ( handle -- str )
PQerrorMessage
"\n" split [ [ blank? ] trim ] map "\n" join ;
: postgresql-error-message ( -- str )
db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
db get db-handle (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
@ -27,7 +31,7 @@ IN: db.postgresql.lib
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
PQsetdbLogin
dup PQstatus zero? [ postgresql-error-message throw ] unless ;
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res )
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
@ -37,9 +41,9 @@ IN: db.postgresql.lib
: do-postgresql-bound-statement ( statement -- res )
>r db get db-handle r>
[ statement-sql ] keep
[ statement-params length f ] keep
statement-params
[ first number>string* malloc-char-string ] map >c-void*-array
[ statement-bind-params length f ] keep
statement-bind-params
[ number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw

254
extra/db/postgresql/postgresql-tests.factor Normal file → Executable file
View File

@ -1,13 +1,14 @@
! You will need to run 'createdb factor-test' to create the database.
! Set username and password in the 'connect' word.
USING: kernel db.postgresql alien continuations io prettyprint
sequences namespaces tools.test db db.types ;
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db
db.tuples db.types unicode.case ;
IN: temporary
IN: scratchpad
: test-db ( -- postgresql-db )
"localhost" "postgres" "" "factor-test" <postgresql-db> ;
{ "localhost" "postgres" "" "factor-test" } postgresql-db ;
IN: temporary
[ ] [ test-db [ ] with-db ] unit-test
@ -39,7 +40,7 @@ IN: temporary
] [
test-db [
"select * from person where name = $1 and country = $2"
<simple-statement> [
f f <simple-statement> [
{ { "Jane" TEXT } { "New Zealand" TEXT } }
over do-bound-query
@ -108,3 +109,248 @@ IN: temporary
"select * from person" sql-query length
] with-db
] unit-test
: with-dummy-db ( quot -- )
>r T{ postgresql-db } db r> with-variable ;
! TEST TUPLE DB
TUPLE: puppy id name age ;
: <puppy> ( name age -- puppy )
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
{ "id" "ID" +native-id+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: kitty id name age ;
: <kitty> ( name age -- kitty )
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
{ "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id serial primary key not null, name varchar 256, age integer);"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
[
"create table basket(id serial primary key not null, location text);"
] [
T{ postgresql-db } db [
basket dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
! Create function
[
"create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table create-function-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ postgresql-db } db [
puppy db-table drop-table-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ postgresql-db } db [
kitty db-table drop-table-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ postgresql-db } db [
basket db-table drop-table-sql >lower
] with-variable
] unit-test
! Drop function
[
"drop function add_puppy(varchar, integer);"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table drop-function-sql >lower
] with-variable
] unit-test
! Insert
[
] [
T{ postgresql-db } db [
puppy <insert-native-statement>
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values($1, $2, $3);"
{
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
T{ sql-spec f "name" "NAME" TEXT { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
{ }
] [
T{ postgresql-db } db [
kitty <insert-assigned-statement>
] with-variable
] unit-test
! Update
[
"update puppy set name = $1, age = $2 where id = $3"
{
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
}
{ }
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
[
"update kitty set name = $1, age = $2 where id = $3"
{
T{ sql-spec f "name" "NAME" TEXT { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
}
{ }
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = $1"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
}
{ }
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table <delete-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
[
"delete from KITTY where ID = $1"
{
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
}
{ }
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table <delete-tuple-statement>
] with-variable
] unit-test
! Select
[
"select from PUPPY ID, NAME, AGE where NAME = $1;"
{ T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } }
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ postgresql-db } db [
T{ puppy f f "Mr. Clunkers" }
<select-by-slots-statement>
] with-variable
] unit-test

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

@ -4,25 +4,28 @@ USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators ;
combinators sequences.lib classes locals words tools.walker ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
TUPLE: postgresql-result-set ;
: <postgresql-statement> ( statement -- postgresql-statement )
: <postgresql-statement> ( statement in out -- postgresql-statement )
<statement>
postgresql-statement construct-delegate ;
: <postgresql-db> ( host user pass db -- obj )
{
set-postgresql-db-host
set-postgresql-db-user
set-postgresql-db-pass
set-postgresql-db-db
} postgresql-db construct ;
M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r> [
{
set-postgresql-db-host
set-postgresql-db-user
set-postgresql-db-pass
set-postgresql-db-db
} set-slots
] keep ;
M: postgresql-db db-open ( db -- )
dup {
dup {
postgresql-db-host
postgresql-db-port
postgresql-db-pgopts
@ -35,15 +38,15 @@ M: postgresql-db db-open ( db -- )
M: postgresql-db dispose ( db -- )
db-handle PQfinish ;
: with-postgresql ( host ust pass db quot -- )
>r <postgresql-db> r> with-disposal ;
M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-params ;
M: postgresql-statement reset-statement ( statement -- )
M: postgresql-statement bind-statement* ( statement -- )
drop ;
M: postgresql-statement bind-tuple ( tuple statement -- )
[
statement-in-params
[ sql-spec-slot-name swap get-slot-named ] with map
] keep set-statement-bind-params ;
M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ;
@ -56,19 +59,8 @@ M: postgresql-result-set row-column ( result-set n -- obj )
M: postgresql-result-set row-column-typed ( result-set n type -- obj )
>r row-column r> sql-type>factor-type ;
M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
{
{ INTEGER [ string>number ] }
{ BIG_INTEGER [ string>number ] }
{ DOUBLE [ string>number ] }
[ drop ]
} case ;
M: postgresql-statement insert-statement ( statement -- id )
query-results [ 0 row-column ] with-disposal string>number ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-params [
dup statement-bind-params [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
@ -96,17 +88,15 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
dup statement-sql swap statement-params
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
M: postgresql-db <simple-statement> ( sql -- statement )
{ set-statement-sql } statement construct
M: postgresql-db <simple-statement> ( sql in out -- statement )
<postgresql-statement> ;
M: postgresql-db <prepared-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-statement> ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
<postgresql-statement> dup prepare-statement ;
M: postgresql-db begin-transaction ( -- )
"BEGIN" sql-command ;
@ -117,139 +107,176 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
: postgresql-type-hash* ( -- assoc )
H{
{ SERIAL "serial" }
} ;
SYMBOL: postgresql-counter
: bind-name% ( -- )
CHAR: $ 0,
postgresql-counter [ inc ] keep get 0# ;
: postgresql-type-hash ( -- assoc )
M: postgresql-db bind% ( spec -- )
1, bind-name% ;
: postgresql-make ( class quot -- )
>r sql-props r>
[ postgresql-counter off ] swap compose
{ "" { } { } } nmake <postgresql-statement> ;
: create-table-sql ( class -- statement )
[
"create table " 0% 0%
"(" 0%
[ ", " 0% ] [
dup sql-spec-column-name 0%
" " 0%
dup sql-spec-type t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] postgresql-make ;
: create-function-sql ( class -- statement )
[
>r remove-id r>
"create function add_" 0% dup 0%
"(" 0%
over [ "," 0% ]
[
sql-spec-type f lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
"insert into " 0%
dup 0%
"(" 0%
over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
") values(" 0%
swap [ ", " 0% ] [ drop bind-name% ] interleave
"); " 0%
"select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
] postgresql-make ;
M: postgresql-db create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
dup db-columns find-primary-key native-id?
[ create-function-sql , ] [ drop ] if
] { } make ;
: drop-function-sql ( class -- statement )
[
"drop function add_" 0% 0%
"(" 0%
remove-id
[ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave
");" 0%
] postgresql-make ;
: drop-table-sql ( table -- statement )
[
"drop table " 0% 0% ";" 0% drop
] postgresql-make ;
M: postgresql-db drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
dup db-columns find-primary-key native-id?
[ drop-function-sql , ] [ drop ] if
] { } make ;
M: postgresql-db <insert-native-statement> ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
dup find-primary-key 2,
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
] postgresql-make ;
M: postgresql-db <insert-assigned-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
")" 0%
" values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
] postgresql-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db <update-tuple-statement> ( class -- statement )
[
"update " 0% 0%
" set " 0%
dup remove-id
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <delete-tuple-statement> ( class -- statement )
[
"delete from " 0% 0%
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[
! tuple columns table
"select " 0%
over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0%
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0%
] postgresql-make ;
M: postgresql-db type-table ( -- hash )
H{
{ INTEGER "integer" }
{ SERIAL "integer" }
{ +native-id+ "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ INTEGER "integer" }
{ DOUBLE "real" }
{ TIMESTAMP "timestamp" }
} ;
: enquote ( str -- newstr ) "(" swap ")" 3append ;
: postgresql-type ( str n/str -- newstr )
" " swap number>string* enquote 3append ;
: >sql-type* ( obj -- str )
dup pair? [
first2 >r >sql-type* r> postgresql-type
] [
dup postgresql-type-hash* at* [
nip
] [
drop >sql-type
] if
] if ;
M: postgresql-db >sql-type ( hash obj -- str )
dup pair? [
first2 >r >sql-type r> postgresql-type
] [
postgresql-type-hash at* [
no-sql-type
] unless
] if ;
: insert-function ( columns table -- sql )
[
>r remove-id r>
"create function add_" % dup %
"(" %
over [ "," % ]
[ third dup array? [ first ] when >sql-type % ] interleave
")" %
" returns bigint as '" %
2dup "insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
"); " %
"select currval(''" % % "_id_seq'');' language sql;" %
drop
] "" make ;
: drop-function ( columns table -- sql )
[
>r remove-id r>
"drop function add_" % %
"(" %
[ "," % ] [ third >sql-type % ] interleave
")" %
] "" make ;
M: postgresql-db create-sql ( columns table -- seq )
[
[
2dup
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type* % " " %
sql-modifiers " " join %
] interleave "); " %
] "" make ,
over native-id? [ insert-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db drop-sql ( columns table -- seq )
[
[
dup "drop table " % % ";" %
] "" make ,
over native-id? [ drop-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db insert-sql* ( columns table -- slot-names sql )
[
"select add_" % %
"(" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
")" %
] "" make ;
M: postgresql-db update-sql* ( columns table -- slot-names sql )
[
"update " %
%
" set " %
dup remove-id
dup length [1,b] swap 2array flip
[ ", " % ] [ first2 second % " = $" % # ] interleave
" where " %
[ primary-key? ] find nip second dup % " = $" % length 2 + #
] "" make ;
M: postgresql-db delete-sql* ( columns table -- slot-names sql )
[
"delete from " %
%
" where " %
first second % " = $1" %
] "" make ;
M: postgresql-db select-sql ( columns table -- slot-names sql )
drop ;
M: postgresql-db tuple>params ( columns tuple -- obj )
[ >r dup third swap first r> get-slot-named swap ]
curry { } map>assoc ;
: postgresql-db-modifiers ( -- hashtable )
M: postgresql-db create-type-table ( -- hash )
H{
{ +native-id+ "not null primary key" }
{ +native-id+ "serial primary key" }
} ;
: postgresql-compound ( str n -- newstr )
over {
{ "default" [ first number>string join-space ] }
{ "varchar" [ first number>string paren append ] }
{ "references" [
first2 >r [ unparse join-space ] keep db-columns r>
swap [ sql-spec-slot-name = ] with find nip
sql-spec-column-name paren append
] }
[ "no compound found" 3array throw ]
} case ;
M: postgresql-db compound-modifier ( str seq -- newstr )
postgresql-compound ;
M: postgresql-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +foreign-id+ "references" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
@ -257,13 +284,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
M: postgresql-db sql-modifiers* ( modifiers -- str )
postgresql-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
M: postgresql-db compound-type ( str n -- newstr )
postgresql-compound ;

5
extra/db/sqlite/lib/lib.factor
View File

@ -78,7 +78,8 @@ IN: db.sqlite.lib
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
{ SERIAL [ sqlite-bind-int-by-name ] }
{ TIMESTAMP [ sqlite-bind-double-by-name ] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
! { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
@ -102,6 +103,8 @@ IN: db.sqlite.lib
{ BIG_INTEGER [ sqlite3_column_int64 ] }
{ TEXT [ sqlite3_column_text ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TIMESTAMP [ sqlite3_column_double ] }
[ no-sql-type ]
} case ;
! TODO

157
extra/db/sqlite/sqlite-tests.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: io io.files io.launcher kernel namespaces
prettyprint tools.test db.sqlite db sequences
continuations db.types ;
continuations db.types db.tuples unicode.case ;
IN: temporary
: test.db "extra/db/sqlite/test.db" resource-path ;
@ -89,3 +89,158 @@ IN: temporary
"select * from person" sql-query length
] with-sqlite
] unit-test
! TEST TUPLE DB
TUPLE: puppy id name age ;
: <puppy> ( name age -- puppy )
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
{ "id" "ID" +native-id+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: kitty id name age ;
: <kitty> ( name age -- kitty )
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
{ "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id integer primary key not null, name varchar, age integer);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table basket(id integer primary key not null, location text);"
] [
T{ sqlite-db } db [
basket dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ sqlite-db } db [
puppy db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ sqlite-db } db [
kitty db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ sqlite-db } db [
basket db-table drop-sql >lower
] with-variable
] unit-test
! Insert
[
"insert into puppy(name, age) values(:name, :age);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values(:id, :name, :age);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
! Update
[
"update puppy set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
[
"update kitty set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
[
"delete from kitty where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
! Select
[
"select from puppy id, name, age where name = :name;"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ sqlite-db } db [
T{ puppy f f "Mr. Clunkers" }
select-sql >r >lower r>
] with-variable
] unit-test

198
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 ;
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,11 +22,7 @@ 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 ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set has-more? ;
@ -31,9 +30,14 @@ M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle over sqlite-prepare
{ set-statement-sql set-statement-handle } statement construct
<sqlite-statement> [ set-delegate ] keep ;
{
set-statement-sql
set-statement-in-params
set-statement-out-params
} statement construct
db get db-handle over statement-sql sqlite-prepare
over set-statement-handle
sqlite-statement construct-delegate ;
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
@ -44,18 +48,30 @@ M: sqlite-result-set dispose ( result-set -- )
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( triples statement -- )
statement-handle sqlite-bind ;
M: sqlite-statement reset-statement ( statement -- )
: reset-statement ( statement -- )
statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
dup statement-bound? [ dup reset-statement ] when
[ statement-bind-params ] [ statement-handle ] bi sqlite-bind ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
statement-in-params
[
[ sql-spec-column-name ":" swap append ]
[ sql-spec-slot-name rot get-slot-named ]
[ sql-spec-type ] tri 3array
] with map
] keep
[ set-statement-bind-params ] keep bind-statement* ;
: last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-statement insert-statement ( statement -- id )
execute-statement last-insert-id ;
M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
@ -86,78 +102,83 @@ M: sqlite-db commit-transaction ( -- )
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
M: sqlite-db create-sql ( columns table -- sql )
[
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type % " " %
sql-modifiers " " join %
] interleave ")" %
] "" make ;
: sqlite-make ( class quot -- )
>r sql-props r>
{ "" { } { } } nmake <simple-statement> ;
M: sqlite-db drop-sql ( columns table -- sql )
M: sqlite-db create-sql-statement ( class -- statement )
[
"drop table " % %
drop
] "" make ;
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup sql-spec-column-name 0%
" " 0%
dup sql-spec-type t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make ;
M: sqlite-db insert-sql* ( columns table -- sql )
M: sqlite-db drop-sql-statement ( class -- statement )
[
"insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
[ ", " % ] [ ":" % second % ] interleave
")" %
] "" make ;
"drop table " 0% 0% ";" 0% drop
] sqlite-make ;
: where-primary-key% ( columns -- )
" where " %
[ primary-key? ] find nip second dup % " = :" % % ;
M: sqlite-db update-sql* ( columns table -- sql )
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
"update " %
%
" set " %
"insert into " 0% 0%
"(" 0%
maybe-remove-id
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
") values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
] sqlite-make ;
M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
"update " 0%
0%
" set " 0%
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
[ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
where-primary-key%
] "" make ;
] sqlite-make ;
M: sqlite-db delete-sql* ( columns table -- sql )
M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
[
"delete from " %
%
" where " %
first second dup % " = :" % %
] "" make ;
"delete from " 0% 0%
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] sqlite-make ;
: select-interval ( interval name -- )
;
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
: select-sequence ( seq name -- )
;
M: sqlite-db bind% ( spec -- )
dup 1, sql-spec-column-name ":" swap append 0% ;
M: sqlite-db select-sql ( columns table -- sql )
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select ROWID, " %
over [ ", " % ] [ second % ] interleave
" from " % %
" where " %
] "" make ;
"select " 0%
over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave
M: sqlite-db tuple>params ( columns tuple -- obj )
[
>r [ second ":" swap append ] keep r>
dupd >r first r> get-slot-named swap
third 3array
] curry map ;
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0%
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0%
] sqlite-make ;
: sqlite-db-modifiers ( -- hashtable )
M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
@ -168,33 +189,24 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
M: sqlite-db sql-modifiers* ( modifiers -- str )
sqlite-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
M: sqlite-db compound-modifier ( str obj -- newstr )
compound-type ;
: sqlite-type-hash ( -- assoc )
M: sqlite-db compound-type ( str seq -- newstr )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
} case ;
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
{ INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ TIMESTAMP "timestamp" }
{ DOUBLE "real" }
} ;
M: sqlite-db >sql-type ( obj -- str )
dup pair? [
first >sql-type
] [
sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
] if ;
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {
! "INTEGER" get-integer-column } ... } case ;
M: sqlite-db create-type-table
type-table ;

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

@ -1,70 +1,119 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.sqlite db.tuples
db.types continuations namespaces db.postgresql math ;
! tools.time ;
USING: io.files kernel tools.test db db.tuples
db.types continuations namespaces db.postgresql math
prettyprint tools.walker db.sqlite ;
IN: temporary
TUPLE: person the-id the-name the-number real ;
TUPLE: person the-id the-name the-number the-real ;
: <person> ( name age real -- person )
{
set-person-the-name
set-person-the-number
set-person-real
set-person-the-real
} person construct ;
: <assigned-person> ( id name number real -- obj )
: <assigned-person> ( id name number the-real -- obj )
<person> [ set-person-the-id ] keep ;
SYMBOL: the-person
SYMBOL: the-person1
SYMBOL: the-person2
: test-tuples ( -- )
[ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test
[ person create-table ] must-fail
[ ] [ the-person get insert-tuple ] unit-test
[ ] [ the-person1 get insert-tuple ] unit-test
[ 1 ] [ the-person get person-the-id ] unit-test
[ 1 ] [ the-person1 get person-the-id ] unit-test
200 the-person get set-person-the-number
200 the-person1 get set-person-the-number
[ ] [ the-person get update-tuple ] unit-test
[ ] [ the-person1 get update-tuple ] unit-test
[ ] [ the-person get delete-tuple ] unit-test
; ! 1 [ ] [ person drop-table ] unit-test ;
[ T{ person f 1 "billy" 200 3.14 } ]
[ T{ person f 1 } select-tuple ] unit-test
[ ] [ the-person2 get insert-tuple ] unit-test
[
{
T{ person f 1 "billy" 200 3.14 }
T{ person f 2 "johnny" 10 3.14 }
}
] [ T{ person f f f f 3.14 } select-tuples ] unit-test
[ ] [ the-person1 get delete-tuple ] unit-test
[ f ] [ T{ person f 1 } select-tuple ] unit-test
[ ] [ person drop-table ] unit-test ;
: test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [
"tuples-test.db" resource-path sqlite-db [
test-tuples
] with-db ;
: test-postgresql ( -- )
"localhost" "postgres" "" "factor-test" <postgresql-db> [
{ "localhost" "postgres" "" "factor-test" } postgresql-db [
test-tuples
] with-db ;
person "PERSON"
{
{ "the-id" "ID" SERIAL +native-id+ }
{ "the-id" "ID" +native-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent
"billy" 10 3.14 <person> the-person set
"billy" 10 3.14 <person> the-person1 set
"johnny" 10 3.14 <person> the-person2 set
! test-sqlite
test-postgresql
! person "PERSON"
! {
! { "the-id" "ID" INTEGER +assigned-id+ }
! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
! { "the-number" "AGE" INTEGER { +default+ 0 } }
! { "real" "REAL" DOUBLE { +default+ 0.3 } }
! } define-persistent
! 1 "billy" 20 6.28 <assigned-person> the-person set
! test-sqlite
test-sqlite
! test-postgresql
person "PERSON"
{
{ "the-id" "ID" INTEGER +assigned-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent
1 "billy" 10 3.14 <assigned-person> the-person1 set
2 "johnny" 10 3.14 <assigned-person> the-person2 set
test-sqlite
! test-postgresql
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
paste "PASTE"
{
{ "n" "ID" +native-id+ }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "channel" "CHANNEL" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
{ "date" "DATE" TIMESTAMP }
{ "annotations" { +has-many+ annotation } }
} define-persistent
annotation "ANNOTATION"
{
{ "n" "ID" +native-id+ }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
} define-persistent
! { "localhost" "postgres" "" "factor-test" } postgresql-db [
! [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover
! [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover
! [ ] [ paste create-table ] unit-test
! [ ] [ annotation create-table ] unit-test
! ] with-db

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

@ -1,115 +1,111 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
tuples words sequences slots slots.private math
math.parser io prettyprint db.types continuations ;
tuples words sequences slots math
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples
: db-columns ( class -- obj ) "db-columns" word-prop ;
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop dup r>
[ relation? ] partition swapd
dupd [ spec>tuple ] with map
"db-columns" set-word-prop
"db-relations" set-word-prop ;
: db-table ( class -- obj ) "db-table" word-prop ;
: db-columns ( class -- obj ) "db-columns" word-prop ;
: db-relations ( class -- obj ) "db-relations" word-prop ;
TUPLE: no-slot-named ;
: no-slot-named ( -- * ) T{ no-slot-named } throw ;
: set-primary-key ( key tuple -- )
[
class db-columns find-primary-key sql-spec-slot-name
] keep set-slot-named ;
: slot-spec-named ( str class -- slot-spec )
"slots" word-prop [ slot-spec-name = ] with find nip
[ no-slot-named ] unless* ;
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
: offset-of-slot ( str obj -- n )
class slot-spec-named slot-spec-offset ;
HOOK: <insert-native-statement> db ( class -- obj )
HOOK: <insert-assigned-statement> db ( class -- obj )
: get-slot-named ( str obj -- value )
tuck offset-of-slot [ no-slot-named ] unless* slot ;
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <update-tuples-statement> db ( class -- obj )
: set-slot-named ( value str obj -- )
tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
HOOK: <delete-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( class -- obj )
: primary-key-spec ( class -- spec )
db-columns [ primary-key? ] find nip ;
: primary-key ( tuple -- obj )
dup class primary-key-spec get-slot-named ;
: set-primary-key ( obj tuple -- )
[ class primary-key-spec first ] keep
set-slot-named ;
: cache-statement ( columns class assoc quot -- statement )
[ db-table dupd ] swap
[ <prepared-statement> ] 3compose cache nip ; inline
HOOK: create-sql db ( columns table -- seq )
HOOK: drop-sql db ( columns table -- seq )
HOOK: insert-sql* db ( columns table -- slot-names sql )
HOOK: update-sql* db ( columns table -- slot-names sql )
HOOK: delete-sql* db ( columns table -- slot-names sql )
HOOK: select-sql db ( tuple -- statement )
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
HOOK: row-column-typed db ( result-set n type -- sql )
HOOK: sql-type>factor-type db ( obj type -- obj )
HOOK: tuple>params db ( columns tuple -- obj )
HOOK: insert-tuple* db ( tuple statement -- )
: resulting-tuple ( row out-params -- tuple )
dup first sql-spec-class construct-empty [
[
>r [ sql-spec-type sql-type>factor-type ] keep
sql-spec-slot-name r> set-slot-named
] curry 2each
] keep ;
HOOK: make-slot-names* db ( quot -- seq )
HOOK: column-slot-name% db ( spec -- )
HOOK: column-bind-name% db ( spec -- )
: query-tuples ( statement -- seq )
[ statement-out-params ] keep query-results [
[ sql-row swap resulting-tuple ] with query-map
] with-disposal ;
: query-modify-tuple ( tuple statement -- )
[ query-results [ sql-row ] with-disposal ] keep
statement-out-params rot [
>r [ sql-spec-type sql-type>factor-type ] keep
sql-spec-slot-name r> set-slot-named
] curry 2each ;
: make-slots-names ( quot -- seq str )
[ make-slot-names* ] "" make ; inline
: slot-name% ( seq -- ) first % ;
: column-name% ( seq -- ) second % ;
: column-type% ( seq -- ) third % ;
: sql-props ( class -- columns table )
dup db-columns swap db-table ;
: insert-sql ( columns class -- statement )
db get db-insert-statements [ insert-sql* ] cache-statement ;
: update-sql ( columns class -- statement )
db get db-update-statements [ update-sql* ] cache-statement ;
: delete-sql ( columns class -- statement )
db get db-delete-statements [ delete-sql* ] cache-statement ;
: tuple-statement ( columns tuple quot -- statement )
>r [ tuple>params ] 2keep class r> call
2dup . .
[ bind-statement ] keep ;
: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
>r [ class db-columns ] swap compose keep
r> tuple-statement ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
make-tuple-statement execute-statement ;
: with-disposals ( seq quot -- )
over sequence? [
[ with-disposal ] curry each
] [
with-disposal
] if ;
: create-table ( class -- )
dup db-columns swap db-table create-sql sql-command ;
create-sql-statement [ execute-statement ] with-disposals ;
: drop-table ( class -- )
dup db-columns swap db-table drop-sql sql-command ;
drop-sql-statement [ execute-statement ] with-disposals ;
: insert-native ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
: insert-assigned ( tuple -- )
dup class
db get db-insert-statements [ <insert-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
[
[ maybe-remove-id ] [ insert-sql ]
make-tuple-statement insert-statement
] keep set-primary-key ;
dup class db-columns find-primary-key assigned-id? [
insert-assigned
] [
insert-native
] if ;
: update-tuple ( tuple -- )
[ ] [ update-sql ] do-tuple-statement ;
dup class
db get db-update-statements [ <update-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: delete-tuple ( tuple -- )
[ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
dup class
db get db-delete-statements [ <delete-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: select-tuple ( tuple -- )
[ select-sql ] keep do-query ;
: select-tuples ( tuple -- tuple )
dup dup class <select-by-slots-statement> [
[ bind-tuple ] keep query-tuples
] with-disposal ;
: persist ( tuple -- )
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop r>
"db-columns" set-word-prop ;
: define-relation ( spec -- )
drop ;
: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

205
extra/db/types/types.factor
View File

@ -1,21 +1,50 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations ;
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors tuples combinators ;
IN: db.types
HOOK: modifier-table db ( -- hash )
HOOK: compound-modifier db ( str seq -- hash )
HOOK: type-table db ( -- hash )
HOOK: create-type-table db ( -- hash )
HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
! ID is the Primary key
! +native-id+ can be a columns type or a modifier
SYMBOL: +native-id+
! +assigned-id+ can only be a modifier
SYMBOL: +assigned-id+
: primary-key? ( spec -- ? )
[ { +native-id+ +assigned-id+ } member? ] contains? ;
: (primary-key?) ( obj -- ? )
{ +native-id+ +assigned-id+ } member? ;
: contains-id? ( columns id -- ? )
swap [ member? ] with contains? ;
: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
: native-id? ( columns -- ? ) +native-id+ contains-id? ;
: primary-key? ( spec -- ? )
sql-spec-primary-key (primary-key?) ;
: normalize-spec ( spec -- )
dup sql-spec-type dup (primary-key?) [
swap set-sql-spec-primary-key
] [
drop dup sql-spec-modifiers [
(primary-key?)
] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ;
: native-id? ( spec -- ? )
sql-spec-primary-key +native-id+ = ;
: assigned-id? ( spec -- ? )
sql-spec-primary-key +assigned-id+ = ;
SYMBOL: +foreign-id+
! Same concept, SQLite has autoincrement, PostgreSQL has serial
SYMBOL: +autoincrement+
@ -28,40 +57,168 @@ SYMBOL: +not-null+
SYMBOL: +has-many+
SYMBOL: SERIAL
SYMBOL: INTEGER
SYMBOL: DOUBLE
SYMBOL: BOOLEAN
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOL: INTEGER
SYMBOL: BIG_INTEGER
SYMBOL: DOUBLE
SYMBOL: REAL
SYMBOL: BOOLEAN
SYMBOL: TEXT
SYMBOL: VARCHAR
SYMBOL: TIMESTAMP
SYMBOL: DATE
SYMBOL: BIG_INTEGER
: spec>tuple ( class spec -- tuple )
[ ?first3 ] keep 3 ?tail*
{
set-sql-spec-class
set-sql-spec-slot-name
set-sql-spec-column-name
set-sql-spec-type
set-sql-spec-modifiers
} sql-spec construct
dup normalize-spec ;
: sql-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ DOUBLE "real" }
{ TIMESTAMP "timestamp" }
} ;
TUPLE: no-sql-type ;
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
HOOK: sql-modifiers* db ( modifiers -- str )
HOOK: >sql-type db ( obj -- str )
! HOOK: >factor-type db ( obj -- obj )
TUPLE: no-sql-modifier ;
: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
: maybe-remove-id ( columns -- obj )
[ +native-id+ swap member? not ] subset ;
: maybe-remove-id ( specs -- obj )
[ native-id? not ] subset ;
: remove-id ( columns -- obj )
[ primary-key? not ] subset ;
: remove-relations ( specs -- newcolumns )
[ relation? not ] subset ;
: sql-modifiers ( spec -- seq )
3 tail sql-modifiers* ;
: remove-id ( specs -- obj )
[ sql-spec-primary-key not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
: lookup-modifier ( obj -- str )
dup array? [
unclip lookup-modifier swap compound-modifier
] [
modifier-table at*
[ "unknown modifier" throw ] unless
] if ;
: lookup-type* ( obj -- str )
dup array? [
first lookup-type*
] [
type-table at*
[ no-sql-type ] unless
] if ;
: lookup-create-type ( obj -- str )
dup array? [
unclip lookup-create-type swap compound-type
] [
dup create-type-table at*
[ nip ] [ drop lookup-type* ] if
] if ;
: lookup-type ( obj create? -- str )
[ lookup-create-type ] [ lookup-type* ] if ;
: single-quote ( str -- newstr )
"'" swap "'" 3append ;
: double-quote ( str -- newstr )
"\"" swap "\"" 3append ;
: paren ( str -- newstr )
"(" swap ")" 3append ;
: join-space ( str1 str2 -- newstr )
" " swap 3append ;
: modifiers ( spec -- str )
sql-spec-modifiers
[ lookup-modifier ] map " " join
dup empty? [ " " swap append ] unless ;
SYMBOL: building-seq
: get-building-seq ( n -- seq )
building-seq get nth ;
: n, get-building-seq push ;
: n% get-building-seq push-all ;
: n# >r number>string r> n% ;
: 0, 0 n, ;
: 0% 0 n% ;
: 0# 0 n# ;
: 1, 1 n, ;
: 1% 1 n% ;
: 1# 1 n# ;
: 2, 2 n, ;
: 2% 2 n% ;
: 2# 2 n# ;
: nmake ( quot exemplars -- seqs )
dup length dup zero? [ 1+ ] when
[
[
[ drop 1024 swap new-resizable ] 2map
[ building-seq set call ] keep
] 2keep >r [ like ] 2map r> firstn
] with-scope ;
HOOK: bind% db ( spec -- )
TUPLE: no-slot-named ;
: no-slot-named ( -- * ) T{ no-slot-named } throw ;
: slot-spec-named ( str class -- slot-spec )
"slots" word-prop [ slot-spec-name = ] with find nip
[ no-slot-named ] unless* ;
: offset-of-slot ( str obj -- n )
class slot-spec-named slot-spec-offset ;
: get-slot-named ( str obj -- value )
tuck offset-of-slot [ no-slot-named ] unless* slot ;
: set-slot-named ( value str obj -- )
tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
: tuple>filled-slots ( tuple -- alist )
dup <mirror> mirror-slots [ slot-spec-name ] map
swap tuple-slots 2array flip [ nip ] assoc-subset ;
: tuple>params ( specs tuple -- obj )
[
>r dup sql-spec-type swap sql-spec-slot-name r>
get-slot-named swap
] curry { } map>assoc ;
: sql-type>factor-type ( obj type -- obj )
dup array? [ first ] when
{
{ +native-id+ [ string>number ] }
{ INTEGER [ string>number ] }
{ DOUBLE [ string>number ] }
{ REAL [ string>number ] }
{ TEXT [ ] }
{ VARCHAR [ ] }
[ "no conversion from sql type to factor type" throw ]
} case ;

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

1
extra/furnace/furnace.factor
View File

@ -215,4 +215,3 @@ SYMBOL: model
] [
drop
] if ;

7
extra/furnace/sessions/sessions.factor
View File

@ -1,5 +1,5 @@
USING: assocs calendar init kernel math.parser
namespaces random boxes alarms ;
namespaces random boxes alarms combinators.lib ;
IN: furnace.sessions
SYMBOL: sessions
@ -11,9 +11,8 @@ SYMBOL: sessions
] "furnace.sessions" add-init-hook
: new-session-id ( -- str )
4 big-random >hex
dup sessions get-global key?
[ drop new-session-id ] when ;
[ 4 big-random >hex ]
[ sessions get-global key? not ] generate ;
TUPLE: session id namespace alarm user-agent ;

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

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