Merge git://factorcode.org/git/factor

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/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/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/math.factor

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

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

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/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:" [

extra/alarms/alarms-docs.factor

@@ -5,11 +5,11 @@ HELP: alarm
 { $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ;
 
 HELP: add-alarm
-{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "alarm" alarm } }
+{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } }
 { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
 
 HELP: later
-{ $values { "quot" quotation } { "time" dt } { "alarm" alarm } }
+{ $values { "quot" quotation } { "time" duration } { "alarm" alarm } }
 { $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;
 
 HELP: cancel-alarm

extra/alarms/alarms.factor

@@ -16,7 +16,7 @@ SYMBOL: alarm-thread
     alarm-thread get-global interrupt ;
 
 : check-alarm
-    dup dt? over not or [ "Not a dt" throw ] unless
+    dup duration? over not or [ "Not a duration" throw ] unless
     over timestamp? [ "Not a timestamp" throw ] unless
     pick callable? [ "Not a quotation" throw ] unless ; inline
 
@@ -29,10 +29,10 @@ SYMBOL: alarm-thread
     notify-alarm-thread ;
 
 : alarm-expired? ( alarm now -- ? )
-    >r alarm-time r> <=> 0 <= ;
+    >r alarm-time r> before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup alarm-time over alarm-interval +dt
+    dup alarm-time over alarm-interval time+
     over set-alarm-time
     register-alarm ;
 

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/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/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
-shuffle threads ;
 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,45 +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
 
 : millis>timestamp ( n -- timestamp )
-    >r unix-1970 r> 1000 /f seconds +dt ;
+    >r unix-1970 r> milliseconds time+ ;
 
 : timestamp>millis ( timestamp -- n )
-    unix-1970 timestamp- 1000 * >integer ;
+    unix-1970 (time-) 1000 * >integer ;
-
-: unix-time>timestamp ( n -- timestamp )
-    >r unix-1970 r> seconds +dt ;
-
-: timestamp>unix-time ( timestamp -- n )
-    unix-1970 timestamp- >integer ;
-
-: timestamp>timeval ( timestamp -- timeval )
-    timestamp>unix-time 1000 * make-timeval ;
-
-: timeval>timestamp ( timeval -- timestamp )
-    [ timeval-sec ] keep
-    timeval-usec 1000000 / + unix-time>timestamp ;
-
 
 : gmt ( -- timestamp )
     #! GMT time, right now
-    unix-1970 millis 1000 /f seconds +dt ;
+    unix-1970 millis milliseconds time+ ;
 
 : now ( -- timestamp ) gmt >local-time ;
-: before ( dt -- -dt ) tuple-slots vneg array>dt ;
-: from-now ( dt -- timestamp ) now swap +dt ;
-: ago ( dt -- timestamp ) before from-now ;
 
-: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
+: from-now ( dt -- timestamp ) now swap time+ ;
+: ago ( dt -- timestamp ) now swap time- ;
+
+: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
 
 : zeller-congruence ( year month day -- n )
     #! Zeller Congruence
@@ -268,7 +301,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
 GENERIC: days-in-year ( obj -- n )
 
 M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
-M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ;
+M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 
 GENERIC: days-in-month ( obj -- n )
 
@@ -280,7 +313,7 @@ M: array days-in-month ( obj -- n )
     ] if ;
 
 M: timestamp days-in-month ( timestamp -- n )
-    { timestamp-year timestamp-month } get-slots 2array days-in-month ;
+    >date< drop 2array days-in-month ;
 
 GENERIC: day-of-week ( obj -- n )
 
@@ -297,156 +330,20 @@ M: array day-of-year ( array -- n )
     3dup day-counts rot head-slice sum +
     swap leap-year? [
         -roll
-        pick 3 1 make-date >r make-date r>
+        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 ;
@@ -457,25 +354,26 @@ M: timestamp year. ( timestamp -- )
 : saturday ( timestamp -- timestamp ) 6 day-this-week ;
 
 : beginning-of-day ( timestamp -- new-timestamp )
-    clone dup >r 0 0 0 r>
+    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: dt sleep from-now 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/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/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/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/locks/locks-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs
 concurrency.messaging concurrency.mailboxes locals kernel
 threads sequences calendar ;
 
-:: lock-test-0 | |
+:: lock-test-0 ( -- )
     [let | v [ V{ } clone ]
            c [ 2 <count-down> ] |
 
@@ -27,7 +27,7 @@ threads sequences calendar ;
            v
     ] ;
 
-:: lock-test-1 | |
+:: lock-test-1 ( -- )
     [let | v [ V{ } clone ]
            l [ <lock> ]
            c [ 2 <count-down> ] |
@@ -79,7 +79,7 @@ threads sequences calendar ;
 
 [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
 
-:: rw-lock-test-1 | |
+:: rw-lock-test-1 ( -- )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 1 <count-down> ]
@@ -129,7 +129,7 @@ threads sequences calendar ;
 
 [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
 
-:: rw-lock-test-2 | |
+:: rw-lock-test-2 ( -- )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 2 <count-down> ]
@@ -160,7 +160,7 @@ threads sequences calendar ;
 [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
 
 ! Test lock timeouts
-:: lock-timeout-test | |
+:: lock-timeout-test ( -- )
     [let | l [ <lock> ] |
         [
             l [ 1 seconds sleep ] with-lock

extra/concurrency/semaphores/semaphores-docs.factor

@@ -9,7 +9,7 @@ HELP: <semaphore>
 { $description "Creates a counting semaphore with the specified initial count." } ;
 
 HELP: acquire-timeout
-{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "value" object } }
+{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "value" object } }
 { $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }
 { $errors "Throws an error if the timeout expires before the semaphore is released." } ;
 
@@ -22,7 +22,7 @@ HELP: release
 { $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;
 
 HELP: with-semaphore-timeout
-{ $values { "semaphore" semaphore } { "timeout" "a " { $link dt } " or " { $link f } } { "quot" quotation } }
+{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }
 { $description "Calls the quotation with the semaphore held." } ;
 
 HELP: with-semaphore

extra/crypto/md5/md5.factor

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

extra/farkup/farkup-tests.factor

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

extra/farkup/farkup.factor

@@ -3,23 +3,37 @@
 USING: arrays io kernel memoize namespaces peg
 peg.ebnf sequences strings html.elements xml.entities
 xmode.code2html splitting io.streams.string html
-html.elements sequences.deep unicode.categories ;
+html.elements sequences.deep ascii ;
+! unicode.categories ;
 USE: tools.walker
 IN: farkup
 
 MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
 
+: delimiters ( -- string )
+    "*_^~%=[-|\\\n" ; inline
+
 MEMO: text ( -- parser )
-    [ "*_^~%=[-|\n" member? not ] satisfy repeat1
+    [ delimiters member? not ] satisfy repeat1
     [ >string escape-string ] action ;
 
+MEMO: delimiter ( -- parser )
+    [ dup delimiters member? swap CHAR: \n = not and ] satisfy
+    [ 1string ] action ;
+
+: surround-with-foo ( string tag -- seq )
+    dup <foo> swap </foo> swapd 3array ;
+
 : delimited ( str html -- parser )
     [
         over token hide ,
-        text [ dup <foo> swap </foo> swapd 3array ] swapd curry action ,
+        text [ surround-with-foo ] swapd curry action ,
         token hide ,
     ] seq* ;
 
+MEMO: escaped-char ( -- parser )
+    [ "\\" token hide , any-char , ] seq* [ >string ] action ;
+
 MEMO: strong ( -- parser ) "*" "strong" delimited ;
 MEMO: emphasis ( -- parser ) "_" "em" delimited ;
 MEMO: superscript ( -- parser ) "^" "sup" delimited ;
@@ -29,6 +43,7 @@ MEMO: h1 ( -- parser ) "=" "h1" delimited ;
 MEMO: h2 ( -- parser ) "==" "h2" delimited ;
 MEMO: h3 ( -- parser ) "===" "h3" delimited ;
 MEMO: h4 ( -- parser ) "====" "h4" delimited ;
+MEMO: nl ( -- parser ) "\n" token ;
 MEMO: 2nl ( -- parser ) "\n\n" token hide ;
 
 : render-code ( string mode -- string' )
@@ -60,14 +75,23 @@ MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ;
 DEFER: line
 MEMO: list-item ( -- parser )
     [
-        "-" token hide ,
+        "-" token hide , line ,
-        line ,
+    ] seq* [ "li" surround-with-foo ] action ;
-    ] seq*
-    [ "li" <foo> swap "li" </foo> 3array ] action ;
 
 MEMO: list ( -- parser )
     list-item "\n" token hide list-of
-    [ "ul" <foo> swap "ul" </foo> 3array ] action ;
+    [ "ul" surround-with-foo ] action ;
+
+MEMO: table-column ( -- parser )
+    text [ "td" surround-with-foo ] action ;
+
+MEMO: table-row ( -- parser )
+    [
+        table-column "|" token hide list-of* ,
+    ] seq* [ "tr" surround-with-foo ] action ;
+
+MEMO: table ( -- parser )
+    table-row repeat1 [ "table" surround-with-foo ] action ;
 
 MEMO: code ( -- parser )
     [
@@ -81,30 +105,44 @@ MEMO: code ( -- parser )
         ] seq* [ concat ] action ,
     ] seq* [ first2 swap render-code ] action ;
 
-MEMO: table-column ( -- parser ) [ "|" token text ] seq* ;
-MEMO: table-row ( -- parser ) [ ] seq* ; 
-MEMO: table ( -- parser ) [ "[" ] seq* ;
-
 MEMO: line ( -- parser )
     [
         text , strong , emphasis , link ,
         superscript , subscript , inline-code ,
+        escaped-char , delimiter ,
     ] choice* repeat1 ;
 
 MEMO: paragraph ( -- parser )
+    line
+    "\n" token over 2seq repeat0
+    "\n" token "\n" token ensure-not 2seq optional 3seq
     [
-        line [
+        dup [ dup string? not swap [ blank? ] all? or ] deep-all?
-            dup [ [ blank? ] all? ] deep-all?
+        [ "<p>" swap "</p>" 3array ] unless
-            [ "<p>" swap "</p>" 3array ] unless
+    ] action ;
-        ] action ,
-        "\n" token hide ,
-    ] choice* ;
 
 MEMO: farkup ( -- parser )
     [
-        list , h1 , h2 , h3 , h4 , code , paragraph , 2nl ,
+        list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
-    ] choice* repeat1 ;
+    ] choice* repeat0 "\n" token optional 2seq ;
+
+: farkup. ( parse-result  -- )
+    parse-result-ast
+    [ dup string? [ write ] [ drop ] if ] deep-each ;
 
 : parse-farkup ( string -- string' )
-    farkup parse parse-result-ast
+    farkup parse [ farkup. ] with-string-writer ;
-    [ [ dup string? [ write ] [ drop ] if ] deep-each ] with-string-writer ;
+
+! MEMO: table-column ( -- parser )
+    ! text [ "td" surround-with-foo ] action ;
+! 
+! MEMO: table-row ( -- parser )
+    ! [
+        ! "|" token hide ,
+        ! table-column "|" token hide list-of ,
+        ! "|" token "\n" token 2array choice hide ,
+    ! ] seq* [ "tr" surround-with-foo ] action ;
+! 
+! MEMO: table ( -- parser )
+    ! table-row repeat1
+    ! [ "table" surround-with-foo ] action ;

extra/io/launcher/launcher-docs.factor

@@ -78,7 +78,7 @@ $nl
 "This is used in situations where you want a spawn child process with some overridden environment variables." } ;
 
 HELP: +timeout+
-{ $description "Launch descriptor key. If set to a " { $link dt } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
+{ $description "Launch descriptor key. If set to a " { $link duration } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
 
 HELP: default-descriptor
 { $description "Association storing default values for launch descriptor keys." } ;

extra/io/paths/paths.factor

@@ -1,5 +1,5 @@
 USING: io.files kernel sequences new-slots accessors
-dlists arrays ;
+dlists arrays sequences.lib ;
 IN: io.paths
 
 TUPLE: directory-iterator path bfs queue ;
@@ -34,19 +34,17 @@ TUPLE: directory-iterator path bfs queue ;
         drop r> r> r> 3drop f
     ] if ; inline
 
-: prepare-find-file ( path bfs? quot -- iter quot' )
-    >r <directory-iterator> r> [ keep and ] curry ; inline
-
 : find-file ( path bfs? quot -- path/f )
-    prepare-find-file iterate-directory ;
+    >r <directory-iterator> r>
+    [ keep and ] curry iterate-directory ; inline
+
+: each-file ( path bfs? quot -- )
+    >r <directory-iterator> r>
+    [ f ] compose iterate-directory drop ; inline
 
 : find-all-files ( path bfs? quot -- paths )
-    prepare-find-file V{ } clone [
+    >r <directory-iterator> r>
-        [ over [ push ] [ 2drop ] if f ] curry compose
+    pusher >r iterate-directory drop r> ; inline
-        iterate-directory
-        drop
-    ] keep ; inline
 
 : recursive-directory ( path bfs? -- paths )
-    <directory-iterator>
+    [ ] accumulator >r each-file r> ;
-    [ dup next-file dup ] [ ] [ drop ] unfold nip ;

extra/io/sniffer/bsd/bsd.factor

@@ -24,7 +24,7 @@ C: <sniffer-spec> sniffer-spec
 : IOC_INOUT      IOC_IN IOC_OUT bitor ; inline
 : IOC_DIRMASK    HEX: e0000000 ; inline
 
-:: ioc | inout group num len |
+:: ioc ( inout group num len -- n )
     group first 8 shift num bitor
     len IOCPARM_MASK bitand 16 shift bitor
     inout bitor ;

extra/io/timeouts/timeouts-docs.factor

@@ -2,11 +2,11 @@ IN: io.timeouts
 USING: help.markup help.syntax math kernel calendar ;
 
 HELP: timeout
-{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } }
+{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } }
 { $contract "Outputs an object's timeout." } ;
 
 HELP: set-timeout
-{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } }
+{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } }
 { $contract "Sets an object's timeout." } ;
 
 HELP: timed-out

