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

Conflicts:

	extra/db/tuples/tuples.factor

.gitignore

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

Makefile

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

core/alien/alien-docs.factor

@@ -87,7 +87,7 @@ $nl
 HELP: alien-invoke-error
 { $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
     { $list
-        { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
+        { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
         { "The return type or parameter list references an unknown C type." }
         { "The symbol or library could not be found." }
         { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
@@ -103,7 +103,7 @@ HELP: alien-invoke
 HELP: alien-indirect-error
 { $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
     { $list
-        { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
+        { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
         { "The return type or parameter list references an unknown C type." }
         { "One of the three inputs to " { $link alien-indirect } " is not a literal value." }
     }
@@ -120,7 +120,7 @@ HELP: alien-indirect
 HELP: alien-callback-error
 { $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
     { $list
-        { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
+        { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
         { "The return type or parameter list references an unknown C type." }
         { "One of the four inputs to " { $link alien-callback } " is not a literal value." }
     }
@@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor"
 { $subsection alien-invoke }
 "Sometimes it is necessary to invoke a C function pointer, rather than a named C function:"
 { $subsection alien-indirect }
-"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
+"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"
 "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."

core/bootstrap/compiler/compiler.factor

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

core/bootstrap/primitives.factor

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

core/bootstrap/stage2.factor

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

core/classes/classes.factor

@@ -255,8 +255,7 @@ PRIVATE>
 
 : (define-class) ( word props -- )
     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
     t "class" set-word-prop ;
 

core/compiler/compiler-docs.factor

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

core/compiler/compiler.factor

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

core/compiler/tests/curry.factor

@@ -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
 
 [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test

core/compiler/tests/float.factor

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

core/compiler/tests/intrinsics.factor

@@ -1,10 +1,11 @@
 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.
 [ ] [ 1 [ drop ] compile-call ] unit-test

core/compiler/tests/simple.factor

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

core/compiler/tests/tuples.factor

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

core/compiler/units/units-docs.factor

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

core/compiler/units/units.factor

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

core/continuations/continuations-docs.factor

@@ -23,9 +23,10 @@ $nl
 "Two words raise an error in the innermost error handler for the current dynamic extent:"
 { $subsection throw }
 { $subsection rethrow }
-"Two words for establishing an error handler:"
+"Words for establishing an error handler:"
 { $subsection cleanup }
 { $subsection recover }
+{ $subsection ignore-errors }
 "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
 { $subsection "errors-restartable" }
 { $subsection "errors-post-mortem" } ;
@@ -148,6 +149,10 @@ HELP: recover
 { $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } }
 { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
 
+HELP: ignore-errors
+{ $values { "try" quotation } }
+{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
+
 HELP: rethrow
 { $values { "error" object } }
 { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }

core/continuations/continuations.factor

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

core/cpu/x86/32/32.factor

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

core/definitions/definitions.factor

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

core/generic/generic.factor

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

core/heaps/heaps-docs.factor

@@ -11,69 +11,72 @@ $nl
 { $subsection min-heap? }
 { $subsection <min-heap> }
 "Max-heaps sort their elements so that the maximum element is first:"
-{ $subsection min-heap }
+{ $subsection max-heap }
-{ $subsection min-heap? }
+{ $subsection max-heap? }
-{ $subsection <min-heap> }
+{ $subsection <max-heap> }
 "Both obey a protocol."
 $nl
 "Queries:"
 { $subsection heap-empty? }
-{ $subsection heap-length }
+{ $subsection heap-size }
 { $subsection heap-peek }
 "Insertion:"
 { $subsection heap-push }
+{ $subsection heap-push* }
 { $subsection heap-push-all }
 "Removal:"
 { $subsection heap-pop* }
-{ $subsection heap-pop } ;
+{ $subsection heap-pop }
+{ $subsection heap-delete } ;
 
 ABOUT: "heaps"
 
 HELP: <min-heap>
 { $values { "min-heap" min-heap } }
-{ $description "Create a new " { $link min-heap } "." }
+{ $description "Create a new " { $link min-heap } "." } ;
-{ $see-also <max-heap> } ;
 
 HELP: <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
-{ $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
-{ $values { "assoc" assoc } { "heap" heap } }
+{ $values { "assoc" assoc } { "heap" "a heap" } }
 { $description "Push every key/value pair of an assoc onto a heap." }
-{ $side-effects "heap" }
+{ $side-effects "heap" } ;
-{ $see-also heap-push heap-pop } ;
 
 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*
-{ $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
-{ $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?
-{ $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" } ;

core/heaps/heaps-tests.factor

@@ -1,8 +1,8 @@
-! Copyright 2007 Ryan Murphy
+! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: arrays kernel math namespaces tools.test
-heaps heaps.private ;
+heaps heaps.private math.parser random assocs sequences sorting ;
 IN: temporary
 
 [ <min-heap> heap-pop ] must-fail
@@ -15,16 +15,8 @@ IN: temporary
 
 ! Binary Min Heap
 { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
-{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
+{ 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
 
@@ -32,18 +24,51 @@ IN: temporary
 
 [ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
 
-[ 0 ] [ <max-heap> heap-length ] unit-test
+[ 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

core/heaps/heaps.factor

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

core/inference/class/class-tests.factor

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

core/inference/state/state-tests.factor

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

core/inference/state/state.factor

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

core/io/files/files.factor

@@ -154,3 +154,11 @@ M: pathname <=> [ pathname-string ] compare ;
 
 : with-file-appender ( path quot -- )
     >r <file-appender> r> with-stream ; inline
+
+: temp-directory ( -- path )
+    "temp" resource-path
+    dup exists? not
+      [ dup make-directory ]
+    when ;
+
+: temp-file ( name -- path ) temp-directory swap path+ ;

core/io/streams/c/c-tests.factor

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

core/io/streams/c/c.factor

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

core/io/thread/thread.factor

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

core/kernel/kernel-docs.factor

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

core/kernel/kernel.factor

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

core/layouts/layouts.factor

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

core/listener/listener.factor

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

core/math/integers/integers-docs.factor

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

core/math/integers/integers.factor

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

core/math/math.factor

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

core/memory/memory-docs.factor

@@ -47,8 +47,8 @@ HELP: gc-time ( -- n )
 { $values { "n" "a timestamp in milliseconds" } }
 { $description "Outputs the total time spent in garbage collection during this Factor session." } ;
 
-HELP: data-room ( -- cards semi generations )
+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." } ;
 
 HELP: code-room ( -- code-free code-total )

core/optimizer/math/math.factor

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

core/optimizer/optimizer-tests.factor

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

core/parser/parser-tests.factor

@@ -1,7 +1,7 @@
 USING: arrays math parser tools.test kernel generic words
 io.streams.string namespaces classes effects source-files
 assocs sequences strings io.files definitions continuations
-sorting tuples compiler.units ;
+sorting tuples compiler.units debugger ;
 IN: temporary
 
 [
@@ -351,13 +351,18 @@ IN: temporary
     << file get parsed >> file set
 
     : ~a ;
-    : ~b ~a ;
+
+    DEFER: ~b
+
+    "IN: temporary : ~b ~a ;" <string-reader>
+    "smudgy" parse-stream drop
+
     : ~c ;
     : ~d ;
 
-    { H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
+    { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
     
-    { H{ { ~d ~d } } H{ } } new-definitions set
+    { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
     
     [ V{ ~b } { ~a } { ~a ~c } ] [
         smudged-usage
@@ -365,6 +370,24 @@ IN: temporary
     ] unit-test
 ] with-scope
 
+[
+    << file get parsed >> file set
+
+    GENERIC: ~e
+
+    : ~f ~e ;
+
+    : ~g ;
+
+    { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
+    
+    { H{ { ~g ~g } } H{ } } new-definitions set
+
+    [ V{ } { } { ~e ~f } ]
+    [ smudged-usage natural-sort ]
+    unit-test
+] with-scope
+
 [ ] [
     "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
 ] unit-test
@@ -372,3 +395,38 @@ IN: temporary
 [ t ] [
     "foo?" "temporary" lookup word eq?
 ] unit-test
+
+[ ] [
+    "IN: temporary TUPLE: foo ; GENERIC: foo"
+    <string-reader> "redefining-a-class-5" parse-stream drop
+] unit-test
+
+[ ] [
+    "IN: temporary M: f foo ;"
+    <string-reader> "redefining-a-class-6" parse-stream drop
+] unit-test
+
+[ f ] [ f "foo" "temporary" lookup execute ] unit-test
+
+[ ] [
+    "IN: temporary TUPLE: foo ; GENERIC: foo"
+    <string-reader> "redefining-a-class-5" parse-stream drop
+] unit-test
+
+[ f ] [ f "foo" "temporary" lookup execute ] unit-test
+
+[ ] [
+    "IN: temporary TUPLE: foo ; GENERIC: foo"
+    <string-reader> "redefining-a-class-7" parse-stream drop
+] unit-test
+
+[ ] [
+    "IN: temporary TUPLE: foo ;"
+    <string-reader> "redefining-a-class-7" parse-stream drop
+] unit-test
+
+[ t ] [ "foo" "temporary" lookup symbol? ] unit-test
+
+[ "resource:core/parser/test/assert-depth.factor" run-file ]
+[ relative-overflow-stack { 1 2 3 } sequence= ]
+must-fail-with

core/parser/parser.factor

@@ -352,6 +352,8 @@ TUPLE: bad-number ;
 : parse-definition ( -- quot )
     \ ; parse-until >quotation ;
 
+: (:) CREATE dup reset-generic parse-definition ;
+
 GENERIC: expected>string ( obj -- str )
 
 M: f expected>string drop "end of input" ;
@@ -439,11 +441,12 @@ SYMBOL: interactive-vocabs
         "Warning: the following definitions were removed from sources," print
         "but are still referenced from other definitions:" print
         nl
-        dup stack.
+        dup sorted-definitions.
         nl
         "The following definitions need to be updated:" print
         nl
-        over stack.
+        over sorted-definitions.
+        nl
     ] when 2drop ;
 
 : filter-moved ( assoc -- newassoc )
@@ -463,9 +466,16 @@ SYMBOL: interactive-vocabs
         dup values concat prune swap keys
     ] keep ;
 
+: fix-class-words ( -- )
+    #! If a class word had a compound definition which was
+    #! removed, it must go back to being a symbol.
+    new-definitions get first2 diff
+    [ nip dup reset-generic define-symbol ] assoc-each ;
+
 : forget-smudged ( -- )
     smudged-usage forget-all
-    over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
+    over empty? [ 2dup smudged-usage-warning ] unless 2drop
+    fix-class-words ;
 
 : finish-parsing ( lines quot -- )
     file get
@@ -499,7 +509,7 @@ SYMBOL: interactive-vocabs
     ] recover ;
 
 : run-file ( file -- )
-    [ [ parse-file call ] keep ] assert-depth drop ;
+    [ dup parse-file call ] assert-depth drop ;
 
 : ?run-file ( path -- )
     dup resource-exists? [ run-file ] [ drop ] if ;

core/parser/test/assert-depth.factor

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

core/prettyprint/prettyprint.factor

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

core/sequences/sequences.factor

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

core/sorting/sorting-tests.factor

@@ -11,7 +11,7 @@ unit-test
 [ t ] [
     100 [
         drop
-        100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ <=> 0 <= ] monotonic?
+        100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
     ] all?
 ] unit-test
 

core/sorting/sorting.factor

@@ -52,7 +52,7 @@ PRIVATE>
 
 : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
 
-: sort-pair ( a b -- c d ) 2dup <=> 0 > [ swap ] when ;
+: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
 
 : midpoint ( seq -- elt )
     [ midpoint@ ] keep nth-unsafe ; inline

core/source-files/source-files.factor

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

core/strings/strings-tests.factor

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

core/syntax/syntax.factor

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

core/threads/threads-docs.factor

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

core/threads/threads.factor

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

core/tuples/tuples-tests.factor

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

core/tuples/tuples.factor

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

core/vocabs/loader/loader.factor

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

core/words/words-docs.factor

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

core/words/words-tests.factor

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

core/words/words.factor

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

cp_dir

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

extra/alarms/alarms-docs.factor

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

extra/alarms/alarms.factor

@@ -1,87 +1,91 @@
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators concurrency.messaging
+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
 
-TUPLE: alarm time quot ;
+TUPLE: alarm quot time interval entry ;
-
-C: <alarm> alarm
 
 <PRIVATE
 
-! for now a V{ }, eventually a min-heap to store 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" 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 ;

extra/benchmark/fasta/fasta.factor

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

extra/benchmark/mandel/mandel.factor

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

extra/benchmark/raytracer/raytracer.factor

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

extra/benchmark/reverse-complement/reverse-complement-tests.factor

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

extra/benchmark/reverse-complement/reverse-complement.factor

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

extra/benchmark/sockets/sockets.factor

@@ -34,10 +34,10 @@ IN: benchmark.sockets
 : socket-benchmarks
     10 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

extra/bootstrap/image/upload/upload.factor

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

extra/builder/builder.factor

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

extra/builder/common/common.factor

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

extra/builder/release/release.factor

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

extra/builder/util/util.factor

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

extra/bunny/bunny.factor

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

extra/bunny/model/model.factor

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

extra/calendar/calendar-tests.factor

@@ -1,14 +1,15 @@
 USING: arrays calendar kernel math sequences tools.test
-continuations system io.streams.string ;
+continuations system ;
 
-[ 2004 12 32 0   0  0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
+[ 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
 [ t ] [ 1904 leap-year? ] unit-test
@@ -16,148 +17,144 @@ continuations system io.streams.string ;
 [ f ] [ 2001 leap-year? ] unit-test
 [ f ] [ 2006 leap-year? ] unit-test
 
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt
+[ 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

extra/calendar/calendar.factor

@@ -1,20 +1,21 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: arrays hashtables io io.streams.string kernel math
+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
 
 TUPLE: timestamp year month day hour minute second gmt-offset ;
 
 C: <timestamp> timestamp
 
-TUPLE: dt year month day hour minute second ;
+: <date> ( year month day -- timestamp )
+    0 0 0 gmt-offset <timestamp> ;
 
-C: <dt> dt
+TUPLE: duration year month day hour minute second ;
+
+C: <duration> duration
 
 : month-names
     {
@@ -36,9 +37,14 @@ C: <dt> dt
 : day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
 : day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
 
-: average-month ( -- x )
+: 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: b
@@ -48,6 +54,8 @@ SYMBOL: e
 SYMBOL: y
 SYMBOL: m
 
+PRIVATE>
+
 : julian-day-number ( year month day -- n )
     #! Returns a composite date number
     #! Not valid before year -4800
@@ -74,38 +82,31 @@ SYMBOL: m
         e get 153 m get * 2 + 5 /i - 1+
     ] with-scope ;
 
-: set-date ( year month day timestamp -- )
-    [ set-timestamp-day ] keep
-    [ set-timestamp-month ] keep
-    set-timestamp-year ;
-
-: set-time ( hour minute second timestamp -- )
-    [ set-timestamp-second ] keep
-    [ set-timestamp-minute ] keep
-    set-timestamp-hour ;
-
 : >date< ( timestamp -- year month day )
-    [ timestamp-year ] keep
+    { year>> month>> day>> } get-slots ;
-    [ timestamp-month ] keep
-    timestamp-day ;
 
 : >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 ;
-: 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: +month ( timestamp x -- timestamp )
@@ -116,96 +117,119 @@ GENERIC: +second ( timestamp x -- timestamp )
 
 : /rem ( f n -- q r )
     #! q is positive or negative, r is positive from 0 <= r < n
-    [ /f floor >integer ] 2keep rem ;
+    [ / floor >integer ] 2keep rem ;
 
 : float>whole-part ( float -- int float )
     [ floor >integer ] keep over - ;
 
-GENERIC: leap-year? ( obj -- ? )
-M: integer leap-year? ( year -- ? )
-    dup 100 mod zero? 400 4 ? mod zero? ;
-
-M: timestamp leap-year? ( timestamp -- ? )
-    timestamp-year leap-year? ;
-
 : adjust-leap-year ( timestamp -- timestamp )
-    dup >date< 29 = swap 2 = and swap leap-year? not and [
+    dup 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 )
-    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 )
-    float>whole-part rot swap 365.2425 * +day swap +year ;
+    [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
+
+: months/years ( n -- months years )
+    12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
 
 M: integer +month ( timestamp n -- timestamp )
-    over timestamp-month + 12 /rem
+    [ 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 )
-    float>whole-part rot swap average-month * +day swap +month ;
+    [ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
 
 M: integer +day ( timestamp n -- timestamp )
-    swap [
+    [
-        >date< julian-day-number + julian-day-number>timestamp
+        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 )
-    float>whole-part rot swap 24 * +hour swap +day ;
+    [ float>whole-part swapd 24 * +hour swap +day ] unless-zero ;
+
+: hours/days ( n -- hours days )
+    24 /rem swap ;
 
 M: integer +hour ( timestamp n -- timestamp )
-    over timestamp-hour + 24 /rem pick set-timestamp-hour
+    [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
-    +day ;
+
 M: real +hour ( timestamp n -- timestamp )
-    float>whole-part rot swap 60 * +minute swap +hour ;
+    float>whole-part swapd 60 * +minute swap +hour ;
+
+: minutes/hours ( n -- minutes hours )
+    60 /rem swap ;
 
 M: integer +minute ( timestamp n -- timestamp )
-    over timestamp-minute + 60 /rem pick
+    [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
-    set-timestamp-minute +hour ;
+
 M: real +minute ( timestamp n -- timestamp )
-    float>whole-part rot swap 60 * +second swap +minute ;
+    [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
+
+: seconds/minutes ( n -- seconds minutes )
+    60 /rem swap >integer ;
 
 M: number +second ( timestamp n -- timestamp )
-    over timestamp-second + 60 /rem >r >integer r>
+    [ 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 )
     #! Uses average month/year length since dt loses calendar
     #! 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 )
-    [ 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 )
     gmt-offset convert-timezone ;
@@ -216,39 +240,54 @@ M: number +second ( timestamp n -- timestamp )
 M: timestamp <=> ( ts1 ts2 -- n )
     [ >gmt tuple-slots ] compare ;
 
-: timestamp- ( timestamp timestamp -- seconds )
+: (time-) ( timestamp timestamp -- n )
-    #! Exact calendar-time difference
     [ >gmt ] 2apply
     [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
     [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
 
+GENERIC: time- ( time1 time2 -- time )
+
+M: timestamp time-
+    #! Exact calendar-time difference
+    (time-) seconds ;
+
+: before ( dt -- -dt )
+    [ year>>   neg ] keep
+    [ month>>  neg ] keep
+    [ day>>    neg ] keep
+    [ hour>>   neg ] keep
+    [ minute>> neg ] keep
+      second>> neg
+    <duration> ;
+
+M: duration time-
+    before time+ ;
+
+: <zero> 0 0 0 0 0 0 0 <timestamp> ;
+
+: valid-timestamp? ( timestamp -- ? )
+    clone 0 >>gmt-offset
+    dup <zero> time- <zero> time+ = ;
+
 : unix-1970 ( -- timestamp )
-    1970 1 1 0 0 0 0 <timestamp> ;
+    1970 1 1 0 0 0 0 <timestamp> ; foldable
 
-: unix-time>timestamp ( n -- timestamp )
+: 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 time, right now
-    unix-1970 millis 1000 /f seconds +dt ;
+    unix-1970 millis milliseconds time+ ;
 
 : now ( -- timestamp ) gmt >local-time ;
-: before ( dt -- -dt ) tuple-slots vneg array>dt ;
-: from-now ( dt -- timestamp ) now swap +dt ;
-: ago ( dt -- timestamp ) before from-now ;
 
-: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
+: from-now ( dt -- timestamp ) now swap time+ ;
+: ago ( dt -- timestamp ) now swap time- ;
+
+: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
 
 : zeller-congruence ( year month day -- n )
     #! Zeller Congruence
@@ -262,7 +301,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
 GENERIC: days-in-year ( obj -- n )
 
 M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
-M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ;
+M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 
 GENERIC: days-in-month ( obj -- n )
 
@@ -274,7 +313,7 @@ M: array days-in-month ( obj -- n )
     ] if ;
 
 M: timestamp days-in-month ( timestamp -- n )
-    { timestamp-year timestamp-month } get-slots 2array days-in-month ;
+    >date< drop 2array days-in-month ;
 
 GENERIC: day-of-week ( obj -- n )
 
@@ -291,156 +330,20 @@ M: array day-of-year ( array -- n )
     3dup day-counts rot head-slice sum +
     swap leap-year? [
         -roll
-        pick 3 1 make-date >r make-date r>
+        pick 3 1 <date> >r <date> r>
-        <=> 0 >= [ 1+ ] when
+        after=? [ 1+ ] when
     ] [
-        3nip
+        >r 3drop r>
     ] if ;
 
 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 )
     over day-of-week - ; inline
 
 : day-this-week ( timestamp n -- timestamp )
-    day-offset days +dt ;
+    day-offset days time+ ;
 
 : sunday ( timestamp -- timestamp ) 0 day-this-week ;
 : monday ( timestamp -- timestamp ) 1 day-this-week ;
@@ -451,21 +354,26 @@ M: timestamp year. ( timestamp -- )
 : saturday ( timestamp -- timestamp ) 6 day-this-week ;
 
 : beginning-of-day ( timestamp -- new-timestamp )
-    clone dup >r 0 0 0 r>
+    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-day 1 over set-timestamp-day ;
+    beginning-of-day 1 >>day ;
 
 : beginning-of-week ( timestamp -- new-timestamp )
     beginning-of-day sunday ;
 
 : beginning-of-year ( timestamp -- new-timestamp )
-    beginning-of-month 1 over set-timestamp-month ;
+    beginning-of-month 1 >>month ;
 
-: seconds-since-midnight ( timestamp -- x )
+: 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" ] }

extra/calendar/format/format-tests.factor

@@ -0,0 +1,22 @@
+IN: temporary
+USING: calendar.format tools.test io.streams.string ;
+
+[ 0 ] [
+    "Z" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test
+
+[ 1 ] [
+    "+01" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test
+
+[ -1 ] [
+    "-01" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test
+
+[ -1-1/2 ] [
+    "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test
+
+[ 1+1/2 ] [
+    "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+] unit-test

extra/calendar/format/format.factor

@@ -0,0 +1,138 @@
+IN: calendar.format
+USING: math math.parser kernel sequences io calendar
+accessors arrays io.streams.string combinators accessors ;
+
+GENERIC: day. ( obj -- )
+
+M: integer day. ( n -- )
+    number>string dup length 2 < [ bl ] when write ;
+
+M: timestamp day. ( timestamp -- )
+    day>> day. ;
+
+GENERIC: month. ( obj -- )
+
+M: array month. ( pair -- )
+    first2
+    [ month-names nth write bl number>string print ] 2keep
+    [ 1 zeller-congruence ] 2keep
+    2array days-in-month day-abbreviations2 " " join print
+    over "   " <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 ;

extra/calendar/unix/unix-tests.factor

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

extra/channels/examples/examples.factor

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

extra/cocoa/cocoa-tests.factor

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

extra/cocoa/plists/plists.factor

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

extra/combinators/cleave/cleave.factor

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

extra/concurrency/combinators/combinators-tests.factor

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

extra/concurrency/conditions/conditions.factor

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

extra/concurrency/count-downs/count-downs.factor

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

extra/concurrency/exchangers/exchangers-tests.factor

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

extra/concurrency/flags/flags-docs.factor

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

extra/concurrency/flags/flags.factor

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

extra/concurrency/futures/futures.factor

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

extra/concurrency/locks/locks-tests.factor

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

extra/concurrency/locks/locks.factor

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

extra/concurrency/mailboxes/mailboxes-docs.factor

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

extra/concurrency/mailboxes/mailboxes-tests.factor

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

extra/concurrency/mailboxes/mailboxes.factor

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

extra/concurrency/messaging/messaging-docs.factor

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

extra/concurrency/messaging/messaging-tests.factor

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

extra/concurrency/messaging/messaging.factor

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