Merge git://factorcode.org/git/factor
Eduardo Cavazos
commit
c8496a3eff
|
|
@ -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." }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays hashtables io kernel math memory namespaces
|
||||
parser sequences strings io.styles io.streams.lines
|
||||
USING: arrays hashtables io kernel math math.parser memory
|
||||
namespaces parser sequences strings io.styles io.streams.lines
|
||||
io.streams.duplex vectors words generic system combinators
|
||||
tuples continuations debugger definitions compiler.units ;
|
||||
IN: listener
|
||||
|
|
@ -63,7 +63,7 @@ M: duplex-stream stream-read-quot
|
|||
[ listen until-quit ] if ; inline
|
||||
|
||||
: print-banner ( -- )
|
||||
"Factor " write version write
|
||||
"Factor #" write build number>string write
|
||||
" on " write os write "/" write cpu print ;
|
||||
|
||||
: listener ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -28,8 +28,8 @@ IN: temporary
|
|||
|
||||
[ "end" ] [ "Beginning and end" 14 tail ] unit-test
|
||||
|
||||
[ t ] [ "abc" "abd" <=> 0 < ] unit-test
|
||||
[ t ] [ "z" "abd" <=> 0 > ] unit-test
|
||||
[ t ] [ "abc" "abd" before? ] unit-test
|
||||
[ t ] [ "z" "abd" after? ] unit-test
|
||||
|
||||
[ 0 10 "hello" subseq ] must-fail
|
||||
|
||||
|
|
|
|||
|
|
@ -107,7 +107,7 @@ IN: bootstrap.syntax
|
|||
] define-syntax
|
||||
|
||||
":" [
|
||||
CREATE dup reset-generic parse-definition define
|
||||
(:) define
|
||||
] define-syntax
|
||||
|
||||
"GENERIC:" [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 +
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
USING: arrays calendar kernel math sequences tools.test
|
||||
continuations system io.streams.string ;
|
||||
continuations system ;
|
||||
|
||||
[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
|
||||
[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
|
||||
[ t ] [ now valid-timestamp? ] unit-test
|
||||
|
||||
[ f ] [ 1900 leap-year? ] unit-test
|
||||
[ t ] [ 1904 leap-year? ] unit-test
|
||||
|
|
@ -16,148 +17,144 @@ continuations system io.streams.string ;
|
|||
[ f ] [ 2001 leap-year? ] unit-test
|
||||
[ f ] [ 2006 leap-year? ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt
|
||||
2006 10 10 0 0 1 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt
|
||||
2006 10 10 0 1 40 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt
|
||||
2006 10 9 23 58 20 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt
|
||||
2006 10 11 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
|
||||
2006 10 10 0 0 1 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
|
||||
2006 10 10 0 1 40 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
|
||||
2006 10 9 23 58 20 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
|
||||
2006 10 11 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt
|
||||
2006 10 10 0 10 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt
|
||||
2006 10 10 0 10 30 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt
|
||||
2006 10 10 0 0 45 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt
|
||||
2006 10 9 23 59 15 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
|
||||
2006 10 10 0 10 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
|
||||
2006 10 10 0 10 30 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
|
||||
2006 10 10 0 0 45 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
|
||||
2006 10 9 23 59 15 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt
|
||||
2006 10 15 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt
|
||||
2006 10 9 23 50 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt
|
||||
2006 10 9 22 20 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
|
||||
2006 10 15 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
|
||||
2006 10 9 23 50 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
|
||||
2006 10 9 22 20 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt
|
||||
2006 1 1 1 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt
|
||||
2006 1 2 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt
|
||||
2005 12 31 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt
|
||||
2006 1 1 12 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt
|
||||
2006 1 4 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
|
||||
2006 1 1 1 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
|
||||
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
|
||||
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
|
||||
2006 1 1 12 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
|
||||
2006 1 4 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt
|
||||
2006 1 2 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt
|
||||
2005 12 31 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt
|
||||
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt
|
||||
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt
|
||||
2004 12 31 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt
|
||||
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
|
||||
2006 1 2 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
|
||||
2005 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
|
||||
2004 12 31 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt
|
||||
2006 12 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt
|
||||
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt
|
||||
2008 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt
|
||||
2007 2 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt
|
||||
2006 2 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt
|
||||
2006 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt
|
||||
2005 12 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt
|
||||
2005 11 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt
|
||||
2004 12 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt
|
||||
2004 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt
|
||||
2005 3 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt
|
||||
2003 3 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
|
||||
2006 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
|
||||
2008 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
|
||||
2007 2 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
|
||||
2006 2 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
|
||||
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
|
||||
2005 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
|
||||
2005 11 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
|
||||
2004 12 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
|
||||
2004 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
|
||||
2005 3 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
|
||||
2003 3 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt
|
||||
2006 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt
|
||||
2007 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt
|
||||
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt
|
||||
1906 1 1 0 0 0 0 make-timestamp = ] unit-test
|
||||
! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt
|
||||
! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
|
||||
2006 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
|
||||
2007 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
|
||||
2005 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
|
||||
1906 1 1 0 0 0 0 <timestamp> = ] unit-test
|
||||
! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
|
||||
! 2003 2 28 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ 5 ] [ 2006 7 14 0 0 0 0 make-timestamp day-of-week ] unit-test
|
||||
[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
|
||||
|
||||
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 make-timestamp ] 3keep 0 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test
|
||||
[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
|
||||
|
||||
[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt
|
||||
2009 1 1 0 0 10 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt
|
||||
1998 12 31 23 59 50 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
|
||||
2009 1 1 0 0 10 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
|
||||
1998 12 31 23 59 50 0 <timestamp> = ] unit-test
|
||||
|
||||
[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone
|
||||
2004 1 1 11 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone
|
||||
2004 1 1 16 0 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone
|
||||
2004 1 1 13 30 0 0 make-timestamp = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
|
||||
2004 1 1 11 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
|
||||
2004 1 1 16 0 0 0 <timestamp> = ] unit-test
|
||||
[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
|
||||
2004 1 1 13 30 0 0 <timestamp> = ] unit-test
|
||||
|
||||
[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp
|
||||
2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test
|
||||
[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
|
||||
2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp
|
||||
2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test
|
||||
[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
|
||||
2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
|
||||
|
||||
[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp
|
||||
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
|
||||
[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
|
||||
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
|
||||
|
||||
[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp
|
||||
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
|
||||
[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
|
||||
2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
|
||||
|
||||
[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test
|
||||
[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test
|
||||
[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
|
||||
[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
|
||||
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
|
||||
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
|
||||
[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
|
||||
[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
: checktime+ now dup clone [ rot time+ drop ] keep = ;
|
||||
|
||||
[ 1 ] [
|
||||
"+01" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
[ t ] [ 5 seconds checktime+ ] unit-test
|
||||
|
||||
[ -1 ] [
|
||||
"-01" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
[ t ] [ 5 minutes checktime+ ] unit-test
|
||||
|
||||
[ -1-1/2 ] [
|
||||
"-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
[ t ] [ 5 hours checktime+ ] unit-test
|
||||
|
||||
[ 1+1/2 ] [
|
||||
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
|
||||
] unit-test
|
||||
[ t ] [ 5 days checktime+ ] unit-test
|
||||
|
||||
[ t ] [ 5 weeks checktime+ ] unit-test
|
||||
|
||||
[ t ] [ 5 months checktime+ ] unit-test
|
||||
|
||||
[ t ] [ 5 years checktime+ ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,20 +1,21 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: arrays hashtables io io.streams.string kernel math
|
||||
math.vectors math.functions math.parser namespaces sequences
|
||||
strings tuples system debugger combinators vocabs.loader
|
||||
calendar.backend structs alien.c-types math.vectors
|
||||
shuffle threads ;
|
||||
USING: arrays kernel math math.functions namespaces sequences
|
||||
strings tuples system vocabs.loader calendar.backend threads
|
||||
new-slots accessors combinators ;
|
||||
IN: calendar
|
||||
|
||||
TUPLE: timestamp year month day hour minute second gmt-offset ;
|
||||
|
||||
C: <timestamp> timestamp
|
||||
|
||||
TUPLE: dt year month day hour minute second ;
|
||||
: <date> ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset <timestamp> ;
|
||||
|
||||
C: <dt> dt
|
||||
TUPLE: duration year month day hour minute second ;
|
||||
|
||||
C: <duration> duration
|
||||
|
||||
: month-names
|
||||
{
|
||||
|
|
@ -36,9 +37,14 @@ C: <dt> dt
|
|||
: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
|
||||
: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
|
||||
|
||||
: average-month ( -- x )
|
||||
#! length of average month in days
|
||||
30.41666666666667 ;
|
||||
: average-month 30+5/12 ; inline
|
||||
: months-per-year 12 ; inline
|
||||
: days-per-year 3652425/10000 ; inline
|
||||
: hours-per-year 876582/100 ; inline
|
||||
: minutes-per-year 5259492/10 ; inline
|
||||
: seconds-per-year 31556952 ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: a
|
||||
SYMBOL: b
|
||||
|
|
@ -48,6 +54,8 @@ SYMBOL: e
|
|||
SYMBOL: y
|
||||
SYMBOL: m
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: julian-day-number ( year month day -- n )
|
||||
#! Returns a composite date number
|
||||
#! Not valid before year -4800
|
||||
|
|
@ -74,38 +82,31 @@ SYMBOL: m
|
|||
e get 153 m get * 2 + 5 /i - 1+
|
||||
] with-scope ;
|
||||
|
||||
: set-date ( year month day timestamp -- )
|
||||
[ set-timestamp-day ] keep
|
||||
[ set-timestamp-month ] keep
|
||||
set-timestamp-year ;
|
||||
|
||||
: set-time ( hour minute second timestamp -- )
|
||||
[ set-timestamp-second ] keep
|
||||
[ set-timestamp-minute ] keep
|
||||
set-timestamp-hour ;
|
||||
|
||||
: >date< ( timestamp -- year month day )
|
||||
[ timestamp-year ] keep
|
||||
[ timestamp-month ] keep
|
||||
timestamp-day ;
|
||||
{ year>> month>> day>> } get-slots ;
|
||||
|
||||
: >time< ( timestamp -- hour minute second )
|
||||
[ timestamp-hour ] keep
|
||||
[ timestamp-minute ] keep
|
||||
timestamp-second ;
|
||||
{ hour>> minute>> second>> } get-slots ;
|
||||
|
||||
: zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ;
|
||||
: years ( n -- dt ) zero-dt [ set-dt-year ] keep ;
|
||||
: months ( n -- dt ) zero-dt [ set-dt-month ] keep ;
|
||||
: days ( n -- dt ) zero-dt [ set-dt-day ] keep ;
|
||||
: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
|
||||
: years ( n -- dt ) instant swap >>year ;
|
||||
: months ( n -- dt ) instant swap >>month ;
|
||||
: days ( n -- dt ) instant swap >>day ;
|
||||
: weeks ( n -- dt ) 7 * days ;
|
||||
: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ;
|
||||
: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ;
|
||||
: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ;
|
||||
: milliseconds ( n -- dt ) 1000 /f seconds ;
|
||||
: hours ( n -- dt ) instant swap >>hour ;
|
||||
: minutes ( n -- dt ) instant swap >>minute ;
|
||||
: seconds ( n -- dt ) instant swap >>second ;
|
||||
: milliseconds ( n -- dt ) 1000 / seconds ;
|
||||
|
||||
: julian-day-number>timestamp ( n -- timestamp )
|
||||
julian-day-number>date 0 0 0 0 <timestamp> ;
|
||||
GENERIC: leap-year? ( obj -- ? )
|
||||
|
||||
M: integer leap-year? ( year -- ? )
|
||||
dup 100 mod zero? 400 4 ? mod zero? ;
|
||||
|
||||
M: timestamp leap-year? ( timestamp -- ? )
|
||||
year>> leap-year? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: +year ( timestamp x -- timestamp )
|
||||
GENERIC: +month ( timestamp x -- timestamp )
|
||||
|
|
@ -116,96 +117,119 @@ GENERIC: +second ( timestamp x -- timestamp )
|
|||
|
||||
: /rem ( f n -- q r )
|
||||
#! q is positive or negative, r is positive from 0 <= r < n
|
||||
[ /f floor >integer ] 2keep rem ;
|
||||
[ / floor >integer ] 2keep rem ;
|
||||
|
||||
: float>whole-part ( float -- int float )
|
||||
[ floor >integer ] keep over - ;
|
||||
|
||||
GENERIC: leap-year? ( obj -- ? )
|
||||
M: integer leap-year? ( year -- ? )
|
||||
dup 100 mod zero? 400 4 ? mod zero? ;
|
||||
|
||||
M: timestamp leap-year? ( timestamp -- ? )
|
||||
timestamp-year leap-year? ;
|
||||
|
||||
: adjust-leap-year ( timestamp -- timestamp )
|
||||
dup >date< 29 = swap 2 = and swap leap-year? not and [
|
||||
dup >r timestamp-year 3 1 r> [ set-date ] keep
|
||||
] when ;
|
||||
dup day>> 29 = over month>> 2 = pick leap-year? not and and
|
||||
[ 3 >>month 1 >>day ] when ;
|
||||
|
||||
: unless-zero >r dup zero? [ drop ] r> if ; inline
|
||||
|
||||
M: integer +year ( timestamp n -- timestamp )
|
||||
over timestamp-year + swap [ set-timestamp-year ] keep
|
||||
adjust-leap-year ;
|
||||
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
|
||||
|
||||
M: real +year ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap 365.2425 * +day swap +year ;
|
||||
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
|
||||
|
||||
: months/years ( n -- months years )
|
||||
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
|
||||
|
||||
M: integer +month ( timestamp n -- timestamp )
|
||||
over timestamp-month + 12 /rem
|
||||
dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month
|
||||
+year ;
|
||||
[ over month>> + months/years >r >>month r> +year ] unless-zero ;
|
||||
|
||||
M: real +month ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap average-month * +day swap +month ;
|
||||
[ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
|
||||
|
||||
M: integer +day ( timestamp n -- timestamp )
|
||||
swap [
|
||||
>date< julian-day-number + julian-day-number>timestamp
|
||||
] keep swap >r >time< r> [ set-time ] keep ;
|
||||
[
|
||||
over >date< julian-day-number + julian-day-number>date
|
||||
>r >r >>year r> >>month r> >>day
|
||||
] unless-zero ;
|
||||
|
||||
M: real +day ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap 24 * +hour swap +day ;
|
||||
[ float>whole-part swapd 24 * +hour swap +day ] unless-zero ;
|
||||
|
||||
: hours/days ( n -- hours days )
|
||||
24 /rem swap ;
|
||||
|
||||
M: integer +hour ( timestamp n -- timestamp )
|
||||
over timestamp-hour + 24 /rem pick set-timestamp-hour
|
||||
+day ;
|
||||
[ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
|
||||
|
||||
M: real +hour ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap 60 * +minute swap +hour ;
|
||||
float>whole-part swapd 60 * +minute swap +hour ;
|
||||
|
||||
: minutes/hours ( n -- minutes hours )
|
||||
60 /rem swap ;
|
||||
|
||||
M: integer +minute ( timestamp n -- timestamp )
|
||||
over timestamp-minute + 60 /rem pick
|
||||
set-timestamp-minute +hour ;
|
||||
[ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
|
||||
|
||||
M: real +minute ( timestamp n -- timestamp )
|
||||
float>whole-part rot swap 60 * +second swap +minute ;
|
||||
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
|
||||
|
||||
: seconds/minutes ( n -- seconds minutes )
|
||||
60 /rem swap >integer ;
|
||||
|
||||
M: number +second ( timestamp n -- timestamp )
|
||||
over timestamp-second + 60 /rem >r >integer r>
|
||||
pick set-timestamp-second +minute ;
|
||||
[ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
|
||||
|
||||
: +dt ( timestamp dt -- timestamp )
|
||||
dupd
|
||||
[ dt-second +second ] keep
|
||||
[ dt-minute +minute ] keep
|
||||
[ dt-hour +hour ] keep
|
||||
[ dt-day +day ] keep
|
||||
[ dt-month +month ] keep
|
||||
dt-year +year
|
||||
swap timestamp-gmt-offset over set-timestamp-gmt-offset ;
|
||||
: (time+)
|
||||
[ second>> +second ] keep
|
||||
[ minute>> +minute ] keep
|
||||
[ hour>> +hour ] keep
|
||||
[ day>> +day ] keep
|
||||
[ month>> +month ] keep
|
||||
[ year>> +year ] keep ; inline
|
||||
|
||||
: make-timestamp ( year month day hour minute second gmt-offset -- timestamp )
|
||||
<timestamp> [ 0 seconds +dt ] keep
|
||||
[ = [ "invalid timestamp" throw ] unless ] keep ;
|
||||
: +slots [ 2apply + ] curry 2keep ; inline
|
||||
|
||||
: make-date ( year month day -- timestamp )
|
||||
0 0 0 gmt-offset make-timestamp ;
|
||||
PRIVATE>
|
||||
|
||||
: array>dt ( vec -- dt ) { dt f } swap append >tuple ;
|
||||
: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ;
|
||||
GENERIC# time+ 1 ( time dt -- time )
|
||||
|
||||
M: timestamp time+
|
||||
>r clone r> (time+) drop ;
|
||||
|
||||
M: duration time+
|
||||
dup timestamp? [
|
||||
swap time+
|
||||
] [
|
||||
[ year>> ] +slots
|
||||
[ month>> ] +slots
|
||||
[ day>> ] +slots
|
||||
[ hour>> ] +slots
|
||||
[ minute>> ] +slots
|
||||
[ second>> ] +slots
|
||||
2drop <duration>
|
||||
] if ;
|
||||
|
||||
: dt>years ( dt -- x )
|
||||
#! Uses average month/year length since dt loses calendar
|
||||
#! data
|
||||
tuple-slots
|
||||
{ 1 12 365.2425 8765.82 525949.2 31556952.0 }
|
||||
v/ sum ;
|
||||
0 swap
|
||||
[ year>> + ] keep
|
||||
[ month>> months-per-year / + ] keep
|
||||
[ day>> days-per-year / + ] keep
|
||||
[ hour>> hours-per-year / + ] keep
|
||||
[ minute>> minutes-per-year / + ] keep
|
||||
second>> seconds-per-year / + ;
|
||||
|
||||
: dt>months ( dt -- x ) dt>years 12 * ;
|
||||
: dt>days ( dt -- x ) dt>years 365.2425 * ;
|
||||
: dt>hours ( dt -- x ) dt>years 8765.82 * ;
|
||||
: dt>minutes ( dt -- x ) dt>years 525949.2 * ;
|
||||
: dt>seconds ( dt -- x ) dt>years 31556952 * ;
|
||||
: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ;
|
||||
M: duration <=> [ dt>years ] compare ;
|
||||
|
||||
: dt>months ( dt -- x ) dt>years months-per-year * ;
|
||||
: dt>days ( dt -- x ) dt>years days-per-year * ;
|
||||
: dt>hours ( dt -- x ) dt>years hours-per-year * ;
|
||||
: dt>minutes ( dt -- x ) dt>years minutes-per-year * ;
|
||||
: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
|
||||
: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
|
||||
|
||||
: convert-timezone ( timestamp n -- timestamp )
|
||||
[ over timestamp-gmt-offset - hours +dt ] keep
|
||||
over set-timestamp-gmt-offset ;
|
||||
over gmt-offset>> over = [ drop ] [
|
||||
[ over gmt-offset>> - hours time+ ] keep >>gmt-offset
|
||||
] if ;
|
||||
|
||||
: >local-time ( timestamp -- timestamp )
|
||||
gmt-offset convert-timezone ;
|
||||
|
|
@ -216,45 +240,54 @@ M: number +second ( timestamp n -- timestamp )
|
|||
M: timestamp <=> ( ts1 ts2 -- n )
|
||||
[ >gmt tuple-slots ] compare ;
|
||||
|
||||
: timestamp- ( timestamp timestamp -- seconds )
|
||||
#! Exact calendar-time difference
|
||||
: (time-) ( timestamp timestamp -- n )
|
||||
[ >gmt ] 2apply
|
||||
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
|
||||
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
|
||||
|
||||
GENERIC: time- ( time1 time2 -- time )
|
||||
|
||||
M: timestamp time-
|
||||
#! Exact calendar-time difference
|
||||
(time-) seconds ;
|
||||
|
||||
: before ( dt -- -dt )
|
||||
[ year>> neg ] keep
|
||||
[ month>> neg ] keep
|
||||
[ day>> neg ] keep
|
||||
[ hour>> neg ] keep
|
||||
[ minute>> neg ] keep
|
||||
second>> neg
|
||||
<duration> ;
|
||||
|
||||
M: duration time-
|
||||
before time+ ;
|
||||
|
||||
: <zero> 0 0 0 0 0 0 0 <timestamp> ;
|
||||
|
||||
: valid-timestamp? ( timestamp -- ? )
|
||||
clone 0 >>gmt-offset
|
||||
dup <zero> time- <zero> time+ = ;
|
||||
|
||||
: unix-1970 ( -- timestamp )
|
||||
1970 1 1 0 0 0 0 <timestamp> ;
|
||||
1970 1 1 0 0 0 0 <timestamp> ; foldable
|
||||
|
||||
: millis>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> 1000 /f seconds +dt ;
|
||||
>r unix-1970 r> milliseconds time+ ;
|
||||
|
||||
: timestamp>millis ( timestamp -- n )
|
||||
unix-1970 timestamp- 1000 * >integer ;
|
||||
|
||||
: unix-time>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> seconds +dt ;
|
||||
|
||||
: timestamp>unix-time ( timestamp -- n )
|
||||
unix-1970 timestamp- >integer ;
|
||||
|
||||
: timestamp>timeval ( timestamp -- timeval )
|
||||
timestamp>unix-time 1000 * make-timeval ;
|
||||
|
||||
: timeval>timestamp ( timeval -- timestamp )
|
||||
[ timeval-sec ] keep
|
||||
timeval-usec 1000000 / + unix-time>timestamp ;
|
||||
|
||||
unix-1970 (time-) 1000 * >integer ;
|
||||
|
||||
: gmt ( -- timestamp )
|
||||
#! GMT time, right now
|
||||
unix-1970 millis 1000 /f seconds +dt ;
|
||||
unix-1970 millis milliseconds time+ ;
|
||||
|
||||
: now ( -- timestamp ) gmt >local-time ;
|
||||
: before ( dt -- -dt ) tuple-slots vneg array>dt ;
|
||||
: from-now ( dt -- timestamp ) now swap +dt ;
|
||||
: ago ( dt -- timestamp ) before from-now ;
|
||||
|
||||
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
|
||||
: from-now ( dt -- timestamp ) now swap time+ ;
|
||||
: ago ( dt -- timestamp ) now swap time- ;
|
||||
|
||||
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
|
||||
|
||||
: zeller-congruence ( year month day -- n )
|
||||
#! Zeller Congruence
|
||||
|
|
@ -268,7 +301,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
GENERIC: days-in-year ( obj -- n )
|
||||
|
||||
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
|
||||
M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ;
|
||||
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
||||
|
||||
GENERIC: days-in-month ( obj -- n )
|
||||
|
||||
|
|
@ -280,7 +313,7 @@ M: array days-in-month ( obj -- n )
|
|||
] if ;
|
||||
|
||||
M: timestamp days-in-month ( timestamp -- n )
|
||||
{ timestamp-year timestamp-month } get-slots 2array days-in-month ;
|
||||
>date< drop 2array days-in-month ;
|
||||
|
||||
GENERIC: day-of-week ( obj -- n )
|
||||
|
||||
|
|
@ -297,156 +330,20 @@ M: array day-of-year ( array -- n )
|
|||
3dup day-counts rot head-slice sum +
|
||||
swap leap-year? [
|
||||
-roll
|
||||
pick 3 1 make-date >r make-date r>
|
||||
<=> 0 >= [ 1+ ] when
|
||||
pick 3 1 <date> >r <date> r>
|
||||
after=? [ 1+ ] when
|
||||
] [
|
||||
3nip
|
||||
>r 3drop r>
|
||||
] if ;
|
||||
|
||||
M: timestamp day-of-year ( timestamp -- n )
|
||||
{ timestamp-year timestamp-month timestamp-day } get-slots
|
||||
3array day-of-year ;
|
||||
|
||||
GENERIC: day. ( obj -- )
|
||||
|
||||
M: integer day. ( n -- )
|
||||
number>string dup length 2 < [ bl ] when write ;
|
||||
|
||||
M: timestamp day. ( timestamp -- )
|
||||
timestamp-day day. ;
|
||||
|
||||
GENERIC: month. ( obj -- )
|
||||
|
||||
M: array month. ( pair -- )
|
||||
first2
|
||||
[ month-names nth write bl number>string print ] 2keep
|
||||
[ 1 zeller-congruence ] 2keep
|
||||
2array days-in-month day-abbreviations2 " " join print
|
||||
over " " <repetition> concat write
|
||||
[
|
||||
[ 1+ day. ] keep
|
||||
1+ + 7 mod zero? [ nl ] [ bl ] if
|
||||
] with each nl ;
|
||||
|
||||
M: timestamp month. ( timestamp -- )
|
||||
{ timestamp-year timestamp-month } get-slots 2array month. ;
|
||||
|
||||
GENERIC: year. ( obj -- )
|
||||
|
||||
M: integer year. ( n -- )
|
||||
12 [ 1+ 2array month. nl ] with each ;
|
||||
|
||||
M: timestamp year. ( timestamp -- )
|
||||
timestamp-year year. ;
|
||||
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left ;
|
||||
|
||||
: write-00 pad-00 write ;
|
||||
|
||||
: (timestamp>string) ( timestamp -- )
|
||||
dup day-of-week day-abbreviations3 nth write ", " write
|
||||
dup timestamp-day number>string write bl
|
||||
dup timestamp-month month-abbreviations nth write bl
|
||||
dup timestamp-year number>string write bl
|
||||
dup timestamp-hour write-00 ":" write
|
||||
dup timestamp-minute write-00 ":" write
|
||||
timestamp-second >fixnum write-00 ;
|
||||
|
||||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] with-string-writer ;
|
||||
|
||||
: (write-gmt-offset) ( ratio -- )
|
||||
1 /mod swap write-00 60 * write-00 ;
|
||||
|
||||
: write-gmt-offset ( gmt-offset -- )
|
||||
{
|
||||
{ [ dup zero? ] [ drop "GMT" write ] }
|
||||
{ [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
|
||||
{ [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
|
||||
} cond ;
|
||||
|
||||
: timestamp>rfc822-string ( timestamp -- str )
|
||||
#! RFC822 timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
||||
[
|
||||
dup (timestamp>string)
|
||||
" " write
|
||||
timestamp-gmt-offset write-gmt-offset
|
||||
] with-string-writer ;
|
||||
|
||||
: timestamp>http-string ( timestamp -- str )
|
||||
#! http timestamp format
|
||||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||
>gmt timestamp>rfc822-string ;
|
||||
|
||||
: write-rfc3339-gmt-offset ( n -- )
|
||||
dup zero? [ drop "Z" write ] [
|
||||
dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
|
||||
60 * 60 /mod swap write-00 CHAR: : write1 write-00
|
||||
] if ;
|
||||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
dup timestamp-year number>string write CHAR: - write1
|
||||
dup timestamp-month write-00 CHAR: - write1
|
||||
dup timestamp-day write-00 CHAR: T write1
|
||||
dup timestamp-hour write-00 CHAR: : write1
|
||||
dup timestamp-minute write-00 CHAR: : write1
|
||||
dup timestamp-second >fixnum write-00
|
||||
timestamp-gmt-offset write-rfc3339-gmt-offset ;
|
||||
|
||||
: timestamp>rfc3339 ( timestamp -- str )
|
||||
[ (timestamp>rfc3339) ] with-string-writer ;
|
||||
|
||||
: expect ( str -- )
|
||||
read1 swap member? [ "Parse error" throw ] unless ;
|
||||
|
||||
: read-00 2 read string>number ;
|
||||
|
||||
: read-0000 4 read string>number ;
|
||||
|
||||
: read-rfc3339-gmt-offset ( -- n )
|
||||
read1 dup CHAR: Z = [ drop 0 ] [
|
||||
{ { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
|
||||
read-00
|
||||
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
|
||||
60 / + *
|
||||
] if ;
|
||||
|
||||
: (rfc3339>timestamp) ( -- timestamp )
|
||||
read-0000 ! year
|
||||
"-" expect
|
||||
read-00 ! month
|
||||
"-" expect
|
||||
read-00 ! day
|
||||
"Tt" expect
|
||||
read-00 ! hour
|
||||
":" expect
|
||||
read-00 ! minute
|
||||
":" expect
|
||||
read-00 ! second
|
||||
read-rfc3339-gmt-offset ! timezone
|
||||
<timestamp> ;
|
||||
|
||||
: rfc3339>timestamp ( str -- timestamp )
|
||||
[ (rfc3339>timestamp) ] with-string-reader ;
|
||||
|
||||
: file-time-string ( timestamp -- string )
|
||||
[
|
||||
[ timestamp-month month-abbreviations nth write ] keep bl
|
||||
[ timestamp-day number>string 2 32 pad-left write ] keep bl
|
||||
dup now [ timestamp-year ] 2apply = [
|
||||
[ timestamp-hour write-00 ] keep ":" write
|
||||
timestamp-minute write-00
|
||||
] [
|
||||
timestamp-year number>string 5 32 pad-left write
|
||||
] if
|
||||
] with-string-writer ;
|
||||
>date< 3array day-of-year ;
|
||||
|
||||
: day-offset ( timestamp m -- timestamp n )
|
||||
over day-of-week - ; inline
|
||||
|
||||
: day-this-week ( timestamp n -- timestamp )
|
||||
day-offset days +dt ;
|
||||
day-offset days time+ ;
|
||||
|
||||
: sunday ( timestamp -- timestamp ) 0 day-this-week ;
|
||||
: monday ( timestamp -- timestamp ) 1 day-this-week ;
|
||||
|
|
@ -457,25 +354,26 @@ M: timestamp year. ( timestamp -- )
|
|||
: saturday ( timestamp -- timestamp ) 6 day-this-week ;
|
||||
|
||||
: beginning-of-day ( timestamp -- new-timestamp )
|
||||
clone dup >r 0 0 0 r>
|
||||
{ set-timestamp-hour set-timestamp-minute set-timestamp-second }
|
||||
set-slots ; inline
|
||||
clone
|
||||
0 >>hour
|
||||
0 >>minute
|
||||
0 >>second ; inline
|
||||
|
||||
: beginning-of-month ( timestamp -- new-timestamp )
|
||||
beginning-of-day 1 over set-timestamp-day ;
|
||||
beginning-of-day 1 >>day ;
|
||||
|
||||
: beginning-of-week ( timestamp -- new-timestamp )
|
||||
beginning-of-day sunday ;
|
||||
|
||||
: beginning-of-year ( timestamp -- new-timestamp )
|
||||
beginning-of-month 1 over set-timestamp-month ;
|
||||
beginning-of-month 1 >>month ;
|
||||
|
||||
: seconds-since-midnight ( timestamp -- x )
|
||||
dup beginning-of-day timestamp- ;
|
||||
: time-since-midnight ( timestamp -- duration )
|
||||
dup beginning-of-day time- ;
|
||||
|
||||
M: timestamp sleep-until timestamp>millis sleep-until ;
|
||||
|
||||
M: dt sleep from-now sleep-until ;
|
||||
M: duration sleep from-now sleep-until ;
|
||||
|
||||
{
|
||||
{ [ unix? ] [ "calendar.unix" ] }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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> ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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+
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ "*foo\nbar\n" parse-farkup ] must-fail
|
||||
[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" parse-farkup ] unit-test
|
||||
[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" parse-farkup ] unit-test
|
||||
[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" parse-farkup ] unit-test
|
||||
[ "<p><em>Wow.</em></p>" ] [ "_Wow._" parse-farkup ] unit-test
|
||||
|
||||
[ "<p>*</p>" ] [ "*" parse-farkup ] unit-test
|
||||
[ "<p>*</p>" ] [ "\\*" parse-farkup ] unit-test
|
||||
[ "<p>**</p>" ] [ "\\**" parse-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "\n\n" parse-farkup ] unit-test
|
||||
[ "\n" ] [ "\n\n\n" parse-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" parse-farkup ] unit-test
|
||||
|
||||
[ "\n<p>bar\n</p>" ] [ "\nbar\n" parse-farkup ] unit-test
|
||||
|
||||
[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" parse-farkup ] unit-test
|
||||
|
||||
[ "" ] [ "" parse-farkup ] unit-test
|
||||
|
||||
[ "<p>|a</p>" ]
|
||||
[ "|a" parse-farkup ] unit-test
|
||||
|
||||
[ "<p>|a|</p>" ]
|
||||
[ "|a|" parse-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>" ]
|
||||
[ "a|b" parse-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>" ]
|
||||
[ "a|b\nc|d" parse-farkup ] unit-test
|
||||
|
||||
[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>\n" ]
|
||||
[ "a|b\nc|d\n" parse-farkup ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ,
|
||||
line ,
|
||||
] seq*
|
||||
[ "li" <foo> swap "li" </foo> 3array ] action ;
|
||||
"-" token hide , line ,
|
||||
] seq* [ "li" surround-with-foo ] 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 [ [ blank? ] all? ] deep-all?
|
||||
[ "<p>" swap "</p>" 3array ] unless
|
||||
] action ,
|
||||
"\n" token hide ,
|
||||
] choice* ;
|
||||
dup [ dup string? not swap [ blank? ] all? or ] deep-all?
|
||||
[ "<p>" swap "</p>" 3array ] unless
|
||||
] action ;
|
||||
|
||||
MEMO: farkup ( -- parser )
|
||||
[
|
||||
list , h1 , h2 , h3 , h4 , code , paragraph , 2nl ,
|
||||
] choice* repeat1 ;
|
||||
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
|
||||
] choice* repeat0 "\n" token optional 2seq ;
|
||||
|
||||
: farkup. ( parse-result -- )
|
||||
parse-result-ast
|
||||
[ dup string? [ write ] [ drop ] if ] deep-each ;
|
||||
|
||||
: parse-farkup ( string -- string' )
|
||||
farkup parse parse-result-ast
|
||||
[ [ dup string? [ write ] [ drop ] if ] deep-each ] with-string-writer ;
|
||||
farkup parse [ farkup. ] with-string-writer ;
|
||||
|
||||
! MEMO: table-column ( -- parser )
|
||||
! text [ "td" surround-with-foo ] action ;
|
||||
!
|
||||
! MEMO: table-row ( -- parser )
|
||||
! [
|
||||
! "|" token hide ,
|
||||
! table-column "|" token hide list-of ,
|
||||
! "|" token "\n" token 2array choice hide ,
|
||||
! ] seq* [ "tr" surround-with-foo ] action ;
|
||||
!
|
||||
! MEMO: table ( -- parser )
|
||||
! table-row repeat1
|
||||
! [ "table" surround-with-foo ] action ;
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
[ over [ push ] [ 2drop ] if f ] curry compose
|
||||
iterate-directory
|
||||
drop
|
||||
] keep ; inline
|
||||
>r <directory-iterator> r>
|
||||
pusher >r iterate-directory drop r> ; inline
|
||||
|
||||
: recursive-directory ( path bfs? -- paths )
|
||||
<directory-iterator>
|
||||
[ dup next-file dup ] [ ] [ drop ] unfold nip ;
|
||||
[ ] accumulator >r each-file r> ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
7-segment numeric display demo
|
||||
7-segment LCD clock demo
|
||||
|
|
|
|||
|
|
@ -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... ;" }
|
||||
{ $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." } ;
|
||||
{ $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." }
|
||||
{ $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 = ] [ ... ] } ;"
|
||||
|
|
|
|||
|
|
@ -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 | a [ ] | [let | b [ a ] | a ] ] ;
|
||||
:: let-test-2 ( a -- a )
|
||||
a [let | a [ ] | [let | b [ a ] | a ] ] ;
|
||||
|
||||
[ 3 ] [ 3 let-test-2 ] unit-test
|
||||
|
||||
:: let-test-3 | |
|
||||
[let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
|
||||
:: let-test-3 ( a -- a )
|
||||
a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
|
||||
|
||||
:: let-test-4 | |
|
||||
[let | a [ 1 ] b [ ] | a b 2array ] ;
|
||||
:: let-test-4 ( a -- b )
|
||||
a [let | a [ 1 ] b [ ] | a b 2array ] ;
|
||||
|
||||
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
|
||||
|
||||
:: let-test-5 | |
|
||||
[let | a [ ] b [ ] | a b 2array ] ;
|
||||
:: let-test-5 ( a -- b )
|
||||
a [let | a [ ] b [ ] | a b 2array ] ;
|
||||
|
||||
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
|
||||
|
||||
:: let-test-6 | |
|
||||
[let | a [ ] b [ 1 ] | a b 2array ] ;
|
||||
:: let-test-6 ( a -- b )
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
>r CREATE dup reset-generic
|
||||
scan "|" assert= parse-locals \ ; (parse-lambda) <lambda>
|
||||
2dup r> set-word-prop
|
||||
[ lambda-rewrite first ] keep lambda-vars length ;
|
||||
: parse-locals
|
||||
parse-effect
|
||||
word [ over "declared-effect" set-word-prop ] when*
|
||||
effect-in make-locals ;
|
||||
|
||||
: ((::)) ( 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 -- )
|
||||
over definer.
|
||||
over seeing-word
|
||||
over pprint-word
|
||||
\ | pprint-word
|
||||
word-prop lambda-vars pprint-vars
|
||||
\ | pprint-word ;
|
||||
: lambda-word-synopsis ( word -- )
|
||||
dup definer.
|
||||
dup seeing-word
|
||||
dup pprint-word
|
||||
stack-effect. ;
|
||||
|
||||
M: lambda-word synopsis*
|
||||
"lambda" lambda-word-synopsis ;
|
||||
M: lambda-word synopsis* 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*
|
||||
"lambda-macro" lambda-word-synopsis ;
|
||||
M: lambda-macro synopsis* 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>
|
||||
|
|
|
|||
|
|
@ -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 ] <@ ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 inference.transforms
|
||||
combinators assocs definitions quotations namespaces memoize ;
|
||||
|
||||
USING: parser kernel sequences words effects
|
||||
inference.transforms combinators assocs definitions quotations
|
||||
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 -- )
|
||||
>r 2dup "macro" set-word-prop
|
||||
2dup over real-macro-effect memoize-quot
|
||||
[ call ] append define
|
||||
: define-macro ( word definition -- )
|
||||
over "declared-effect" word-prop effect-in length >r
|
||||
2dup "macro" set-word-prop
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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> ] %
|
||||
swap writer-word ,
|
||||
] [ ] make define
|
||||
[ r> call r> swap ] %
|
||||
swap setter-word ,
|
||||
] [ ] make define-inline
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: define-new-slot ( class slot name -- )
|
||||
|
|
|
|||
|
|
@ -26,8 +26,8 @@ IN: opengl.capabilities
|
|||
: version-seq ( version-string -- version-seq )
|
||||
"." split [ string>number ] map ;
|
||||
|
||||
: version<=> ( version1 version2 -- n )
|
||||
swap version-seq swap version-seq <=> ;
|
||||
: version-before? ( version1 version2 -- ? )
|
||||
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)" % ]
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
2dup timestamp- 0 >= [
|
||||
dup day-of-week , 1 +month (first-days)
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: first-days ( start-date end-date -- seq )
|
||||
[ swap (first-days) ] { } make ;
|
||||
: first-days ( end-date start-date -- days )
|
||||
[ 2dup after=? ]
|
||||
[ dup 1 months time+ swap day-of-week ]
|
||||
[ ] unfold 2nip ;
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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> ] |
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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-right [ node-key swap node-key key> ] when* r> and swap
|
||||
dup dup node-left [ node-key swap node-key before? ] when* >r
|
||||
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* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue