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

Merge branch 'master' of http://factorcode.org/git/factor into semantic-db 

Conflicts:

	extra/db/tuples/tuples.factor
db4
Alex Chapman 2008-02-28 10:30:07 +11:00
parent 9e3b6e958b 5b0ab02d65
commit 8613940e60
240 changed files with 4129 additions and 2376 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitignore vendored
View File

@ -15,5 +15,7 @@ factor
.gdb_history
*.*.marks
.*.swp
reverse-complement-in.txt
reverse-complement-out.txt
temp
logs
work
misc/wordsize

11
Makefile
View File

@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
EXE_OBJS = $(PLAF_EXE_OBJS)
default:
default: misc/wordsize
make `./misc/target`
help:
@echo "Run 'make' with one of the following parameters:"
@echo ""
@echo "freebsd-x86-32"
@ -142,7 +145,8 @@ wince-arm:
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
install_name_tool \
@ -158,6 +162,9 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
misc/wordsize: misc/wordsize.c
gcc misc/wordsize.c -o misc/wordsize
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor*.*

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

@ -87,7 +87,7 @@ $nl
HELP: alien-invoke-error
{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "The symbol or library could not be found." }
{ "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
@ -103,7 +103,7 @@ HELP: alien-invoke
HELP: alien-indirect-error
{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "One of the three inputs to " { $link alien-indirect } " is not a literal value." }
}
@ -120,7 +120,7 @@ HELP: alien-indirect
HELP: alien-callback-error
{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "One of the four inputs to " { $link alien-callback } " is not a literal value." }
}
@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor"
{ $subsection alien-invoke }
"Sometimes it is necessary to invoke a C function pointer, rather than a named C function:"
{ $subsection alien-indirect }
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
$nl
"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ;
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ;
ARTICLE: "alien-callback-gc" "Callbacks and code GC"
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."

16
core/bootstrap/compiler/compiler.factor
View File

@ -16,6 +16,14 @@ IN: bootstrap.compiler
"cpu." cpu append require
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
enable-compiler
nl
"Compiling some words to speed up bootstrap..." write flush
@ -74,12 +82,4 @@ nl
malloc free memcpy
} compile
: enable-compiler ( -- )
[ compiled-usages recompile ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
enable-compiler
" done" print flush

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
[ drop ] recompile-hook set
! Trivial recompile hook. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
[ drop { } ] recompile-hook set
call
call

4
core/bootstrap/stage2.factor
View File

@ -29,9 +29,7 @@ SYMBOL: bootstrap-time
: compile-remaining ( -- )
"Compiling remaining words..." print flush
vocabs [
words "compile" "compiler" lookup execute
] each ;
vocabs [ words [ compiled? not ] subset compile ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;

3
core/classes/classes.factor
View File

@ -255,8 +255,7 @@ PRIVATE>
: (define-class) ( word props -- )
over reset-class
over reset-generic
over define-symbol
over deferred? [ over define-symbol ] when
>r dup word-props r> union over set-word-props
t "class" set-word-prop ;

33
core/compiler/compiler-docs.factor
View File

@ -1,18 +1,14 @@
USING: generator help.markup help.syntax words io parser
assocs words.private sequences ;
assocs words.private sequences compiler.units ;
IN: compiler
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
$nl
"The main entry points to the optimizing compiler:"
{ $subsection compile }
{ $subsection recompile }
{ $subsection recompile-all }
"The main entry point to the optimizing compiler:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
"The optimizing compiler can also compile and call a single quotation:"
{ $subsection compile-call } ;
{ $subsection decompile } ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"
@ -26,22 +22,6 @@ ARTICLE: "compiler" "Optimizing compiler"
ABOUT: "compiler"
HELP: compile
{ $values { "seq" "a sequence of words" } }
{ $description "Compiles a set of words. Ignores words which are already compiled." } ;
HELP: recompile
{ $values { "seq" "a sequence of words" } }
{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ;
HELP: compile-call
{ $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." }
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
HELP: recompile-all
{ $description "Recompiles all words." } ;
HELP: decompile
{ $values { "word" word } }
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
@ -50,3 +30,8 @@ HELP: (compile)
{ $values { "word" word } }
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: optimized-recompile-hook
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
{ $description "Compile a set of words." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;

29
core/compiler/compiler.factor
View File

@ -4,14 +4,9 @@ USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger math.parser prettyprint words
compiler.units continuations vocabs assocs alien.compiler dlists
optimizer definitions math compiler.errors threads graphs
generic ;
generic inference ;
IN: compiler
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
: ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ;
@ -49,27 +44,17 @@ IN: compiler
compile-loop
] if ;
: recompile ( words -- )
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
H{ } clone compile-queue set
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
compiled get >alist
dup [ drop crossref? ] assoc-contains?
modify-code-heap
] with-scope ; inline
: compile ( words -- )
[ compiled? not ] subset recompile ;
: compile-call ( quot -- )
H{ } clone changed-words
[ define-temp dup 1array compile ] with-variable
execute ;
] with-scope ;
: recompile-all ( -- )
[ all-words recompile ] with-compiler-errors ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
forget-errors all-words compile ;

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 ;

8
core/compiler/units/units-docs.factor
View File

@ -61,3 +61,11 @@ HELP: modify-code-heap ( alist -- )
{ { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
} }
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;
HELP: compile
{ $values { "seq" "a sequence of words" } }
{ $description "Compiles a set of words." } ;
HELP: compile-call
{ $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." } ;

38
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,10 +37,11 @@ SYMBOL: recompile-hook
SYMBOL: definition-observers
definition-observers global [ V{ } like ] change-at
GENERIC: definitions-changed ( assoc obj -- )
[ V{ } clone definition-observers set-global ]
"compiler.units" add-init-hook
: add-definition-observer ( obj -- )
definition-observers get push ;
@ -63,24 +64,45 @@ GENERIC: definitions-changed ( assoc obj -- )
dup changed-words get update
dup dup changed-vocabs update ;
: compile ( words -- )
recompile-hook get call
dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: post-compile-tasks
: after-compilation ( quot -- )
post-compile-tasks get push ;
: call-recompile-hook ( -- )
changed-words get keys
compiled-usages recompile-hook get call ;
: call-post-compile-tasks ( -- )
post-compile-tasks get [ call ] each ;
: finish-compilation-unit ( -- )
changed-words get keys recompile-hook get call
call-recompile-hook
call-post-compile-tasks
dup [ drop crossref? ] assoc-contains? modify-code-heap
changed-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
[
H{ } clone changed-words set
H{ } clone forgotten-definitions set
V{ } clone post-compile-tasks set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ]
[ ] cleanup
] with-scope ; inline
: default-recompile-hook
[ f ] { } map>assoc
dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
: compile-call ( quot -- )
[ define-temp ] with-compilation-unit execute ;
: default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ;
recompile-hook global
[ [ default-recompile-hook ] or ]

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

3
core/continuations/continuations.factor
View File

@ -120,6 +120,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

9
core/cpu/x86/32/32.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system
alien.compiler combinators command-line
compiler io vocabs.loader ;
compiler compiler.units io vocabs.loader ;
IN: cpu.x86.32
PREDICATE: x86-backend x86-32-backend
@ -281,7 +281,10 @@ T{ x86-backend f 4 } compiler-backend set-global
"-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush
[ sse2? ] compile-call [
[ optimized-recompile-hook ] recompile-hook [
[ sse2? ] compile-call
] with-variable
[
" - yes" print
"cpu.x86.sse2" require
] [

2
core/definitions/definitions.factor
View File

@ -43,7 +43,7 @@ M: object uses drop f ;
: xref ( defspec -- ) dup uses crossref get add-vertex ;
: usage ( defspec -- seq ) crossref get at keys ;
: usage ( defspec -- seq ) \ f or crossref get at keys ;
GENERIC: redefined* ( defspec -- )

24
core/generic/generic.factor
View File

@ -102,11 +102,13 @@ M: method-body stack-effect
! Definition protocol
M: method-spec where
dup first2 method [ method-loc ] [ second where ] ?if ;
dup first2 method [ method-word ] [ second ] ?if where ;
M: method-spec set-where first2 method set-method-loc ;
M: method-spec set-where
first2 method method-word set-where ;
M: method-spec definer drop \ M: \ ; ;
M: method-spec definer
drop \ M: \ ; ;
M: method-spec definition
first2 method dup [ method-def ] when ;
@ -114,9 +116,21 @@ M: method-spec definition
: forget-method ( class generic -- )
check-method
[ delete-at* ] with-methods
[ method-word forget ] [ drop ] if ;
[ method-word forget-word ] [ drop ] if ;
M: method-spec forget* first2 forget-method ;
M: method-spec forget*
first2 forget-method ;
M: method-body definer
drop \ M: \ ; ;
M: method-body definition
"method" word-prop method-def ;
M: method-body forget*
"method" word-prop
{ method-specializer method-generic } get-slots
forget-method ;
: implementors* ( classes -- words )
all-words [

71
core/heaps/heaps-docs.factor Normal file → Executable file
View File

@ -11,69 +11,72 @@ $nl
{ $subsection min-heap? }
{ $subsection <min-heap> }
"Max-heaps sort their elements so that the maximum element is first:"
{ $subsection min-heap }
{ $subsection min-heap? }
{ $subsection <min-heap> }
{ $subsection max-heap }
{ $subsection max-heap? }
{ $subsection <max-heap> }
"Both obey a protocol."
$nl
"Queries:"
{ $subsection heap-empty? }
{ $subsection heap-length }
{ $subsection heap-size }
{ $subsection heap-peek }
"Insertion:"
{ $subsection heap-push }
{ $subsection heap-push* }
{ $subsection heap-push-all }
"Removal:"
{ $subsection heap-pop* }
{ $subsection heap-pop } ;
{ $subsection heap-pop }
{ $subsection heap-delete } ;
ABOUT: "heaps"
HELP: <min-heap>
{ $values { "min-heap" min-heap } }
{ $description "Create a new " { $link min-heap } "." }
{ $see-also <max-heap> } ;
{ $description "Create a new " { $link min-heap } "." } ;
HELP: <max-heap>
{ $values { "max-heap" max-heap } }
{ $description "Create a new " { $link max-heap } "." }
{ $see-also <min-heap> } ;
{ $description "Create a new " { $link max-heap } "." } ;
HELP: heap-push
{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" }
{ $see-also heap-push-all heap-pop } ;
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" } ;
HELP: heap-push*
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
{ $side-effects "heap" } ;
HELP: heap-push-all
{ $values { "assoc" assoc } { "heap" heap } }
{ $values { "assoc" assoc } { "heap" "a heap" } }
{ $description "Push every key/value pair of an assoc onto a heap." }
{ $side-effects "heap" }
{ $see-also heap-push heap-pop } ;
{ $side-effects "heap" } ;
HELP: heap-peek
{ $values { "heap" heap } { "key" object } { "value" object } }
{ $description "Outputs the first element in the heap, leaving it in the heap." }
{ $see-also heap-pop heap-pop* } ;
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Output the first element in the heap, leaving it in the heap." } ;
HELP: heap-pop*
{ $values { "heap" heap } }
{ $description "Removes the first element from the heap." }
{ $side-effects "heap" }
{ $see-also heap-pop heap-push heap-peek } ;
{ $values { "heap" "a heap" } }
{ $description "Remove the first element from the heap." }
{ $side-effects "heap" } ;
HELP: heap-pop
{ $values { "heap" heap } { "key" object } { "value" object } }
{ $description "Outputs the first element in the heap and removes it from the heap." }
{ $side-effects "heap" }
{ $see-also heap-pop* heap-push heap-peek } ;
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } ;
HELP: heap-empty?
{ $values { "heap" heap } { "?" "a boolean" } }
{ $description "Tests if a " { $link heap } " has no nodes." }
{ $see-also heap-length heap-peek } ;
{ $values { "heap" "a heap" } { "?" "a boolean" } }
{ $description "Tests if a heap has no nodes." } ;
HELP: heap-length
{ $values { "heap" heap } { "n" integer } }
{ $description "Returns the number of key/value pairs in the heap." }
{ $see-also heap-empty? } ;
HELP: heap-size
{ $values { "heap" "a heap" } { "n" integer } }
{ $description "Returns the number of key/value pairs in the heap." } ;
HELP: heap-delete
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } ;

77
core/heaps/heaps-tests.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
! Copyright 2007 Ryan Murphy
! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test
heaps heaps.private ;
heaps heaps.private math.parser random assocs sequences sorting ;
IN: temporary
[ <min-heap> heap-pop ] must-fail
@ -15,16 +15,8 @@ IN: temporary
! Binary Min Heap
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test
[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
[ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
<min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all
3 [ dup heap-pop* ] times
] unit-test
{ t } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
{ f } [ t 5 f <entry> t 3 f <entry> T{ max-heap } heap-compare ] unit-test
[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
@ -32,18 +24,51 @@ IN: temporary
[ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
[ 0 ] [ <max-heap> heap-length ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
[ 0 ] [ <max-heap> heap-size ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
[ { { 1 2 } { 3 4 } { 5 6 } } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
[ { { 1 2 } } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
[ { } ] [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test
: heap-sort ( alist -- keys )
<min-heap> [ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist )
[
[
(random) dup number>string swap set
] times
] H{ } make-assoc ;
: test-heap-sort ( n -- ? )
random-alist dup >alist sort-keys swap heap-sort = ;
14 [
[ t ] swap [ 2^ test-heap-sort ] curry unit-test
] each
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
heap-data dup length swap [ entry-index ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
] each
: delete-random ( seq -- elt )
dup length random dup pick nth >r swap delete-nth r> ;
: sort-entries ( entries -- entries' )
[ [ entry-key ] compare ] sort ;
: delete-test ( n -- ? )
[
random-alist
<min-heap> [ heap-push-all ] keep
dup heap-data clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
heap-data
[ [ entry-key ] map ] 2apply
[ natural-sort ] 2apply ;
11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
] each

189
core/heaps/heaps.factor Normal file → Executable file
View File

@ -1,26 +1,31 @@
! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs ;
USING: kernel math sequences arrays assocs sequences.private
growable ;
IN: heaps
MIXIN: priority-queue
GENERIC: heap-push ( value key heap -- )
GENERIC: heap-push* ( value key heap -- entry )
GENERIC: heap-peek ( heap -- value key )
GENERIC: heap-pop* ( heap -- )
GENERIC: heap-pop ( heap -- value key )
GENERIC: heap-delete ( key heap -- )
GENERIC: heap-delete* ( key heap -- old ? )
GENERIC: heap-delete ( entry heap -- )
GENERIC: heap-empty? ( heap -- ? )
GENERIC: heap-length ( heap -- n )
GENERIC# heap-pop-while 2 ( heap pred quot -- )
GENERIC: heap-size ( heap -- n )
<PRIVATE
TUPLE: heap data ;
: heap-data delegate ; inline
: <heap> ( class -- heap )
>r V{ } clone heap construct-boa r>
construct-delegate ; inline
>r V{ } clone r> construct-delegate ; inline
TUPLE: entry value key heap index ;
: <entry> ( value key heap -- entry ) f entry construct-boa ;
PRIVATE>
TUPLE: min-heap ;
@ -34,23 +39,67 @@ TUPLE: max-heap ;
INSTANCE: min-heap priority-queue
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
heap-data empty? ;
M: priority-queue heap-size ( heap -- n )
heap-data length ;
<PRIVATE
: left ( n -- m ) 2 * 1+ ; inline
: right ( n -- m ) 2 * 2 + ; inline
: up ( n -- m ) 1- 2 /i ; inline
: left-value ( n heap -- obj ) >r left r> nth ; inline
: right-value ( n heap -- obj ) >r right r> nth ; inline
: up-value ( n vec -- obj ) >r up r> nth ; inline
: swap-up ( n vec -- ) >r dup up r> exchange ; inline
: last-index ( vec -- n ) length 1- ; inline
: left ( n -- m ) 1 shift 1 + ; inline
: right ( n -- m ) 1 shift 2 + ; inline
: up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry )
heap-data nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
: left-value ( n heap -- entry )
>r left r> data-nth ; inline
: right-value ( n heap -- entry )
>r right r> data-nth ; inline
: data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r>
heap-data set-nth-unsafe ;
: data-push ( entry heap -- n )
dup heap-size [
swap 2dup heap-data ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
heap-data pop ; inline
: data-pop* ( heap -- )
heap-data pop* ; inline
: data-peek ( heap -- entry )
heap-data peek ; inline
: data-first ( heap -- entry )
heap-data first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep
tuck >r >r data-set-nth r> r> data-set-nth ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
: (heap-compare) drop [ first ] compare 0 ; inline
: (heap-compare) drop [ entry-key ] compare 0 ; inline
M: min-heap heap-compare (heap-compare) > ;
M: max-heap heap-compare (heap-compare) < ;
: heap-bounds-check? ( m heap -- ? )
heap-data length >= ; inline
heap-size >= ; inline
: left-bounds-check? ( m heap -- ? )
>r left r> heap-bounds-check? ; inline
@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ;
: right-bounds-check? ( m heap -- ? )
>r right r> heap-bounds-check? ; inline
: up-heap-continue? ( vec heap -- ? )
>r [ last-index ] keep [ up-value ] keep peek r>
: continue? ( m up[m] heap -- ? )
[ data-nth swap ] keep [ data-nth ] keep
heap-compare ; inline
: up-heap ( vec heap -- )
2dup up-heap-continue? [
>r dup last-index [ over swap-up ] keep
up 1+ head-slice r> up-heap
DEFER: up-heap
: (up-heap) ( n heap -- )
>r dup up r>
3dup continue? [
[ data-exchange ] 2keep up-heap
] [
2drop
3drop
] if ;
: up-heap ( n heap -- )
over 0 > [ (up-heap) ] [ 2drop ] if ;
: (child) ( m heap -- n )
dupd
[ heap-data left-value ] 2keep
[ heap-data right-value ] keep heap-compare
2dup right-value
>r 2dup left-value r>
rot heap-compare
[ right ] [ left ] if ;
: child ( m heap -- n )
2dup right-bounds-check? [ drop left ] [ (child) ] if ;
2dup right-bounds-check?
[ drop left ] [ (child) ] if ;
: swap-down ( m heap -- )
[ child ] 2keep heap-data exchange ;
[ child ] 2keep data-exchange ;
DEFER: down-heap
: down-heap-continue? ( heap m heap -- m heap ? )
[ heap-data nth ] 2keep child pick
dupd [ heap-data nth swapd ] keep heap-compare ;
: (down-heap) ( m heap -- )
2dup down-heap-continue? [
-rot [ swap-down ] keep down-heap
] [
[ child ] 2keep swapd
3dup continue? [
3drop
] [
[ data-exchange ] 2keep down-heap
] if ;
: down-heap ( m heap -- )
@ -100,40 +152,43 @@ DEFER: down-heap
PRIVATE>
M: priority-queue heap-push ( value key heap -- )
>r swap 2array r>
[ heap-data push ] keep
[ heap-data ] keep
up-heap ;
M: priority-queue heap-push* ( value key heap -- entry )
[ <entry> dup ] keep [ data-push ] keep up-heap ;
: heap-push ( value key heap -- ) heap-push* drop ;
: heap-push-all ( assoc heap -- )
[ swapd heap-push ] curry assoc-each ;
: >entry< ( entry -- key value )
{ entry-value entry-key } get-slots ;
M: priority-queue heap-peek ( heap -- value key )
heap-data first first2 swap ;
data-first >entry< ;
: entry>index ( entry heap -- n )
over entry-heap eq? [
"Invalid entry passed to heap-delete" throw
] unless
entry-index ;
M: priority-queue heap-delete ( entry heap -- )
[ entry>index ] keep
2dup heap-size 1- = [
nip data-pop*
] [
[ nip data-pop ] 2keep
[ data-set-nth ] 2keep
down-heap
] if ;
M: priority-queue heap-pop* ( heap -- )
dup heap-data length 1 > [
[ heap-data pop ] keep
[ heap-data set-first ] keep
0 swap down-heap
] [
heap-data pop*
] if ;
dup data-first swap heap-delete ;
M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
M: priority-queue heap-pop ( heap -- value key )
dup data-first [ swap heap-delete ] keep >entry< ;
M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
M: priority-queue heap-length ( heap -- n ) heap-data length ;
: (heap-pop-while) ( heap pred quot -- )
pick heap-empty? [
3drop
] [
[ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep
roll [ (heap-pop-while) ] [ 3drop ] if
] if ;
M: priority-queue heap-pop-while ( heap pred quot -- )
[ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;
: heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
[ ] unfold nip ;

7
core/inference/class/class-tests.factor
View File

@ -288,3 +288,10 @@ cell-bits 32 = [
[ HEX: ff bitand 0 HEX: ff between? ]
\ >= inlined?
] unit-test
[ t ] [
[ HEX: ff swap HEX: ff bitand >= ]
\ >= inlined?
] unit-test

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

5
core/inference/state/state.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel ;
USING: assocs namespaces sequences kernel words ;
IN: inference.state
! Nesting state to solve recursion
@ -31,9 +31,6 @@ SYMBOL: current-node
! Words that the current dataflow IR depends on
SYMBOL: dependencies
SYMBOL: +inlined+
SYMBOL: +called+
: depends-on ( word how -- )
swap dependencies get dup [
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if

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

@ -154,3 +154,11 @@ 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+ ;

4
core/io/streams/c/c-tests.factor
View File

@ -2,9 +2,9 @@ USING: tools.test io.files io io.streams.c ;
IN: temporary
[ "hello world" ] [
"test.txt" resource-path [
"test.txt" temp-file [
"hello world" write
] with-file-writer
"test.txt" resource-path "rb" fopen <c-reader> contents
"test.txt" temp-file "rb" fopen <c-reader> contents
] unit-test

2
core/io/streams/c/c.factor
View File

@ -64,7 +64,7 @@ M: object init-stdio
stdin-handle stdout-handle <duplex-c-stream> stdio set-global
stderr-handle <c-writer> <plain-writer> stderr set-global ;
M: object io-multiplex (sleep) ;
M: object io-multiplex 60 60 * 1000 * or (sleep) ;
M: object <file-reader>
"rb" fopen <c-reader> <line-reader> ;

2
core/io/thread/thread.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.thread
USING: threads io.backend namespaces init ;
USING: threads io.backend namespaces init math ;
: io-thread ( -- )
sleep-time io-multiplex yield ;

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

4
core/layouts/layouts.factor
View File

@ -32,3 +32,7 @@ SYMBOL: type-numbers
: most-negative-fixnum ( -- n )
first-bignum neg ;
M: real >integer
dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] [ >bignum ] if ;

6
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
@ -63,7 +63,7 @@ M: duplex-stream stream-read-quot
[ listen until-quit ] if ; inline
: print-banner ( -- )
"Factor " write version write
"Factor #" write build number>string write
" on " write os write "/" write cpu print ;
: listener ( -- )

1
core/math/integers/integers-docs.factor
View File

@ -14,6 +14,7 @@ $nl
{ $subsection fixnum? }
{ $subsection bignum? }
{ $subsection >fixnum }
{ $subsection >integer }
{ $subsection >bignum }
{ $see-also "prettyprint-numbers" "modular-arithmetic" "bitwise-arithmetic" "integer-functions" "syntax-integers" } ;

1
core/math/integers/integers.factor
View File

@ -6,6 +6,7 @@ IN: math.integers.private
M: integer numerator ;
M: integer denominator drop 1 ;
M: integer >integer ;
M: fixnum >fixnum ;
M: fixnum >bignum fixnum>bignum ;

6
core/math/math.factor
View File

@ -5,6 +5,7 @@ IN: math
GENERIC: >fixnum ( x -- y ) foldable
GENERIC: >bignum ( x -- y ) foldable
GENERIC: >integer ( x -- y ) foldable
GENERIC: >float ( x -- y ) foldable
MATH: number= ( x y -- ? ) foldable
@ -16,6 +17,11 @@ MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline
: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline
: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline
: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable

4
core/memory/memory-docs.factor Normal file → Executable file
View File

@ -47,8 +47,8 @@ HELP: gc-time ( -- n )
{ $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
HELP: data-room ( -- cards semi generations )
{ $values { "cards" "number of bytes reserved for card marking" } { "semi" "number of bytes reserved for tenured semi-space" } { "generations" "array of free/total bytes pairs" } }
HELP: data-room ( -- cards generations )
{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
{ $description "Queries the runtime for memory usage information." } ;
HELP: code-room ( -- code-free code-total )

2
core/optimizer/math/math.factor
View File

@ -379,7 +379,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
>r dup dup node-in-d first node-interval
swap dup node-in-d second node-literal r> execute ; inline
: foldable-comparison? ( #call word -- )
: foldable-comparison? ( #call word -- ? )
>r dup known-comparison? [
r> perform-comparison incomparable eq? not
] [

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

66
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
[
@ -351,13 +351,18 @@ IN: temporary
<< file get parsed >> file set
: ~a ;
: ~b ~a ;
DEFER: ~b
"IN: temporary : ~b ~a ;" <string-reader>
"smudgy" parse-stream drop
: ~c ;
: ~d ;
{ H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
{ H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
{ H{ { ~d ~d } } H{ } } new-definitions set
{ H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
[ V{ ~b } { ~a } { ~a ~c } ] [
smudged-usage
@ -365,6 +370,24 @@ IN: temporary
] unit-test
] with-scope
[
<< file get parsed >> file set
GENERIC: ~e
: ~f ~e ;
: ~g ;
{ H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
{ H{ { ~g ~g } } H{ } } new-definitions set
[ V{ } { } { ~e ~f } ]
[ smudged-usage natural-sort ]
unit-test
] with-scope
[ ] [
"IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
] unit-test
@ -372,3 +395,38 @@ IN: temporary
[ t ] [
"foo?" "temporary" lookup word eq?
] unit-test
[ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ ] [
"IN: temporary M: f foo ;"
<string-reader> "redefining-a-class-6" parse-stream drop
] unit-test
[ f ] [ f "foo" "temporary" lookup execute ] unit-test
[ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ f ] [ f "foo" "temporary" lookup execute ] unit-test
[ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
[ ] [
"IN: temporary TUPLE: foo ;"
<string-reader> "redefining-a-class-7" parse-stream drop
] 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

18
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" ;
@ -439,11 +441,12 @@ SYMBOL: interactive-vocabs
"Warning: the following definitions were removed from sources," print
"but are still referenced from other definitions:" print
nl
dup stack.
dup sorted-definitions.
nl
"The following definitions need to be updated:" print
nl
over stack.
over sorted-definitions.
nl
] when 2drop ;
: filter-moved ( assoc -- newassoc )
@ -463,9 +466,16 @@ SYMBOL: interactive-vocabs
dup values concat prune swap keys
] keep ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2 diff
[ nip dup reset-generic define-symbol ] assoc-each ;
: forget-smudged ( -- )
smudged-usage forget-all
over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
over empty? [ 2dup smudged-usage-warning ] unless 2drop
fix-class-words ;
: finish-parsing ( lines quot -- )
file get
@ -499,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

24
core/prettyprint/prettyprint.factor
View File

@ -174,6 +174,12 @@ M: hook-generic synopsis*
M: method-spec synopsis*
dup definer. [ pprint-word ] each ;
M: method-body synopsis*
dup definer.
"method" word-prop dup
method-specializer pprint*
method-generic pprint* ;
M: mixin-instance synopsis*
dup definer.
dup mixin-instance-class pprint-word
@ -188,6 +194,15 @@ M: pathname synopsis* pprint* ;
[ synopsis* ] with-in
] with-string-writer ;
: synopsis-alist ( definitions -- alist )
[ dup synopsis swap ] { } map>assoc ;
: definitions. ( alist -- )
[ write-object nl ] assoc-each ;
: sorted-definitions. ( definitions -- )
synopsis-alist sort-keys definitions. ;
GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
@ -253,7 +268,9 @@ M: builtin-class see-class*
natural-sort [ nl see ] each ;
: see-implementors ( class -- seq )
dup implementors [ 2array ] with map ;
dup implementors
[ method method-word ] with map
natural-sort ;
: see-class ( class -- )
dup class? [
@ -263,8 +280,9 @@ M: builtin-class see-class*
] when drop ;
: see-methods ( generic -- seq )
[ "methods" word-prop keys natural-sort ] keep
[ 2array ] curry map ;
"methods" word-prop
[ nip method-word ] { } assoc>map
natural-sort ;
M: word see
dup see-class

12
core/sequences/sequences.factor
View File

@ -310,13 +310,11 @@ M: immutable-sequence clone-like like ;
<PRIVATE
: iterate-seq >r dup length swap r> ; inline
: (each) ( seq quot -- n quot' )
iterate-seq [ >r nth-unsafe r> call ] 2curry ; inline
>r dup length swap [ nth-unsafe ] curry r> compose ; inline
: (collect) ( quot into -- quot' )
[ >r over slip r> set-nth-unsafe ] 2curry ; inline
[ >r keep r> set-nth-unsafe ] 2curry ; inline
: collect ( n quot into -- )
(collect) each-integer ; inline
@ -415,7 +413,7 @@ PRIVATE>
>r dup length 1- swap r> (monotonic) all? ; inline
: interleave ( seq between quot -- )
[ (interleave) ] 2curry iterate-seq 2each ; inline
[ (interleave) ] 2curry >r dup length swap r> 2each ; inline
: unfold ( pred quot tail -- seq )
V{ } clone [
@ -695,9 +693,9 @@ PRIVATE>
: sequence-hashcode-step ( oldhash newpart -- newhash )
swap [
dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
fixnum+fast fixnum+fast
] keep bitxor ; inline
] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
0 -rot [

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

12
core/source-files/source-files.factor
View File

@ -97,16 +97,8 @@ SYMBOL: file
[ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline
: smart-usage ( word -- definitions )
\ f or usage [
dup method-body? [
"method" word-prop
{ method-specializer method-generic } get-slots
2array
] when
] map ;
: outside-usages ( seq -- usages )
dup [
over smart-usage [ pathname? not ] subset seq-diff
over usage
[ dup pathname? not swap where and ] subset seq-diff
] curry { } map>assoc ;

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

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

24
core/threads/threads-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations dlists init quotations strings
assocs heaps boxes ;
assocs heaps boxes namespaces ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"
@ -17,7 +17,10 @@ ARTICLE: "threads-start/stop" "Starting and stopping threads"
ARTICLE: "threads-yield" "Yielding and suspending threads"
"Yielding to other threads:"
{ $subsection yield }
"Sleeping for a period of time:"
{ $subsection sleep }
"Interrupting sleep:"
{ $subsection interrupt }
"Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
{ $subsection suspend }
{ $subsection resume }
@ -102,9 +105,21 @@ HELP: stop
HELP: yield
{ $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ;
HELP: sleep-until
{ $values { "time/f" "a non-negative integer or " { $link f } } }
{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in."
$nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
HELP: sleep
{ $values { "ms" "a non-negative integer" } }
{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ;
{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds."
$nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
HELP: interrupt
{ $values { "thread" thread } }
{ $description "Interrupts a sleeping thread." } ;
HELP: suspend
{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } }
@ -114,7 +129,10 @@ HELP: spawn
{ $values { "quot" quotation } { "name" string } }
{ $description "Spawns a new thread. The thread begins executing the given quotation; the name is for debugging purposes. The new thread begins running immediately and the current thread is added to the end of the run queue."
$nl
"The new thread begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." }
"The new thread begins with an empty data stack, an empty retain stack, and an empty catch stack. The name stack is inherited from the parent thread but may be cleared with " { $link init-namespaces } "." }
{ $notes
"The recommended way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "."
}
{ $examples
{ $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" }
} ;

101
core/threads/threads.factor
View File

@ -13,7 +13,7 @@ TUPLE: thread
name quot error-handler exit-handler
id
continuation state
mailbox variables ;
mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
@ -75,45 +75,65 @@ PRIVATE>
: sleep-queue 43 getenv ;
: resume ( thread -- )
f over set-thread-state
check-registered run-queue push-front ;
: resume-now ( thread -- )
f over set-thread-state
check-registered run-queue push-back ;
: resume-with ( obj thread -- )
f over set-thread-state
check-registered 2array run-queue push-front ;
<PRIVATE
: schedule-sleep ( thread ms -- )
>r check-registered r> sleep-queue heap-push ;
: wake-up? ( heap -- ? )
dup heap-empty?
[ drop f ] [ heap-peek nip millis <= ] if ;
: wake-up ( -- )
sleep-queue
[ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while
drop ;
: next ( -- )
wake-up
run-queue pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with ;
PRIVATE>
: sleep-time ( -- ms )
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] }
} cond ;
<PRIVATE
: schedule-sleep ( thread ms -- )
>r check-registered dup r> sleep-queue heap-push*
swap set-thread-sleep-entry ;
: expire-sleep? ( heap -- ? )
dup heap-empty?
[ drop f ] [ heap-peek nip millis <= ] if ;
: expire-sleep ( thread -- )
f over set-thread-sleep-entry resume ;
: expire-sleep-loop ( -- )
sleep-queue
[ dup expire-sleep? ]
[ dup heap-pop drop expire-sleep ]
[ ] while
drop ;
: next ( -- * )
expire-sleep-loop
run-queue dup dlist-empty? [
! We should never be in a state where the only threads
! are sleeping; the I/O wait thread is always runnable.
! However, if it dies, we handle this case
! semi-gracefully.
!
! And if sleep-time outputs f, there are no sleeping
! threads either... so WTF.
drop sleep-time [ die 0 ] unless* (sleep) next
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with
] if ;
PRIVATE>
: stop ( -- )
self dup thread-exit-handler call
unregister-thread next ;
@ -125,19 +145,33 @@ PRIVATE>
self swap call next
] callcc1 2nip ; inline
: yield ( -- ) [ resume ] "yield" suspend drop ;
: yield ( -- ) [ resume ] f suspend drop ;
: sleep ( ms -- )
>fixnum millis +
[ schedule-sleep ] curry
"sleep" suspend drop ;
GENERIC: sleep-until ( time/f -- )
M: integer sleep-until
[ schedule-sleep ] curry "sleep" suspend drop ;
M: f sleep-until
drop [ drop ] "interrupt" suspend drop ;
GENERIC: sleep ( ms -- )
M: real sleep
millis + >integer sleep-until ;
: interrupt ( thread -- )
dup thread-state [
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
f over set-thread-sleep-entry
dup resume
] when drop ;
: (spawn) ( thread -- )
[
resume [
resume-now [
dup set-self
dup register-thread
init-namespaces
V{ } set-catchstack
{ } set-retainstack
>r { } set-datastack r>
@ -177,6 +211,7 @@ PRIVATE>
initial-thread global
[ drop f "Initial" [ die ] <thread> ] cache
<box> over set-thread-continuation
f over set-thread-state
dup register-thread
set-self ;

37
core/tuples/tuples-tests.factor
View File

@ -237,3 +237,40 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ check-tuple? ] is? ] must-fail-with
! Hardcore unit tests
USE: threads
\ thread "slot-names" word-prop "slot-names" set
[ ] [
[
\ thread { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop
[
\ thread "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test
USE: vocabs
\ vocab "slot-names" word-prop "slot-names" set
[ ] [
[
\ vocab { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
\ vocab "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test

12
core/tuples/tuples.factor
View File

@ -3,7 +3,7 @@
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots slots.private ;
classes classes.private slots slots.private compiler.units ;
IN: tuples
M: tuple delegate 3 slot ;
@ -35,9 +35,12 @@ M: tuple class class-of-tuple ;
append (>tuple) ;
: reshape-tuples ( class newslots -- )
>r dup [ swap class eq? ] curry instances dup
rot "slot-names" word-prop r> permutation
[ reshape-tuple ] curry map become ;
>r dup "slot-names" word-prop r> permutation
[
>r [ swap class eq? ] curry instances dup r>
[ reshape-tuple ] curry map
become
] 2curry after-compilation ;
: old-slots ( class newslots -- seq )
swap "slots" word-prop 1 tail-slice
@ -55,6 +58,7 @@ M: tuple class class-of-tuple ;
over "slot-names" word-prop over = [
2dup forget-slots
2dup reshape-tuples
over changed-word
over redefined
] unless
] when 2drop ;

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 )

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

@ -76,9 +76,9 @@ $nl
ARTICLE: "declarations" "Declarations"
"Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word."
$nl
"The first declaration specifies the time when a word runs. It affects both interpreted and compiled definitions."
"The first declaration specifies the time when a word runs. It affects both the non-optimizing and optimizing compilers:"
{ $subsection POSTPONE: parsing }
"The remaining declarations only affect compiled definitions. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently."
"The remaining declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently."
{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." }
{ $subsection POSTPONE: inline }
{ $subsection POSTPONE: foldable }

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

8
core/words/words.factor
View File

@ -111,9 +111,17 @@ compiled-crossref global [ H{ } assoc-like ] change-at
dup compiled-unxref
compiled-crossref get delete-at ;
SYMBOL: +inlined+
SYMBOL: +called+
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
M: word redefined* ( word -- )
{ "inferred-effect" "no-effect" } reset-props ;

5
cp_dir
View File

@ -1,5 +0,0 @@
#!/bin/sh
echo $1
mkdir -p "`dirname \"$2\"`"
cp "$1" "$2"

27
extra/alarms/alarms-docs.factor Executable file
View File

@ -0,0 +1,27 @@
IN: alarms
USING: help.markup help.syntax calendar quotations ;
HELP: alarm
{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ;
HELP: add-alarm
{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } }
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
HELP: later
{ $values { "quot" quotation } { "time" duration } { "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;
HELP: cancel-alarm
{ $values { "alarm" alarm } }
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
ARTICLE: "alarms" "Alarms"
"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
{ $subsection alarm }
{ $subsection add-alarm }
{ $subsection later }
{ $subsection cancel-alarm }
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
ABOUT: "alarms"

148
extra/alarms/alarms.factor
View File

@ -1,87 +1,91 @@
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar combinators concurrency.messaging
threads generic init kernel math namespaces sequences ;
USING: arrays calendar combinators generic init kernel math
namespaces sequences heaps boxes threads debugger quotations
assocs ;
IN: alarms
TUPLE: alarm time quot ;
C: <alarm> alarm
TUPLE: alarm quot time interval entry ;
<PRIVATE
! for now a V{ }, eventually a min-heap to store alarms
SYMBOL: alarms
SYMBOL: alarm-receiver
SYMBOL: alarm-looper
SYMBOL: alarm-thread
: add-alarm ( alarm -- )
alarms get-global push ;
: notify-alarm-thread ( -- )
alarm-thread get-global interrupt ;
: remove-alarm ( alarm -- )
alarms get-global delete ;
: check-alarm
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
: handle-alarm ( alarm -- )
dup delegate {
{ "register" [ add-alarm ] }
{ "unregister" [ remove-alarm ] }
} case ;
: expired-alarms ( -- seq )
now alarms get-global
[ alarm-time <=> 0 > ] with subset ;
: unexpired-alarms ( -- seq )
now alarms get-global
[ alarm-time <=> 0 <= ] with subset ;
: call-alarm ( alarm -- )
alarm-quot "Alarm invocation" spawn drop ;
: do-alarms ( -- )
expired-alarms [ call-alarm ] each
unexpired-alarms alarms set-global ;
: alarm-receive-loop ( -- )
receive dup alarm? [ handle-alarm ] [ drop ] if
alarm-receive-loop ;
: start-alarm-receiver ( -- )
[
alarm-receive-loop
] "Alarm receiver" spawn alarm-receiver set-global ;
: alarm-loop ( -- )
alarms get-global empty? [
do-alarms
] unless 100 sleep alarm-loop ;
: start-alarm-looper ( -- )
[
alarm-loop
] "Alarm looper" spawn alarm-looper set-global ;
: send-alarm ( str alarm -- )
over set-delegate
alarm-receiver get-global send ;
: start-alarm-daemon ( -- )
alarms get-global [ V{ } clone alarms set-global ] unless
start-alarm-looper
start-alarm-receiver ;
[ start-alarm-daemon ] "alarms" add-init-hook
PRIVATE>
: <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm construct-boa ;
: register-alarm ( alarm -- )
"register" send-alarm ;
dup dup alarm-time alarms get-global heap-push*
swap alarm-entry >box
notify-alarm-thread ;
: unregister-alarm ( alarm -- )
"unregister" send-alarm ;
: alarm-expired? ( alarm now -- ? )
>r alarm-time r> before=? ;
: change-alarm ( alarm-old alarm-new -- )
"register" send-alarm
"unregister" send-alarm ;
: reschedule-alarm ( alarm -- )
dup alarm-time over alarm-interval time+
over set-alarm-time
register-alarm ;
! Example:
! 5 seconds from-now [ "hi" print flush ] <alarm> register-alarm
: call-alarm ( alarm -- )
dup alarm-quot try
dup alarm-entry box> drop
dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
: (trigger-alarms) ( alarms now -- )
over heap-empty? [
2drop
] [
over heap-peek drop over alarm-expired? [
over heap-pop drop call-alarm
(trigger-alarms)
] [
2drop
] if
] if ;
: trigger-alarms ( alarms -- )
now (trigger-alarms) ;
: next-alarm ( alarms -- timestamp/f )
dup heap-empty?
[ drop f ] [ heap-peek drop alarm-time ] if ;
: alarm-thread-loop ( -- )
alarms get-global
dup next-alarm sleep-until
dup trigger-alarms
alarm-thread-loop ;
: cancel-alarms ( alarms -- )
[
heap-pop-all [ nip alarm-entry box> drop ] assoc-each
] when* ;
: init-alarms ( -- )
alarms global [ cancel-alarms <min-heap> ] change-at
[ alarm-thread-loop ] "Alarms" spawn
alarm-thread set-global ;
[ init-alarms ] "alarms" add-init-hook
PRIVATE>
: add-alarm ( quot time frequency -- alarm )
<alarm> [ register-alarm ] keep ;
: later ( quot dt -- alarm )
from-now f add-alarm ;
: cancel-alarm ( alarm -- )
alarm-entry ?box
[ alarms get-global heap-delete ] [ drop ] if ;

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 +

2
extra/benchmark/mandel/mandel.factor
View File

@ -65,7 +65,7 @@ SYMBOL: cols
] with-scope ;
: mandel-main ( -- )
"mandel.ppm" resource-path
"mandel.ppm" temp-file
[ mandel write ] with-file-writer ;
MAIN: mandel-main

2
extra/benchmark/raytracer/raytracer.factor
View File

@ -170,7 +170,7 @@ DEFER: create ( level c r -- scene )
] "" make ;
: raytracer-main
"raytracer.pnm" resource-path
"raytracer.pnm" temp-file
[ run write ] with-file-writer ;
MAIN: raytracer-main

0
extra/benchmark/reverse-complement/reverse-complement-test-out.txt Normal file → Executable file
View File

13
extra/benchmark/reverse-complement/reverse-complement-tests.factor Executable file
View File

@ -0,0 +1,13 @@
IN: temporary
USING: tools.test benchmark.reverse-complement crypto.md5
io.files kernel ;
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
[ resource-path ] 2apply
reverse-complement
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
resource-path file>md5str
] unit-test

6
extra/benchmark/reverse-complement/reverse-complement.factor
View File

@ -41,12 +41,10 @@ HINTS: do-line vector string ;
] with-disposal ;
: reverse-complement-in
"extra/benchmark/reverse-complement/reverse-complement-in.txt"
resource-path ;
"reverse-complement-in.txt" temp-file ;
: reverse-complement-out
"extra/benchmark/reverse-complement/reverse-complement-out.txt"
resource-path ;
"reverse-complement-out.txt" temp-file ;
: reverse-complement-main ( -- )
reverse-complement-in

10
extra/benchmark/sockets/sockets.factor
View File

@ -34,10 +34,10 @@ IN: benchmark.sockets
: socket-benchmarks
10 clients
20 clients
40 clients
80 clients
160 clients
320 clients
640 clients ;
40 clients ;
! 80 clients
! 160 clients
! 320 clients
! 640 clients ;
MAIN: socket-benchmarks

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

51
extra/builder/builder.factor
View File

@ -2,21 +2,15 @@
USING: kernel namespaces sequences splitting system combinators continuations
parser io io.files io.launcher io.sockets prettyprint threads
bootstrap.image benchmark vars bake smtp builder.util accessors
builder.benchmark ;
calendar
builder.common
builder.benchmark
builder.release ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builds-dir
: builds ( -- path )
builds-dir get
home "/builds" append
or ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
builds make-directory
builds cd
@ -32,8 +26,6 @@ SYMBOL: builds-dir
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: stamp
: enter-build-dir ( -- )
datestamp >stamp
builds cd
@ -73,15 +65,8 @@ VAR: stamp
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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*>
@ -89,11 +74,11 @@ VAR: stamp
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
20 minutes>ms >>timeout
20 minutes >>timeout
>desc ;
: builder-test-cmd ( -- cmd )
{ factor-binary "-run=builder.test" } to-strings ;
{ "./factor" "-run=builder.test" } to-strings ;
: builder-test ( -- desc )
<process*>
@ -101,7 +86,7 @@ VAR: stamp
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
45 minutes>ms >>timeout
45 minutes >>timeout
>desc ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -155,7 +140,11 @@ SYMBOL: build-status
show-benchmark-deltas
"../benchmarks" "../../benchmarks" copy-file
"../benchmarks" "../../benchmarks" copy-file
".." cd
maybe-release
] with-file-writer
@ -176,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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -185,10 +174,11 @@ SYMBOL: builder-recipients
{ "bzip2" my-boot-image-name } to-strings run-process drop ;
: build ( -- )
[ (build) ] [ drop ] recover
[ (build) ] failsafe
builds cd stamp> cd
[ send-builder-email ] [ drop "not sending mail" . ] recover
".." cd { "rm" "-rf" "factor" } run-process drop
[ compress-image ] [ drop ] recover ;
{ "rm" "-rf" "factor" } run-process drop
[ compress-image ] failsafe ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -223,9 +213,8 @@ USE: bootstrap.image.download
[ build ]
when
]
[ drop ]
recover
5 minutes>ms sleep
failsafe
5 minutes sleep
build-loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

18
extra/builder/common/common.factor Normal file
View File

@ -0,0 +1,18 @@
USING: kernel namespaces io.files sequences vars ;
IN: builder.common
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builds-dir
: builds ( -- path )
builds-dir get
home "/builds" append
or ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: stamp

137
extra/builder/release/release.factor Normal file
View File

@ -0,0 +1,137 @@
USING: kernel namespaces sequences combinators io.files io.launcher
bake combinators.cleave builder.common builder.util ;
IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path ) builds "/releases" append dup make-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: common-files ( -- seq )
{
"boot.x86.32.image"
"boot.x86.64.image"
"boot.macosx-ppc.boot"
"vm"
"temp"
"logs"
".git"
".gitignore"
"Makefile"
"cp_dir"
"unmaintained"
"misc/target"
"misc/wordsize"
"misc/wordsize.c"
"misc/macos-release.sh"
"misc/source-release.sh"
"misc/windows-release.sh"
"misc/version.sh"
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: system sequences splitting ;
: cpu- ( -- cpu ) cpu "." split "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: extension ( -- extension )
os
{
{ "linux" [ ".tar.gz" ] }
{ "winnt" [ ".zip" ] }
{ "macosx" [ ".dmg" ] }
}
case ;
: archive-name ( -- string ) base-name extension append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: move-file ( source destination -- )
swap { "mv" , , } bake run-process drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: linux-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
{ "tar" "-cvzf" archive-name "factor" } to-strings run-process drop
archive-name releases move-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: windows-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
{ "zip" "-r" archive-name "factor" } to-strings run-process drop
archive-name releases move-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: macosx-release ( -- )
"factor" cd
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
{ "hdiutil" "create"
"-srcfolder" "factor"
"-fs" "HFS+"
"-volname" "factor"
archive-name }
to-strings run-process drop
archive-name releases move-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: release ( -- )
os
{
{ "linux" [ linux-release ] }
{ "winnt" [ windows-release ] }
{ "macosx" [ macosx-release ] }
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: release? ( -- ? )
{
"./load-everything-vocabs"
"./test-all-vocabs"
}
[ eval-file empty? ]
all? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: maybe-release ( -- ) release? [ release ] when ;

14
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
@ -98,4 +98,14 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
: cat-n ( file n -- )
[ file-lines ] [ ] bi*
maybe-tail*
[ print ] each ;
[ print ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: prettyprint
: to-file ( object file -- ) [ . ] with-file-writer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: failsafe ( quot -- ) [ drop ] recover ;

2
extra/bunny/bunny.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl
opengl.gl opengl.glu shuffle http.client vectors timers
opengl.gl opengl.glu shuffle http.client vectors
namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
combinators tools.time system combinators.lib combinators.cleave
float-arrays continuations opengl.demo-support multiline

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

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
math.ranges shuffle ;
USING: arrays kernel math math.functions namespaces sequences
strings tuples system vocabs.loader calendar.backend threads
new-slots accessors combinators ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
C: <timestamp> 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,39 +240,54 @@ M: number +second ( timestamp n -- timestamp )
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
: timestamp- ( timestamp timestamp -- seconds )
#! Exact calendar-time difference
: (time-) ( timestamp timestamp -- n )
[ >gmt ] 2apply
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
GENERIC: time- ( time1 time2 -- time )
M: timestamp time-
#! Exact calendar-time difference
(time-) seconds ;
: before ( dt -- -dt )
[ year>> neg ] keep
[ month>> neg ] keep
[ day>> neg ] keep
[ hour>> neg ] keep
[ minute>> neg ] keep
second>> neg
<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
: unix-time>timestamp ( n -- timestamp )
>r unix-1970 r> seconds +dt ;
: timestamp>unix-time ( timestamp -- n )
unix-1970 timestamp- >integer ;
: timestamp>timeval ( timestamp -- timeval )
timestamp>unix-time 1000 * make-timeval ;
: timeval>timestamp ( timeval -- timestamp )
[ timeval-sec ] keep
timeval-usec 1000000 / + unix-time>timestamp ;
: millis>timestamp ( n -- timestamp )
>r unix-1970 r> milliseconds time+ ;
: timestamp>millis ( timestamp -- n )
unix-1970 (time-) 1000 * >integer ;
: gmt ( -- timestamp )
#! GMT time, right now
unix-1970 millis 1000 /f seconds +dt ;
unix-1970 millis milliseconds time+ ;
: now ( -- timestamp ) gmt >local-time ;
: before ( dt -- -dt ) tuple-slots vneg array>dt ;
: from-now ( dt -- timestamp ) now swap +dt ;
: ago ( dt -- timestamp ) before from-now ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
: from-now ( dt -- timestamp ) now swap time+ ;
: ago ( dt -- timestamp ) now swap time- ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
: zeller-congruence ( year month day -- n )
#! Zeller Congruence
@ -262,7 +301,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
GENERIC: days-in-year ( obj -- n )
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ;
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
GENERIC: days-in-month ( obj -- n )
@ -274,7 +313,7 @@ M: array days-in-month ( obj -- n )
] if ;
M: timestamp days-in-month ( timestamp -- n )
{ timestamp-year timestamp-month } get-slots 2array days-in-month ;
>date< drop 2array days-in-month ;
GENERIC: day-of-week ( obj -- n )
@ -291,156 +330,20 @@ M: array day-of-year ( array -- n )
3dup day-counts rot head-slice sum +
swap leap-year? [
-roll
pick 3 1 make-date >r make-date r>
<=> 0 >= [ 1+ ] when
pick 3 1 <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 ;
@ -451,21 +354,26 @@ M: timestamp year. ( timestamp -- )
: saturday ( timestamp -- timestamp ) 6 day-this-week ;
: beginning-of-day ( timestamp -- new-timestamp )
clone dup >r 0 0 0 r>
{ set-timestamp-hour set-timestamp-minute set-timestamp-second }
set-slots ; inline
clone
0 >>hour
0 >>minute
0 >>second ; inline
: beginning-of-month ( timestamp -- new-timestamp )
beginning-of-day 1 over set-timestamp-day ;
beginning-of-day 1 >>day ;
: beginning-of-week ( timestamp -- new-timestamp )
beginning-of-day sunday ;
: beginning-of-year ( timestamp -- new-timestamp )
beginning-of-month 1 over set-timestamp-month ;
beginning-of-month 1 >>month ;
: seconds-since-midnight ( timestamp -- x )
dup beginning-of-day timestamp- ;
: time-since-midnight ( timestamp -- duration )
dup beginning-of-day time- ;
M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep from-now sleep-until ;
{
{ [ unix? ] [ "calendar.unix" ] }

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 ;

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 )

29
extra/combinators/cleave/cleave.factor
View File

@ -1,5 +1,5 @@
USING: kernel ;
USING: kernel sequences macros ;
IN: combinators.cleave
@ -19,6 +19,22 @@ IN: combinators.cleave
: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! General cleave
MACRO: cleave ( seq -- )
dup
[ drop [ dup ] ] map concat
swap
dup
[ drop [ >r ] ] map concat
swap
[ [ r> ] append ] map concat
3append
[ drop ]
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -30,3 +46,14 @@ IN: combinators.cleave
: tetra* ( obj obj obj obj quot quot quot quot -- val val val val )
>r roll >r tri* r> r> call ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! General spread
MACRO: spread ( seq -- )
dup
[ drop [ >r ] ] map concat
swap
[ [ r> ] swap append ] map concat
append ;

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

@ -1,6 +1,6 @@
IN: temporary
USING: concurrency.combinators tools.test random kernel math
concurrency.messaging threads sequences ;
concurrency.mailboxes threads sequences ;
[ [ drop ] parallel-each ] must-infer
[ [ ] parallel-map ] must-infer

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

@ -1,14 +1,27 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists threads kernel arrays sequences ;
USING: dlists dlists.private threads kernel arrays sequences
alarms ;
IN: concurrency.conditions
: notify-1 ( dlist -- )
dup dlist-empty?
[ drop ] [ pop-back second resume-now ] if ;
dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-all ( dlist -- )
[ second resume-now ] dlist-slurp yield ;
[ resume-now ] dlist-slurp ;
: queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the
#! queue, and resumes it, passing it a value of t.
>r self over push-front* [
tuck delete-node
dlist-node-obj t swap resume-with
] 2curry r> later ;
: wait ( queue timeout status -- )
>r [ 2array swap push-front ] r> suspend 3drop ; inline
over [
>r queue-timeout [ drop ] r> suspend
[ "Timeout" throw ] [ cancel-alarm ] if
] [
>r drop [ push-front ] curry r> suspend drop
] if ;

2
extra/concurrency/count-downs/count-downs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dlists kernel math concurrency.promises
concurrency.messaging ;
concurrency.mailboxes ;
IN: concurrency.count-downs
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html

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

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

@ -0,0 +1,33 @@
! 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: 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 the flag has not been raised, it first waits for it to be raised."
$nl
"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
{ $subsection flag }
{ $subsection flag? }
"Raising and lowering flags:"
{ $subsection raise-flag }
{ $subsection lower-flag } ;
ABOUT: "concurrency.flags"

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

@ -0,0 +1,21 @@
! 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 ;
: lower-flag ( flag -- )
dup flag-value? [
f swap set-flag-value?
] [
[ flag-thread >box ] curry "flag" suspend drop
] if ;

6
extra/concurrency/futures/futures.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises concurrency.messaging kernel arrays
USING: concurrency.promises concurrency.mailboxes kernel arrays
continuations ;
IN: concurrency.futures
@ -11,7 +11,7 @@ IN: concurrency.futures
] keep ; inline
: ?future-timeout ( future timeout -- value )
?promise-timeout ;
?promise-timeout ?linked ;
: ?future ( future -- value )
?promise ;
?promise ?linked ;

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

@ -1,8 +1,9 @@
IN: temporary
USING: tools.test concurrency.locks concurrency.count-downs
locals kernel threads sequences ;
concurrency.messaging concurrency.mailboxes locals kernel
threads sequences calendar ;
:: lock-test-0 | |
:: lock-test-0 ( -- )
[let | v [ V{ } clone ]
c [ 2 <count-down> ] |
@ -26,13 +27,13 @@ locals kernel threads sequences ;
v
] ;
:: lock-test-1 | |
:: lock-test-1 ( -- )
[let | v [ V{ } clone ]
l [ <lock> ]
c [ 2 <count-down> ] |
[
l f [
l [
yield
1 v push
yield
@ -42,7 +43,7 @@ locals kernel threads sequences ;
] "Lock test 1" spawn drop
[
l f [
l [
yield
3 v push
yield
@ -59,8 +60,8 @@ locals kernel threads sequences ;
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
[ 3 ] [
<reentrant-lock> dup f [
f [
<reentrant-lock> dup [
[
3
] with-lock
] with-lock
@ -68,17 +69,17 @@ locals kernel threads sequences ;
[ ] [ <rw-lock> drop ] unit-test
[ ] [ <rw-lock> f [ ] with-read-lock ] unit-test
[ ] [ <rw-lock> [ ] with-read-lock ] unit-test
[ ] [ <rw-lock> dup f [ f [ ] with-read-lock ] with-read-lock ] unit-test
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
[ ] [ <rw-lock> f [ ] with-write-lock ] unit-test
[ ] [ <rw-lock> [ ] with-write-lock ] unit-test
[ ] [ <rw-lock> dup f [ f [ ] with-write-lock ] with-write-lock ] unit-test
[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
[ ] [ <rw-lock> dup f [ f [ ] with-read-lock ] with-write-lock ] unit-test
[ ] [ <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> ]
@ -86,7 +87,7 @@ locals kernel threads sequences ;
v [ V{ } clone ] |
[
l f [
l [
1 v push
c count-down
yield
@ -97,7 +98,7 @@ locals kernel threads sequences ;
[
c await
l f [
l [
4 v push
1000 sleep
5 v push
@ -107,7 +108,7 @@ locals kernel threads sequences ;
[
c await
l f [
l [
2 v push
c' count-down
] with-read-lock
@ -116,7 +117,7 @@ locals kernel threads sequences ;
[
c' await
l f [
l [
6 v push
] with-write-lock
c'' count-down
@ -128,14 +129,14 @@ locals kernel threads sequences ;
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
:: rw-lock-test-2 | |
:: rw-lock-test-2 ( -- )
[let | l [ <rw-lock> ]
c [ 1 <count-down> ]
c' [ 2 <count-down> ]
v [ V{ } clone ] |
[
l f [
l [
1 v push
c count-down
1000 sleep
@ -146,7 +147,7 @@ locals kernel threads sequences ;
[
c await
l f [
l [
3 v push
] with-read-lock
c' count-down
@ -157,3 +158,21 @@ locals kernel threads sequences ;
] ;
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
! Test lock timeouts
:: lock-timeout-test ( -- )
[let | l [ <lock> ] |
[
l [ 1 seconds sleep ] with-lock
] "Lock holder" spawn drop
[
l 1/10 seconds [ ] with-lock-timeout
] "Lock timeout-er" spawn-linked drop
receive
] ;
[ lock-timeout-test ] [
linked-thread thread-name "Lock timeout-er" =
] must-fail-with

19
extra/concurrency/locks/locks.factor
View File

@ -25,15 +25,15 @@ TUPLE: lock threads owner reentrant? ;
lock-threads notify-1 ;
: do-lock ( lock timeout quot acquire release -- )
>r swap compose pick >r 2curry r> r> curry [ ] cleanup ;
inline
>r >r pick rot r> call ! use up timeout acquire
swap r> curry [ ] cleanup ; inline
: (with-lock) ( lock timeout quot -- )
[ acquire-lock ] [ release-lock ] do-lock ; inline
PRIVATE>
: with-lock ( lock timeout quot -- )
: with-lock-timeout ( lock timeout quot -- )
pick lock-reentrant? [
pick lock-owner self eq? [
2nip call
@ -44,6 +44,9 @@ PRIVATE>
(with-lock)
] if ; inline
: with-lock ( lock quot -- )
f swap with-lock-timeout ; inline
! Many-reader/single-writer locks
TUPLE: rw-lock readers writers reader# writer ;
@ -79,12 +82,18 @@ TUPLE: rw-lock readers writers reader# writer ;
PRIVATE>
: with-read-lock ( lock timeout quot -- )
: with-read-lock-timeout ( lock timeout quot -- )
[
[ acquire-read-lock ] [ release-read-lock ] do-lock
] do-reentrant-rw-lock ; inline
: with-write-lock ( lock timeout quot -- )
: with-read-lock ( lock quot -- )
f swap with-read-lock-timeout ; inline
: with-write-lock-timeout ( lock timeout quot -- )
[
[ acquire-write-lock ] [ release-write-lock ] do-lock
] do-reentrant-rw-lock ; inline
: with-write-lock ( lock quot -- )
f swap with-write-lock-timeout ; inline

75
extra/concurrency/mailboxes/mailboxes-docs.factor Executable file
View File

@ -0,0 +1,75 @@
USING: help.markup help.syntax kernel arrays ;
IN: concurrency.mailboxes
HELP: <mailbox>
{ $values { "mailbox" mailbox } }
{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ;
HELP: mailbox-empty?
{ $values { "mailbox" mailbox }
{ "bool" "a boolean" }
}
{ $description "Return true if the mailbox is empty." } ;
HELP: mailbox-put
{ $values { "obj" object }
{ "mailbox" mailbox }
}
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
HELP: block-unless-pred
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" mailbox }
{ "timeout" "a timeout in milliseconds, or " { $link f } }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;
HELP: block-if-empty
{ $values { "mailbox" mailbox }
{ "timeout" "a timeout in milliseconds, or " { $link f } }
}
{ $description "Block the thread if the mailbox is empty." } ;
HELP: mailbox-get
{ $values { "mailbox" mailbox }
{ "obj" object }
}
{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;
HELP: mailbox-get-all
{ $values { "mailbox" mailbox }
{ "array" array }
}
{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;
HELP: while-mailbox-empty
{ $values { "mailbox" mailbox }
{ "quot" "a quotation with stack effect " { $snippet "( -- )" } }
}
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
HELP: mailbox-get?
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" mailbox }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
ARTICLE: "concurrency.mailboxes" "Mailboxes"
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."
{ $subsection mailbox }
{ $subsection <mailbox> }
"Removing the first element:"
{ $subsection mailbox-get }
{ $subsection mailbox-get-timeout }
"Removing the first element matching a predicate:"
{ $subsection mailbox-get? }
{ $subsection mailbox-get-timeout? }
"Emptying out a mailbox:"
{ $subsection mailbox-get-all }
"Adding an element:"
{ $subsection mailbox-put }
"Testing if a mailbox is empty:"
{ $subsection mailbox-empty? }
{ $subsection while-mailbox-empty } ;

40
extra/concurrency/mailboxes/mailboxes-tests.factor Executable file
View File

@ -0,0 +1,40 @@
IN: temporary
USING: concurrency.mailboxes vectors sequences threads
tools.test math kernel strings ;
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put
3 over mailbox-put
"junk2" over mailbox-put
mailbox-get
] unit-test

76
extra/concurrency/mailboxes/mailboxes.factor Executable file
View File

@ -0,0 +1,76 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: concurrency.mailboxes
USING: dlists threads sequences continuations
namespaces random math quotations words kernel arrays assocs
init system concurrency.conditions ;
TUPLE: mailbox threads data ;
: <mailbox> ( -- mailbox )
<dlist> <dlist> mailbox construct-boa ;
: mailbox-empty? ( mailbox -- bool )
mailbox-data dlist-empty? ;
: mailbox-put ( obj mailbox -- )
[ mailbox-data push-front ] keep
mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
3drop
] [
2dup >r mailbox-threads r> "mailbox" wait
block-unless-pred
] if ; inline
: block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [
2dup >r mailbox-threads r> "mailbox" wait
block-if-empty
] [
drop
] if ;
: mailbox-peek ( mailbox -- obj )
mailbox-data peek-back ;
: mailbox-get-timeout ( mailbox timeout -- obj )
block-if-empty mailbox-data pop-back ;
: mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ;
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
[ dup mailbox-empty? ]
[ dup mailbox-data pop-back ]
[ ] unfold nip ;
: mailbox-get-all ( mailbox -- array )
f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [
dup >r swap slip r> while-mailbox-empty
] [
2drop
] if ; inline
: mailbox-get-timeout? ( pred mailbox timeout -- obj )
[ block-unless-pred ] 3keep drop
mailbox-data delete-node-if ; inline
: mailbox-get? ( pred mailbox -- obj )
f mailbox-get-timeout? ; inline
TUPLE: linked error thread ;
C: <linked> linked
: ?linked dup linked? [ rethrow ] when ;
: spawn-linked-to ( quot name mailbox -- thread )
[ >r <linked> r> mailbox-put ] curry <thread>
[ (spawn) ] keep ;

81
extra/concurrency/messaging/messaging-docs.factor
View File

@ -4,70 +4,6 @@ USING: help.syntax help.markup concurrency.messaging.private
threads kernel arrays quotations ;
IN: concurrency.messaging
HELP: <mailbox>
{ $values { "mailbox" mailbox }
}
{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." }
{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
HELP: mailbox-empty?
{ $values { "mailbox" mailbox }
{ "bool" "a boolean" }
}
{ $description "Return true if the mailbox is empty." }
{ $see-also <mailbox> mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
HELP: mailbox-put
{ $values { "obj" object }
{ "mailbox" mailbox }
}
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." }
{ $see-also <mailbox> mailbox-empty? mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
HELP: block-unless-pred
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" mailbox }
{ "timeout" "a timeout in milliseconds, or " { $link f } }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." }
{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
HELP: block-if-empty
{ $values { "mailbox" mailbox }
{ "timeout" "a timeout in milliseconds, or " { $link f } }
}
{ $description "Block the thread if the mailbox is empty." }
{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
HELP: mailbox-get
{ $values { "mailbox" mailbox }
{ "obj" object }
}
{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." }
{ $see-also <mailbox> mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ;
HELP: mailbox-get-all
{ $values { "mailbox" mailbox }
{ "array" array }
}
{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." }
{ $see-also <mailbox> mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ;
HELP: while-mailbox-empty
{ $values { "mailbox" mailbox }
{ "quot" "a quotation with stack effect " { $snippet "( -- )" } }
}
{ $description "Repeatedly call the quotation while there are no items in the mailbox." }
{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ;
HELP: mailbox-get?
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" mailbox }
{ "obj" object }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ;
HELP: send
{ $values { "message" object }
{ "thread" "a thread object" }
@ -95,8 +31,8 @@ HELP: spawn-linked
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
{ $see-also spawn } ;
ARTICLE: { "concurrency" "mailboxes" } "Mailboxes"
"Each thread has an associated message queue. Other threads can place items on this queue by sending the thread a message. A thread can check its queue for messages, blocking if none are pending, and thread them as they are queued."
ARTICLE: { "concurrency" "messaging" } "Mailboxes"
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
$nl
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
$nl
@ -104,14 +40,9 @@ $nl
{ $subsection send }
"A thread can get a message from its queue:"
{ $subsection receive }
{ $subsection receive }
{ $subsection receive-timeout }
{ $subsection receive-if }
"Mailboxes can be created and used directly:"
{ $subsection mailbox }
{ $subsection <mailbox> }
{ $subsection mailbox-get }
{ $subsection mailbox-put }
{ $subsection mailbox-empty? } ;
{ $subsection receive-if-timeout } ;
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
@ -133,8 +64,6 @@ ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
{ $code "[ 1 0 / \"This will not print\" print ] spawn" }
"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
{ $subsection spawn-linked }
"A more flexible version of the above deposits the error in an arbitary mailbox:"
{ $subsection spawn-linked-to }
"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
{ $code "["
" [ 1 0 / \"This will not print\" print ] spawn-linked drop"
@ -148,7 +77,7 @@ $nl
"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends."
$nl
"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
{ $subsection { "concurrency" "mailboxes" } }
{ $subsection { "concurrency" "messaging" } }
{ $subsection { "concurrency" "synchronous-sends" } }
{ $subsection { "concurrency" "exceptions" } } ;

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

@ -3,48 +3,10 @@
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
match quotations concurrency.messaging ;
match quotations concurrency.messaging concurrency.mailboxes ;
IN: temporary
[ ] [ mailbox mailbox-data dlist-delete-all ] unit-test
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread
[ mailbox-get swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ V{ 1 2 3 } ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
1 over mailbox-put
2 over mailbox-put
3 swap mailbox-put
] unit-test
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
0 <vector>
<mailbox>
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ integer? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
[ [ string? ] swap mailbox-get? swap push ] in-thread
1 over mailbox-put
"junk" over mailbox-put
[ 456 ] over mailbox-put
3 over mailbox-put
"junk2" over mailbox-put
mailbox-get
] unit-test
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
[ "received" ] [
[

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

@ -1,80 +1,11 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
!
! Concurrency library for Factor based on Erlang/Termite style
! Concurrency library for Factor, based on Erlang/Termite style
! concurrency.
USING: kernel threads concurrency.mailboxes continuations
namespaces assocs random ;
IN: concurrency.messaging
USING: dlists threads sequences continuations
namespaces random math quotations words kernel arrays assocs
init system concurrency.conditions ;
TUPLE: mailbox threads data ;
: <mailbox> ( -- mailbox )
<dlist> <dlist> \ mailbox construct-boa ;
: mailbox-empty? ( mailbox -- bool )
mailbox-data dlist-empty? ;
: mailbox-put ( obj mailbox -- )
[ mailbox-data push-front ] keep
mailbox-threads notify-all ;
<PRIVATE
: block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
3drop
] [
2dup >r mailbox-threads r> "mailbox" wait
block-unless-pred
] if ; inline
: block-if-empty ( mailbox timeout -- mailbox )
over mailbox-empty? [
2dup >r mailbox-threads r> "mailbox" wait
block-if-empty
] [
drop
] if ;
PRIVATE>
: mailbox-peek ( mailbox -- obj )
mailbox-data peek-back ;
: mailbox-get-timeout ( mailbox timeout -- obj )
block-if-empty mailbox-data pop-back ;
: mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ;
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
[ dup mailbox-empty? ]
[ dup mailbox-data pop-back ]
[ ] unfold nip ;
: mailbox-get-all ( mailbox -- array )
f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [
dup >r swap slip r> while-mailbox-empty
] [
2drop
] if ; inline
: mailbox-timeout-get? ( pred mailbox timeout -- obj )
[ block-unless-pred ] 3keep drop
mailbox-data delete-node-if ; inline
: mailbox-get? ( pred mailbox -- obj )
f mailbox-timeout-get? ; inline
TUPLE: linked error thread ;
C: <linked> linked
GENERIC: send ( message process -- )
@ -86,25 +17,25 @@ GENERIC: send ( message process -- )
M: thread send ( message thread -- )
check-registered mailbox-of mailbox-put ;
: ?linked dup linked? [ rethrow ] when ;
: mailbox self mailbox-of ;
: my-mailbox self mailbox-of ;
: receive ( -- message )
mailbox mailbox-get ?linked ;
my-mailbox mailbox-get ?linked ;
: receive-timeout ( timeout -- message )
my-mailbox swap mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
mailbox mailbox-get? ?linked ; inline
my-mailbox mailbox-get? ?linked ; inline
: receive-if-timeout ( pred timeout -- message )
my-mailbox swap mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
>r <linked> r> send ;
: spawn-linked-to ( quot name mailbox -- thread )
[ >r <linked> r> mailbox-put ] curry <thread>
[ (spawn) ] keep ;
: spawn-linked ( quot name -- thread )
mailbox spawn-linked-to ;
my-mailbox spawn-linked-to ;
TUPLE: synchronous data sender tag ;
@ -116,17 +47,18 @@ TUPLE: reply data tag ;
: <reply> ( data synchronous -- reply )
synchronous-tag \ reply construct-boa ;
: synchronous-reply? ( response synchronous -- ? )
over reply?
[ >r reply-tag r> synchronous-tag = ]
[ 2drop f ] if ;
: send-synchronous ( message thread -- reply )
dup self eq? [
"Cannot synchronous send to myself" throw
] [
>r <synchronous> dup r> send [
over reply? [
>r reply-tag r> synchronous-tag =
] [
2drop f
] if
] curry receive-if reply-data
>r <synchronous> dup r> send
[ synchronous-reply? ] curry receive-if
reply-data
] if ;
: reply-synchronous ( message synchronous -- )
@ -139,18 +71,18 @@ TUPLE: reply data tag ;
<PRIVATE
: remote-processes ( -- hash )
\ remote-processes get-global ;
: registered-processes ( -- hash )
\ registered-processes get-global ;
PRIVATE>
: register-process ( name process -- )
swap remote-processes set-at ;
swap registered-processes set-at ;
: unregister-process ( name -- )
remote-processes delete-at ;
registered-processes delete-at ;
: get-process ( name -- process )
dup remote-processes at [ ] [ thread ] ?if ;
dup registered-processes at [ ] [ thread ] ?if ;
\ remote-processes global [ H{ } assoc-like ] change-at
\ registered-processes global [ H{ } assoc-like ] change-at

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