More documentation updates

slava 2006-08-17 01:55:53 +00:00
parent c99c10632c
commit 29e28008cd
123 changed files with 1580 additions and 1319 deletions

View File

@ -1,6 +1,7 @@
+ 0.84:
- doc mashup:
- document: equals? parse-hook no-parse-hook
- HELP: should not specify stack effect
- figure out what to do for parsing words
- document inference errors

View File

@ -4,7 +4,8 @@ ARTICLE: "help" "The help system"
"The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words."
{ $subsection "browsing-help" }
{ $subsection "searching-help" }
{ $subsection "writing-help" } ;
{ $subsection "writing-help" }
{ $subsection "porter-stemmer" } ;
ARTICLE: "browsing-help" "Browsing documentation"
"The easiest way to browse the help is from the help browser tool in the UI, however you can also display help topics in the listener."
@ -91,3 +92,21 @@ ARTICLE: "markup-utils" "Markup element utilities"
{ $subsection simple-element }
{ $subsection ($span) }
{ $subsection ($block) } ;
ARTICLE: "porter-stemmer" "Porter stemming algorithm"
"The help system uses the Porter stemming algorithm to normalize words when building the full-text search index."
$terpri
"The Factor implementation of the algorithm is based on the Common Lisp version, which was hand-translated from ANSI C by Steven M. Haflich. The original ANSI C was written by Martin Porter."
$terpri
"A detailed description of the algorithm, along with implementations in various languages, can be at in " { $url "http://www.tartarus.org/~martin/PorterStemmer" } "."
$terpri
"The main word of the algorithm takes an English word as input and outputs its stem:"
{ $subsection stem }
"The algorithm consists of a number of steps:"
{ $subsection step1a }
{ $subsection step1b }
{ $subsection step1c }
{ $subsection step2 }
{ $subsection step3 }
{ $subsection step4 }
{ $subsection step5 } ;

View File

@ -64,11 +64,12 @@ ARTICLE: "stdio" "The default stream"
{ $subsection with-stream* } ;
ARTICLE: "styles" "Formatted output"
"The " { $link stream-format } " and " { $link with-nested-stream } " words take a hashtable of style attributes. The former acts on character styles, and the latter acts on paragraph styles. Output stream implementations are free to ignore style information."
"The " { $link stream-format } ", " { $link with-nested-stream } " and " { $link with-stream-table } " words take a hashtable of style attributes. Output stream implementations are free to ignore style information."
$terpri
"Style hashtables are keyed by symbols from the " { $vocab-link "styles" } " vocabulary."
{ $subsection "character-styles" }
{ $subsection "paragraph-styles" }
{ $subsection "table-styles" }
{ $subsection "presentations" } ;
ARTICLE: "character-styles" "Character styles"
@ -89,6 +90,11 @@ ARTICLE: "paragraph-styles" "Paragraph styles"
{ $subsection outline }
{ $subsection presented } ;
ARTICLE: "table-styles" "Table styles"
"Table styles for " { $link with-stream-table } ":"
{ $subsection table-gap }
{ $subsection table-border } ;
ARTICLE: "presentations" "Presentations and outliners"
"The " { $link presented } " and " { $link outline } " styles can be used to build sophisticated user interfaces in the Factor UI. Instead of setting them directly, two utility words should be used:"
{ $subsection write-object }

View File

@ -220,6 +220,7 @@ sequences vectors words ;
"/library/ui/tools/launchpad.factor"
"/library/continuations.facts"
"/library/definitions.facts"
"/library/effects.facts"
"/library/errors.facts"
"/library/kernel.facts"
@ -264,6 +265,7 @@ sequences vectors words ;
"/library/generic/tuple.facts"
"/library/help/help.facts"
"/library/help/markup.facts"
"/library/help/porter-stemmer.facts"
"/library/help/search.facts"
"/library/help/syntax.facts"
"/library/help/topics.facts"
@ -273,6 +275,7 @@ sequences vectors words ;
"/library/io/duplex-stream.facts"
"/library/io/files.facts"
"/library/io/lines.facts"
"/library/io/nested-style.facts"
"/library/io/plain-stream.facts"
"/library/io/server.facts"
"/library/io/stdio.facts"

View File

@ -10,5 +10,5 @@ M: sbuf set-nth-unsafe underlying set-nth-unsafe ;
M: sbuf set-nth growable-check 2dup ensure set-nth-unsafe ;
M: sbuf clone clone-growable ;
M: sbuf thaw drop SBUF" " clone ;
: >sbuf [ sbuf? ] [ <sbuf> ] >sequence ; inline
: >sbuf ( seq -- sbuf ) [ sbuf? ] [ <sbuf> ] >sequence ; inline
M: sbuf like drop dup sbuf? [ >sbuf ] unless ;

View File

@ -85,15 +85,15 @@ IN: sequences
swap dup length 1 <=
[ 2drop ] [ 0 over length 1- (nsort) ] if ; inline
: sort ( seq quot -- seq )
: sort ( seq quot -- sortedseq )
swap [ swap nsort ] immutable ; inline
: natural-sort ( seq -- seq ) [ <=> ] sort ;
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
: binsearch ( elt seq quot -- i )
swap dup empty?
[ 3drop -1 ] [ flatten-slice (binsearch) ] if ; inline
: binsearch* ( elt seq quot -- elt )
: binsearch* ( elt seq quot -- result )
over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] if ;
inline

View File

