From a5807774e094779db56882efdc75e5191c289e72 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 Feb 2008 12:50:19 -0600 Subject: [PATCH 01/22] add rules to allow * by itself add escape characters --- extra/farkup/farkup-tests.factor | 12 ++++++++---- extra/farkup/farkup.factor | 28 ++++++++++++++++++++-------- 2 files changed, 28 insertions(+), 12 deletions(-) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 1964b2b8a6..4d418ab99c 100644 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -2,11 +2,15 @@ USING: farkup kernel tools.test ; IN: temporary [ "" ] [ "-foo" parse-farkup ] unit-test -[ "" ] [ "-foo\n" parse-farkup ] unit-test +[ "\n" ] [ "-foo\n" parse-farkup ] unit-test [ "" ] [ "-foo\n-bar" parse-farkup ] unit-test -[ "" ] [ "-foo\n-bar\n" parse-farkup ] unit-test +[ "\n" ] [ "-foo\n-bar\n" parse-farkup ] unit-test -[ "

bar

" ] [ "-foo\nbar\n" parse-farkup ] unit-test -[ "*foo\nbar\n" parse-farkup ] must-fail +[ "

\nbar\n

" ] [ "-foo\nbar\n" parse-farkup ] unit-test +[ "

*foo\nbar\n

" ] [ "*foo\nbar\n" parse-farkup ] unit-test [ "

Wow!

" ] [ "*Wow!*" parse-farkup ] unit-test [ "

Wow.

" ] [ "_Wow._" parse-farkup ] unit-test + +[ "

*

" ] [ "*" parse-farkup ] unit-test +[ "

*

" ] [ "\\*" parse-farkup ] unit-test +[ "

**

" ] [ "\\**" parse-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 084b1c80cb..ff39606853 100644 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -3,16 +3,24 @@ 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 ; + : delimited ( str html -- parser ) [ over token hide , @@ -20,6 +28,9 @@ MEMO: text ( -- parser ) 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 ; @@ -89,16 +100,17 @@ MEMO: line ( -- parser ) [ text , strong , emphasis , link , superscript , subscript , inline-code , + escaped-char , delimiter , ] choice* repeat1 ; MEMO: paragraph ( -- parser ) [ - line [ - dup [ [ blank? ] all? ] deep-all? - [ "

" swap "

" 3array ] unless - ] action , - "\n" token hide , - ] choice* ; + line , + "\n" token , + ] choice* repeat1 [ + dup [ dup string? not swap [ blank? ] all? or ] deep-all? + [ "

" swap "

" 3array ] unless + ] action ; MEMO: farkup ( -- parser ) [ From aeef08cd514009522ee58c6784ad339d0a1bddbe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 14:57:37 -0600 Subject: [PATCH 02/22] Improve LCD demo --- extra/lcd/lcd.factor | 22 ++++++++++++++++++---- extra/lcd/summary.txt | 2 +- 2 files changed, 19 insertions(+), 5 deletions(-) mode change 100644 => 100755 extra/lcd/summary.txt diff --git a/extra/lcd/lcd.factor b/extra/lcd/lcd.factor index 605ac4cd59..c2eba8b7b6 100755 --- a/extra/lcd/lcd.factor +++ b/extra/lcd/lcd.factor @@ -1,4 +1,6 @@ -USING: sequences kernel math io ; +USING: sequences kernel math io calendar calendar.model +arrays models namespaces ui.gadgets ui.gadgets.labels +ui.gadgets.theme ui ; IN: lcd : lcd-digit ( row digit -- str ) @@ -6,14 +8,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 +: ( timestamp -- gadget ) + [ hh:mm:ss lcd ] + "99:99:99" lcd over set-label-string + monospace-font over set-label-font ; + +: time-window ( -- ) + [ time get "Time" open-window ] with-ui ; + +MAIN: time-window diff --git a/extra/lcd/summary.txt b/extra/lcd/summary.txt old mode 100644 new mode 100755 index 1b6436a614..e477045071 --- a/extra/lcd/summary.txt +++ b/extra/lcd/summary.txt @@ -1 +1 @@ -7-segment numeric display demo +7-segment LCD clock demo From da575528cf4b69f236c7b5b7a8e87e979835dcfb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 14:58:02 -0600 Subject: [PATCH 03/22] Add ignore-errors to core --- core/continuations/continuations-docs.factor | 7 ++++++- core/continuations/continuations.factor | 3 +++ extra/tools/test/test.factor | 3 --- extra/vocabs/monitor/monitor.factor | 2 +- 4 files changed, 10 insertions(+), 5 deletions(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index a1e2525c14..5fc86e25d4 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -23,9 +23,10 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"Two words for establishing an error handler:" +"Words for establishing an error handler:" { $subsection cleanup } { $subsection recover } +{ $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -148,6 +149,10 @@ HELP: recover { $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } } { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; +HELP: ignore-errors +{ $values { "try" quotation } } +{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; + HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index a0aa59332e..d68b5b2433 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -120,6 +120,9 @@ SYMBOL: thread-error-hook : recover ( try recovery -- ) >r [ swap >c call c> drop ] curry r> ifcc ; inline +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry recover r> call ; inline diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 69093f18a6..0ab68f502e 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -48,9 +48,6 @@ SYMBOL: this-test : must-fail ( quot -- ) [ drop t ] must-fail-with ; -: ignore-errors ( quot -- ) - [ drop ] recover ; inline - : (run-test) ( vocab -- ) dup vocab-source-loaded? [ vocab-tests diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor index d3e4a44896..32a104687e 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/vocabs/monitor/monitor.factor @@ -17,6 +17,6 @@ SYMBOL: vocab-monitor [ "" resource-path t vocab-monitor set-global [ monitor-thread t ] "Vocabulary monitor" spawn-server drop - ] [ drop ] recover ; + ] ignore-errors ; [ start-monitor-thread ] "vocabs.monitor" add-init-hook From 5a8ab4f6ee33b73fc983cef4f00e9e7e851c4370 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 14:58:16 -0600 Subject: [PATCH 04/22] Use temp-file --- extra/bootstrap/image/upload/upload.factor | 6 ++++-- extra/bunny/model/model.factor | 4 ++-- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 552e26ebf5..0cdc7ccc26 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -6,16 +6,18 @@ 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 % checksums , destination , ] { } make try-process ; : new-images ( -- ) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 2d731dd830..49a0f9254a 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -39,12 +39,12 @@ IN: bunny.model [ normals ] 2keep 3array ] time ; -: model-path "bun_zipper.ply" ; +: model-path "bun_zipper.ply" temp-file ; : model-url "http://factorcode.org/bun_zipper.ply" ; : maybe-download ( -- path ) - model-path resource-path dup exists? [ + model-path dup exists? [ "Downloading bunny from " write model-url dup print flush over download-to From 4c3eabe9a3a46a2944cea6aae16c39341f8728a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 14:58:41 -0600 Subject: [PATCH 05/22] Handle repaint messages properly --- extra/ui/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 45da2706f4..b5ab63c4c8 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -85,7 +85,7 @@ SYMBOL: mouse-captured : handle-wm-paint ( hWnd uMsg wParam lParam -- ) #! wParam and lParam are unused #! only paint if width/height both > 0 - 3drop window relayout-1 ; + 3drop window relayout-1 yield ; : handle-wm-size ( hWnd uMsg wParam lParam -- ) 2nip From 59c0c66857c9cd4ecae0e4c68daa269f06f7ccd6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 Feb 2008 15:06:23 -0600 Subject: [PATCH 06/22] make farkup pass the empty string better handling of \n and special characters add escaped chars --- extra/farkup/farkup-tests.factor | 12 +++++++++++- extra/farkup/farkup.factor | 17 ++++++++++++----- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 4d418ab99c..ec1b915d4d 100644 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -6,7 +6,7 @@ IN: temporary [ "
  • foo
  • bar
" ] [ "-foo\n-bar" parse-farkup ] unit-test [ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" parse-farkup ] unit-test -[ "
  • foo

\nbar\n

" ] [ "-foo\nbar\n" parse-farkup ] unit-test +[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" parse-farkup ] unit-test [ "

*foo\nbar\n

" ] [ "*foo\nbar\n" parse-farkup ] unit-test [ "

Wow!

" ] [ "*Wow!*" parse-farkup ] unit-test [ "

Wow.

" ] [ "_Wow._" parse-farkup ] unit-test @@ -14,3 +14,13 @@ IN: temporary [ "

*

" ] [ "*" parse-farkup ] unit-test [ "

*

" ] [ "\\*" parse-farkup ] unit-test [ "

**

" ] [ "\\**" parse-farkup ] unit-test + +[ "" ] [ "\n\n" parse-farkup ] unit-test +[ "\n" ] [ "\n\n\n" parse-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\n\nbar" parse-farkup ] unit-test + +[ "\n

bar\n

" ] [ "\nbar\n" parse-farkup ] unit-test + +[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" parse-farkup ] unit-test + +[ "" ] [ "" parse-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index ff39606853..e605483f54 100644 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -40,6 +40,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' ) @@ -104,19 +105,25 @@ MEMO: line ( -- parser ) ] choice* repeat1 ; MEMO: paragraph ( -- parser ) + line + "\n" token over 2seq repeat0 + "\n" token "\n" token ensure-not 2seq optional 3seq [ - line , - "\n" token , - ] choice* repeat1 [ dup [ dup string? not swap [ blank? ] all? or ] deep-all? [ "

" swap "

" 3array ] unless ] action ; MEMO: farkup ( -- parser ) [ - list , h1 , h2 , h3 , h4 , code , paragraph , 2nl , - ] choice* repeat1 ; + list , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , + ] choice* repeat0 "\n" token optional 2seq ; : parse-farkup ( string -- string' ) farkup parse parse-result-ast [ [ dup string? [ write ] [ drop ] if ] deep-each ] with-string-writer ; + +! paragraph + ! [ + ! line , + ! "\n" token , + ! ] choice* repeat1 From 75a2838a7c3c82a72e1d3b2304377c8322891ad6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 Feb 2008 15:17:04 -0600 Subject: [PATCH 07/22] clean up duplication of words that used --- extra/farkup/farkup.factor | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index e605483f54..aadc61be85 100644 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -21,10 +21,13 @@ MEMO: delimiter ( -- parser ) [ dup delimiters member? swap CHAR: \n = not and ] satisfy [ 1string ] action ; +: surround-with-foo ( string tag -- seq ) + dup swap swapd 3array ; + : delimited ( str html -- parser ) [ over token hide , - text [ dup swap swapd 3array ] swapd curry action , + text [ surround-with-foo ] swapd curry action , token hide , ] seq* ; @@ -72,14 +75,22 @@ MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ; DEFER: line MEMO: list-item ( -- parser ) [ - "-" token hide , - line , - ] seq* - [ "li" swap "li" 3array ] action ; + "-" token hide , line , + ] seq* [ "li" surround-with-foo ] action ; MEMO: list ( -- parser ) list-item "\n" token hide list-of - [ "ul" swap "ul" 3array ] action ; + [ "ul" surround-with-foo ] action ; + +MEMO: table-column ( -- parser ) [ "|" token text ] seq* ; +MEMO: table-row ( -- parser ) + [ + "|" + ] seq* ; +MEMO: table ( -- parser ) + [ + "|" + ] seq* ; MEMO: code ( -- parser ) [ @@ -93,10 +104,6 @@ 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 , @@ -121,9 +128,3 @@ MEMO: farkup ( -- parser ) : parse-farkup ( string -- string' ) farkup parse parse-result-ast [ [ dup string? [ write ] [ drop ] if ] deep-each ] with-string-writer ; - -! paragraph - ! [ - ! line , - ! "\n" token , - ! ] choice* repeat1 From 11147c7bc03c29e31f1b5eaf7e86495171ff0ef3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 Feb 2008 15:17:17 -0600 Subject: [PATCH 08/22] add 2seq, 3seq --- extra/peg/peg.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8298814017..6e42668436 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -306,6 +306,12 @@ 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 @@ -343,7 +349,7 @@ MEMO: delay ( parser -- parser ) delay-parser construct-boa init-parser ; MEMO: list-of ( items separator -- parser ) - hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ; + hide over 2seq repeat0 [ concat ] action 2seq [ unclip 1vector swap first append ] action ; MEMO: 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] action ; From d143eedb6887b0ba58c257f7994240b174fb40a2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 15:22:39 -0600 Subject: [PATCH 09/22] Fix image upload for cygwin --- extra/bootstrap/image/upload/upload.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 0cdc7ccc26..1fa8ee4f41 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -17,7 +17,9 @@ bootstrap.image sequences io namespaces io.launcher math ; : upload-images ( -- ) [ - "scp" , boot-image-names % checksums , destination , + "scp" , + boot-image-names % + "temp/checksums.txt" , destination , ] { } make try-process ; : new-images ( -- ) From 0c9855167736d9f045cb127150b060f3b848d927 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 15:22:49 -0600 Subject: [PATCH 10/22] Add failing test --- extra/calendar/calendar-tests.factor | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index a3ae5f115a..a03ebeffcb 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -161,3 +161,19 @@ continuations system io.streams.string ; [ 1+1/2 ] [ "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader ] unit-test + +: check+dt now dup clone [ rot +dt drop ] keep = ; + +[ t ] [ 5 seconds check+dt ] unit-test + +[ t ] [ 5 minutes check+dt ] unit-test + +[ t ] [ 5 hours check+dt ] unit-test + +[ t ] [ 5 days check+dt ] unit-test + +[ t ] [ 5 weeks check+dt ] unit-test + +[ t ] [ 5 months check+dt ] unit-test + +[ t ] [ 5 years check+dt ] unit-test From dd9ace770710d339f02e4610743365a5cb56189a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 15:24:30 -0600 Subject: [PATCH 11/22] Don't need version number anymore --- core/kernel/kernel.factor | 2 -- core/listener/listener.factor | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d1f3af4779..61574e406f 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -3,8 +3,6 @@ USING: kernel.private ; IN: kernel -: version ( -- str ) "0.92" ; foldable - ! Stack stuff : spin ( x y z -- z y x ) swap rot ; inline diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 288cb53322..c3142bde4d 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -63,7 +63,7 @@ M: duplex-stream stream-read-quot [ listen until-quit ] if ; inline : print-banner ( -- ) - "Factor " write version write + "Factor #" write build write " on " write os write "/" write cpu print ; : listener ( -- ) From ac02bd8319c7dd906399e641e7e9bdfdb69945fe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 16:45:06 -0600 Subject: [PATCH 12/22] Fix listener --- core/listener/listener.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/listener/listener.factor b/core/listener/listener.factor index c3142bde4d..110f0d3ee1 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables io kernel math memory namespaces -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 build write + "Factor #" write build number>string write " on " write os write "/" write cpu print ; : listener ( -- ) From 635b02ca27c57ab6551428089600d9b798a32fc1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 Feb 2008 17:13:15 -0600 Subject: [PATCH 13/22] implement list-of, list-of* in terms of (list-of) add 2choice 3choice --- extra/peg/peg.factor | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 6e42668436..ed7012da45 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -318,6 +318,12 @@ MEMO: range ( min max -- parser ) : 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 @@ -348,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 2seq repeat0 [ concat ] action 2seq [ 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 ; From 2d716e1b6a2095f0bf0e5b234a494e7fb29ec559 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 26 Feb 2008 17:20:34 -0600 Subject: [PATCH 14/22] fix tables a|b|c d|e|f is now a table --- extra/farkup/farkup-tests.factor | 16 ++++++++++++++ extra/farkup/farkup.factor | 36 ++++++++++++++++++++++++-------- 2 files changed, 43 insertions(+), 9 deletions(-) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index ec1b915d4d..db11833cf1 100644 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -24,3 +24,19 @@ IN: temporary [ "

