diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 97e8b18dfb..2f2d4a8c18 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/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/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/calendar/unix/unix-tests.factor b/extra/calendar/unix/unix-tests.factor deleted file mode 100644 index a35a60c6f3..0000000000 --- a/extra/calendar/unix/unix-tests.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: alien alien.c-types calendar calendar.unix -kernel math tools.test ; - -[ t ] [ 239293000 [ - unix-time>timestamp timestamp>timeval - timeval>timestamp timestamp>timeval *ulong -] keep = ] unit-test - - -[ t ] [ 23929000.3 [ - unix-time>timestamp timestamp>timeval - timeval>timestamp timestamp>timeval *ulong -] keep >bignum = ] unit-test 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/help/lint/lint-docs.factor b/extra/help/lint/lint-docs.factor index 2813391d07..6aa3310bf9 100644 --- a/extra/help/lint/lint-docs.factor +++ b/extra/help/lint/lint-docs.factor @@ -1,26 +1,26 @@ USING: help.markup help.syntax ; IN: help.lint -HELP: check-help -{ $description "Checks all word and article help." } ; +HELP: help-lint-all +{ $description "Checks all word help and articles in all loaded vocabularies." } ; -HELP: check-vocab-help +HELP: help-lint { $values { "vocab" "a vocabulary specifier" } } -{ $description "Checks all word help in the given vocabulary." } ; +{ $description "Checks all word help and articles in the given vocabulary and all child vocabularies." } ; ARTICLE: "help.lint" "Help lint tool" "The " { $vocab-link "help.lint" } " vocabulary implements a tool to check documentation in an automated fashion. You should use this tool to check any documentation that you write." $nl "To run help lint, use one of the following two words:" -{ $subsection check-help } -{ $subsection check-vocab-help } +{ $subsection help-lint } +{ $subsection help-lint-all } "Help lint performs the following checks:" { $list "ensures examples run and produce stated output" { "ensures " { $link $see-also } " elements don't contain duplicate entries" } { "ensures " { $link $vocab-link } " elements point to modules which actually exist" } { "ensures that " { $link $values } " match the stack effect declaration" } - { "ensures that word help articles actually render (this catches broken links, improper nesting, etc)" } + { "ensures that help topics actually render (this catches broken links, improper nesting, etc)" } } ; ABOUT: "help.lint" diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 3c11a93509..4b97499a4c 100644 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -5,7 +5,7 @@ words strings classes tools.browser namespaces io io.streams.string prettyprint definitions arrays vectors combinators splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate -macros combinators.lib ; +macros combinators.lib sequences.lib ; IN: help.lint : check-example ( element -- ) @@ -84,7 +84,7 @@ M: help-error error. delegate error. ; : check-something ( obj quot -- ) - over . flush [ , ] recover ; inline + flush [ , ] recover ; inline : check-word ( word -- ) dup word-help [ @@ -106,22 +106,45 @@ M: help-error error. [ dup check-rendering ] assert-depth drop ] check-something ; -: check-articles ( -- ) - articles get keys [ check-article ] each ; +: group-articles ( -- assoc ) + articles get keys + vocabs [ dup vocab-docs-path swap ] H{ } map>assoc + H{ } clone [ + [ + >r >r dup >link where ?first r> at r> [ ?push ] change-at + ] 2curry each + ] keep ; -: with-help-lint ( quot -- ) +: check-vocab ( vocab -- seq ) + "Checking " write dup write "..." print + [ + dup words [ check-word ] each + "vocab-articles" get at [ check-article ] each + ] { } make ; + +: run-help-lint ( prefix -- alist ) [ all-vocabs-seq [ vocab-name ] map "all-vocabs" set - call - ] { } make [ nl error. ] each ; inline + articles get keys "group-articles" set + child-vocabs + [ dup check-vocab ] { } map>assoc + [ nip empty? not ] assoc-subset + ] with-scope ; -: check-help ( -- ) - [ all-words check-words check-articles ] with-help-lint ; +: typos. ( assoc -- ) + dup empty? [ + drop + "==== ALL CHECKS PASSED" print + ] [ + [ + swap vocab-heading. + [ error. nl ] each + ] assoc-each + ] if ; -: check-vocab-help ( vocab -- ) - [ - child-vocabs [ words check-words ] each - ] with-help-lint ; +: help-lint ( prefix -- ) run-help-lint typos. ; + +: help-lint-all ( -- ) "" help-lint ; : unlinked-words ( words -- seq ) all-word-help [ article-parent not ] subset ; @@ -132,4 +155,4 @@ M: help-error error. [ article-parent ] subset [ "predicating" word-prop not ] subset ; -MAIN: check-help +MAIN: help-lint 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/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/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/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/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/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/project-euler/019/019.factor b/extra/project-euler/019/019.factor index fd3ca02135..a2c3ebcd1f 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -45,25 +45,20 @@ IN: project-euler.019 ; : end-date ( -- timestamp ) - 2000 12 31 0 0 0 0 make-timestamp ; + 2000 12 31 ; -: (first-days) ( end-date start-date -- ) - 2dup timestamp- 0 >= [ - dup day-of-week , 1 +month (first-days) - ] [ - 2drop - ] if ; - -: first-days ( start-date end-date -- seq ) - [ swap (first-days) ] { } make ; +: first-days ( end-date start-date -- days ) + [ 2dup after=? ] + [ dup 1 months time+ swap day-of-week ] + [ ] unfold 2nip ; PRIVATE> : euler019a ( -- answer ) - start-date end-date first-days [ zero? ] count ; + end-date start-date first-days [ zero? ] count ; ! [ euler019a ] 100 ave-time ! 131 ms run / 3 ms GC ave time - 100 trials 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/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 ] | diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 9d5a6122a2..7df41069e0 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -5,22 +5,29 @@ USING: alien alien.c-types alien.syntax kernel libc structs math namespaces system combinators vocabs.loader ; ! ! ! Unix types -TYPEDEF: int blksize_t -TYPEDEF: int dev_t + +TYPEDEF: long word +TYPEDEF: ulong uword + +TYPEDEF: long longword +TYPEDEF: ulong ulongword + TYPEDEF: long ssize_t -TYPEDEF: longlong blkcnt_t +TYPEDEF: longword blksize_t +TYPEDEF: longword blkcnt_t TYPEDEF: longlong quad_t +TYPEDEF: ulonglong dev_t TYPEDEF: uint gid_t TYPEDEF: uint in_addr_t -TYPEDEF: uint ino_t +TYPEDEF: ulong ino_t TYPEDEF: int pid_t TYPEDEF: uint socklen_t TYPEDEF: uint time_t TYPEDEF: uint uid_t TYPEDEF: ulong size_t TYPEDEF: ulong u_long -TYPEDEF: ushort mode_t -TYPEDEF: ushort nlink_t +TYPEDEF: uint mode_t +TYPEDEF: uword nlink_t TYPEDEF: void* caddr_t TYPEDEF: ulong off_t @@ -226,3 +233,4 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { [ solaris? ] [ "unix.solaris" require ] } { [ t ] [ ] } } cond + 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..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 timestamp- >bignum 10000000 * ; + >gmt windows-1601 (time-) 10000000 * >integer ; : 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