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
commit 8613940e60
240 changed files with 4129 additions and 2376 deletions

6
.gitignore vendored
View File

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

View File

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

View File

@ -87,7 +87,7 @@ $nl
HELP: alien-invoke-error 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:" { $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 { $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 return type or parameter list references an unknown C type." }
{ "The symbol or library could not be found." } { "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 } "." } { "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 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:" { $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 { $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." } { "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." } { "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 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:" { $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 { $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." } { "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." } { "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 } { $subsection alien-invoke }
"Sometimes it is necessary to invoke a C function pointer, rather than a named C function:" "Sometimes it is necessary to invoke a C function pointer, rather than a named C function:"
{ $subsection alien-indirect } { $subsection alien-indirect }
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." "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." ;
ARTICLE: "alien-callback-gc" "Callbacks and code GC" 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." "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."

View File

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

View File

@ -30,7 +30,10 @@ crossref off
"syntax" vocab vocab-words bootstrap-syntax set "syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set H{ } clone dictionary set
H{ } clone changed-words 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
call call

View File

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

View File

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

View File

@ -1,18 +1,14 @@
USING: generator help.markup help.syntax words io parser USING: generator help.markup help.syntax words io parser
assocs words.private sequences ; assocs words.private sequences compiler.units ;
IN: compiler IN: compiler
ARTICLE: "compiler-usage" "Calling the optimizing 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." "Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
$nl $nl
"The main entry points to the optimizing compiler:" "The main entry point to the optimizing compiler:"
{ $subsection compile } { $subsection optimized-recompile-hook }
{ $subsection recompile }
{ $subsection recompile-all }
"Removing a word's optimized definition:" "Removing a word's optimized definition:"
{ $subsection decompile } { $subsection decompile } ;
"The optimizing compiler can also compile and call a single quotation:"
{ $subsection compile-call } ;
ARTICLE: "compiler" "Optimizing compiler" ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:" "Factor is a fully compiled language implementation with two distinct compilers:"
@ -26,22 +22,6 @@ ARTICLE: "compiler" "Optimizing compiler"
ABOUT: "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 HELP: decompile
{ $values { "word" word } } { $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." } ; { $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 } } { $values { "word" word } }
{ $description "Compile a single word." } { $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; { $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." } ;

View File

@ -4,14 +4,9 @@ USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger math.parser prettyprint words inference.state generator debugger math.parser prettyprint words
compiler.units continuations vocabs assocs alien.compiler dlists compiler.units continuations vocabs assocs alien.compiler dlists
optimizer definitions math compiler.errors threads graphs optimizer definitions math compiler.errors threads graphs
generic ; generic inference ;
IN: compiler 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 -- ) : ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ; compiled-usage [ drop queue-compile ] assoc-each ;
@ -49,27 +44,17 @@ IN: compiler
compile-loop compile-loop
] if ; ] if ;
: recompile ( words -- ) : decompile ( word -- )
f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[ [
H{ } clone compile-queue set H{ } clone compile-queue set
H{ } clone compiled set H{ } clone compiled set
[ queue-compile ] each [ queue-compile ] each
compile-queue get compile-loop compile-queue get compile-loop
compiled get >alist compiled get >alist
dup [ drop crossref? ] assoc-contains? ] with-scope ;
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 ;
: recompile-all ( -- ) : recompile-all ( -- )
[ all-words recompile ] with-compiler-errors ; forget-errors all-words compile ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;

View File

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

View File

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

View File

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

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 sequences.private math.private math combinators strings
alien arrays memory ; alien arrays memory ;
IN: temporary IN: temporary

View File

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

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

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words USING: kernel continuations assocs namespaces sequences words
vocabs definitions hashtables ; vocabs definitions hashtables init ;
IN: compiler.units IN: compiler.units
SYMBOL: old-definitions SYMBOL: old-definitions
@ -37,10 +37,11 @@ SYMBOL: recompile-hook
SYMBOL: definition-observers SYMBOL: definition-observers
definition-observers global [ V{ } like ] change-at
GENERIC: definitions-changed ( assoc obj -- ) GENERIC: definitions-changed ( assoc obj -- )
[ V{ } clone definition-observers set-global ]
"compiler.units" add-init-hook
: add-definition-observer ( obj -- ) : add-definition-observer ( obj -- )
definition-observers get push ; definition-observers get push ;
@ -63,24 +64,45 @@ GENERIC: definitions-changed ( assoc obj -- )
dup changed-words get update dup changed-words get update
dup dup changed-vocabs 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 ( -- ) : 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 ; changed-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- ) : with-compilation-unit ( quot -- )
[ [
H{ } clone changed-words set H{ } clone changed-words set
H{ } clone forgotten-definitions set H{ } clone forgotten-definitions set
V{ } clone post-compile-tasks set
<definitions> new-definitions set <definitions> new-definitions set
<definitions> old-definitions set <definitions> old-definitions set
[ finish-compilation-unit ] [ finish-compilation-unit ]
[ ] cleanup [ ] cleanup
] with-scope ; inline ] with-scope ; inline
: default-recompile-hook : compile-call ( quot -- )
[ f ] { } map>assoc [ define-temp ] with-compilation-unit execute ;
dup [ drop crossref? ] assoc-contains?
modify-code-heap ; : default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ;
recompile-hook global recompile-hook global
[ [ default-recompile-hook ] or ] [ [ default-recompile-hook ] or ]

View File

@ -23,9 +23,10 @@ $nl
"Two words raise an error in the innermost error handler for the current dynamic extent:" "Two words raise an error in the innermost error handler for the current dynamic extent:"
{ $subsection throw } { $subsection throw }
{ $subsection rethrow } { $subsection rethrow }
"Two words for establishing an error handler:" "Words for establishing an error handler:"
{ $subsection cleanup } { $subsection cleanup }
{ $subsection recover } { $subsection recover }
{ $subsection ignore-errors }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" } { $subsection "errors-restartable" }
{ $subsection "errors-post-mortem" } ; { $subsection "errors-post-mortem" } ;
@ -148,6 +149,10 @@ HELP: recover
{ $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } } { $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." } ; { $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 HELP: rethrow
{ $values { "error" object } } { $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." } { $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." }

View File

@ -120,6 +120,9 @@ SYMBOL: thread-error-hook
: recover ( try recovery -- ) : recover ( try recovery -- )
>r [ swap >c call c> drop ] curry r> ifcc ; inline >r [ swap >c call c> drop ] curry r> ifcc ; inline
: ignore-errors ( quot -- )
[ drop ] recover ; inline
: cleanup ( try cleanup-always cleanup-error -- ) : cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry over >r compose [ dip rethrow ] curry
recover r> call ; inline recover r> call ; inline

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

View File

@ -43,7 +43,7 @@ M: object uses drop f ;
: xref ( defspec -- ) dup uses crossref get add-vertex ; : 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 -- ) GENERIC: redefined* ( defspec -- )

View File

@ -102,11 +102,13 @@ M: method-body stack-effect
! Definition protocol ! Definition protocol
M: method-spec where 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 M: method-spec definition
first2 method dup [ method-def ] when ; first2 method dup [ method-def ] when ;
@ -114,9 +116,21 @@ M: method-spec definition
: forget-method ( class generic -- ) : forget-method ( class generic -- )
check-method check-method
[ delete-at* ] with-methods [ 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 ) : implementors* ( classes -- words )
all-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? }
{ $subsection <min-heap> } { $subsection <min-heap> }
"Max-heaps sort their elements so that the maximum element is first:" "Max-heaps sort their elements so that the maximum element is first:"
{ $subsection min-heap } { $subsection max-heap }
{ $subsection min-heap? } { $subsection max-heap? }
{ $subsection <min-heap> } { $subsection <max-heap> }
"Both obey a protocol." "Both obey a protocol."
$nl $nl
"Queries:" "Queries:"
{ $subsection heap-empty? } { $subsection heap-empty? }
{ $subsection heap-length } { $subsection heap-size }
{ $subsection heap-peek } { $subsection heap-peek }
"Insertion:" "Insertion:"
{ $subsection heap-push } { $subsection heap-push }
{ $subsection heap-push* }
{ $subsection heap-push-all } { $subsection heap-push-all }
"Removal:" "Removal:"
{ $subsection heap-pop* } { $subsection heap-pop* }
{ $subsection heap-pop } ; { $subsection heap-pop }
{ $subsection heap-delete } ;
ABOUT: "heaps" ABOUT: "heaps"
HELP: <min-heap> HELP: <min-heap>
{ $values { "min-heap" min-heap } } { $values { "min-heap" min-heap } }
{ $description "Create a new " { $link min-heap } "." } { $description "Create a new " { $link min-heap } "." } ;
{ $see-also <max-heap> } ;
HELP: <max-heap> HELP: <max-heap>
{ $values { "max-heap" max-heap } } { $values { "max-heap" max-heap } }
{ $description "Create a new " { $link max-heap } "." } { $description "Create a new " { $link max-heap } "." } ;
{ $see-also <min-heap> } ;
HELP: heap-push HELP: heap-push
{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } } { $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } { $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" } { $side-effects "heap" } ;
{ $see-also heap-push-all heap-pop } ;
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 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." } { $description "Push every key/value pair of an assoc onto a heap." }
{ $side-effects "heap" } { $side-effects "heap" } ;
{ $see-also heap-push heap-pop } ;
HELP: heap-peek HELP: heap-peek
{ $values { "heap" heap } { "key" object } { "value" object } } { $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Outputs the first element in the heap, leaving it in the heap." } { $description "Output the first element in the heap, leaving it in the heap." } ;
{ $see-also heap-pop heap-pop* } ;
HELP: heap-pop* HELP: heap-pop*
{ $values { "heap" heap } } { $values { "heap" "a heap" } }
{ $description "Removes the first element from the heap." } { $description "Remove the first element from the heap." }
{ $side-effects "heap" } { $side-effects "heap" } ;
{ $see-also heap-pop heap-push heap-peek } ;
HELP: heap-pop HELP: heap-pop
{ $values { "heap" heap } { "key" object } { "value" object } } { $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $description "Outputs the first element in the heap and removes it from the heap." } { $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } { $side-effects "heap" } ;
{ $see-also heap-pop* heap-push heap-peek } ;
HELP: heap-empty? HELP: heap-empty?
{ $values { "heap" heap } { "?" "a boolean" } } { $values { "heap" "a heap" } { "?" "a boolean" } }
{ $description "Tests if a " { $link heap } " has no nodes." } { $description "Tests if a heap has no nodes." } ;
{ $see-also heap-length heap-peek } ;
HELP: heap-length HELP: heap-size
{ $values { "heap" heap } { "n" integer } } { $values { "heap" "a heap" } { "n" integer } }
{ $description "Returns the number of key/value pairs in the heap." } { $description "Returns the number of key/value pairs in the heap." } ;
{ $see-also heap-empty? } ;
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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test USING: arrays kernel math namespaces tools.test
heaps heaps.private ; heaps heaps.private math.parser random assocs sequences sorting ;
IN: temporary IN: temporary
[ <min-heap> heap-pop ] must-fail [ <min-heap> heap-pop ] must-fail
@ -15,16 +15,8 @@ IN: temporary
! Binary Min Heap ! Binary Min Heap
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test { 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 { t } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test { f } [ t 5 f <entry> t 3 f <entry> 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 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 [ 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 [ 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 [ 0 ] [ <max-heap> heap-size ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test [ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
[ { { 1 2 } { 3 4 } { 5 6 } } ] [ : heap-sort ( alist -- keys )
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } <min-heap> [ heap-push-all ] keep heap-pop-all ;
[ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
] unit-test : random-alist ( n -- alist )
[ { { 1 2 } } ] [ [
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } } [
[ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make (random) dup number>string swap set
] unit-test ] times
[ { } ] [ ] H{ } make-assoc ;
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
[ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make : test-heap-sort ( n -- ? )
] unit-test 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. ! 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 IN: heaps
MIXIN: priority-queue MIXIN: priority-queue
GENERIC: heap-push ( value key heap -- ) GENERIC: heap-push* ( value key heap -- entry )
GENERIC: heap-peek ( heap -- value key ) GENERIC: heap-peek ( heap -- value key )
GENERIC: heap-pop* ( heap -- ) GENERIC: heap-pop* ( heap -- )
GENERIC: heap-pop ( heap -- value key ) GENERIC: heap-pop ( heap -- value key )
GENERIC: heap-delete ( key heap -- ) GENERIC: heap-delete ( entry heap -- )
GENERIC: heap-delete* ( key heap -- old ? )
GENERIC: heap-empty? ( heap -- ? ) GENERIC: heap-empty? ( heap -- ? )
GENERIC: heap-length ( heap -- n ) GENERIC: heap-size ( heap -- n )
GENERIC# heap-pop-while 2 ( heap pred quot -- )
<PRIVATE <PRIVATE
TUPLE: heap data ;
: heap-data delegate ; inline
: <heap> ( class -- heap ) : <heap> ( class -- heap )
>r V{ } clone heap construct-boa r> >r V{ } clone r> construct-delegate ; inline
construct-delegate ; inline
TUPLE: entry value key heap index ;
: <entry> ( value key heap -- entry ) f entry construct-boa ;
PRIVATE> PRIVATE>
TUPLE: min-heap ; TUPLE: min-heap ;
@ -34,23 +39,67 @@ TUPLE: max-heap ;
INSTANCE: min-heap priority-queue INSTANCE: min-heap priority-queue
INSTANCE: max-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 <PRIVATE
: left ( n -- m ) 2 * 1+ ; inline
: right ( n -- m ) 2 * 2 + ; inline : left ( n -- m ) 1 shift 1 + ; inline
: up ( n -- m ) 1- 2 /i ; inline
: left-value ( n heap -- obj ) >r left r> nth ; inline : right ( n -- m ) 1 shift 2 + ; inline
: right-value ( n heap -- obj ) >r right r> nth ; inline
: up-value ( n vec -- obj ) >r up r> nth ; inline : up ( n -- m ) 1- 2/ ; inline
: swap-up ( n vec -- ) >r dup up r> exchange ; inline
: last-index ( vec -- n ) length 1- ; 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 -- ? ) 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: min-heap heap-compare (heap-compare) > ;
M: max-heap heap-compare (heap-compare) < ; M: max-heap heap-compare (heap-compare) < ;
: heap-bounds-check? ( m heap -- ? ) : heap-bounds-check? ( m heap -- ? )
heap-data length >= ; inline heap-size >= ; inline
: left-bounds-check? ( m heap -- ? ) : left-bounds-check? ( m heap -- ? )
>r left r> heap-bounds-check? ; inline >r left r> heap-bounds-check? ; inline
@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ;
: right-bounds-check? ( m heap -- ? ) : right-bounds-check? ( m heap -- ? )
>r right r> heap-bounds-check? ; inline >r right r> heap-bounds-check? ; inline
: up-heap-continue? ( vec heap -- ? ) : continue? ( m up[m] heap -- ? )
>r [ last-index ] keep [ up-value ] keep peek r> [ data-nth swap ] keep [ data-nth ] keep
heap-compare ; inline heap-compare ; inline
: up-heap ( vec heap -- ) DEFER: up-heap
2dup up-heap-continue? [
>r dup last-index [ over swap-up ] keep : (up-heap) ( n heap -- )
up 1+ head-slice r> up-heap >r dup up r>
3dup continue? [
[ data-exchange ] 2keep up-heap
] [ ] [
2drop 3drop
] if ; ] if ;
: up-heap ( n heap -- )
over 0 > [ (up-heap) ] [ 2drop ] if ;
: (child) ( m heap -- n ) : (child) ( m heap -- n )
dupd 2dup right-value
[ heap-data left-value ] 2keep >r 2dup left-value r>
[ heap-data right-value ] keep heap-compare rot heap-compare
[ right ] [ left ] if ; [ right ] [ left ] if ;
: child ( m heap -- n ) : child ( m heap -- n )
2dup right-bounds-check? [ drop left ] [ (child) ] if ; 2dup right-bounds-check?
[ drop left ] [ (child) ] if ;
: swap-down ( m heap -- ) : swap-down ( m heap -- )
[ child ] 2keep heap-data exchange ; [ child ] 2keep data-exchange ;
DEFER: down-heap 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 -- ) : (down-heap) ( m heap -- )
2dup down-heap-continue? [ [ child ] 2keep swapd
-rot [ swap-down ] keep down-heap 3dup continue? [
] [
3drop 3drop
] [
[ data-exchange ] 2keep down-heap
] if ; ] if ;
: down-heap ( m heap -- ) : down-heap ( m heap -- )
@ -100,40 +152,43 @@ DEFER: down-heap
PRIVATE> PRIVATE>
M: priority-queue heap-push ( value key heap -- ) M: priority-queue heap-push* ( value key heap -- entry )
>r swap 2array r> [ <entry> dup ] keep [ data-push ] keep up-heap ;
[ heap-data push ] keep
[ heap-data ] keep : heap-push ( value key heap -- ) heap-push* drop ;
up-heap ;
: heap-push-all ( assoc heap -- ) : heap-push-all ( assoc heap -- )
[ swapd heap-push ] curry assoc-each ; [ swapd heap-push ] curry assoc-each ;
: >entry< ( entry -- key value )
{ entry-value entry-key } get-slots ;
M: priority-queue heap-peek ( heap -- value key ) 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 -- ) M: priority-queue heap-pop* ( heap -- )
dup heap-data length 1 > [ dup data-first swap heap-delete ;
[ heap-data pop ] keep
[ heap-data set-first ] keep
0 swap down-heap
] [
heap-data pop*
] if ;
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? ; : heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
M: priority-queue heap-length ( heap -- n ) heap-data length ; [ dup heap-pop swap 2array ]
[ ] unfold nip ;
: (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) ;

View File

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

View File

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

View File

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

View File

@ -154,3 +154,11 @@ M: pathname <=> [ pathname-string ] compare ;
: with-file-appender ( path quot -- ) : with-file-appender ( path quot -- )
>r <file-appender> r> with-stream ; inline >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+ ;

View File

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

View File

@ -64,7 +64,7 @@ M: object init-stdio
stdin-handle stdout-handle <duplex-c-stream> stdio set-global stdin-handle stdout-handle <duplex-c-stream> stdio set-global
stderr-handle <c-writer> <plain-writer> stderr 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> M: object <file-reader>
"rb" fopen <c-reader> <line-reader> ; "rb" fopen <c-reader> <line-reader> ;

View File

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

View File

@ -139,10 +139,6 @@ ARTICLE: "equality" "Equality and comparison testing"
! Defined in handbook.factor ! Defined in handbook.factor
ABOUT: "dataflow" ABOUT: "dataflow"
HELP: version
{ $values { "str" string } }
{ $description "Outputs the version number of the current Factor instance." } ;
HELP: eq? ( obj1 obj2 -- ? ) HELP: eq? ( obj1 obj2 -- ? )
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if two references point at the same object." } ; { $description "Tests if two references point at the same object." } ;

View File

@ -3,8 +3,6 @@
USING: kernel.private ; USING: kernel.private ;
IN: kernel IN: kernel
: version ( -- str ) "0.92" ; foldable
! Stack stuff ! Stack stuff
: spin ( x y z -- z y x ) swap rot ; inline : spin ( x y z -- z y x ) swap rot ; inline

View File

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

View File

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

View File

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

View File

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

View File

@ -5,6 +5,7 @@ IN: math
GENERIC: >fixnum ( x -- y ) foldable GENERIC: >fixnum ( x -- y ) foldable
GENERIC: >bignum ( x -- y ) foldable GENERIC: >bignum ( x -- y ) foldable
GENERIC: >integer ( x -- y ) foldable
GENERIC: >float ( x -- y ) foldable GENERIC: >float ( x -- y ) foldable
MATH: number= ( x y -- ? ) foldable MATH: number= ( x y -- ? ) foldable
@ -16,6 +17,11 @@ MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable 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 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" } } { $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ; { $description "Outputs the total time spent in garbage collection during this Factor session." } ;
HELP: data-room ( -- cards semi generations ) HELP: data-room ( -- cards 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" } } { $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
{ $description "Queries the runtime for memory usage information." } ; { $description "Queries the runtime for memory usage information." } ;
HELP: code-room ( -- code-free code-total ) HELP: code-room ( -- code-free code-total )

View File

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

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 kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private optimizer.backend classes inference.dataflow tuples.private

View File

@ -1,7 +1,7 @@
USING: arrays math parser tools.test kernel generic words USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations assocs sequences strings io.files definitions continuations
sorting tuples compiler.units ; sorting tuples compiler.units debugger ;
IN: temporary IN: temporary
[ [
@ -351,13 +351,18 @@ IN: temporary
<< file get parsed >> file set << file get parsed >> file set
: ~a ; : ~a ;
: ~b ~a ;
DEFER: ~b
"IN: temporary : ~b ~a ;" <string-reader>
"smudgy" parse-stream drop
: ~c ; : ~c ;
: ~d ; : ~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 } ] [ [ V{ ~b } { ~a } { ~a ~c } ] [
smudged-usage smudged-usage
@ -365,6 +370,24 @@ IN: temporary
] unit-test ] unit-test
] with-scope ] with-scope
[
<< file get parsed >> file set
GENERIC: ~e
: ~f ~e ;
: ~g ;
{ H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
{ H{ { ~g ~g } } H{ } } new-definitions set
[ V{ } { } { ~e ~f } ]
[ smudged-usage natural-sort ]
unit-test
] with-scope
[ ] [ [ ] [
"IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
] unit-test ] unit-test
@ -372,3 +395,38 @@ IN: temporary
[ t ] [ [ t ] [
"foo?" "temporary" lookup word eq? "foo?" "temporary" lookup word eq?
] unit-test ] 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

View File

@ -352,6 +352,8 @@ TUPLE: bad-number ;
: parse-definition ( -- quot ) : parse-definition ( -- quot )
\ ; parse-until >quotation ; \ ; parse-until >quotation ;
: (:) CREATE dup reset-generic parse-definition ;
GENERIC: expected>string ( obj -- str ) GENERIC: expected>string ( obj -- str )
M: f expected>string drop "end of input" ; M: f expected>string drop "end of input" ;
@ -439,11 +441,12 @@ SYMBOL: interactive-vocabs
"Warning: the following definitions were removed from sources," print "Warning: the following definitions were removed from sources," print
"but are still referenced from other definitions:" print "but are still referenced from other definitions:" print
nl nl
dup stack. dup sorted-definitions.
nl nl
"The following definitions need to be updated:" print "The following definitions need to be updated:" print
nl nl
over stack. over sorted-definitions.
nl
] when 2drop ; ] when 2drop ;
: filter-moved ( assoc -- newassoc ) : filter-moved ( assoc -- newassoc )
@ -463,9 +466,16 @@ SYMBOL: interactive-vocabs
dup values concat prune swap keys dup values concat prune swap keys
] keep ; ] 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 ( -- ) : forget-smudged ( -- )
smudged-usage forget-all 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 -- ) : finish-parsing ( lines quot -- )
file get file get
@ -499,7 +509,7 @@ SYMBOL: interactive-vocabs
] recover ; ] recover ;
: run-file ( file -- ) : run-file ( file -- )
[ [ parse-file call ] keep ] assert-depth drop ; [ dup parse-file call ] assert-depth drop ;
: ?run-file ( path -- ) : ?run-file ( path -- )
dup resource-exists? [ run-file ] [ drop ] if ; dup resource-exists? [ run-file ] [ drop ] if ;