foo

\n

bar

" ] [ "foo\n\n\nbar" parse-farkup ] unit-test [ "" ] [ "" parse-farkup ] unit-test + +[ "

|a

" ] +[ "|a" parse-farkup ] unit-test + +[ "

|a|

" ] +[ "|a|" parse-farkup ] unit-test + +[ "
ab
" ] +[ "a|b" parse-farkup ] unit-test + +[ "
ab
\n
cd
" ] +[ "a|b\nc|d" parse-farkup ] unit-test + +[ "
ab
\n
cd
\n" ] +[ "a|b\nc|d\n" parse-farkup ] unit-test + diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index aadc61be85..718b8b3e28 100644 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -82,15 +82,16 @@ MEMO: list ( -- parser ) list-item "\n" token hide list-of [ "ul" surround-with-foo ] action ; -MEMO: table-column ( -- parser ) [ "|" token text ] seq* ; +MEMO: table-column ( -- parser ) + text [ "td" surround-with-foo ] action ; + MEMO: table-row ( -- parser ) [ - "|" - ] seq* ; + table-column "|" token hide list-of* , + ] seq* [ "tr" surround-with-foo ] action ; + MEMO: table ( -- parser ) - [ - "|" - ] seq* ; + table-row repeat1 [ "table" surround-with-foo ] action ; MEMO: code ( -- parser ) [ @@ -122,9 +123,26 @@ MEMO: paragraph ( -- parser ) MEMO: farkup ( -- parser ) [ - list , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , + 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 ; From 5796a18d5949f0d508e073d200ef58f21b8307f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 17:21:38 -0600 Subject: [PATCH 15/22] Update docs --- core/kernel/kernel-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 456c3cc4ca..2f80e3c368 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -139,10 +139,6 @@ ARTICLE: "equality" "Equality and comparison testing" ! Defined in handbook.factor ABOUT: "dataflow" -HELP: version -{ $values { "str" string } } -{ $description "Outputs the version number of the current Factor instance." } ; - HELP: eq? ( obj1 obj2 -- ? ) { $values { "obj1" object } { "obj2" object } { "?" "a boolean" } } { $description "Tests if two references point at the same object." } ; From 2acfc8fe387ad1e2f2406cf73af039360ca5e5d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 17:22:48 -0600 Subject: [PATCH 16/22] Refactor calendar --- extra/calendar/calendar-tests.factor | 272 +++++++-------- extra/calendar/calendar.factor | 387 ++++++++-------------- extra/calendar/format/format-tests.factor | 22 ++ extra/calendar/format/format.factor | 138 ++++++++ extra/webapps/file/file.factor | 3 + extra/windows/time/time-tests.factor | 2 +- extra/windows/time/time.factor | 2 +- 7 files changed, 423 insertions(+), 403 deletions(-) create mode 100755 extra/calendar/format/format-tests.factor create mode 100755 extra/calendar/format/format.factor mode change 100644 => 100755 extra/windows/time/time-tests.factor diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index a03ebeffcb..804c2b5fb1 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,14 @@ 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 +! [ 2004 12 32 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 2 30 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2003 2 29 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 -2 9 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 0 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 1 24 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 1 23 60 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 1 23 59 60 0 ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test @@ -16,164 +16,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 1 seconds time+ + 2006 10 10 0 0 1 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 100 seconds time+ + 2006 10 10 0 1 40 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 seconds time+ + 2006 10 9 23 58 20 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 86400 seconds time+ + 2006 10 11 0 0 0 0 = ] 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 10 minutes time+ + 2006 10 10 0 10 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10.5 minutes time+ + 2006 10 10 0 10 30 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 3/4 minutes time+ + 2006 10 10 0 0 45 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -3/4 minutes time+ + 2006 10 9 23 59 15 0 = ] 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 7200 minutes time+ + 2006 10 15 0 0 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -10 minutes time+ + 2006 10 9 23 50 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 minutes time+ + 2006 10 9 22 20 0 0 = ] 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 1 hours time+ + 2006 1 1 1 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 hours time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 hours time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 hours time+ + 2006 1 1 12 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 72 hours time+ + 2006 1 4 0 0 0 0 = ] 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 1 days time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 days time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 365 days time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -365 days time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 365 days time+ + 2004 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 366 days time+ + 2005 1 1 0 0 0 0 = ] 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 11 months time+ + 2006 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 months time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 months time+ + 2008 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 13 months time+ + 2007 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 months time+ + 2006 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 months time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 months time+ + 2005 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -2 months time+ + 2005 11 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -13 months time+ + 2004 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 months time+ + 2004 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 12 months time+ + 2005 3 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 -12 months time+ + 2003 3 1 0 0 0 0 = ] 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 0 years time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 years time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 years time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -100 years time+ + 1906 1 1 0 0 0 0 = ] unit-test +! [ t ] [ 2004 2 29 0 0 0 0 -1 years time+ +! 2003 2 28 0 0 0 0 = ] 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 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 ] 3keep 0 0 0 0 = ] 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 day-of-year ] unit-test +[ 60 ] [ 2004 2 29 0 0 0 0 day-of-year ] unit-test +[ 61 ] [ 2004 3 1 0 0 0 0 day-of-year ] unit-test +[ 366 ] [ 2004 12 31 0 0 0 0 day-of-year ] unit-test +[ 365 ] [ 2003 12 31 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2003 3 1 0 0 0 0 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 dup = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 10 seconds 5 years time+ time+ + 2009 1 1 0 0 10 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 -10 seconds -5 years time+ time+ + 1998 12 31 23 59 50 0 = ] 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 0 convert-timezone + 2004 1 1 11 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 5 0 0 -11 0 convert-timezone + 2004 1 1 16 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 23 0 0 9+1/2 0 convert-timezone + 2004 1 1 13 30 0 0 = ] 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 + 2004 1 1 12 30 0 -1 <=> ] 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 + 2004 1 1 12 30 0 0 <=> ] 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 + 2004 1 1 13 30 0 0 <=> ] 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 + 2004 1 1 13 30 0 0 <=> ] 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 -: check+dt now dup clone [ rot +dt drop ] keep = ; +[ t ] [ 5 weeks checktime+ ] unit-test -[ t ] [ 5 seconds check+dt ] unit-test +[ t ] [ 5 months checktime+ ] unit-test -[ t ] [ 5 minutes check+dt ] unit-test - -[ t ] [ 5 hours check+dt ] unit-test - -[ t ] [ 5 days check+dt ] unit-test - -[ t ] [ 5 weeks check+dt ] unit-test - -[ t ] [ 5 months check+dt ] unit-test - -[ t ] [ 5 years check+dt ] unit-test +[ t ] [ 5 years checktime+ ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index d834698d08..7bd655b002 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -1,20 +1,21 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables io io.streams.string kernel math -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 -TUPLE: dt year month day hour minute second ; +: ( year month day -- timestamp ) + 0 0 0 gmt-offset ; -C:
dt +TUPLE: duration year month day hour minute second ; + +C: duration : month-names { @@ -40,6 +41,8 @@ C:
dt #! length of average month in days 30.41666666666667 ; + + : julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 @@ -74,38 +79,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 ( --
) 0 0 0 0 0 0
; -: 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 ; +: 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 ; +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? ; + +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 365.2425 * +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 ) - [ 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+ + [ year>> ] +slots + [ month>> ] +slots + [ day>> ] +slots + [ hour>> ] +slots + [ minute>> ] +slots + [ second>> ] +slots + 2drop ; : 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>> 12 / + ] keep + [ day>> 365.2425 / + ] keep + [ hour>> 8765.82 / + ] keep + [ minute>> 525949.2 / + ] keep + second>> 31556952.0 / + ; + +M: duration <=> [ dt>years ] compare ; : dt>months ( dt -- x ) dt>years 12 * ; : dt>days ( dt -- x ) dt>years 365.2425 * ; @@ -204,8 +220,9 @@ M: number +second ( timestamp n -- timestamp ) : dt>milliseconds ( dt -- x ) dt>years 31556952000 * ; : 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,42 +233,37 @@ M: number +second ( timestamp n -- timestamp ) M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; -: timestamp- ( timestamp timestamp -- seconds ) +: time- ( timestamp timestamp -- seconds ) #! Exact calendar-time difference [ >gmt ] 2apply [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; + 1970 1 1 0 0 0 0 ; 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 ; + +: before ( dt -- -dt ) + [ year>> neg ] keep + [ month>> neg ] keep + [ day>> neg ] keep + [ hour>> neg ] keep + [ minute>> neg ] keep + [ second>> neg ] keep + ; + +: from-now ( dt -- timestamp ) now swap time+ ; : ago ( dt -- timestamp ) before from-now ; : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; @@ -268,7 +280,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 +292,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 +309,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 >r 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 " " 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 - ; - -: 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 +333,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- ; + 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" ] } diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor new file mode 100755 index 0000000000..1f23d4f841 --- /dev/null +++ b/extra/calendar/format/format-tests.factor @@ -0,0 +1,22 @@ +IN: temporary +USING: calendar.format tools.test io.streams.string ; + +[ 0 ] [ + "Z" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1 ] [ + "+01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1 ] [ + "-01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1-1/2 ] [ + "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1+1/2 ] [ + "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor new file mode 100755 index 0000000000..ea8d387e01 --- /dev/null +++ b/extra/calendar/format/format.factor @@ -0,0 +1,138 @@ +IN: calendar.format +USING: math math.parser kernel sequences io calendar +accessors arrays io.streams.string combinators ; + +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 " " 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 + ; + +: 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 ; diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 82bc5d1316..898ae35f1a 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -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 ; diff --git a/extra/windows/time/time-tests.factor b/extra/windows/time/time-tests.factor old mode 100644 new mode 100755 index ed0dcae6f4..dc846a1b04 --- a/extra/windows/time/time-tests.factor +++ b/extra/windows/time/time-tests.factor @@ -2,5 +2,5 @@ USING: calendar calendar.windows kernel tools.test ; [ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test [ t ] [ windows-time [ windows-time>FILETIME FILETIME>windows-time ] keep = ] unit-test -[ t ] [ windows-1601 400 years +dt [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test +[ t ] [ windows-1601 400 years time+ [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor index 3ccb4cfa67..5409edbb75 100755 --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -15,7 +15,7 @@ IN: windows.time FILETIME-dwHighDateTime >64bit ; : windows-time>timestamp ( n -- timestamp ) - 10000000 /i seconds windows-1601 swap +dt ; + 10000000 /i seconds windows-1601 swap time+ ; : windows-time ( -- n ) "FILETIME" [ GetSystemTimeAsFileTime ] keep From 3bf3c3ee5abd1b6e647df9c7fd4cd6de40d7bf79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 17:33:48 -0600 Subject: [PATCH 17/22] New sorting comparison operators --- core/math/math.factor | 5 +++++ core/sorting/sorting-tests.factor | 2 +- core/sorting/sorting.factor | 2 +- core/strings/strings-tests.factor | 4 ++-- extra/alarms/alarms.factor | 4 ++-- extra/opengl/capabilities/capabilities.factor | 8 ++++---- extra/trees/avl/avl.factor | 4 ++-- extra/trees/trees.factor | 10 +++------- extra/ui/gadgets/editors/editors.factor | 2 +- 9 files changed, 21 insertions(+), 20 deletions(-) mode change 100644 => 100755 core/sorting/sorting-tests.factor mode change 100644 => 100755 extra/opengl/capabilities/capabilities.factor mode change 100644 => 100755 extra/trees/avl/avl.factor mode change 100644 => 100755 extra/trees/trees.factor diff --git a/core/math/math.factor b/core/math/math.factor index 1d034aad49..cd908ea10f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -17,6 +17,11 @@ MATH: <= ( x y -- ? ) foldable MATH: > ( x y -- ? ) foldable MATH: >= ( x y -- ? ) foldable +: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline +: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline +: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline +: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline + MATH: + ( x y -- z ) foldable MATH: - ( x y -- z ) foldable MATH: * ( x y -- z ) foldable diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor old mode 100644 new mode 100755 index 8325832050..d9227b2d95 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -11,7 +11,7 @@ unit-test [ t ] [ 100 [ drop - 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ <=> 0 <= ] monotonic? + 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic? ] all? ] unit-test diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 25b8252ea1..ab2ce21010 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -52,7 +52,7 @@ PRIVATE> : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ; -: sort-pair ( a b -- c d ) 2dup <=> 0 > [ swap ] when ; +: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ; : midpoint ( seq -- elt ) [ midpoint@ ] keep nth-unsafe ; inline diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 90e74275ff..1df4e1c477 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -28,8 +28,8 @@ IN: temporary [ "end" ] [ "Beginning and end" 14 tail ] unit-test -[ t ] [ "abc" "abd" <=> 0 < ] unit-test -[ t ] [ "z" "abd" <=> 0 > ] unit-test +[ t ] [ "abc" "abd" before? ] unit-test +[ t ] [ "z" "abd" after? ] unit-test [ 0 10 "hello" subseq ] must-fail diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 7f43dbd612..651744d07f 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -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 ; diff --git a/extra/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor old mode 100644 new mode 100755 index d9eb6fd679..d27df4965d --- a/extra/opengl/capabilities/capabilities.factor +++ b/extra/opengl/capabilities/capabilities.factor @@ -26,8 +26,8 @@ IN: opengl.capabilities : version-seq ( version-string -- version-seq ) "." split [ string>number ] map ; -: version<=> ( version1 version2 -- n ) - 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)" % ] diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor old mode 100644 new mode 100755 index a806dafdec..81628684bc --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -53,14 +53,14 @@ TUPLE: avl-node balance ; DEFER: avl-set : avl-insert ( value key node -- node taller? ) - 2dup node-key key< left right ? [ + 2dup node-key before? left right ? [ [ node-link avl-set ] keep swap >r tuck set-node-link r> [ dup current-side get change-balance balance-insert ] [ f ] if ] with-side ; : (avl-set) ( value key node -- node taller? ) - 2dup node-key key= [ + 2dup node-key = [ -rot pick set-node-key over set-node-value f ] [ avl-insert ] if ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor old mode 100644 new mode 100755 index 6d53d9e541..e59bbab1ed --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -61,10 +61,6 @@ SYMBOL: current-side #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2 <=> sgn ; -: key< ( k1 k2 -- ? ) <=> 0 < ; -: key> ( k1 k2 -- ? ) <=> 0 > ; -: key= ( k1 k2 -- ? ) <=> zero? ; - : random-side ( -- side ) left right 2array random ; : choose-branch ( key node -- key node-left/right ) @@ -72,7 +68,7 @@ SYMBOL: current-side : node-at* ( key node -- value ? ) [ - 2dup node-key key= [ + 2dup node-key = [ nip node-value t ] [ choose-branch node-at* @@ -97,8 +93,8 @@ M: tree set-at ( value key tree -- ) : valid-node? ( node -- ? ) [ - dup dup node-left [ node-key swap node-key key< ] when* >r - dup dup node-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* ; diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 507dc932a4..def6b99b05 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -256,7 +256,7 @@ M: editor gadget-text* editor-string % ; } at T{ one-line-elt } or ; : drag-direction? ( loc editor -- ? ) - editor-mark* <=> 0 < ; + editor-mark* before? ; : drag-selection-caret ( loc editor element -- loc ) >r [ drag-direction? ] 2keep From 6fc74fd356c26e31f2ea5f11072519bb7917c6bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 17:33:57 -0600 Subject: [PATCH 18/22] New changer effect --- extra/new-slots/new-slots.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 4edd4239fa..3273036b8b 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -34,7 +34,7 @@ IN: new-slots [ \ over , swap writer-word , ] [ ] make define-inline ] [ 2drop ] if ; -: changer-effect T{ effect f { "object" "quot" } } ; inline +: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline : changer-word ( name -- word ) "change-" swap append changer-effect create-accessor ; @@ -44,9 +44,9 @@ IN: new-slots [ [ over >r >r ] % over reader-word , - [ r> call r> ] % - swap writer-word , - ] [ ] make define + [ r> call r> swap ] % + swap setter-word , + ] [ ] make define-inline ] [ 2drop ] if ; : define-new-slot ( class slot name -- ) From 64469916a95296fbdfbe1538ebba6d497cb8c874 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 18:40:32 -0600 Subject: [PATCH 19/22] New locals syntax; added M:: --- core/parser/parser.factor | 2 + core/syntax/syntax.factor | 2 +- extra/benchmark/fasta/fasta.factor | 6 +- extra/channels/examples/examples.factor | 2 +- extra/cocoa/plists/plists.factor | 1 + .../exchangers/exchangers-tests.factor | 2 +- extra/concurrency/locks/locks-tests.factor | 10 +-- extra/crypto/md5/md5.factor | 2 +- extra/io/sniffer/bsd/bsd.factor | 2 +- extra/locals/locals-docs.factor | 18 ++-- extra/locals/locals-tests.factor | 86 +++++++++++++------ extra/locals/locals.factor | 84 ++++++++++++------ extra/macros/macros.factor | 23 ++--- extra/math/miller-rabin/miller-rabin.factor | 2 +- extra/tools/walker/debug/debug.factor | 2 +- 15 files changed, 156 insertions(+), 88 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 63d3f2e45f..b51374d733 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -352,6 +352,8 @@ TUPLE: bad-number ; : parse-definition ( -- quot ) \ ; parse-until >quotation ; +: (:) CREATE dup reset-generic parse-definition ; + GENERIC: expected>string ( obj -- str ) M: f expected>string drop "end of input" ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 601c05d8d9..79a5553228 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -107,7 +107,7 @@ IN: bootstrap.syntax ] define-syntax ":" [ - CREATE dup reset-generic parse-definition define + (:) define ] define-syntax "GENERIC:" [ diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 75321def2d..1740bcb28e 100644 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -51,7 +51,7 @@ HINTS: random fixnum ; dup keys >byte-array swap values >float-array unclip [ + ] accumulate swap add ; -:: select-random | seed chars floats | +:: select-random ( seed chars floats -- elt ) floats seed random -rot [ >= ] curry find drop chars nth-unsafe ; inline @@ -62,7 +62,7 @@ HINTS: random fixnum ; : write-description ( desc id -- ) ">" write write bl print ; inline -:: split-lines | n quot | +:: split-lines ( n quot -- ) n line-length /mod [ [ line-length quot call ] times ] dip dup zero? [ drop ] quot if ; inline @@ -71,7 +71,7 @@ HINTS: random fixnum ; write-description [ make-random-fasta ] 2curry split-lines ; inline -:: make-repeat-fasta | k len alu | +:: make-repeat-fasta ( k len alu -- ) [let | kn [ alu length ] | len [ k + kn mod alu nth-unsafe ] B{ } map-as print k len + diff --git a/extra/channels/examples/examples.factor b/extra/channels/examples/examples.factor index 993b1db1a4..1e51fb06d8 100755 --- a/extra/channels/examples/examples.factor +++ b/extra/channels/examples/examples.factor @@ -24,7 +24,7 @@ IN: channels.examples from swap dupd mod zero? not [ swap to ] [ 2drop ] if ] 3keep filter ; -:: (sieve) | prime c | ( prime c -- ) +:: (sieve) ( prime c -- ) [let | p [ c from ] newc [ ] | p prime to diff --git a/extra/cocoa/plists/plists.factor b/extra/cocoa/plists/plists.factor index 32b35e9153..646a759c59 100644 --- a/extra/cocoa/plists/plists.factor +++ b/extra/cocoa/plists/plists.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: strings arrays hashtables assocs sequences xml.writer xml.utilities kernel namespaces ; +IN: cocoa.plists GENERIC: >plist ( obj -- tag ) diff --git a/extra/concurrency/exchangers/exchangers-tests.factor b/extra/concurrency/exchangers/exchangers-tests.factor index 3e7f67b9f0..91338389d1 100755 --- a/extra/concurrency/exchangers/exchangers-tests.factor +++ b/extra/concurrency/exchangers/exchangers-tests.factor @@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; -:: exchanger-test | | +:: exchanger-test ( -- ) [let | ex [ ] c [ 2 ] diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 8ebf6856a9..1280339231 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel threads sequences calendar ; -:: lock-test-0 | | +:: lock-test-0 ( -- ) [let | v [ V{ } clone ] c [ 2 ] | @@ -27,7 +27,7 @@ threads sequences calendar ; v ] ; -:: lock-test-1 | | +:: lock-test-1 ( -- ) [let | v [ V{ } clone ] l [ ] c [ 2 ] | @@ -79,7 +79,7 @@ threads sequences calendar ; [ ] [ dup [ [ ] with-read-lock ] with-write-lock ] unit-test -:: rw-lock-test-1 | | +:: rw-lock-test-1 ( -- ) [let | l [ ] c [ 1 ] c' [ 1 ] @@ -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 [ ] c [ 1 ] c' [ 2 ] @@ -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 [ ] | [ l [ 1 seconds sleep ] with-lock diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index fe215e32db..631a7a1020 100644 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -32,7 +32,7 @@ SYMBOL: old-d old-c c update-old-new old-d d update-old-new ; -:: (ABCD) | x s i k func a b c d | +:: (ABCD) ( x s i k func a b c d -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) a [ b get c get d get func call w+ diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor index 66336425a1..1c72a4780c 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/extra/io/sniffer/bsd/bsd.factor @@ -24,7 +24,7 @@ C: 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 ; diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 97f9aa5c65..b8d836ecc1 100644 --- a/extra/locals/locals-docs.factor +++ b/extra/locals/locals-docs.factor @@ -16,7 +16,7 @@ HELP: [| { $examples { $example "USE: locals" - ":: adder | n | [| m | m n + ] ;" + ":: adder ( n -- quot ) [| m | m n + ] ;" "3 5 adder call ." "8" } @@ -29,7 +29,7 @@ HELP: [let { $examples { $example "USING: locals math.functions ;" - ":: frobnicate | n seq |" + ":: frobnicate ( n seq -- newseq )" " [let | n' [ n 6 * ] |" " seq [ n' gcd nip ] map ] ;" "6 { 36 14 } frobnicate ." @@ -44,7 +44,7 @@ HELP: [wlet { $examples { $example "USE: locals" - ":: quuxify | n seq |" + ":: quuxify ( n seq -- newseq )" " [wlet | add-n [| m | m n + ] |" " seq [ add-n ] map ] ;" "2 { 1 2 3 } quuxify ." @@ -57,13 +57,15 @@ HELP: with-locals { $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ; HELP: :: -{ $syntax ":: word | bindings... | body... ;" } +{ $syntax ":: word ( bindings... -- outputs... ) body... ;" } { $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } +{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } { $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ; HELP: MACRO:: -{ $syntax "MACRO:: word | bindings... | body... ;" } -{ $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 = ] [ ... ] } ;" diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index aa724c4aca..b290c25159 100644 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,52 +1,52 @@ USING: locals math sequences tools.test hashtables words kernel -namespaces arrays ; +namespaces arrays strings prettyprint ; IN: temporary -:: foo | a b | a a ; +:: foo ( a b -- a a ) a a ; [ 1 1 ] [ 1 2 foo ] unit-test -:: add-test | a b | a b + ; +:: add-test ( a b -- c ) a b + ; [ 3 ] [ 1 2 add-test ] unit-test -:: sub-test | a b | a b - ; +:: sub-test ( a b -- c ) a b - ; [ -1 ] [ 1 2 sub-test ] unit-test -:: map-test | a b | a [ b + ] map ; +:: map-test ( a b -- seq ) a [ b + ] map ; [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test -:: map-test-2 | seq inc | seq [| elt | elt inc + ] map ; +:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ; [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test -:: let-test | c | +:: let-test ( c -- d ) [let | a [ 1 ] b [ 2 ] | a b + c + ] ; [ 7 ] [ 4 let-test ] unit-test -:: let-test-2 | | - [let | 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 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 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 diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 52ccb1bed3..2e6fd6485d 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables combinators.lib -prettyprint.sections sequences.private ; +prettyprint.sections sequences.private effects generic +compiler.units ; IN: locals ! Inspired by @@ -208,9 +209,6 @@ M: object local-rewrite* , ; : push-locals ( assoc -- ) use get push ; -: parse-locals ( -- words assoc ) - "|" parse-tokens make-locals ; - : pop-locals ( assoc -- ) use get delete ; @@ -218,7 +216,7 @@ M: object local-rewrite* , ; over push-locals parse-until >quotation swap pop-locals ; : parse-lambda ( -- lambda ) - parse-locals \ ] (parse-lambda) ; + "|" parse-tokens make-locals \ ] (parse-lambda) ; : (parse-bindings) ( -- ) scan dup "|" = [ @@ -246,11 +244,18 @@ M: wlet local-rewrite* dup wlet-bindings values over wlet-vars rot wlet-body [ call ] curry compose local-rewrite* \ call , ; -: (::) ( prop -- word quot n ) - >r CREATE dup reset-generic - scan "|" assert= parse-locals \ ; (parse-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) + 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 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 + ; + +M: lambda-method synopsis* + dup definer. + dup "method" word-prop dup + method-specializer pprint* + method-generic pprint* + method-stack-effect effect>string comment. ; PRIVATE> diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor index 7694d9fa84..87b3acd47c 100755 --- a/extra/macros/macros.factor +++ b/extra/macros/macros.factor @@ -1,26 +1,21 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. - -USING: parser kernel sequences words effects 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 ; -: (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 ; diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index 8b0d98283c..3985906b32 100755 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -30,7 +30,7 @@ TUPLE: positive-even-expected n ; #! factor an integer into s * 2^r 0 swap (factor-2s) ; -:: (miller-rabin) | n prime?! | +:: (miller-rabin) ( n prime?! -- ? ) n 1- factor-2s s set r set trials get [ n 1- [1,b] random a set diff --git a/extra/tools/walker/debug/debug.factor b/extra/tools/walker/debug/debug.factor index cfac9d8367..c8c0ff28a6 100755 --- a/extra/tools/walker/debug/debug.factor +++ b/extra/tools/walker/debug/debug.factor @@ -5,7 +5,7 @@ sequences concurrency.messaging locals continuations threads namespaces namespaces.private ; IN: tools.walker.debug -:: test-walker | quot | +:: test-walker ( quot -- data ) [let | p [ ] s [ f ] c [ f ] | From 4533e0e55ebf3b70e38e30128e74bc2bf10ad3e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 18:47:05 -0600 Subject: [PATCH 20/22] Load fixes --- extra/alarms/alarms-docs.factor | 4 ++-- extra/alarms/alarms.factor | 2 +- extra/calendar/calendar.factor | 10 +++++----- .../semaphores/semaphores-docs.factor | 4 ++-- extra/io/launcher/launcher-docs.factor | 2 +- extra/io/paths/paths.factor | 20 +++++++++---------- extra/io/timeouts/timeouts-docs.factor | 4 ++-- extra/models/models-docs.factor | 2 +- 8 files changed, 23 insertions(+), 25 deletions(-) diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index b609878c77..fcb2de8b6b 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -5,11 +5,11 @@ HELP: alarm { $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ; HELP: add-alarm -{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link dt } " or " { $link f } } { "alarm" alarm } } +{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } } { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; HELP: later -{ $values { "quot" quotation } { "time" dt } { "alarm" alarm } } +{ $values { "quot" quotation } { "time" duration } { "alarm" alarm } } { $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ; HELP: cancel-alarm diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 651744d07f..a50e1817e1 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -16,7 +16,7 @@ SYMBOL: alarm-thread alarm-thread get-global interrupt ; : check-alarm - dup dt? over not or [ "Not a dt" throw ] unless + dup duration? over not or [ "Not a duration" throw ] unless over timestamp? [ "Not a timestamp" throw ] unless pick callable? [ "Not a quotation" throw ] unless ; inline diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 7bd655b002..044553067b 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -255,12 +255,12 @@ M: timestamp <=> ( ts1 ts2 -- n ) : now ( -- timestamp ) gmt >local-time ; : before ( dt -- -dt ) - [ year>> neg ] keep - [ month>> neg ] keep - [ day>> neg ] keep - [ hour>> neg ] keep + [ year>> neg ] keep + [ month>> neg ] keep + [ day>> neg ] keep + [ hour>> neg ] keep [ minute>> neg ] keep - [ second>> neg ] keep + second>> neg ; : from-now ( dt -- timestamp ) now swap time+ ; diff --git a/extra/concurrency/semaphores/semaphores-docs.factor b/extra/concurrency/semaphores/semaphores-docs.factor index 7f8b9b017a..76a87f2077 100755 --- a/extra/concurrency/semaphores/semaphores-docs.factor +++ b/extra/concurrency/semaphores/semaphores-docs.factor @@ -9,7 +9,7 @@ HELP: { $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 diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 48b2a01b7d..96639dee87 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -78,7 +78,7 @@ $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; HELP: +timeout+ -{ $description "Launch descriptor key. If set to a " { $link dt } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; +{ $description "Launch descriptor key. If set to a " { $link duration } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ; HELP: default-descriptor { $description "Association storing default values for launch descriptor keys." } ; diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 8980eacc3d..fae07643d5 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -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 r> [ keep and ] curry ; inline - : find-file ( path bfs? quot -- path/f ) - prepare-find-file iterate-directory ; + >r r> + [ keep and ] curry iterate-directory ; inline + +: each-file ( path bfs? quot -- ) + >r 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 r> + pusher >r iterate-directory drop r> ; inline : recursive-directory ( path bfs? -- paths ) - - [ dup next-file dup ] [ ] [ drop ] unfold nip ; + [ ] accumulator >r each-file r> ; diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index 347c57a0d6..df7e1389cc 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -2,11 +2,11 @@ IN: io.timeouts USING: help.markup help.syntax math kernel calendar ; HELP: timeout -{ $values { "obj" object } { "dt/f" "a " { $link dt } " or " { $link f } } } +{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } } { $contract "Outputs an object's timeout." } ; HELP: set-timeout -{ $values { "dt/f" "a " { $link dt } " or " { $link f } } { "obj" object } } +{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } } { $contract "Sets an object's timeout." } ; HELP: timed-out diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor index ce86905b9f..d514a539aa 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -153,7 +153,7 @@ HELP: delay } ; HELP: -{ $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 } "." } ; From ef53dbd1b944391dd66fcf062039d5fb6d518786 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 19:18:21 -0600 Subject: [PATCH 21/22] Fix load-everything --- extra/calendar/format/format.factor | 2 +- extra/io/paths/paths.factor | 2 +- extra/lcd/lcd.factor | 5 +++-- extra/logging/parser/parser.factor | 2 +- extra/logging/server/server.factor | 2 +- extra/project-euler/019/019.factor | 8 ++++---- extra/smtp/smtp.factor | 2 +- extra/webapps/cgi/cgi.factor | 2 +- extra/webapps/file/file.factor | 2 +- extra/webapps/pastebin/pastebin.factor | 2 +- extra/webapps/planet/planet.factor | 2 +- extra/windows/time/time.factor | 2 +- extra/xml-rpc/xml-rpc.factor | 3 ++- 13 files changed, 19 insertions(+), 17 deletions(-) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index ea8d387e01..75ceea8ea2 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -1,6 +1,6 @@ IN: calendar.format USING: math math.parser kernel sequences io calendar -accessors arrays io.streams.string combinators ; +accessors arrays io.streams.string combinators accessors ; GENERIC: day. ( obj -- ) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index fae07643d5..4acfb9acad 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,5 +1,5 @@ USING: io.files kernel sequences new-slots accessors -dlists arrays ; +dlists arrays sequences.lib ; IN: io.paths TUPLE: directory-iterator path bfs queue ; diff --git a/extra/lcd/lcd.factor b/extra/lcd/lcd.factor index c2eba8b7b6..952bc17f17 100755 --- a/extra/lcd/lcd.factor +++ b/extra/lcd/lcd.factor @@ -1,5 +1,6 @@ -USING: sequences kernel math io calendar calendar.model -arrays models namespaces ui.gadgets ui.gadgets.labels +USING: sequences kernel math io calendar calendar.format +calendar.model arrays models namespaces ui.gadgets +ui.gadgets.labels ui.gadgets.theme ui ; IN: lcd diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index b4c7e12772..015861501e 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -3,7 +3,7 @@ USING: parser-combinators memoize kernel sequences logging arrays words strings vectors io io.files namespaces combinators combinators.lib logging.server -calendar ; +calendar calendar.format ; IN: logging.parser : string-of satisfy [ >string ] <@ ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index e31391e5d5..94d112583a 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -3,7 +3,7 @@ USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser words debugger math combinators concurrency.messaging -threads arrays init math.ranges strings ; +threads arrays init math.ranges strings calendar.format ; IN: logging.server : log-root ( -- string ) diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index fd3ca02135..391af05ffa 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -45,14 +45,14 @@ IN: project-euler.019 ; : end-date ( -- timestamp ) - 2000 12 31 0 0 0 0 make-timestamp ; + 2000 12 31 0 0 0 0 ; : (first-days) ( end-date start-date -- ) - 2dup timestamp- 0 >= [ - dup day-of-week , 1 +month (first-days) + 2dup time- 0 >= [ + dup day-of-week , 1 months time+ (first-days) ] [ 2drop ] if ; diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 184bd0c1cc..f3f90f68b9 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings -math.parser random system calendar ; +math.parser random system calendar calendar.format ; IN: smtp diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor index 1ef83abbe7..5dba9dae00 100755 --- a/extra/webapps/cgi/cgi.factor +++ b/extra/webapps/cgi/cgi.factor @@ -14,7 +14,7 @@ SYMBOL: cgi-root [ "CGI/1.0" "GATEWAY_INTERFACE" set "HTTP/1.0" "SERVER_PROTOCOL" set - "Factor " version append "SERVER_SOFTWARE" set + "Factor" "SERVER_SOFTWARE" set dup "PATH_TRANSLATED" set "SCRIPT_FILENAME" set diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 898ae35f1a..411c70c76a 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -3,7 +3,7 @@ USING: calendar html io io.files kernel math math.parser http.server.responders http.server.templating namespaces parser sequences strings assocs hashtables debugger http.mime sorting -html.elements logging ; +html.elements logging calendar.format ; IN: webapps.file SYMBOL: doc-root diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 21bae57fe7..36a72795db 100755 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,6 +1,6 @@ USING: calendar furnace furnace.validator io.files kernel namespaces sequences http.server.responders html math.parser rss -xml.writer xmode.code2html math ; +xml.writer xmode.code2html math calendar.format ; IN: webapps.pastebin TUPLE: pastebin pastes ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 062f6dbce2..9a5f8eeb97 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency.combinators kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint logging ; +xml.writer prettyprint logging calendar.format ; IN: webapps.planet : print-posting-summary ( posting -- ) diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor index 5409edbb75..011f500d88 100755 --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -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- >integer 10000000 * ; : windows-time>FILETIME ( n -- FILETIME ) "FILETIME" diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor index a7603a939e..ffccb5e0f5 100644 --- a/extra/xml-rpc/xml-rpc.factor +++ b/extra/xml-rpc/xml-rpc.factor @@ -3,7 +3,8 @@ IN: xml-rpc USING: kernel xml arrays math generic http.client combinators hashtables namespaces io base64 sequences strings calendar - xml.data xml.writer xml.utilities assocs math.parser debugger ; + xml.data xml.writer xml.utilities assocs math.parser debugger + calendar.format ; ! * Sending RPC requests ! TODO: time From 00ae7633519896670ed7b93779c575e20527867d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Feb 2008 20:03:35 -0600 Subject: [PATCH 22/22] Final calendar cleanup --- extra/calendar/calendar-tests.factor | 17 ++--- extra/calendar/calendar.factor | 103 ++++++++++++++++----------- extra/project-euler/019/019.factor | 19 ++--- extra/windows/time/time.factor | 2 +- 4 files changed, 79 insertions(+), 62 deletions(-) diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index 804c2b5fb1..f700d244f5 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,15 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; -! [ 2004 12 32 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 2 30 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2003 2 29 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 -2 9 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 12 0 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 12 1 24 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 12 1 23 60 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 12 1 23 59 60 0 ] [ "invalid timestamp" = ] must-fail-with +[ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2003 2 29 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 -2 9 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 0 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 24 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 60 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 59 60 0 valid-timestamp? ] unit-test +[ t ] [ now valid-timestamp? ] unit-test [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 044553067b..2b80a8dce6 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -37,9 +37,12 @@ C: duration : 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 whole-part swapd 365.2425 * +day swap +year ] unless-zero ; + [ 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 @@ -191,33 +194,37 @@ M: timestamp time+ >r clone r> (time+) drop ; M: duration time+ - [ year>> ] +slots - [ month>> ] +slots - [ day>> ] +slots - [ hour>> ] +slots - [ minute>> ] +slots - [ second>> ] +slots - 2drop ; + dup timestamp? [ + swap time+ + ] [ + [ year>> ] +slots + [ month>> ] +slots + [ day>> ] +slots + [ hour>> ] +slots + [ minute>> ] +slots + [ second>> ] +slots + 2drop + ] if ; : dt>years ( dt -- x ) #! Uses average month/year length since dt loses calendar #! data 0 swap [ year>> + ] keep - [ month>> 12 / + ] keep - [ day>> 365.2425 / + ] keep - [ hour>> 8765.82 / + ] keep - [ minute>> 525949.2 / + ] keep - second>> 31556952.0 / + ; + [ month>> months-per-year / + ] keep + [ day>> days-per-year / + ] keep + [ hour>> hours-per-year / + ] keep + [ minute>> minutes-per-year / + ] keep + second>> seconds-per-year / + ; M: duration <=> [ dt>years ] compare ; -: 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 * ; +: 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 gmt-offset>> over = [ drop ] [ @@ -233,26 +240,16 @@ M: duration <=> [ dt>years ] compare ; M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; -: time- ( 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 - + ; -: unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; foldable +GENERIC: time- ( time1 time2 -- time ) -: millis>timestamp ( n -- timestamp ) - >r unix-1970 r> milliseconds time+ ; - -: timestamp>millis ( timestamp -- n ) - unix-1970 time- 1000 * >integer ; - -: gmt ( -- timestamp ) - #! GMT time, right now - unix-1970 millis milliseconds time+ ; - -: now ( -- timestamp ) gmt >local-time ; +M: timestamp time- + #! Exact calendar-time difference + (time-) seconds ; : before ( dt -- -dt ) [ year>> neg ] keep @@ -263,10 +260,34 @@ M: timestamp <=> ( ts1 ts2 -- n ) second>> neg ; -: from-now ( dt -- timestamp ) now swap time+ ; -: ago ( dt -- timestamp ) before from-now ; +M: duration time- + before time+ ; -: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; +: 0 0 0 0 0 0 0 ; + +: valid-timestamp? ( timestamp -- ? ) + clone 0 >>gmt-offset + dup time- time+ = ; + +: unix-1970 ( -- timestamp ) + 1970 1 1 0 0 0 0 ; foldable + +: millis>timestamp ( n -- timestamp ) + >r unix-1970 r> milliseconds time+ ; + +: timestamp>millis ( timestamp -- n ) + unix-1970 (time-) 1000 * >integer ; + +: gmt ( -- timestamp ) + #! GMT time, right now + unix-1970 millis milliseconds time+ ; + +: now ( -- timestamp ) gmt >local-time ; + +: 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 @@ -347,7 +368,7 @@ M: timestamp day-of-year ( timestamp -- n ) : beginning-of-year ( timestamp -- new-timestamp ) beginning-of-month 1 >>month ; -: seconds-since-midnight ( timestamp -- x ) +: time-since-midnight ( timestamp -- duration ) dup beginning-of-day time- ; M: timestamp sleep-until timestamp>millis sleep-until ; diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index 391af05ffa..a2c3ebcd1f 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -45,25 +45,20 @@ IN: project-euler.019 ; + 1901 1 1 ; : end-date ( -- timestamp ) - 2000 12 31 0 0 0 0 ; + 2000 12 31 ; -: (first-days) ( end-date start-date -- ) - 2dup time- 0 >= [ - dup day-of-week , 1 months time+ (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 diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor index 011f500d88..62d2805f01 100755 --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -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 time- >integer 10000000 * ; + >gmt windows-1601 (time-) 10000000 * >integer ; : windows-time>FILETIME ( n -- FILETIME ) "FILETIME"