steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-02-26 21:03:22 -06:00
parent 66c9eb089a 6ded6740fe
commit cf9105c056
34 changed files with 307 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/parser/parser.factor
View File

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

2
core/syntax/syntax.factor
View File

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

6
extra/benchmark/fasta/fasta.factor
View File

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

17
extra/calendar/calendar-tests.factor
View File

@ -1,14 +1,15 @@
USING: arrays calendar kernel math sequences tools.test
continuations system ;
! [ 2004 12 32 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
! [ 2004 2 30 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
! [ 2003 2 29 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
! [ 2004 -2 9 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
! [ 2004 12 0 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
! [ 2004 12 1 24 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
! [ 2004 12 1 23 60 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
! [ 2004 12 1 23 59 60 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
[ t ] [ now valid-timestamp? ] unit-test
[ f ] [ 1900 leap-year? ] unit-test
[ t ] [ 1904 leap-year? ] unit-test

103
extra/calendar/calendar.factor
View File

@ -37,9 +37,12 @@ C: <duration> 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
<PRIVATE
@ -129,7 +132,7 @@ M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ;
M: real +year ( timestamp n -- timestamp )
[ float>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 <duration> ;
dup timestamp? [
swap time+
] [
[ year>> ] +slots
[ month>> ] +slots
[ day>> ] +slots
[ hour>> ] +slots
[ minute>> ] +slots
[ second>> ] +slots
2drop <duration>
] if ;
: dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar
#! data
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 <timestamp> ; 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
<duration> ;
: 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 } ;
: <zero> 0 0 0 0 0 0 0 <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
clone 0 >>gmt-offset
dup <zero> time- <zero> time+ = ;
: unix-1970 ( -- timestamp )
1970 1 1 0 0 0 0 <timestamp> ; 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 ;

2
extra/calendar/format/format.factor
View File

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

13
extra/calendar/unix/unix-tests.factor
View File

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

2
extra/channels/examples/examples.factor
View File

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

1
extra/cocoa/plists/plists.factor
View File

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

2
extra/concurrency/exchangers/exchangers-tests.factor
View File

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

10
extra/concurrency/locks/locks-tests.factor
View File

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

2
extra/crypto/md5/md5.factor
View File

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

14
extra/help/lint/lint-docs.factor
View File

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

51
extra/help/lint/lint.factor
View File

@ -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 [ <help-error> , ] recover ; inline
flush [ <help-error> , ] 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

2
extra/io/paths/paths.factor
View File

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

2
extra/io/sniffer/bsd/bsd.factor
View File

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

5
extra/lcd/lcd.factor
View File

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

18
extra/locals/locals-docs.factor
View File

@ -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 = ] [ ... ] } ;"

86
extra/locals/locals-tests.factor
View File

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

84
extra/locals/locals.factor
View File

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

2
extra/logging/parser/parser.factor
View File

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

2
extra/logging/server/server.factor
View File

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

23
extra/macros/macros.factor
View File

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

2
extra/math/miller-rabin/miller-rabin.factor
View File

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

19
extra/project-euler/019/019.factor
View File

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

2
extra/smtp/smtp.factor
View File

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

2
extra/tools/walker/debug/debug.factor
View File

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

20
extra/unix/unix.factor
View File

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

2
extra/webapps/cgi/cgi.factor
View File

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

2
extra/webapps/file/file.factor
View File

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

2
extra/webapps/pastebin/pastebin.factor
View File

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

2
extra/webapps/planet/planet.factor
View File

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

2
extra/windows/time/time.factor
View File

@ -23,7 +23,7 @@ IN: windows.time
: timestamp>windows-time ( timestamp -- n )
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
>gmt windows-1601 timestamp- >bignum 10000000 * ;
>gmt windows-1601 (time-) 10000000 * >integer ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>

3
extra/xml-rpc/xml-rpc.factor
View File

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