extra/lcd/lcd.factor

@@ -1,4 +1,7 @@
-USING: sequences kernel math io ;
+USING: sequences kernel math io calendar calendar.format
+calendar.model arrays models namespaces ui.gadgets
+ui.gadgets.labels
+ui.gadgets.theme ui ;
 IN: lcd
 
 : lcd-digit ( row digit -- str )
@@ -6,14 +9,26 @@ IN: lcd
         "  _       _  _       _   _   _   _   _      "
         " | |  |   _| _| |_| |_  |_    | |_| |_|  *  "
         " |_|  |  |_  _|   |  _| |_|   | |_|   |  *  "
+        "                                            "
     } nth >r 4 * dup 4 + r> subseq ;
 
 : lcd-row ( num row -- string )
     [ swap lcd-digit ] curry { } map-as concat ;
 
 : lcd ( digit-str -- string )
-    3 [ lcd-row ] with map "\n" join ;
+    4 [ lcd-row ] with map "\n" join ;
 
-: lcd-demo ( -- ) "31337" lcd print ;
+: hh:mm:ss ( timestamp -- string )
+    {
+        timestamp-hour timestamp-minute timestamp-second
+    } get-slots >fixnum 3array [ pad-00 ] map ":" join ;
 
-MAIN: lcd-demo
+: <time-display> ( timestamp -- gadget )
+    [ hh:mm:ss lcd ] <filter> <label-control>
+    "99:99:99" lcd over set-label-string
+    monospace-font over set-label-font ;
+
+: time-window ( -- )
+    [ time get <time-display> "Time" open-window ] with-ui ;
+
+MAIN: time-window

extra/lcd/summary.txt

@@ -1 +1 @@
-7-segment numeric display demo
+7-segment LCD clock demo

extra/locals/locals-docs.factor

@@ -16,7 +16,7 @@ HELP: [|
 { $examples
     { $example
         "USE: locals"
-        ":: adder | n | [| m | m n + ] ;"
+        ":: adder ( n -- quot ) [| m | m n + ] ;"
         "3 5 adder call ."
         "8"
     }
@@ -29,7 +29,7 @@ HELP: [let
 { $examples
     { $example
         "USING: locals math.functions ;"
-        ":: frobnicate | n seq |"
+        ":: frobnicate ( n seq -- newseq )"
         "    [let | n' [ n 6 * ] |"
         "        seq [ n' gcd nip ] map ] ;"
         "6 { 36 14 } frobnicate ."
@@ -44,7 +44,7 @@ HELP: [wlet
 { $examples
     { $example
         "USE: locals"
-        ":: quuxify | n seq |"
+        ":: quuxify ( n seq -- newseq )"
         "    [wlet | add-n [| m | m n + ] |"
         "        seq [ add-n ] map ] ;"
         "2 { 1 2 3 } quuxify ."
@@ -57,13 +57,15 @@ HELP: with-locals
 { $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ;
 
 HELP: ::
-{ $syntax ":: word | bindings... | body... ;" }
+{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
 { $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
+{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." }
 { $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ;
 
 HELP: MACRO::
-{ $syntax "MACRO:: word | bindings... | body... ;" }
+{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" }
-{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } ;
+{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
+{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
 
 { POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
 
@@ -72,7 +74,7 @@ ARTICLE: "locals-mutable" "Mutable locals"
 $nl
 "Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
 { $code
-    ":: counter | |"
+    ":: counter ( -- )"
     "    [let | value! [ 0 ] |"
     "        [ value 1+ dup value! ]"
     "        [ value 1- dup value! ] ] ;"
@@ -86,7 +88,7 @@ ARTICLE: "locals-limitations" "Limitations of locals"
 $nl
 "Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:"
 { $code
-    ":: bad-cond-usage | a |"
+    ":: bad-cond-usage ( a -- ... )"
     "    { [ a 0 < ] [ ... ] }"
     "    { [ a 0 > ] [ ... ] }"
     "    { [ a 0 = ] [ ... ] } ;"

extra/locals/locals-tests.factor

@@ -1,52 +1,52 @@
 USING: locals math sequences tools.test hashtables words kernel
-namespaces arrays ;
+namespaces arrays strings prettyprint ;
 IN: temporary
 
-:: foo | a b | a a ;
+:: foo ( a b -- a a ) a a ;
 
 [ 1 1 ] [ 1 2 foo ] unit-test
 
-:: add-test | a b | a b + ;
+:: add-test ( a b -- c ) a b + ;
 
 [ 3 ] [ 1 2 add-test ] unit-test
 
-:: sub-test | a b | a b - ;
+:: sub-test ( a b -- c ) a b - ;
 
 [ -1 ] [ 1 2 sub-test ] unit-test
 
-:: map-test | a b | a [ b + ] map ;
+:: map-test ( a b -- seq ) a [ b + ] map ;
 
 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
 
-:: map-test-2 | seq inc | seq [| elt | elt inc + ] map ;
+:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
 
 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
 
-:: let-test | c |
+:: let-test ( c -- d )
     [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
 
 [ 7 ] [ 4 let-test ] unit-test
 
-:: let-test-2 | |
+:: let-test-2 ( a -- a )
-    [let | a [ ] | [let | b [ a ] | a ] ] ;
+    a [let | a [ ] | [let | b [ a ] | a ] ] ;
 
 [ 3 ] [ 3 let-test-2 ] unit-test
 
-:: let-test-3 | |
+:: let-test-3 ( a -- a )
-    [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
+    a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
 
-:: let-test-4 | |
+:: let-test-4 ( a -- b )
-    [let | a [ 1 ] b [ ] | a b 2array ] ;
+    a [let | a [ 1 ] b [ ] | a b 2array ] ;
 
 [ { 1 2 } ] [ 2 let-test-4 ] unit-test
 
-:: let-test-5 | |
+:: let-test-5 ( a -- b )
-    [let | a [ ] b [ ] | a b 2array ] ;
+    a [let | a [ ] b [ ] | a b 2array ] ;
 
 [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
 
-:: let-test-6 | |
+:: let-test-6 ( a -- b )
-    [let | a [ ] b [ 1 ] | a b 2array ] ;
+    a [let | a [ ] b [ 1 ] | a b 2array ] ;
 
 [ { 2 1 } ] [ 2 let-test-6 ] unit-test
 
@@ -57,26 +57,26 @@ IN: temporary
     with-locals
 ] unit-test
 
-:: wlet-test-2 | a b |
+:: wlet-test-2 ( a b -- seq )
     [wlet | add-b [ b + ] |
         a [ add-b ] map ] ;
 
 
 [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
     
-:: wlet-test-3 | a |
+:: wlet-test-3 ( a -- b )
     [wlet | add-a [ a + ] | [ add-a ] ]
     [let | a [ 3 ] | a swap call ] ;
 
 [ 5 ] [ 2 wlet-test-3 ] unit-test
 
-:: wlet-test-4 | a |
+:: wlet-test-4 ( a -- b )
     [wlet | sub-a [| b | b a - ] |
         3 sub-a ] ;
 
 [ -7 ] [ 10 wlet-test-4 ] unit-test
 
-:: write-test-1 | n! |
+:: write-test-1 ( n! -- q )
     [| i | n i + dup n! ] ;
 
 0 write-test-1 "q" set
@@ -89,7 +89,7 @@ IN: temporary
 
 [ 5 ] [ 2 "q" get call ] unit-test
 
-:: write-test-2 | |
+:: write-test-2 ( -- q )
     [let | n! [ 0 ] |
         [| i | n i + dup n! ] ] ;
 
@@ -108,21 +108,55 @@ write-test-2 "q" set
     20 10 [| a! | [| b! | a b ] ] with-locals call call
 ] unit-test
 
-:: write-test-3 | a! | [| b | b a! ] ;
+:: write-test-3 ( a! -- q ) [| b | b a! ] ;
 
 [ ] [ 1 2 write-test-3 call ] unit-test
 
-:: write-test-4 | x! | [ [let | y! [ 0 ] | f x! ] ] ;
+:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
 
 [ ] [ 5 write-test-4 drop ] unit-test
 
 SYMBOL: a
 
-:: use-test | a b c |
+:: use-test ( a b c -- a b c )
     USE: kernel ;
 
 [ t ] [ a symbol? ] unit-test
 
-:: let-let-test | n | [let | n [ n 3 + ] | n ] ;
+:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
 
 [ 13 ] [ 10 let-let-test ] unit-test
+
+GENERIC: lambda-generic ( a b -- c )
+
+GENERIC# lambda-generic-1 1 ( a b -- c )
+
+M:: integer lambda-generic-1 ( a b -- c ) a b * ;
+
+M:: string lambda-generic-1 ( a b -- c )
+    a b CHAR: x <string> lambda-generic ;
+
+M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
+
+GENERIC# lambda-generic-2 1 ( a b -- c )
+
+M:: integer lambda-generic-2 ( a b -- c )
+    a CHAR: x <string> b lambda-generic ;
+
+M:: string lambda-generic-2 ( a b -- c ) a b append ;
+
+M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
+
+[ 10 ] [ 5 2 lambda-generic ] unit-test
+
+[ "abab" ] [ "aba" "b" lambda-generic ] unit-test
+
+[ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
+
+[ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
+
+[ ] [ \ lambda-generic-1 see ] unit-test
+
+[ ] [ \ lambda-generic-2 see ] unit-test
+
+[ ] [ \ lambda-generic see ] unit-test

extra/locals/locals.factor

@@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
 inference.transforms parser words quotations debugger macros
 arrays macros splitting combinators prettyprint.backend
 definitions prettyprint hashtables combinators.lib
-prettyprint.sections sequences.private ;
+prettyprint.sections sequences.private effects generic
+compiler.units ;
 IN: locals
 
 ! Inspired by
@@ -208,9 +209,6 @@ M: object local-rewrite* , ;
 : push-locals ( assoc -- )
     use get push ;
 
-: parse-locals ( -- words assoc )
-    "|" parse-tokens make-locals ;
-
 : pop-locals ( assoc -- )
     use get delete ;
 
@@ -218,7 +216,7 @@ M: object local-rewrite* , ;
     over push-locals parse-until >quotation swap pop-locals ;
 
 : parse-lambda ( -- lambda )
-    parse-locals \ ] (parse-lambda) <lambda> ;
+    "|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
 
 : (parse-bindings) ( -- )
     scan dup "|" = [
@@ -246,11 +244,18 @@ M: wlet local-rewrite*
     dup wlet-bindings values over wlet-vars rot wlet-body
     <lambda> [ call ] curry compose local-rewrite* \ call , ;
 
-: (::) ( prop -- word quot n )
+: parse-locals
-    >r CREATE dup reset-generic
+    parse-effect
-    scan "|" assert= parse-locals \ ; (parse-lambda) <lambda>
+    word [ over "declared-effect" set-word-prop ] when*
-    2dup r> set-word-prop
+    effect-in make-locals ;
-    [ lambda-rewrite first ] keep lambda-vars length ;
+
+: ((::)) ( word -- word quot )
+    scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
+    2dup "lambda" set-word-prop
+    lambda-rewrite first ;
+
+: (::) ( -- word quot )
+    CREATE dup reset-generic ((::)) ;
 
 PRIVATE>
 
@@ -268,9 +273,22 @@ PRIVATE>
 
 MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 
-: :: "lambda" (::) drop define ; parsing
+: :: (::) define ; parsing
 
-: MACRO:: "lambda-macro" (::) (MACRO:) ; parsing
+! This will be cleaned up when method tuples and method words
+! are unified
+: create-method ( class generic -- method )
+    2dup method dup
+    [ 2nip method-word ]
+    [ drop 2dup [ ] -rot define-method create-method ] if ;
+
+: CREATE-METHOD ( -- class generic body )
+    scan-word bootstrap-word scan-word 2dup
+    create-method f set-word dup save-location ;
+
+: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
+
+: MACRO:: (::) define-macro ; parsing
 
 <PRIVATE
 
@@ -323,26 +341,42 @@ M: lambda-word definer drop \ :: \ ; ;
 M: lambda-word definition
     "lambda" word-prop lambda-body ;
 
-: lambda-word-synopsis ( word prop -- )
+: lambda-word-synopsis ( word -- )
-    over definer.
+    dup definer.
-    over seeing-word
+    dup seeing-word
-    over pprint-word
+    dup pprint-word
-    \ | pprint-word
+    stack-effect. ;
-    word-prop lambda-vars pprint-vars
-    \ | pprint-word ;
 
-M: lambda-word synopsis*
+M: lambda-word synopsis* lambda-word-synopsis ;
-    "lambda" lambda-word-synopsis ;
 
 PREDICATE: macro lambda-macro
-    "lambda-macro" word-prop >boolean ;
+    "lambda" word-prop >boolean ;
 
 M: lambda-macro definer drop \ MACRO:: \ ; ;
 
 M: lambda-macro definition
-    "lambda-macro" word-prop lambda-body ;
+    "lambda" word-prop lambda-body ;
 
-M: lambda-macro synopsis*
+M: lambda-macro synopsis* lambda-word-synopsis ;
-    "lambda-macro" lambda-word-synopsis ;
+
+PREDICATE: method-body lambda-method
+    "lambda" word-prop >boolean ;
+
+M: lambda-method definer drop \ M:: \ ; ;
+
+M: lambda-method definition
+    "lambda" word-prop lambda-body ;
+
+: method-stack-effect
+    dup "lambda" word-prop lambda-vars
+    swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
+    <effect> ;
+
+M: lambda-method synopsis*
+    dup definer.
+    dup "method" word-prop dup
+        method-specializer pprint*
+        method-generic pprint*
+    method-stack-effect effect>string comment. ;
 
 PRIVATE>

extra/logging/parser/parser.factor

@@ -3,7 +3,7 @@
 USING: parser-combinators memoize kernel sequences
 logging arrays words strings vectors io io.files
 namespaces combinators combinators.lib logging.server
-calendar ;
+calendar calendar.format ;
 IN: logging.parser
 
 : string-of satisfy <!*> [ >string ] <@ ;

extra/logging/server/server.factor

@@ -3,7 +3,7 @@
 USING: namespaces kernel io calendar sequences io.files
 io.sockets continuations prettyprint assocs math.parser
 words debugger math combinators concurrency.messaging
-threads arrays init math.ranges strings ;
+threads arrays init math.ranges strings calendar.format ;
 IN: logging.server
 
 : log-root ( -- string )

extra/macros/macros.factor

@@ -1,26 +1,21 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: parser kernel sequences words effects
-USING: parser kernel sequences words effects inference.transforms
+inference.transforms combinators assocs definitions quotations
-combinators assocs definitions quotations namespaces memoize ;
+namespaces memoize ;
-
 IN: macros
 
-: (:) ( -- word definition effect-in )
-    CREATE dup reset-generic parse-definition
-    over "declared-effect" word-prop effect-in length ;
-
 : real-macro-effect ( word -- effect' )
     "declared-effect" word-prop effect-in 1 <effect> ;
 
-: (MACRO:) ( word definition effect-in -- )
+: define-macro ( word definition -- )
-    >r 2dup "macro" set-word-prop
+    over "declared-effect" word-prop effect-in length >r
-    2dup over real-macro-effect memoize-quot
+    2dup "macro" set-word-prop
-    [ call ] append define
+    2dup over real-macro-effect memoize-quot [ call ] append define
     r> define-transform ;
 
 : MACRO:
-    (:) (MACRO:) ; parsing
+    (:) define-macro ; parsing
 
 PREDICATE: word macro "macro" word-prop >boolean ;
 

extra/math/miller-rabin/miller-rabin.factor

@@ -30,7 +30,7 @@ TUPLE: positive-even-expected n ;
     #! factor an integer into s * 2^r
     0 swap (factor-2s) ;
 
-:: (miller-rabin) | n prime?! |
+:: (miller-rabin) ( n prime?! -- ? )
     n 1- factor-2s s set r set
     trials get [
         n 1- [1,b] random a set

extra/models/models-docs.factor

@@ -153,7 +153,7 @@ HELP: delay
 } ;
 
 HELP: <delay>
-{ $values { "model" model } { "timeout" dt } { "delay" delay } }
+{ $values { "model" model } { "timeout" duration } { "delay" delay } }
 { $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
 { $examples "See the example in the documentation for " { $link delay } "." } ;
 

extra/new-slots/new-slots.factor

@@ -34,7 +34,7 @@ IN: new-slots
         [ \ over , swap writer-word , ] [ ] make define-inline
     ] [ 2drop ] if ;
 
-: changer-effect T{ effect f { "object" "quot" } } ; inline
+: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
 
 : changer-word ( name -- word )
     "change-" swap append changer-effect create-accessor ;
@@ -44,9 +44,9 @@ IN: new-slots
         [
             [ over >r >r ] %
             over reader-word ,
-            [ r> call r> ] %
+            [ r> call r> swap ] %
-            swap writer-word ,
+            swap setter-word ,
-        ] [ ] make define
+        ] [ ] make define-inline
     ] [ 2drop ] if ;
 
 : define-new-slot ( class slot name -- )

extra/opengl/capabilities/capabilities.factor

@@ -26,8 +26,8 @@ IN: opengl.capabilities
 : version-seq ( version-string -- version-seq )
     "." split [ string>number ] map ;
 
-: version<=> ( version1 version2 -- n )
+: version-before? ( version1 version2 -- ? )
-    swap version-seq swap version-seq <=> ;
+    swap version-seq swap version-seq before=? ;
 
 : (gl-version) ( -- version vendor )
     GL_VERSION glGetString " " split1 ;
@@ -36,7 +36,7 @@ IN: opengl.capabilities
 : gl-vendor-version ( -- version )
     (gl-version) nip ;
 : has-gl-version? ( version -- ? )
-    gl-version version<=> 0 <= ;
+    gl-version version-before? ;
 : (make-gl-version-error) ( required-version -- )
     "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
 : require-gl-version ( version -- )
@@ -51,7 +51,7 @@ IN: opengl.capabilities
 : glsl-vendor-version ( -- version )
     (glsl-version) nip ;
 : has-glsl-version? ( version -- ? )
-    glsl-version version<=> 0 <= ;
+    glsl-version version-before? ;
 : require-glsl-version ( version -- )
     [ has-glsl-version? ]
     [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]

extra/peg/peg.factor

@@ -306,12 +306,24 @@ MEMO: range ( min max -- parser )
 : seq ( seq -- parser )
   seq-parser construct-boa init-parser ;
 
+: 2seq ( parser1 parser2 -- parser )
+  2array seq ;
+
+: 3seq ( parser1 parser2 parser3 -- parser )
+  3array seq ;
+
 : seq* ( quot -- paser )
   { } make seq ; inline 
 
 : choice ( seq -- parser )
   choice-parser construct-boa init-parser ;
 
+: 2choice ( parser1 parser2 -- parser )
+  2array choice ;
+
+: 3choice ( parser1 parser2 parser3 -- parser )
+  3array choice ;
+
 : choice* ( quot -- paser )
   { } make choice ; inline 
 
@@ -342,8 +354,15 @@ MEMO: hide ( parser -- parser )
 MEMO: delay ( parser -- parser )
   delay-parser construct-boa init-parser ;
 
+MEMO: (list-of) ( items separator repeat1? -- parser )
+  >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
+  [ unclip 1vector swap first append ] action ;
+
 MEMO: list-of ( items separator -- parser )
-  hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ;
+  hide f (list-of) ;
+
+MEMO: list-of* ( items separator -- parser )
+  hide t (list-of) ;
 
 MEMO: 'digit' ( -- parser )
   [ digit? ] satisfy [ digit> ] action ;

extra/project-euler/019/019.factor

@@ -45,25 +45,20 @@ IN: project-euler.019
 <PRIVATE
 
 : start-date ( -- timestamp )
-    1901 1 1 0 0 0 0 make-timestamp ;
+    1901 1 1 <date> ;
 
 : end-date ( -- timestamp )
-    2000 12 31 0 0 0 0 make-timestamp ;
+    2000 12 31 <date> ;
 
-: (first-days) ( end-date start-date -- )
+: first-days ( end-date start-date -- days )
-    2dup timestamp- 0 >= [
+    [ 2dup after=? ]
-        dup day-of-week , 1 +month (first-days)
+    [ dup 1 months time+ swap day-of-week ]
-    ] [
+    [ ] unfold 2nip ;
-        2drop
-    ] if ;
-
-: first-days ( start-date end-date -- seq )
-    [ swap (first-days) ] { } make ;
 
 PRIVATE>
 
 : euler019a ( -- answer )
-    start-date end-date first-days [ zero? ] count ;
+    end-date start-date first-days [ zero? ] count ;
 
 ! [ euler019a ] 100 ave-time
 ! 131 ms run / 3 ms GC ave time - 100 trials

extra/smtp/smtp.factor

@@ -3,7 +3,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces io io.timeouts kernel logging io.sockets
 sequences combinators sequences.lib splitting assocs strings
-math.parser random system calendar ;
+math.parser random system calendar calendar.format ;
 
 IN: smtp
 

extra/tools/test/test.factor

@@ -48,9 +48,6 @@ SYMBOL: this-test
 : must-fail ( quot -- )
     [ drop t ] must-fail-with ;
 
-: ignore-errors ( quot -- )
-    [ drop ] recover ; inline
-
 : (run-test) ( vocab -- )
     dup vocab-source-loaded? [
         vocab-tests

extra/tools/walker/debug/debug.factor

@@ -5,7 +5,7 @@ sequences concurrency.messaging locals continuations
 threads namespaces namespaces.private ;
 IN: tools.walker.debug
 
-:: test-walker | quot |
+:: test-walker ( quot -- data )
     [let | p [ <promise> ]
            s [ f <model> ]
            c [ f <model> ] |

extra/trees/avl/avl.factor

@@ -53,14 +53,14 @@ TUPLE: avl-node balance ;
 DEFER: avl-set
 
 : avl-insert ( value key node -- node taller? )
-    2dup node-key key< left right ? [
+    2dup node-key before? left right ? [
         [ node-link avl-set ] keep swap
         >r tuck set-node-link r>
         [ dup current-side get change-balance balance-insert ] [ f ] if
     ] with-side ;
 
 : (avl-set) ( value key node -- node taller? )
-    2dup node-key key= [
+    2dup node-key = [
         -rot pick set-node-key over set-node-value f
     ] [ avl-insert ] if ;
 

extra/trees/trees.factor

@@ -61,10 +61,6 @@ SYMBOL: current-side
     #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
     <=> sgn ;
 
-: key< ( k1 k2 -- ? ) <=> 0 < ;
-: key> ( k1 k2 -- ? ) <=> 0 > ;
-: key= ( k1 k2 -- ? ) <=> zero? ;
-
 : random-side ( -- side ) left right 2array random ;
 
 : choose-branch ( key node -- key node-left/right )
@@ -72,7 +68,7 @@ SYMBOL: current-side
 
 : node-at* ( key node -- value ? )
     [
-        2dup node-key key= [
+        2dup node-key = [
             nip node-value t
         ] [
             choose-branch node-at*
@@ -97,8 +93,8 @@ M: tree set-at ( value key tree -- )
 
 : valid-node? ( node -- ? )
     [
-        dup dup node-left [ node-key swap node-key key< ] when* >r
+        dup dup node-left [ node-key swap node-key before? ] when* >r
-        dup dup node-right [ node-key swap node-key key> ] when* r> and swap
+        dup dup node-right [ node-key swap node-key after? ] when* r> and swap
         dup node-left valid-node? swap node-right valid-node? and and
     ] [ t ] if* ;
 

extra/ui/gadgets/editors/editors.factor

@@ -256,7 +256,7 @@ M: editor gadget-text* editor-string % ;
     } at T{ one-line-elt } or ;
 
 : drag-direction? ( loc editor -- ? )
-    editor-mark* <=> 0 < ;
+    editor-mark* before? ;
 
 : drag-selection-caret ( loc editor element -- loc )
     >r [ drag-direction? ] 2keep

extra/ui/windows/windows.factor

@@ -85,7 +85,7 @@ SYMBOL: mouse-captured
 : handle-wm-paint ( hWnd uMsg wParam lParam -- )
     #! wParam and lParam are unused
     #! only paint if width/height both > 0
-    3drop window relayout-1 ;
+    3drop window relayout-1 yield ;
 
 : handle-wm-size ( hWnd uMsg wParam lParam -- )
     2nip

extra/vocabs/monitor/monitor.factor

@@ -17,6 +17,6 @@ SYMBOL: vocab-monitor
     [
         "" resource-path t <monitor> vocab-monitor set-global
         [ monitor-thread t ] "Vocabulary monitor" spawn-server drop
-    ] [ drop ] recover ;
+    ] ignore-errors ;
 
 [ start-monitor-thread ] "vocabs.monitor" add-init-hook

extra/webapps/cgi/cgi.factor

@@ -14,7 +14,7 @@ SYMBOL: cgi-root
     [
         "CGI/1.0" "GATEWAY_INTERFACE" set
         "HTTP/1.0" "SERVER_PROTOCOL" set
-        "Factor " version append "SERVER_SOFTWARE" set
+        "Factor" "SERVER_SOFTWARE" set
 
         dup "PATH_TRANSLATED" set
         "SCRIPT_FILENAME" set

extra/webapps/file/file.factor

@@ -3,7 +3,7 @@
 USING: calendar html io io.files kernel math math.parser
 http.server.responders http.server.templating namespaces parser
 sequences strings assocs hashtables debugger http.mime sorting
-html.elements logging ;
+html.elements logging calendar.format ;
 IN: webapps.file
 
 SYMBOL: doc-root
@@ -11,6 +11,9 @@ SYMBOL: doc-root
 : serving-path ( filename -- filename )
     "" or doc-root get swap path+ ;
 
+: unix-time>timestamp ( n -- timestamp )
+    >r unix-1970 r> seconds time+ ;
+
 : file-http-date ( filename -- string )
     file-modified unix-time>timestamp timestamp>http-string ;
 

extra/webapps/pastebin/pastebin.factor

@@ -1,6 +1,6 @@
 USING: calendar furnace furnace.validator io.files kernel
 namespaces sequences http.server.responders html math.parser rss
-xml.writer xmode.code2html math ;
+xml.writer xmode.code2html math calendar.format ;
 IN: webapps.pastebin
 
 TUPLE: pastebin pastes ;

extra/webapps/planet/planet.factor

@@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency.combinators kernel
 sorting html.elements io assocs namespaces math threads vocabs
 html furnace http.server.templating calendar math.parser
 splitting continuations debugger system http.server.responders
-xml.writer prettyprint logging ;
+xml.writer prettyprint logging calendar.format ;
 IN: webapps.planet
 
 : print-posting-summary ( posting -- )

extra/windows/time/time-tests.factor

@@ -2,5 +2,5 @@ USING: calendar calendar.windows kernel tools.test ;
 
 [ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test
 [ t ] [ windows-time [ windows-time>FILETIME FILETIME>windows-time ] keep = ] unit-test
-[ t ] [ windows-1601 400 years +dt [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test
+[ t ] [ windows-1601 400 years time+ [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test
 

extra/windows/time/time.factor

@@ -15,7 +15,7 @@ IN: windows.time
     FILETIME-dwHighDateTime >64bit ;
 
 : windows-time>timestamp ( n -- timestamp )
-    10000000 /i seconds windows-1601 swap +dt ;
+    10000000 /i seconds windows-1601 swap time+ ;
 
 : windows-time ( -- n )
     "FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
@@ -23,7 +23,7 @@ IN: windows.time
 
 : timestamp>windows-time ( timestamp -- n )
     #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
-    >gmt windows-1601 timestamp- >bignum 10000000 * ;
+    >gmt windows-1601 (time-) 10000000 * >integer ;
 
 : windows-time>FILETIME ( n -- FILETIME )
     "FILETIME" <c-object>

extra/xml-rpc/xml-rpc.factor

@@ -3,7 +3,8 @@
 IN: xml-rpc
 USING: kernel xml arrays math generic http.client combinators
     hashtables namespaces io base64 sequences strings calendar
-    xml.data xml.writer xml.utilities assocs math.parser debugger ;
+    xml.data xml.writer xml.utilities assocs math.parser debugger
+    calendar.format ;
 
 ! * Sending RPC requests
 ! TODO: time