View File

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

View File

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

View File

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

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

@ -11,7 +11,7 @@ unit-test
[ t ] [ [ t ] [
100 [ 100 [
drop 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? ] all?
] unit-test ] unit-test

View File

@ -52,7 +52,7 @@ PRIVATE>
: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ; : 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 ( seq -- elt )
[ midpoint@ ] keep nth-unsafe ; inline [ midpoint@ ] keep nth-unsafe ; inline

View File

@ -97,16 +97,8 @@ SYMBOL: file
[ ] [ file get rollback-source-file ] cleanup [ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline ] 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 ) : outside-usages ( seq -- usages )
dup [ dup [
over smart-usage [ pathname? not ] subset seq-diff over usage
[ dup pathname? not swap where and ] subset seq-diff
] curry { } map>assoc ; ] curry { } map>assoc ;

View File

@ -28,8 +28,8 @@ IN: temporary
[ "end" ] [ "Beginning and end" 14 tail ] unit-test [ "end" ] [ "Beginning and end" 14 tail ] unit-test
[ t ] [ "abc" "abd" <=> 0 < ] unit-test [ t ] [ "abc" "abd" before? ] unit-test
[ t ] [ "z" "abd" <=> 0 > ] unit-test [ t ] [ "z" "abd" after? ] unit-test
[ 0 10 "hello" subseq ] must-fail [ 0 10 "hello" subseq ] must-fail

View File

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

View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io USING: help.markup help.syntax kernel kernel.private io
threads.private continuations dlists init quotations strings threads.private continuations dlists init quotations strings
assocs heaps boxes ; assocs heaps boxes namespaces ;
IN: threads IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping 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" ARTICLE: "threads-yield" "Yielding and suspending threads"
"Yielding to other threads:" "Yielding to other threads:"
{ $subsection yield } { $subsection yield }
"Sleeping for a period of time:"
{ $subsection sleep } { $subsection sleep }
"Interrupting sleep:"
{ $subsection interrupt }
"Threads can be suspended and woken up at some point in the future when a condition is satisfied:" "Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
{ $subsection suspend } { $subsection suspend }
{ $subsection resume } { $subsection resume }
@ -102,9 +105,21 @@ HELP: stop
HELP: yield HELP: yield
{ $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ; { $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 HELP: sleep
{ $values { "ms" "a non-negative integer" } } { $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 HELP: suspend
{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } } { $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } }
@ -114,7 +129,10 @@ HELP: spawn
{ $values { "quot" quotation } { "name" string } } { $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." { $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 $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 { $examples
{ $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" } { $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" }
} ; } ;

View File

@ -13,7 +13,7 @@ TUPLE: thread
name quot error-handler exit-handler name quot error-handler exit-handler
id id
continuation state continuation state
mailbox variables ; mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline : self ( -- thread ) 40 getenv ; inline
@ -75,45 +75,65 @@ PRIVATE>
: sleep-queue 43 getenv ; : sleep-queue 43 getenv ;
: resume ( thread -- ) : resume ( thread -- )
f over set-thread-state
check-registered run-queue push-front ; check-registered run-queue push-front ;
: resume-now ( thread -- ) : resume-now ( thread -- )
f over set-thread-state
check-registered run-queue push-back ; check-registered run-queue push-back ;
: resume-with ( obj thread -- ) : resume-with ( obj thread -- )
f over set-thread-state
check-registered 2array run-queue push-front ; check-registered 2array run-queue push-front ;
<PRIVATE : sleep-time ( -- ms/f )
: 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 )
{ {
{ [ run-queue dlist-empty? not ] [ 0 ] } { [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] } { [ sleep-queue heap-empty? ] [ f ] }
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] } { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
} cond ; } 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 ( -- ) : stop ( -- )
self dup thread-exit-handler call self dup thread-exit-handler call
unregister-thread next ; unregister-thread next ;
@ -125,19 +145,33 @@ PRIVATE>
self swap call next self swap call next
] callcc1 2nip ; inline ] callcc1 2nip ; inline
: yield ( -- ) [ resume ] "yield" suspend drop ; : yield ( -- ) [ resume ] f suspend drop ;
: sleep ( ms -- ) GENERIC: sleep-until ( time/f -- )
>fixnum millis +
[ schedule-sleep ] curry M: integer sleep-until
"sleep" suspend drop ; [ 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 -- ) : (spawn) ( thread -- )
[ [
resume [ resume-now [
dup set-self dup set-self
dup register-thread dup register-thread
init-namespaces
V{ } set-catchstack V{ } set-catchstack
{ } set-retainstack { } set-retainstack
>r { } set-datastack r> >r { } set-datastack r>
@ -177,6 +211,7 @@ PRIVATE>
initial-thread global initial-thread global
[ drop f "Initial" [ die ] <thread> ] cache [ drop f "Initial" [ die ] <thread> ] cache
<box> over set-thread-continuation <box> over set-thread-continuation
f over set-thread-state
dup register-thread dup register-thread
set-self ; set-self ;

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 "IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ check-tuple? ] is? ] must-fail-with ] [ [ 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

View File

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

View File

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

View File

@ -76,9 +76,9 @@ $nl
ARTICLE: "declarations" "Declarations" 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." "Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word."
$nl $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 } { $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." } { $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: inline }
{ $subsection POSTPONE: foldable } { $subsection POSTPONE: foldable }

View File

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

View File

@ -111,9 +111,17 @@ compiled-crossref global [ H{ } assoc-like ] change-at
dup compiled-unxref dup compiled-unxref
compiled-crossref get delete-at ; compiled-crossref get delete-at ;
SYMBOL: +inlined+
SYMBOL: +called+
: compiled-usage ( word -- assoc ) : compiled-usage ( word -- assoc )
compiled-crossref get at ; 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 -- ) M: word redefined* ( word -- )
{ "inferred-effect" "no-effect" } reset-props ; { "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"

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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar combinators concurrency.messaging USING: arrays calendar combinators generic init kernel math
threads generic init kernel math namespaces sequences ; namespaces sequences heaps boxes threads debugger quotations
assocs ;
IN: alarms IN: alarms
TUPLE: alarm time quot ; TUPLE: alarm quot time interval entry ;
C: <alarm> alarm
<PRIVATE <PRIVATE
! for now a V{ }, eventually a min-heap to store alarms
SYMBOL: alarms SYMBOL: alarms
SYMBOL: alarm-receiver SYMBOL: alarm-thread
SYMBOL: alarm-looper
: add-alarm ( alarm -- ) : notify-alarm-thread ( -- )
alarms get-global push ; alarm-thread get-global interrupt ;
: remove-alarm ( alarm -- ) : check-alarm
alarms get-global delete ; 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 -- ) : <alarm> ( quot time frequency -- alarm )
dup delegate { check-alarm <box> alarm construct-boa ;
{ "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>
: register-alarm ( alarm -- ) : 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 -- ) : alarm-expired? ( alarm now -- ? )
"unregister" send-alarm ; >r alarm-time r> before=? ;
: change-alarm ( alarm-old alarm-new -- ) : reschedule-alarm ( alarm -- )
"register" send-alarm dup alarm-time over alarm-interval time+
"unregister" send-alarm ; over set-alarm-time
register-alarm ;
! Example: : call-alarm ( alarm -- )
! 5 seconds from-now [ "hi" print flush ] <alarm> register-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 ;

View File

@ -51,7 +51,7 @@ HINTS: random fixnum ;
dup keys >byte-array dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ; swap values >float-array unclip [ + ] accumulate swap add ;
:: select-random | seed chars floats | :: select-random ( seed chars floats -- elt )
floats seed random -rot floats seed random -rot
[ >= ] curry find drop [ >= ] curry find drop
chars nth-unsafe ; inline chars nth-unsafe ; inline
@ -62,7 +62,7 @@ HINTS: random fixnum ;
: write-description ( desc id -- ) : write-description ( desc id -- )
">" write write bl print ; inline ">" write write bl print ; inline
:: split-lines | n quot | :: split-lines ( n quot -- )
n line-length /mod n line-length /mod
[ [ line-length quot call ] times ] dip [ [ line-length quot call ] times ] dip
dup zero? [ drop ] quot if ; inline dup zero? [ drop ] quot if ; inline
@ -71,7 +71,7 @@ HINTS: random fixnum ;
write-description write-description
[ make-random-fasta ] 2curry split-lines ; inline [ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta | k len alu | :: make-repeat-fasta ( k len alu -- )
[let | kn [ alu length ] | [let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len + k len +

View File

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

View File

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

View 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

View File

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

View File

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

View File

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

View File

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

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

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 ;

View File

@ -4,7 +4,7 @@ USING: kernel words namespaces classes parser continuations
math math.parser math math.parser
combinators sequences splitting quotations arrays strings tools.time combinators sequences splitting quotations arrays strings tools.time
parser-combinators new-slots accessors assocs.lib parser-combinators new-slots accessors assocs.lib
combinators.cleave bake calendar ; combinators.cleave bake calendar calendar.format ;
IN: builder.util IN: builder.util
@ -99,3 +99,13 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
[ file-lines ] [ ] bi* [ file-lines ] [ ] bi*
maybe-tail* maybe-tail*
[ print ] each ; [ print ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: prettyprint
: to-file ( object file -- ) [ . ] with-file-writer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: failsafe ( quot -- ) [ drop ] recover ;

View File

@ -1,6 +1,6 @@
USING: alien alien.c-types arrays sequences math USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl 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 namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
combinators tools.time system combinators.lib combinators.cleave combinators tools.time system combinators.lib combinators.cleave
float-arrays continuations opengl.demo-support multiline float-arrays continuations opengl.demo-support multiline

View File

@ -39,12 +39,12 @@ IN: bunny.model
[ normals ] 2keep 3array [ normals ] 2keep 3array
] time ; ] time ;
: model-path "bun_zipper.ply" ; : model-path "bun_zipper.ply" temp-file ;
: model-url "http://factorcode.org/bun_zipper.ply" ; : model-url "http://factorcode.org/bun_zipper.ply" ;
: maybe-download ( -- path ) : maybe-download ( -- path )
model-path resource-path dup exists? [ model-path dup exists? [
"Downloading bunny from " write "Downloading bunny from " write
model-url dup print flush model-url dup print flush
over download-to over download-to

View File

@ -1,14 +1,15 @@
USING: arrays calendar kernel math sequences tools.test 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 [ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ 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 [ f ] [ 1900 leap-year? ] unit-test
[ t ] [ 1904 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 ] [ 2001 leap-year? ] unit-test
[ f ] [ 2006 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
2006 10 10 0 0 1 0 make-timestamp = ] unit-test 2006 10 10 0 0 1 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
2006 10 10 0 1 40 0 make-timestamp = ] unit-test 2006 10 10 0 1 40 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
2006 10 9 23 58 20 0 make-timestamp = ] unit-test 2006 10 9 23 58 20 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
2006 10 11 0 0 0 0 make-timestamp = ] unit-test 2006 10 11 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
2006 10 10 0 10 0 0 make-timestamp = ] unit-test 2006 10 10 0 10 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
2006 10 10 0 10 30 0 make-timestamp = ] unit-test 2006 10 10 0 10 30 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
2006 10 10 0 0 45 0 make-timestamp = ] unit-test 2006 10 10 0 0 45 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
2006 10 9 23 59 15 0 make-timestamp = ] unit-test 2006 10 9 23 59 15 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
2006 10 15 0 0 0 0 make-timestamp = ] unit-test 2006 10 15 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
2006 10 9 23 50 0 0 make-timestamp = ] unit-test 2006 10 9 23 50 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
2006 10 9 22 20 0 0 make-timestamp = ] unit-test 2006 10 9 22 20 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
2006 1 1 1 0 0 0 make-timestamp = ] unit-test 2006 1 1 1 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
2006 1 2 0 0 0 0 make-timestamp = ] unit-test 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
2005 12 31 0 0 0 0 make-timestamp = ] unit-test 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
2006 1 1 12 0 0 0 make-timestamp = ] unit-test 2006 1 1 12 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
2006 1 4 0 0 0 0 make-timestamp = ] unit-test 2006 1 4 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
2006 1 2 0 0 0 0 make-timestamp = ] unit-test 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
2005 12 31 0 0 0 0 make-timestamp = ] unit-test 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
2007 1 1 0 0 0 0 make-timestamp = ] unit-test 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
2005 1 1 0 0 0 0 make-timestamp = ] unit-test 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt [ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
2004 12 31 0 0 0 0 make-timestamp = ] unit-test 2004 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt [ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
2005 1 1 0 0 0 0 make-timestamp = ] unit-test 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
2006 12 1 0 0 0 0 make-timestamp = ] unit-test 2006 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
2007 1 1 0 0 0 0 make-timestamp = ] unit-test 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
2008 1 1 0 0 0 0 make-timestamp = ] unit-test 2008 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
2007 2 1 0 0 0 0 make-timestamp = ] unit-test 2007 2 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
2006 2 1 0 0 0 0 make-timestamp = ] unit-test 2006 2 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
2006 1 1 0 0 0 0 make-timestamp = ] unit-test 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
2005 12 1 0 0 0 0 make-timestamp = ] unit-test 2005 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
2005 11 1 0 0 0 0 make-timestamp = ] unit-test 2005 11 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
2004 12 1 0 0 0 0 make-timestamp = ] unit-test 2004 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
2004 1 1 0 0 0 0 make-timestamp = ] unit-test 2004 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt [ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
2005 3 1 0 0 0 0 make-timestamp = ] unit-test 2005 3 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
2003 3 1 0 0 0 0 make-timestamp = ] unit-test 2003 3 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
2006 1 1 0 0 0 0 make-timestamp = ] unit-test 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
2007 1 1 0 0 0 0 make-timestamp = ] unit-test 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
2005 1 1 0 0 0 0 make-timestamp = ] unit-test 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
1906 1 1 0 0 0 0 make-timestamp = ] unit-test 1906 1 1 0 0 0 0 <timestamp> = ] unit-test
! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt ! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test ! 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 [ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 60 ] [ 2004 2 29 0 0 0 0 make-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 make-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 make-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 make-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 make-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 12 31 0 0 0 0 <timestamp> dup = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt [ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
2009 1 1 0 0 10 0 make-timestamp = ] unit-test 2009 1 1 0 0 10 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt [ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
1998 12 31 23 59 50 0 make-timestamp = ] unit-test 1998 12 31 23 59 50 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone [ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
2004 1 1 11 0 0 0 make-timestamp = ] unit-test 2004 1 1 11 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone [ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
2004 1 1 16 0 0 0 make-timestamp = ] unit-test 2004 1 1 16 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone [ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
2004 1 1 13 30 0 0 make-timestamp = ] unit-test 2004 1 1 13 30 0 0 <timestamp> = ] unit-test
[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp [ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test 2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp [ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test 2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp [ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp [ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test [ t ] [ now timestamp>millis millis - 1000 < ] unit-test
[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test [ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test [ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test [ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
[ 0 ] [ : checktime+ now dup clone [ rot time+ drop ] keep = ;
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
[ 1 ] [ [ t ] [ 5 seconds checktime+ ] unit-test
"+01" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
[ -1 ] [ [ t ] [ 5 minutes checktime+ ] unit-test
"-01" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
[ -1-1/2 ] [ [ t ] [ 5 hours checktime+ ] unit-test
"-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
[ 1+1/2 ] [ [ t ] [ 5 days checktime+ ] unit-test
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test [ t ] [ 5 weeks checktime+ ] unit-test
[ t ] [ 5 months checktime+ ] unit-test
[ t ] [ 5 years checktime+ ] unit-test

View File

@ -1,20 +1,21 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io io.streams.string kernel math USING: arrays kernel math math.functions namespaces sequences
math.vectors math.functions math.parser namespaces sequences strings tuples system vocabs.loader calendar.backend threads
strings tuples system debugger combinators vocabs.loader new-slots accessors combinators ;
calendar.backend structs alien.c-types math.vectors
math.ranges shuffle ;
IN: calendar IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ; TUPLE: timestamp year month day hour minute second gmt-offset ;
C: <timestamp> timestamp 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 : month-names
{ {
@ -36,9 +37,14 @@ C: <dt> dt
: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ; : day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ; : day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
: average-month ( -- x ) : average-month 30+5/12 ; inline
#! length of average month in days : months-per-year 12 ; inline
30.41666666666667 ; : 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: a
SYMBOL: b SYMBOL: b
@ -48,6 +54,8 @@ SYMBOL: e
SYMBOL: y SYMBOL: y
SYMBOL: m SYMBOL: m
PRIVATE>
: julian-day-number ( year month day -- n ) : julian-day-number ( year month day -- n )
#! Returns a composite date number #! Returns a composite date number
#! Not valid before year -4800 #! Not valid before year -4800
@ -74,38 +82,31 @@ SYMBOL: m
e get 153 m get * 2 + 5 /i - 1+ e get 153 m get * 2 + 5 /i - 1+
] with-scope ; ] 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 ) : >date< ( timestamp -- year month day )
[ timestamp-year ] keep { year>> month>> day>> } get-slots ;
[ timestamp-month ] keep
timestamp-day ;
: >time< ( timestamp -- hour minute second ) : >time< ( timestamp -- hour minute second )
[ timestamp-hour ] keep { hour>> minute>> second>> } get-slots ;
[ timestamp-minute ] keep
timestamp-second ;
: zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ; : instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
: years ( n -- dt ) zero-dt [ set-dt-year ] keep ; : years ( n -- dt ) instant swap >>year ;
: months ( n -- dt ) zero-dt [ set-dt-month ] keep ; : months ( n -- dt ) instant swap >>month ;
: days ( n -- dt ) zero-dt [ set-dt-day ] keep ; : days ( n -- dt ) instant swap >>day ;
: weeks ( n -- dt ) 7 * days ; : weeks ( n -- dt ) 7 * days ;
: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ; : hours ( n -- dt ) instant swap >>hour ;
: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ; : minutes ( n -- dt ) instant swap >>minute ;
: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ; : seconds ( n -- dt ) instant swap >>second ;
: milliseconds ( n -- dt ) 1000 /f seconds ; : milliseconds ( n -- dt ) 1000 / seconds ;
: julian-day-number>timestamp ( n -- timestamp ) GENERIC: leap-year? ( obj -- ? )
julian-day-number>date 0 0 0 0 <timestamp> ;
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: +year ( timestamp x -- timestamp )
GENERIC: +month ( timestamp x -- timestamp ) GENERIC: +month ( timestamp x -- timestamp )
@ -116,96 +117,119 @@ GENERIC: +second ( timestamp x -- timestamp )
: /rem ( f n -- q r ) : /rem ( f n -- q r )
#! q is positive or negative, r is positive from 0 <= r < n #! 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 ) : float>whole-part ( float -- int float )
[ floor >integer ] keep over - ; [ 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 ) : adjust-leap-year ( timestamp -- timestamp )
dup >date< 29 = swap 2 = and swap leap-year? not and [ dup day>> 29 = over month>> 2 = pick leap-year? not and and
dup >r timestamp-year 3 1 r> [ set-date ] keep [ 3 >>month 1 >>day ] when ;
] when ;
: unless-zero >r dup zero? [ drop ] r> if ; inline
M: integer +year ( timestamp n -- timestamp ) M: integer +year ( timestamp n -- timestamp )
over timestamp-year + swap [ set-timestamp-year ] keep [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
adjust-leap-year ;
M: real +year ( timestamp n -- timestamp ) 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 ) M: integer +month ( timestamp n -- timestamp )
over timestamp-month + 12 /rem [ over month>> + months/years >r >>month r> +year ] unless-zero ;
dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month
+year ;
M: real +month ( timestamp n -- timestamp ) 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 ) M: integer +day ( timestamp n -- timestamp )
swap [ [
>date< julian-day-number + julian-day-number>timestamp over >date< julian-day-number + julian-day-number>date
] keep swap >r >time< r> [ set-time ] keep ; >r >r >>year r> >>month r> >>day
] unless-zero ;
M: real +day ( timestamp n -- timestamp ) 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 ) M: integer +hour ( timestamp n -- timestamp )
over timestamp-hour + 24 /rem pick set-timestamp-hour [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
+day ;
M: real +hour ( timestamp n -- timestamp ) 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 ) M: integer +minute ( timestamp n -- timestamp )
over timestamp-minute + 60 /rem pick [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
set-timestamp-minute +hour ;
M: real +minute ( timestamp n -- timestamp ) 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 ) M: number +second ( timestamp n -- timestamp )
over timestamp-second + 60 /rem >r >integer r> [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
pick set-timestamp-second +minute ;
: +dt ( timestamp dt -- timestamp ) : (time+)
dupd [ second>> +second ] keep
[ dt-second +second ] keep [ minute>> +minute ] keep
[ dt-minute +minute ] keep [ hour>> +hour ] keep
[ dt-hour +hour ] keep [ day>> +day ] keep
[ dt-day +day ] keep [ month>> +month ] keep
[ dt-month +month ] keep [ year>> +year ] keep ; inline
dt-year +year
swap timestamp-gmt-offset over set-timestamp-gmt-offset ;
: make-timestamp ( year month day hour minute second gmt-offset -- timestamp ) : +slots [ 2apply + ] curry 2keep ; inline
<timestamp> [ 0 seconds +dt ] keep
[ = [ "invalid timestamp" throw ] unless ] keep ;
: make-date ( year month day -- timestamp ) PRIVATE>
0 0 0 gmt-offset make-timestamp ;
: array>dt ( vec -- dt ) { dt f } swap append >tuple ; GENERIC# time+ 1 ( time dt -- time )
: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ;
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 ) : dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar #! Uses average month/year length since dt loses calendar
#! data #! data
tuple-slots 0 swap
{ 1 12 365.2425 8765.82 525949.2 31556952.0 } [ year>> + ] keep
v/ sum ; [ 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 * ; M: duration <=> [ dt>years ] compare ;
: dt>days ( dt -- x ) dt>years 365.2425 * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ; : dt>months ( dt -- x ) dt>years months-per-year * ;
: dt>minutes ( dt -- x ) dt>years 525949.2 * ; : dt>days ( dt -- x ) dt>years days-per-year * ;
: dt>seconds ( dt -- x ) dt>years 31556952 * ; : dt>hours ( dt -- x ) dt>years hours-per-year * ;
: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ; : 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 ) : convert-timezone ( timestamp n -- timestamp )
[ over timestamp-gmt-offset - hours +dt ] keep over gmt-offset>> over = [ drop ] [
over set-timestamp-gmt-offset ; [ over gmt-offset>> - hours time+ ] keep >>gmt-offset
] if ;
: >local-time ( timestamp -- timestamp ) : >local-time ( timestamp -- timestamp )
gmt-offset convert-timezone ; gmt-offset convert-timezone ;
@ -216,39 +240,54 @@ M: number +second ( timestamp n -- timestamp )
M: timestamp <=> ( ts1 ts2 -- n ) M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ; [ >gmt tuple-slots ] compare ;
: timestamp- ( timestamp timestamp -- seconds ) : (time-) ( timestamp timestamp -- n )
#! Exact calendar-time difference
[ >gmt ] 2apply [ >gmt ] 2apply
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; [ >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 ) : 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 ) : millis>timestamp ( n -- timestamp )
>r unix-1970 r> seconds +dt ; >r unix-1970 r> milliseconds time+ ;
: 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 ;
: timestamp>millis ( timestamp -- n )
unix-1970 (time-) 1000 * >integer ;
: gmt ( -- timestamp ) : gmt ( -- timestamp )
#! GMT time, right now #! GMT time, right now
unix-1970 millis 1000 /f seconds +dt ; unix-1970 millis milliseconds time+ ;
: now ( -- timestamp ) gmt >local-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 ( year month day -- n )
#! Zeller Congruence #! Zeller Congruence
@ -262,7 +301,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
GENERIC: days-in-year ( obj -- n ) GENERIC: days-in-year ( obj -- n )
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; 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 ) GENERIC: days-in-month ( obj -- n )
@ -274,7 +313,7 @@ M: array days-in-month ( obj -- n )
] if ; ] if ;
M: timestamp days-in-month ( timestamp -- n ) 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 ) GENERIC: day-of-week ( obj -- n )
@ -291,156 +330,20 @@ M: array day-of-year ( array -- n )
3dup day-counts rot head-slice sum + 3dup day-counts rot head-slice sum +
swap leap-year? [ swap leap-year? [
-roll -roll
pick 3 1 make-date >r make-date r> pick 3 1 <date> >r <date> r>
<=> 0 >= [ 1+ ] when after=? [ 1+ ] when
] [ ] [
3nip >r 3drop r>
] if ; ] if ;
M: timestamp day-of-year ( timestamp -- n ) M: timestamp day-of-year ( timestamp -- n )
{ timestamp-year timestamp-month timestamp-day } get-slots >date< 3array day-of-year ;
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 ;
: day-offset ( timestamp m -- timestamp n ) : day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline over day-of-week - ; inline
: day-this-week ( timestamp n -- timestamp ) : day-this-week ( timestamp n -- timestamp )
day-offset days +dt ; day-offset days time+ ;
: sunday ( timestamp -- timestamp ) 0 day-this-week ; : sunday ( timestamp -- timestamp ) 0 day-this-week ;
: monday ( timestamp -- timestamp ) 1 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 ; : saturday ( timestamp -- timestamp ) 6 day-this-week ;
: beginning-of-day ( timestamp -- new-timestamp ) : beginning-of-day ( timestamp -- new-timestamp )
clone dup >r 0 0 0 r> clone
{ set-timestamp-hour set-timestamp-minute set-timestamp-second } 0 >>hour
set-slots ; inline 0 >>minute
0 >>second ; inline
: beginning-of-month ( timestamp -- new-timestamp ) : 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-week ( timestamp -- new-timestamp )
beginning-of-day sunday ; beginning-of-day sunday ;
: beginning-of-year ( timestamp -- new-timestamp ) : beginning-of-year ( timestamp -- new-timestamp )
beginning-of-month 1 over set-timestamp-month ; beginning-of-month 1 >>month ;
: seconds-since-midnight ( timestamp -- x ) : time-since-midnight ( timestamp -- duration )
dup beginning-of-day timestamp- ; dup beginning-of-day time- ;
M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep from-now sleep-until ;
{ {
{ [ unix? ] [ "calendar.unix" ] } { [ unix? ] [ "calendar.unix" ] }

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

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 ;

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

View File

@ -24,7 +24,7 @@ IN: channels.examples
from swap dupd mod zero? not [ swap to ] [ 2drop ] if from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ; ] 3keep filter ;
:: (sieve) | prime c | ( prime c -- ) :: (sieve) ( prime c -- )
[let | p [ c from ] [let | p [ c from ]
newc [ <channel> ] | newc [ <channel> ] |
p prime to p prime to

View File

@ -1,6 +1,7 @@
IN: temporary IN: temporary
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types 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: { CLASS: {
{ +superclass+ "NSObject" } { +superclass+ "NSObject" }

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences USING: strings arrays hashtables assocs sequences
xml.writer xml.utilities kernel namespaces ; xml.writer xml.utilities kernel namespaces ;
IN: cocoa.plists
GENERIC: >plist ( obj -- tag ) GENERIC: >plist ( obj -- tag )

View File

@ -1,5 +1,5 @@
USING: kernel ; USING: kernel sequences macros ;
IN: combinators.cleave IN: combinators.cleave
@ -19,6 +19,22 @@ IN: combinators.cleave
: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline : 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 ! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -30,3 +46,14 @@ IN: combinators.cleave
: tetra* ( obj obj obj obj quot quot quot quot -- val val val val ) : tetra* ( obj obj obj obj quot quot quot quot -- val val val val )
>r roll >r tri* r> r> call ; inline >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 ;

View File

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

View File

@ -1,14 +1,27 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: concurrency.conditions
: notify-1 ( dlist -- ) : notify-1 ( dlist -- )
dup dlist-empty? dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
[ drop ] [ pop-back second resume-now ] if ;
: notify-all ( dlist -- ) : 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 -- ) : 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 ;

View File

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

View File

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

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"

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 ;

View File

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

View File

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

View File

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

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

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

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 ;

View File

@ -4,70 +4,6 @@ USING: help.syntax help.markup concurrency.messaging.private
threads kernel arrays quotations ; threads kernel arrays quotations ;
IN: concurrency.messaging 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 HELP: send
{ $values { "message" object } { $values { "message" object }
{ "thread" "a thread 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" } { $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 } ; { $see-also spawn } ;
ARTICLE: { "concurrency" "mailboxes" } "Mailboxes" ARTICLE: { "concurrency" "messaging" } "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." "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 $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." "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 $nl
@ -104,14 +40,9 @@ $nl
{ $subsection send } { $subsection send }
"A thread can get a message from its queue:" "A thread can get a message from its queue:"
{ $subsection receive } { $subsection receive }
{ $subsection receive } { $subsection receive-timeout }
{ $subsection receive-if } { $subsection receive-if }
"Mailboxes can be created and used directly:" { $subsection receive-if-timeout } ;
{ $subsection mailbox }
{ $subsection <mailbox> }
{ $subsection mailbox-get }
{ $subsection mailbox-put }
{ $subsection mailbox-empty? } ;
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" 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:" "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" } { $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." "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 } { $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:" "This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
{ $code "[" { $code "["
" [ 1 0 / \"This will not print\" print ] spawn-linked drop" " [ 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." "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 $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." "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" "synchronous-sends" } }
{ $subsection { "concurrency" "exceptions" } } ; { $subsection { "concurrency" "exceptions" } } ;

View File

@ -3,48 +3,10 @@
! !
USING: kernel threads vectors arrays sequences USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words namespaces tools.test continuations dlists strings math words
match quotations concurrency.messaging ; match quotations concurrency.messaging concurrency.mailboxes ;
IN: temporary IN: temporary
[ ] [ mailbox mailbox-data dlist-delete-all ] unit-test [ ] [ my-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
[ "received" ] [ [ "received" ] [
[ [

View File

@ -1,80 +1,11 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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. ! concurrency.
USING: kernel threads concurrency.mailboxes continuations
namespaces assocs random ;
IN: concurrency.messaging 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 -- ) GENERIC: send ( message process -- )
@ -86,25 +17,25 @@ GENERIC: send ( message process -- )
M: thread send ( message thread -- ) M: thread send ( message thread -- )
check-registered mailbox-of mailbox-put ; check-registered mailbox-of mailbox-put ;
: ?linked dup linked? [ rethrow ] when ; : my-mailbox self mailbox-of ;
: mailbox self mailbox-of ;
: receive ( -- message ) : 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 ) : 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 -- ) : rethrow-linked ( error process supervisor -- )
>r <linked> r> send ; >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 ) : spawn-linked ( quot name -- thread )
mailbox spawn-linked-to ; my-mailbox spawn-linked-to ;
TUPLE: synchronous data sender tag ; TUPLE: synchronous data sender tag ;
@ -116,17 +47,18 @@ TUPLE: reply data tag ;
: <reply> ( data synchronous -- reply ) : <reply> ( data synchronous -- reply )
synchronous-tag \ reply construct-boa ; 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 ) : send-synchronous ( message thread -- reply )
dup self eq? [ dup self eq? [
"Cannot synchronous send to myself" throw "Cannot synchronous send to myself" throw
] [ ] [
>r <synchronous> dup r> send [ >r <synchronous> dup r> send
over reply? [ [ synchronous-reply? ] curry receive-if
>r reply-tag r> synchronous-tag = reply-data
] [
2drop f
] if
] curry receive-if reply-data
] if ; ] if ;
: reply-synchronous ( message synchronous -- ) : reply-synchronous ( message synchronous -- )
@ -139,18 +71,18 @@ TUPLE: reply data tag ;
<PRIVATE <PRIVATE
: remote-processes ( -- hash ) : registered-processes ( -- hash )
\ remote-processes get-global ; \ registered-processes get-global ;
PRIVATE> PRIVATE>
: register-process ( name process -- ) : register-process ( name process -- )
swap remote-processes set-at ; swap registered-processes set-at ;
: unregister-process ( name -- ) : unregister-process ( name -- )
remote-processes delete-at ; registered-processes delete-at ;
: get-process ( name -- process ) : 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