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-definition ( -- quot )
\ ; parse-until >quotation ; \ ; parse-until >quotation ;
: (:) CREATE dup reset-generic parse-definition ;
GENERIC: expected>string ( obj -- str ) GENERIC: expected>string ( obj -- str )
M: f expected>string drop "end of input" ; M: f expected>string drop "end of input" ;

2
core/syntax/syntax.factor
View File

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

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

@ -51,7 +51,7 @@ HINTS: random fixnum ;
dup keys >byte-array dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ; swap values >float-array unclip [ + ] accumulate swap add ;
:: select-random | seed chars floats | :: select-random ( seed chars floats -- elt )
floats seed random -rot floats seed random -rot
[ >= ] curry find drop [ >= ] curry find drop
chars nth-unsafe ; inline chars nth-unsafe ; inline
@ -62,7 +62,7 @@ HINTS: random fixnum ;
: write-description ( desc id -- ) : write-description ( desc id -- )
">" write write bl print ; inline ">" write write bl print ; inline
:: split-lines | n quot | :: split-lines ( n quot -- )
n line-length /mod n line-length /mod
[ [ line-length quot call ] times ] dip [ [ line-length quot call ] times ] dip
dup zero? [ drop ] quot if ; inline dup zero? [ drop ] quot if ; inline
@ -71,7 +71,7 @@ HINTS: random fixnum ;
write-description write-description
[ make-random-fasta ] 2curry split-lines ; inline [ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta | k len alu | :: make-repeat-fasta ( k len alu -- )
[let | kn [ alu length ] | [let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len + k len +

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

@ -1,14 +1,15 @@
USING: arrays calendar kernel math sequences tools.test USING: arrays calendar kernel math sequences tools.test
continuations system ; continuations system ;
! [ 2004 12 32 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
! [ 2004 2 30 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
! [ 2003 2 29 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
! [ 2004 -2 9 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
! [ 2004 12 0 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
! [ 2004 12 1 24 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
! [ 2004 12 1 23 60 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
! [ 2004 12 1 23 59 60 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
[ t ] [ now valid-timestamp? ] unit-test
[ f ] [ 1900 leap-year? ] unit-test [ f ] [ 1900 leap-year? ] unit-test
[ t ] [ 1904 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-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ; : day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
: average-month ( -- x ) : average-month 30+5/12 ; inline
#! length of average month in days : months-per-year 12 ; inline
30.41666666666667 ; : days-per-year 3652425/10000 ; inline
: hours-per-year 876582/100 ; inline
: minutes-per-year 5259492/10 ; inline
: seconds-per-year 31556952 ; inline
<PRIVATE <PRIVATE
@ -129,7 +132,7 @@ M: integer +year ( timestamp n -- timestamp )
[ [ + ] curry change-year adjust-leap-year ] unless-zero ; [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
M: real +year ( timestamp n -- timestamp ) 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 ) : months/years ( n -- months years )
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
@ -191,33 +194,37 @@ M: timestamp time+
>r clone r> (time+) drop ; >r clone r> (time+) drop ;
M: duration time+ M: duration time+
[ year>> ] +slots dup timestamp? [
[ month>> ] +slots swap time+
[ day>> ] +slots ] [
[ hour>> ] +slots [ year>> ] +slots
[ minute>> ] +slots [ month>> ] +slots
[ second>> ] +slots [ day>> ] +slots
2drop <duration> ; [ hour>> ] +slots
[ minute>> ] +slots
[ second>> ] +slots
2drop <duration>
] if ;
: dt>years ( dt -- x ) : dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar #! Uses average month/year length since dt loses calendar
#! data #! data
0 swap 0 swap
[ year>> + ] keep [ year>> + ] keep
[ month>> 12 / + ] keep [ month>> months-per-year / + ] keep
[ day>> 365.2425 / + ] keep [ day>> days-per-year / + ] keep
[ hour>> 8765.82 / + ] keep [ hour>> hours-per-year / + ] keep
[ minute>> 525949.2 / + ] keep [ minute>> minutes-per-year / + ] keep
second>> 31556952.0 / + ; second>> seconds-per-year / + ;
M: duration <=> [ dt>years ] compare ; M: duration <=> [ dt>years ] compare ;
: dt>months ( dt -- x ) dt>years 12 * ; : dt>months ( dt -- x ) dt>years months-per-year * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ; : dt>days ( dt -- x ) dt>years days-per-year * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ; : dt>hours ( dt -- x ) dt>years hours-per-year * ;
: dt>minutes ( dt -- x ) dt>years 525949.2 * ; : dt>minutes ( dt -- x ) dt>years minutes-per-year * ;
: dt>seconds ( dt -- x ) dt>years 31556952 * ; : dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ; : dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
: convert-timezone ( timestamp n -- timestamp ) : convert-timezone ( timestamp n -- timestamp )
over gmt-offset>> over = [ drop ] [ over gmt-offset>> over = [ drop ] [
@ -233,26 +240,16 @@ M: duration <=> [ dt>years ] compare ;
M: timestamp <=> ( ts1 ts2 -- n ) M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ; [ >gmt tuple-slots ] compare ;
: time- ( timestamp timestamp -- seconds ) : (time-) ( timestamp timestamp -- n )
#! Exact calendar-time difference
[ >gmt ] 2apply [ >gmt ] 2apply
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
: unix-1970 ( -- timestamp ) GENERIC: time- ( time1 time2 -- time )
1970 1 1 0 0 0 0 <timestamp> ; foldable
: millis>timestamp ( n -- timestamp ) M: timestamp time-
>r unix-1970 r> milliseconds time+ ; #! Exact calendar-time difference
(time-) seconds ;
: 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 ;
: before ( dt -- -dt ) : before ( dt -- -dt )
[ year>> neg ] keep [ year>> neg ] keep
@ -263,10 +260,34 @@ M: timestamp <=> ( ts1 ts2 -- n )
second>> neg second>> neg
<duration> ; <duration> ;
: from-now ( dt -- timestamp ) now swap time+ ; M: duration time-
: ago ( dt -- timestamp ) before from-now ; 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 ( year month day -- n )
#! Zeller Congruence #! Zeller Congruence
@ -347,7 +368,7 @@ M: timestamp day-of-year ( timestamp -- n )
: beginning-of-year ( timestamp -- new-timestamp ) : beginning-of-year ( timestamp -- new-timestamp )
beginning-of-month 1 >>month ; beginning-of-month 1 >>month ;
: seconds-since-midnight ( timestamp -- x ) : time-since-midnight ( timestamp -- duration )
dup beginning-of-day time- ; dup beginning-of-day time- ;
M: timestamp sleep-until timestamp>millis sleep-until ; M: timestamp sleep-until timestamp>millis sleep-until ;

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

@ -1,6 +1,6 @@
IN: calendar.format IN: calendar.format
USING: math math.parser kernel sequences io calendar USING: math math.parser kernel sequences io calendar
accessors arrays io.streams.string combinators ; accessors arrays io.streams.string combinators accessors ;
GENERIC: day. ( obj -- ) 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 from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ; ] 3keep filter ;
:: (sieve) | prime c | ( prime c -- ) :: (sieve) ( prime c -- )
[let | p [ c from ] [let | p [ c from ]
newc [ <channel> ] | newc [ <channel> ] |
p prime to p prime to

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

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences USING: strings arrays hashtables assocs sequences
xml.writer xml.utilities kernel namespaces ; xml.writer xml.utilities kernel namespaces ;
IN: cocoa.plists
GENERIC: >plist ( obj -- tag ) 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 concurrency.count-downs concurrency.promises locals kernel
threads ; threads ;
:: exchanger-test | | :: exchanger-test ( -- )
[let | [let |
ex [ <exchanger> ] ex [ <exchanger> ]
c [ 2 <count-down> ] 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 concurrency.messaging concurrency.mailboxes locals kernel
threads sequences calendar ; threads sequences calendar ;
:: lock-test-0 | | :: lock-test-0 ( -- )
[let | v [ V{ } clone ] [let | v [ V{ } clone ]
c [ 2 <count-down> ] | c [ 2 <count-down> ] |
@ -27,7 +27,7 @@ threads sequences calendar ;
v v
] ; ] ;
:: lock-test-1 | | :: lock-test-1 ( -- )
[let | v [ V{ } clone ] [let | v [ V{ } clone ]
l [ <lock> ] l [ <lock> ]
c [ 2 <count-down> ] | c [ 2 <count-down> ] |
@ -79,7 +79,7 @@ threads sequences calendar ;
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
:: rw-lock-test-1 | | :: rw-lock-test-1 ( -- )
[let | l [ <rw-lock> ] [let | l [ <rw-lock> ]
c [ 1 <count-down> ] c [ 1 <count-down> ]
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 [ 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> ] [let | l [ <rw-lock> ]
c [ 1 <count-down> ] c [ 1 <count-down> ]
c' [ 2 <count-down> ] c' [ 2 <count-down> ]
@ -160,7 +160,7 @@ threads sequences calendar ;
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
! Test lock timeouts ! Test lock timeouts
:: lock-timeout-test | | :: lock-timeout-test ( -- )
[let | l [ <lock> ] | [let | l [ <lock> ] |
[ [
l [ 1 seconds sleep ] with-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-c c update-old-new
old-d d 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 + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
a [ a [
b get c get d get func call w+ 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 ; USING: help.markup help.syntax ;
IN: help.lint IN: help.lint
HELP: check-help HELP: help-lint-all
{ $description "Checks all word and article help." } ; { $description "Checks all word help and articles in all loaded vocabularies." } ;
HELP: check-vocab-help HELP: help-lint
{ $values { "vocab" "a vocabulary specifier" } } { $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" 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." "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 $nl
"To run help lint, use one of the following two words:" "To run help lint, use one of the following two words:"
{ $subsection check-help } { $subsection help-lint }
{ $subsection check-vocab-help } { $subsection help-lint-all }
"Help lint performs the following checks:" "Help lint performs the following checks:"
{ $list { $list
"ensures examples run and produce stated output" "ensures examples run and produce stated output"
{ "ensures " { $link $see-also } " elements don't contain duplicate entries" } { "ensures " { $link $see-also } " elements don't contain duplicate entries" }
{ "ensures " { $link $vocab-link } " elements point to modules which actually exist" } { "ensures " { $link $vocab-link } " elements point to modules which actually exist" }
{ "ensures that " { $link $values } " match the stack effect declaration" } { "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" 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 io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate vocabs.loader assocs editors continuations classes.predicate
macros combinators.lib ; macros combinators.lib sequences.lib ;
IN: help.lint IN: help.lint
: check-example ( element -- ) : check-example ( element -- )
@ -84,7 +84,7 @@ M: help-error error.
delegate error. ; delegate error. ;
: check-something ( obj quot -- ) : check-something ( obj quot -- )
over . flush [ <help-error> , ] recover ; inline flush [ <help-error> , ] recover ; inline
: check-word ( word -- ) : check-word ( word -- )
dup word-help [ dup word-help [
@ -106,22 +106,45 @@ M: help-error error.
[ dup check-rendering ] assert-depth drop [ dup check-rendering ] assert-depth drop
] check-something ; ] check-something ;
: check-articles ( -- ) : group-articles ( -- assoc )
articles get keys [ check-article ] each ; 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 all-vocabs-seq [ vocab-name ] map "all-vocabs" set
call articles get keys "group-articles" set
] { } make [ nl error. ] each ; inline child-vocabs
[ dup check-vocab ] { } map>assoc
[ nip empty? not ] assoc-subset
] with-scope ;
: check-help ( -- ) : typos. ( assoc -- )
[ all-words check-words check-articles ] with-help-lint ; dup empty? [
drop
"==== ALL CHECKS PASSED" print
] [
[
swap vocab-heading.
[ error. nl ] each
] assoc-each
] if ;
: check-vocab-help ( vocab -- ) : help-lint ( prefix -- ) run-help-lint typos. ;
[
child-vocabs [ words check-words ] each : help-lint-all ( -- ) "" help-lint ;
] with-help-lint ;
: unlinked-words ( words -- seq ) : unlinked-words ( words -- seq )
all-word-help [ article-parent not ] subset ; all-word-help [ article-parent not ] subset ;
@ -132,4 +155,4 @@ M: help-error error.
[ article-parent ] subset [ article-parent ] subset
[ "predicating" word-prop not ] 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 USING: io.files kernel sequences new-slots accessors
dlists arrays ; dlists arrays sequences.lib ;
IN: io.paths IN: io.paths
TUPLE: directory-iterator path bfs queue ; 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_INOUT IOC_IN IOC_OUT bitor ; inline
: IOC_DIRMASK HEX: e0000000 ; inline : IOC_DIRMASK HEX: e0000000 ; inline
:: ioc | inout group num len | :: ioc ( inout group num len -- n )
group first 8 shift num bitor group first 8 shift num bitor
len IOCPARM_MASK bitand 16 shift bitor len IOCPARM_MASK bitand 16 shift bitor
inout bitor ; inout bitor ;

5
extra/lcd/lcd.factor
View File

@ -1,5 +1,6 @@
USING: sequences kernel math io calendar calendar.model USING: sequences kernel math io calendar calendar.format
arrays models namespaces ui.gadgets ui.gadgets.labels calendar.model arrays models namespaces ui.gadgets
ui.gadgets.labels
ui.gadgets.theme ui ; ui.gadgets.theme ui ;
IN: lcd IN: lcd

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

@ -16,7 +16,7 @@ HELP: [|
{ $examples { $examples
{ $example { $example
"USE: locals" "USE: locals"
":: adder | n | [| m | m n + ] ;" ":: adder ( n -- quot ) [| m | m n + ] ;"
"3 5 adder call ." "3 5 adder call ."
"8" "8"
} }
@ -29,7 +29,7 @@ HELP: [let
{ $examples { $examples
{ $example { $example
"USING: locals math.functions ;" "USING: locals math.functions ;"
":: frobnicate | n seq |" ":: frobnicate ( n seq -- newseq )"
" [let | n' [ n 6 * ] |" " [let | n' [ n 6 * ] |"
" seq [ n' gcd nip ] map ] ;" " seq [ n' gcd nip ] map ] ;"
"6 { 36 14 } frobnicate ." "6 { 36 14 } frobnicate ."
@ -44,7 +44,7 @@ HELP: [wlet
{ $examples { $examples
{ $example { $example
"USE: locals" "USE: locals"
":: quuxify | n seq |" ":: quuxify ( n seq -- newseq )"
" [wlet | add-n [| m | m n + ] |" " [wlet | add-n [| m | m n + ] |"
" seq [ add-n ] map ] ;" " seq [ add-n ] map ] ;"
"2 { 1 2 3 } quuxify ." "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." } ; { $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: :: 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." } { $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 } "." } ; { $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ;
HELP: MACRO:: HELP: MACRO::
{ $syntax "MACRO:: word | bindings... | body... ;" } { $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } ; { $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
{ POSTPONE: MACRO: POSTPONE: MACRO:: } related-words { POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
@ -72,7 +74,7 @@ ARTICLE: "locals-mutable" "Mutable locals"
$nl $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:" "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 { $code
":: counter | |" ":: counter ( -- )"
" [let | value! [ 0 ] |" " [let | value! [ 0 ] |"
" [ value 1+ dup value! ]" " [ value 1+ dup value! ]"
" [ value 1- dup value! ] ] ;" " [ value 1- dup value! ] ] ;"
@ -86,7 +88,7 @@ ARTICLE: "locals-limitations" "Limitations of locals"
$nl $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:" "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 { $code
":: bad-cond-usage | a |" ":: bad-cond-usage ( a -- ... )"
" { [ a 0 < ] [ ... ] }" " { [ a 0 < ] [ ... ] }"
" { [ a 0 > ] [ ... ] }" " { [ 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 USING: locals math sequences tools.test hashtables words kernel
namespaces arrays ; namespaces arrays strings prettyprint ;
IN: temporary IN: temporary
:: foo | a b | a a ; :: foo ( a b -- a a ) a a ;
[ 1 1 ] [ 1 2 foo ] unit-test [ 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 [ 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 [ -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 [ { 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 [ { 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 + ] ; [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
[ 7 ] [ 4 let-test ] unit-test [ 7 ] [ 4 let-test ] unit-test
:: let-test-2 | | :: let-test-2 ( a -- a )
[let | a [ ] | [let | b [ a ] | a ] ] ; a [let | a [ ] | [let | b [ a ] | a ] ] ;
[ 3 ] [ 3 let-test-2 ] unit-test [ 3 ] [ 3 let-test-2 ] unit-test
:: let-test-3 | | :: let-test-3 ( a -- a )
[let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ; a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
:: let-test-4 | | :: let-test-4 ( a -- b )
[let | a [ 1 ] b [ ] | a b 2array ] ; a [let | a [ 1 ] b [ ] | a b 2array ] ;
[ { 1 2 } ] [ 2 let-test-4 ] unit-test [ { 1 2 } ] [ 2 let-test-4 ] unit-test
:: let-test-5 | | :: let-test-5 ( a -- b )
[let | a [ ] b [ ] | a b 2array ] ; a [let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
:: let-test-6 | | :: let-test-6 ( a -- b )
[let | a [ ] b [ 1 ] | a b 2array ] ; a [let | a [ ] b [ 1 ] | a b 2array ] ;
[ { 2 1 } ] [ 2 let-test-6 ] unit-test [ { 2 1 } ] [ 2 let-test-6 ] unit-test
@ -57,26 +57,26 @@ IN: temporary
with-locals with-locals
] unit-test ] unit-test
:: wlet-test-2 | a b | :: wlet-test-2 ( a b -- seq )
[wlet | add-b [ b + ] | [wlet | add-b [ b + ] |
a [ add-b ] map ] ; a [ add-b ] map ] ;
[ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test [ { 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 ] ] [wlet | add-a [ a + ] | [ add-a ] ]
[let | a [ 3 ] | a swap call ] ; [let | a [ 3 ] | a swap call ] ;
[ 5 ] [ 2 wlet-test-3 ] unit-test [ 5 ] [ 2 wlet-test-3 ] unit-test
:: wlet-test-4 | a | :: wlet-test-4 ( a -- b )
[wlet | sub-a [| b | b a - ] | [wlet | sub-a [| b | b a - ] |
3 sub-a ] ; 3 sub-a ] ;
[ -7 ] [ 10 wlet-test-4 ] unit-test [ -7 ] [ 10 wlet-test-4 ] unit-test
:: write-test-1 | n! | :: write-test-1 ( n! -- q )
[| i | n i + dup n! ] ; [| i | n i + dup n! ] ;
0 write-test-1 "q" set 0 write-test-1 "q" set
@ -89,7 +89,7 @@ IN: temporary
[ 5 ] [ 2 "q" get call ] unit-test [ 5 ] [ 2 "q" get call ] unit-test
:: write-test-2 | | :: write-test-2 ( -- q )
[let | n! [ 0 ] | [let | n! [ 0 ] |
[| i | n i + dup n! ] ] ; [| i | n i + dup n! ] ] ;
@ -108,21 +108,55 @@ write-test-2 "q" set
20 10 [| a! | [| b! | a b ] ] with-locals call call 20 10 [| a! | [| b! | a b ] ] with-locals call call
] unit-test ] 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 [ ] [ 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 [ ] [ 5 write-test-4 drop ] unit-test
SYMBOL: a SYMBOL: a
:: use-test | a b c | :: use-test ( a b c -- a b c )
USE: kernel ; USE: kernel ;
[ t ] [ a symbol? ] unit-test [ 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 [ 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 inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private ; prettyprint.sections sequences.private effects generic
compiler.units ;
IN: locals IN: locals
! Inspired by ! Inspired by
@ -208,9 +209,6 @@ M: object local-rewrite* , ;
: push-locals ( assoc -- ) : push-locals ( assoc -- )
use get push ; use get push ;
: parse-locals ( -- words assoc )
"|" parse-tokens make-locals ;
: pop-locals ( assoc -- ) : pop-locals ( assoc -- )
use get delete ; use get delete ;
@ -218,7 +216,7 @@ M: object local-rewrite* , ;
over push-locals parse-until >quotation swap pop-locals ; over push-locals parse-until >quotation swap pop-locals ;
: parse-lambda ( -- lambda ) : parse-lambda ( -- lambda )
parse-locals \ ] (parse-lambda) <lambda> ; "|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
: (parse-bindings) ( -- ) : (parse-bindings) ( -- )
scan dup "|" = [ scan dup "|" = [
@ -246,11 +244,18 @@ M: wlet local-rewrite*
dup wlet-bindings values over wlet-vars rot wlet-body dup wlet-bindings values over wlet-vars rot wlet-body
<lambda> [ call ] curry compose local-rewrite* \ call , ; <lambda> [ call ] curry compose local-rewrite* \ call , ;
: (::) ( prop -- word quot n ) : parse-locals
>r CREATE dup reset-generic parse-effect
scan "|" assert= parse-locals \ ; (parse-lambda) <lambda> word [ over "declared-effect" set-word-prop ] when*
2dup r> set-word-prop effect-in make-locals ;
[ lambda-rewrite first ] keep lambda-vars length ;
: ((::)) ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
: (::) ( -- word quot )
CREATE dup reset-generic ((::)) ;
PRIVATE> PRIVATE>
@ -268,9 +273,22 @@ PRIVATE>
MACRO: with-locals ( form -- quot ) lambda-rewrite ; 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 <PRIVATE
@ -323,26 +341,42 @@ M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition M: lambda-word definition
"lambda" word-prop lambda-body ; "lambda" word-prop lambda-body ;
: lambda-word-synopsis ( word prop -- ) : lambda-word-synopsis ( word -- )
over definer. dup definer.
over seeing-word dup seeing-word
over pprint-word dup pprint-word
\ | pprint-word stack-effect. ;
word-prop lambda-vars pprint-vars
\ | pprint-word ;
M: lambda-word synopsis* M: lambda-word synopsis* lambda-word-synopsis ;
"lambda" lambda-word-synopsis ;
PREDICATE: macro lambda-macro PREDICATE: macro lambda-macro
"lambda-macro" word-prop >boolean ; "lambda" word-prop >boolean ;
M: lambda-macro definer drop \ MACRO:: \ ; ; M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition M: lambda-macro definition
"lambda-macro" word-prop lambda-body ; "lambda" word-prop lambda-body ;
M: lambda-macro synopsis* M: lambda-macro synopsis* lambda-word-synopsis ;
"lambda-macro" lambda-word-synopsis ;
PREDICATE: method-body lambda-method
"lambda" word-prop >boolean ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop lambda-body ;
: method-stack-effect
dup "lambda" word-prop lambda-vars
swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
<effect> ;
M: lambda-method synopsis*
dup definer.
dup "method" word-prop dup
method-specializer pprint*
method-generic pprint*
method-stack-effect effect>string comment. ;
PRIVATE> PRIVATE>

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

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

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

@ -3,7 +3,7 @@
USING: namespaces kernel io calendar sequences io.files USING: namespaces kernel io calendar sequences io.files
io.sockets continuations prettyprint assocs math.parser io.sockets continuations prettyprint assocs math.parser
words debugger math combinators concurrency.messaging words debugger math combinators concurrency.messaging
threads arrays init math.ranges strings ; threads arrays init math.ranges strings calendar.format ;
IN: logging.server IN: logging.server
: log-root ( -- string ) : 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. ! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects
USING: parser kernel sequences words effects inference.transforms inference.transforms combinators assocs definitions quotations
combinators assocs definitions quotations namespaces memoize ; namespaces memoize ;
IN: macros 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' ) : real-macro-effect ( word -- effect' )
"declared-effect" word-prop effect-in 1 <effect> ; "declared-effect" word-prop effect-in 1 <effect> ;
: (MACRO:) ( word definition effect-in -- ) : define-macro ( word definition -- )
>r 2dup "macro" set-word-prop over "declared-effect" word-prop effect-in length >r
2dup over real-macro-effect memoize-quot 2dup "macro" set-word-prop
[ call ] append define 2dup over real-macro-effect memoize-quot [ call ] append define
r> define-transform ; r> define-transform ;
: MACRO: : MACRO:
(:) (MACRO:) ; parsing (:) define-macro ; parsing
PREDICATE: word macro "macro" word-prop >boolean ; 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 #! factor an integer into s * 2^r
0 swap (factor-2s) ; 0 swap (factor-2s) ;
:: (miller-rabin) | n prime?! | :: (miller-rabin) ( n prime?! -- ? )
n 1- factor-2s s set r set n 1- factor-2s s set r set
trials get [ trials get [
n 1- [1,b] random a set 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 <PRIVATE
: start-date ( -- timestamp ) : start-date ( -- timestamp )
1901 1 1 0 0 0 0 make-timestamp ; 1901 1 1 <date> ;
: end-date ( -- timestamp ) : end-date ( -- timestamp )
2000 12 31 0 0 0 0 make-timestamp ; 2000 12 31 <date> ;
: (first-days) ( end-date start-date -- ) : first-days ( end-date start-date -- days )
2dup timestamp- 0 >= [ [ 2dup after=? ]
dup day-of-week , 1 +month (first-days) [ dup 1 months time+ swap day-of-week ]
] [ [ ] unfold 2nip ;
2drop
] if ;
: first-days ( start-date end-date -- seq )
[ swap (first-days) ] { } make ;
PRIVATE> PRIVATE>
: euler019a ( -- answer ) : euler019a ( -- answer )
start-date end-date first-days [ zero? ] count ; end-date start-date first-days [ zero? ] count ;
! [ euler019a ] 100 ave-time ! [ euler019a ] 100 ave-time
! 131 ms run / 3 ms GC ave time - 100 trials ! 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. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces io io.timeouts kernel logging io.sockets USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings sequences combinators sequences.lib splitting assocs strings
math.parser random system calendar ; math.parser random system calendar calendar.format ;
IN: smtp IN: smtp

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

@ -5,7 +5,7 @@ sequences concurrency.messaging locals continuations
threads namespaces namespaces.private ; threads namespaces namespaces.private ;
IN: tools.walker.debug IN: tools.walker.debug
:: test-walker | quot | :: test-walker ( quot -- data )
[let | p [ <promise> ] [let | p [ <promise> ]
s [ f <model> ] s [ f <model> ]
c [ 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 ; math namespaces system combinators vocabs.loader ;
! ! ! Unix types ! ! ! 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: long ssize_t
TYPEDEF: longlong blkcnt_t TYPEDEF: longword blksize_t
TYPEDEF: longword blkcnt_t
TYPEDEF: longlong quad_t TYPEDEF: longlong quad_t
TYPEDEF: ulonglong dev_t
TYPEDEF: uint gid_t TYPEDEF: uint gid_t
TYPEDEF: uint in_addr_t TYPEDEF: uint in_addr_t
TYPEDEF: uint ino_t TYPEDEF: ulong ino_t
TYPEDEF: int pid_t TYPEDEF: int pid_t
TYPEDEF: uint socklen_t TYPEDEF: uint socklen_t
TYPEDEF: uint time_t TYPEDEF: uint time_t
TYPEDEF: uint uid_t TYPEDEF: uint uid_t
TYPEDEF: ulong size_t TYPEDEF: ulong size_t
TYPEDEF: ulong u_long TYPEDEF: ulong u_long
TYPEDEF: ushort mode_t TYPEDEF: uint mode_t
TYPEDEF: ushort nlink_t TYPEDEF: uword nlink_t
TYPEDEF: void* caddr_t TYPEDEF: void* caddr_t
TYPEDEF: ulong off_t TYPEDEF: ulong off_t
@ -226,3 +233,4 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{ [ solaris? ] [ "unix.solaris" require ] } { [ solaris? ] [ "unix.solaris" require ] }
{ [ t ] [ ] } { [ t ] [ ] }
} cond } cond

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

@ -14,7 +14,7 @@ SYMBOL: cgi-root
[ [
"CGI/1.0" "GATEWAY_INTERFACE" set "CGI/1.0" "GATEWAY_INTERFACE" set
"HTTP/1.0" "SERVER_PROTOCOL" set "HTTP/1.0" "SERVER_PROTOCOL" set
"Factor " version append "SERVER_SOFTWARE" set "Factor" "SERVER_SOFTWARE" set
dup "PATH_TRANSLATED" set dup "PATH_TRANSLATED" set
"SCRIPT_FILENAME" 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 USING: calendar html io io.files kernel math math.parser
http.server.responders http.server.templating namespaces parser http.server.responders http.server.templating namespaces parser
sequences strings assocs hashtables debugger http.mime sorting sequences strings assocs hashtables debugger http.mime sorting
html.elements logging ; html.elements logging calendar.format ;
IN: webapps.file IN: webapps.file
SYMBOL: doc-root SYMBOL: doc-root

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

@ -1,6 +1,6 @@
USING: calendar furnace furnace.validator io.files kernel USING: calendar furnace furnace.validator io.files kernel
namespaces sequences http.server.responders html math.parser rss namespaces sequences http.server.responders html math.parser rss
xml.writer xmode.code2html math ; xml.writer xmode.code2html math calendar.format ;
IN: webapps.pastebin IN: webapps.pastebin
TUPLE: pastebin pastes ; 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 sorting html.elements io assocs namespaces math threads vocabs
html furnace http.server.templating calendar math.parser html furnace http.server.templating calendar math.parser
splitting continuations debugger system http.server.responders splitting continuations debugger system http.server.responders
xml.writer prettyprint logging ; xml.writer prettyprint logging calendar.format ;
IN: webapps.planet IN: webapps.planet
: print-posting-summary ( posting -- ) : print-posting-summary ( posting -- )

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

@ -23,7 +23,7 @@ IN: windows.time
: timestamp>windows-time ( timestamp -- n ) : timestamp>windows-time ( timestamp -- n )
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) #! 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 ) : windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object> "FILETIME" <c-object>

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

@ -3,7 +3,8 @@
IN: xml-rpc IN: xml-rpc
USING: kernel xml arrays math generic http.client combinators USING: kernel xml arrays math generic http.client combinators
hashtables namespaces io base64 sequences strings calendar 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 ! * Sending RPC requests
! TODO: time ! TODO: time