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

Merge branch 'master' into new_gc

db4
Slava Pestov 2009-10-23 03:56:46 -05:00
parent 810e309e0c 57d9968006
commit 64ff812611
55 changed files with 515 additions and 360 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/cocoa/messages/messages-docs.factor
View File

@ -2,13 +2,13 @@ USING: help.markup help.syntax strings alien ;
IN: cocoa.messages
HELP: send
{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." }
{ $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." }
{ $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ;
HELP: super-send
{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ;
HELP: objc-class

2
basis/cocoa/subclassing/subclassing-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax strings alien hashtables ;
IN: cocoa.subclassing
HELP: define-objc-class
{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } }
{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
{ $list
{ { $link +name+ } " - a string naming the new class. Required." }

24
basis/compiler/compiler.factor
View File

@ -55,28 +55,22 @@ SYMBOL: compiled
GENERIC: no-compile? ( word -- ? )
M: word no-compile? "no-compile" word-prop ;
M: method-body no-compile? "method-generic" word-prop no-compile? ;
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
M: word no-compile?
{
[ macro? ]
[ inline? ]
[ "special" word-prop ]
[ "no-compile" word-prop ]
} 1|| ;
: ignore-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
[
{
[ macro? ]
[ inline? ]
[ no-compile? ]
[ "special" word-prop ]
} 1||
] [
{
[ do-not-compile? ]
[ literal-expected? ]
} 1||
] bi* and ;
[ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ;
: finish ( word -- )
#! Recompile callers if the word's stack effect changed, then

13
basis/compiler/tests/simple.factor
View File

@ -1,6 +1,7 @@
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
arrays memory vocabs parser eval quotations compiler.errors
definitions ;
IN: compiler.tests.simple
! Test empty word
@ -238,3 +239,13 @@ M: f single-combination-test-2 single-combination-test-4 ;
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
] unit-test
] times
! This should not compile
GENERIC: bad-effect-test ( a -- )
M: quotation bad-effect-test call ; inline
: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ;
[ bad-effect-test* ] [ not-compiled? ] must-fail-with
! Don't want compiler error to stick around
[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] unit-test

3
basis/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -18,9 +18,10 @@ HELP: mailbox-put
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
HELP: block-unless-pred
{ $values { "pred" { $quotation "( obj -- ? )" } }
{ $values
{ "mailbox" mailbox }
{ "timeout" "a " { $link duration } " or " { $link f } }
{ "pred" { $quotation "( obj -- ? )" } }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;

2
basis/delegate/delegate-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.syntax help.markup delegate.private ;
IN: delegate
HELP: define-protocol
{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } }
{ $values { "protocol" "a word for the new protocol" } { "wordlist" "a sequence of words" } }
{ $description "Defines a symbol as a protocol." }
{ $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ;

4
basis/documents/documents-docs.factor
View File

@ -12,11 +12,11 @@ HELP: +line
{ $description "Adds an integer to the line number of a line/column pair." } ;
HELP: =col
{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } }
{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } }
{ $description "Sets the column number of a line/column pair." } ;
HELP: =line
{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } }
{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } }
{ $description "Sets the line number of a line/column pair." } ;
HELP: lines-equal?

2
basis/furnace/auth/auth-docs.factor
View File

@ -63,7 +63,7 @@ HELP: realm
{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ;
HELP: uchange
{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
{ $values { "quot" { $quotation "( old -- new )" } } { "key" symbol } }
{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ;
HELP: uget

28
basis/generalizations/generalizations-docs.factor
View File

@ -266,26 +266,6 @@ HELP: spread-curry
{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;
HELP: neach
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
HELP: nmap
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
HELP: nmap-as
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
HELP: mnmap
{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;
HELP: mnmap-as
{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the " { $snippet "exemplar" } "s" } }
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;
HELP: mnswap
{ $values { "m" integer } { "n" integer } }
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
@ -401,11 +381,6 @@ ARTICLE: "combinator-generalizations" "Generalized combinators"
apply-curry
cleave-curry
spread-curry
neach
nmap
nmap-as
mnmap
mnmap-as
} ;
ARTICLE: "other-generalizations" "Additional generalizations"
@ -424,6 +399,7 @@ ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"shuffle-generalizations"
"combinator-generalizations"
"other-generalizations"
} ;
}
"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence iteration combinators." ;
ABOUT: "generalizations"

102
basis/generalizations/generalizations-tests.factor
View File

@ -82,108 +82,6 @@ IN: generalizations.tests
[ '[ number>string _ append ] 4 napply ] must-infer
: neach-test ( a b c d -- )
[ 4 nappend print ] 4 neach ;
: nmap-test ( a b c d -- e )
[ 4 nappend ] 4 nmap ;
: nmap-as-test ( a b c d -- e )
[ 4 nappend ] [ ] 4 nmap-as ;
: mnmap-3-test ( a b c d -- e f g )
[ append ] 4 3 mnmap ;
: mnmap-2-test ( a b c d -- e f )
[ [ append ] 2bi@ ] 4 2 mnmap ;
: mnmap-as-test ( a b c d -- e f )
[ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
: mnmap-1-test ( a b c d -- e )
[ 4 nappend ] 4 1 mnmap ;
: mnmap-0-test ( a b c d -- )
[ 4 nappend print ] 4 0 mnmap ;
[ """A1a!
B2b@
C3c#
D4d$
""" ] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
[ neach-test ] with-string-writer
] unit-test
[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
[
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
nmap-test
] unit-test
[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ]
[
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
nmap-as-test
] unit-test
[
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a!" "b@" "c#" "d$" }
] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
mnmap-3-test
] unit-test
[
{ "A1" "B2" "C3" "D4" }
{ "a!" "b@" "c#" "d$" }
] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
mnmap-2-test
] unit-test
[
{ "A1" "B2" "C3" "D4" }
[ "a!" "b@" "c#" "d$" ]
] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
mnmap-as-test
] unit-test
[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
[
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
mnmap-1-test
] unit-test
[ """A1a!
B2b@
C3c#
D4d$
""" ] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
[ mnmap-0-test ] with-string-writer
] unit-test
[ 6 8 10 12 ] [
1 2 3 4
5 6 7 8 [ + ] 4 apply-curry 4 spread*

54
basis/generalizations/generalizations.factor
View File

@ -142,57 +142,3 @@ MACRO: nbi-curry ( n -- )
MACRO: nspin ( n -- )
[ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;
MACRO: nmin-length ( n -- )
dup 1 - [ min ] n*quot
'[ [ length ] _ napply @ ] ;
: nnth-unsafe ( n ...seq n -- )
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
MACRO: nset-nth-unsafe ( n -- )
[ [ drop ] ]
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
if-zero ;
: (neach) ( ...seq quot n -- len quot' )
dup dup dup
'[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
: neach ( ...seq quot n -- )
(neach) each-integer ; inline
: nmap-as ( ...seq quot exemplar n -- result )
'[ _ (neach) ] dip map-integers ; inline
: nmap ( ...seq quot n -- result )
dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
MACRO: nnew-sequence ( n -- )
[ [ drop ] ]
[ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
: nnew-like ( len ...exemplar quot n -- result... )
dup dup dup dup '[
_ nover
[ [ _ nnew-sequence ] dip call ]
_ ndip [ like ]
_ apply-curry
_ spread*
] call ; inline
MACRO: (ncollect) ( n -- )
dup dup 1 +
'[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
: ncollect ( len quot ...into n -- )
(ncollect) each-integer ; inline
: nmap-integers ( len quot ...exemplar n -- result... )
dup dup dup
'[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
: mnmap ( m*seq quot m n -- result*n )
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline

11
basis/grouping/grouping-tests.factor
View File

@ -1,5 +1,5 @@
USING: grouping tools.test kernel sequences arrays
math ;
math accessors ;
IN: grouping.tests
[ { 1 2 3 } 0 group ] must-fail
@ -12,6 +12,15 @@ IN: grouping.tests
>array
] unit-test
[ 0 ] [ { } 2 <clumps> length ] unit-test
[ 0 ] [ { 1 } 2 <clumps> length ] unit-test
[ 1 ] [ { 1 2 } 2 <clumps> length ] unit-test
[ 2 ] [ { 1 2 3 } 2 <clumps> length ] unit-test
[ 1 ] [ V{ } 2 <clumps> 0 over set-length seq>> length ] unit-test
[ 2 ] [ V{ } 2 <clumps> 1 over set-length seq>> length ] unit-test
[ 3 ] [ V{ } 2 <clumps> 2 over set-length seq>> length ] unit-test
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test

2
basis/grouping/grouping.factor
View File

@ -46,7 +46,7 @@ M: abstract-groups group@
TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length
[ seq>> length ] [ n>> ] bi - 1 + ; inline
[ seq>> length 1 + ] [ n>> ] bi [-] ; inline
M: abstract-clumps set-length
[ n>> + 1 - ] [ seq>> ] bi set-length ; inline

8
basis/heaps/heaps-docs.factor
View File

@ -53,12 +53,12 @@ HELP: <max-heap>
{ $description "Create a new " { $link max-heap } "." } ;
HELP: heap-push
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } }
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" } ;
HELP: heap-push*
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } { "entry" entry } }
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
{ $side-effects "heap" } ;
@ -68,7 +68,7 @@ HELP: heap-push-all
{ $side-effects "heap" } ;
HELP: heap-peek
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $values { "heap" "a heap" } { "value" object } { "key" object } }
{ $description "Output the first element in the heap, leaving it in the heap." } ;
HELP: heap-pop*
@ -77,7 +77,7 @@ HELP: heap-pop*
{ $side-effects "heap" } ;
HELP: heap-pop
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
{ $values { "heap" "a heap" } { "value" object } { "key" object } }
{ $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } ;

11
basis/help/crossref/crossref-tests.factor
View File

@ -1,6 +1,7 @@
USING: help.crossref help.topics help.markup tools.test words
definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units eval ;
io.streams.string continuations debugger compiler.units eval
help.syntax ;
IN: help.crossref.tests
[ ] [
@ -54,3 +55,11 @@ IN: help.crossref.tests
] unit-test
[ "xxx" ] [ "yyy" article-parent ] unit-test
ARTICLE: "crossref-test-1" "Crossref test 1"
"Hello world" ;
ARTICLE: "crossref-test-2" "Crossref test 2"
{ $markup-example { $subsection "crossref-test-1" } } ;
[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test

5
basis/help/lint/checks/checks.factor
View File

@ -33,14 +33,13 @@ SYMBOL: vocab-articles
: extract-values ( element -- seq )
\ $values swap elements dup empty? [
first rest [ first ] map prune natural-sort
first rest [ first ] map prune
] unless ;
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
[ dup pair? [ first ] when effect>string ] map
prune natural-sort ;
[ dup pair? [ first ] when effect>string ] map prune ;
: contains-funky-elements? ( element -- ? )
{

4
basis/help/markup/markup.factor
View File

@ -430,8 +430,8 @@ M: simple-element elements*
M: object elements* 2drop ;
M: array elements*
[ [ elements* ] with each ] 2keep
[ first eq? ] keep swap [ , ] [ drop ] if ;
[ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
[ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
: elements ( elt-type element -- seq ) [ elements* ] { } make ;

3
basis/help/vocabs/vocabs-tests.factor
View File

@ -1,5 +1,6 @@
USING: help.vocabs tools.test help.markup help vocabs ;
USING: help.vocabs tools.test help.markup help vocabs io ;
IN: help.vocabs.tests
[ ] [ { $vocab "scratchpad" } print-content ] unit-test
[ ] [ "classes" vocab print-topic ] unit-test
[ ] [ nl ] unit-test

14
basis/io/sockets/sockets.factor
View File

@ -173,6 +173,8 @@ GENERIC: (get-remote-address) ( handle remote -- sockaddr )
[ <input-port> |dispose ] [ <output-port> |dispose ] bi
] with-destructors ;
SYMBOL: bind-local-address
GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle )
@ -321,6 +323,18 @@ M: invalid-inet-server summary
M: inet (server)
invalid-inet-server ;
ERROR: invalid-local-address addrspec ;
M: invalid-local-address summary
drop "Cannot use with-local-address with <inet>; use <inet4> or <inet6> instead" ;
: with-local-address ( addr quot -- )
[
[ ] [ inet4? ] [ inet6? ] tri or
[ bind-local-address ]
[ invalid-local-address ] if
] dip with-variable ; inline
{
{ [ os unix? ] [ "io.sockets.unix" require ] }
{ [ os winnt? ] [ "io.sockets.windows.nt" require ] }

6
basis/io/sockets/unix/unix.factor
View File

@ -69,8 +69,12 @@ M: object establish-connection ( client-out remote -- )
[ (io-error) ]
} cond ;
: ?bind-client ( socket -- )
bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline
M: object ((client)) ( addrspec -- fd )
protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
protocol-family SOCK_STREAM socket-fd
[ init-client-socket ] [ ?bind-client ] [ ] tri ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )

6
basis/io/sockets/windows/windows.factor
View File

@ -55,7 +55,11 @@ M: object (get-remote-address) ( socket addrspec -- sockaddr )
M: object ((client)) ( addrspec -- handle )
[ SOCK_STREAM open-socket ] keep
[ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;
[
bind-local-address get
[ nip make-sockaddr/size ]
[ unspecific-sockaddr/size ] if* bind-socket
] [ drop ] 2bi ;
: server-socket ( addrspec type -- fd )
[ open-socket ] [ drop ] 2bi

2
basis/lists/lists-docs.factor
View File

@ -122,7 +122,7 @@ HELP: uncons
{ $description "Put the head and tail of the list on the stack." } ;
HELP: unswons
{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
{ $values { "cons" list } { "cdr" "the tail of the list" } { "car" "the head of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
{ leach foldl lmap>array } related-words

8
basis/logging/logging-docs.factor
View File

@ -47,19 +47,19 @@ HELP: log-message
{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
HELP: add-logging
{ $values { "level" "a log level" } { "word" word } }
{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log a message every time it is called." } ;
HELP: add-input-logging
{ $values { "level" "a log level" } { "word" word } }
{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-output-logging
{ $values { "level" "a log level" } { "word" word } }
{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-error-logging
{ $values { "level" "a log level" } { "word" word } }
{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its input values and any errors it throws."
$nl
"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller."

2
basis/math/functions/functions-docs.factor
View File

@ -239,7 +239,7 @@ HELP: cis
{ cis exp } related-words
HELP: polar>
{ $values { "z" number } { "abs" "a non-negative real number" } { "arg" real } }
{ $values { "abs" "a non-negative real number" } { "arg" real } { "z" number } }
{ $description "Converts an absolute value and argument (polar form) to a complex number." } ;
HELP: [-1,1]?

4
basis/math/matrices/matrices.factor
View File

@ -122,7 +122,9 @@ IN: math.matrices
PRIVATE>
: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
: cross ( vec1 vec2 -- vec3 )
[ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ]
[ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline
: proj ( v u -- w )
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;

3
basis/math/primes/primes-docs.factor
View File

@ -44,7 +44,8 @@ HELP: random-prime
HELP: unique-primes
{ $values
{ "numbits" integer } { "n" integer }
{ "n" integer }
{ "numbits" integer }
{ "seq" sequence }
}
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;

1
basis/math/vectors/vectors.factor
View File

@ -96,6 +96,7 @@ PRIVATE>
:: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
: vshuffle-elements ( u perm -- v )
over length 0 pad-tail
swap [ '[ _ nth ] ] keep map-as ;
: vshuffle-bytes ( u perm -- v )

2
basis/persistent/heaps/heaps-docs.factor
View File

@ -18,7 +18,7 @@ HELP: pheap-peek
{ $description "Gets the object in the heap with minumum priority." } ;
HELP: pheap-push
{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } }
{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } }
{ $description "Creates a new persistent heap also containing the given object of the given priority." } ;
HELP: pheap-pop*

46
basis/sequences/generalizations/generalizations-docs.factor Normal file
View File

@ -0,0 +1,46 @@
! (c)2009 Joe Groff bsd license
USING: help.syntax help.markup kernel sequences quotations
math arrays combinators ;
IN: sequences.generalizations
HELP: neach
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
HELP: nmap
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
HELP: nmap-as
{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
HELP: mnmap
{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;
HELP: mnmap-as
{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;
HELP: nproduce
{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } }
{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
HELP: nproduce-as
{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of the iteration " { $link "sequences-combinators" } "."
{ $subsections
neach
nmap
nmap-as
mnmap
mnmap-as
nproduce
nproduce-as
} ;
ABOUT: "sequences.generalizations"

120
basis/sequences/generalizations/generalizations-tests.factor Normal file
View File

@ -0,0 +1,120 @@
! (c)2009 Joe Groff bsd license
USING: tools.test generalizations kernel math arrays sequences
sequences.generalizations ascii fry math.parser io io.streams.string ;
IN: sequences.generalizations.tests
: neach-test ( a b c d -- )
[ 4 nappend print ] 4 neach ;
: nmap-test ( a b c d -- e )
[ 4 nappend ] 4 nmap ;
: nmap-as-test ( a b c d -- e )
[ 4 nappend ] [ ] 4 nmap-as ;
: mnmap-3-test ( a b c d -- e f g )
[ append ] 4 3 mnmap ;
: mnmap-2-test ( a b c d -- e f )
[ [ append ] 2bi@ ] 4 2 mnmap ;
: mnmap-as-test ( a b c d -- e f )
[ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
: mnmap-1-test ( a b c d -- e )
[ 4 nappend ] 4 1 mnmap ;
: mnmap-0-test ( a b c d -- )
[ 4 nappend print ] 4 0 mnmap ;
: nproduce-as-test ( n -- a b )
[ dup zero? not ]
[ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as
[ drop ] 2dip ;
: nproduce-test ( n -- a b )
[ dup zero? not ]
[ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce
[ drop ] 2dip ;
[ """A1a!
B2b@
C3c#
D4d$
""" ] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
[ neach-test ] with-string-writer
] unit-test
[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
[
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
nmap-test
] unit-test
[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ]
[
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
nmap-as-test
] unit-test
[
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a!" "b@" "c#" "d$" }
] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
mnmap-3-test
] unit-test
[
{ "A1" "B2" "C3" "D4" }
{ "a!" "b@" "c#" "d$" }
] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
mnmap-2-test
] unit-test
[
{ "A1" "B2" "C3" "D4" }
[ "a!" "b@" "c#" "d$" ]
] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
mnmap-as-test
] unit-test
[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
[
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
mnmap-1-test
] unit-test
[ """A1a!
B2b@
C3c#
D4d$
""" ] [
{ "A" "B" "C" "D" }
{ "1" "2" "3" "4" }
{ "a" "b" "c" "d" }
{ "!" "@" "#" "$" }
[ mnmap-0-test ] with-string-writer
] unit-test
[ { 10 8 6 4 2 } B{ 9 7 5 3 1 } ]
[ 10 nproduce-as-test ] unit-test
[ { 10 8 6 4 2 } { 9 7 5 3 1 } ]
[ 10 nproduce-test ] unit-test

79
basis/sequences/generalizations/generalizations.factor Normal file
View File

@ -0,0 +1,79 @@
! (c)2009 Joe Groff bsd license
USING: kernel sequences sequences.private math
combinators macros math.order math.ranges quotations fry effects
memoize.private generalizations ;
IN: sequences.generalizations
MACRO: nmin-length ( n -- )
dup 1 - [ min ] n*quot
'[ [ length ] _ napply @ ] ;
: nnth-unsafe ( n ...seq n -- )
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
MACRO: nset-nth-unsafe ( n -- )
[ [ drop ] ]
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
if-zero ;
: (neach) ( ...seq quot n -- len quot' )
dup dup dup
'[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
: neach ( ...seq quot n -- )
(neach) each-integer ; inline
: nmap-as ( ...seq quot exemplar n -- result )
'[ _ (neach) ] dip map-integers ; inline
: nmap ( ...seq quot n -- result )
dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
MACRO: nnew-sequence ( n -- )
[ [ drop ] ]
[ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
: nnew-like ( len ...exemplar quot n -- result... )
5 dupn '[
_ nover
[ [ _ nnew-sequence ] dip call ]
_ ndip [ like ]
_ apply-curry
_ spread*
] call ; inline
MACRO: (ncollect) ( n -- )
3 dupn 1 +
'[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
: ncollect ( len quot ...into n -- )
(ncollect) each-integer ; inline
: nmap-integers ( len quot ...exemplar n -- result... )
4 dupn
'[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
: mnmap ( m*seq quot m n -- result*n )
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
: naccumulator-for ( quot ...exemplar n -- quot' vec... )
5 dupn '[
[ [ length ] keep new-resizable ] _ napply
[ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
] call ; inline
: naccumulator ( quot n -- quot' vec... )
[ V{ } swap dupn ] keep naccumulator-for ; inline
: nproduce-as ( pred quot ...exemplar n -- seq... )
7 dupn '[
_ ndup
[ _ naccumulator-for [ while ] _ ndip ]
_ ncurry _ ndip
[ like ] _ apply-curry _ spread*
] call ; inline
: nproduce ( pred quot n -- seq... )
[ { } swap dupn ] keep nproduce-as ; inline

2
basis/tools/walker/walker-docs.factor
View File

@ -6,7 +6,7 @@ HELP: breakpoint
{ $description "Annotates a word definition to enter the single stepper when executed." } ;
HELP: breakpoint-if
{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
{ $values { "word" word } { "quot" { $quotation "( -- ? )" } } }
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
HELP: B

2
basis/ui/gadgets/menus/menus-docs.factor
View File

@ -3,7 +3,7 @@ kernel ;
IN: ui.gadgets.menus
HELP: <commands-menu>
{ $values { "target" object } { "commands" "a sequence of commands" } { "hook" { $quotation "( button -- )" } } { "menu" "a new " { $link gadget } } }
{ $values { "target" object } { "hook" { $quotation "( button -- )" } } { "commands" "a sequence of commands" } { "menu" "a new " { $link gadget } } }
{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
HELP: show-menu

2
basis/ui/gadgets/scrollers/scrollers-docs.factor
View File

@ -24,7 +24,7 @@ HELP: <scroller>
{ <viewport> <scroller> } related-words
HELP: set-scroll-position
{ $values { "scroller" scroller } { "value" "a pair of integers" } }
{ $values { "value" "a pair of integers" } { "scroller" scroller } }
{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
HELP: relative-scroll-rect

2
basis/ui/gadgets/tracks/tracks-docs.factor
View File

@ -18,7 +18,7 @@ HELP: <track>
{ $description "Creates a new track which lays out children along the given orientation, either " { $link horizontal } " or " { $link vertical } "." } ;
HELP: track-add
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $values { "track" track } { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
ABOUT: "ui-track-layout"

6
basis/ui/pens/pens-docs.factor
View File

@ -2,11 +2,11 @@ IN: ui.pens
USING: help.markup help.syntax kernel ui.gadgets ;
HELP: draw-interior
{ $values { "pen" object } { "gadget" gadget } }
{ $values { "gadget" gadget } { "pen" object } }
{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ;
HELP: draw-boundary
{ $values { "pen" object } { "gadget" gadget } }
{ $values { "gadget" gadget } { "pen" object } }
{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
ARTICLE: "ui-pen-protocol" "UI pen protocol"
@ -23,4 +23,4 @@ $nl
{ $vocab-subsection "Polygon pens" "ui.pens.polygon" }
{ $vocab-subsection "Solid pens" "ui.pens.solid" }
{ $vocab-subsection "Tile pens" "ui.pens.tile" }
"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;

2
basis/vectors/functor/functor.factor
View File

@ -24,6 +24,8 @@ M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ; inline
M: A new-resizable drop <V> ; inline
M: V new-resizable drop <V> ; inline
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
: >V ( seq -- vector ) V new clone-like ; inline

2
core/byte-vectors/byte-vectors.factor
View File

@ -43,4 +43,6 @@ M: byte-array like
M: byte-array new-resizable drop <byte-vector> ; inline
M: byte-vector new-resizable drop <byte-vector> ; inline
INSTANCE: byte-vector growable

2
core/combinators/combinators-docs.factor
View File

@ -438,7 +438,7 @@ $nl
{ $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
HELP: case>quot
{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
{ $values { "default" quotation } { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl
"This word uses three strategies:"

4
core/continuations/continuations-docs.factor
View File

@ -122,7 +122,7 @@ HELP: continuation
{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
HELP: >continuation<
{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } }
{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }
{ $description "Takes a continuation apart into its constituents." } ;
HELP: ifcc
@ -271,4 +271,4 @@ HELP: with-return
HELP: restart
{ $values { "restart" restart } }
{ $description "Invokes a restart." }
{ $class-description "The class of restarts." } ;
{ $class-description "The class of restarts." } ;

2
core/generic/generic-docs.factor
View File

@ -124,7 +124,7 @@ HELP: make-generic
$low-level-note ;
HELP: define-generic
{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } }
{ $values { "word" word } { "combination" "a method combination" } { "effect" effect } }
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;

2
core/growable/growable.factor
View File

@ -66,4 +66,6 @@ M: growable shorten ( n seq -- )
2dup (>>length)
] when 2drop ; inline
M: growable new-resizable new-sequence 0 over set-length ; inline
INSTANCE: growable sequence

43
core/io/io.factor
View File

@ -87,42 +87,51 @@ SYMBOL: error-stream
: bl ( -- ) " " write ;
<PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
[ dup ] compose swap while drop ; inline
: stream-element-exemplar ( type -- exemplar )
<PRIVATE
: (stream-element-exemplar) ( type -- exemplar )
{
{ +byte+ [ B{ } ] }
{ +character+ [ "" ] }
} case ;
} case ; inline
: stream-element-exemplar ( stream -- exemplar )
stream-element-type (stream-element-exemplar) ;
: element-exemplar ( -- exemplar )
input-stream get
stream-element-type
stream-element-exemplar ;
input-stream get stream-element-exemplar ; inline
PRIVATE>
: each-line ( quot -- )
[ readln ] each-morsel ; inline
: each-stream-line ( stream quot -- )
swap [ stream-readln ] curry each-morsel ; inline
: lines ( -- seq )
[ ] accumulator [ each-line ] dip { } like ;
: each-line ( quot -- )
input-stream get swap each-stream-line ; inline
: stream-lines ( stream -- seq )
[ lines ] with-input-stream ;
[ [ ] accumulator [ each-stream-line ] dip { } like ] with-disposal ;
: contents ( -- seq )
[ 65536 read-partial dup ] [ ] produce nip
element-exemplar concat-as ;
: lines ( -- seq )
input-stream get stream-lines ; inline
: stream-contents ( stream -- seq )
[ contents ] with-input-stream ;
[
[ [ 65536 swap stream-read-partial dup ] curry [ ] produce nip ]
[ stream-element-exemplar concat-as ] bi
] with-disposal ;
: contents ( -- seq )
input-stream get stream-contents ; inline
: each-stream-block ( stream quot: ( block -- ) -- )
swap [ 8192 swap stream-read-partial ] curry each-morsel ; inline
: each-block ( quot: ( block -- ) -- )
[ 8192 read-partial ] each-morsel ; inline
input-stream get swap each-stream-block ; inline
: stream-copy ( in out -- )
[ [ [ write ] each-block ] with-output-stream ]

5
core/io/streams/byte-array/byte-array-docs.factor
View File

@ -27,8 +27,9 @@ HELP: <byte-writer>
{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
HELP: with-byte-reader
{ $values { "encoding" "an encoding descriptor" }
{ "quot" quotation } { "byte-array" byte-array } }
{ $values { "byte-array" byte-array }
{ "encoding" "an encoding descriptor" }
{ "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
HELP: with-byte-writer

12
core/kernel/kernel-docs.factor
View File

@ -168,7 +168,7 @@ HELP: xor
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?
{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" }
@ -176,7 +176,7 @@ HELP: both?
} ;
HELP: either?
{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" }
@ -213,18 +213,18 @@ HELP: call-clear ( quot -- )
{ $notes "Used to implement " { $link "threads" } "." } ;
HELP: keep
{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
{ $values { "x" object } { "quot" { $quotation "( x -- ... )" } } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
{ $examples
{ $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ <array> ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" }
} ;
HELP: 2keep
{ $values { "quot" { $quotation "( x y -- ... )" } } { "x" object } { "y" object } }
{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ... )" } } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
{ $values { "quot" { $quotation "( x y z -- ... )" } } { "x" object } { "y" object } { "z" object } }
{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( x y z -- ... )" } } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
@ -664,7 +664,7 @@ HELP: getenv ( n -- obj )
{ $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ;
HELP: setenv ( obj n -- )
{ $values { "n" "a non-negative integer" } { "obj" object } }
{ $values { "obj" object } { "n" "a non-negative integer" } }
{ $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ;
HELP: object

2
core/kernel/kernel.factor
View File

@ -122,7 +122,7 @@ DEFER: if
: 2bi@ ( w x y z quot -- )
dup 2bi* ; inline
: 2tri@ ( u v w y x z quot -- )
: 2tri@ ( u v w x y z quot -- )
dup dup 2tri* ; inline
! Quotation building

93
core/math/parser/parser.factor
View File

@ -5,39 +5,18 @@ strings arrays combinators splitting math assocs byte-arrays make ;
IN: math.parser
: digit> ( ch -- n )
H{
{ CHAR: 0 0 }
{ CHAR: 1 1 }
{ CHAR: 2 2 }
{ CHAR: 3 3 }
{ CHAR: 4 4 }
{ CHAR: 5 5 }
{ CHAR: 6 6 }
{ CHAR: 7 7 }
{ CHAR: 8 8 }
{ CHAR: 9 9 }
{ CHAR: A 10 }
{ CHAR: B 11 }
{ CHAR: C 12 }
{ CHAR: D 13 }
{ CHAR: E 14 }
{ CHAR: F 15 }
{ CHAR: a 10 }
{ CHAR: b 11 }
{ CHAR: c 12 }
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
{ CHAR: , f }
} at* [ drop 255 ] unless ; inline
127 bitand {
{ [ dup CHAR: 9 <= ] [ CHAR: 0 - ] }
{ [ dup CHAR: a < ] [ CHAR: A 10 - - ] }
[ CHAR: a 10 - - ]
} cond
dup 0 < [ drop 255 ] [ dup 16 >= [ drop 255 ] when ] if ; inline
: string>digits ( str -- digits )
[ digit> ] B{ } map-as ; inline
: (digits>integer) ( valid? accum digit radix -- valid? accum )
over [
2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if
] [ 2drop ] if ; inline
2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
: each-digit ( seq radix quot -- n/f )
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
@ -54,8 +33,8 @@ SYMBOL: negative?
: string>natural ( seq radix -- n/f )
over empty? [ 2drop f ] [
[ [ digit> ] dip (digits>integer) ] each-digit
] if ; inline
[ over CHAR: , eq? [ 2drop ] [ [ digit> ] dip (digits>integer) ] if ] each-digit
] if ;
: sign ( -- str ) negative? get "-" "+" ? ;
@ -83,8 +62,8 @@ SYMBOL: negative?
] if ; inline
: dec>float ( str -- n/f )
[ CHAR: , eq? not ] filter
>byte-array 0 suffix (string>float) ;
[ CHAR: , eq? not ] BV{ } filter-as
0 over push B{ } like (string>float) ;
: hex>float-parts ( str -- neg? mantissa-str expt )
"-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ;
@ -111,23 +90,33 @@ SYMBOL: negative?
{
{ 16 [ hex>float ] }
[ drop dec>float ]
} case ;
} case ; inline
: number-char? ( char -- ? )
"0123456789ABCDEFabcdef." member? ;
"0123456789ABCDEFabcdef." member? ; inline
: last-unsafe ( seq -- elt )
[ length 1 - ] [ nth-unsafe ] bi ; inline
: numeric-looking? ( str -- ? )
"-" ?head drop
dup empty? [ drop f ] [
dup first number-char? [
last number-char?
] [ drop f ] if
] if ;
dup first-unsafe number-char? [
last-unsafe number-char?
] [
dup first-unsafe CHAR: - eq? [
dup length 1 eq? [ drop f ] [
1 over nth-unsafe number-char? [
last-unsafe number-char?
] [ drop f ] if
] if
] [ drop f ] if
] if
] if ; inline
PRIVATE>
: string>float ( str -- n/f )
10 base>float ;
10 base>float ; inline
: base> ( str radix -- n/f )
over numeric-looking? [
@ -138,13 +127,13 @@ PRIVATE>
} case
] [ 2drop f ] if ;
: string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ;
: oct> ( str -- n/f ) 8 base> ;
: hex> ( str -- n/f ) 16 base> ;
: string>number ( str -- n/f ) 10 base> ; inline
: bin> ( str -- n/f ) 2 base> ; inline
: oct> ( str -- n/f ) 8 base> ; inline
: hex> ( str -- n/f ) 16 base> ; inline
: >digit ( n -- ch )
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
: positive>base ( num radix -- str )
dup 1 <= [ "Invalid radix" throw ] when
@ -234,12 +223,12 @@ M: ratio >base
{
{ 16 [ float>hex ] }
[ drop float>decimal ]
} case ;
} case ; inline
PRIVATE>
: float>string ( n -- str )
10 float>base ;
10 float>base ; inline
M: float >base
{
@ -251,9 +240,9 @@ M: float >base
[ float>base ]
} cond ;
: number>string ( n -- str ) 10 >base ;
: >bin ( n -- str ) 2 >base ;
: >oct ( n -- str ) 8 >base ;
: >hex ( n -- str ) 16 >base ;
: number>string ( n -- str ) 10 >base ; inline
: >bin ( n -- str ) 2 >base ; inline
: >oct ( n -- str ) 8 >base ; inline
: >hex ( n -- str ) 16 >base ; inline
: # ( n -- ) number>string % ;
: # ( n -- ) number>string % ; inline

2
core/parser/parser-docs.factor
View File

@ -188,7 +188,7 @@ HELP: parse-lines
{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-base
{ $values { "base" "an integer between 2 and 36" } { "parsed" integer } }
{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } { "parsed" integer } }
{ $description "Reads an integer in a specific numerical base from the parser input." }
$parsing-note ;

4
core/sbufs/sbufs.factor
View File

@ -23,13 +23,13 @@ M: sbuf like
dup string? [ dup length sbuf boa ] [ >sbuf ] if
] unless ; inline
M: sbuf new-resizable drop <sbuf> ; inline
M: sbuf equal?
over sbuf? [ sequence= ] [ 2drop f ] if ;
M: string new-resizable drop <sbuf> ; inline
M: sbuf new-resizable drop <sbuf> ; inline
M: string like
#! If we have a string, we're done.
#! If we have an sbuf, and it's at full capacity, we're done.

17
core/sequences/sequences-docs.factor
View File

@ -218,7 +218,7 @@ HELP: 3sequence
{ $description "Creates a three-element sequence of the same type as " { $snippet "exemplar" } "." } ;
HELP: 4sequence
{ $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "obj3" object } { "obj4" object } { "seq" sequence } }
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "obj4" object } { "exemplar" sequence } { "seq" sequence } }
{ $description "Creates a four-element sequence of the same type as " { $snippet "exemplar" } "." } ;
HELP: first2
@ -277,7 +277,7 @@ HELP: reduce-index
} } ;
HELP: accumulate-as
{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of the same type as " { $snippet "exemplar" } " containing intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
@ -285,7 +285,7 @@ $nl
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } ;
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } }
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs an array of intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
@ -300,7 +300,7 @@ HELP: map
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: map-as
{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
{ $examples
"The following example converts a string into an array of one-element strings:"
@ -426,6 +426,10 @@ HELP: filter
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter-as
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter-here
{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
@ -483,7 +487,7 @@ HELP: remove-nth
} } ;
HELP: move
{ $values { "from" "an index in " { $snippet "seq" } } { "to" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } }
{ $values { "to" "an index in " { $snippet "seq" } } { "from" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } }
{ $description "Sets the element with index " { $snippet "m" } " to the element with index " { $snippet "n" } "." }
{ $side-effects "seq" } ;
@ -510,7 +514,7 @@ HELP: delete-slice
{ $side-effects "seq" } ;
HELP: replace-slice
{ $values { "new" sequence } { "seq" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq'" sequence } }
{ $values { "new" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "seq'" sequence } }
{ $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." }
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } ;
@ -1512,6 +1516,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
"Filtering:"
{ $subsections
filter
filter-as
partition
}
"Testing if a sequence contains elements satisfying a predicate:"

17
core/sequences/sequences.factor
View File

@ -483,11 +483,17 @@ PRIVATE>
: push-if ( elt quot accum -- )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
: pusher-for ( quot exemplar -- quot accum )
[ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline
: pusher ( quot -- quot accum )
V{ } clone [ [ push-if ] 2curry ] keep ; inline
V{ } pusher-for ; inline
: filter-as ( seq quot exemplar -- subseq )
dup [ pusher-for [ each ] dip ] curry dip like ; inline
: filter ( seq quot -- subseq )
over [ pusher [ each ] dip ] dip like ; inline
over filter-as ; inline
: push-either ( elt quot accum1 accum2 -- )
[ keep swap ] 2dip ? push ; inline
@ -498,11 +504,14 @@ PRIVATE>
: partition ( seq quot -- trueseq falseseq )
over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: accumulator-for ( quot exemplar -- quot' vec )
[ length ] keep new-resizable [ [ push ] curry compose ] keep ; inline
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
V{ } accumulator-for ; inline
: produce-as ( pred quot exemplar -- seq )
[ accumulator [ while ] dip ] dip like ; inline
dup [ accumulator-for [ while ] dip ] curry dip like ; inline
: produce ( pred quot -- seq )
{ } produce-as ; inline

2
core/source-files/source-files-docs.factor
View File

@ -38,7 +38,7 @@ HELP: source-file
} ;
HELP: record-checksum
{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
{ $values { "lines" "a sequence of strings" } { "source-file" source-file } }
{ $description "Records the CRC32 checksm of the source file's contents." }
$low-level-note ;

3
extra/alien/data/map/map.factor
View File

@ -1,7 +1,8 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays combinators effects.parser fry generalizations grouping kernel
lexer locals macros make math math.ranges parser sequences sequences.private ;
lexer locals macros make math math.ranges parser sequences
sequences.generalizations sequences.private ;
FROM: alien.arrays => array-length ;
IN: alien.data.map

68
extra/gpu/demos/bunny/bunny.factor
View File

@ -3,13 +3,15 @@ USING: accessors alien.c-types arrays classes.struct combinators
combinators.short-circuit game.worlds gpu gpu.buffers
gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
gpu.textures gpu.util grouping http.client images images.loader
io io.encodings.ascii io.files io.files.temp kernel math
math.matrices math.parser math.vectors method-chains sequences
splitting threads ui ui.gadgets ui.gadgets.worlds
ui.pixel-formats specialized-arrays specialized-vectors ;
io io.encodings.ascii io.files io.files.temp kernel locals math
math.matrices math.vectors.simd math.parser math.vectors
method-chains namespaces sequences splitting threads ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats specialized-arrays
specialized-vectors ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: uint
SIMD: float
IN: gpu.demos.bunny
GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl"
@ -52,7 +54,10 @@ VERTEX-FORMAT: bunny-vertex
{ f float-components 1 f }
{ "normal" float-components 3 f }
{ f float-components 1 f } ;
VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
STRUCT: bunny-vertex-struct
{ vertex float-4 }
{ normal float-4 } ;
SPECIALIZED-VECTOR: bunny-vertex-struct
@ -74,43 +79,58 @@ UNIFORM-TUPLE: loading-uniforms
{ "texcoord-scale" vec2-uniform f }
{ "loading-texture" texture-uniform f } ;
: numbers ( str -- seq )
" " split [ string>number ] map sift ;
: numbers ( tokens -- seq )
[ string>number ] map ; inline
: <bunny-vertex> ( vertex -- struct )
bunny-vertex-struct <struct>
swap >float-array >>vertex ; inline
swap first3 0.0 float-4-boa >>vertex ; inline
: (read-line-tokens) ( seq stream -- seq )
" \n" over stream-read-until
[ [ pick push ] unless-empty ]
[
{
{ CHAR: \s [ (read-line-tokens) ] }
{ CHAR: \n [ drop ] }
[ 2drop [ f ] when-empty ]
} case
] bi* ; inline recursive
: stream-read-line-tokens ( stream -- seq )
V{ } clone swap (read-line-tokens) ;
: each-line-tokens ( quot -- )
input-stream get [ stream-read-line-tokens ] curry each-morsel ; inline
: (parse-bunny-model) ( vs is -- vs is )
readln [
[
numbers {
{ [ dup length 5 = ] [ 3 head <bunny-vertex> pick push ] }
{ [ dup length 5 = ] [ <bunny-vertex> pick push ] }
{ [ dup first 3 = ] [ rest over push-all ] }
[ drop ]
} cond (parse-bunny-model)
] when* ;
} cond
] each-line-tokens ; inline
: parse-bunny-model ( -- vertexes indexes )
100000 <bunny-vertex-struct-vector>
100000 <uint-vector>
(parse-bunny-model) ;
(parse-bunny-model) ; inline
: normal ( vertexes -- normal )
[ [ second ] [ first ] bi v- ]
[ [ third ] [ first ] bi v- ] bi cross
vneg normalize ; inline
:: normal ( a b c -- normal )
c a v-
b a v- cross normalize ; inline
: calc-bunny-normal ( vertexes indexes -- )
swap
[ [ nth vertex>> ] curry { } map-as normal ]
[ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ;
:: calc-bunny-normal ( a b c vertexes -- )
a b c [ vertexes nth vertex>> ] tri@ normal :> n
a b c [ vertexes nth [ n v+ ] change-normal drop ] tri@ ; inline
: calc-bunny-normals ( vertexes indexes -- )
3 <groups>
[ calc-bunny-normal ] with each ;
3 <sliced-groups> swap
[ [ first3 ] dip calc-bunny-normal ] curry each ; inline
: normalize-bunny-normals ( vertexes -- )
[ [ normalize ] change-normal drop ] each ;
[ [ normalize ] change-normal drop ] each ; inline
: bunny-data ( filename -- vertexes indexes )
ascii [ parse-bunny-model ] with-file-reader

4
extra/models/combinators/combinators-docs.factor
View File

@ -10,7 +10,7 @@ HELP: filter-model
{ $description "Creates a model that uses the updates of another model only when they satisfy a given predicate" } ;
HELP: fold
{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model" model } }
{ $values { "model" model } { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } }
{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
HELP: switch-models
@ -38,4 +38,4 @@ ARTICLE: "models.combinators" "Extending models"
"Also, it provides methods of manipulating and combining models, expecially useful when programming user interfaces: "
"The output models of some gadgets (see " { $vocab-link "ui.gadgets.controls" } " ) can be manipulated and used as the input models of others. " ;
ABOUT: "models.combinators"
ABOUT: "models.combinators"