@ -1,26 +1,26 @@
IN: sequences
USING: help kernel words ;
HELP: sort "( seq quot -- sortedseq )"
HELP: sort
{ $values { "seq" "a sequence" } { "quot" "a comparator quotation" } { "sortedseq" "a new sorted sequence" } }
{ $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ;
HELP: nsort "( seq quot -- sortedseq )"
{ $values { "seq" "a mutable sequence" } { "quot" "a comparator quotation" } { "sortedseq" "a new sorted sequence" } }
HELP: nsort
{ $values { "seq" "a mutable sequence" } { "quot" "a comparator quotation" } }
{ $description "Sorts the sequence in-place." }
{ $side-effects "seq" } ;
HELP: natural-sort "( seq -- sortedseq )"
HELP: natural-sort
{ $values { "seq" "a sequence of real numbers" } { "sortedseq" "a new sorted sequence" } }
{ $description "Sorts a sequence of objects in natural order using the " { $link <=> } " word." } ;
HELP: binsearch "( elt seq quot -- i )"
HELP: binsearch
{ $values { "elt" "an object" } { "seq" "a sorted sequence" } { "quot" "a comparator quotation" } { "i" "the index of the search result" } }
{ $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "."
$terpri
"Outputs -1 if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
HELP: binsearch* "( elt seq quot -- result )"
HELP: binsearch*
{ $values { "elt" "an object" } { "seq" "a sorted sequence" } { "quot" "a comparator quotation" } { "result" "the search result" } }
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
$terpri

View File

@ -4,13 +4,13 @@ IN: sequences
USING: arrays errors generic kernel kernel-internals math
sequences-internals strings vectors words ;
: first2 ( seq -- x y )
: first2 ( seq -- first second )
1 swap bounds-check nip first2-unsafe ;
: first3 ( seq -- x y z )
: first3 ( seq -- first second third )
2 swap bounds-check nip first3-unsafe ;
: first4 ( seq -- x y z w )
: first4 ( seq -- first second third fourth )
3 swap bounds-check nip first4-unsafe ;
M: object like drop ;
@ -43,7 +43,7 @@ M: object like drop ;
: subst ( newseq oldseq seq -- )
[ >r 2dup r> (subst) ] inject 2drop ;
: move ( to from seq -- )
: move ( m n seq -- )
pick pick number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
@ -58,41 +58,39 @@ M: object like drop ;
: push-new ( elt seq -- ) [ delete ] 2keep push ;
: prune ( seq -- seq )
: prune ( seq -- newseq )
[ V{ } clone swap [ over push-new ] each ] keep like ;
: nappend ( to from -- )
: nappend ( dest src -- )
>r [ length ] keep r> copy-into ; inline
: >resizable ( seq -- seq ) [ thaw dup ] keep nappend ;
: >resizable ( seq -- newseq ) [ thaw dup ] keep nappend ;
: immutable ( seq quot -- seq )
: immutable ( seq quot -- newseq )
swap [ >resizable [ swap call ] keep ] keep like ; inline
: append ( s1 s2 -- s1+s2 )
: append ( seq1 seq2 -- newseq )
swap [ swap nappend ] immutable ;
: add ( seq elt -- seq )
: add ( seq elt -- newseq )
swap [ push ] immutable ;
: add* ( seq elt -- seq )
: add* ( seq elt -- newseq )
over >r
over thaw [ push ] keep [ swap nappend ] keep
r> like ;
: diff ( seq1 seq2 -- seq2-seq1 )
: diff ( seq1 seq2 -- newseq )
[ swap member? not ] subset-with ;
: append3 ( s1 s2 s3 -- s1+s2+s3 )
: append3 ( seq1 seq2 seq3 -- newseq )
rot [ [ rot nappend ] keep swap nappend ] immutable ;
: peek ( sequence -- element ) dup length 1- swap nth ;
: peek ( seq -- elt ) dup length 1- swap nth ;
: pop* ( sequence -- )
dup length 1- swap set-length ;
: pop* ( seq -- ) dup length 1- swap set-length ;
: pop ( sequence -- element )
dup length 1- swap [ nth ] 2keep set-length ;
: pop ( seq -- ) dup length 1- swap [ nth ] 2keep set-length ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
@ -104,16 +102,16 @@ M: object like drop ;
: mismatch ( seq1 seq2 -- i )
2dup min-length (mismatch) ;
: flip ( seq -- seq )
: flip ( matrix -- newmatrix )
dup empty? [
dup first [ length ] keep like
[ swap [ nth ] map-with ] map-with
] unless ;
: unpair ( seq -- firsts seconds )
: unpair ( assoc -- keys values )
flip dup empty? [ drop { } { } ] [ first2 ] if ;
: exchange ( n n seq -- )
: exchange ( m n seq -- )
pick over bounds-check 2drop 2dup bounds-check 2drop
exchange-unsafe ;
@ -125,7 +123,7 @@ M: object like drop ;
: last/first ( seq -- pair ) dup peek swap first 2array ;
: sequence= ( seq seq -- ? )
: sequence= ( seq1 seq2 -- ? )
2dup [ length ] 2apply tuck number=
[ (mismatch) -1 number= ] [ 3drop f ] if ; inline
@ -157,7 +155,8 @@ M: object <=>
TUPLE: no-cond ;
: no-cond ( -- * ) <no-cond> throw ;
: cond ( conditions -- )
: cond ( assoc -- )
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
: unix? os { "freebsd" "linux" "macosx" "solaris" } member? ;
: unix? ( -- ? )
os { "freebsd" "linux" "macosx" "solaris" } member? ;

View File

@ -1,37 +1,47 @@
IN: sequences
USING: help kernel ;
HELP: first2 "( seq -- first second )"
HELP: first2
{ $values { "seq" "a sequence" } { "first" "the first element" } { "second" "the second element" } }
{ $description "Pushes the first two elements of a sequence." }
{ $errors "Throws an error if the sequence has less than two elements." } ;
HELP: first3 "( seq -- first second third )"
HELP: first3
{ $values { "seq" "a sequence" } { "first" "the first element" } { "second" "the second element" } { "third" "the third element" } }
{ $description "Pushes the first three elements of a sequence." }
{ $errors "Throws an error if the sequence has less than three elements." } ;
HELP: first4 "( seq -- first second third fourth )"
HELP: first4
{ $values { "seq" "a sequence" } { "first" "the first element" } { "second" "the second element" } { "third" "the third element" } { "fourth" "the fourth element" } }
{ $description "Pushes the first four elements of a sequence." }
{ $errors "Throws an error if the sequence has less than four elements." } ;
HELP: index "( obj seq -- n )"
HELP: index
{ $values { "obj" "an object" } { "seq" "a sequence" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs -1." }
{ $see-also index* member? } ;
HELP: index* "( obj i seq -- n )"
HELP: index*
{ $values { "obj" "an object" } { "i" "a start index" } { "seq" "a sequence" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs -1." }
{ $see-also index member? } ;
HELP: member? "( obj seq -- ? )"
HELP: last-index
{ $values { "obj" "an object" } { "seq" "a sequence" } }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } "; the sequence is traversed back to front. If no element is found, outputs -1." }
{ $see-also index* member? } ;
HELP: last-index*
{ $values { "obj" "an object" } { "i" "a start index" } { "seq" "a sequence" } }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } ", traversing the sequence backwards starting from the " { $snippet "i" } "th element and finishing at the first. If no element is found, outputs -1." }
{ $see-also index member? } ;
HELP: member?
{ $values { "obj" "an object" } { "seq" "a sequence" } }
{ $description "Tests if the sequence contains an element equal to the object." }
{ $see-also index index* memq? } ;
HELP: memq? "( obj seq -- ? )"
HELP: memq?
{ $values { "obj" "an object" } { "seq" "a sequence" } }
{ $description "Tests if the sequence contains the object." }
{ $examples
@ -40,26 +50,26 @@ HELP: memq? "( obj seq -- ? )"
}
{ $see-also index index* member? } ;
HELP: remove "( elt seq -- newseq )"
HELP: remove
{ $values { "elt" "an object" } { "seq" "a sequence" } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." } ;
HELP: subst "( newseq oldseq seq -- )"
HELP: subst
{ $values { "newseq" "a sequence" } { "oldseq" "a mutable sequence" } { "seq" "a sequence" } }
{ $description "Searches for every element of " { $snippet "seq" } " in " { $snippet "oldseq" } "; if a match is found, the element is replaced by the element of " { $snippet "oldseq" } " at the same index." }
{ $side-effects "seq" } ;
HELP: move "( m n seq -- )"
HELP: move
{ $values { "m" "an index in " { $snippet "seq" } } { "n" "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" } ;
HELP: delete "( elt seq -- )"
HELP: delete
{ $values { "elt" "an object" } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } "." }
{ $side-effects "seq" } ;
HELP: push-new "( elt seq -- )"
HELP: push-new
{ $values { "elt" "an object" } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
{ $examples
@ -74,21 +84,21 @@ HELP: push-new "( elt seq -- )"
{ $side-effects "seq" }
{ $see-also push } ;
HELP: prune "( seq -- newseq )"
HELP: prune
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." } ;
HELP: nappend "( dest src -- )"
HELP: nappend
{ $values { "n" "an index in " { $snippet "dest" } } { "dest" "a resizable mutable sequence" } { "src" "a sequence" } }
{ $description "Appends " { $snippet "src" } " to the end of " { $snippet "dest" } "." }
{ $side-effects "dest" }
{ $errors "Throws an error if " { $snippet "src" } " contains elements not permitted in " { $snippet "dest" } "." } ;
HELP: >resizable "( seq -- newseq )"
HELP: >resizable
{ $values { "seq" "a sequence" } { "newseq" "a mutable resizable sequence" } }
{ $description "Outputs a new, mutable resizable sequence having the same elements as " { $snippet "seq" } "." } ;
HELP: immutable "( seq quot -- newseq )"
HELP: immutable
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( seq -- )" } } { "newseq" "a sequence" } }
{ $description "A utility combinator transforming a word which modifies its input sequence into a word which returns a new output sequence. "
$terpri
@ -97,7 +107,7 @@ $terpri
"Take a look at " { $link append } ", which is built off the mutating word " { $link nappend } ", or " { $link add } " which is built from " { $link push } "."
} ;
HELP: add "( seq elt -- newseq )"
HELP: add
{ $values { "seq" "a sequence" } { "elt" "an object" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
@ -105,7 +115,7 @@ HELP: add "( seq elt -- newseq )"
{ $example "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" }
} ;
HELP: add* "( seq elt -- newseq )"
HELP: add*
{ $values { "seq" "a sequence" } { "elt" "an object" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
@ -113,88 +123,88 @@ HELP: add* "( seq elt -- newseq )"
{ $example "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" }
} ;
HELP: diff "( seq1 seq2 -- newseq )"
HELP: diff
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality." } ;
HELP: append "( seq1 seq2 -- newseq )"
HELP: append
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence of the same type as " { $snippet "seq1" } " consisting of the elements of " { $snippet "seq1" } " followed by " { $snippet "seq2" } "." }
{ $errors "Throws an error if " { $snippet "seq2" } " contains elements not permitted in sequences of the same class as " { $snippet "seq1" } "." } ;
HELP: append3 "( seq1 seq2 seq3 -- newseq )"
HELP: append3
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "seq3" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence consisting of the elements of " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } " in turn." }
{ $errors "Throws an error if " { $snippet "seq2" } " or " { $snippet "seq3" } " contain elements not permitted in sequences of the same class as " { $snippet "seq1" } "." } ;
HELP: peek "( seq -- elt )"
HELP: peek
{ $values { "seq" "a sequence" } { "elt" "an object" } }
{ $description "Outputs the last element of a sequence." }
{ $errors "Throws an error if the sequence is empty." }
{ $see-also pop* pop } ;
HELP: pop* "( seq -- )"
HELP: pop*
{ $values { "seq" "a resizable mutable sequence" } }
{ $description "Removes the last element and shortens the sequence." }
{ $side-effects "seq" }
{ $errors "Throws an error if the sequence is empty." }
{ $see-also peek pop } ;
HELP: pop "( seq -- )"
HELP: pop
{ $values { "seq" "a resizable mutable sequence" } }
{ $description "Outputs the last element after removing it and shortening the sequence." }
{ $side-effects "seq" }
{ $errors "Throws an error if the sequence is empty." }
{ $see-also peek pop* } ;
HELP: all-equal? "( seq -- ? )"
HELP: all-equal?
{ $values { "seq" "a sequence" } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence are equal. Yields true with an empty sequence." } ;
HELP: all-eq? "( seq -- ? )"
HELP: all-eq?
{ $values { "seq" "a sequence" } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence are the same identical object. Yields true with an empty sequence." } ;
HELP: mismatch "( seq1 seq2 -- i )"
HELP: mismatch
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "i" "an index" } }
{ $description "Compares pairs of elements up to the minimum of the sequences' lengths, outputting the first index where the two sequences have non-equal elements, or -1 if all tested elements were equal." } ;
HELP: flip "( matrix -- newmatrix )"
HELP: flip
{ $values { "matrix" "a sequence of equal-length sequences" } { "newmatrix" "a sequence of equal-length sequences" } }
{ $description "Transposes the matrix; that is, rows become columns and columns become rows." }
{ $examples { $example "{ { 1 2 3 } { 4 5 6 } } flip ." "{ { 1 4 } { 2 5 } { 3 6 } }" } } ;
HELP: unpair "( assoc -- keys values )"
HELP: unpair
{ $values { "assoc" "a sequence of pairs" } { "keys" "a new sequence" } { "values" "a new sequence" } }
{ $description "Given a sequence of two-element sequences, outputs a new sequence with the first element of each pair, and a new sequence with the second element of each pair." } ;
HELP: exchange "( m n seq -- )"
HELP: exchange
{ $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
{ $description "Exchanges the " { $snippet "m" } "th and " { $snippet "n" } "th elements of " { $snippet "seq" } "." } ;
HELP: assoc "( key assoc -- value )"
HELP: assoc
{ $values { "key" "an object" } { "assoc" "a sequence of pairs" } { "value" "the associated value, or " { $link f } } }
{ $description "Searches for a pair whose first element is equal to the key and outputs the second element of the pair. Keys are compared for equality using " { $link = } ". Outputs " { $link f } " if no matching key is found." }
{ $see-also rassoc } ;
HELP: rassoc "( value assoc -- key )"
HELP: rassoc
{ $values { "value" "an object" } { "assoc" "a sequence of pairs" } { "key" "the associated key, or " { $link f } } }
{ $description "Searches for a pair whose second element is equal to the value and outputs the first element of the pair. Values are compared for equality using " { $link = } ". Outputs " { $link f } " if no matching value is found." }
{ $see-also rassoc } ;
HELP: last/first "( seq -- pair )"
HELP: last/first
{ $values { "seq" "a sequence" } { "pair" "a two-element array" } }
{ $description "Creates an array holding the first and last element of the sequence." } ;
HELP: sequence= "( seq1 seq2 -- ? )"
HELP: sequence=
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "?" "a boolean" } }
{ $description "Tests if the two sequences have the same length and elements. This is weaker than " { $link = } ", since it does not ensure that the sequences are instances of the same class." } ;
HELP: depth "( -- n )"
HELP: depth
{ $values { "n" "a non-negative integer" } }
{ $description "Outputs the number of elements on the data stack." } ;
HELP: cond "( assoc -- )"
HELP: cond
{ $values { "assoc" "a sequence of quotation pairs" } }
{ $description
"Calls the second quotation in the first pair whose first quotation yields a true value."
@ -214,10 +224,10 @@ HELP: cond "( assoc -- )"
}
} ;
HELP: no-cond "( -- )"
HELP: no-cond
{ $description "Throws a " { $link no-cond } " error." }
{ $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Most uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error. If you wish to assert that certain conditions are true, and fail otherwise, you can use " { $link cond } " without a default case." } ;
HELP: unix? "( -- ? )"
HELP: unix?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;

View File

@ -3,24 +3,23 @@
IN: sequences
USING: errors generic kernel math math-internals strings vectors ;
GENERIC: length ( sequence -- n )
GENERIC: set-length ( n sequence -- )
GENERIC: nth ( n sequence -- obj )
GENERIC: set-nth ( value n sequence -- )
GENERIC: thaw ( seq -- mutable-seq )
GENERIC: like ( seq seq -- seq )
GENERIC: length ( seq -- n )
GENERIC: set-length ( n seq -- )
GENERIC: nth ( n seq -- elt )
GENERIC: set-nth ( elt n seq -- )
GENERIC: thaw ( seq -- resizable-seq )
GENERIC: like ( seq prototype -- newseq )
: empty? ( seq -- ? ) length zero? ; inline
: delete-all ( seq -- ) 0 swap set-length ;
: first 0 swap nth ; inline
: second 1 swap nth ; inline
: third 2 swap nth ; inline
: fourth 3 swap nth ; inline
: first ( seq -- first ) 0 swap nth ; inline
: second ( seq -- second ) 1 swap nth ; inline
: third ( seq -- third ) 2 swap nth ; inline
: fourth ( seq -- fourth ) 3 swap nth ; inline
: push ( element sequence -- )
dup length swap set-nth ;
: push ( elt seq -- ) dup length swap set-nth ;
: ?push ( elt seq/f -- seq )
[ 1 <vector> ] unless* [ push ] keep ;
@ -30,11 +29,11 @@ GENERIC: like ( seq seq -- seq )
IN: sequences-internals
GENERIC: resize ( n seq -- seq )
GENERIC: resize ( n seq -- newseq )
! Unsafe sequence protocol for inner loops
GENERIC: nth-unsafe ( n sequence -- elt )
GENERIC: set-nth-unsafe ( elt n sequence -- )
GENERIC: nth-unsafe ( n seq -- elt )
GENERIC: set-nth-unsafe ( elt n seq -- )
M: object nth-unsafe nth ;
M: object set-nth-unsafe set-nth ;
@ -53,9 +52,14 @@ M: integer length ;
M: integer nth drop ;
M: integer nth-unsafe drop ;
: first2-unsafe [ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline
: first3-unsafe [ first2-unsafe ] keep 2 swap nth-unsafe ; inline
: first4-unsafe [ first3-unsafe ] keep 3 swap nth-unsafe ; inline
: first2-unsafe
[ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline
: first3-unsafe
[ first2-unsafe ] keep 2 swap nth-unsafe ; inline
: first4-unsafe
[ first3-unsafe ] keep 3 swap nth-unsafe ; inline
: exchange-unsafe ( n n seq -- )
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck

View File

@ -1,21 +1,21 @@
USING: help sequences sequences-internals ;
HELP: length "( seq -- n )"
HELP: length
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } }
{ $contract "Outputs the length of the sequence. All sequences support this operation." } ;
HELP: set-length "( n seq -- )"
HELP: set-length
{ $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } }
{ $description "Resizes the sequence. Not all sequences are resizable." }
{ $contract "Resizes the sequence. Not all sequences are resizable." }
{ $errors "Throws a " { $link bounds-error } " if the new length is negative, or if the sequence is not resizable." }
{ $side-effects "seq" } ;
HELP: nth "( n seq -- elt )"
HELP: nth
{ $values { "n" "a non-negative integer" } { "seq" "a sequence" } { "elt" "the element at the " { $snippet "n" } "th index" } }
{ $contract "Outputs the " { $snippet "n" } "th element of the sequence. Elements are numbered from zero, so the last element has an index one less than the length of the sequence. All sequences support this operation." }
{ $errors "Throws a " { $link bounds-error } " if the index is negative, or greater than or equal to the length of the sequence." } ;
HELP: set-nth "( elt n seq -- )"
HELP: set-nth
{ $values { "elt" "an object" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
{ $contract "Sets the " { $snippet "n" } "th element of the sequence. Storing beyond the end of a resizable sequence such as a vector or string buffer grows the sequence." }
{ $errors "Throws an error if the index is negative, or if the sequence is not resizable and the index is greater than or equal to the length of the sequence."
@ -23,78 +23,91 @@ $terpri
"Throws an error if the sequence cannot hold elements of the given type." }
{ $side-effects "seq" } ;
HELP: thaw "( seq -- resizable-seq )"
HELP: thaw
{ $values { "seq" "a sequence" } { "resizable-seq" "a resizable mutable sequence" } }
{ $contract "Outputs an empty, resizable mutable sequence that can hold the elements of " { $snippet "seq" } "." }
{ $examples "The default implementation returns a new vector, but given a string, it returns a string buffer, since string buffers are more efficient in terms of memory usage." } ;
HELP: like "( seq prototype -- newseq )"
HELP: like
{ $values { "seq" "a sequence" } { "prototype" "a sequence" } { "newseq" "a sequence" } }
{ $contract "Outputs a sequence with the same elements as the input sequence, but " { $emphasis "like" } " the template sequence, in the sense that it either has the same class as the template sequence, or if the template sequence is a virtual sequence, the same class as the template sequence's underlying sequence. The default implementation does nothing." } ;
HELP: empty? "( seq -- ? )"
HELP: empty?
{ $values { "seq" "a sequence" } { "?" "a boolean" } }
{ $description "Tests if the sequence has zero length." } ;
HELP: peek "( seq -- elt )"
{ $values { "seq" "a sequence" } { "elt" "an object" } }
{ $description "Outputs the last element of the sequence." }
{ $errors "Throws an error if the sequence is empty." } ;
HELP: delete-all
{ $values { "seq" "a resizable sequence" } }
{ $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." }
{ $errors "Throws a " { $link bounds-error } " if the new length is negative, or if the sequence is not resizable." }
{ $side-effects "seq" } ;
HELP: resize "( n seq -- newseq )"
HELP: resize
{ $values { "n" "a non-negative integer" } { "seq" "a sequence" } { "newseq" "a new sequence" } }
{ $description "Creates a new sequence of the same type as " { $snippet "seq" } " with " { $snippet "n" } " elements, and copies the contents of " { $snippet "seq" } " into the new sequence. If " { $snippet "n" } " exceeds the length of " { $snippet "seq" } ", the remaining elements are filled with a default value; " { $link f } " for arrays and 0 for strings." }
{ $notes "This generic word is only implemented for strings and arrays." } ;
HELP: first "( seq -- first )"
HELP: first
{ $values { "seq" "a sequence" } { "first" "the first element of the sequence" } }
{ $description "Outputs the first element of the sequence." }
{ $errors "Throws an error if the sequence is empty." } ;
HELP: second "( seq -- second )"
HELP: second
{ $values { "seq" "a sequence" } { "second" "the second element of the sequence" } }
{ $description "Outputs the second element of the sequence." }
{ $errors "Throws an error if the sequence contains less than two elements." } ;
HELP: third "( seq -- third )"
HELP: third
{ $values { "seq" "a sequence" } { "third" "the third element of the sequence" } }
{ $description "Outputs the third element of the sequence." }
{ $errors "Throws an error if the sequence contains less than three elements." } ;
HELP: fourth "( seq -- fourth )"
HELP: fourth
{ $values { "seq" "a sequence" } { "fourth" "the fourth element of the sequence" } }
{ $description "Outputs the fourth element of the sequence." }
{ $errors "Throws an error if the sequence contains less than four elements." } ;
HELP: push "( elt seq -- )"
HELP: push
{ $values { "elt" "an object" } { "seq" "a resizable mutable sequence" } }
{ $description "Adds an element at the end of the sequence. The sequence length is adjusted accordingly." }
{ $errors "Throws an error if " { $snippet "seq" } " is not resizable, or if the type of " { $snippet "elt" } " is not permitted in " { $snippet "seq" } "." }
{ $side-effects "seq" }
{ $see-also pop push-new } ;
HELP: ?push "( elt seq/f -- seq )"
HELP: ?push
{ $values { "elt" "an object" } { "seq/f" "a resizable mutable sequence, or " { $link f } } { "seq" "a resizable mutable sequence" } }
{ $description "If the given sequence is " { $link f } ", creates and outputs a new one-element vector holding " { $snippet "elt" } ". Otherwise, pushes " { $snippet "elt" } " onto the given sequence." }
{ $errors "Throws an error if " { $snippet "seq" } " is not resizable, or if the type of " { $snippet "elt" } " is not permitted in " { $snippet "seq" } "." }
{ $side-effects "seq" } ;
HELP: bounds-check? "( n seq -- ? )"
HELP: bounds-check?
{ $values { "n" "an integer" } { "seq" "a sequence" } { "?" "a boolean" } }
{ $description "Tests if the index is within the bounds of the sequence." } ;
HELP: ?nth "( n seq/f -- elt )"
{ $values { "n" "an integer" } { "seq" "a sequence" } { "elt" "an object" } }
HELP: ?nth
{ $values { "n" "an integer" } { "seq" "a sequence" } { "elt/f" "an object or " { $link f } } }
{ $description "A forgiving version of " { $link nth } ". If the index is out of bounds, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ;
HELP: nth-unsafe "( n seq -- elt )"
HELP: nth-unsafe
{ $values { "n" "an integer" } { "seq" "a sequence" } { "elt" "an object" } }
{ $contract "Unsafe variant of " { $link nth } " that does not perform bounds checks." } ;
HELP: set-nth-unsafe "( elt n seq -- )"
HELP: set-nth-unsafe
{ $values { "elt" "an object" } { "n" "an integer" } { "seq" "a sequence" } }
{ $contract "Unsafe variant of " { $link set-nth } " that does not perform bounds checks." } ;
HELP: exchange-unsafe "( m n seq -- )"
{ $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
{ $description "Unsafe variant of " { $link exchange } " that does not perform bounds checks." } ;
HELP: first2-unsafe
{ $values { "seq" "a sequence" } { "first" "the first element" } { "second" "the second element" } }
{ $contract "Unsafe variant of " { $link first2 } " that does not perform bounds checks." } ;
HELP: first3-unsafe
{ $values { "seq" "a sequence" } { "first" "the first element" } { "second" "the second element" } { "third" "the third element" } }
{ $contract "Unsafe variant of " { $link first3 } " that does not perform bounds checks." } ;
HELP: first4-unsafe
{ $values { "seq" "a sequence" } { "first" "the first element" } { "second" "the second element" } { "third" "the third element" } { "fourth" "the fourth element" } }
{ $contract "Unsafe variant of " { $link first4 } " that does not perform bounds checks." } ;

View File

@ -14,15 +14,15 @@ strings vectors ;
: tail-slice* ( seq n -- slice ) (slice*) tail-slice ;
: subseq ( from to seq -- seq ) [ <slice> ] keep like ;
: subseq ( from to seq -- subseq ) [ <slice> ] keep like ;
: head ( seq n -- slice ) dupd head-slice swap like ;
: head ( seq n -- headseq ) dupd head-slice swap like ;
: head* ( seq n -- slice ) dupd head-slice* swap like ;
: head* ( seq n -- headseq ) dupd head-slice* swap like ;
: tail ( seq n -- slice ) dupd tail-slice swap like ;
: tail ( seq n -- tailseq ) dupd tail-slice swap like ;
: tail* ( seq n -- slice ) dupd tail-slice* swap like ;
: tail* ( seq n -- tailseq ) dupd tail-slice* swap like ;
: head? ( seq begin -- ? )
2dup [ length ] 2apply < [
@ -31,23 +31,23 @@ strings vectors ;
[ length head-slice ] keep sequence=
] if ;
: ?head ( seq begin -- seq ? )
: ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ;
: tail? ( seq end -- ? )
: tail? ( seq end -- newseq ? )
2dup [ length ] 2apply < [
2drop f
] [
[ length tail-slice* ] keep sequence=
] if ;
: ?tail ( seq end -- seq ? )
: ?tail ( seq end -- newseq ? )
2dup tail? [ length head* t ] [ drop f ] if ;
: replace-slice ( new from to seq -- seq )
: replace-slice ( new m n seq -- replaced )
tuck swap tail-slice >r swap head-slice swap r> append3 ;
: remove-nth ( n seq -- seq )
: remove-nth ( n seq -- newseq )
>r f swap dup 1+ r> replace-slice ;
: (cut) ( n seq -- before after )
@ -66,12 +66,12 @@ strings vectors ;
dupd (cut) >r , r> (group)
] if ;
: group ( seq n -- seq ) [ swap (group) ] { } make ;
: group ( seq n -- groups ) [ swap (group) ] { } make ;
: start-step ( subseq seq n -- subseq slice )
pick length dupd + rot <slice> ;
: start* ( subseq seq n -- n )
: start* ( subseq seq i -- n )
pick length pick length pick - > [
3drop -1
] [
@ -97,19 +97,19 @@ strings vectors ;
: split-next, V{ } clone , ;
: (split) ( separator elt -- )
: (split) ( quot elt -- )
[ swap call ] keep swap
[ drop split-next, ] [ split, ] if ; inline
: split* ( seq separator -- split )
: split* ( seq quot -- pieces )
over >r
[ split-next, swap [ (split) ] each-with ]
{ } make r> swap [ swap like ] map-with ; inline
: split ( seq separators -- split )
: split ( seq separators -- pieces )
swap [ over member? ] split* nip ;
: drop-prefix ( seq1 seq2 -- seq1 seq2 )
: drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch dup -1 = [ drop 2dup min-length ] when
tuck tail-slice >r tail-slice r> ;

View File

@ -1,123 +1,128 @@
USING: help sequences ;
HELP: head-slice "( seq n -- slice )"
HELP: head-slice
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with the first " { $snippet "n" } " elements of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: tail-slice "( seq n -- slice )"
HELP: tail-slice
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements up to the " { $snippet "n" } "th index of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: head-slice* "( seq n -- slice )"
HELP: head-slice*
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: tail-slice* "( seq n -- slice )"
HELP: tail-slice*
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with the last " { $snippet "n" } " elements of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: subseq "( m n seq -- subseq )"
HELP: subseq
{ $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a sequence" } { "subseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." } ;
HELP: head "( seq n -- headseq )"
HELP: head
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "headseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the first " { $snippet "n" } " elements of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: tail "( seq n -- tailseq )"
HELP: tail
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "tailseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: head* "( seq n -- headseq )"
HELP: head*
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "headseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of all elements of " { $snippet "seq" } " until the " { $snippet "n" } "th element from the end. In other words, it outputs a sequence of the first " { $snippet "l-n" } " elements of the input sequence, where " { $snippet "l" } " is its length." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: tail* "( seq n -- tailseq )"
HELP: tail*
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "tailseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the last " { $snippet "n" } " elements of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: head? "( seq begin -- ? )"
HELP: head?
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " starts with " { $snippet "begin" } ". If " { $snippet "begin" } " is longer than " { $snippet "seq" } ", this word outputs " { $link f } "." } ;
HELP: tail? "( seq end -- ? )"
HELP: tail?
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " ends with " { $snippet "end" } ". If " { $snippet "end" } " is longer than " { $snippet "seq" } ", this word outputs " { $link f } "." } ;
HELP: ?head "( seq begin -- newseq ? )"
HELP: ?head
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " starts with " { $snippet "begin" } ". If there is a match, outputs the subrange of " { $snippet "seq" } " excluding " { $snippet "begin" } ", and " { $link t } ". If there is no match, outputs " { $snippet "seq" } " and " { $link f } "." } ;
HELP: ?tail "( seq end -- newseq ? )"
HELP: ?tail
{ $values { "seq" "a sequence" } { "end" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " ends with " { $snippet "end" } ". If there is a match, outputs the subrange of " { $snippet "seq" } " excluding " { $snippet "begin" } ", and " { $link t } ". If there is no match, outputs " { $snippet "seq" } " and " { $link f } "." } ;
HELP: replace-slice "( new m n seq -- replaced )"
HELP: replace-slice
{ $values { "new" "a sequence" } { "seq" "a sequence" } { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "replaced" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the elements of " { $snippet "seq" } ", with the range from " { $snippet "m" } " to " { $snippet "n" } " replaced by " { $snippet "new" } "." }
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in sequences of the same class as " { $snippet "seq" } "." } ;
HELP: remove-nth "( n seq -- newseq )"
HELP: remove-nth
{ $values { "n" "a non-negative integer" } { "seq" "a sequence" } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence with the same elements as " { $snippet "seq" } " except omitting the " { $snippet "n" } "th element." }
{ $examples
{ $example "2 { + - = * / } remove-nth ." "{ + - * / }" }
} ;
HELP: (cut) "( n seq -- before after )"
HELP: (cut)
{ $values { "n" "a non-negative integer" } { "seq" "a sequence" } { "before" "a sequence" } { "after" "a slice" } }
{ $description "Outputs a pair of sequences, where " { $snippet "before" } " consists of the first " { $snippet "n" } " elements of " { $snippet "seq" } " and has the same type, while " { $snippet "after" } " is a slice of the remaining elements." }
{ $notes "Unlike " { $link cut } ", the run time of this word is proportional to the length of " { $snippet "before" } ", not " { $snippet "after" } ", so it is suitable for use in an iterative algorithm which cuts successive pieces off a sequence." } ;
HELP: cut "( n seq -- before after )"
HELP: cut
{ $values { "n" "a non-negative integer" } { "seq" "a sequence" } { "before" "a sequence" } { "after" "a sequence" } }
{ $description "Outputs a pair of sequences, where " { $snippet "before" } " consists of the first " { $snippet "n" } " elements of " { $snippet "seq" } ", while " { $snippet "after" } " holds the remaining elements. Both output sequences have the same type as " { $snippet "seq" } "." }
{ $notes "Since this word copies the entire tail of the sequence, it should not be used in a loop. If this is important, consider using " { $link (cut) } " instead, since it returns a slice for the tail instead of copying." } ;
HELP: cut* "( n seq -- before after )"
HELP: cut*
{ $values { "n" "a non-negative integer" } { "seq" "a sequence" } { "before" "a sequence" } { "after" "a sequence" } }
{ $description "Outputs a pair of sequences, where " { $snippet "after" } " consists of the last " { $snippet "n" } " elements of " { $snippet "seq" } ", while " { $snippet "before" } " holds the remaining elements. Both output sequences have the same type as " { $snippet "seq" } "." } ;
HELP: group "( seq n -- groups )"
HELP: group
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" "a sequence of sequences" } }
{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." }
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ;
HELP: start* "( subseq seq i -- n )"
HELP: start*
{ $values { "subseq" "a sequence" } { "seq" "a sequence" } { "i" "a start index" } { "n" "a start index" } }
{ $description "Outputs the start index of the first contiguous subsequence equal to " { $snippet "subseq" } ", starting the search from the " { $snippet "i" } "th element. If no matching subsequence is found, outputs -1." } ;
HELP: start "( subseq seq -- n )"
HELP: start
{ $values { "subseq" "a sequence" } { "seq" "a sequence" } { "n" "a start index" } }
{ $description "Outputs the start index of the first contiguous subsequence equal to " { $snippet "subseq" } ", or -1 if no matching subsequence is found." } ;
HELP: subseq? "( subseq seq -- ? )"
HELP: subseq?
{ $values { "subseq" "a sequence" } { "seq" "a sequence" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " contains the elements of " { $snippet "subseq" } " as a contiguous subsequence." } ;
HELP: split1 "( seq subseq -- before after )"
HELP: split1
{ $values { "seq" "a sequence" } { "subseq" "a sequence" } { "before" "a new sequence" } { "after" "a new sequence" } }
{ $description "Splits " { $snippet "seq" } " at the first occurrence of " { $snippet "subseq" } ", and outputs the pieces before and after the split. If " { $snippet "subseq" } " does not occur in " { $snippet "seq" } ", then " { $snippet "before" } " is just " { $snippet "seq" } " and " { $snippet "after" } " is " { $link f } "." } ;
HELP: split "( seq subseq -- pieces )"
HELP: split*
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "pieces" "a new array" } }
{ $description "Splits " { $snippet "seq" } " at each element for which " { $snippet "quot" } " yields a true value, and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
{ $examples { $example "{ 1 2 3 4 5 6 7 8 } [ 3 mod zero? ] split* ." "{ { 1 2 } { 4 5 } { 7 8 } }" } } ;
HELP: split
{ $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } }
{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces." }
{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
{ $examples { $example "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
HELP: drop-prefix "( seq1 seq2 -- slice1 slice2 )"
HELP: drop-prefix
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "slice1" "a slice" } { "slice2" "a slice" } }
{ $description "Outputs a pair of virtual sequences with the common prefix of " { $snippet "seq1" } " and " { $snippet "seq2" } " removed." } ;
HELP: unclip "( seq -- rest first )"
HELP: unclip
{ $values { "seq" "a sequence" } { "rest" "a sequence" } { "first" "an object" } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." }
{ $examples

View File

@ -38,33 +38,30 @@ PREDICATE: integer LETTER CHAR: A CHAR: Z between? ;
PREDICATE: integer digit CHAR: 0 CHAR: 9 between? ;
PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
PREDICATE: integer control "\0\e\r\n\t\u0008\u007f" member? ;
PREDICATE: printable quotable "\"\\" member? not ;
UNION: Letter letter LETTER ;
UNION: alpha Letter digit ;
: ch>lower ( n -- n ) dup LETTER? [ HEX: 20 + ] when ;
: ch>upper ( n -- n ) dup letter? [ HEX: 20 - ] when ;
: >lower ( str -- str ) [ ch>lower ] map ;
: >upper ( str -- str ) [ ch>upper ] map ;
: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ;
: ch>upper ( ch -- lower ) dup letter? [ HEX: 20 - ] when ;
: >lower ( str -- lower ) [ ch>lower ] map ;
: >upper ( str -- upper ) [ ch>upper ] map ;
: quotable? ( ch -- ? )
dup printable? swap "\"\\" member? not and ; foldable
: padding ( string count char -- string )
: padding ( str n ch -- padstr )
>r swap length [-] r> <string> ;
: pad-left ( string count char -- string )
: pad-left ( str n ch -- padded )
pick >r padding r> append ;
: pad-right ( string count char -- string )
: pad-right ( str n ch -- padded )
pick >r padding r> swap append ;
: ch>string ( ch -- str ) 1 swap <string> ;
: >string ( seq -- array )
: >string ( seq -- str )
[ string? ] [ 0 <string> ] >sequence ; inline
M: string thaw drop SBUF" " clone ;
M: string like
drop dup string? [ >string ] unless ;
M: string like drop dup string? [ >string ] unless ;

View File

@ -1,92 +1,91 @@
USING: arrays help kernel kernel-internals sequences strings
vectors ;
HELP: string f
HELP: string
{ $description "The class of fixed-length character strings. See " { $link "syntax-strings" } " for syntax and " { $link "strings" } " for general information." } ;
HELP: char-slot "( n string -- ch )"
HELP: char-slot ( n string -- ch )
{ $values { "n" "a fixnum" } { "string" "a string" } { "ch" "the character at the " { $snippet "n" } "th index" } }
{ $description "Unsafe string accessor, used to define " { $link nth } " on strings." }
{ $warning "This word is in the " { $vocab-link "kernel-internals" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link nth } " instead." } ;
HELP: set-char-slot "( ch n string -- )"
HELP: set-char-slot ( ch n string -- )
{ $values { "ch" "a character" } { "n" "a fixnum" } { "string" "a string" } }
{ $description "Unsafe string mutator, used to define " { $link set-nth } " on strings." }
{ $warning "This word is in the " { $vocab-link "kernel-internals" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link set-nth } " instead." } ;
HELP: <string> "( n ch -- string )"
HELP: <string> ( n ch -- string )
{ $values { "n" "a positive integer specifying string length" } { "elt" "an initial character" } }
{ $description "Creates a new string with the given length and all characters initially set to " { $snippet "ch" } "." }
{ $see-also <array> <quotation> <sbuf> <vector> } ;
HELP: blank? "( ch -- ? )"
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a whitespace character." } ;
HELP: blank
{ $class-description "Class of integers denoting ASCII whitespace characters." } ;
HELP: letter? "( ch -- ? )"
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a lowercase alphabet character." } ;
HELP: letter
{ $class-description "Class of integers denoting lowercase alphabet ASCII characters." } ;
HELP: LETTER? "( ch -- ? )"
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a uppercase alphabet character." } ;
HELP: LETTER
{ $class-description "Class of integers denoting uppercase alphabet ASCII characters." } ;
HELP: digit? "( ch -- ? )"
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a decimal digit character." } ;
HELP: digit
{ $class-description "Class of integers denoting ASCII decimal digit characters." } ;
HELP: printable? "( ch -- ? )"
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a printable ASCII character." } ;
HELP: Letter
{ $class-description "Class of integers denoting ASCII alphabet characters, both upper and lower case." } ;
HELP: control? "( ch -- ? )"
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for an ASCII control character." } ;
HELP: alpha
{ $class-description "Class of integers denoting alphanumeric ASCII characters." } ;
HELP: ch>lower "( ch -- lower )"
HELP: alpha
{ $class-description "Class of integers denoting printable ASCII characters." } ;
HELP: alpha
{ $class-description "Class of integers denoting ASCII control characters." } ;
HELP: alpha
{ $class-description "Class of integers denoting characters which may appear in a Factor string literal without escaping." } ;
HELP: ch>lower
{ $values { "ch" "a character" } { "lower" "a character" } }
{ $description "Converts a character to lowercase." } ;
HELP: ch>upper "( ch -- lower )"
HELP: ch>upper
{ $values { "ch" "a character" } { "lower" "a character" } }
{ $description "Converts a character to uppercase." } ;
HELP: >lower "( str -- lower )"
HELP: >lower
{ $values { "str" "a string" } { "lower" "a string" } }
{ $description "Converts a string to lowercase." } ;
HELP: >upper "( str -- upper )"
HELP: >upper
{ $values { "str" "a string" } { "upper" "a string" } }
{ $description "Converts a string to uppercase." } ;
HELP: quotable? "( ch -- ? )"
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for a character which may appear in a Factor string literal without escaping." } ;
HELP: padding "( str n ch -- padstr )"
HELP: padding
{ $values { "str" "a string" } { "n" "a non-negative integer" } { "ch" "a character"} { "padstr" "a new string" } }
{ $description "Outputs a new string consisting of " { $snippet "ch" } " repeated, that when appended to " { $snippet "str" } ", yields a string of length " { $snippet "n" } ". If the length of { " { $snippet "str" } " is greater than " { $snippet "n" } ", this word outputs the empty string." } ;
HELP: pad-left "( str n ch -- padded )"
HELP: pad-left
{ $values { "str" "a string" } { "n" "a non-negative integer" } { "ch" "a character"} { "padded" "a new string" } }
{ $description "Outputs a new string consisting of " { $snippet "str" } " padded on the left with enough repetitions of " { $snippet "ch" } " to have the result be of length " { $snippet "n" } "." }
{ $examples { $example "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ;
HELP: pad-right "( str n ch -- padded )"
HELP: pad-right
{ $values { "str" "a string" } { "n" "a non-negative integer" } { "ch" "a character"} { "padded" "a new string" } }
{ $description "Outputs a new string consisting of " { $snippet "str" } " padded on the right with enough repetitions of " { $snippet "ch" } " to have the result be of length " { $snippet "n" } "." }
{ $examples { $example "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ;
HELP: ch>string "( ch -- str )"
HELP: ch>string
{ $values { "ch" "a character"} { "str" "a new string" } }
{ $description "Outputs a string of one character." } ;
HELP: >string "( seq -- str )"
HELP: >string
{ $values { "seq" "a sequence of characters" } { "str" "a new string" } }
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than real numbers." }
{ $see-also >array >sbuf >vector >quotation } ;
HELP: resize-string "( n str -- newstr )"
HELP: resize-string ( n str -- newstr )
{ $values { "n" "a non-negative integer" } { "str" "a string" } { "newstr" "a new string" } }
{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\u0000" } "." } ;

View File

@ -31,6 +31,6 @@ M: vector like
IN: kernel
: with-datastack ( stack word -- stack )
: with-datastack ( stack word -- newstack )
datastack >r >r >vector set-datastack r> execute
datastack r> [ push ] keep set-datastack 2nip ;

View File

@ -1,25 +1,25 @@
IN: vectors
USING: arrays help kernel strings ;
HELP: vector f
HELP: vector
{ $description "The class of resizable vectors. See " { $link "syntax-vectors" } " for syntax and " { $link "vectors" } " for general information." } ;
HELP: <vector> "( n -- vector )"
HELP: <vector> ( n -- vector )
{ $values { "n" "a positive integer specifying initial capacity" } { "vector" "a new vector" } }
{ $description "Creates a new vector that can hold " { $snippet "n" } " elements before resizing." }
{ $see-also <array> <string> <sbuf> } ;
HELP: >vector "( seq -- vector )"
HELP: >vector
{ $values { "seq" "a sequence" } { "vector" "a new vector" } }
{ $description "Outputs a freshly-allocated vector with the same elements as a given sequence." } ;
HELP: array>vector "( array -- vector )"
HELP: array>vector ( array -- vector )
{ $values { "array" "an array" } { "vector" "a new vector" } }
{ $description "Creates a new vector using the array for underlying storage. The vector's initial length is the same as that of the array."
$terpri
"This word can be marginally more efficient than " { $link >vector } ", but the sharing of storage can lead to unexpected results." } ;
HELP: with-datastack "( stack word -- newstack )"
HELP: with-datastack
{ $values { "stack" "a sequence" } { "word" "a word" } { "newstack" "a sequence" } }
{ $description "Executes " { $snippet "word" } " with the given data stack contents, and outputs the new data stack after the word returns. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
{ $examples

View File

@ -6,7 +6,8 @@ USING: errors generic kernel math sequences-internals vectors ;
! A reversal of an underlying sequence.
TUPLE: reversed seq ;
: reversed@ reversed-seq [ length swap - 1- ] keep ; inline
: reversed@ ( m reversed -- n seq )
reversed-seq [ length swap - 1- ] keep ; inline
M: reversed length reversed-seq length ;
@ -23,7 +24,7 @@ M: reversed like reversed-seq like ;
M: reversed thaw reversed-seq thaw ;
: reverse ( seq -- seq ) [ <reversed> ] keep like ;
: reverse ( seq -- newseq ) [ <reversed> ] keep like ;
! A slice of another sequence.
TUPLE: slice seq from to ;
@ -39,7 +40,7 @@ TUPLE: slice-error reason ;
length over < [ "end > sequence" slice-error ] when
> [ "start > end" slice-error ] when ;
C: slice ( from to seq -- seq )
C: slice ( m n seq -- slice )
#! A slice of a slice collapses.
>r dup slice? [ collapse-slice ] when r>
>r 3dup check-slice r>
@ -50,7 +51,7 @@ C: slice ( from to seq -- seq )
M: slice length
dup slice-to swap slice-from - ;
: slice@ ( n slice -- n seq )
: slice@ ( m slice -- n seq )
[ slice-from + ] keep slice-seq ; inline
M: slice nth slice@ nth ;

View File

@ -1,6 +1,22 @@
USING: help sequences ;
HELP: slice-error "( str -- )"
HELP: reversed
{ $class-description "A virtual sequence which presents a reversed view of an underlying sequence." }
{ $see-also <reversed> reverse } ;
HELP: reversed@
{ $values { "m" "a non-negative integer" } { "reversed" "an instance of " { $link reversed } } { "n" "a non-negative integer" } { "seq" "a sequence" } }
{ $description "Indexes into a reversed sequence. Helper word used to implement " { $link "sequence-protocol" } " methods for the " { $link reversed } " class." } ;
HELP: reverse
{ $values { "seq" "a sequence" } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence having the same elements as " { $snippet "seq" } " but in reverse order." } ;
HELP: <reversed> ( seq -- reversed )
{ $values { "seq" "a sequence" } { "reversed" "a new sequence" } }
{ $description "Creates an instance of the " { $link reversed } " virtual sequence." } ;
HELP: slice-error
{ $values { "str" "a reason" } }
{ $description "Throws a " { $link slice-error } "." }
{ $error-description "Thrown by " { $link <slice> } " if one of the following invalid conditions holds:"
@ -11,19 +27,15 @@ HELP: slice-error "( str -- )"
}
} ;
HELP: slice f
HELP: slice
{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence." }
{ $see-also <slice> subseq } ;
HELP: <slice> "( m n seq -- slice )"
HELP: <slice>
{ $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a sequence" } { "slice" "a slice" } }
{ $description "Outputs a new virtual sequence sharing storage with the subrange of elements in " { $snippet "seq" } " with indices starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." } ;
HELP: reverse "( seq -- reversed )"
{ $values { "seq" "a sequence" } { "reversed" "a sequence" } }
{ $description "Outputs a new sequence having the same elements as " { $snippet "seq" } " but in reverse order." } ;
HELP: <reversed> "( seq -- reversed )"
{ $values { "seq" "a sequence" } { "reversed" "a sequence" } }
{ $description "Outputs a virtual sequence sharing storage with " { $snippet "seq" } " but with reverse element order." } ;
HELP: slice@
{ $values { "m" "a non-negative integer" } { "slice" "an instance of " { $link slice } } { "n" "a non-negative integer" } { "seq" "a sequence" } }
{ $description "Indexes into a slice. Helper word used to implement " { $link "sequence-protocol" } " methods for the " { $link reversed } " class." } ;

View File

@ -9,7 +9,7 @@ C: alien-callback make-node ;
TUPLE: alien-callback-error ;
: alien-callback ( return parameters quot -- address )
: alien-callback ( return parameters quot -- alien )
<alien-callback-error> throw ;
: callback-bottom ( node -- )

View File

@ -1,10 +1,10 @@
IN: alien
USING: errors help ;
HELP: alien-callback-error "( -- )"
HELP: alien-callback-error
{ $error-description "Thrown when " { $link alien-callback } " is called in the interpreter. Words using " { $link alien-callback } " must be compiled first, and all three inputs to " { $link alien-callback } " must be literals." } ;
HELP: alien-callback "( return parameters quot -- alien )"
HELP: alien-callback
{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "quot" "a quotation" } { "alien" "an alien address" } }
{ $description
"Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned."

View File

@ -1,16 +1,16 @@
IN: alien
USING: help ;
HELP: alien-invoke-error "( -- )"
HELP: alien-invoke-error
{ $error-description "Thrown when " { $link alien-invoke } " is called in the interpreter. Words using " { $link alien-invoke } " must be compiled first, and all four inputs to " { $link alien-invoke } " must be literals." } ;
HELP: alien-invoke "( ... return library function parameters -- ... )"
HELP: alien-invoke
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected." }
{ $errors "Throws an " { $link alien-invoke-error } " if the word calling " { $link alien-invoke } " is not compiled." }
{ $see-also alien-callback } ;
HELP: define-c-word "( return library function parameters -- )"
HELP: define-c-word
{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;

View File

@ -21,7 +21,7 @@ M: alien equal?
global [ "libraries" nest drop ] bind
: library ( name -- object ) "libraries" get hash ;
: library ( name -- library ) "libraries" get hash ;
: load-library ( name -- dll )
library dup [
@ -32,7 +32,7 @@ global [ "libraries" nest drop ] bind
] bind
] when ;
: add-library ( library name abi -- )
: add-library ( name path abi -- )
"libraries" get [
[ "abi" set "name" set ] make-hash swap set
] bind ;

View File

@ -1,19 +1,19 @@
IN: alien
USING: help ;
HELP: alien f
{ $description "The class of alien pointers. See " { $link "syntax-aliens" } " for syntax and " { $link "c-objects" } " for general information." } ;
HELP: alien
{ $class-description "The class of alien pointers. See " { $link "syntax-aliens" } " for syntax and " { $link "c-objects" } " for general information." } ;
HELP: dll f
{ $description "The class of native library handles. See " { $link "dll-internals" } " for syntax and " { $link "c-objects" } " for general information." } ;
HELP: dll
{ $class-description "The class of native library handles. See " { $link "dll-internals" } " for syntax and " { $link "c-objects" } " for general information." } ;
HELP: expired? "( c-ptr -- ? )"
HELP: expired? ( c-ptr -- ? )
{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
{ $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired."
$terpri
"A byte array is never considered to be expired, whereas passing " { $link f } " always yields true." } ;
HELP: <displaced-alien> "( displacement c-ptr -- alien )"
HELP: <displaced-alien> ( displacement c-ptr -- alien )
{ $values { "displacement" "an integer" } { "c-ptr" "an alien, byte array, or " { $link f } } { "alien" "a new alien" } }
{ $description "Creates a new alien address object, wrapping a raw memory address. The alien points to a location in memory which is offset by " { $snippet "displacement" } " from the address of " { $snippet "c-ptr" } "." }
{ $notes "Passing a value of " { $link f } " for " { $snippet "c-ptr" } " creates an alien with an absolute address; this is how " { $link <alien> } " is implemented."
@ -21,21 +21,21 @@ $terpri
"Passing a zero absolute address does not construct a new alien object, but instead makes the word output " { $link f } "." }
{ $see-also <alien> alien-address } ;
HELP: alien-address "( c-ptr -- addr )"
HELP: alien-address ( c-ptr -- addr )
{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "addr" "a non-negative integer" } }
{ $description "Outputs the address of an alien." }
{ $warning "Taking the address of a byte array is not safe. The byte array can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ;
HELP: <alien> "( address -- alien )"
HELP: <alien>
{ $values { "address" "a non-negative integer" } { "alien" "a new alien address" } }
{ $description "Creates an alien object, wrapping a raw memory address." }
{ $notes "Alien objects are invalidated between image saves and loads." }
{ $see-also <displaced-alien> alien-address } ;
HELP: c-ptr f
{ $description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
HELP: c-ptr
{ $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
HELP: library "( name -- library )"
HELP: library
{ $values { "name" "a string" } { "library" "a hashtable" } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
@ -45,27 +45,27 @@ HELP: library "( name -- library )"
}
} ;
HELP: dlopen "( path -- dll )"
HELP: dlopen ( path -- dll )
{ $values { "path" "a path name string" } { "dll" "a DLL handle" } }
{ $description "Opens a native library and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." }
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." }
{ $notes "This is the low-level facility used to implement " { $link load-library } ". Use the latter instead." } ;
HELP: dlsym "( name dll -- alien )"
HELP: dlsym ( name dll -- alien )
{ $values { "name" "a C symbol name" } { "dll" "a DLL handle" } { "alien" "an alien pointer" } }
{ $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable." }
{ $errors "Throws an error if the symbol could not be found." } ;
HELP: dlclose "( dll -- )"
HELP: dlclose ( dll -- )
{ $values { "dll" "a DLL handle" } }
{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
HELP: load-library "( name -- dll )"
HELP: load-library
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
HELP: add-library "( name path abi -- )"
HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
{ $examples { $code "\"gif\" \"libgif.so\" \"cdecl\" add-library" } } ;

View File

@ -15,9 +15,11 @@ parser sequences strings words ;
SYMBOL: c-types
TUPLE: no-c-type name ;
: no-c-type ( type -- * ) <no-c-type> throw ;
: c-type ( name -- type )
dup c-types get hash
[ ] [ "No such C type: " swap append throw ] ?if ;
dup c-types get hash [ ] [ no-c-type ] ?if ;
: c-size ( name -- size ) "width" swap c-type hash ;
@ -31,15 +33,15 @@ SYMBOL: c-types
>r <c-type> [ swap bind ] keep r> c-types get set-hash ;
inline
: <c-array> ( size type -- c-ptr )
: <c-array> ( n type -- array )
global [ c-size * <byte-array> ] bind ;
: <c-object> ( type -- c-ptr ) 1 swap <c-array> ;
: <c-object> ( type -- array ) 1 swap <c-array> ;
: <malloc-array> ( size type -- malloc-ptr )
: <malloc-array> ( n type -- alien )
global [ c-size calloc ] bind check-ptr ;
: <malloc-object> ( type -- malloc-ptr ) 1 swap <malloc-array> ;
: <malloc-object> ( type -- alien ) 1 swap <malloc-array> ;
: <malloc-string> ( string -- alien )
"\0" append dup length malloc check-ptr

View File

@ -1,122 +1,131 @@
IN: alien
USING: help libc ;
HELP: c-type "( name -- type )"
HELP: <c-type> "( -- type )"
{ $values { "type" "a hashtable" } }
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-types" } "." } ;
HELP: no-c-type
{ $values { "type" "a string" } }
{ $description "Throws a " { $link no-c-type } " error." }
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
HELP: c-type
{ $values { "name" "a string" } { "type" "a hashtable" } }
{ $description "Looks up a C type by name." }
{ $errors "Throws an error if the type does not exist." } ;
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-size "( name -- size )"
HELP: c-size
{ $values { "name" "a string" } { "size" "an integer" } }
{ $description "Outputs the number of bytes taken up by this C type." }
{ $examples
"On a 32-bit system, you will get the following output:"
{ $example "USE: alien\n\"void*\" c-size ." "4" }
}
{ $errors "Throws an error if the type does not exist." } ;
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-align "( name -- n )"
{ $values { "name" "a string" } { "n" "an integer" } }
HELP: c-align
{ $values { "name" "a string" } { "align" "an integer" } }
{ $description "Outputs alignment at which values of this C type are padded in C structures." }
{ $errors "Throws an error if the type does not exist." } ;
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-getter "( name -- quot )"
HELP: c-getter
{ $values { "name" "a string" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-setter "( name -- quot )"
HELP: c-setter
{ $values { "name" "a string" } { "quot" "a quotation with stack effect " { $snippet "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
HELP: <c-array> "( n type -- array )"
HELP: <c-array>
{ $values { "n" "a non-negative integer" } { "type" "a string" } { "array" "a byte array" } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
{ $errors "Throws an error if the type does not exist or the requested size is negative." }
{ $see-also <malloc-array> } ;
HELP: <c-object> "( type -- array )"
HELP: <c-object>
{ $values { "type" "a string" } { "array" "a byte array" } }
{ $description "Creates a byte array suitable for holding a value with the given C type." }
{ $errors "Throws an error if the type does not exist." }
{ $see-also <malloc-object> } ;
HELP: string>char-alien "( string -- array )"
HELP: string>char-alien ( string -- array )
{ $values { "string" "a string" } { "array" "a byte array" } }
{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." }
{ $see-also alien>char-string <malloc-string> } ;
HELP: alien>char-string "( c-ptr -- string )"
HELP: alien>char-string ( c-ptr -- string )
{ $values { "c-ptr" "an alien, byte array or " { $link f } } { "string" "a string" } }
{ $description "Reads a null-terminated 8-bit C string from the specified address." }
{ $see-also string>char-alien } ;
HELP: string>u16-alien "( string -- array )"
HELP: string>u16-alien ( string -- array )
{ $values { "string" "a string" } { "array" "a byte array" } }
{ $description "Copies the string to a new byte array in UTF16 format with a trailing null byte." }
{ $errors "Throws an error if the string contains null characters." }
{ $see-also alien>u16-string } ;
HELP: alien>u16-string "( c-ptr -- string )"
HELP: alien>u16-string ( c-ptr -- string )
{ $values { "c-ptr" "an alien, byte array or " { $link f } } { "string" "a string" } }
{ $description "Reads a null-terminated UTF16 string from the specified address." }
{ $see-also string>u16-alien } ;
HELP: <malloc-array> "( n type -- alien )"
HELP: <malloc-array>
{ $values { "n" "a non-negative integer" } { "type" "a string" } { "alien" "an alien address" } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." }
{ $see-also <c-array> } ;
HELP: <malloc-object> "( type -- alien )"
HELP: <malloc-object>
{ $values { "type" "a string" } { "alien" "an alien address" } }
{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist or if memory allocation fails." }
{ $see-also <c-object> } ;
HELP: <malloc-string> "( string -- alien )"
HELP: <malloc-string>
{ $values { "string" "a string" } { "alien" "an alien address" } }
{ $description "Copies a string to an unmanaged memory block large enough to hold a copy of the string in 8-bit ASCII encoding, with a trailing null byte." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." }
{ $see-also string>char-alien } ;
HELP: (typedef) "( old new -- )"
HELP: (typedef)
{ $values { "old" "a string" } { "new" "a string" } }
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }
{ $see-also typedef POSTPONE: TYPEDEF: } ;
HELP: define-pointer "( type -- )"
HELP: define-pointer
{ $values { "type" "a string" } }
{ $description "Aliases the C type " { $snippet "type*" } " to " { $snippet "void*" } "." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: define-deref "( name vocab -- )"
HELP: define-deref
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: define-nth "( name vocab -- )"
HELP: define-nth
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: define-set-nth "( name vocab -- )"
HELP: define-set-nth
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: define-out "( name vocab -- )"
HELP: define-out
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: typedef "( old new -- )"
HELP: typedef
{ $values { "old" "a string" } { "new" "a string" } }
{ $description "Alises the C types " { $snippet "old" } " and " { $snippet "old*" } " under the names " { $snippet "new" } " and " { $snippet "new*" } ", respectively." }
{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }

View File

@ -11,7 +11,7 @@ FUNCTION: void* realloc ( void* ptr, ulong size ) ;
FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
TUPLE: check-ptr ;
: check-ptr [ <check-ptr> throw ] unless* ;
: check-ptr ( c-ptr -- c-ptr ) [ <check-ptr> throw ] unless* ;
: with-malloc ( size quot -- )
swap 1 calloc check-ptr [ swap call ] keep free ; inline

View File

@ -1,37 +1,41 @@
IN: libc
USING: help ;
HELP: malloc "( size -- alien )"
HELP: malloc ( size -- alien )
{ $values { "size" "a non-negative integer" } { "alien" "an alien address" } }
{ $description "Allocates a block of " { $snippet "size" } " bytes from the operating system. The contents of the block are undefined."
$terpri
"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
HELP: calloc "( count size -- alien )"
HELP: calloc ( count size -- alien )
{ $values { "count" "a non-negative integer" } { "size" "a non-negative integer" } { "alien" "an alien address" } }
{ $description "Allocates a block of " { $snippet "count * size" } " bytes from the operating system. The contents of the block are initially zero."
$terpri
"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
HELP: realloc "( alien size -- newalien )"
HELP: realloc ( alien size -- newalien )
{ $values { "alien" "an alien address" } { "size" "a non-negative integer" } { "newalien" "an alien address" } }
{ $description "Allocates a new block of " { $snippet "size" } " bytes from the operating system. The contents of " { $snippet "alien" } ", which itself must be a block previously returned by " { $link malloc } " or " { $link realloc } ", are copied into the new block, and the old block is freed."
$terpri
"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } ;
HELP: memcpy "( dst src size -- newalien )"
HELP: memcpy ( dst src size -- newalien )
{ $values { "dst" "an alien address" } { "src" "an alien address" } { "size" "a non-negative integer" } }
{ $description "Copies " { $snippet "size" } " bytes from " { $snippet "src" } " to " { $snippet "dst" } "." }
{ $warning "As per the BSD C library documentation, the behavior is undefined if the source and destination overlap." } ;
HELP: check-ptr "( c-ptr -- checked )"
HELP: check-ptr
{ $values { "c-ptr" "an alien address, byte array, or " { $link f } } { "checked" "an alien address or byte array with non-zero address" } }
{ $description "Throws an error if the input is " { $link f } ". Otherwise the object remains on the data stack. This word should be used to check the return values of " { $link malloc } " and " { $link realloc } " before use." }
{ $error-description "Thrown by " { $link malloc } " and " { $link realloc } " to indicate a memory allocation failure." } ;
{ $error-description "Callers of " { $link malloc } " and " { $link realloc } " should use " { $link check-ptr } " to throw an error in the case of a memory allocation failure." } ;
HELP: free "( ptr -- )"
HELP: free ( ptr -- )
{ $values { "ptr" "an alien address" } }
{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
HELP: with-malloc
{ $values { "n" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } }
{ $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ;

View File

@ -1,6 +1,6 @@
IN: alien
USING: help ;
HELP: c-struct? "( type -- ? )"
HELP: c-struct?
{ $values { "type" "a string" } { "?" "a boolean" } }
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: BEGIN-STRUCT: } "." } ;

View File

@ -19,7 +19,7 @@ words ;
: try-compile ( word -- )
[ compile ] [ error. update-xt ] recover ;
: compile-vocabs ( vocabs -- )
: compile-vocabs ( seq -- )
[ words ] map concat
dup [ f "no-effect" set-word-prop ] each
[ try-compile ] each ;

View File

@ -1,40 +1,39 @@
IN: compiler
USING: assembler help words ;
HELP: compiled? "( word -- ? )"
HELP: compiled? ( word -- ? )
{ $values { "word" "a word" } }
{ $description "Tests if a word is compiled." }
{ $notes "Primitives are considered as compiled words." } ;
{ $description "Tests if a word is compiled." } ;
HELP: compile "( word -- )"
HELP: compile
{ $values { "word" "a word" } }
{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." }
{ $errors "If compilation fails, this word can throw an error. In particular, if the word's stack effect cannot be inferred, this word will throw an error. The related " { $link try-compile } " word logs errors and returns rather than throwing." } ;
HELP: try-compile "( word -- )"
HELP: try-compile
{ $values { "word" "a word" } }
{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." }
{ $errors "If compilation fails, this word logs the error to the default stream and returns normally." } ;
HELP: compile-vocabs "( seq -- )"
HELP: compile-vocabs
{ $values { "seq" "a sequence of strings" } }
{ $description "Compiles all words in the vocabularies named by elements of a sequence, skipping compiled words. Compile errors are logged to the default stream." } ;
HELP: compile-all "( -- )"
HELP: compile-all
{ $description "Compile all words in the dictionary which have not already been compiled. Compile errors are logged to the default stream." } ;
HELP: compile-quot "( quot -- word )"
HELP: compile-quot
{ $values { "quot" "a quotation" } { "word" "a new, uninterned word" } }
{ $description "Creates a new uninterned word having the given quotation as its definition, and compiles it. The returned word can be passed to " { $link execute } "." }
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
HELP: compile-1 "( quot -- )"
HELP: compile-1
{ $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." }
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
IN: assembler
HELP: finalize-compile "( xts -- )"
HELP: finalize-compile ( xts -- )
{ $values { "xts" "an array of pairs mapping words to XTs" } }
{ $description "Flushes the CPUs instruction cache on PowerPC, and does nothing on other architectures. PowerPC CPUs do not automatically invalidate the cache when memory contents change, so the compiler must do this explicitly." } ;
{ $description "Performs relocation, atomically changes the XT of all given words, and on PowerPC, flushes the CPU instruction cache." } ;

View File

@ -1,7 +1,7 @@
IN: inference
USING: help kernel ;
HELP: inference-error "( msg -- )"
HELP: inference-error
{ $values { "msg" "an object" } }
{ $description "Throws an " { $link inference-error } "." }
{ $error-description
@ -14,7 +14,7 @@ HELP: inference-error "( msg -- )"
"Words without a static stack effect cannot be compiled, but will still run in the interpreter."
} ;
HELP: infer "( quot -- effect )"
HELP: infer
{ $values { "quot" "a quotation" } { "effect" "a pair of integers" } }
{ $description "Attempts to infer the quotation's stack effect, outputting a pair holding the correct of data stack inputs and outputs for the quotation." }
{ $errors "Throws an error if stack effect inference fails." } ;

View File

@ -36,7 +36,7 @@ words ;
: will-inline-method ( node -- quot/t )
#! t indicates failure
dup inlining-class dup
[ swap node-param method ] [ 2drop t ] if ;
[ swap node-param method method-def ] [ 2drop t ] if ;
: inline-standard-method ( node -- node )
dup will-inline-method (inline-method) ;

View File

@ -5,16 +5,16 @@ USING: arrays definitions errors hashtables kernel
kernel-internals namespaces sequences strings words
vectors math parser ;
PREDICATE: word class "class" word-prop ;
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
: classes ( -- list ) [ class? ] word-subset ;
: classes ( -- seq ) [ class? ] word-subset ;
SYMBOL: typemap
SYMBOL: builtins
: type>class ( n -- symbol ) builtins get nth ;
: type>class ( n -- class ) builtins get nth ;
: predicate-word ( word -- word )
: predicate-word ( word -- predicate )
word-name "?" append create-in ;
: predicate-effect 1 1 <effect> ;
@ -29,14 +29,14 @@ SYMBOL: builtins
3drop
] if ;
: superclass "superclass" word-prop ;
: superclass ( class -- super ) "superclass" word-prop ;
: members "members" word-prop ;
: (flatten-class) ( class -- )
dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
: flatten-class ( class -- classes )
: flatten-class ( class -- seq )
[ (flatten-class) ] make-hash ;
: (types) ( class -- )
@ -45,7 +45,7 @@ SYMBOL: builtins
[ (types) ] [ "type" word-prop dup set ] ?if
] hash-each ;
: types ( class -- types )
: types ( class -- seq )
[ (types) ] make-hash hash-keys natural-sort ;
DEFER: (class<)
@ -60,7 +60,7 @@ DEFER: (class<)
: class-empty? ( class -- ? )
members dup [ empty? ] when ;
: (class<) ( cls1 cls2 -- ? )
: (class<) ( class1 class2 -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over class-empty? ] [ 2drop t ] }
@ -71,7 +71,7 @@ DEFER: (class<)
SYMBOL: class<cache
: class< ( cls1 cls2 -- ? )
: class< ( class1 class2 -- ? )
class<cache get [ hash hash-member? ] [ (class<) ] if* ;
: smaller-classes ( class seq -- )
@ -86,18 +86,19 @@ SYMBOL: class<cache
[ make-class<cache class<cache set call ] with-scope ;
inline
: class-compare ( cls1 cls2 -- -1/0/1 )
: class-compare ( class1 class2 -- n )
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
: lookup-union ( class-set -- class )
: lookup-union ( classes -- class )
typemap get hash [ object ] unless* ;
: types* ( class -- hash ) types [ type>class dup ] map>hash ;
: types* ( class -- classes )
types [ type>class dup ] map>hash ;
: (class-or) ( class class -- class )
[ types* ] 2apply hash-union lookup-union ;
: class-or ( class class -- class )
: class-or ( class1 class2 -- class )
{
{ [ 2dup class< ] [ nip ] }
{ [ 2dup swap class< ] [ drop ] }
@ -107,14 +108,14 @@ SYMBOL: class<cache
: (class-and) ( class class -- class )
[ types* ] 2apply hash-intersect lookup-union ;
: class-and ( class class -- class )
: class-and ( class1 class2 -- class )
{
{ [ 2dup class< ] [ drop ] }
{ [ 2dup swap class< ] [ nip ] }
{ [ t ] [ (class-and) ] }
} cond ;
: classes-intersect? ( class class -- ? )
: classes-intersect? ( class1 class2 -- ? )
class-and class-empty? not ;
: min-class ( class seq -- class/f )
@ -139,7 +140,7 @@ SYMBOL: class<cache
PREDICATE: class predicate "definition" word-prop ;
! Union classes for dispatch on multiple classes.
: union-predicate ( members -- list )
: union-predicate ( seq -- quot )
[ dup ] swap [ "predicate" word-prop append ] map-with
[ [ drop t ] 2array ] map [ drop f ] swap alist>quot ;

View File

@ -1,34 +1,37 @@
USING: generic help kernel kernel-internals ;
HELP: typemap f
HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
HELP: typemap
{ $description "Global variable. Hashtable mapping unions to class words." }
{ $see-also class-and } ;
HELP: builtins f
HELP: builtins
{ $description "Global variable. Vector mapping type numbers to builtin class words." } ;
HELP: object f
HELP: object
{ $description
"The class of all objects. If a generic word defines a method specializing on this class, the method is used as a fallback, if no other applicable method is found. For instance:"
{ $code "GENERIC: enclose" "M: number enclose 1array ;" "M: object enclose ;" }
} ;
HELP: null f
HELP: null
{ $description
"The canonical empty class with no instances."
} ;
HELP: type>class "( n -- class )"
HELP: type>class
{ $values { "n" "a non-negative integer" } { "class" "a class word" } }
{ $description "Outputs a builtin class whose instances are precisely those of a builtin type." }
{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
HELP: predicate-word "( word -- predicate )"
HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes \"?\" to the name of " { $snippet "word" } " and creates a word with that name in the current vocabulary." } ;
HELP: define-predicate "( class predicate quot -- )"
HELP: define-predicate
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "quot" "a quotation" } }
{ $description
"Defines a predicate word. This is identical to a compound definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that two word properties are set:"
@ -40,7 +43,7 @@ HELP: define-predicate "( class predicate quot -- )"
}
$low-level-note ;
HELP: superclass "( class -- super )"
HELP: superclass
{ $values { "class" "a class word" } { "super" "a class word" } }
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
{ $notes "If " { $link class< } " yields that one class is a subtype of another, it does not imply that a superclass relation is involved. The superclass relation is a technical implementation detail of predicate classes (see " { $link POSTPONE: PREDICATE: } ").." } ;
@ -49,95 +52,88 @@ HELP: members "( class -- seq )"
{ $values { "class" "a class word" } { "seq" "a sequence of union members, or " { $link f } } }
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of members, otherwise outputs " { $link f } "." } ;
HELP: flatten-class "( class -- seq )"
HELP: flatten-class
{ $values { "class" "a class word" } { "seq" "a sequence of classes" } }
{ $description "Outputs a sequence of classes whose union is the given class. Unless the given class is a union class, the output is just a singleton sequence consisting of the given class." } ;
HELP: types "( class -- seq )"
HELP: types
{ $values { "class" "a class word" } { "seq" "a sequence of integers" } }
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
HELP: class-empty? "( class -- ? )"
HELP: class-empty?
{ $values { "class" "a class" } }
{ $description "Tests if a class is a union class with no members." }
{ $examples { $example "null class-empty? ." "t" } } ;
HELP: class< "( class1 class2 -- ? )"
HELP: class<
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: class-compare "( class1 class2 -- n )"
HELP: make-class<cache
{ $values { "hash" "a hashtable" } }
{ $description "Constructs a hashtable mapping classes to hashtables of classes which are smaller than them under " { $link class< } "." }
{ $notes "This word should not be called directly. Instead, use " { $link with-class<cache } "." } ;
HELP: with-class<cache
{ $values { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope where the " { $link class<cache } " variable is bound to a hashtable output by " { $link make-class<cache } ". When this variable is bound, " { $link class< } " can be performed much more quickly than usual." }
{ $notes "Calls to compile large numbers of words can be wrapped in this combinator to reduce compile time." } ;
HELP: class-compare
{ $values { "class1" "a class" } { "class2" "a class" } { "n" "an integer" } }
{ $description "Compares two classes, with the sign of the result indicating their sort order." }
{ $notes "This word is used to sort sequences of classes." }
{ $see-also methods order } ;
HELP: ?make-generic "( word -- )"
{ $values { "word" "a generic word" } }
{ $description "Regenerates the definition of a generic word, unless bootstrap is in progress, in which case nothing is done. This avoids regenerating generic words multiple times during bootstrap as methods are defined. Instead, all generic words are built once at the end of the process, resulting in a performance improvement." }
$low-level-note ;
HELP: lookup-union
{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" "a class word" } }
{ $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." }
{ $see-also "unions" class-and class-or } ;
HELP: init-methods "( word -- )"
{ $values { "word" "a word" } }
{ $description "Prepare to define a generic word." } ;
HELP: define-generic* "( word combination -- )"
{ $values { "word" "a word" } { "combination" "a quotation with stack effect " { $snippet "( word -- quot )" } } }
{ $description "Defines a generic word with the specified method combination. If the word is already a generic word, existing methods are retained." }
{ $see-also POSTPONE: G: define-generic } ;
HELP: lookup-union "( classes -- class )"
{ $values { "classes" "a hashtable where keys are classes and values equal keys" } { "class" "a class word" } }
{ $description "Outputs a class that is the union of the given classes. If no precise match is found, outputs " { $link object } ", even if the given set is not an exhaustive cover all classes." } ;
HELP: types* "( class -- classes )"
{ $values { "class" "a class word" } { "classes" "a hashtable where keys are classes and values equal keys" } }
HELP: types*
{ $values { "class" "a class word" } { "classes" "a hashtable mapping class words to themselves" } }
{ $description "Outputs a sequence of builtin classes whose instances can possibly be instances of the given class." } ;
HELP: class-or "( class1 class2 -- class )"
HELP: class-or
{ $values { "class1" "a class word" } { "class2" "a class word" } { "class" "a class word" } }
{ $description "Outputs a class whose instances are instances of either one of the two input classes. If the union is non-empty but no class with those members is defined, outputs " { $link object } "." } ;
HELP: class-and "( class1 class2 -- class )"
HELP: class-and
{ $values { "class1" "a class word" } { "class2" "a class word" } { "class" "a class word" } }
{ $description "Outputs a class whose instances are instances of both input classes. If the intersection is non-empty but no class with those members is defined, outputs " { $link object } ". If the intersection is empty, outputs " { $link null } "." } ;
HELP: classes-intersect? "( class1 class2 -- ? )"
HELP: classes-intersect?
{ $values { "class1" "a class word" } { "class2" "a class word" } { "?" "a boolean" } }
{ $description "Tests if two classes have a non-empty intersection." } ;
HELP: min-class "( class seq -- class/f )"
HELP: min-class
{ $values { "class" "a class word" } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
HELP: define-class "( class -- )"
HELP: define-class
{ $values { "class" "a class word" } }
{ $description "Sets a property indicating this is a class word, and registers the class in the global union lookup map." }
$low-level-note ;
HELP: classes "( -- seq )"
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
HELP: define-predicate-class "( class predicate definition -- )"
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
{ $description "Defines a predicate class. The superclass of " { $snippet "class" } " must already be set." }
{ $see-also POSTPONE: PREDICATE: } ;
HELP: predicate f
{ $description "The class of predicate class words." }
{ $see-also POSTPONE: PREDICATE: } ;
HELP: predicate
{ $class-description "The class of predicate class words." }
{ $see-also "predicates" POSTPONE: PREDICATE: } ;
HELP: union-predicate "( seq -- quot )"
HELP: union-predicate
{ $values { "seq" "a sequence of class words" } { "quot" "a quotation with stack effect " { $snippet "( object -- ? )" } } }
{ $description "Outputs a quotation for testing of an object is an instance of one of the given classes." } ;
HELP: define-union "( class predicate members -- )"
HELP: define-union
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "members" "a sequence of class words" } }
{ $description "Defines a union class with specified members." }
{ $see-also POSTPONE: UNION: } ;
HELP: union f
{ $description "The class of union class words." }
{ $see-also POSTPONE: UNION: } ;
HELP: union
{ $class-description "The class of union class words." }
{ $see-also "unions" POSTPONE: UNION: } ;

View File

@ -1,19 +1,25 @@
IN: generic
USING: help ;
HELP: methods "( word -- alist )"
{ $values { "word" "a generic word" } { "alist" "a sequence of pairs" } }
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation." } ;
HELP: generic
{ $class-description "The class of generic words." }
{ $see-also "generic" POSTPONE: GENERIC: POSTPONE: G: } ;
HELP: order "( word -- classes )"
{ $values { "word" "a generic word" } { "classes" "a sequence of classes" } }
{ $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
HELP: generic f
{ $description "The class of generic words." }
{ $see-also POSTPONE: GENERIC: POSTPONE: G: } ;
HELP: make-generic "( word -- )"
HELP: make-generic
{ $values { "word" "a generic word" } }
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
$low-level-note ;
HELP: ?make-generic
{ $values { "word" "a generic word" } }
{ $description "Regenerates the definition of a generic word, unless bootstrap is in progress, in which case nothing is done. This avoids regenerating generic words multiple times during bootstrap as methods are defined. Instead, all generic words are built once at the end of the process, resulting in a performance improvement." }
$low-level-note ;
HELP: init-methods
{ $values { "word" "a word" } }
{ $description "Prepare to define a generic word." } ;
HELP: define-generic*
{ $values { "word" "a word" } { "combination" "a quotation with stack effect " { $snippet "( word -- quot )" } } }
{ $description "Defines a generic word with the specified method combination. If the word is already a generic word, existing methods are retained." }
{ $see-also POSTPONE: G: define-generic } ;

View File

@ -1,20 +1,14 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: generic
USING: arrays errors generic hashtables kernel kernel-internals
math namespaces sequences words ;
! Math combination for generic dyadic upgrading arithmetic.
: math-class? ( object -- ? )
dup word? [
PREDICATE: class math-class ( object -- ? )
dup null bootstrap-word eq? [
drop f
] [
number bootstrap-word class<
] if
] [
drop f
] if ;
: math-class-compare ( class class -- n )
@ -33,7 +27,7 @@ math namespaces sequences words ;
"coercer" word-prop [ [ ] ] unless*
] if ;
: math-upgrade ( left right -- quot )
: math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep
>r over r> (math-upgrade)
>r (math-upgrade) dup empty? [ 1 make-dip ] unless
@ -50,7 +44,7 @@ TUPLE: no-math-method left right generic ;
: object-method ( generic -- quot )
object bootstrap-word applicable-method ;
: math-method ( word left right -- quot )
: math-method ( word class1 class2 -- quot )
2dup and [
2dup math-upgrade >r
math-class-max over order min-class applicable-method

View File

@ -1,28 +1,25 @@
USING: generic help math ;
HELP: math-upgrade "( class1 class2 -- quot )"
HELP: math-upgrade
{ $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
{ $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." }
{ $examples { $example "fixnum bignum math-upgrade ." "[ >r >bignum r> ]" } } ;
HELP: no-math-method "( left right generic -- )"
HELP: no-math-method
{ $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } }
{ $description "Throws a " { $link no-math-method } " error." }
{ $error-description "Thrown by generic words using the " { $link math-combination } " method combination if there is no suitable method defined for the two inputs." } ;
HELP: math-method "( word class1 class2 -- quot )"
HELP: math-method
{ $values { "word" "a generic word" } { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation" } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
{ $examples { $example "\\ + fixnum float math-method ." "[ >r >float r> float+ ]" } } ;
HELP: math-class? "( object -- ? )"
HELP: math-class
{ $values { "object" "an object" } { "?" "a boolean" } }
{ $description
"Tests if the object is a numerical class word. The numerical classes are precisely the following:"
{ $list { $link fixnum } { $link bignum } { $link ratio } { $link float } { $link complex } }
} ;
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
HELP: math-combination "( word -- quot )"
HELP: math-combination
{ $values { "word" "a generic word" } { "quot" "a quotation" } }
{ $description "Generates a double-dispatching word definition. Only methods defined on numerical classes and " { $link object } " take effect in the math combination. Methods defined on numerical classes are guaranteed to have their two inputs upgraded to the highest priority type of the two."
$terpri
@ -39,5 +36,6 @@ $terpri
}
"The math combination performs numerical upgrading as described in " { $link "number-protocol" } "." } ;
HELP: 2generic f
{ $description "The class of generic words with the math combination." } ;
HELP: 2generic
{ $class-description "The class of generic words using " { $link math-combination } "." }
{ $see-also POSTPONE: G: } ;

View File

@ -18,15 +18,15 @@ M: f method-loc ;
M: quotation method-def ;
M: quotation method-loc drop f ;
: method ( class generic -- quot )
"methods" word-prop hash method-def ;
: method ( class generic -- method/f )
"methods" word-prop hash ;
: methods ( generic -- alist )
: methods ( generic -- assoc )
"methods" word-prop hash>alist
[ [ first ] 2apply class-compare ] sort
[ first2 method-def 2array ] map ;
: order ( generic -- list )
: order ( generic -- seq )
"methods" word-prop hash-keys [ class-compare ] sort ;
TUPLE: check-method class generic ;
@ -43,12 +43,11 @@ TUPLE: check-method class generic ;
>r bootstrap-word r> check-method
[ set-hash ] with-methods ;
: implementors ( class -- list )
: implementors ( class -- seq )
[ "methods" word-prop ?hash* nip ] word-subset-with ;
M: method-spec where
dup first2 "methods" word-prop hash method-loc
[ ] [ second where ] ?if ;
dup first2 method method-loc [ ] [ second where ] ?if ;
M: method-spec subdefs drop f ;

View File

@ -1,20 +1,43 @@
IN: generic
USING: help ;
HELP: check-method "( class generic -- class generic )"
HELP: method-spec
{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
HELP: method
{ $values { "class" "a class word" } { "generic" "a generic word" } { "method" "an instance of " { $link method } } }
{ $description "Looks up a method definition." }
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." }
{ $see-also method-def method-loc define-method POSTPONE: M: } ;
HELP: <method> ( def loc -- method )
{ $values { "def" "a quotation" } { "loc" "a file/line pair or " { $link f } } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ;
HELP: methods
{ $values { "word" "a generic word" } { "assoc" "a sequence of pairs" } }
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation." } ;
HELP: order
{ $values { "word" "a generic word" } { "seq" "a sequence of classes" } }
{ $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
HELP: check-method
{ $values { "class" "a class word" } { "generic" "a generic word" } }
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
HELP: with-methods "( word quot -- )"
HELP: with-methods
{ $values { "word" "a generic word" } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
HELP: define-method "( quot class generic -- )"
{ $values { "quot" "a quotation" } { "class" "a class word" } { "generic" "a generic word" } }
{ $description "Defines a method on " { $snippet "generic" } " associating " { $snippet "class" } " with " { $snippet "quot" } "." } ;
HELP: define-method
{ $values { "method" "an instance of " { $link method } } { "class" "a class word" } { "generic" "a generic word" } }
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
{ $see-also <method> } ;
HELP: implementors "( class -- seq )"
HELP: implementors
{ $values { "class" "a class word" } { "seq" "a sequence of generic words" } }
{ $description "Finds all generic words in the dictionary implementing methods for this class." } ;

View File

@ -5,13 +5,13 @@ IN: generic
USING: arrays kernel kernel-internals math namespaces
parser sequences strings words ;
: define-typecheck ( class generic def -- )
: define-typecheck ( class generic quot -- )
over define-generic -rot define-method ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
: reader-effect 1 1 <effect> ; inline
: reader-effect ( -- effect ) 1 1 <effect> ; inline
: define-reader ( class slot decl reader -- )
dup [
@ -23,7 +23,7 @@ parser sequences strings words ;
2drop 2drop
] if ;
: writer-effect 2 0 <effect> ; inline
: writer-effect ( -- effect ) 2 0 <effect> ; inline
: define-writer ( class slot writer -- )
dup [

View File

@ -1,6 +1,6 @@
USING: generic help ;
USING: generic help kernel-internals parser ;
HELP: define-typecheck "( class generic quot -- )"
HELP: define-typecheck
{ $values { "class" "a class word" } { "generic" "a generic word" } { "quot" "a quotation" } }
{ $description
"Defines a generic word with the " { $link standard-combination } " using dispatch position 0, and having one method on " { $snippet "class" } "."
@ -14,12 +14,31 @@ HELP: define-typecheck "( class generic quot -- )"
}
{ $notes "This word is used internally to wrap low-level code that does not do type-checking in safe user-visible words." } ;
HELP: define-slot-word "( class slot word quot -- )"
{ $values { "class" "a class word" } { "slot" "a non-negative integer" } { "word" "a new word" } { "quot" "a quotation" } }
HELP: define-slot-word
{ $values { "class" "a class word" } { "slot" "a positive integer" } { "word" "a new word" } { "quot" "a quotation" } }
{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." }
$low-level-note ;
HELP: define-slots "( class spec -- )"
HELP: reader-effect
{ $values { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot reader words is " { $snippet "( obj -- value )" } "." } ;
HELP: define-reader
{ $values { "class" "a class word" } { "slot" "a positive integer" } { "decl" "a class word or " { $link f } } { "reader" "a word" } }
{ $description "Defines a generic word " { $snippet "reader" } " to read a slot from instances of " { $snippet "class" } ". If " { $snippet "decl" } " is not " { $link f } ", then " { $link declare } " is applied to the slot value to declare that the value is an instance of a specific class." }
$low-level-note ;
HELP: define-writer
{ $values { "class" "a class word" } { "slot" "a positive integer" } { "writer" "a word" } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-slot
{ $values { "class" "a class word" } { "slot" "a positive integer" } { "decl" "a class word or " { $link f } } { "reader" "a word" } { "writer" "a word" } }
{ $description "Defines a pair of generic words, " { $snippet "reader" } " and " { $snippet "writer" } " for reading and writing a slot value in instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: define-slots
{ $values { "class" "a class word" } { "spec" "a sequence of triples" } }
{ $description
"Defines a set of slot accessor/mutator words."
@ -34,6 +53,7 @@ HELP: define-slots "( class spec -- )"
}
$low-level-note ;
HELP: simple-slots "( class slots base -- spec )"
HELP: simple-slots
{ $values { "class" "a class word" } { "slots" "a sequence of strings" } { "base" "a slot number" } }
{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." } ;
{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." }
{ $notes "This word is used by " { $link define-tuple } " and " { $link POSTPONE: TUPLE: } "." } ;

View File

@ -1,11 +1,11 @@
USING: generic help sequences ;
HELP: no-method "( object generic -- )"
HELP: no-method
{ $values { "object" "an object" } { "generic" "a generic word" } }
{ $description "Throws a " { $link no-method } " error." }
{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
HELP: standard-combination "( word dispatch# -- quot )"
HELP: standard-combination
{ $values { "word" "a generic word" } { "dispatch#" "a dispatch position" } { "quot" "a new quotation" } }
{ $description
"Performs standard method combination."
@ -24,7 +24,7 @@ HELP: standard-combination "( word dispatch# -- quot )"
{ $examples "Most generic words in the standard library use this method combination with a dispatch position of 0. A handful of combinators such as " { $link each } " dispatch on position 1, since position 0 (the top of the stack) is a quotation." }
{ $see-also POSTPONE: GENERIC: define-generic POSTPONE: G: define-generic* } ;
HELP: define-generic "( word -- )"
HELP: define-generic
{ $values { "word" "a word" } }
{ $description "Defines a generic word with the " { $link standard-combination } " method combination, and a dispatch position of 0." }
{ $see-also POSTPONE: GENERIC: define-generic* } ;

View File

@ -7,7 +7,7 @@ sequences-internals strings vectors words ;
IN: kernel-internals
: tuple= ( tuple tuple -- ? )
: tuple= ( tuple1 tuple2 -- ? )
2dup [ array-capacity ] 2apply number= [
dup array-capacity
[ 2dup swap array-nth >r pick array-nth r> = ] all? 2nip
@ -20,7 +20,7 @@ IN: generic
: class ( object -- class )
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
: tuple-predicate ( word -- )
: tuple-predicate ( class -- )
dup predicate-word [
[ dup tuple? ] %
[ [ 2 slot ] % over literalize , \ eq? , ] [ ] make ,
@ -30,7 +30,7 @@ IN: generic
: forget-tuple ( class -- )
dup forget "predicate" word-prop first [ forget ] when* ;
: check-shape ( word slots -- )
: check-shape ( class slots -- )
>r in get lookup dup [
dup "tuple-size" word-prop r> length 2 + =
[ drop ] [ forget-tuple ] if
@ -40,7 +40,7 @@ IN: generic
: delegate-slots { { 3 object delegate set-delegate } } ;
: tuple-slots ( tuple slots -- )
: tuple-slots ( class slots -- )
2dup "slot-names" set-word-prop
2dup length 2 + "tuple-size" set-word-prop
dupd 4 simple-slots
@ -61,13 +61,13 @@ TUPLE: check-tuple class ;
\ <tuple> , %
] [ ] make define-compound ;
: default-constructor ( tuple -- )
: default-constructor ( class -- )
dup create-constructor 2dup "constructor" set-word-prop
swap dup "slots" word-prop unclip drop <reversed>
[ [ tuck ] swap peek add ] map concat >quotation
define-constructor ;
: define-tuple ( tuple slots -- )
: define-tuple ( class slots -- )
2dup check-shape
>r create-in
dup intern-symbol
@ -91,7 +91,7 @@ M: tuple equal?
: delegates ( obj -- seq )
[ (delegates) ] { } make ;
: is? ( obj pred -- ? )
: is? ( obj quot -- ? )
>r delegates r> contains? ; inline
: >tuple ( seq -- tuple )

View File

@ -1,12 +1,12 @@
USING: generic help kernel kernel-internals ;
HELP: tuple= "( tuple1 tuple2 -- ? )"
HELP: tuple=
{ $values { "tuple1" "a tuple" } { "tuple2" "a tuple" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "kernel-internals" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
HELP: tuple f
{ $description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
$terpri
"Tuple classes have additional word properties:"
{ $list
@ -14,74 +14,78 @@ $terpri
{ { $snippet "\"tuple-size\"" } " - the number of slots" }
} } ;
HELP: class "( object -- class )"
HELP: class
{ $values { "object" "an object" } { "class" "a class word" } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
{ $examples { $example "1.0 class ." "float" } { $example "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: tuple-predicate "( class -- )"
HELP: tuple-predicate
{ $values { "class" "a tuple class word" } }
{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
$low-level-note ;
HELP: check-shape "( class slots -- )"
HELP: check-shape
{ $values { "class" "a tuple class word" } { "slots" "a sequence of strings" } }
{ $description "If the new slot list does not have the same length as the current slot list for " { $snippet "class" } ", removes the class word from the dictionary. This allows a new class to be defined, and instances of the old class and the new class can co-exist, with new instances having a different number of slots. This prevents memory corruption if old accessors are called on new instances, or vice versa."
$terpri
"If " { $snippet "class" } " is not a tuple class word, or if no slots are being added or removed, this word does nothing. In this case, it is safe to redefine the class, and have the same set of accessor words operate on old and new instances." }
$low-level-note ;
HELP: tuple-slots "( class slots -- )"
HELP: tuple-slots
{ $values { "class" "a tuple class word" } { "slots" "a sequence of strings" } }
{ $description "Defines slot accessor and mutator words for the tuple." }
$low-level-note ;
HELP: tuple-class f
{ $description "The class of tuple class words." }
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "TUPLE: name title first last ;\nname tuple-class? ." "t" } } ;
HELP: define-constructor "( word class def -- )"
HELP: define-constructor
{ $values { "word" "a constructor word" } { "class" "a tuple class word" } { "def" "a quotation" } }
{ $description "Define a constructor word for a tuple class. The constructor definition receives a new instance of the class on the stack, with all slots initially set to " { $link f } "." }
{ $see-also POSTPONE: C: } ;
HELP: check-tuple "( class -- )"
{ $values { "word" "a word" } }
{ $description "Throws an error if " { $snippet "word" } " is not a tuple class word." }
HELP: check-tuple
{ $values { "class" "a class" } }
{ $description "Throws a " { $link check-tuple } " error if " { $snippet "word" } " is not a tuple class word." }
{ $error-description "Thrown if " { $link define-constructor } " or " { $link POSTPONE: C: } " is called with a word which does not name a tuple class. Only tuple classes can have user-defined constructors." } ;
HELP: default-constructor "( class -- )"
HELP: default-constructor
{ $values { "class" "a tuple class word" } }
{ $description "Defines the default constructor for a tuple class. The default constructor fills slot values in from the stack." }
{ $examples { $example "TUPLE: account type balance ;\n\"savings\" 100 <account> ." "T{ account f \"savings\" 100 }" } } ;
HELP: define-tuple "( class slots -- )"
HELP: define-tuple
{ $values { "class" "a new word" } { "slots" "a sequence of strings" } }
{ $description "Defines a tuple class with slots named by " { $snippet "slots" } "." }
{ $see-also POSTPONE: TUPLE: } ;
HELP: is? "( obj quot -- ? )"
HELP: delegates
{ $values { "obj" "an object" } { "seq" "a sequence" } }
{ $description "Outputs the delegation chain of an object. The last element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
HELP: is?
{ $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
$terpri
"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
HELP: >tuple "( seq -- tuple )"
HELP: >tuple
{ $values { "seq" "a sequence" } { "tuple" "a new tuple" } }
{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
$terpri
"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
HELP: tuple>array "( tuple -- array )"
HELP: tuple>array ( tuple -- array )
{ $values { "tuple" "a tuple" } { "array" "a new array" } }
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
HELP: array>tuple "( array -- tuple )"
HELP: array>tuple ( array -- tuple )
{ $values { "array" "a array" } { "tuple" "a new tuple" } }
{ $description "Outputs a tuple having the same slot values as the array." }
{ $warning "This word is in the " { $vocab-link "kernel-internals" } " vocabulary since it is unsafe. Creating a tuple with the wrong shape can cause crashes or memory corruption. User code should construct tuples using generated tuple constructors instead; see " { $link "tuples" } "." } ;
HELP: <tuple> "( class n -- tuple )"
HELP: <tuple> ( class n -- tuple )
{ $values { "class" "a class word" } { "n" "a non-negative integer" } { "tuple" "a new tuple" } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use the constructor word which is defined for each tuple. See " { $link "tuples" } "." } ;

View File

@ -18,7 +18,7 @@ M: word article-content
] ?if
] { } make ;
: $title ( article -- )
: $title ( topic -- )
title-style [
title-style [
dup [ 1array $link ] ($block) $doc-path
@ -34,7 +34,7 @@ M: word article-content
: handbook ( -- ) "handbook" help ;
: $subtopic ( object -- )
: $subtopic ( element -- )
[
subtopic-style [
unclip f rot [ print-content ] curry write-outliner
@ -46,7 +46,7 @@ M: word article-content
dup [ (help) ] curry
write-outliner ;
: $subsection ( object -- )
: $subsection ( element -- )
[
subsection-style [ first ($subsection) ] with-style
] ($block) ;
@ -56,5 +56,5 @@ M: word article-content
sort-articles [ ($subsection) terpri ] each
] with-style ;
: $outliner ( content -- )
: $outliner ( element -- )
first call help-outliner ;

View File

@ -1,47 +1,43 @@
IN: help
USING: definitions io prettyprint ;
HELP: $title "( topic -- )"
HELP: $title
{ $values { "topic" "a help article name or a word" } }
{ $description "Prints a help article's title, or a word's " { $link synopsis } ", depending on the type of " { $snippet "topic" } "." } ;
HELP: print-content "( element -- )"
{ $values { "element" "a markup element" } }
{ $description "Prints a top-level markup element to the " { $link stdio } " stream." } ;
HELP: (help) "( topic -- )"
HELP: (help)
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help article or documentation associated to a word on the " { $link stdio } " stream. This word does not print the article title, so it is intended for use by outliners and in other contexts where the title is already visible to the user."
}
{ $see-also help see-help } ;
HELP: help "( topic -- )"
HELP: help
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help article or documentation associated to a word on the " { $link stdio } " stream."
}
{ $see-also (help) see-help } ;
HELP: see-help "( word -- )"
HELP: see-help
{ $values { "word" "a word" } }
{ $description
"Display the documentation and definition of a word on the " { $link stdio } " stream."
}
{ $see-also (help) help see } ;
HELP: handbook "( -- )"
HELP: handbook
{ $description "Displays the Factor developer's handbook." }
{ $see-also help } ;
HELP: $subsection "( element -- )"
HELP: $subsection
{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
{ $description "Prints an expandable outliner containing the body of the help topic named by the first string element of " { $snippet "element" } "." }
{ $examples
{ $markup-example { $subsection "sequences" } }
} ;
HELP: $subtopic "( element -- )"
HELP: $subtopic
{ $values { "element" "a markup element of the form " { $snippet "{ title content }" } } }
{ $description "Prints an expandable outliner with the given title containing an arbitrary markup element." }
{ $examples
@ -51,6 +47,10 @@ HELP: $subtopic "( element -- )"
"their own help article." } }
} ;
HELP: $outliner "( element -- )"
{ $values { "element" "a markup element of the form " { $snippet "( quot -- )" } } }
HELP: $outliner
{ $values { "element" "a markup element containing one quotation with stack effect " { $snippet "( quot -- )" } } }
{ $description "Calls the quotation to generate a sequence of help topics, and outputs an outliner for each one. Expanding a help topic shows the article body." } ;
HELP: help-outliner "( seq quot -- )"
{ $values { "seq" "a sequence of help article names and words" } { "quot" "a quotation with stack effect " { $snippet "( topic -- )" } } }
{ $description "Writes an outliner of help topics to the " { $link stdio } " stream. Expanding a help topic calls " { $snippet "quot" } " with the topic on the data stack." } ;

View File

@ -37,6 +37,8 @@ SYMBOL: table
span last-element set
call ; inline
GENERIC: print-element ( element -- )
M: simple-element print-element [ print-element ] each ;
M: string print-element [ write ] ($span) ;
M: array print-element unclip execute ;
@ -75,7 +77,7 @@ M: word print-element { } swap execute ;
: ($heading)
last-element get [ terpri ] when ($block) ; inline
: $heading
: $heading ( element -- )
[ heading-style print-element* ] ($heading) ;
: ($code) ( presentation quot -- )
@ -87,34 +89,37 @@ M: word print-element { } swap execute ;
] with-style
] ($block) ; inline
: $code ( content -- )
: $code ( element -- )
"\n" join dup <input> [ write ] ($code) ;
: $description ( content -- )
: $description ( element -- )
"Word description" $heading print-element ;
: $class-description ( content -- )
: $class-description ( element -- )
"Class description" $heading print-element ;
: $error-description ( content -- )
: $error-description ( element -- )
"Error description" $heading print-element ;
: $contract ( content -- )
: $var-description ( element -- )
"Variable description" $heading print-element ;
: $contract ( element -- )
"Generic word contract" $heading print-element ;
: $examples ( content -- )
: $examples ( element -- )
"Examples" $heading print-element ;
: $example ( content -- )
: $example ( element -- )
1 swap cut* swap "\n" join dup <input> [
input-style format terpri print-element
] ($code) ;
: $markup-example ( content -- )
: $markup-example ( element -- )
first dup unparse " print-element" append 1array $code
print-element ;
: $warning ( content -- )
: $warning ( element -- )
[
warning-style [
last-element off
@ -129,27 +134,27 @@ M: word >link ;
M: link >link ;
M: object >link <link> ;
: $link ( article -- )
: $link ( element -- )
first link-style [
dup article-title swap >link write-object
] with-style ;
: $vocab-link ( content -- )
: $vocab-link ( element -- )
first link-style [
dup <vocab-link> write-object
] with-style ;
: $vocabulary ( content -- )
: $vocabulary ( element -- )
[ word-vocabulary ] map
[ "Vocabulary" $heading terpri $vocab-link ] when* ;
: textual-list ( seq quot -- )
[ ", " print-element ] interleave ; inline
: $links ( content -- )
: $links ( topics -- )
[ [ 1array $link ] textual-list ] ($span) ;
: $see-also ( content -- )
: $see-also ( topics -- )
"See also" $heading $links ;
: $doc-path ( article -- )
@ -170,17 +175,17 @@ M: object >link <link> ;
] with-style
] ($block) table last-element set ;
: $list ( content -- )
: $list ( element -- )
[ "-" swap 2array ] map list-style $grid ;
: $table ( content -- )
: $table ( element -- )
table-style $grid ;
: $values ( content -- )
: $values ( element -- )
"Arguments and values" $heading
[ unclip \ $snippet swap 2array swap 2array ] map $table ;
: $predicate ( content -- )
: $predicate ( element -- )
{ { "object" "an object" } } $values
[
"Tests if the object is an instance of the " ,
@ -188,14 +193,14 @@ M: object >link <link> ;
" class." ,
] { } make $description ;
: $errors ( content -- )
: $errors ( element -- )
"Errors" $heading print-element ;
: $side-effects ( content -- )
: $side-effects ( element -- )
"Side effects" $heading "Modifies " print-element
[ $snippet ] textual-list ;
: $notes ( content -- )
: $notes ( element -- )
"Notes" $heading print-element ;
: ($see) ( word -- )
@ -205,19 +210,19 @@ M: object >link <link> ;
] with-style
] ($block) ;
: $see ( content -- ) first ($see) ;
: $see ( element -- ) first ($see) ;
: $definition ( content -- )
: $definition ( word -- )
"Definition" $heading ($see) ;
: $curious ( content -- )
: $curious ( element -- )
"For the curious..." $heading print-element ;
: $references ( content -- )
: $references ( element -- )
"References" $heading
unclip print-element [ \ $link swap 2array ] map $list ;
: $shuffle ( content -- )
: $shuffle ( element -- )
drop
"Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;

View File

@ -2,25 +2,33 @@ IN: help
USING: arrays definitions inspector io math prettyprint
sequences ;
HELP: simple-element f
{ $description "Class of simple elements, which are just arrays of elements." } ;
HELP: print-element
{ $values { "element" "a markup element" } }
{ $description "Prints a markup element to the " { $link stdio } " stream." } ;
HELP: ($span) "( content style -- )"
{ $values { "content" "a markup element" } { "style" "a hashtable" } }
HELP: print-content
{ $values { "element" "a markup element" } }
{ $description "Prints a top-level markup element to the " { $link stdio } " stream." } ;
HELP: simple-element
{ $class-description "Class of simple elements, which are just arrays of elements." } ;
HELP: ($span)
{ $values { "quot" "a quotation" } }
{ $description "Prints an inline markup element." } ;
HELP: ($block) "( quot -- )"
HELP: ($block)
{ $values { "quot" "a quotation" } }
{ $description "Prints a block markup element with newlines before and after." } ;
HELP: $heading "( element -- )"
HELP: $heading
{ $values { "element" "a markup element" } }
{ $description "Prints a markup element, usually a string, as a block with the " { $link heading-style } "." }
{ $examples
{ $markup-example { $heading "What remains to be discovered" } }
} ;
HELP: $code "( element -- )"
HELP: $code
{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } }
{ $description "Prints code examples, as seen in many help articles. The markup element must be an array of strings." }
{ $notes
@ -32,29 +40,29 @@ HELP: $code "( element -- )"
{ $markup-example { $code "2 2 + ." } }
} ;
HELP: $vocabulary "( word -- )"
{ $values { "word" "a markup element of the form " { $snippet "{ word }" } } }
HELP: $vocabulary
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
{ $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ;
HELP: $description "( element -- )"
HELP: $description
{ $values { "element" "a markup element" } }
{ $description "Prints the description subheading found on the help page of most words." } ;
HELP: $contract "( element -- )"
HELP: $contract
{ $values { "element" "a markup element" } }
{ $description "Prints a heading followed by a contract, found on the help page of generic words. Every generic word should document a contract which specifies method behavior that callers can rely upon, and implementations must obey." }
{ $examples
{ $markup-example { $contract "Methods of this generic word must always crash." } }
} ;
HELP: $examples "( element -- )"
HELP: $examples
{ $values { "element" "a markup element" } }
{ $description "Prints a heading followed by some examples. Word documentation should include examples, at least if the usage of the word is not entirely obvious." }
{ $examples
{ $markup-example { $examples { $example "2 2 + ." "4" } } }
} ;
HELP: $example "( element -- )"
HELP: $example
{ $values { "element" "a markup element of the form " { $snippet "{ inputs... output }" } } }
{ $description "Prints a clickable example with sample output. The markup element must be an array of strings. All but the last string are joined by newlines and taken as the input text, and the last string is the output. The example becomes clickable if the output stream supports it, and clicking it opens a listener window with the input text inserted at the input prompt." }
{ $examples
@ -65,21 +73,21 @@ HELP: $example "( element -- )"
"Examples can incorporate a call to " { $link .s } " to show multiple output values; the convention is that you may assume the stack is empty before the example evaluates."
} ;
HELP: $markup-example "( element -- )"
HELP: $markup-example
{ $values { "element" "a markup element" } }
{ $description "Prints a clickable example showing the prettyprinted source text of " { $snippet "element" } " followed by rendered output. The example becomes clickable if the output stream supports it." }
{ $examples
{ $markup-example { $markup-example { $emphasis "Hi" } } }
} ;
HELP: $warning "( element -- )"
HELP: $warning
{ $values { "element" "a markup element" } }
{ $description "Prints an element inset in a block styled as so to draw the reader's attention towards it." }
{ $examples
{ $markup-example { $warning "Incorrect use of this product may cause serious injury or death." } }
} ;
HELP: $link "( element -- )"
HELP: $link
{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
{ $description "Prints a link to a help article or word." }
{ $examples
@ -87,14 +95,14 @@ HELP: $link "( element -- )"
{ $markup-example { $link + } }
} ;
HELP: textual-list "( seq -- str )"
{ $values { "seq" "a sequence of strings" } { "str" "a string" } }
{ $description "Concatenates a sequence of strings together, separated by " { $snippet "\", \"" } "." }
HELP: textual-list
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." }
{ $examples
{ $example "{ \"fish\" \"chips\" \"salt\" } textual-list print" "fish, chips, salt" }
{ $example "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list print" "fish, chips, salt" }
} ;
HELP: $links "( topics -- )"
HELP: $links
{ $values { "topics" "a sequence of article names or words" } }
{ $description "Prints a series of links to help articles or word documentation." }
{ $notes "This markup element is used to implement " { $link $links } "." }
@ -102,14 +110,14 @@ HELP: $links "( topics -- )"
{ $markup-example { $links + - * / } }
} ;
HELP: $see-also "( topics -- )"
HELP: $see-also
{ $values { "topics" "a sequence of article names or words" } }
{ $description "Prints a heading followed by a series of links." }
{ $examples
{ $markup-example { $see-also "graphs" "queues" } }
} ;
HELP: $table "( element -- )"
HELP: $table
{ $values { "element" "an array of arrays of markup elements" } }
{ $description "Prints a table given as an array of rows, where each row must have the same number of columns." }
{ $examples
@ -121,15 +129,15 @@ HELP: $table "( element -- )"
}
} ;
HELP: $values "( element -- )"
HELP: $values
{ $values { "element" "an array of pairs of markup elements" } }
{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder can be an element of any form." } ;
HELP: $predicate "( element -- )"
HELP: $predicate
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
{ $description "Prints the boilerplate description of a class membership predicate word such as " { $link array? } " or " { $link integer? } "." } ;
HELP: $list "( element -- )"
HELP: $list
{ $values { "element" "an array of markup elements" } }
{ $description "Prints a bulleted list of markup elements." }
{ $notes
@ -149,14 +157,14 @@ HELP: $list "( element -- )"
}
} ;
HELP: $errors "( element -- )"
HELP: $errors
{ $values { "element" "a markup element" } }
{ $description "Prints the errors subheading found on the help page of some words. This section should document any errors thrown by the word." }
{ $examples
{ $markup-example { $errors "I/O errors, network errors, hardware errors... oh my!" } }
} ;
HELP: $side-effects "( element -- )"
HELP: $side-effects
{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } }
{ $description "Prints a heading followed by a list of input values or variables which are modified by the word being documented." }
{ $examples
@ -165,38 +173,34 @@ HELP: $side-effects "( element -- )"
}
} ;
HELP: $notes "( element -- )"
HELP: $notes
{ $values { "element" "a markup element" } }
{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ;
HELP: $see "( element -- )"
HELP: $see
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
{ $description "Prints the definition of " { $snippet "word" } " by calling " { $link see } "." }
{ $examples
{ $markup-example { "Here is a word definition:" { $see reverse } } }
} ;
HELP: $definition "( word -- )"
HELP: $definition
{ $values { "word" "a word" } }
{ $description "Prints a heading followed by the definition of " { $snippet "word" } " by calling " { $link see } "." }
{ $notes
"This markup element is output by " { $link see-help } " but not " { $link help } "."
} ;
HELP: $curious "( element -- )"
HELP: $curious
{ $values { "element" "a markup element" } }
{ $description "Prints a heading followed by a markup element." }
{ $notes "This element type is used by the cookbook-style introductory articles in the " { $link "handbook" } "." } ;
HELP: $references "( element -- )"
HELP: $references
{ $values { "element" "a markup element of the form " { $snippet "{ topic... }" } } }
{ $description "Prints a heading followed by a series of links." }
{ $notes "This element type is used by the cookbook-style introductory articles in the " { $link "handbook" } "." } ;
HELP: sort-articles "( seq -- assoc )"
HELP: sort-articles
{ $values { "seq" "a sequence of help article names and words" } { "assoc" "a new sequence of pairs" } }
{ $description "Constructs a key-sorted association list mapping article titles to help topics." } ;
HELP: help-outliner "( seq quot -- )"
{ $values { "seq" "a sequence of help article names and words" } { "quot" "a quotation with stack effect " { $snippet "( topic -- )" } } }
{ $description "Writes an outliner of help topics to the " { $link stdio } " stream. Expanding a help topic calls " { $snippet "quot" } " with the topic on the data stack." } ;

View File

@ -1,15 +1,3 @@
! The Porter Stemming Algorithm, hand translated to Factor from
! Common Lisp by Slava Pestov.
! The Common Lisp version was hand translated from ANSI C by
! Steven M. Haflich smh@franz.com.
! The original ANSI C was written by Martin Porter.
! References:
! http://www.tartarus.org/~martin/PorterStemmer
! Porter, 1980, An algorithm for suffix stripping, Program,
! Vol. 14, no. 3, pp 130-137.
IN: porter-stemmer
USING: kernel math parser sequences ;
@ -80,27 +68,7 @@ USING: kernel math parser sequences ;
: butlast ( seq -- seq ) 1 head-slice* ;
! step1a and step1b get rid of plurals and -ed or -ing. e.g.
!
! caresses -> caress
! ponies -> poni
! ties -> ti
! caress -> caress
! cats -> cat
!
! feed -> feed
! agreed -> agree
! disabled -> disable
!
! matting -> mat
! mating -> mate
! meeting -> meet
! milling -> mill
! messing -> mess
!
! meetings -> meet
: step1a ( str -- str )
: step1a ( str -- newstr )
dup peek CHAR: s = [
{
{ [ "sses" ?tail ] [ "ss" append ] }
@ -138,7 +106,7 @@ USING: kernel math parser sequences ;
}
} cond ;
: step1b ( str -- str )
: step1b ( str -- newstr )
{
{ [ "eed" ?tail ] [ -eed ] }
{
@ -153,17 +121,12 @@ USING: kernel math parser sequences ;
{ [ t ] [ ] }
} cond ;
: step1c ( str -- str )
#! step1c turns terminal y to i when there is another vowel
#! in the stem.
: step1c ( str -- newstr )
dup butlast stem-vowel? [
"y" ?tail [ "i" append ] when
] when ;
: step2 ( str -- str )
#! step2 maps double suffices to single ones. so -ization
#! ( = -ize plus-ation) maps to -ize etc. note that the
#! string before the suffix must give consonant-seq > 0.
: step2 ( str -- newstr )
{
{ [ "ational" ?tail ] [ "ational" "ate" r ] }
{ [ "tional" ?tail ] [ "tional" "tion" r ] }
@ -189,9 +152,7 @@ USING: kernel math parser sequences ;
{ [ t ] [ ] }
} cond ;
: step3 ( str -- str )
#! step3 deals with -ic-, -full, -ness etc. similar
#! jstrategy to step2.
: step3 ( str -- newstr )
{
{ [ "icate" ?tail ] [ "icate" "ic" r ] }
{ [ "ative" ?tail ] [ "ative" "" r ] }
@ -203,14 +164,14 @@ USING: kernel math parser sequences ;
{ [ t ] [ ] }
} cond ;
: -ion ( str -- str )
: -ion ( str -- newstr )
dup empty? [
drop "ion"
] [
dup "st" last-is? [ "ion" append ] unless
] if ;
: step4 ( str -- str )
: step4 ( str -- newstr )
dup {
{ [ "al" ?tail ] [ ] }
{ [ "ance" ?tail ] [ ] }
@ -239,14 +200,12 @@ USING: kernel math parser sequences ;
[ 2drop t ]
[ 1 = [ butlast cvc? not ] [ drop f ] if ] if ;
: remove-e ( str -- str )
#! removes a final -e if consonant-seq > 1
: remove-e ( str -- newstr )
dup peek CHAR: e = [
dup remove-e? [ butlast ] when
] when ;
: ll->l ( str -- str )
#! changes -ll to -l if consonant-seq > 1.
: ll->l ( str -- newstr )
{
{ [ dup peek CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
@ -254,9 +213,9 @@ USING: kernel math parser sequences ;
{ [ t ] [ ] }
} cond ;
: step5 ( str -- str ) remove-e ll->l ;
: step5 ( str -- newstr ) remove-e ll->l ;
: stem ( str -- str )
: stem ( str -- newstr )
dup length 2 <= [
step1a step1b step1c step2 step3 step4 step5 "" like
] unless ;

View File

@ -0,0 +1,54 @@
IN: porter-stemmer
USING: help ;
HELP: step1a
{ $values { "str" "a string" } { "newstr" "a new string" } }
{ $description "Gets rid of plurals." }
{ $examples
{ $table
{ "Input:" "Output:" }
{ "caresses" "caress" }
{ "ponies" "poni" }
{ "ties" "ti" }
{ "caress" "caress" }
{ "cats" "cat" }
}
} ;
HELP: step1b
{ $values { "str" "a string" } { "newstr" "a new string" } }
{ $description "Gets rid of \"-ed\" and \"-ing\" suffixes." }
{ $examples
{ $table
{ "Input:" "Output:" }
{ "feed" } { "feed" }
{ "agreed" } { "agree" }
{ "disabled" } { "disable" }
{ "matting" } { "mat" }
{ "mating" } { "mate" }
{ "meeting" } { "meet" }
{ "milling" } { "mill" }
{ "messing" } { "mess" }
{ "meetings" } { "meet" }
}
} ;
HELP: step1c
{ $values { "str" "a string" } { "newstr" "a new string" } }
{ $description "Turns a terminal y to i when there is another vowel in the stem." } ;
HELP: step2
{ $values { "str" "a string" } { "newstr" "a new string" } }
{ $description "Maps double suffices to single ones. so -ization maps to -ize etc. note that the string before the suffix must give positive " { $link consonant-seq } "." } ;
HELP: step3
{ $values { "str" "a string" } { "newstr" "a new string" } }
{ $description "Deals with -c-, -full, -ness, etc. Similar strategy to " { $link step2 } "." } ;
HELP: step5
{ $values { "str" "a string" } { "newstr" "a new string" } }
{ $description "Removes a final -e and changes a final -ll to -l if " { $link consanant-seq } " is greater than 1," } ;
HELP: stem
{ $values { "str" "a string" } { "newstr" "a new string" } }
{ $description "Applies the Porter stemming algorithm to the input string." } ;

View File

@ -7,7 +7,7 @@ namespaces porter-stemmer prettyprint sequences strings words ;
! Right now this code is specific to the help. It will be
! generalized to an abstract full text search engine later.
: ignored-word? ( str -- ? )
: ignored-word? ( string -- ? )
{ "the" "of" "is" "to" "an" "and" "if" "in" "with" "this" "not" "are" "for" "by" "can" "be" "or" "from" "it" "does" "as" } member? ;
: tokenize ( string -- seq )
@ -17,12 +17,12 @@ namespaces porter-stemmer prettyprint sequences strings words ;
dup ignored-word? over length 1 = or swap empty? or not
] subset ;
: index-text ( article string -- )
: index-text ( topic string -- )
tokenize [ 1 -rot nest hash+ ] each-with ;
SYMBOL: term-index
: index-article ( article -- )
: index-article ( topic -- )
term-index get [
[ dup [ help ] string-out index-text ] bind
] [
@ -36,7 +36,7 @@ SYMBOL: term-index
drop
] if* ;
: discard-irrelevant ( results -- results )
: discard-irrelevant ( results -- newresults )
#! Discard results in the low 33%
dup 0 [ second max ] reduce
swap [ first2 rot / 2array ] map-with

View File

@ -1,43 +1,43 @@
IN: help
USING: namespaces ;
HELP: ignored-word? "( string -- ? )"
HELP: ignored-word?
{ $values { "string" "a string" } } { $description "Tests for English stop words." } ;
HELP: tokenize "( string -- seq )"
HELP: tokenize
{ $values { "string" "a string" } { "seq" "a sequence of strings" } }
{ $description "Split a string along whitespace boundaries, convert all tokens to lower case, stem all tokens, and discards one-letter words and stop words." } ;
HELP: index-text "( topic string -- )"
HELP: index-text
{ $values { "topic" "a help article name or a word" } { "string" "a string" } }
{ $description "Tokenizes the string and adds each token to the term index." }
{ $notes "This word operates on the current namespace, and so must be wrapped in a " { $link bind } " to specify the term index hashtable." } ;
HELP: index-article "( topic -- )"
HELP: index-article
{ $values { "topic" "a help article name or a word" } }
{ $description "Adds the tokens making up the article to the term index." } ;
HELP: term-index f
{ $description "Variable. A hashtable mapping stemmed search terms to hashtables mapping help topics to relevancy scores."
HELP: term-index
{ $var-description "A hashtable mapping stemmed search terms to hashtables mapping help topics to relevancy scores."
$terpri
"The " { $link search-help } " word searches the term index and the " { $link index-help } " word updates it." }
{ $see-also help } ;
HELP: discard-irrelevant "( results -- results )"
{ $values }
HELP: discard-irrelevant
{ $values { "results" "a sequence" } { "newresults" "a new sequence" } }
{ $description "Discard search results which rank in the lower 33% compared to the top scoring result, since they are most likely irrelevant." } ;
HELP: count-occurrences "( seq -- hash )"
HELP: count-occurrences
{ $values { "seq" "a sequence of hashtables" } { "hash" "a hashtable" } }
{ $description "Collates all keys from the hashtables in " { $snippet "seq" } " and sums their values, which must be numbers." } ;
HELP: search-help "( phrase -- assoc )"
HELP: search-help
{ $values { "phrase" "a string" } { "assoc" "a sequence of pairs" } }
{ $description "Performs a full-text search in the term index for help topics relating to " { $snippet "phrase" } ". The result is an association list of topic names paired with scores, sorted by decreasing score." } ;
HELP: index-help "( -- )"
HELP: index-help
{ $description "Updates the full-text search term index for use by " { $link search-help } " and " { $link search-help. } "." } ;
HELP: search-help. "( phrase -- )"
HELP: search-help.
{ $values { "phrase" "a string" } }
{ $description "Performs a full-text search in the term index for help topics relating to " { $snippet "phrase" } ", and prints an outliner with the results." } ;

View File

@ -1,12 +1,12 @@
USING: help ;
HELP: HELP: "word stack-effect content..."
{ $values { "word" "a word" } { "stack-effect" "a stack effect or syntax string" } { "content" "markup elements" } }
HELP: HELP: "word content..."
{ $values { "word" "a word" } { "content" "markup elements" } }
{ $description "Defines documentation for a word." }
{ $examples
{ $code
": foo 2 + ;"
"HELP: foo \"( m -- n )\""
"HELP: foo
"{ $values { \"m\" \"an integer\" } { \"n\" \"an integer\" } }"
"{ $description \"Increments a value by 2.\" } ;"
"\ foo help"

View File

@ -4,9 +4,6 @@ IN: help
USING: arrays definitions errors generic graphs hashtables
inspector io kernel namespaces prettyprint sequences words ;
! Markup
GENERIC: print-element ( element -- )
! Help articles
SYMBOL: articles
@ -54,23 +51,23 @@ SYMBOL: parent-graph
DEFER: $subsection
: children ( article -- seq )
: children ( topic -- seq )
article-content { $subsection } collect-elements ;
: parents ( article -- seq )
: parents ( topic -- seq )
dup link? [ link-name ] when parent-graph get in-edges ;
: (doc-path) ( article -- )
: (doc-path) ( topic -- )
dup , parents [ word? not ] subset dup empty?
[ drop ] [ [ (doc-path) ] each ] if ;
: doc-path ( article -- seq )
: doc-path ( topic -- seq )
[ (doc-path) ] { } make 1 tail prune ;
: xref-article ( article -- )
: xref-article ( topic -- )
[ children ] parent-graph get add-vertex ;
: unxref-article ( article -- )
: unxref-article ( topic -- )
[ children ] parent-graph get remove-vertex ;
: xref-help ( -- )

View File

@ -1,71 +1,67 @@
IN: help
USING: io ;
HELP: print-element "( element -- )"
{ $values { "element" "a markup element" } }
{ $description "Prints a markup element to the " { $link stdio } " stream." } ;
HELP: articles
{ $var-description "Hashtable mapping article names to " { $link article } " instances." } ;
HELP: articles f
{ $description "Variable. Hashtable mapping article names to " { $link article } " instances." } ;
HELP: no-article "( name -- )"
HELP: no-article
{ $values { "name" "an article name" } }
{ $description "Throws a " { $link no-article } " error." }
{ $error-description "Thrown by " { $link help } " if the given help topic does not exist, or if the help topic being dispayed links to a help topic which does not exist." } ;
HELP: article "( name -- article )"
HELP: article
{ $values { "name" "an article name" } { "article" "an " { $link article } " object" } }
{ $description "Outputs a named " { $link article } " object." } ;
HELP: article-title "( topic -- string )"
HELP: article-title ( topic -- string )
{ $values { "topic" "an article name or a word" } { "string" "a string" } }
{ $description "Outputs the title of a specific help article." } ;
HELP: article-content "( topic -- element )"
HELP: article-content ( topic -- element )
{ $values { "topic" "an article name or a word" } { "element" "a markup element" } }
{ $description "Outputs the content of a specific help article." } ;
HELP: all-articles "( -- seq )"
HELP: all-articles
{ $values { "seq" "a sequence" } }
{ $description "Outputs a sequence of all help article names, and all words with documentation." } ;
HELP: elements "( elt-type element -- seq )"
HELP: elements
{ $values { "elt-type" "a word" } { "element" "a markup element" } { "seq" "a new sequence" } }
{ $description "Outputs a sequence of all elements of type " { $snippet "elt-type" } " found by traversing " { $snippet "element" } "." } ;
HELP: collect-elements "( element seq -- )"
HELP: collect-elements
{ $values { "element" "a markup element" } { "seq" "a sequence of words" } { "elements" "a new sequence" } }
{ $description "Collects the arguments of all sub-elements of " { $snippet "element" } " whose markup element type occurs in " { $snippet "seq" } "." }
{ $notes "Used to implement " { $link children } "." } ;
HELP: parent-graph f
{ $description "Variable. A graph whose vertices are help articles and edges are subsections. See " { $link "graphs" } "." }
HELP: parent-graph
{ $var-description "A graph whose vertices are help articles and edges are subsections. See " { $link "graphs" } "." }
{ $see-also children parents xref-help } ;
HELP: children "( topic -- seq )"
HELP: children
{ $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
{ $description "Outputs a sequence of all subsections of " { $snippet "topic" } "." } ;
HELP: parents "( topic -- seq )"
HELP: parents
{ $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
{ $description "Outputs a sequence of all help articles which contain " { $snippet "topic" } " as a subsection." } ;
HELP: doc-path "( topic -- seq )"
HELP: doc-path
{ $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
{ $description "Outputs a sequence of all help articles which contain " { $snippet "topic" } " as a subsection, traversing all the way up to the root." }
{ $examples
{ $example "\"sequences\" doc-path ." "{ \"collections\" \"handbook\" }" }
} ;
HELP: xref-article "( topic -- )"
HELP: xref-article
{ $values { "topic" "an article name or a word" } }
{ $description "Adds an article to the " { $link parent-graph } " graph." }
$low-level-note ;
HELP: unxref-article "( topic -- )"
HELP: unxref-article
{ $values { "topic" "an article name or a word" } }
{ $description "Removes an article to the " { $link parent-graph } " graph." }
$low-level-note ;
HELP: xref-help "( -- )"
HELP: xref-help
{ $description "Update the " { $link parent-graph } ". Usually this is done automatically." } ;

View File

@ -8,5 +8,5 @@ USING: kernel math sequences strings ;
: nth-byte ( x n -- b ) -8 * shift HEX: ff bitand ;
: >le ( x n -- string ) [ nth-byte ] map-with >string ;
: >be ( x n -- string ) >le reverse ;
: >le ( x n -- str ) [ nth-byte ] map-with >string ;
: >be ( x n -- str ) >le reverse ;

View File

@ -1,21 +1,21 @@
USING: help io ;
HELP: be> "( seq -- x )"
HELP: be>
{ $values { "seq" "a sequence of bytes" } { "x" "a non-negative integer" } }
{ $description "Converts a sequence of bytes in big endian order into an unsigned integer." } ;
HELP: le> "( seq -- x )"
HELP: le>
{ $values { "seq" "a sequence of bytes" } { "x" "a non-negative integer" } }
{ $description "Converts a sequence of bytes in little endian order into an unsigned integer." } ;
HELP: nth-byte "( x n -- b )"
HELP: nth-byte
{ $values { "x" "an integer" } { "n" "a non-negative integer" } { "b" "a byte" } }
{ $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ;
HELP: >le "( x n -- str )"
HELP: >le
{ $values { "x" "an integer" } { "n" "a non-negative integer" } { "str" "a string" } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: >be "( x n -- str )"
HELP: >be
{ $values { "x" "an integer" } { "n" "a non-negative integer" } { "str" "a string" } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;

View File

@ -7,7 +7,7 @@ strings ;
TUPLE: buffer size ptr fill pos ;
C: buffer ( size -- buffer )
C: buffer ( n -- buffer )
2dup set-buffer-size
[ >r malloc check-ptr alien-address r> set-buffer-ptr ] keep
0 over set-buffer-fill
@ -20,10 +20,10 @@ C: buffer ( size -- buffer )
dup buffer-ptr over buffer-pos +
over buffer-fill rot buffer-pos - memory>string ;
: buffer-reset ( count buffer -- )
: buffer-reset ( n buffer -- )
[ set-buffer-fill ] keep 0 swap set-buffer-pos ;
: buffer-consume ( count buffer -- )
: buffer-consume ( n buffer -- )
[ buffer-pos + ] keep
[ buffer-fill min ] keep
[ set-buffer-pos ] keep
@ -32,33 +32,33 @@ C: buffer ( size -- buffer )
0 over set-buffer-fill
] when drop ;
: buffer@ ( buffer -- int ) dup buffer-ptr swap buffer-pos + ;
: buffer@ ( buffer -- n ) dup buffer-ptr swap buffer-pos + ;
: buffer-end ( buffer -- int ) dup buffer-ptr swap buffer-fill + ;
: buffer-end ( buffer -- n ) dup buffer-ptr swap buffer-fill + ;
: buffer-first-n ( count buffer -- string )
: buffer-first-n ( n buffer -- string )
[ dup buffer-fill swap buffer-pos - min ] keep
buffer@ swap memory>string ;
: buffer> ( count buffer -- string )
: buffer> ( n buffer -- string )
[ buffer-first-n ] 2keep buffer-consume ;
: buffer>> ( buffer -- string )
[ buffer-contents ] keep 0 swap buffer-reset ;
: buffer-length ( buffer -- length )
: buffer-length ( buffer -- n )
dup buffer-fill swap buffer-pos - ;
: buffer-capacity ( buffer -- int )
: buffer-capacity ( buffer -- n )
dup buffer-size swap buffer-fill - ;
: buffer-empty? ( buffer -- ? ) buffer-fill zero? ;
: extend-buffer ( length buffer -- )
: extend-buffer ( n buffer -- )
2dup buffer-ptr <alien> swap realloc check-ptr alien-address
over set-buffer-ptr set-buffer-size ;
: check-overflow ( length buffer -- )
: check-overflow ( n buffer -- )
2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
: >buffer ( string buffer -- )
@ -66,7 +66,7 @@ C: buffer ( size -- buffer )
[ buffer-end string>memory ] 2keep
[ buffer-fill swap length + ] keep set-buffer-fill ;
: ch>buffer ( char buffer -- )
: ch>buffer ( ch buffer -- )
1 over check-overflow
[ buffer-end f swap set-alien-unsigned-1 ] keep
[ buffer-fill 1+ ] keep set-buffer-fill ;
@ -74,13 +74,13 @@ C: buffer ( size -- buffer )
: buffer-bound ( buffer -- n )
dup buffer-ptr swap buffer-size + ;
: n>buffer ( count buffer -- )
: n>buffer ( n buffer -- )
[ buffer-fill + ] keep
[ buffer-bound > [ "Buffer overflow" throw ] when ] 2keep
set-buffer-fill ;
: buffer-peek ( buffer -- char )
: buffer-peek ( buffer -- ch )
buffer@ f swap alien-unsigned-1 ;
: buffer-pop ( buffer -- char )
: buffer-pop ( buffer -- ch )
[ buffer-peek 1 ] keep buffer-consume ;

View File

@ -1,7 +1,7 @@
USING: help io-internals ;
HELP: buffer f
{ $description "The class of I/O buffers, which are allocated in the system malloc arena, and thus have a fixed address, unlike garbage-collected heap objects which are moved around. Buffers must be de-allocated manually."
HELP: buffer
{ $class-description "The class of I/O buffers, which are allocated in the system malloc arena, and thus have a fixed address, unlike garbage-collected heap objects which are moved around. Buffers must be de-allocated manually."
$terpri
"Buffers have two internal pointers:"
{ $list
@ -9,88 +9,92 @@ $terpri
{ "the position -- a read index where data is consumed; accessor: " { $link buffer-pos } }
} } ;
HELP: <buffer> "( n -- buffer )"
HELP: <buffer>
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
{ $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ;
HELP: buffer-free "( buffer -- )"
HELP: buffer-free
{ $values { "buffer" "a buffer" } }
{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." }
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
HELP: buffer-contents "( buffer -- string )"
HELP: buffer-contents
{ $values { "buffer" "a buffer" } { "string" "a string" } }
{ $description "Collects the entire contents of the buffer into a string." } ;
HELP: buffer-reset "( n buffer -- )"
HELP: buffer-reset
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
{ $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
HELP: buffer-consume "( n buffer -- )"
HELP: buffer-consume
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
{ $description "Moves the position forward by " { $snippet "n" } " bytes. If it exceeds the fill pointer, both are reset to 0." } ;
HELP: buffer@ "( buffer -- n )"
HELP: buffer@
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
{ $description "Outputs the memory address of the current buffer position." } ;
HELP: buffer-end "( buffer -- n )"
HELP: buffer-end
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
{ $description "Outputs the memory address of the current fill-pointer." } ;
HELP: buffer-first-n "( n buffer -- string )"
HELP: buffer-first-n
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
{ $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." }
{ $see-also buffer> } ;
HELP: buffer> "( n buffer -- string )"
HELP: buffer>
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } { "string" "a string" } }
{ $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
HELP: buffer>> "( buffer -- string )"
HELP: buffer>>
{ $values { "buffer" "a buffer" } { "string" "a string" } }
{ $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ;
HELP: buffer-length "( buffer -- n )"
HELP: buffer-length
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
{ $description "Outputs the number of unconsumed bytes in the buffer." } ;
HELP: buffer-capacity "( buffer -- n )"
HELP: buffer-capacity
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
{ $description "Outputs the buffer's maximum capacity before growing." } ;
HELP: buffer-empty? "( buffer -- ? )"
HELP: buffer-empty?
{ $values { "buffer" "a buffer" } { "?" "a boolean" } }
{ $description "Tests if the buffer contains no more data to be read." } ;
HELP: extend-buffer "( n buffer -- )"
HELP: extend-buffer
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
{ $description "Grows a buffer to fit " { $snippet "n" } " bytes of data." } ;
HELP: check-overflow "( n buffer -- )"
HELP: check-overflow
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
{ $description "Grows the buffer, if possible, so it can accomodate " { $snippet "n" } " bytes." }
{ $warning "I/O system implementations should call this word or one of the other words that calls this word, at the beginning of an I/O transaction, when the buffer is empty. Buffers cannot be resized if they contain data; one of the requirements of a buffer is to remain fixed in memory while I/O operations are in progress." }
{ $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ;
HELP: >buffer "( string buffer -- )"
HELP: >buffer
{ $values { "string" "a string" } { "buffer" "a buffer" } }
{ $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ;
HELP: ch>buffer "( ch buffer -- )"
HELP: ch>buffer
{ $values { "ch" "a character" } { "buffer" "a buffer" } }
{ $description "Appends a single byte to a buffer." } ;
HELP: n>buffer "( n buffer -- )"
HELP: buffer-bound
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
{ $description "Outputs the address pointing to the end of the buffer." } ;
HELP: n>buffer
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
{ $description "Advances the fill pointer by " { $snippet "n" } " bytes." }
{ $errors "Throws an error if the buffer does not contain " { $snippet "n" } " bytes of data." } ;
HELP: buffer-peek "( buffer -- ch )"
HELP: buffer-peek
{ $values { "buffer" "a buffer" } { "ch" "a character" } }
{ $description "Outputs the byte at the buffer position." }
{ $see-also buffer-pop } ;
HELP: buffer-pop "( buffer -- ch )"
HELP: buffer-pop
{ $values { "buffer" "a buffer" } { "ch" "a character" } }
{ $description "Outputs the byte at the buffer position and advances the position." } ;

View File

@ -49,6 +49,6 @@ TUPLE: client-stream host port ;
TUPLE: c-stream-error ;
: c-stream-error ( -- * ) <c-stream-error> throw ;
: <client> c-stream-error ;
: <server> c-stream-error ;
: accept c-stream-error ;
: <client> ( host port -- stream ) c-stream-error ;
: <server> ( port -- server ) c-stream-error ;
: accept ( server -- stream ) c-stream-error ;

View File

@ -1,26 +1,26 @@
USING: help io io-internals threads ;
HELP: io-multiplex "( ms -- )"
HELP: io-multiplex
{ $values { "ms" "a non-negative integer" } }
{ $description "Waits up to " { $snippet "ms" } " milliseconds for pending I/O requests to complete." }
{ $warning "If an I/O request completes during the time period, its continuation is resumed and the current one is not saved. If you need to delay execution for a period of time, use the higher-level " { $link sleep } " word instead." } ;
HELP: <file-reader> "( path -- stream )"
HELP: <file-reader>
{ $values { "path" "a string" } { "stream" "an input stream" } }
{ $description "Outputs an input stream for reading from the specified path name." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: <file-writer> "( path -- stream )"
HELP: <file-writer>
{ $values { "path" "a string" } { "stream" "an output stream" } }
{ $description "Outputs an input stream for writing to the specified path name." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: <client> "( host port -- stream )"
HELP: <client>
{ $values { "host" "a string" } { "port" "an integer between 0 and 65535" } { "stream" "a bidirectional stream" } }
{ $description "Connects to TCP/IP port number " { $code "port" } " on the host named by " { $code "host" } ", and outputs a bidirectional stream." }
{ $errors "Throws an error if domain name lookup fails, or if there is a connection cannot be established." } ;
HELP: <server> "( port -- server )"
HELP: <server>
{ $values { "port" "an integer between 0 and 65535" } { "server" "a handle" } }
{ $description
"Begins listening for connections to " { $snippet "port" } " on all network interfaces. The returned object responds to two generic words:"
@ -31,7 +31,7 @@ HELP: <server> "( port -- server )"
}
{ $errors "Throws an error if the port is already in use, or if the OS forbits access." } ;
HELP: accept "( server -- stream )"
HELP: accept
{ $values { "server" "a handle" } { "stream" "a bidirectional stream" } }
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established."
$terpri
@ -39,35 +39,35 @@ $terpri
{ $list { $link client-stream-host } { $link client-stream-port } } }
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
HELP: <c-stream> "( in out -- stream )"
HELP: <c-stream> ( in out -- stream )
{ $values { "in" "a C FILE* handle" } { "out" "a C FILE* handle" } }
{ $description "Creates a stream which reads and writes data by calling C standard library functions." }
{ $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ;
HELP: fopen "( path mode -- alien )"
HELP: fopen ( path mode -- alien )
{ $values { "path" "a path name string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } }
{ $description "Opens a file named by " { $snippet "path" } ". The " { $snippet "mode" } " parameter should be something like " { $snippet "\"r\"" } " or " { $snippet "\"rw\"" } "; consult the " { $snippet "fopen(3)" } " manual page for details." }
{ $errors "Throws an error if the file could not be opened." }
{ $notes "User code should call " { $link <file-reader> } " or " { $link <file-writer> } " to get a high level stream." } ;
HELP: fwrite "( string alien -- )"
HELP: fwrite ( string alien -- )
{ $values { "string" "a string" } { "alien" "a C FILE* handle" } }
{ $description "Writes a string of text to a C FILE* handle." }
{ $errors "Throws an error if the output operation failed." } ;
HELP: fflush "( alien -- )"
HELP: fflush ( alien -- )
{ $values { "alien" "a C FILE* handle" } }
{ $description "Forces pending output on a C FILE* handle to complete." }
{ $errors "Throws an error if the output operation failed." } ;
HELP: fclose "( alien -- )"
HELP: fclose ( alien -- )
{ $values { "alien" "a C FILE* handle" } }
{ $description "Closes a C FILE* handle." } ;
HELP: fgetc "( alien -- ch )"
HELP: fgetc ( alien -- ch )
{ $values { "alien" "a C FILE* handle" } { "ch" "a character" } }
{ $description "Reads a single character from a C FILE* handle." }
{ $errors "Throws an error if the input operation failed." } ;
HELP: c-stream-error "( -- )"
HELP: c-stream-error
{ $error-description "This error is thrown when C stream I/O is in use and one of the TCP/IP networking words is called. C stream I/O will be in use if either the " { $snippet "-no-native-io" } " switch is passed to bootstrap (see " { $link "bootstrap-cli-args" } ") or if Factor does not have a native I/O implementation for your operating system." } ;

View File

@ -13,7 +13,8 @@ C: duplex-stream ( in out -- stream )
[ set-duplex-stream-in ] keep ;
TUPLE: check-closed ;
: check-closed ( duplex -- )
: check-closed ( stream -- )
duplex-stream-closed? [ <check-closed> throw ] when ;
: duplex-stream-in+ ( duplex -- stream )

View File

@ -6,28 +6,28 @@ strings styles ;
! Words for accessing filesystem meta-data.
: path+ ( path path -- path )
: path+ ( str1 str2 -- str )
over "/" tail? [ append ] [ "/" swap append3 ] if ;
: exists? ( file -- ? ) stat >boolean ;
: exists? ( path -- ? ) stat >boolean ;
: directory? ( file -- ? ) stat first ;
: directory? ( path -- ? ) stat first ;
: directory ( dir -- list )
: directory ( path -- seq )
(directory)
[ { "." ".." } member? not ] subset natural-sort ;
: file-length ( file -- length ) stat third ;
: file-length ( path -- n ) stat third ;
: parent-dir ( path -- path )
: parent-dir ( path -- parent )
CHAR: / over last-index CHAR: \\ pick last-index max
dup -1 = [ 2drop "." ] [ head ] if ;
: resource-path ( path -- path )
: resource-path ( resource -- path )
\ resource-path get [ image parent-dir ] unless*
swap path+ ;
: <resource-reader> ( path -- stream )
: <resource-reader> ( resource -- stream )
resource-path <file-reader> ;
TUPLE: pathname string ;
@ -45,5 +45,5 @@ DEFER: directory.
tuck path+
dup directory? [ (directory.) ] [ (file.) terpri ] if ;
: directory. ( dir -- )
: directory. ( path -- )
dup directory [ file. ] each-with ;

View File

@ -1,16 +1,16 @@
USING: help io ;
USING: help io styles ;
HELP: cwd "( -- path )"
HELP: cwd ( -- path )
{ $values { "path" "a path name string" } }
{ $description "Outputs the current working directory of the Factor process." }
{ $see-also cd } ;
HELP: cd "( path -- )"
HELP: cd ( path -- )
{ $values { "path" "a path name string" } }
{ $description "Changes the current working directory of the Factor process." }
{ $see-also cwd } ;
HELP: stat "( path -- array/f )"
HELP: stat ( path -- array/f )
{ $values { "path" "a path name string" } { "array/f" "a four-element array or " { $link f } } }
{ $description
"If the file does not exist, outputs " { $link f } ". Otherwise, outputs a four-element array:"
@ -22,11 +22,11 @@ HELP: stat "( path -- array/f )"
}
} ;
HELP: path+ "( str1 str2 -- str )"
HELP: path+
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two path names." } ;
HELP: exists? "( path -- ? )"
HELP: exists?
{ $values { "path" "a string" } { "?" "a boolean" } }
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
@ -34,22 +34,30 @@ HELP: directory? "( path -- ? )"
{ $values { "path" "a string" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "path" } " names a directory." } ;
HELP: directory "( path -- seq )"
HELP: directory
{ $values { "path" "a string" } { "seq" "a sequence of file name strings" } }
{ $description "Outputs a sorted sequence of file names stored in the directory named by " { $snippet "path" } "." } ;
HELP: file-length "( path -- n )"
HELP: file-length
{ $values { "path" "a string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
HELP: resource-path "( resource -- path )"
{ $values { "resource" "a string" } { "path" "a string" } }
{ $description "Resolve a path relative to the Factor source code location." } ;
HELP: parent-dir
{ $values { "path" "a string" } { "parent" "a string" } }
{ $description "Strips the last component off a path name." }
{ $examples { $example "\"/etc/passwd\" parent-dir print" "/etc" } } ;
HELP: <resource-reader> "( resource -- stream )"
HELP: resource-path
{ $values { "resource" "a string" } { "path" "a string" } }
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
HELP: <resource-reader>
{ $values { "resource" "a string" } { "stream" "an input stream" } }
{ $description "Opens a file relative to the Factor source code location." } ;
HELP: directory. "( path -- )"
HELP: pathname
{ $class-description "Class of path name presentations. Instances can be used as the value associated to the " { $link presented } " key in the style hashtable passed to " { $link stream-format } " to output a clickable path name." } ;
HELP: directory.
{ $values { "path" "a string" } }
{ $description "Prints a directory listing to the " { $link stdio } " stream. If the stream supports it, subdirectories are shown as expandable outliners." } ;

View File

@ -6,7 +6,7 @@ vectors ;
TUPLE: line-reader cr ;
C: line-reader ( stream -- line ) [ set-delegate ] keep ;
C: line-reader ( stream -- new-stream ) [ set-delegate ] keep ;
: cr> dup line-reader-cr f rot set-line-reader-cr ;
@ -41,6 +41,6 @@ M: line-reader stream-read
drop
] if ;
: (lines) ( seq -- seq ) readln [ , (lines) ] when* ;
: (lines) ( -- ) readln [ , (lines) ] when* ;
: lines ( stream -- seq ) [ [ (lines) ] { } make ] with-stream ;

View File

@ -1,10 +1,10 @@
USING: help io ;
HELP: <line-reader> "( stream -- new-stream )"
HELP: <line-reader>
{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } }
{ $description "Wraps an input stream in a stream supporting the " { $link stream-readln } " generic word." }
{ $notes "Stream constructors should call this word to wrap streams that do not natively support reading lines. Unix (" { $snippet "\\n" } "), Windows (" { $snippet "\\r\\n" } ") and MacOS (" { $snippet "\\r" } ") line endings are supported." } ;
HELP: lines "( stream -- seq )"
HELP: lines
{ $values { "stream" "an input stream" } { "seq" "a sequence of strings" } }
{ $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ;

View File

@ -0,0 +1,7 @@
IN: io
USING: help ;
HELP: (with-stream-style)
{ $values { "quot" "a quotation" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $description "Wraps the stream in a " { $link nested-style-stream } " and calls the quotation in a dynamic scope where " { $link stdio } " is rebound to the new stream." }
{ $notes "This word provides a default implementation for the " { $link with-stream-style } " generic word that methods can call. It should not be used outside this context, since some streams require a custom definition of " { $link with-stream-style } "." } ;

View File

@ -1,6 +1,7 @@
USING: help io ;
HELP: <plain-writer> "( stream -- new-stream )"
HELP: <plain-writer>
{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } }
{ $description "Wraps an input stream in a stream supporting the extended stream output protocol in a trivial way." }
{ $notes "Stream constructors should call this word to wrap streams that do not natively support the extended stream output protocol." } ;
{ $notes "Stream constructors should call this word to wrap streams that do not natively support the extended stream output protocol." }
{ $see "stream-protocol" } ;

View File

@ -6,12 +6,12 @@ threads ;
SYMBOL: log-stream
: log-message ( msg -- )
: log-message ( str -- )
log-stream get [ stream-print ] keep stream-flush ;
: log-error ( error -- ) "Error: " swap append log-message ;
: log-error ( str -- ) "Error: " swap append log-message ;
: log-client ( client-stream -- )
: log-client ( client -- )
[
"Accepted connection from " %
dup client-stream-host %
@ -19,7 +19,7 @@ SYMBOL: log-stream
client-stream-port #
] "" make log-message ;
: with-log-file ( file quot -- )
: with-log-file ( path quot -- )
[ swap <file-writer> log-stream set call ] with-scope ;
: with-logging ( quot -- )

View File

@ -1,40 +1,40 @@
USING: help io ;
HELP: log-stream f
{ $description "Variable. Holds an output stream for logging messages." }
HELP: log-stream
{ $var-description "Holds an output stream for logging messages." }
{ $see-also log-error log-client with-log-file with-logging } ;
HELP: log-message "( str -- )"
HELP: log-message
{ $values { "str" "a string" } }
{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." }
{ $see-also log-error log-client } ;
HELP: log-error "( str -- )"
HELP: log-error
{ $values { "str" "a string" } }
{ $description "Logs an error message." }
{ $see-also log-message log-client } ;
HELP: log-client "( client -- )"
HELP: log-client
{ $values { "client" "a client socket stream" } }
{ $description "Logs an incoming client connection." }
{ $see-also log-message log-error } ;
HELP: with-log-file "( path quot -- )"
HELP: with-log-file
{ $values { "path" "a string" } { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file output stream writing to " { $snippet "path" } "." } ;
HELP: with-logging "( quot -- )"
HELP: with-logging
{ $values { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to the " { $link stdio } " stream " { $emphasis "at this point in time" } "." } ;
HELP: with-client "( quot client -- )"
HELP: with-client
{ $values { "quot" "a quotation" } { "client" "a client socket stream" } }
{ $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ;
HELP: server-stream f
{ $description "Variable. Current server socket, set by " { $link with-server } "." } ;
HELP: server-stream
{ $var-description "Current server socket, set by " { $link with-server } "." } ;
HELP: with-server "( port ident quot -- )"
HELP: with-server
{ $values { "port" "an integer from 0 to 65535" } { "ident" "a symbol" } { "quot" "a quotation" } }
{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being the " { $link stdio } " stream. Client connections are logged to the " { $link stdio } " stream at the time the server was started."
$terpri

View File

@ -9,16 +9,16 @@ SYMBOL: stdio
: close ( -- ) stdio get stream-close ;
: readln ( -- string/f ) stdio get stream-readln ;
: read1 ( -- char/f ) stdio get stream-read1 ;
: read ( count -- string ) stdio get stream-read ;
: readln ( -- str/f ) stdio get stream-readln ;
: read1 ( -- ch/f ) stdio get stream-read1 ;
: read ( n -- str/f ) stdio get stream-read ;
: write1 ( char -- ) stdio get stream-write1 ;
: write ( string -- ) stdio get stream-write ;
: write1 ( ch -- ) stdio get stream-write1 ;
: write ( str -- ) stdio get stream-write ;
: flush ( -- ) stdio get stream-flush ;
: terpri ( -- ) stdio get stream-terpri ;
: format ( string style -- ) stdio get stream-format ;
: format ( str style -- ) stdio get stream-format ;
: with-nesting ( style quot -- )
swap stdio get with-nested-stream ;
@ -40,8 +40,8 @@ SYMBOL: stdio
: bl ( -- ) " " write ;
: write-object ( string object -- )
: write-object ( str obj -- )
presented associate format ;
: write-outliner ( string object content -- )
: write-outliner ( str obj content -- )
outline associate [ write-object ] with-nesting ;

View File

@ -1,88 +1,95 @@
USING: help io ;
HELP: stdio f
{ $description "Variable. Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
HELP: stdio
{ $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
HELP: close "( -- )"
HELP: close
{ $contract "Closes the " { $link stdio } " stream." }
$io-error ;
HELP: readln "( -- str/f )"
HELP: readln
{ $values { "str/f" "a string or " { $link f } } }
{ $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read1 "( -- ch/f )"
HELP: read1
{ $values { "ch/f" "a character or " { $link f } } }
{ $contract "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read "( n -- str/f )"
HELP: read
{ $values { "str/f" "a string or " { $link f } } }
{ $contract "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
$io-error ;
HELP: write1 "( ch -- )"
HELP: write1
{ $values { "ch" "a character" } }
{ $contract "Writes a character of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: write1 "( ch -- )"
{ $values { "ch" "a character" } }
{ $contract "Writes a character of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: write "( str -- )"
HELP: write
{ $values { "str" "a string" } }
{ $contract "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: flush "( -- )"
HELP: flush
{ $contract "Waits for any pending output to the " { $link stdio } " stream to complete." }
$io-error ;
HELP: terpri "( -- )"
HELP: terpri
{ $contract "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: format "( str style -- )"
HELP: format
{ $values { "str" "a string" } { "style" "a hashtable" } }
{ $contract "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: with-nesting "( style quot -- )"
HELP: with-nesting
{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
{ $contract "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: print "( style -- )"
{ $values { "style" "a hashtable" } }
HELP: tabular-output
{ $values { "grid" "a sequence of equal-length sequences" } { "style" "a hashtable" } { "quot" "a quotation" } }
{ $description "Calls the quotation with each element of the grid in turn, each time in a new dynamic scope with " { $link stdio } " rebound to a new stream. The results are laid out in a tabular fashion on the " { $link stdio } " stream." }
{ $notes "Details are in the documentation for " { $link with-stream-table } "." }
$io-error ;
HELP: with-style
{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link with-stream-style } "." }
$io-error ;
HELP: print
{ $values { "string" "a string" } }
{ $description "Writes a newline-terminated string to the " { $link stdio } " stream." }
$io-error ;
HELP: with-stream "( stream quot -- )"
HELP: with-stream
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." }
{ $see-also with-stream* } ;
HELP: with-stream* "( stream quot -- )"
HELP: with-stream*
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } "." }
{ $notes "This word differs from " { $link with-stream } " in that if an error is thrown while the quotation is executing, the stream is " { $emphasis "not" } " closed." }
{ $see-also with-stream } ;
HELP: bl "( -- )"
HELP: bl
{ $description "Outputs a space character (" { $snippet "\" \"" } ")." }
$io-error ;
HELP: write-object "( str obj -- )"
HELP: write-object
{ $values { "str" "a string" } { "obj" "an object" } }
{ $description "Writes a string to the " { $link stdio } " stream, associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." }
$io-error ;
HELP: write-outliner "( str obj content -- )"
HELP: write-outliner
{ $values { "str" "a string" } { "obj" "an object" } { "content" "a quotation" } }
{ $description "Writes an outliner to the " { $link stdio } " stream. The outliner's caption is a the string " { $snippet "str" } " with an associated presentation of " { $snippet "obj" } ". Expanding the outliner calls " { $snippet "content" } " in a new dynamic scope with " { $link stdio } " rebound to the body of the outliner. If the stream does not support formatted output, this simply writes " { $snippet "str" } " and ignores everything else." }
$io-error ;

View File

@ -5,15 +5,15 @@ USING: errors hashtables generic kernel math namespaces
sequences strings ;
GENERIC: stream-close ( stream -- )
GENERIC: set-timeout ( timeout stream -- )
GENERIC: stream-readln ( stream -- string )
GENERIC: stream-read1 ( stream -- char/f )
GENERIC: stream-read ( count stream -- string )
GENERIC: stream-write1 ( char stream -- )
GENERIC: stream-write ( string stream -- )
GENERIC: set-timeout ( n stream -- )
GENERIC: stream-readln ( stream -- str )
GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f )
GENERIC: stream-write1 ( ch stream -- )
GENERIC: stream-write ( str stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-terpri ( stream -- )
GENERIC: stream-format ( string style stream -- )
GENERIC: stream-format ( str style stream -- )
GENERIC: with-nested-stream ( quot style stream -- )
GENERIC: with-stream-table ( grid quot style stream -- )
GENERIC: with-stream-style ( quot style stream -- )

View File

@ -1,53 +1,53 @@
USING: help io ;
HELP: stream-close "( stream -- )"
HELP: stream-close
{ $values { "stream" "a stream" } }
{ $contract "Closes the stream. This releases any external resources associated with the stream, such as file handles and network connections. No further operations can be performed on the stream after this call." }
{ $notes "You must close streams after you are finished working with them. A convenient way to automate this is by using the " { $link with-stream } " word." }
$io-error ;
HELP: set-timeout "( n stream -- )"
HELP: set-timeout
{ $values { "n" "an integer" } { "stream" "a stream" } }
{ $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." }
$io-error ;
HELP: stream-readln "( stream -- str )"
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" "a string" } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: stream-read1 "( stream -- ch/f )"
HELP: stream-read1
{ $values { "stream" "an input stream" } }
{ $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: stream-read "( n stream -- str )"
{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str" "a string" } }
HELP: stream-read
{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
{ $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
$io-error ;
HELP: stream-write1 "( ch stream -- )"
HELP: stream-write1
{ $values { "ch" "a character" } { "stream" "an output stream" } }
{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
$io-error ;
HELP: stream-write "( str stream -- )"
HELP: stream-write
{ $values { "str" "a string" } { "stream" "an output stream" } }
{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
$io-error ;
HELP: stream-flush "( stream -- )"
HELP: stream-flush
{ $values { "stream" "an output stream" } }
{ $contract "Waits for any pending output to complete." }
{ $notes "With many output streams, written output is buffered and not sent to the underlying resource until either the buffer is full, or this word is called." }
$io-error ;
HELP: stream-terpri "( stream -- )"
HELP: stream-terpri
{ $values { "stream" "an output stream" } }
{ $contract "Writes a line terminator. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
$io-error ;
HELP: stream-format "( str style stream -- )"
HELP: stream-format
{ $values { "str" "a string" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
$terpri
@ -58,15 +58,32 @@ HELP: with-nested-stream "( quot style stream -- )"
{ $values { "quot" "a quotation" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $contract "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied."
$terpri
"Unlike " { $link with-stream-style } ", this creates a new paragraph block in the output."
$terpri
"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
$io-error ;
HELP: stream-print "( str stream -- )"
HELP: with-stream-table
{ $values { "grid" "a sequence of equal-length sequences" } { "quot" "a quotation" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $description "Calls the quotation with each element of the grid in turn, each time in a new dynamic scope with " { $link stdio } " rebound to a new stream. The results are laid out in a tabular fashion on " { $snippet "stream" } "."
$terpri
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
$io-error ;
HELP: with-stream-style
{ $values { "style" "a hashtable" } { "quot" "a quotation" } { "stream" "an output stream" } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "."
$terpri
"Unlike " { $link with-nested-stream } ", the quotation's output is inline, and not nested in a paragraph block." }
{ $notes "Details are in the documentation for " { $link with-stream-style } "." }
$io-error ;
HELP: stream-print
{ $values { "str" "a string" } { "stream" "an output stream" } }
{ $description "Writes a newline-terminated string." }
$io-error ;
HELP: stream-copy "( in out -- )"
HELP: stream-copy
{ $values { "in" "an input stream" } { "out" "an output stream" } }
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;

View File

@ -3,7 +3,6 @@
IN: io
USING: io kernel math namespaces sequences strings ;
! String buffers support the stream output protocol.
M: sbuf stream-write1 push ;
M: sbuf stream-write swap nappend ;
M: sbuf stream-close drop ;
@ -35,7 +34,6 @@ M: plain-writer with-stream-table
[ print ] each
] with-stream* ;
! Reversed string buffers support the stream input protocol.
M: sbuf stream-read1
dup empty? [ drop f ] [ pop ] if ;
@ -47,12 +45,11 @@ M: sbuf stream-read
[ [ drop pop ] inject-with ] keep
] if ;
: <string-reader> ( string -- stream )
: <string-reader> ( str -- stream )
<reversed> >sbuf <line-reader> ;
: string-in ( str quot -- )
>r <string-reader> r> with-stream ; inline
: contents ( stream -- string )
#! Read the entire stream into a string.
: contents ( stream -- str )
<string-writer> [ stream-copy ] keep >string ;

View File

@ -1,23 +1,23 @@
USING: help io strings ;
HELP: <string-writer> "( -- stream )"
HELP: <string-writer>
{ $values { "stream" "an output stream" } }
{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
HELP: string-out "( quot -- str )"
HELP: string-out
{ $values { "quot" "a quotation" } { "str" "a string" } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ;
HELP: <string-reader> "( str -- stream )"
HELP: <string-reader>
{ $values { "str" "a string" } { "stream" "an input stream" } }
{ $description "Creates a new stream for reading " { $snippet "str" } " from beginning to end." }
{ $notes "The implementation exploits the ability of string buffers to respond to the input stream protocol by reading characters from the end of the buffer." } ;
HELP: string-in "( str quot -- )"
HELP: string-in
{ $values { "str" "a string" } { "quot" "a quotation" } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end. The accumulated string is output when the quotation returns." } ;
HELP: contents "( stream -- str )"
HELP: contents
{ $values { "stream" "an input stream" } { "str" "a string" } }
{ $description "Reads the contents of a stream into a string." }
$io-error ;

View File

@ -1,18 +1,18 @@
USING: help styles io ;
HELP: plain f
HELP: plain
{ $description "A value for the " { $link font-style } " character style denoting plain text." } ;
HELP: bold f
HELP: bold
{ $description "A value for the " { $link font-style } " character style denoting boldface text." } ;
HELP: italic f
HELP: italic
{ $description "A value for the " { $link font-style } " character style denoting italicized text." } ;
HELP: bold-italic f
HELP: bold-italic
{ $description "A value for the " { $link font-style } " character style denoting boldface italicized text." } ;
HELP: foreground f
HELP: foreground
{ $description "Character style. Text color, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
{ $examples
{ $code
@ -23,7 +23,7 @@ HELP: foreground f
}
} ;
HELP: background f
HELP: background
{ $description "Character style. Background color, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
{ $examples
{ $code
@ -34,59 +34,71 @@ HELP: background f
}
} ;
HELP: font f
HELP: font
{ $description "Character style. Font family named by a string." }
{ $examples
"This example outputs some different font sizes:"
{ $code "{ \"Monospaced\" \"Serif\" \"Sans Serif\" }\n[ dup font associate format terpri ] each" }
} ;
HELP: font-size f
HELP: font-size
{ $description "Character style. Font size, an integer." }
{ $examples
"This example outputs some different font sizes:"
{ $code "\"Bigger\" { 12 18 24 72 }\n[ font-size associate format terpri ] each-with" }
} ;
HELP: font-style f
HELP: font-style
{ $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." }
{ $examples
"This example outputs text in all three styles:"
{ $code "{ plain bold italic bold-italic }\n[ [ word-name ] keep font-style associate format terpri ] each" }
} ;
HELP: presented f
HELP: presented
{ $description "Character and paragraph style. An object associated with the text. In the Factor UI, this is shown as a clickable presentation of the object; left-clicking invokes a default command, and right-clicking shows a menu of commands." }
{ $see-also write-object } ;
HELP: page-color f
HELP: highlight
{ $description "Character style. Used to mark up text on streams that otherwise do not support different colors or font styles." }
{ $examples "Instances of " { $link plain-writer } " uppercases highlighted text." } ;
HELP: page-color
{ $description "Paragraph style. Background color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
{ $examples
{ $code "H{ { page-color { 1 0.8 0.5 1 } } }\n[ \"A background\" write ] with-nesting terpri" }
} ;
HELP: border-color f
HELP: border-color
{ $description "Paragraph style. Border color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
{ $examples
{ $code "H{ { border-color { 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting terpri" }
} ;
HELP: border-width f
HELP: border-width
{ $description "Paragraph style. Pixels between edge of text and border color, an integer." }
{ $examples
{ $code "H{ { border-width 10 } }\n[ \"Some inset text\" write ] with-nesting terpri" }
} ;
HELP: wrap-margin f
HELP: wrap-margin
{ $description "Paragraph style. Pixels between left margin and right margin where text is wrapped, an integer." }
{ $see-also bl } ;
HELP: outline f
HELP: outline
{ $description "Paragraph style. In the Factor UI, a quotation executed to produce outliner content when the outliner widget next to the paragraph block is expanded." }
{ $see-also write-outliner } ;
HELP: input f
{ $description "A wrapper class. In the Factor UI, presentations of this class are output as blocks of text which insert themselves in the listener's input area when clicked." }
HELP: table-gap
{ $description "Table style. Pixels between table cells." }
{ $see-also with-stream-table tabular-output } ;
HELP: table-border
{ $description "Table style. Color of the border drawn between cells, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
{ $see-also with-stream-table tabular-output } ;
HELP: input
{ $class-description "Class of input text presentations.A wrapper class. Instances can be used passed to " { $link write-object } " to output a clickable piece of input." }
{ $examples
"This presentation class is used for the code examples you see in the online help:"
{ $code "\"2 3 + .\" dup <input> write-object terpri" }

View File

@ -146,7 +146,7 @@ GENERIC: task-container ( task -- vector )
read-fdset/tasks init-fdset
write-fdset/tasks init-fdset f ;
: io-multiplex ( timeout -- )
: io-multiplex ( ms -- )
>r FD_SETSIZE init-fdsets r> make-timeval select io-error
read-fdset/tasks handle-fdset
write-fdset/tasks handle-fdset ;

View File

@ -10,7 +10,7 @@ USING: compiler namespaces kernel win32-io-internals win32-stream win32-api
IN: io-internals
: io-multiplex ( timeout -- )
: io-multiplex ( ms -- )
#! FIXME: needs to work given a timeout
dup -1 = [ drop INFINITE ] when cancel-timedout wait-for-io
swap [ schedule-thread-with ] [ drop ] if* ;

View File

@ -3,16 +3,32 @@
IN: math
USING: kernel math math-internals ;
: acosh dup sq 1- sqrt + log ; inline
: asech recip acosh ; inline
: asinh dup sq 1+ sqrt + log ; inline
: acosech recip asinh ; inline
: atanh dup 1+ swap 1- neg / log 2 / ; inline
: acoth recip atanh ; inline
: [-1,1]? ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] if ; inline
: asin dup [-1,1]? [ fasin ] [ i * asinh -i * ] if ; inline
: acos dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline
: atan dup [-1,1]? [ fatan ] [ i * atanh i * ] if ; inline
: asec recip acos ; inline
: acosec recip asin ; inline
: acot recip atan ; inline
: acosh ( x -- y ) dup sq 1- sqrt + log ; inline
: asech ( x -- y ) recip acosh ; inline
: asinh ( x -- y ) dup sq 1+ sqrt + log ; inline
: acosech ( x -- y ) recip asinh ; inline
: atanh ( x -- y ) dup 1+ swap 1- neg / log 2 / ; inline
: acoth ( x -- y ) recip atanh ; inline
: [-1,1]? ( x -- ? )
dup complex? [ drop f ] [ abs 1 <= ] if ; inline
: asin ( x -- y )
dup [-1,1]? [ fasin ] [ i * asinh -i * ] if ; inline
: acos ( x -- y )
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline
: atan ( x -- y )
dup [-1,1]? [ fatan ] [ i * atanh i * ] if ; inline
: asec ( x -- y ) recip acos ; inline
: acosec ( x -- y ) recip asin ; inline
: acot ( x -- y ) recip atan ; inline

View File

@ -1,57 +1,57 @@
USING: help math ;
HELP: acosh "( x -- y )"
HELP: acosh
$values-x/y
{ $description "Inverse hyperbolic cosine." } ;
HELP: asech "( x -- y )"
HELP: asech
$values-x/y
{ $description "Inverse hyperbolic secant." } ;
HELP: asinh "( x -- y )"
HELP: asinh
$values-x/y
{ $description "Inverse hyperbolic sine." } ;
HELP: asinh "( x -- y )"
HELP: asinh
$values-x/y
{ $description "Inverse hyperbolic sine." } ;
HELP: acosech "( x -- y )"
HELP: acosech
$values-x/y
{ $description "Inverse hyperbolic cosecant." } ;
HELP: atanh "( x -- y )"
HELP: atanh
$values-x/y
{ $description "Inverse hyperbolic tangent." } ;
HELP: acoth "( x -- y )"
HELP: acoth
$values-x/y
{ $description "Inverse hyperbolic cotangent." } ;
HELP: acos "( x -- y )"
HELP: acos
$values-x/y
{ $description "Inverse trigonometric cosine." } ;
HELP: asec "( x -- y )"
HELP: asec
$values-x/y
{ $description "Inverse trigonometric secant." } ;
HELP: asin "( x -- y )"
HELP: asin
$values-x/y
{ $description "Inverse trigonometric sine." } ;
HELP: asin "( x -- y )"
HELP: asin
$values-x/y
{ $description "Inverse trigonometric sine." } ;
HELP: acosec "( x -- y )"
HELP: acosec
$values-x/y
{ $description "Inverse trigonometric cosecant." } ;
HELP: atan "( x -- y )"
HELP: atan
$values-x/y
{ $description "Inverse trigonometric tangent." } ;
HELP: acot "( x -- y )"
HELP: acot
$values-x/y
{ $description "Inverse trigonometric cotangent." } ;

View File

@ -3,7 +3,7 @@
IN: math-internals
USING: errors generic kernel kernel-internals math ;
: (rect>) ( xr xi -- x )
: (rect>) ( x y -- z )
dup zero? [ drop ] [ <complex> ] if ; inline
IN: math
@ -15,14 +15,14 @@ M: real imaginary drop 0 ;
M: number equal? number= ;
: rect> ( xr xi -- x )
: rect> ( x y -- z )
over real? over real? and [
(rect>)
] [
"Complex number must have real components" throw
] if ; inline
: >rect ( x -- xr xi ) dup real swap imaginary ; inline
: >rect ( z -- x y ) dup real swap imaginary ; inline
: conjugate ( z -- z* ) >rect neg rect> ; inline
@ -31,7 +31,7 @@ M: number equal? number= ;
: >polar ( z -- abs arg )
dup abs swap >rect swap fatan2 ; inline
: cis ( theta -- cis ) dup fcos swap fsin rect> ; inline
: cis ( arg --- z ) dup fcos swap fsin rect> ; inline
: polar> ( abs arg -- z ) cis * ; inline

View File

@ -1,59 +1,59 @@
USING: help math math-internals ;
HELP: complex f
{ $description "The class of complex numbers with non-zero imaginary part." } ;
HELP: complex
{ $class-description "The class of complex numbers with non-zero imaginary part." } ;
HELP: real "( z -- x )"
HELP: real ( z -- x )
{ $values { "z" "a complex number" } { "x" "a real number" } }
{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." }
{ $notes "This word also acts as the class word for the class of real numbers, which is a disjoint union of rationals and floats." } ;
HELP: imaginary "( z -- y )"
HELP: imaginary ( z -- y )
{ $values { "z" "a complex number" } { "y" "a real number" } }
{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
HELP: (rect>) "( x y -- z )"
HELP: (rect>)
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } }
{ $description "Creates a complex number from real and imaginary components." }
{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ;
HELP: number f
{ $description "The class of numbers." } ;
HELP: number
{ $class-description "The class of numbers." } ;
HELP: rect> "( x y -- z )"
HELP: rect>
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } }
{ $description "Creates a complex number from real and imaginary components." } ;
HELP: >rect "( z -- x y )"
HELP: >rect
{ $values { "z" "a complex number" } { "x" "a real number" } { "y" "a real number" } }
{ $description "Extracts the real and imaginary components of a complex number." } ;
HELP: conjugate "( z -- z* )"
HELP: conjugate
{ $values { "z" "a complex number" } { "z*" "a complex number" } }
{ $description "Computes the complex conjugate by flipping the sign of the imaginary part of " { $snippet "z" } "." } ;
HELP: arg "( z -- arg )"
HELP: arg
{ $values { "z" "a complex number" } { "arg" "a number in the interval " { $snippet "(-pi,pi]" } } }
{ $description "Computes the complex argument." } ;
HELP: >polar "( z -- abs arg )"
HELP: >polar
{ $values { "z" "a complex number" } { "abs" "a non-negative real number" } { "arg" "a number in the interval " { $snippet "(-pi,pi]" } } }
{ $description "Creates a complex number from an absolute value and argument (polar form)." } ;
HELP: cis "( arg --- z )"
HELP: cis
{ $values { "arg" "a real number" } { "z" "a complex number on the unit circle" } }
{ $description "Computes a point on the unit circle using Euler's formula for " { $snippet "exp(arg*i)" } "." }
{ $see-also exp } ;
HELP: polar> "( abs arg -- z )"
HELP: polar>
{ $values { "z" "a complex number" } { "abs" "a non-negative real number" } { "arg" "a real number" } }
{ $description "Converts an absolute value and argument (polar form) to a complex number." } ;
HELP: 2>rect "( x y -- xr xi yr yi )"
HELP: 2>rect
{ $values { "x" "a complex number" } { "y" "a complex number" } { "xr" "real part of " { $snippet "x" } } { "xi" "imaginary part of " { $snippet "x" } } { "yr" "real part of " { $snippet "y" } } { "yi" "imaginary part of " { $snippet "y" } } }
{ $description "Extracts real and imaginary components of two numbers at once." } ;
HELP: complex/ "( x y -- r i m )"
HELP: complex/
{ $values { "x" "a complex number" } { "y" "a complex number" } { "r" "a real number" } { "i" "a real number" } { "m" "a real number" } }
{ $description
"Complex division kernel. If we use the notation from " { $link 2>rect } ", this word computes:"
@ -64,6 +64,6 @@ HELP: complex/ "( x y -- r i m )"
}
} ;
HELP: <complex> "( x y -- z )"
HELP: <complex> ( x y -- z )
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } }
{ $description "Low-level complex number constructor. User code should call " { $link rect> } " instead." } ;

View File

@ -4,10 +4,10 @@ IN: kernel-internals
USING: kernel namespaces math ;
: bootstrap-cell \ cell get ; inline
: cells cell * ; inline
: cells ( m -- n ) cell * ; inline
: bootstrap-cells bootstrap-cell * ; inline
: cell-bits 8 cells ; inline
: cell-bits ( -- n ) 8 cells ; inline
: bootstrap-cell-bits 8 bootstrap-cells ; inline
: tag-address ( x tag -- tagged ) swap tag-bits shift bitor ;
@ -15,11 +15,14 @@ USING: kernel namespaces math ;
IN: math
: i C{ 0 1 } ; inline
: -i C{ 0 -1 } ; inline
: e 2.7182818284590452354 ; inline
: pi 3.14159265358979323846 ; inline
: epsilon 2.2204460492503131e-16 ; inline
: first-bignum 1 bootstrap-cell-bits tag-bits - 1- shift ;
: most-positive-fixnum first-bignum 1- ;
: most-negative-fixnum first-bignum neg ;
: i ( -- i ) C{ 0 1 } ; inline
: -i ( -- -i ) C{ 0 -1 } ; inline
: e ( -- e ) 2.7182818284590452354 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
: first-bignum ( -- n )
1 bootstrap-cell-bits tag-bits - 1- shift ;
: most-positive-fixnum ( -- n ) first-bignum 1- ;
: most-negative-fixnum ( -- n ) first-bignum neg ;

View File

@ -1,33 +1,33 @@
USING: help kernel-internals math ;
HELP: cells "( m -- n )"
HELP: cells
{ $values { "m" "an integer" } { "n" "an integer" } }
{ $description "Computes the number of bytes corresponding to " { $snippet "m" } " CPU operand-sized cells." } ;
HELP: cell-bits "( m -- n )"
{ $values { "m" "an integer" } { "n" "an integer" } }
{ $description "Computes the number of bits corresponding to " { $snippet "m" } " CPU operand-sized cells." } ;
HELP: cell-bits
{ $values { "n" "an integer" } }
{ $description "Outputs the number of bits in one CPU operand-sized cell." } ;
HELP: i "( -- i )"
HELP: i
{ $values { "i" "the imaginary unit" } } ;
HELP: -i "( -- -i )"
{ $values { "i" "the negated imaginary unit" } } ;
HELP: -i
{ $values { "-i" "the negated imaginary unit" } } ;
HELP: e "( -- e )"
HELP: e
{ $values { "e" "base of natural logarithm" } } ;
HELP: pi "( -- pi )"
HELP: pi
{ $values { "pi" "circumference of circle with diameter 1" } } ;
HELP: epsilon "( -- epsilon )"
HELP: epsilon
{ $values { "epsilon" "smallest floating point value you can add to 1 without underflow" } } ;
HELP: first-bignum "( -- n )"
HELP: first-bignum
{ $values { "n" "smallest positive integer not representable by a fixnum" } } ;
HELP: most-positive-fixnum "( -- n )"
HELP: most-positive-fixnum
{ $values { "n" "largest positive integer representable by a fixnum" } } ;
HELP: most-negative-fixnum "( -- n )"
HELP: most-negative-fixnum
{ $values { "n" "smallest negative integer representable by a fixnum" } } ;

View File

@ -1,74 +1,74 @@
USING: help math math-internals ;
HELP: float f
{ $description "The class of double-precision floating point numbers." } ;
HELP: float
{ $class-description "The class of double-precision floating point numbers." } ;
HELP: >float "( x -- y )"
HELP: >float ( x -- y )
{ $values { "x" "a real number" } { "y" "a float" } }
{ $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ;
HELP: bits>double "( n -- x )"
HELP: bits>double ( n -- x )
{ $values { "n" "a 64-bit integer representing an 754 double-precision float" } { "x" "a float" } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." }
{ $see-also bits>float double>bits float>bits } ;
HELP: bits>float "( n -- x )"
HELP: bits>float ( n -- x )
{ $values { "n" "a 32-bit integer representing an 754 single-precision float" } { "x" "a float" } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." }
{ $see-also bits>double double>bits float>bits } ;
HELP: double>bits "( x -- n )"
HELP: double>bits ( x -- n )
{ $values { "x" "a float" } { "n" "a 64-bit integer representing an 754 double-precision float" } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." }
{ $see-also bits>double bits>float float>bits } ;
HELP: float>bits "( x -- n )"
HELP: float>bits ( x -- n )
{ $values { "x" "a float" } { "n" "a 32-bit integer representing an 754 single-precision float" } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." }
{ $see-also bits>double bits>float double>bits } ;
! Unsafe primitives
HELP: float+ "( x y -- z )"
HELP: float+ ( x y -- z )
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
{ $description "Primitive version of " { $link + } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link + } " instead." } ;
HELP: float- "( x y -- z )"
HELP: float- ( x y -- z )
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
{ $description "Primitive version of " { $link - } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link - } " instead." } ;
HELP: float* "( x y -- z )"
HELP: float* ( x y -- z )
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
{ $description "Primitive version of " { $link * } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link * } " instead." } ;
HELP: float-mod "( x y -- z )"
HELP: float-mod ( x y -- z )
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
{ $description "Primitive version of " { $link mod } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link mod } " instead." } ;
HELP: float/f "( x y -- z )"
HELP: float/f ( x y -- z )
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
{ $description "Primitive version of " { $link /f } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link /f } " instead." } ;
HELP: float< "( x y -- ? )"
HELP: float< ( x y -- ? )
{ $values { "x" "a float" } { "y" "a float" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link < } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link < } " instead." } ;
HELP: float<= "( x y -- ? )"
HELP: float<= ( x y -- ? )
{ $values { "x" "a float" } { "y" "a float" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link <= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link <= } " instead." } ;
HELP: float> "( x y -- ? )"
HELP: float> ( x y -- ? )
{ $values { "x" "a float" } { "y" "a float" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link > } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link > } " instead." } ;
HELP: float>= "( x y -- ? )"
HELP: float>= ( x y -- ? )
{ $values { "x" "a float" } { "y" "a float" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link >= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;

View File

@ -26,13 +26,13 @@ UNION: integer fixnum bignum ;
>r 1 shift r> (next-power-of-2)
] if ;
: next-power-of-2 ( n -- n ) 2 swap (next-power-of-2) ;
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ;
: d>w/w ( d -- w w )
: d>w/w ( d -- w1 w2 )
dup HEX: ffffffff bitand
swap -32 shift HEX: ffffffff bitand ;
: w>h/h ( w -- h h )
: w>h/h ( w -- h1 h2 )
dup HEX: ffff bitand
swap -16 shift HEX: ffff bitand ;

View File

@ -1,219 +1,228 @@
USING: errors help math math-internals ;
HELP: fixnum f
{ $description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ;
HELP: fixnum
{ $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ;
HELP: >fixnum "( x -- n )"
HELP: >fixnum ( x -- n )
{ $values { "x" "a real number" } { "n" "a fixnum" } }
{ $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ;
HELP: bignum f
{ $description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ;
HELP: bignum
{ $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ;
HELP: >bignum "( x -- n )"
HELP: >bignum ( x -- n )
{ $values { "x" "a real number" } { "n" "a bignum" } }
{ $description "Converts a real number to a bignum, with a possible loss of precision." } ;
HELP: integer f
{ $description "The class of integers, which is a disjoint union of fixnums and bignums." } ;
HELP: integer
{ $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ;
HELP: even? "( n -- ? )"
HELP: even?
{ $values { "n" "an integer" } { "?" "a boolean" } }
{ $description "Tests if an integer is even." } ;
HELP: odd? "( n -- ? )"
HELP: odd?
{ $values { "n" "an integer" } { "?" "a boolean" } }
{ $description "Tests if an integer is odd." } ;
HELP: gcd "( x y -- a d )"
HELP: gcd
{ $values { "x" "an integer" } { "y" "an integer" } { "a" "an integer" } { "d" "an integer" } }
{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
{ $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;
HELP: next-power-of-2 "( m -- n )"
HELP: d>w/w
{ $values { "d" "a 64-bit integer" } { "w1" "a 32-bit integer" } { "w2" "a 32-bit integer" } }
{ $description "Outputs two integers, the least followed by the most significant 32 bits of the input." } ;
HELP: w>h/h
{ $values { "w" "a 32-bit integer" } { "h1" "a 16-bit integer" } { "h2" "a 16-bit integer" } }
{ $description "Outputs two integers, the least followed by the most significant 16 bits of the input." } ;
HELP: next-power-of-2
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
HELP: fraction> "( a b -- a/b )"
HELP: fraction>
{ $values { "a" "an integer" } { "b" "a positive integer" } { "a/b" "a rational number" } }
{ $description "Creates a new ratio, or outputs the numerator if the denominator is 1. This word does not reduce the fraction to lowest terms, and should not be called directly; use " { $link / } " instead." } ;
! Unsafe primitives
HELP: fixnum+ "( x y -- z )"
HELP: fixnum+ ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
{ $description "Primitive version of " { $link + } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link + } " instead." } ;
HELP: fixnum- "( x y -- z )"
HELP: fixnum- ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
{ $description "Primitive version of " { $link - } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link - } " instead." } ;
HELP: fixnum* "( x y -- z )"
HELP: fixnum* ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
{ $description "Primitive version of " { $link * } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link * } " instead." } ;
HELP: fixnum/f "( x y -- z )"
HELP: fixnum/f ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a float" } }
{ $description "Primitive version of " { $link /f } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link /f } " instead." } ;
HELP: fixnum/i "( x y -- z )"
HELP: fixnum/i ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
{ $description "Primitive version of " { $link /i } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link /i } " instead." } ;
HELP: fixnum-mod "( x y -- z )"
HELP: fixnum-mod ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
{ $description "Primitive version of " { $link mod } ". The result always fits in a fixnum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link mod } " instead." } ;
HELP: fixnum/mod "( x y -- z w )"
HELP: fixnum/mod ( x y -- z w )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } { "w" "a fixnum" } }
{ $description "Primitive version of " { $link /mod } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link /mod } " instead." } ;
HELP: fixnum< "( x y -- ? )"
HELP: fixnum< ( x y -- ? )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link < } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link < } " instead." } ;
HELP: fixnum<= "( x y -- z )"
HELP: fixnum<= ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
{ $description "Primitive version of " { $link <= } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link <= } " instead." } ;
HELP: fixnum> "( x y -- ? )"
HELP: fixnum> ( x y -- ? )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link > } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link > } " instead." } ;
HELP: fixnum>= "( x y -- ? )"
HELP: fixnum>= ( x y -- ? )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link >= } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
HELP: fixnum-bitand "( x y -- z )"
HELP: fixnum-bitand ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
{ $description "Primitive version of " { $link bitand } ". The result always fits in a fixnum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link bitand } " instead." } ;
HELP: fixnum-bitor "( x y -- z )"
HELP: fixnum-bitor ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
{ $description "Primitive version of " { $link bitor } ". The result always fits in a fixnum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link bitor } " instead." } ;
HELP: fixnum-bitxor "( x y -- z )"
HELP: fixnum-bitxor ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
{ $description "Primitive version of " { $link bitxor } ". The result always fits in a fixnum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link bitxor } " instead." } ;
HELP: fixnum-bitnot "( x -- y )"
HELP: fixnum-bitnot ( x -- y )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } }
{ $description "Primitive version of " { $link bitnot } ". The result always fits in a fixnum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link bitnot } " instead." } ;
HELP: fixnum-shift "( x y -- z )"
HELP: fixnum-shift ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
{ $description "Primitive version of " { $link shift } ". The result may overflow to a bignum." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
HELP: fixnum+fast "( x y -- z )"
HELP: fixnum+fast ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
{ $description "Primitive version of " { $link + } ". Unlike " { $link fixnum+ } ", does not perform an overflow check, so the result may be incorrect." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link + } " instead." } ;
HELP: fixnum-fast "( x y -- z )"
HELP: fixnum-fast ( x y -- z )
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
{ $description "Primitive version of " { $link - } ". Unlike " { $link fixnum- } ", does not perform an overflow check, so the result may be incorrect." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link - } " instead." } ;
HELP: bignum+ "( x y -- z )"
HELP: bignum+ ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link + } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link + } " instead." } ;
HELP: bignum- "( x y -- z )"
HELP: bignum- ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link - } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link - } " instead." } ;
HELP: bignum* "( x y -- z )"
HELP: bignum* ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link * } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link * } " instead." } ;
HELP: bignum/f "( x y -- z )"
HELP: bignum/f ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a float" } }
{ $description "Primitive version of " { $link /f } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link /f } " instead." } ;
HELP: bignum/i "( x y -- z )"
HELP: bignum/i ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link /i } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link /i } " instead." } ;
HELP: bignum-mod "( x y -- z w )"
HELP: bignum-mod ( x y -- z w )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } { "w" "a bignum" } }
{ $description "Primitive version of " { $link mod } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link mod } " instead." } ;
HELP: bignum/mod "( x y -- z )"
HELP: bignum/mod ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link /mod } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link /mod } " instead." } ;
HELP: bignum< "( x y -- ? )"
HELP: bignum< ( x y -- ? )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link < } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link < } " instead." } ;
HELP: bignum<= "( x y -- ? )"
HELP: bignum<= ( x y -- ? )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link <= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link <= } " instead." } ;
HELP: bignum> "( x y -- ? )"
HELP: bignum> ( x y -- ? )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link > } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link > } " instead." } ;
HELP: bignum>= "( x y -- ? )"
HELP: bignum>= ( x y -- ? )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link >= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
HELP: bignum= "( x y -- ? )"
HELP: bignum= ( x y -- ? )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
{ $description "Primitive version of " { $link number= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link number= } " instead." } ;
HELP: bignum-bitand "( x y -- z )"
HELP: bignum-bitand ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link bitand } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link bitand } " instead." } ;
HELP: bignum-bitor "( x y -- z )"
HELP: bignum-bitor ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link bitor } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link bitor } " instead." } ;
HELP: bignum-bitxor "( x y -- z )"
HELP: bignum-bitxor ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link bitxor } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link bitxor } " instead." } ;
HELP: bignum-bitnot "( x -- y )"
HELP: bignum-bitnot ( x -- y )
{ $values { "x" "a bignum" } { "y" "a bignum" } }
{ $description "Primitive version of " { $link bitnot } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link bitnot } " instead." } ;
HELP: bignum-shift "( x y -- z )"
HELP: bignum-shift ( x y -- z )
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
{ $description "Primitive version of " { $link shift } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
HELP: /0 "( -- )"
HELP: /0
{ $error-description "This error is thrown when " { $link / } " is called with two integer inputs, the denominator being zero." }
{ $notes "Floating point division by zero does not raise an error at all, whereas integer division by zero in " { $link /i } " typically raises an operating system signal (see " { $link signal-error. } ")." } ;

View File

@ -11,39 +11,39 @@ G: <= ( x y -- ? ) math-combination ; foldable
G: > ( x y -- ? ) math-combination ; foldable
G: >= ( x y -- ? ) math-combination ; foldable
G: + ( x y -- x+y ) math-combination ; foldable
G: - ( x y -- x-y ) math-combination ; foldable
G: * ( x y -- x*y ) math-combination ; foldable
G: / ( x y -- x/y ) math-combination ; foldable
G: /i ( x y -- x/y ) math-combination ; foldable
G: /f ( x y -- x/y ) math-combination ; foldable
G: mod ( x y -- x%y ) math-combination ; foldable
G: + ( x y -- z ) math-combination ; foldable
G: - ( x y -- z ) math-combination ; foldable
G: * ( x y -- z ) math-combination ; foldable
G: / ( x y -- z ) math-combination ; foldable
G: /i ( x y -- z ) math-combination ; foldable
G: /f ( x y -- z ) math-combination ; foldable
G: mod ( x y -- z ) math-combination ; foldable
G: /mod ( x y -- x/y x%y ) math-combination ; foldable
G: /mod ( x y -- z w ) math-combination ; foldable
G: bitand ( x y -- z ) math-combination ; foldable
G: bitor ( x y -- z ) math-combination ; foldable
G: bitxor ( x y -- z ) math-combination ; foldable
G: shift ( x n -- y ) math-combination ; foldable
GENERIC: bitnot ( n -- n ) foldable
GENERIC: bitnot ( x -- y ) foldable
GENERIC: abs ( z -- |z| ) foldable
GENERIC: absq ( n -- |n|^2 ) foldable
GENERIC: abs ( x -- y ) foldable
GENERIC: absq ( x -- y ) foldable
GENERIC: zero? ( x -- ? ) foldable
M: object zero? drop f ;
: 1+ 1 + ; foldable
: 1- 1 - ; foldable
: sq dup * ; foldable
: neg 0 swap - ; foldable
: recip 1 swap / ; foldable
: 1+ ( x -- y ) 1 + ; foldable
: 1- ( x -- y ) 1 - ; foldable
: sq ( x -- y ) dup * ; foldable
: neg ( x -- -x ) 0 swap - ; foldable
: recip ( x -- y ) 1 swap / ; foldable
: max ( x y -- z ) [ > ] 2keep ? ; foldable
: min ( x y -- z ) [ < ] 2keep ? ; foldable
: between? ( x min max -- ? ) pick >= >r >= r> and ; foldable
: between? ( x y z -- ? ) pick >= >r >= r> and ; foldable
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( m -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
: truncate ( x -- y ) dup 1 mod - ; foldable

View File

@ -1,27 +1,27 @@
USING: help kernel math ;
HELP: number= "( x y -- ? )"
HELP: number=
{ $values { "x" "a number" } { "y" "a number" } { "?" "a boolean" } }
{ $description "Tests if two numbers have the same numerical value." }
{ $notes "Do not call this word directly. Calling " { $link = } " has the same effect and is more concise." } ;
HELP: < "( x y -- ? )"
HELP: <
{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
HELP: <= "( x y -- ? )"
HELP: <=
{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
HELP: > "( x y -- ? )"
HELP: >
{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
HELP: >= "( x y -- ? )"
HELP: >=
{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
HELP: + "( x y -- z )"
HELP: +
{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } }
{ $description
"Adds two numbers."
@ -33,7 +33,7 @@ HELP: + "( x y -- z )"
}
} ;
HELP: - "( x y -- z )"
HELP: -
{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } }
{ $description
"Subtracts " { $snippet "y" } " from " { $snippet "x" } "."
@ -45,7 +45,7 @@ HELP: - "( x y -- z )"
}
} ;
HELP: * "( x y -- z )"
HELP: *
{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } }
{ $description
"Multiplies two numbers."
@ -57,7 +57,7 @@ HELP: * "( x y -- z )"
}
} ;
HELP: / "( x y -- z )"
HELP: /
{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } }
{ $description
"Divides " { $snippet "x" } " by " { $snippet "y" } ", retaining as much precision as possible."
@ -70,7 +70,7 @@ HELP: / "( x y -- z )"
}
{ $errors "Throws an error if both inputs are integers, and the denominator is 0." } ;
HELP: /i "( x y -- z )"
HELP: /i
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } }
{ $description
"Divides " { $snippet "x" } " by " { $snippet "y" } ", truncating the result to an integer."
@ -83,7 +83,7 @@ HELP: /i "( x y -- z )"
}
{ $errors "Throws an error if both inputs are integers, and the denominator is 0." } ;
HELP: /f "( x y -- z )"
HELP: /f
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } }
{ $description
"Divides " { $snippet "x" } " by " { $snippet "y" } ", representing the result as a floating point number."
@ -96,7 +96,7 @@ HELP: /f "( x y -- z )"
}
{ $errors "Throws an error if both inputs are integers, and the denominator is 0." } ;
HELP: mod "( x y -- z )"
HELP: mod
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } }
{ $description
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative."
@ -108,7 +108,7 @@ HELP: mod "( x y -- z )"
{ $errors "Throws an error if the denominator is 0." }
{ $see-also rem } ;
HELP: /mod "( x y -- z w )"
HELP: /mod
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } { "w" "an integer" } }
{ $description
"Computes the quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative."
@ -119,7 +119,7 @@ HELP: /mod "( x y -- z w )"
}
{ $errors "Throws an error if the denominator is 0." } ;
HELP: bitand "( x y -- z )"
HELP: bitand
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } }
{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in both inputs." }
{ $examples
@ -127,7 +127,7 @@ HELP: bitand "( x y -- z )"
{ $example "BIN: 110 BIN: 10 bitand .b" "10" }
} ;
HELP: bitor "( x y -- z )"
HELP: bitor
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } }
{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in at least one of the inputs." }
{ $examples
@ -135,7 +135,7 @@ HELP: bitor "( x y -- z )"
{ $example "BIN: 110 BIN: 10 bitor .b" "110" }
} ;
HELP: bitxor "( x y -- z )"
HELP: bitxor
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } }
{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in exactly one of the inputs." }
{ $examples
@ -143,80 +143,80 @@ HELP: bitxor "( x y -- z )"
{ $example "BIN: 110 BIN: 10 bitxor .b" "100" }
} ;
HELP: shift "( x n -- y )"
HELP: shift
{ $values { "x" "an integer" } { "n" "an integer" } { "y" "an integer" } }
{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "y" } " bits if " { $snippet "y" } " is positive, or " { $snippet "-y" } " bits to the right if " { $snippet "y" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
{ $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ;
HELP: bitnot "( x -- y )"
HELP: bitnot
{ $values { "x" "an integer" } { "y" "an integer" } }
{ $description "Computes the bitwise complement of the input; that is, each bit in the input number is flipped." }
{ $notes "Due to the two's complement representation of signed integers, the following two lines are equivalent:" { $code "bitnot" "neg 1-" } } ;
HELP: 1+ "( x -- y )"
HELP: 1+
{ $values { "x" "a number" } { "y" "a number" } }
{ $description
"Increments a number by 1. The following two lines are equivalent, but the first is more efficient:"
{ $code "1+" "1 +" }
} ;
HELP: 1- "( x -- y )"
HELP: 1-
{ $values { "x" "a number" } { "y" "a number" } }
{ $description
"Decrements a number by 1. The following two lines are equivalent, but the first is more efficient:"
{ $code "1-" "1 -" }
} ;
HELP: truncate "( x -- y )"
HELP: truncate
{ $values { "x" "a real number" } { "y" "a whole real number" } }
{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: floor "( x -- y )"
HELP: floor
{ $values { "x" "a real number" } { "y" "a whole real number" } }
{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: ceiling "( x -- y )"
HELP: ceiling
{ $values { "x" "a real number" } { "y" "a whole real number" } }
{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." }
{ $notes "The result is not necessarily an integer." } ;
HELP: abs "( x -- y )"
HELP: abs
{ $values { "x" "a complex number" } { "y" "a non-negative real number" } }
{ $description "Computes the absolute value of a complex number." } ;
HELP: absq "( x -- y )"
HELP: absq
{ $values { "x" "a complex number" } { "y" "a non-negative real number" } }
{ $description "Computes the squared absolute value of a complex number. This is marginally more efficient than " { $link abs } "." } ;
HELP: sq "( x -- y )"
HELP: sq
{ $values { "x" "a number" } { "y" "a number" } }
{ $description "Multiplies a number by itself." } ;
HELP: neg "( x -- -x )"
HELP: neg
{ $values { "x" "a number" } { "-x" "a number" } }
{ $description "Computes a number's additive inverse." } ;
HELP: recip "( x -- -x )"
{ $values { "x" "a number" } { "-x" "a number" } }
HELP: recip
{ $values { "x" "a number" } { "y" "a number" } }
{ $description "Computes a number's multiplicative inverse." }
{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
HELP: max "( x y -- z )"
HELP: max
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } }
{ $description "Outputs the greatest of two real numbers." } ;
HELP: min "( x y -- z )"
HELP: min
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } }
{ $description "Outputs the smallest of two real numbers." } ;
HELP: between? "( x y z -- ? )"
HELP: between?
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
HELP: rem "( x y -- z )"
HELP: rem
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } }
{ $description
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive."
@ -228,7 +228,7 @@ HELP: rem "( x y -- z )"
{ $errors "Throws an error if the denominator is 0." }
{ $see-also mod } ;
HELP: sgn "( x -- n )"
HELP: sgn
{ $values { "x" "a real number" } { "n" "-1, 0 or 1" } }
{ $description
"Outputs one of the following:"
@ -239,12 +239,12 @@ HELP: sgn "( x -- n )"
}
} ;
HELP: align "( m w -- n )"
HELP: align
{ $values { "m" "an integer" } { "w" "a power of 2" } { "n" "an integer multiple of " { $snippet "w" } } }
{ $description "Outputs the least multiple of " { $snippet "w" } " greater than " { $snippet "m" } "." }
{ $notes "This word will give an incorrect result if " { $snippet "w" } " is not a power of 2." } ;
HELP: number>string "( n -- str )"
HELP: number>string
{ $values { "n" "a real number" } { "str" "a string" } }
{ $description "Converts a real number to a string." }
{ $notes "Printing complex numbers requires the more general prettyprinter facility (see " { $link "prettyprint" } ")." } ;

View File

@ -30,17 +30,17 @@ M: object digit> drop f ;
: string>integer ( string radix -- n )
swap "-" ?head >r (string>integer) dup r> and [ neg ] when ;
: base> ( string radix -- n )
: base> ( str radix -- n/f )
{
{ [ CHAR: / pick member? ] [ string>ratio ] }
{ [ CHAR: . pick member? ] [ drop string>float ] }
{ [ t ] [ string>integer ] }
} cond ;
: string>number ( string -- num ) 10 base> ;
: bin> ( string -- num ) 2 base> ;
: oct> ( string -- num ) 8 base> ;
: hex> ( string -- num ) 16 base> ;
: string>number ( str -- n ) 10 base> ;
: bin> ( str -- n ) 2 base> ;
: oct> ( str -- n ) 8 base> ;
: hex> ( str -- n ) 16 base> ;
: >digit ( n -- ch )
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
@ -49,7 +49,7 @@ M: object digit> drop f ;
dup >r /mod >digit , dup 0 >
[ r> integer, ] [ r> 2drop ] if ;
G: >base ( num radix -- string ) 1 standard-combination ;
G: >base ( n radix -- str ) 1 standard-combination ;
M: integer >base
[
@ -78,7 +78,7 @@ M: float >base
{ [ t ] [ float>string fix-float ] }
} cond ;
: number>string ( num -- string ) 10 >base ;
: number>string ( n -- str ) 10 >base ;
: >bin ( num -- string ) 2 >base ;
: >oct ( num -- string ) 8 >base ;
: >hex ( num -- string ) 16 >base ;

View File

@ -1,70 +1,70 @@
USING: help math math-internals prettyprint ;
HELP: base> "( str radix -- n/f )"
HELP: base>
{ $values { "str" "a string" } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } }
{ $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10."
$terpri
"Outputs " { $link f } " if the string does not represent a number." }
{ $see-also >base } ;
HELP: string>number "( str -- n )"
HELP: string>number
{ $values { "str" "a string" } { "n/f" "a real number or " { $link f } } }
{ $description "Creates a real number from a string representation of a number in base 10."
$terpri
"Outputs " { $link f } " if the string does not represent a number." }
{ $see-also number>string } ;
HELP: bin> "( str -- n )"
HELP: bin>
{ $values { "str" "a string" } { "n/f" "a real number or " { $link f } } }
{ $description "Creates a real number from a string representation of a number in base 2."
$terpri
"Outputs " { $link f } " if the string does not represent a number." }
{ $see-also POSTPONE: BIN: } ;
HELP: oct> "( str -- n )"
HELP: oct>
{ $values { "str" "a string" } { "n/f" "a real number or " { $link f } } }
{ $description "Creates a real number from a string representation of a number in base 8."
$terpri
"Outputs " { $link f } " if the string does not represent a number." }
{ $see-also POSTPONE: OCT: } ;
HELP: hex> "( str -- n )"
HELP: hex>
{ $values { "str" "a string" } { "n" "a real number" } }
{ $description "Creates a real number from a string representation of a number in base 16."
$terpri
"Outputs " { $link f } " if the string does not represent a number." }
{ $see-also POSTPONE: HEX: } ;
HELP: >base "( n radix -- str )"
HELP: >base
{ $values { "n" "a real number" } { "radix" "an integer between 2 and 36" } { "str" "a string" } }
{ $description "Converts a real number into a string representation using the given radix. If the number is a float, the radix is ignored and the output is always in base 10." }
{ $see-also base> } ;
HELP: number>string "( n -- str )"
HELP: number>string
{ $values { "n" "a real number" } { "str" "a string" } }
{ $description "Outputs a string representation of a number using base 10." } ;
HELP: >bin "( n -- str )"
HELP: >bin
{ $values { "n" "a real number" } { "str" "a string" } }
{ $description "Outputs a string representation of a number using base 2." }
{ $see-also .b } ;
HELP: >oct "( n -- str )"
HELP: >oct
{ $values { "n" "a real number" } { "str" "a string" } }
{ $description "Outputs a string representation of a number using base 8." }
{ $see-also .o } ;
HELP: >hex "( n -- str )"
HELP: >hex
{ $values { "n" "a real number" } { "str" "a string" } }
{ $description "Outputs a string representation of a number using base 16." }
{ $see-also .h } ;
HELP: string>float "( n -- str )"
HELP: string>float ( n -- str )
{ $values { "str" "a string" } { "n/f" "a real number or " { $link f } } }
{ $description "Primitive for creating a float from a string representation. User code should call " { $link string>number } " instead, since it is polymorphic and can handle other types of numbers."
$terpri
"Outputs " { $link f } " if the string does not represent a float." } ;
HELP: float>string "( n -- str )"
HELP: float>string ( n -- str )
{ $values { "n" "a real number" } { "str" "a string" } }
{ $description "Primitive for getting a string representation of a float. User code should call " { $link number>string } " instead, since it is polymorphic and can handle other types of numbers." } ;

View File

@ -3,17 +3,17 @@
IN: math
USING: errors kernel math math-internals ;
: exp >rect swap fexp swap polar> ; inline
: log >polar swap flog swap rect> ; inline
: exp ( x -- y ) >rect swap fexp swap polar> ; inline
: log ( x -- y ) >polar swap flog swap rect> ; inline
GENERIC: sqrt ( n -- n ) foldable
GENERIC: sqrt ( x -- y ) foldable
M: complex sqrt >polar swap fsqrt swap 2 / polar> ;
M: real sqrt dup 0 < [ neg fsqrt 0 swap rect> ] [ fsqrt ] if ;
GENERIC: (^) ( z w -- z^w ) foldable
GENERIC: (^) ( x y -- z ) foldable
: ^ ( z w -- z^w )
: ^ ( x y -- z )
over zero? [
dup zero?
[ 2drop 0.0/0.0 ] [ 0 < [ drop 1.0/0.0 ] when ] if

View File

@ -1,27 +1,27 @@
USING: help math ;
HELP: exp "( x -- y )"
HELP: exp
{ $values { "x" "a complex number" } { "y" "a complex number" } }
{ $description "Computes the exponential function." } ;
HELP: log "( x -- y )"
HELP: log
{ $values { "x" "a complex number" } { "y" "a complex number" } }
{ $description "Computes the natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
HELP: sqrt "( x -- y )"
HELP: sqrt
{ $values { "x" "a complex number" } { "y" "a complex number" } }
{ $description "Computes the square root function." } ;
HELP: ^ "( x y -- z )"
HELP: ^
{ $values { "x" "a complex number" } { "y" "a complex number" } { "z" "a complex number" } }
{ $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." }
{ $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ;
HELP: power-of-2? "( n -- ? )"
HELP: power-of-2?
{ $values { "n" "an integer" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: log2 "( n -- b )"
HELP: log2
{ $values { "n" "a positive integer" } { "b" "an integer" } }
{ $description "Computes the largest integer " { $snippet "b" } " such that " { $snippet "2^b" } " is less than " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "n" } " is zero or negative." } ;

View File

@ -1,10 +1,10 @@
USING: help math ;
HELP: (random-int) "( -- rand )"
HELP: (random-int)
{ $values { "rand" "an integer between 0 and 2^32-1" } }
{ $description "Generates a random 32-bit unsigned integer." } ;
HELP: random-int "( n -- rand )"
HELP: random-int
{ $values { "rand" "an integer between 0 and n" } }
{ $description "Outputs a pseudo-random integer in the interval " { $snippet "[0,n)" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;

View File

@ -1,27 +1,27 @@
USING: help math math-internals ;
HELP: ratio f
{ $description "The class of rational numbers with denominator not equal to 1." } ;
HELP: ratio
{ $class-description "The class of rational numbers with denominator not equal to 1." } ;
HELP: rational f
{ $description "The class of rational numbers, a disjoint union of integers and ratios." } ;
HELP: rational
{ $class-description "The class of rational numbers, a disjoint union of integers and ratios." } ;
HELP: numerator "( a/b -- a )"
HELP: numerator ( a/b -- a )
{ $values { "a/b" "a rational number" } { "a" "an integer" } }
{ $description "Outputs the numerator of a rational number. Acts as the identity on integers." } ;
HELP: denominator "( a/b -- b )"
HELP: denominator ( a/b -- b )
{ $values { "a/b" "a rational number" } { "b" "a positive integer" } }
{ $description "Outputs the denominator of a rational number. Always outputs 1 with integers." } ;
HELP: >fraction "( a/b -- a b )"
HELP: >fraction
{ $values { "a/b" "a rational number" } { "a" "an integer" } { "b" "a positive integer" } }
{ $description "Extracts the numerator and denominator of a rational number." } ;
HELP: 2>fraction "( a/b c/d -- a c b d )"
HELP: 2>fraction
{ $values { "a/b" "a rational number" } { "a" "an integer" } { "c" "an integer" } { "b" "a positive integer" } { "d" "a positive integer" } }
{ $description "Extracts the numerator and denominator of two rational numbers at once." } ;
HELP: (fraction>) "( a b -- a/b )"
HELP: (fraction>) ( a b -- a/b )
{ $values { "a" "an integer" } { "b" "an integer" } { "a/b" "a ratio" } }
{ $description "Low-level ratio constructor. User code should call " { $link / } " to create ratios instead." } ;
{ $description "Primitive ratio constructor. User code should call " { $link / } " to create ratios instead." } ;

View File

@ -3,35 +3,35 @@
IN: math
USING: kernel math math-internals ;
: cos ( z -- cos )
: cos ( x -- y )
>rect 2dup
fcosh swap fcos * -rot
fsinh swap fsin neg * rect> ; inline
: sec cos recip ; inline
: sec ( x -- y ) cos recip ; inline
: cosh ( z -- cosh )
: cosh ( x -- y )
>rect 2dup
fcos swap fcosh * -rot
fsin swap fsinh * rect> ; inline
: sech cosh recip ; inline
: sech ( x -- y ) cosh recip ; inline
: sin ( z -- sin )
: sin ( x -- y )
>rect 2dup
fcosh swap fsin * -rot
fsinh swap fcos * rect> ; inline
: cosec sin recip ; inline
: cosec ( x -- y ) sin recip ; inline
: sinh ( z -- sinh )
: sinh ( x -- y )
>rect 2dup
fcos swap fsinh * -rot
fsin swap fcosh * rect> ; inline
: cosech sinh recip ; inline
: cosech ( x -- y ) sinh recip ; inline
: tan dup sin swap cos / ; inline
: tanh dup sinh swap cosh / ; inline
: cot dup cos swap sin / ; inline
: coth dup cosh swap sinh / ; inline
: tan ( x -- y ) dup sin swap cos / ; inline
: tanh ( x -- y ) dup sinh swap cosh / ; inline
: cot ( x -- y ) dup cos swap sin / ; inline
: coth ( x -- y ) dup cosh swap sinh / ; inline

View File

@ -1,57 +1,57 @@
USING: help math ;
HELP: cosh "( x -- y )"
HELP: cosh
$values-x/y
{ $description "Hyperbolic cosine." } ;
HELP: sech "( x -- y )"
HELP: sech
$values-x/y
{ $description "Hyperbolic secant." } ;
HELP: sinh "( x -- y )"
HELP: sinh
$values-x/y
{ $description "Hyperbolic sine." } ;
HELP: sinh "( x -- y )"
HELP: sinh
$values-x/y
{ $description "Hyperbolic sine." } ;
HELP: cosech "( x -- y )"
HELP: cosech
$values-x/y
{ $description "Hyperbolic cosecant." } ;
HELP: tanh "( x -- y )"
HELP: tanh
$values-x/y
{ $description "Hyperbolic tangent." } ;
HELP: coth "( x -- y )"
HELP: coth
$values-x/y
{ $description "Hyperbolic cotangent." } ;
HELP: cos "( x -- y )"
HELP: cos
$values-x/y
{ $description "Trigonometric cosine." } ;
HELP: sec "( x -- y )"
HELP: sec
$values-x/y
{ $description "Trigonometric secant." } ;
HELP: sin "( x -- y )"
HELP: sin
$values-x/y
{ $description "Trigonometric sine." } ;
HELP: sin "( x -- y )"
HELP: sin
$values-x/y
{ $description "Trigonometric sine." } ;
HELP: cosec "( x -- y )"
HELP: cosec
$values-x/y
{ $description "Trigonometric cosecant." } ;
HELP: tan "( x -- y )"
HELP: tan
$values-x/y
{ $description "Trigonometric tangent." } ;
HELP: cot "( x -- y )"
HELP: cot
$values-x/y
{ $description "Trigonometric cotangent." } ;

View File

@ -3,27 +3,27 @@
IN: math
USING: arrays generic kernel sequences ;
: vneg ( v -- v ) [ neg ] map ;
: vneg ( u -- v ) [ neg ] map ;
: n*v ( n v -- v ) [ * ] map-with ;
: v*n ( v n -- v ) swap n*v ;
: n/v ( n v -- v ) [ / ] map-with ;
: v/n ( v n -- v ) swap [ swap / ] map-with ;
: n*v ( n u -- v ) [ * ] map-with ;
: v*n ( n u -- v ) swap n*v ;
: n/v ( n u -- v ) [ / ] map-with ;
: v/n ( u n -- v ) swap [ swap / ] map-with ;
: v+ ( v v -- v ) [ + ] 2map ;
: v- ( v v -- v ) [ - ] 2map ;
: [v-] ( v v -- v ) [ [-] ] 2map ;
: v* ( v v -- v ) [ * ] 2map ;
: v/ ( v v -- v ) [ / ] 2map ;
: vmax ( v v -- v ) [ max ] 2map ;
: vmin ( v v -- v ) [ min ] 2map ;
: v+ ( u v -- w ) [ + ] 2map ;
: v- ( u v -- w ) [ - ] 2map ;
: [v-] ( u v -- w ) [ [-] ] 2map ;
: v* ( u v -- w ) [ * ] 2map ;
: v/ ( u v -- w ) [ / ] 2map ;
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
: v. ( v v -- x ) 0 [ * + ] 2reduce ;
: norm-sq ( v -- n ) 0 [ absq + ] reduce ;
: norm ( vec -- n ) norm-sq sqrt ;
: normalize ( vec -- uvec ) dup norm v/n ;
: norm-sq ( v -- x ) 0 [ absq + ] reduce ;
: norm ( vec -- x ) norm-sq sqrt ;
: normalize ( u -- v ) dup norm v/n ;
: set-axis ( x y axis -- v )
: set-axis ( u v axis -- w )
dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ;
: sum ( seq -- n ) 0 [ + ] reduce ;

Some files were not shown because too many files have changed in this diff Show More