More documentation updates
parent
c99c10632c
commit
29e28008cd
|
@ -1,6 +1,7 @@
|
||||||
+ 0.84:
|
+ 0.84:
|
||||||
|
|
||||||
- doc mashup:
|
- doc mashup:
|
||||||
|
- document: equals? parse-hook no-parse-hook
|
||||||
- HELP: should not specify stack effect
|
- HELP: should not specify stack effect
|
||||||
- figure out what to do for parsing words
|
- figure out what to do for parsing words
|
||||||
- document inference errors
|
- document inference errors
|
||||||
|
|
|
@ -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."
|
"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 "browsing-help" }
|
||||||
{ $subsection "searching-help" }
|
{ $subsection "searching-help" }
|
||||||
{ $subsection "writing-help" } ;
|
{ $subsection "writing-help" }
|
||||||
|
{ $subsection "porter-stemmer" } ;
|
||||||
|
|
||||||
ARTICLE: "browsing-help" "Browsing documentation"
|
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."
|
"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 simple-element }
|
||||||
{ $subsection ($span) }
|
{ $subsection ($span) }
|
||||||
{ $subsection ($block) } ;
|
{ $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 } ;
|
||||||
|
|
|
@ -64,11 +64,12 @@ ARTICLE: "stdio" "The default stream"
|
||||||
{ $subsection with-stream* } ;
|
{ $subsection with-stream* } ;
|
||||||
|
|
||||||
ARTICLE: "styles" "Formatted output"
|
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
|
$terpri
|
||||||
"Style hashtables are keyed by symbols from the " { $vocab-link "styles" } " vocabulary."
|
"Style hashtables are keyed by symbols from the " { $vocab-link "styles" } " vocabulary."
|
||||||
{ $subsection "character-styles" }
|
{ $subsection "character-styles" }
|
||||||
{ $subsection "paragraph-styles" }
|
{ $subsection "paragraph-styles" }
|
||||||
|
{ $subsection "table-styles" }
|
||||||
{ $subsection "presentations" } ;
|
{ $subsection "presentations" } ;
|
||||||
|
|
||||||
ARTICLE: "character-styles" "Character styles"
|
ARTICLE: "character-styles" "Character styles"
|
||||||
|
@ -89,6 +90,11 @@ ARTICLE: "paragraph-styles" "Paragraph styles"
|
||||||
{ $subsection outline }
|
{ $subsection outline }
|
||||||
{ $subsection presented } ;
|
{ $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"
|
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:"
|
"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 }
|
{ $subsection write-object }
|
||||||
|
|
|
@ -220,6 +220,7 @@ sequences vectors words ;
|
||||||
"/library/ui/tools/launchpad.factor"
|
"/library/ui/tools/launchpad.factor"
|
||||||
|
|
||||||
"/library/continuations.facts"
|
"/library/continuations.facts"
|
||||||
|
"/library/definitions.facts"
|
||||||
"/library/effects.facts"
|
"/library/effects.facts"
|
||||||
"/library/errors.facts"
|
"/library/errors.facts"
|
||||||
"/library/kernel.facts"
|
"/library/kernel.facts"
|
||||||
|
@ -264,6 +265,7 @@ sequences vectors words ;
|
||||||
"/library/generic/tuple.facts"
|
"/library/generic/tuple.facts"
|
||||||
"/library/help/help.facts"
|
"/library/help/help.facts"
|
||||||
"/library/help/markup.facts"
|
"/library/help/markup.facts"
|
||||||
|
"/library/help/porter-stemmer.facts"
|
||||||
"/library/help/search.facts"
|
"/library/help/search.facts"
|
||||||
"/library/help/syntax.facts"
|
"/library/help/syntax.facts"
|
||||||
"/library/help/topics.facts"
|
"/library/help/topics.facts"
|
||||||
|
@ -273,6 +275,7 @@ sequences vectors words ;
|
||||||
"/library/io/duplex-stream.facts"
|
"/library/io/duplex-stream.facts"
|
||||||
"/library/io/files.facts"
|
"/library/io/files.facts"
|
||||||
"/library/io/lines.facts"
|
"/library/io/lines.facts"
|
||||||
|
"/library/io/nested-style.facts"
|
||||||
"/library/io/plain-stream.facts"
|
"/library/io/plain-stream.facts"
|
||||||
"/library/io/server.facts"
|
"/library/io/server.facts"
|
||||||
"/library/io/stdio.facts"
|
"/library/io/stdio.facts"
|
||||||
|
|
|
@ -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 set-nth growable-check 2dup ensure set-nth-unsafe ;
|
||||||
M: sbuf clone clone-growable ;
|
M: sbuf clone clone-growable ;
|
||||||
M: sbuf thaw drop SBUF" " clone ;
|
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 ;
|
M: sbuf like drop dup sbuf? [ >sbuf ] unless ;
|
||||||
|
|
|
@ -85,15 +85,15 @@ IN: sequences
|
||||||
swap dup length 1 <=
|
swap dup length 1 <=
|
||||||
[ 2drop ] [ 0 over length 1- (nsort) ] if ; inline
|
[ 2drop ] [ 0 over length 1- (nsort) ] if ; inline
|
||||||
|
|
||||||
: sort ( seq quot -- seq )
|
: sort ( seq quot -- sortedseq )
|
||||||
swap [ swap nsort ] immutable ; inline
|
swap [ swap nsort ] immutable ; inline
|
||||||
|
|
||||||
: natural-sort ( seq -- seq ) [ <=> ] sort ;
|
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
|
||||||
|
|
||||||
: binsearch ( elt seq quot -- i )
|
: binsearch ( elt seq quot -- i )
|
||||||
swap dup empty?
|
swap dup empty?
|
||||||
[ 3drop -1 ] [ flatten-slice (binsearch) ] if ; inline
|
[ 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 ;
|
over >r binsearch dup -1 = [ r> 2drop f ] [ r> nth ] if ;
|
||||||
inline
|
inline
|
||||||
|
|
|
@ -1,26 +1,26 @@
|
||||||
IN: sequences
|
IN: sequences
|
||||||
USING: help kernel words ;
|
USING: help kernel words ;
|
||||||
|
|
||||||
HELP: sort "( seq quot -- sortedseq )"
|
HELP: sort
|
||||||
{ $values { "seq" "a sequence" } { "quot" "a comparator quotation" } { "sortedseq" "a new sorted sequence" } }
|
{ $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" } "." } ;
|
{ $description "Sorts the elements into a new sequence of the same class as " { $snippet "seq" } "." } ;
|
||||||
|
|
||||||
HELP: nsort "( seq quot -- sortedseq )"
|
HELP: nsort
|
||||||
{ $values { "seq" "a mutable sequence" } { "quot" "a comparator quotation" } { "sortedseq" "a new sorted sequence" } }
|
{ $values { "seq" "a mutable sequence" } { "quot" "a comparator quotation" } }
|
||||||
{ $description "Sorts the sequence in-place." }
|
{ $description "Sorts the sequence in-place." }
|
||||||
{ $side-effects "seq" } ;
|
{ $side-effects "seq" } ;
|
||||||
|
|
||||||
HELP: natural-sort "( seq -- sortedseq )"
|
HELP: natural-sort
|
||||||
{ $values { "seq" "a sequence of real numbers" } { "sortedseq" "a new sorted sequence" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "."
|
{ $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
|
$terpri
|
||||||
"Outputs -1 if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ;
|
"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" } }
|
{ $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."
|
{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence."
|
||||||
$terpri
|
$terpri
|
||||||
|
|
|
@ -4,13 +4,13 @@ IN: sequences
|
||||||
USING: arrays errors generic kernel kernel-internals math
|
USING: arrays errors generic kernel kernel-internals math
|
||||||
sequences-internals strings vectors words ;
|
sequences-internals strings vectors words ;
|
||||||
|
|
||||||
: first2 ( seq -- x y )
|
: first2 ( seq -- first second )
|
||||||
1 swap bounds-check nip first2-unsafe ;
|
1 swap bounds-check nip first2-unsafe ;
|
||||||
|
|
||||||
: first3 ( seq -- x y z )
|
: first3 ( seq -- first second third )
|
||||||
2 swap bounds-check nip first3-unsafe ;
|
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 ;
|
3 swap bounds-check nip first4-unsafe ;
|
||||||
|
|
||||||
M: object like drop ;
|
M: object like drop ;
|
||||||
|
@ -43,7 +43,7 @@ M: object like drop ;
|
||||||
: subst ( newseq oldseq seq -- )
|
: subst ( newseq oldseq seq -- )
|
||||||
[ >r 2dup r> (subst) ] inject 2drop ;
|
[ >r 2dup r> (subst) ] inject 2drop ;
|
||||||
|
|
||||||
: move ( to from seq -- )
|
: move ( m n seq -- )
|
||||||
pick pick number=
|
pick pick number=
|
||||||
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
|
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
|
||||||
|
|
||||||
|
@ -58,41 +58,39 @@ M: object like drop ;
|
||||||
|
|
||||||
: push-new ( elt seq -- ) [ delete ] 2keep push ;
|
: push-new ( elt seq -- ) [ delete ] 2keep push ;
|
||||||
|
|
||||||
: prune ( seq -- seq )
|
: prune ( seq -- newseq )
|
||||||
[ V{ } clone swap [ over push-new ] each ] keep like ;
|
[ V{ } clone swap [ over push-new ] each ] keep like ;
|
||||||
|
|
||||||
: nappend ( to from -- )
|
: nappend ( dest src -- )
|
||||||
>r [ length ] keep r> copy-into ; inline
|
>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
|
swap [ >resizable [ swap call ] keep ] keep like ; inline
|
||||||
|
|
||||||
: append ( s1 s2 -- s1+s2 )
|
: append ( seq1 seq2 -- newseq )
|
||||||
swap [ swap nappend ] immutable ;
|
swap [ swap nappend ] immutable ;
|
||||||
|
|
||||||
: add ( seq elt -- seq )
|
: add ( seq elt -- newseq )
|
||||||
swap [ push ] immutable ;
|
swap [ push ] immutable ;
|
||||||
|
|
||||||
: add* ( seq elt -- seq )
|
: add* ( seq elt -- newseq )
|
||||||
over >r
|
over >r
|
||||||
over thaw [ push ] keep [ swap nappend ] keep
|
over thaw [ push ] keep [ swap nappend ] keep
|
||||||
r> like ;
|
r> like ;
|
||||||
|
|
||||||
: diff ( seq1 seq2 -- seq2-seq1 )
|
: diff ( seq1 seq2 -- newseq )
|
||||||
[ swap member? not ] subset-with ;
|
[ swap member? not ] subset-with ;
|
||||||
|
|
||||||
: append3 ( s1 s2 s3 -- s1+s2+s3 )
|
: append3 ( seq1 seq2 seq3 -- newseq )
|
||||||
rot [ [ rot nappend ] keep swap nappend ] immutable ;
|
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 -- )
|
: pop* ( seq -- ) dup length 1- swap set-length ;
|
||||||
dup length 1- swap set-length ;
|
|
||||||
|
|
||||||
: pop ( sequence -- element )
|
: pop ( seq -- ) dup length 1- swap [ nth ] 2keep set-length ;
|
||||||
dup length 1- swap [ nth ] 2keep set-length ;
|
|
||||||
|
|
||||||
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
|
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
|
||||||
|
|
||||||
|
@ -104,16 +102,16 @@ M: object like drop ;
|
||||||
: mismatch ( seq1 seq2 -- i )
|
: mismatch ( seq1 seq2 -- i )
|
||||||
2dup min-length (mismatch) ;
|
2dup min-length (mismatch) ;
|
||||||
|
|
||||||
: flip ( seq -- seq )
|
: flip ( matrix -- newmatrix )
|
||||||
dup empty? [
|
dup empty? [
|
||||||
dup first [ length ] keep like
|
dup first [ length ] keep like
|
||||||
[ swap [ nth ] map-with ] map-with
|
[ swap [ nth ] map-with ] map-with
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
: unpair ( seq -- firsts seconds )
|
: unpair ( assoc -- keys values )
|
||||||
flip dup empty? [ drop { } { } ] [ first2 ] if ;
|
flip dup empty? [ drop { } { } ] [ first2 ] if ;
|
||||||
|
|
||||||
: exchange ( n n seq -- )
|
: exchange ( m n seq -- )
|
||||||
pick over bounds-check 2drop 2dup bounds-check 2drop
|
pick over bounds-check 2drop 2dup bounds-check 2drop
|
||||||
exchange-unsafe ;
|
exchange-unsafe ;
|
||||||
|
|
||||||
|
@ -125,7 +123,7 @@ M: object like drop ;
|
||||||
|
|
||||||
: last/first ( seq -- pair ) dup peek swap first 2array ;
|
: last/first ( seq -- pair ) dup peek swap first 2array ;
|
||||||
|
|
||||||
: sequence= ( seq seq -- ? )
|
: sequence= ( seq1 seq2 -- ? )
|
||||||
2dup [ length ] 2apply tuck number=
|
2dup [ length ] 2apply tuck number=
|
||||||
[ (mismatch) -1 number= ] [ 3drop f ] if ; inline
|
[ (mismatch) -1 number= ] [ 3drop f ] if ; inline
|
||||||
|
|
||||||
|
@ -157,7 +155,8 @@ M: object <=>
|
||||||
TUPLE: no-cond ;
|
TUPLE: no-cond ;
|
||||||
: no-cond ( -- * ) <no-cond> throw ;
|
: no-cond ( -- * ) <no-cond> throw ;
|
||||||
|
|
||||||
: cond ( conditions -- )
|
: cond ( assoc -- )
|
||||||
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
|
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
|
||||||
|
|
||||||
: unix? os { "freebsd" "linux" "macosx" "solaris" } member? ;
|
: unix? ( -- ? )
|
||||||
|
os { "freebsd" "linux" "macosx" "solaris" } member? ;
|
||||||
|
|
|
@ -1,37 +1,47 @@
|
||||||
IN: sequences
|
IN: sequences
|
||||||
USING: help kernel ;
|
USING: help kernel ;
|
||||||
|
|
||||||
HELP: first2 "( seq -- first second )"
|
HELP: first2
|
||||||
{ $values { "seq" "a sequence" } { "first" "the first element" } { "second" "the second element" } }
|
{ $values { "seq" "a sequence" } { "first" "the first element" } { "second" "the second element" } }
|
||||||
{ $description "Pushes the first two elements of a sequence." }
|
{ $description "Pushes the first two elements of a sequence." }
|
||||||
{ $errors "Throws an error if the sequence has less than two elements." } ;
|
{ $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" } }
|
{ $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." }
|
{ $description "Pushes the first three elements of a sequence." }
|
||||||
{ $errors "Throws an error if the sequence has less than three elements." } ;
|
{ $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" } }
|
{ $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." }
|
{ $description "Pushes the first four elements of a sequence." }
|
||||||
{ $errors "Throws an error if the sequence has less than four elements." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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? } ;
|
{ $see-also index* member? } ;
|
||||||
|
|
||||||
HELP: index* "( obj i seq -- n )"
|
HELP: index*
|
||||||
{ $values { "obj" "an object" } { "i" "a start index" } { "seq" "a sequence" } }
|
{ $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." }
|
{ $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? } ;
|
{ $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" } }
|
{ $values { "obj" "an object" } { "seq" "a sequence" } }
|
||||||
{ $description "Tests if the sequence contains an element equal to the object." }
|
{ $description "Tests if the sequence contains an element equal to the object." }
|
||||||
{ $see-also index index* memq? } ;
|
{ $see-also index index* memq? } ;
|
||||||
|
|
||||||
HELP: memq? "( obj seq -- ? )"
|
HELP: memq?
|
||||||
{ $values { "obj" "an object" } { "seq" "a sequence" } }
|
{ $values { "obj" "an object" } { "seq" "a sequence" } }
|
||||||
{ $description "Tests if the sequence contains the object." }
|
{ $description "Tests if the sequence contains the object." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
@ -40,26 +50,26 @@ HELP: memq? "( obj seq -- ? )"
|
||||||
}
|
}
|
||||||
{ $see-also index index* member? } ;
|
{ $see-also index index* member? } ;
|
||||||
|
|
||||||
HELP: remove "( elt seq -- newseq )"
|
HELP: remove
|
||||||
{ $values { "elt" "an object" } { "seq" "a sequence" } { "newseq" "a new sequence" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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" } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $description "Sets the element with index " { $snippet "m" } " to the element with index " { $snippet "n" } "." }
|
||||||
{ $side-effects "seq" } ;
|
{ $side-effects "seq" } ;
|
||||||
|
|
||||||
HELP: delete "( elt seq -- )"
|
HELP: delete
|
||||||
{ $values { "elt" "an object" } { "seq" "a resizable mutable sequence" } }
|
{ $values { "elt" "an object" } { "seq" "a resizable mutable sequence" } }
|
||||||
{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } "." }
|
{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } "." }
|
||||||
{ $side-effects "seq" } ;
|
{ $side-effects "seq" } ;
|
||||||
|
|
||||||
HELP: push-new "( elt seq -- )"
|
HELP: push-new
|
||||||
{ $values { "elt" "an object" } { "seq" "a resizable mutable sequence" } }
|
{ $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." }
|
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
@ -74,21 +84,21 @@ HELP: push-new "( elt seq -- )"
|
||||||
{ $side-effects "seq" }
|
{ $side-effects "seq" }
|
||||||
{ $see-also push } ;
|
{ $see-also push } ;
|
||||||
|
|
||||||
HELP: prune "( seq -- newseq )"
|
HELP: prune
|
||||||
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $description "Appends " { $snippet "src" } " to the end of " { $snippet "dest" } "." }
|
||||||
{ $side-effects "dest" }
|
{ $side-effects "dest" }
|
||||||
{ $errors "Throws an error if " { $snippet "src" } " contains elements not permitted in " { $snippet "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" } }
|
{ $values { "seq" "a sequence" } { "newseq" "a mutable resizable sequence" } }
|
||||||
{ $description "Outputs a new, mutable resizable sequence having the same elements as " { $snippet "seq" } "." } ;
|
{ $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" } }
|
{ $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. "
|
{ $description "A utility combinator transforming a word which modifies its input sequence into a word which returns a new output sequence. "
|
||||||
$terpri
|
$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 } "."
|
"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" } }
|
{ $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" } "." }
|
{ $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" } "." }
|
{ $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 }" }
|
{ $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" } }
|
{ $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" } "." }
|
{ $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" } "." }
|
{ $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 }" }
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $values { "seq" "a sequence" } { "elt" "an object" } }
|
||||||
{ $description "Outputs the last element of a sequence." }
|
{ $description "Outputs the last element of a sequence." }
|
||||||
{ $errors "Throws an error if the sequence is empty." }
|
{ $errors "Throws an error if the sequence is empty." }
|
||||||
{ $see-also pop* pop } ;
|
{ $see-also pop* pop } ;
|
||||||
|
|
||||||
HELP: pop* "( seq -- )"
|
HELP: pop*
|
||||||
{ $values { "seq" "a resizable mutable sequence" } }
|
{ $values { "seq" "a resizable mutable sequence" } }
|
||||||
{ $description "Removes the last element and shortens the sequence." }
|
{ $description "Removes the last element and shortens the sequence." }
|
||||||
{ $side-effects "seq" }
|
{ $side-effects "seq" }
|
||||||
{ $errors "Throws an error if the sequence is empty." }
|
{ $errors "Throws an error if the sequence is empty." }
|
||||||
{ $see-also peek pop } ;
|
{ $see-also peek pop } ;
|
||||||
|
|
||||||
HELP: pop "( seq -- )"
|
HELP: pop
|
||||||
{ $values { "seq" "a resizable mutable sequence" } }
|
{ $values { "seq" "a resizable mutable sequence" } }
|
||||||
{ $description "Outputs the last element after removing it and shortening the sequence." }
|
{ $description "Outputs the last element after removing it and shortening the sequence." }
|
||||||
{ $side-effects "seq" }
|
{ $side-effects "seq" }
|
||||||
{ $errors "Throws an error if the sequence is empty." }
|
{ $errors "Throws an error if the sequence is empty." }
|
||||||
{ $see-also peek pop* } ;
|
{ $see-also peek pop* } ;
|
||||||
|
|
||||||
HELP: all-equal? "( seq -- ? )"
|
HELP: all-equal?
|
||||||
{ $values { "seq" "a sequence" } { "?" "a boolean" } }
|
{ $values { "seq" "a sequence" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if all elements in the sequence are equal. Yields true with an empty sequence." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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 } }" } } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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 } } }
|
{ $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." }
|
{ $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 } ;
|
{ $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 } } }
|
{ $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." }
|
{ $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 } ;
|
{ $see-also rassoc } ;
|
||||||
|
|
||||||
HELP: last/first "( seq -- pair )"
|
HELP: last/first
|
||||||
{ $values { "seq" "a sequence" } { "pair" "a two-element array" } }
|
{ $values { "seq" "a sequence" } { "pair" "a two-element array" } }
|
||||||
{ $description "Creates an array holding the first and last element of the sequence." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "n" "a non-negative integer" } }
|
||||||
{ $description "Outputs the number of elements on the data stack." } ;
|
{ $description "Outputs the number of elements on the data stack." } ;
|
||||||
|
|
||||||
HELP: cond "( assoc -- )"
|
HELP: cond
|
||||||
{ $values { "assoc" "a sequence of quotation pairs" } }
|
{ $values { "assoc" "a sequence of quotation pairs" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Calls the second quotation in the first pair whose first quotation yields a true value."
|
"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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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." } ;
|
||||||
|
|
|
@ -3,24 +3,23 @@
|
||||||
IN: sequences
|
IN: sequences
|
||||||
USING: errors generic kernel math math-internals strings vectors ;
|
USING: errors generic kernel math math-internals strings vectors ;
|
||||||
|
|
||||||
GENERIC: length ( sequence -- n )
|
GENERIC: length ( seq -- n )
|
||||||
GENERIC: set-length ( n sequence -- )
|
GENERIC: set-length ( n seq -- )
|
||||||
GENERIC: nth ( n sequence -- obj )
|
GENERIC: nth ( n seq -- elt )
|
||||||
GENERIC: set-nth ( value n sequence -- )
|
GENERIC: set-nth ( elt n seq -- )
|
||||||
GENERIC: thaw ( seq -- mutable-seq )
|
GENERIC: thaw ( seq -- resizable-seq )
|
||||||
GENERIC: like ( seq seq -- seq )
|
GENERIC: like ( seq prototype -- newseq )
|
||||||
|
|
||||||
: empty? ( seq -- ? ) length zero? ; inline
|
: empty? ( seq -- ? ) length zero? ; inline
|
||||||
|
|
||||||
: delete-all ( seq -- ) 0 swap set-length ;
|
: delete-all ( seq -- ) 0 swap set-length ;
|
||||||
|
|
||||||
: first 0 swap nth ; inline
|
: first ( seq -- first ) 0 swap nth ; inline
|
||||||
: second 1 swap nth ; inline
|
: second ( seq -- second ) 1 swap nth ; inline
|
||||||
: third 2 swap nth ; inline
|
: third ( seq -- third ) 2 swap nth ; inline
|
||||||
: fourth 3 swap nth ; inline
|
: fourth ( seq -- fourth ) 3 swap nth ; inline
|
||||||
|
|
||||||
: push ( element sequence -- )
|
: push ( elt seq -- ) dup length swap set-nth ;
|
||||||
dup length swap set-nth ;
|
|
||||||
|
|
||||||
: ?push ( elt seq/f -- seq )
|
: ?push ( elt seq/f -- seq )
|
||||||
[ 1 <vector> ] unless* [ push ] keep ;
|
[ 1 <vector> ] unless* [ push ] keep ;
|
||||||
|
@ -30,11 +29,11 @@ GENERIC: like ( seq seq -- seq )
|
||||||
|
|
||||||
IN: sequences-internals
|
IN: sequences-internals
|
||||||
|
|
||||||
GENERIC: resize ( n seq -- seq )
|
GENERIC: resize ( n seq -- newseq )
|
||||||
|
|
||||||
! Unsafe sequence protocol for inner loops
|
! Unsafe sequence protocol for inner loops
|
||||||
GENERIC: nth-unsafe ( n sequence -- elt )
|
GENERIC: nth-unsafe ( n seq -- elt )
|
||||||
GENERIC: set-nth-unsafe ( elt n sequence -- )
|
GENERIC: set-nth-unsafe ( elt n seq -- )
|
||||||
|
|
||||||
M: object nth-unsafe nth ;
|
M: object nth-unsafe nth ;
|
||||||
M: object set-nth-unsafe set-nth ;
|
M: object set-nth-unsafe set-nth ;
|
||||||
|
@ -53,9 +52,14 @@ M: integer length ;
|
||||||
M: integer nth drop ;
|
M: integer nth drop ;
|
||||||
M: integer nth-unsafe drop ;
|
M: integer nth-unsafe drop ;
|
||||||
|
|
||||||
: first2-unsafe [ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline
|
: first2-unsafe
|
||||||
: first3-unsafe [ first2-unsafe ] keep 2 swap nth-unsafe ; inline
|
[ 0 swap nth-unsafe ] keep 1 swap nth-unsafe ; inline
|
||||||
: first4-unsafe [ first3-unsafe ] keep 3 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 -- )
|
: exchange-unsafe ( n n seq -- )
|
||||||
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
|
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
|
||||||
|
|
|
@ -1,21 +1,21 @@
|
||||||
USING: help sequences sequences-internals ;
|
USING: help sequences sequences-internals ;
|
||||||
|
|
||||||
HELP: length "( seq -- n )"
|
HELP: length
|
||||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } }
|
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } }
|
||||||
{ $contract "Outputs the length of the sequence. All sequences support this operation." } ;
|
{ $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" } }
|
{ $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." }
|
{ $errors "Throws a " { $link bounds-error } " if the new length is negative, or if the sequence is not resizable." }
|
||||||
{ $side-effects "seq" } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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."
|
{ $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." }
|
"Throws an error if the sequence cannot hold elements of the given type." }
|
||||||
{ $side-effects "seq" } ;
|
{ $side-effects "seq" } ;
|
||||||
|
|
||||||
HELP: thaw "( seq -- resizable-seq )"
|
HELP: thaw
|
||||||
{ $values { "seq" "a sequence" } { "resizable-seq" "a resizable mutable sequence" } }
|
{ $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" } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "seq" "a sequence" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if the sequence has zero length." } ;
|
{ $description "Tests if the sequence has zero length." } ;
|
||||||
|
|
||||||
HELP: peek "( seq -- elt )"
|
HELP: delete-all
|
||||||
{ $values { "seq" "a sequence" } { "elt" "an object" } }
|
{ $values { "seq" "a resizable sequence" } }
|
||||||
{ $description "Outputs the last element of the sequence." }
|
{ $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." }
|
||||||
{ $errors "Throws an error if the sequence is empty." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "seq" "a sequence" } { "first" "the first element of the sequence" } }
|
||||||
{ $description "Outputs the first element of the sequence." }
|
{ $description "Outputs the first element of the sequence." }
|
||||||
{ $errors "Throws an error if the sequence is empty." } ;
|
{ $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" } }
|
{ $values { "seq" "a sequence" } { "second" "the second element of the sequence" } }
|
||||||
{ $description "Outputs 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." } ;
|
{ $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" } }
|
{ $values { "seq" "a sequence" } { "third" "the third element of the sequence" } }
|
||||||
{ $description "Outputs 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." } ;
|
{ $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" } }
|
{ $values { "seq" "a sequence" } { "fourth" "the fourth element of the sequence" } }
|
||||||
{ $description "Outputs 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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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" } "." }
|
{ $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" }
|
{ $side-effects "seq" }
|
||||||
{ $see-also pop push-new } ;
|
{ $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" } }
|
{ $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." }
|
{ $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" } "." }
|
{ $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" } ;
|
{ $side-effects "seq" } ;
|
||||||
|
|
||||||
HELP: bounds-check? "( n seq -- ? )"
|
HELP: bounds-check?
|
||||||
{ $values { "n" "an integer" } { "seq" "a sequence" } { "?" "a boolean" } }
|
{ $values { "n" "an integer" } { "seq" "a sequence" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if the index is within the bounds of the sequence." } ;
|
{ $description "Tests if the index is within the bounds of the sequence." } ;
|
||||||
|
|
||||||
HELP: ?nth "( n seq/f -- elt )"
|
HELP: ?nth
|
||||||
{ $values { "n" "an integer" } { "seq" "a sequence" } { "elt" "an object" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $values { "n" "an integer" } { "seq" "a sequence" } { "elt" "an object" } }
|
||||||
{ $contract "Unsafe variant of " { $link nth } " that does not perform bounds checks." } ;
|
{ $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" } }
|
{ $values { "elt" "an object" } { "n" "an integer" } { "seq" "a sequence" } }
|
||||||
{ $contract "Unsafe variant of " { $link set-nth } " that does not perform bounds checks." } ;
|
{ $contract "Unsafe variant of " { $link set-nth } " that does not perform bounds checks." } ;
|
||||||
|
|
||||||
HELP: exchange-unsafe "( m n seq -- )"
|
HELP: exchange-unsafe "( m n seq -- )"
|
||||||
{ $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
|
{ $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." } ;
|
{ $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." } ;
|
||||||
|
|
|
@ -14,15 +14,15 @@ strings vectors ;
|
||||||
|
|
||||||
: tail-slice* ( seq n -- slice ) (slice*) tail-slice ;
|
: 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 -- ? )
|
: head? ( seq begin -- ? )
|
||||||
2dup [ length ] 2apply < [
|
2dup [ length ] 2apply < [
|
||||||
|
@ -31,23 +31,23 @@ strings vectors ;
|
||||||
[ length head-slice ] keep sequence=
|
[ length head-slice ] keep sequence=
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: ?head ( seq begin -- seq ? )
|
: ?head ( seq begin -- newseq ? )
|
||||||
2dup head? [ length tail t ] [ drop f ] if ;
|
2dup head? [ length tail t ] [ drop f ] if ;
|
||||||
|
|
||||||
: tail? ( seq end -- ? )
|
: tail? ( seq end -- newseq ? )
|
||||||
2dup [ length ] 2apply < [
|
2dup [ length ] 2apply < [
|
||||||
2drop f
|
2drop f
|
||||||
] [
|
] [
|
||||||
[ length tail-slice* ] keep sequence=
|
[ length tail-slice* ] keep sequence=
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: ?tail ( seq end -- seq ? )
|
: ?tail ( seq end -- newseq ? )
|
||||||
2dup tail? [ length head* t ] [ drop f ] if ;
|
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 ;
|
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 ;
|
>r f swap dup 1+ r> replace-slice ;
|
||||||
|
|
||||||
: (cut) ( n seq -- before after )
|
: (cut) ( n seq -- before after )
|
||||||
|
@ -66,12 +66,12 @@ strings vectors ;
|
||||||
dupd (cut) >r , r> (group)
|
dupd (cut) >r , r> (group)
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: group ( seq n -- seq ) [ swap (group) ] { } make ;
|
: group ( seq n -- groups ) [ swap (group) ] { } make ;
|
||||||
|
|
||||||
: start-step ( subseq seq n -- subseq slice )
|
: start-step ( subseq seq n -- subseq slice )
|
||||||
pick length dupd + rot <slice> ;
|
pick length dupd + rot <slice> ;
|
||||||
|
|
||||||
: start* ( subseq seq n -- n )
|
: start* ( subseq seq i -- n )
|
||||||
pick length pick length pick - > [
|
pick length pick length pick - > [
|
||||||
3drop -1
|
3drop -1
|
||||||
] [
|
] [
|
||||||
|
@ -97,19 +97,19 @@ strings vectors ;
|
||||||
|
|
||||||
: split-next, V{ } clone , ;
|
: split-next, V{ } clone , ;
|
||||||
|
|
||||||
: (split) ( separator elt -- )
|
: (split) ( quot elt -- )
|
||||||
[ swap call ] keep swap
|
[ swap call ] keep swap
|
||||||
[ drop split-next, ] [ split, ] if ; inline
|
[ drop split-next, ] [ split, ] if ; inline
|
||||||
|
|
||||||
: split* ( seq separator -- split )
|
: split* ( seq quot -- pieces )
|
||||||
over >r
|
over >r
|
||||||
[ split-next, swap [ (split) ] each-with ]
|
[ split-next, swap [ (split) ] each-with ]
|
||||||
{ } make r> swap [ swap like ] map-with ; inline
|
{ } make r> swap [ swap like ] map-with ; inline
|
||||||
|
|
||||||
: split ( seq separators -- split )
|
: split ( seq separators -- pieces )
|
||||||
swap [ over member? ] split* nip ;
|
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
|
2dup mismatch dup -1 = [ drop 2dup min-length ] when
|
||||||
tuck tail-slice >r tail-slice r> ;
|
tuck tail-slice >r tail-slice r> ;
|
||||||
|
|
||||||
|
|
|
@ -1,123 +1,128 @@
|
||||||
USING: help sequences ;
|
USING: help sequences ;
|
||||||
|
|
||||||
HELP: head-slice "( seq n -- slice )"
|
HELP: head-slice
|
||||||
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "slice" "a 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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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." }
|
{ $description "Outputs a new sequence with the same elements as " { $snippet "seq" } " except omitting the " { $snippet "n" } "th element." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example "2 { + - = * / } remove-nth ." "{ + - * / }" }
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "subseq" "a sequence" } { "seq" "a sequence" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $snippet "seq" } " contains the elements of " { $snippet "subseq" } " as a contiguous subsequence." } ;
|
{ $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" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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?\" }" } } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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
|
{ $examples
|
||||||
|
|
|
@ -38,33 +38,30 @@ PREDICATE: integer LETTER CHAR: A CHAR: Z between? ;
|
||||||
PREDICATE: integer digit CHAR: 0 CHAR: 9 between? ;
|
PREDICATE: integer digit CHAR: 0 CHAR: 9 between? ;
|
||||||
PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
|
PREDICATE: integer printable CHAR: \s CHAR: ~ between? ;
|
||||||
PREDICATE: integer control "\0\e\r\n\t\u0008\u007f" member? ;
|
PREDICATE: integer control "\0\e\r\n\t\u0008\u007f" member? ;
|
||||||
|
PREDICATE: printable quotable "\"\\" member? not ;
|
||||||
|
|
||||||
UNION: Letter letter LETTER ;
|
UNION: Letter letter LETTER ;
|
||||||
UNION: alpha Letter digit ;
|
UNION: alpha Letter digit ;
|
||||||
|
|
||||||
: ch>lower ( n -- n ) dup LETTER? [ HEX: 20 + ] when ;
|
: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ;
|
||||||
: ch>upper ( n -- n ) dup letter? [ HEX: 20 - ] when ;
|
: ch>upper ( ch -- lower ) dup letter? [ HEX: 20 - ] when ;
|
||||||
: >lower ( str -- str ) [ ch>lower ] map ;
|
: >lower ( str -- lower ) [ ch>lower ] map ;
|
||||||
: >upper ( str -- str ) [ ch>upper ] map ;
|
: >upper ( str -- upper ) [ ch>upper ] map ;
|
||||||
|
|
||||||
: quotable? ( ch -- ? )
|
: padding ( str n ch -- padstr )
|
||||||
dup printable? swap "\"\\" member? not and ; foldable
|
|
||||||
|
|
||||||
: padding ( string count char -- string )
|
|
||||||
>r swap length [-] r> <string> ;
|
>r swap length [-] r> <string> ;
|
||||||
|
|
||||||
: pad-left ( string count char -- string )
|
: pad-left ( str n ch -- padded )
|
||||||
pick >r padding r> append ;
|
pick >r padding r> append ;
|
||||||
|
|
||||||
: pad-right ( string count char -- string )
|
: pad-right ( str n ch -- padded )
|
||||||
pick >r padding r> swap append ;
|
pick >r padding r> swap append ;
|
||||||
|
|
||||||
: ch>string ( ch -- str ) 1 swap <string> ;
|
: ch>string ( ch -- str ) 1 swap <string> ;
|
||||||
|
|
||||||
: >string ( seq -- array )
|
: >string ( seq -- str )
|
||||||
[ string? ] [ 0 <string> ] >sequence ; inline
|
[ string? ] [ 0 <string> ] >sequence ; inline
|
||||||
|
|
||||||
M: string thaw drop SBUF" " clone ;
|
M: string thaw drop SBUF" " clone ;
|
||||||
|
|
||||||
M: string like
|
M: string like drop dup string? [ >string ] unless ;
|
||||||
drop dup string? [ >string ] unless ;
|
|
||||||
|
|
|
@ -1,92 +1,91 @@
|
||||||
USING: arrays help kernel kernel-internals sequences strings
|
USING: arrays help kernel kernel-internals sequences strings
|
||||||
vectors ;
|
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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "ch" "a character" } { "n" "a fixnum" } { "string" "a string" } }
|
||||||
{ $description "Unsafe string mutator, used to define " { $link set-nth } " on strings." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $description "Creates a new string with the given length and all characters initially set to " { $snippet "ch" } "." }
|
||||||
{ $see-also <array> <quotation> <sbuf> <vector> } ;
|
{ $see-also <array> <quotation> <sbuf> <vector> } ;
|
||||||
|
|
||||||
HELP: blank? "( ch -- ? )"
|
HELP: blank
|
||||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
{ $class-description "Class of integers denoting ASCII whitespace characters." } ;
|
||||||
{ $description "Tests for a whitespace character." } ;
|
|
||||||
|
|
||||||
HELP: letter? "( ch -- ? )"
|
HELP: letter
|
||||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
{ $class-description "Class of integers denoting lowercase alphabet ASCII characters." } ;
|
||||||
{ $description "Tests for a lowercase alphabet character." } ;
|
|
||||||
|
|
||||||
HELP: LETTER? "( ch -- ? )"
|
HELP: LETTER
|
||||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
{ $class-description "Class of integers denoting uppercase alphabet ASCII characters." } ;
|
||||||
{ $description "Tests for a uppercase alphabet character." } ;
|
|
||||||
|
|
||||||
HELP: digit? "( ch -- ? )"
|
HELP: digit
|
||||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
{ $class-description "Class of integers denoting ASCII decimal digit characters." } ;
|
||||||
{ $description "Tests for a decimal digit character." } ;
|
|
||||||
|
|
||||||
HELP: printable? "( ch -- ? )"
|
HELP: Letter
|
||||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
{ $class-description "Class of integers denoting ASCII alphabet characters, both upper and lower case." } ;
|
||||||
{ $description "Tests for a printable ASCII character." } ;
|
|
||||||
|
|
||||||
HELP: control? "( ch -- ? )"
|
HELP: alpha
|
||||||
{ $values { "ch" "a character" } { "?" "a boolean" } }
|
{ $class-description "Class of integers denoting alphanumeric ASCII characters." } ;
|
||||||
{ $description "Tests for an ASCII control character." } ;
|
|
||||||
|
|
||||||
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" } }
|
{ $values { "ch" "a character" } { "lower" "a character" } }
|
||||||
{ $description "Converts a character to lowercase." } ;
|
{ $description "Converts a character to lowercase." } ;
|
||||||
|
|
||||||
HELP: ch>upper "( ch -- lower )"
|
HELP: ch>upper
|
||||||
{ $values { "ch" "a character" } { "lower" "a character" } }
|
{ $values { "ch" "a character" } { "lower" "a character" } }
|
||||||
{ $description "Converts a character to uppercase." } ;
|
{ $description "Converts a character to uppercase." } ;
|
||||||
|
|
||||||
HELP: >lower "( str -- lower )"
|
HELP: >lower
|
||||||
{ $values { "str" "a string" } { "lower" "a string" } }
|
{ $values { "str" "a string" } { "lower" "a string" } }
|
||||||
{ $description "Converts a string to lowercase." } ;
|
{ $description "Converts a string to lowercase." } ;
|
||||||
|
|
||||||
HELP: >upper "( str -- upper )"
|
HELP: >upper
|
||||||
{ $values { "str" "a string" } { "upper" "a string" } }
|
{ $values { "str" "a string" } { "upper" "a string" } }
|
||||||
{ $description "Converts a string to uppercase." } ;
|
{ $description "Converts a string to uppercase." } ;
|
||||||
|
|
||||||
HELP: quotable? "( ch -- ? )"
|
HELP: padding
|
||||||
{ $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 )"
|
|
||||||
{ $values { "str" "a string" } { "n" "a non-negative integer" } { "ch" "a character"} { "padstr" "a new string" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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" } } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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-" } } ;
|
{ $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" } }
|
{ $values { "ch" "a character"} { "str" "a new string" } }
|
||||||
{ $description "Outputs a string of one character." } ;
|
{ $description "Outputs a string of one character." } ;
|
||||||
|
|
||||||
HELP: >string "( seq -- str )"
|
HELP: >string
|
||||||
{ $values { "seq" "a sequence of characters" } { "str" "a new 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." }
|
{ $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." }
|
{ $errors "Throws an error if the sequence contains elements other than real numbers." }
|
||||||
{ $see-also >array >sbuf >vector >quotation } ;
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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" } "." } ;
|
||||||
|
|
|
@ -31,6 +31,6 @@ M: vector like
|
||||||
|
|
||||||
IN: kernel
|
IN: kernel
|
||||||
|
|
||||||
: with-datastack ( stack word -- stack )
|
: with-datastack ( stack word -- newstack )
|
||||||
datastack >r >r >vector set-datastack r> execute
|
datastack >r >r >vector set-datastack r> execute
|
||||||
datastack r> [ push ] keep set-datastack 2nip ;
|
datastack r> [ push ] keep set-datastack 2nip ;
|
||||||
|
|
|
@ -1,25 +1,25 @@
|
||||||
IN: vectors
|
IN: vectors
|
||||||
USING: arrays help kernel strings ;
|
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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $description "Creates a new vector that can hold " { $snippet "n" } " elements before resizing." }
|
||||||
{ $see-also <array> <string> <sbuf> } ;
|
{ $see-also <array> <string> <sbuf> } ;
|
||||||
|
|
||||||
HELP: >vector "( seq -- vector )"
|
HELP: >vector
|
||||||
{ $values { "seq" "a sequence" } { "vector" "a new vector" } }
|
{ $values { "seq" "a sequence" } { "vector" "a new vector" } }
|
||||||
{ $description "Outputs a freshly-allocated vector with the same elements as a given sequence." } ;
|
{ $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" } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
"This word can be marginally more efficient than " { $link >vector } ", but the sharing of storage can lead to unexpected results." } ;
|
"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" } }
|
{ $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." }
|
{ $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
|
{ $examples
|
||||||
|
|
|
@ -6,7 +6,8 @@ USING: errors generic kernel math sequences-internals vectors ;
|
||||||
! A reversal of an underlying sequence.
|
! A reversal of an underlying sequence.
|
||||||
TUPLE: reversed seq ;
|
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 ;
|
M: reversed length reversed-seq length ;
|
||||||
|
|
||||||
|
@ -23,7 +24,7 @@ M: reversed like reversed-seq like ;
|
||||||
|
|
||||||
M: reversed thaw reversed-seq thaw ;
|
M: reversed thaw reversed-seq thaw ;
|
||||||
|
|
||||||
: reverse ( seq -- seq ) [ <reversed> ] keep like ;
|
: reverse ( seq -- newseq ) [ <reversed> ] keep like ;
|
||||||
|
|
||||||
! A slice of another sequence.
|
! A slice of another sequence.
|
||||||
TUPLE: slice seq from to ;
|
TUPLE: slice seq from to ;
|
||||||
|
@ -39,7 +40,7 @@ TUPLE: slice-error reason ;
|
||||||
length over < [ "end > sequence" slice-error ] when
|
length over < [ "end > sequence" slice-error ] when
|
||||||
> [ "start > end" 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.
|
#! A slice of a slice collapses.
|
||||||
>r dup slice? [ collapse-slice ] when r>
|
>r dup slice? [ collapse-slice ] when r>
|
||||||
>r 3dup check-slice r>
|
>r 3dup check-slice r>
|
||||||
|
@ -50,7 +51,7 @@ C: slice ( from to seq -- seq )
|
||||||
M: slice length
|
M: slice length
|
||||||
dup slice-to swap slice-from - ;
|
dup slice-to swap slice-from - ;
|
||||||
|
|
||||||
: slice@ ( n slice -- n seq )
|
: slice@ ( m slice -- n seq )
|
||||||
[ slice-from + ] keep slice-seq ; inline
|
[ slice-from + ] keep slice-seq ; inline
|
||||||
|
|
||||||
M: slice nth slice@ nth ;
|
M: slice nth slice@ nth ;
|
||||||
|
|
|
@ -1,6 +1,22 @@
|
||||||
USING: help sequences ;
|
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" } }
|
{ $values { "str" "a reason" } }
|
||||||
{ $description "Throws a " { $link slice-error } "." }
|
{ $description "Throws a " { $link slice-error } "." }
|
||||||
{ $error-description "Thrown by " { $link <slice> } " if one of the following invalid conditions holds:"
|
{ $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." }
|
{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence." }
|
||||||
{ $see-also <slice> subseq } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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." } ;
|
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." } ;
|
||||||
|
|
||||||
HELP: reverse "( seq -- reversed )"
|
HELP: slice@
|
||||||
{ $values { "seq" "a sequence" } { "reversed" "a sequence" } }
|
{ $values { "m" "a non-negative integer" } { "slice" "an instance of " { $link slice } } { "n" "a non-negative integer" } { "seq" "a sequence" } }
|
||||||
{ $description "Outputs a new sequence having the same elements as " { $snippet "seq" } " but in reverse order." } ;
|
{ $description "Indexes into a slice. Helper word used to implement " { $link "sequence-protocol" } " methods for the " { $link reversed } " class." } ;
|
||||||
|
|
||||||
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." } ;
|
|
||||||
|
|
|
@ -9,7 +9,7 @@ C: alien-callback make-node ;
|
||||||
|
|
||||||
TUPLE: alien-callback-error ;
|
TUPLE: alien-callback-error ;
|
||||||
|
|
||||||
: alien-callback ( return parameters quot -- address )
|
: alien-callback ( return parameters quot -- alien )
|
||||||
<alien-callback-error> throw ;
|
<alien-callback-error> throw ;
|
||||||
|
|
||||||
: callback-bottom ( node -- )
|
: callback-bottom ( node -- )
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
IN: alien
|
IN: alien
|
||||||
USING: errors help ;
|
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." } ;
|
{ $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" } }
|
{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "quot" "a quotation" } { "alien" "an alien address" } }
|
||||||
{ $description
|
{ $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."
|
"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."
|
||||||
|
|
|
@ -1,16 +1,16 @@
|
||||||
IN: alien
|
IN: alien
|
||||||
USING: help ;
|
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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." }
|
{ $errors "Throws an " { $link alien-invoke-error } " if the word calling " { $link alien-invoke } " is not compiled." }
|
||||||
{ $see-also alien-callback } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
|
||||||
|
|
|
@ -21,7 +21,7 @@ M: alien equal?
|
||||||
|
|
||||||
global [ "libraries" nest drop ] bind
|
global [ "libraries" nest drop ] bind
|
||||||
|
|
||||||
: library ( name -- object ) "libraries" get hash ;
|
: library ( name -- library ) "libraries" get hash ;
|
||||||
|
|
||||||
: load-library ( name -- dll )
|
: load-library ( name -- dll )
|
||||||
library dup [
|
library dup [
|
||||||
|
@ -32,7 +32,7 @@ global [ "libraries" nest drop ] bind
|
||||||
] bind
|
] bind
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: add-library ( library name abi -- )
|
: add-library ( name path abi -- )
|
||||||
"libraries" get [
|
"libraries" get [
|
||||||
[ "abi" set "name" set ] make-hash swap set
|
[ "abi" set "name" set ] make-hash swap set
|
||||||
] bind ;
|
] bind ;
|
||||||
|
|
|
@ -1,19 +1,19 @@
|
||||||
IN: alien
|
IN: alien
|
||||||
USING: help ;
|
USING: help ;
|
||||||
|
|
||||||
HELP: alien f
|
HELP: alien
|
||||||
{ $description "The class of alien pointers. See " { $link "syntax-aliens" } " for syntax and " { $link "c-objects" } " for general information." } ;
|
{ $class-description "The class of alien pointers. See " { $link "syntax-aliens" } " for syntax and " { $link "c-objects" } " for general information." } ;
|
||||||
|
|
||||||
HELP: dll f
|
HELP: dll
|
||||||
{ $description "The class of native library handles. See " { $link "dll-internals" } " for syntax and " { $link "c-objects" } " for general information." } ;
|
{ $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" } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
"A byte array is never considered to be expired, whereas passing " { $link f } " always yields true." } ;
|
"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" } }
|
{ $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" } "." }
|
{ $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."
|
{ $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 } "." }
|
"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 } ;
|
{ $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" } }
|
{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "addr" "a non-negative integer" } }
|
||||||
{ $description "Outputs the address of an alien." }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $values { "address" "a non-negative integer" } { "alien" "a new alien address" } }
|
||||||
{ $description "Creates an alien object, wrapping a raw memory address." }
|
{ $description "Creates an alien object, wrapping a raw memory address." }
|
||||||
{ $notes "Alien objects are invalidated between image saves and loads." }
|
{ $notes "Alien objects are invalidated between image saves and loads." }
|
||||||
{ $see-also <displaced-alien> alien-address } ;
|
{ $see-also <displaced-alien> alien-address } ;
|
||||||
|
|
||||||
HELP: c-ptr f
|
HELP: c-ptr
|
||||||
{ $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*" } "." } ;
|
{ $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" } }
|
{ $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:"
|
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
|
||||||
{ $list
|
{ $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" } }
|
{ $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 } "." }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $errors "Throws an error if the symbol could not be found." } ;
|
||||||
|
|
||||||
HELP: dlclose "( dll -- )"
|
HELP: dlclose ( dll -- )
|
||||||
{ $values { "dll" "a DLL handle" } }
|
{ $values { "dll" "a DLL handle" } }
|
||||||
{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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\"" } } }
|
{ $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." }
|
{ $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" } } ;
|
{ $examples { $code "\"gif\" \"libgif.so\" \"cdecl\" add-library" } } ;
|
||||||
|
|
|
@ -15,9 +15,11 @@ parser sequences strings words ;
|
||||||
|
|
||||||
SYMBOL: c-types
|
SYMBOL: c-types
|
||||||
|
|
||||||
|
TUPLE: no-c-type name ;
|
||||||
|
: no-c-type ( type -- * ) <no-c-type> throw ;
|
||||||
|
|
||||||
: c-type ( name -- type )
|
: c-type ( name -- type )
|
||||||
dup c-types get hash
|
dup c-types get hash [ ] [ no-c-type ] ?if ;
|
||||||
[ ] [ "No such C type: " swap append throw ] ?if ;
|
|
||||||
|
|
||||||
: c-size ( name -- size ) "width" swap c-type hash ;
|
: 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 ;
|
>r <c-type> [ swap bind ] keep r> c-types get set-hash ;
|
||||||
inline
|
inline
|
||||||
|
|
||||||
: <c-array> ( size type -- c-ptr )
|
: <c-array> ( n type -- array )
|
||||||
global [ c-size * <byte-array> ] bind ;
|
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 ;
|
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 )
|
: <malloc-string> ( string -- alien )
|
||||||
"\0" append dup length malloc check-ptr
|
"\0" append dup length malloc check-ptr
|
||||||
|
|
|
@ -1,122 +1,131 @@
|
||||||
IN: alien
|
IN: alien
|
||||||
USING: help libc ;
|
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" } }
|
{ $values { "name" "a string" } { "type" "a hashtable" } }
|
||||||
{ $description "Looks up a C type by name." }
|
{ $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" } }
|
{ $values { "name" "a string" } { "size" "an integer" } }
|
||||||
{ $description "Outputs the number of bytes taken up by this C type." }
|
{ $description "Outputs the number of bytes taken up by this C type." }
|
||||||
{ $examples
|
{ $examples
|
||||||
"On a 32-bit system, you will get the following output:"
|
"On a 32-bit system, you will get the following output:"
|
||||||
{ $example "USE: alien\n\"void*\" c-size ." "4" }
|
{ $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 )"
|
HELP: c-align
|
||||||
{ $values { "name" "a string" } { "n" "an integer" } }
|
{ $values { "name" "a string" } { "align" "an integer" } }
|
||||||
{ $description "Outputs alignment at which values of this C type are padded in C structures." }
|
{ $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 )" } } }
|
{ $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." }
|
{ $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 -- )" } } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." }
|
{ $errors "Throws an error if the type does not exist or the requested size is negative." }
|
||||||
{ $see-also <malloc-array> } ;
|
{ $see-also <malloc-array> } ;
|
||||||
|
|
||||||
HELP: <c-object> "( type -- array )"
|
HELP: <c-object>
|
||||||
{ $values { "type" "a string" } { "array" "a byte array" } }
|
{ $values { "type" "a string" } { "array" "a byte array" } }
|
||||||
{ $description "Creates a byte array suitable for holding a value with the given C type." }
|
{ $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." }
|
{ $errors "Throws an error if the type does not exist." }
|
||||||
{ $see-also <malloc-object> } ;
|
{ $see-also <malloc-object> } ;
|
||||||
|
|
||||||
HELP: string>char-alien "( string -- array )"
|
HELP: string>char-alien ( string -- array )
|
||||||
{ $values { "string" "a string" } { "array" "a byte 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." }
|
{ $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." }
|
{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." }
|
||||||
{ $see-also alien>char-string <malloc-string> } ;
|
{ $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" } }
|
{ $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." }
|
{ $description "Reads a null-terminated 8-bit C string from the specified address." }
|
||||||
{ $see-also string>char-alien } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." }
|
{ $errors "Throws an error if the string contains null characters." }
|
||||||
{ $see-also alien>u16-string } ;
|
{ $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" } }
|
{ $values { "c-ptr" "an alien, byte array or " { $link f } } { "string" "a string" } }
|
||||||
{ $description "Reads a null-terminated UTF16 string from the specified address." }
|
{ $description "Reads a null-terminated UTF16 string from the specified address." }
|
||||||
{ $see-also string>u16-alien } ;
|
{ $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" } }
|
{ $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." }
|
{ $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 } "." }
|
{ $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." }
|
{ $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> } ;
|
{ $see-also <c-array> } ;
|
||||||
|
|
||||||
HELP: <malloc-object> "( type -- alien )"
|
HELP: <malloc-object>
|
||||||
{ $values { "type" "a string" } { "alien" "an alien address" } }
|
{ $values { "type" "a string" } { "alien" "an alien address" } }
|
||||||
{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." }
|
{ $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 } "." }
|
{ $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." }
|
{ $errors "Throws an error if the type does not exist or if memory allocation fails." }
|
||||||
{ $see-also <c-object> } ;
|
{ $see-also <c-object> } ;
|
||||||
|
|
||||||
HELP: <malloc-string> "( string -- alien )"
|
HELP: <malloc-string>
|
||||||
{ $values { "string" "a string" } { "alien" "an alien address" } }
|
{ $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." }
|
{ $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 } "." }
|
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||||
{ $errors "Throws an error if memory allocation fails." }
|
{ $errors "Throws an error if memory allocation fails." }
|
||||||
{ $see-also string>char-alien } ;
|
{ $see-also string>char-alien } ;
|
||||||
|
|
||||||
HELP: (typedef) "( old new -- )"
|
HELP: (typedef)
|
||||||
{ $values { "old" "a string" } { "new" "a string" } }
|
{ $values { "old" "a string" } { "new" "a string" } }
|
||||||
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||||
{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }
|
{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }
|
||||||
{ $see-also typedef POSTPONE: TYPEDEF: } ;
|
{ $see-also typedef POSTPONE: TYPEDEF: } ;
|
||||||
|
|
||||||
HELP: define-pointer "( type -- )"
|
HELP: define-pointer
|
||||||
{ $values { "type" "a string" } }
|
{ $values { "type" "a string" } }
|
||||||
{ $description "Aliases the C type " { $snippet "type*" } " to " { $snippet "void*" } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." }
|
{ $notes "You should use the higher-level " { $link POSTPONE: TYPEDEF: } " word instead." }
|
||||||
|
|
|
@ -11,7 +11,7 @@ FUNCTION: void* realloc ( void* ptr, ulong size ) ;
|
||||||
FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
|
FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
|
||||||
|
|
||||||
TUPLE: check-ptr ;
|
TUPLE: check-ptr ;
|
||||||
: check-ptr [ <check-ptr> throw ] unless* ;
|
: check-ptr ( c-ptr -- c-ptr ) [ <check-ptr> throw ] unless* ;
|
||||||
|
|
||||||
: with-malloc ( size quot -- )
|
: with-malloc ( size quot -- )
|
||||||
swap 1 calloc check-ptr [ swap call ] keep free ; inline
|
swap 1 calloc check-ptr [ swap call ] keep free ; inline
|
||||||
|
|
|
@ -1,37 +1,41 @@
|
||||||
IN: libc
|
IN: libc
|
||||||
USING: help ;
|
USING: help ;
|
||||||
|
|
||||||
HELP: malloc "( size -- alien )"
|
HELP: malloc ( size -- alien )
|
||||||
{ $values { "size" "a non-negative integer" } { "alien" "an alien address" } }
|
{ $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."
|
{ $description "Allocates a block of " { $snippet "size" } " bytes from the operating system. The contents of the block are undefined."
|
||||||
$terpri
|
$terpri
|
||||||
"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
|
"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 } "." } ;
|
{ $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" } }
|
{ $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."
|
{ $description "Allocates a block of " { $snippet "count * size" } " bytes from the operating system. The contents of the block are initially zero."
|
||||||
$terpri
|
$terpri
|
||||||
"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
|
"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 } "." } ;
|
{ $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" } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
"Outputs " { $link f } " if memory allocation failed, so calls to this word should be followed by a call to " { $link check-ptr } "." }
|
"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 } "." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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" } }
|
{ $values { "ptr" "an alien address" } }
|
||||||
{ $description "Deallocates a block of memory allocated by " { $link malloc } ", " { $link calloc } " or " { $link realloc } "." } ;
|
{ $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." } ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
IN: alien
|
IN: alien
|
||||||
USING: help ;
|
USING: help ;
|
||||||
|
|
||||||
HELP: c-struct? "( type -- ? )"
|
HELP: c-struct?
|
||||||
{ $values { "type" "a string" } { "?" "a boolean" } }
|
{ $values { "type" "a string" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: BEGIN-STRUCT: } "." } ;
|
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: BEGIN-STRUCT: } "." } ;
|
||||||
|
|
|
@ -19,7 +19,7 @@ words ;
|
||||||
: try-compile ( word -- )
|
: try-compile ( word -- )
|
||||||
[ compile ] [ error. update-xt ] recover ;
|
[ compile ] [ error. update-xt ] recover ;
|
||||||
|
|
||||||
: compile-vocabs ( vocabs -- )
|
: compile-vocabs ( seq -- )
|
||||||
[ words ] map concat
|
[ words ] map concat
|
||||||
dup [ f "no-effect" set-word-prop ] each
|
dup [ f "no-effect" set-word-prop ] each
|
||||||
[ try-compile ] each ;
|
[ try-compile ] each ;
|
||||||
|
|
|
@ -1,40 +1,39 @@
|
||||||
IN: compiler
|
IN: compiler
|
||||||
USING: assembler help words ;
|
USING: assembler help words ;
|
||||||
|
|
||||||
HELP: compiled? "( word -- ? )"
|
HELP: compiled? ( word -- ? )
|
||||||
{ $values { "word" "a word" } }
|
{ $values { "word" "a word" } }
|
||||||
{ $description "Tests if a word is compiled." }
|
{ $description "Tests if a word is compiled." } ;
|
||||||
{ $notes "Primitives are considered as compiled words." } ;
|
|
||||||
|
|
||||||
HELP: compile "( word -- )"
|
HELP: compile
|
||||||
{ $values { "word" "a word" } }
|
{ $values { "word" "a word" } }
|
||||||
{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "word" "a word" } }
|
||||||
{ $description "Compiles a word together with any uncompiled dependencies. Does nothing if the word is already compiled." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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." } ;
|
{ $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" } }
|
{ $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 } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "quot" "a quotation" } }
|
||||||
{ $description "Compiles and runs a quotation." }
|
{ $description "Compiles and runs a quotation." }
|
||||||
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
|
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
|
||||||
|
|
||||||
IN: assembler
|
IN: assembler
|
||||||
|
|
||||||
HELP: finalize-compile "( xts -- )"
|
HELP: finalize-compile ( xts -- )
|
||||||
{ $values { "xts" "an array of pairs mapping words to 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." } ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: inference
|
IN: inference
|
||||||
USING: help kernel ;
|
USING: help kernel ;
|
||||||
|
|
||||||
HELP: inference-error "( msg -- )"
|
HELP: inference-error
|
||||||
{ $values { "msg" "an object" } }
|
{ $values { "msg" "an object" } }
|
||||||
{ $description "Throws an " { $link inference-error } "." }
|
{ $description "Throws an " { $link inference-error } "." }
|
||||||
{ $error-description
|
{ $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."
|
"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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $errors "Throws an error if stack effect inference fails." } ;
|
||||||
|
|
|
@ -36,7 +36,7 @@ words ;
|
||||||
: will-inline-method ( node -- quot/t )
|
: will-inline-method ( node -- quot/t )
|
||||||
#! t indicates failure
|
#! t indicates failure
|
||||||
dup inlining-class dup
|
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 )
|
: inline-standard-method ( node -- node )
|
||||||
dup will-inline-method (inline-method) ;
|
dup will-inline-method (inline-method) ;
|
||||||
|
|
|
@ -5,16 +5,16 @@ USING: arrays definitions errors hashtables kernel
|
||||||
kernel-internals namespaces sequences strings words
|
kernel-internals namespaces sequences strings words
|
||||||
vectors math parser ;
|
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: typemap
|
||||||
SYMBOL: builtins
|
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 ;
|
word-name "?" append create-in ;
|
||||||
|
|
||||||
: predicate-effect 1 1 <effect> ;
|
: predicate-effect 1 1 <effect> ;
|
||||||
|
@ -29,14 +29,14 @@ SYMBOL: builtins
|
||||||
3drop
|
3drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: superclass "superclass" word-prop ;
|
: superclass ( class -- super ) "superclass" word-prop ;
|
||||||
|
|
||||||
: members "members" word-prop ;
|
: members "members" word-prop ;
|
||||||
|
|
||||||
: (flatten-class) ( class -- )
|
: (flatten-class) ( class -- )
|
||||||
dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
|
dup members [ [ (flatten-class) ] each ] [ dup set ] ?if ;
|
||||||
|
|
||||||
: flatten-class ( class -- classes )
|
: flatten-class ( class -- seq )
|
||||||
[ (flatten-class) ] make-hash ;
|
[ (flatten-class) ] make-hash ;
|
||||||
|
|
||||||
: (types) ( class -- )
|
: (types) ( class -- )
|
||||||
|
@ -45,7 +45,7 @@ SYMBOL: builtins
|
||||||
[ (types) ] [ "type" word-prop dup set ] ?if
|
[ (types) ] [ "type" word-prop dup set ] ?if
|
||||||
] hash-each ;
|
] hash-each ;
|
||||||
|
|
||||||
: types ( class -- types )
|
: types ( class -- seq )
|
||||||
[ (types) ] make-hash hash-keys natural-sort ;
|
[ (types) ] make-hash hash-keys natural-sort ;
|
||||||
|
|
||||||
DEFER: (class<)
|
DEFER: (class<)
|
||||||
|
@ -60,7 +60,7 @@ DEFER: (class<)
|
||||||
: class-empty? ( class -- ? )
|
: class-empty? ( class -- ? )
|
||||||
members dup [ empty? ] when ;
|
members dup [ empty? ] when ;
|
||||||
|
|
||||||
: (class<) ( cls1 cls2 -- ? )
|
: (class<) ( class1 class2 -- ? )
|
||||||
{
|
{
|
||||||
{ [ 2dup eq? ] [ 2drop t ] }
|
{ [ 2dup eq? ] [ 2drop t ] }
|
||||||
{ [ over class-empty? ] [ 2drop t ] }
|
{ [ over class-empty? ] [ 2drop t ] }
|
||||||
|
@ -71,7 +71,7 @@ DEFER: (class<)
|
||||||
|
|
||||||
SYMBOL: class<cache
|
SYMBOL: class<cache
|
||||||
|
|
||||||
: class< ( cls1 cls2 -- ? )
|
: class< ( class1 class2 -- ? )
|
||||||
class<cache get [ hash hash-member? ] [ (class<) ] if* ;
|
class<cache get [ hash hash-member? ] [ (class<) ] if* ;
|
||||||
|
|
||||||
: smaller-classes ( class seq -- )
|
: smaller-classes ( class seq -- )
|
||||||
|
@ -86,18 +86,19 @@ SYMBOL: class<cache
|
||||||
[ make-class<cache class<cache set call ] with-scope ;
|
[ make-class<cache class<cache set call ] with-scope ;
|
||||||
inline
|
inline
|
||||||
|
|
||||||
: class-compare ( cls1 cls2 -- -1/0/1 )
|
: class-compare ( class1 class2 -- n )
|
||||||
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
|
2dup eq? [ 2drop 0 ] [ class< 1 -1 ? ] if ;
|
||||||
|
|
||||||
: lookup-union ( class-set -- class )
|
: lookup-union ( classes -- class )
|
||||||
typemap get hash [ object ] unless* ;
|
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 )
|
: (class-or) ( class class -- class )
|
||||||
[ types* ] 2apply hash-union lookup-union ;
|
[ types* ] 2apply hash-union lookup-union ;
|
||||||
|
|
||||||
: class-or ( class class -- class )
|
: class-or ( class1 class2 -- class )
|
||||||
{
|
{
|
||||||
{ [ 2dup class< ] [ nip ] }
|
{ [ 2dup class< ] [ nip ] }
|
||||||
{ [ 2dup swap class< ] [ drop ] }
|
{ [ 2dup swap class< ] [ drop ] }
|
||||||
|
@ -107,14 +108,14 @@ SYMBOL: class<cache
|
||||||
: (class-and) ( class class -- class )
|
: (class-and) ( class class -- class )
|
||||||
[ types* ] 2apply hash-intersect lookup-union ;
|
[ types* ] 2apply hash-intersect lookup-union ;
|
||||||
|
|
||||||
: class-and ( class class -- class )
|
: class-and ( class1 class2 -- class )
|
||||||
{
|
{
|
||||||
{ [ 2dup class< ] [ drop ] }
|
{ [ 2dup class< ] [ drop ] }
|
||||||
{ [ 2dup swap class< ] [ nip ] }
|
{ [ 2dup swap class< ] [ nip ] }
|
||||||
{ [ t ] [ (class-and) ] }
|
{ [ t ] [ (class-and) ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: classes-intersect? ( class class -- ? )
|
: classes-intersect? ( class1 class2 -- ? )
|
||||||
class-and class-empty? not ;
|
class-and class-empty? not ;
|
||||||
|
|
||||||
: min-class ( class seq -- class/f )
|
: min-class ( class seq -- class/f )
|
||||||
|
@ -139,7 +140,7 @@ SYMBOL: class<cache
|
||||||
PREDICATE: class predicate "definition" word-prop ;
|
PREDICATE: class predicate "definition" word-prop ;
|
||||||
|
|
||||||
! Union classes for dispatch on multiple classes.
|
! Union classes for dispatch on multiple classes.
|
||||||
: union-predicate ( members -- list )
|
: union-predicate ( seq -- quot )
|
||||||
[ dup ] swap [ "predicate" word-prop append ] map-with
|
[ dup ] swap [ "predicate" word-prop append ] map-with
|
||||||
[ [ drop t ] 2array ] map [ drop f ] swap alist>quot ;
|
[ [ drop t ] 2array ] map [ drop f ] swap alist>quot ;
|
||||||
|
|
||||||
|
|
|
@ -1,34 +1,37 @@
|
||||||
USING: generic help kernel kernel-internals ;
|
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." }
|
{ $description "Global variable. Hashtable mapping unions to class words." }
|
||||||
{ $see-also class-and } ;
|
{ $see-also class-and } ;
|
||||||
|
|
||||||
HELP: builtins f
|
HELP: builtins
|
||||||
{ $description "Global variable. Vector mapping type numbers to builtin class words." } ;
|
{ $description "Global variable. Vector mapping type numbers to builtin class words." } ;
|
||||||
|
|
||||||
HELP: object f
|
HELP: object
|
||||||
{ $description
|
{ $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:"
|
"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 ;" }
|
{ $code "GENERIC: enclose" "M: number enclose 1array ;" "M: object enclose ;" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: null f
|
HELP: null
|
||||||
{ $description
|
{ $description
|
||||||
"The canonical empty class with no instances."
|
"The canonical empty class with no instances."
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
HELP: type>class
|
||||||
HELP: type>class "( n -- class )"
|
|
||||||
{ $values { "n" "a non-negative integer" } { "class" "a class word" } }
|
{ $values { "n" "a non-negative integer" } { "class" "a class word" } }
|
||||||
{ $description "Outputs a builtin class whose instances are precisely those of a builtin type." }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "quot" "a quotation" } }
|
||||||
{ $description
|
{ $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:"
|
"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 ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: superclass "( class -- super )"
|
HELP: superclass
|
||||||
{ $values { "class" "a class word" } { "super" "a class word" } }
|
{ $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." }
|
{ $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: } ").." } ;
|
{ $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 } } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "class" "a class" } }
|
||||||
{ $description "Tests if a class is a union class with no members." }
|
{ $description "Tests if a class is a union class with no members." }
|
||||||
{ $examples { $example "null class-empty? ." "t" } } ;
|
{ $examples { $example "null class-empty? ." "t" } } ;
|
||||||
|
|
||||||
HELP: class< "( class1 class2 -- ? )"
|
HELP: class<
|
||||||
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
|
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $values { "class1" "a class" } { "class2" "a class" } { "n" "an integer" } }
|
||||||
{ $description "Compares two classes, with the sign of the result indicating their sort order." }
|
{ $description "Compares two classes, with the sign of the result indicating their sort order." }
|
||||||
{ $notes "This word is used to sort sequences of classes." }
|
{ $notes "This word is used to sort sequences of classes." }
|
||||||
{ $see-also methods order } ;
|
{ $see-also methods order } ;
|
||||||
|
|
||||||
HELP: ?make-generic "( word -- )"
|
HELP: lookup-union
|
||||||
{ $values { "word" "a generic word" } }
|
{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" "a class 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." }
|
{ $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 } "." }
|
||||||
$low-level-note ;
|
{ $see-also "unions" class-and class-or } ;
|
||||||
|
|
||||||
HELP: init-methods "( word -- )"
|
HELP: types*
|
||||||
{ $values { "word" "a word" } }
|
{ $values { "class" "a class word" } { "classes" "a hashtable mapping class words to themselves" } }
|
||||||
{ $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" } }
|
|
||||||
{ $description "Outputs a sequence of builtin classes whose instances can possibly be instances of the given class." } ;
|
{ $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" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $values { "class1" "a class word" } { "class2" "a class word" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if two classes have a non-empty intersection." } ;
|
{ $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 } } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $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." }
|
{ $description "Sets a property indicating this is a class word, and registers the class in the global union lookup map." }
|
||||||
$low-level-note ;
|
$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 -- )"
|
HELP: define-predicate-class "( class predicate definition -- )"
|
||||||
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
|
{ $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." }
|
{ $description "Defines a predicate class. The superclass of " { $snippet "class" } " must already be set." }
|
||||||
{ $see-also POSTPONE: PREDICATE: } ;
|
{ $see-also POSTPONE: PREDICATE: } ;
|
||||||
|
|
||||||
HELP: predicate f
|
HELP: predicate
|
||||||
{ $description "The class of predicate class words." }
|
{ $class-description "The class of predicate class words." }
|
||||||
{ $see-also POSTPONE: PREDICATE: } ;
|
{ $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 -- ? )" } } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "class" "a class word" } { "predicate" "a predicate word" } { "members" "a sequence of class words" } }
|
||||||
{ $description "Defines a union class with specified members." }
|
{ $description "Defines a union class with specified members." }
|
||||||
{ $see-also POSTPONE: UNION: } ;
|
{ $see-also POSTPONE: UNION: } ;
|
||||||
|
|
||||||
HELP: union f
|
HELP: union
|
||||||
{ $description "The class of union class words." }
|
{ $class-description "The class of union class words." }
|
||||||
{ $see-also POSTPONE: UNION: } ;
|
{ $see-also "unions" POSTPONE: UNION: } ;
|
||||||
|
|
|
@ -1,19 +1,25 @@
|
||||||
IN: generic
|
IN: generic
|
||||||
USING: help ;
|
USING: help ;
|
||||||
|
|
||||||
HELP: methods "( word -- alist )"
|
HELP: generic
|
||||||
{ $values { "word" "a generic word" } { "alist" "a sequence of pairs" } }
|
{ $class-description "The class of generic words." }
|
||||||
{ $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." } ;
|
{ $see-also "generic" POSTPONE: GENERIC: POSTPONE: G: } ;
|
||||||
|
|
||||||
HELP: order "( word -- classes )"
|
HELP: make-generic
|
||||||
{ $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 -- )"
|
|
||||||
{ $values { "word" "a generic word" } }
|
{ $values { "word" "a generic word" } }
|
||||||
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
|
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
|
||||||
$low-level-note ;
|
$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 } ;
|
||||||
|
|
|
@ -1,20 +1,14 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005, 2006 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: generic
|
IN: generic
|
||||||
USING: arrays errors generic hashtables kernel kernel-internals
|
USING: arrays errors generic hashtables kernel kernel-internals
|
||||||
math namespaces sequences words ;
|
math namespaces sequences words ;
|
||||||
|
|
||||||
! Math combination for generic dyadic upgrading arithmetic.
|
PREDICATE: class math-class ( object -- ? )
|
||||||
|
|
||||||
: math-class? ( object -- ? )
|
|
||||||
dup word? [
|
|
||||||
dup null bootstrap-word eq? [
|
dup null bootstrap-word eq? [
|
||||||
drop f
|
drop f
|
||||||
] [
|
] [
|
||||||
number bootstrap-word class<
|
number bootstrap-word class<
|
||||||
] if
|
|
||||||
] [
|
|
||||||
drop f
|
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: math-class-compare ( class class -- n )
|
: math-class-compare ( class class -- n )
|
||||||
|
@ -33,7 +27,7 @@ math namespaces sequences words ;
|
||||||
"coercer" word-prop [ [ ] ] unless*
|
"coercer" word-prop [ [ ] ] unless*
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: math-upgrade ( left right -- quot )
|
: math-upgrade ( class1 class2 -- quot )
|
||||||
[ math-class-max ] 2keep
|
[ math-class-max ] 2keep
|
||||||
>r over r> (math-upgrade)
|
>r over r> (math-upgrade)
|
||||||
>r (math-upgrade) dup empty? [ 1 make-dip ] unless
|
>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-method ( generic -- quot )
|
||||||
object bootstrap-word applicable-method ;
|
object bootstrap-word applicable-method ;
|
||||||
|
|
||||||
: math-method ( word left right -- quot )
|
: math-method ( word class1 class2 -- quot )
|
||||||
2dup and [
|
2dup and [
|
||||||
2dup math-upgrade >r
|
2dup math-upgrade >r
|
||||||
math-class-max over order min-class applicable-method
|
math-class-max over order min-class applicable-method
|
||||||
|
|
|
@ -1,28 +1,25 @@
|
||||||
USING: generic help math ;
|
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 )" } } }
|
{ $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." }
|
{ $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> ]" } } ;
|
{ $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" } }
|
{ $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } }
|
||||||
{ $description "Throws a " { $link no-math-method } " error." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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+ ]" } } ;
|
{ $examples { $example "\\ + fixnum float math-method ." "[ >r >float r> float+ ]" } } ;
|
||||||
|
|
||||||
HELP: math-class? "( object -- ? )"
|
HELP: math-class
|
||||||
{ $values { "object" "an object" } { "?" "a boolean" } }
|
{ $values { "object" "an object" } { "?" "a boolean" } }
|
||||||
{ $description
|
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
|
||||||
"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 } }
|
|
||||||
} ;
|
|
||||||
|
|
||||||
HELP: math-combination "( word -- quot )"
|
HELP: math-combination
|
||||||
{ $values { "word" "a generic word" } { "quot" "a quotation" } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
|
@ -39,5 +36,6 @@ $terpri
|
||||||
}
|
}
|
||||||
"The math combination performs numerical upgrading as described in " { $link "number-protocol" } "." } ;
|
"The math combination performs numerical upgrading as described in " { $link "number-protocol" } "." } ;
|
||||||
|
|
||||||
HELP: 2generic f
|
HELP: 2generic
|
||||||
{ $description "The class of generic words with the math combination." } ;
|
{ $class-description "The class of generic words using " { $link math-combination } "." }
|
||||||
|
{ $see-also POSTPONE: G: } ;
|
||||||
|
|
|
@ -18,15 +18,15 @@ M: f method-loc ;
|
||||||
M: quotation method-def ;
|
M: quotation method-def ;
|
||||||
M: quotation method-loc drop f ;
|
M: quotation method-loc drop f ;
|
||||||
|
|
||||||
: method ( class generic -- quot )
|
: method ( class generic -- method/f )
|
||||||
"methods" word-prop hash method-def ;
|
"methods" word-prop hash ;
|
||||||
|
|
||||||
: methods ( generic -- alist )
|
: methods ( generic -- assoc )
|
||||||
"methods" word-prop hash>alist
|
"methods" word-prop hash>alist
|
||||||
[ [ first ] 2apply class-compare ] sort
|
[ [ first ] 2apply class-compare ] sort
|
||||||
[ first2 method-def 2array ] map ;
|
[ first2 method-def 2array ] map ;
|
||||||
|
|
||||||
: order ( generic -- list )
|
: order ( generic -- seq )
|
||||||
"methods" word-prop hash-keys [ class-compare ] sort ;
|
"methods" word-prop hash-keys [ class-compare ] sort ;
|
||||||
|
|
||||||
TUPLE: check-method class generic ;
|
TUPLE: check-method class generic ;
|
||||||
|
@ -43,12 +43,11 @@ TUPLE: check-method class generic ;
|
||||||
>r bootstrap-word r> check-method
|
>r bootstrap-word r> check-method
|
||||||
[ set-hash ] with-methods ;
|
[ set-hash ] with-methods ;
|
||||||
|
|
||||||
: implementors ( class -- list )
|
: implementors ( class -- seq )
|
||||||
[ "methods" word-prop ?hash* nip ] word-subset-with ;
|
[ "methods" word-prop ?hash* nip ] word-subset-with ;
|
||||||
|
|
||||||
M: method-spec where
|
M: method-spec where
|
||||||
dup first2 "methods" word-prop hash method-loc
|
dup first2 method method-loc [ ] [ second where ] ?if ;
|
||||||
[ ] [ second where ] ?if ;
|
|
||||||
|
|
||||||
M: method-spec subdefs drop f ;
|
M: method-spec subdefs drop f ;
|
||||||
|
|
||||||
|
|
|
@ -1,20 +1,43 @@
|
||||||
IN: generic
|
IN: generic
|
||||||
USING: help ;
|
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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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 -- )" } } }
|
{ $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." }
|
{ $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 ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: define-method "( quot class generic -- )"
|
HELP: define-method
|
||||||
{ $values { "quot" "a quotation" } { "class" "a class word" } { "generic" "a generic word" } }
|
{ $values { "method" "an instance of " { $link method } } { "class" "a class word" } { "generic" "a generic word" } }
|
||||||
{ $description "Defines a method on " { $snippet "generic" } " associating " { $snippet "class" } " with " { $snippet "quot" } "." } ;
|
{ $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" } }
|
{ $values { "class" "a class word" } { "seq" "a sequence of generic words" } }
|
||||||
{ $description "Finds all generic words in the dictionary implementing methods for this class." } ;
|
{ $description "Finds all generic words in the dictionary implementing methods for this class." } ;
|
||||||
|
|
|
@ -5,13 +5,13 @@ IN: generic
|
||||||
USING: arrays kernel kernel-internals math namespaces
|
USING: arrays kernel kernel-internals math namespaces
|
||||||
parser sequences strings words ;
|
parser sequences strings words ;
|
||||||
|
|
||||||
: define-typecheck ( class generic def -- )
|
: define-typecheck ( class generic quot -- )
|
||||||
over define-generic -rot define-method ;
|
over define-generic -rot define-method ;
|
||||||
|
|
||||||
: define-slot-word ( class slot word quot -- )
|
: define-slot-word ( class slot word quot -- )
|
||||||
rot >fixnum add* define-typecheck ;
|
rot >fixnum add* define-typecheck ;
|
||||||
|
|
||||||
: reader-effect 1 1 <effect> ; inline
|
: reader-effect ( -- effect ) 1 1 <effect> ; inline
|
||||||
|
|
||||||
: define-reader ( class slot decl reader -- )
|
: define-reader ( class slot decl reader -- )
|
||||||
dup [
|
dup [
|
||||||
|
@ -23,7 +23,7 @@ parser sequences strings words ;
|
||||||
2drop 2drop
|
2drop 2drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: writer-effect 2 0 <effect> ; inline
|
: writer-effect ( -- effect ) 2 0 <effect> ; inline
|
||||||
|
|
||||||
: define-writer ( class slot writer -- )
|
: define-writer ( class slot writer -- )
|
||||||
dup [
|
dup [
|
||||||
|
|
|
@ -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" } }
|
{ $values { "class" "a class word" } { "generic" "a generic word" } { "quot" "a quotation" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Defines a generic word with the " { $link standard-combination } " using dispatch position 0, and having one method on " { $snippet "class" } "."
|
"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." } ;
|
{ $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 -- )"
|
HELP: define-slot-word
|
||||||
{ $values { "class" "a class word" } { "slot" "a non-negative integer" } { "word" "a new word" } { "quot" "a quotation" } }
|
{ $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." }
|
{ $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 ;
|
$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" } }
|
{ $values { "class" "a class word" } { "spec" "a sequence of triples" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Defines a set of slot accessor/mutator words."
|
"Defines a set of slot accessor/mutator words."
|
||||||
|
@ -34,6 +53,7 @@ HELP: define-slots "( class spec -- )"
|
||||||
}
|
}
|
||||||
$low-level-note ;
|
$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" } }
|
{ $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: } "." } ;
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
USING: generic help sequences ;
|
USING: generic help sequences ;
|
||||||
|
|
||||||
HELP: no-method "( object generic -- )"
|
HELP: no-method
|
||||||
{ $values { "object" "an object" } { "generic" "a generic word" } }
|
{ $values { "object" "an object" } { "generic" "a generic word" } }
|
||||||
{ $description "Throws a " { $link no-method } " error." }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $values { "word" "a generic word" } { "dispatch#" "a dispatch position" } { "quot" "a new quotation" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Performs standard method combination."
|
"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." }
|
{ $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* } ;
|
{ $see-also POSTPONE: GENERIC: define-generic POSTPONE: G: define-generic* } ;
|
||||||
|
|
||||||
HELP: define-generic "( word -- )"
|
HELP: define-generic
|
||||||
{ $values { "word" "a word" } }
|
{ $values { "word" "a word" } }
|
||||||
{ $description "Defines a generic word with the " { $link standard-combination } " method combination, and a dispatch position of 0." }
|
{ $description "Defines a generic word with the " { $link standard-combination } " method combination, and a dispatch position of 0." }
|
||||||
{ $see-also POSTPONE: GENERIC: define-generic* } ;
|
{ $see-also POSTPONE: GENERIC: define-generic* } ;
|
||||||
|
|
|
@ -7,7 +7,7 @@ sequences-internals strings vectors words ;
|
||||||
|
|
||||||
IN: kernel-internals
|
IN: kernel-internals
|
||||||
|
|
||||||
: tuple= ( tuple tuple -- ? )
|
: tuple= ( tuple1 tuple2 -- ? )
|
||||||
2dup [ array-capacity ] 2apply number= [
|
2dup [ array-capacity ] 2apply number= [
|
||||||
dup array-capacity
|
dup array-capacity
|
||||||
[ 2dup swap array-nth >r pick array-nth r> = ] all? 2nip
|
[ 2dup swap array-nth >r pick array-nth r> = ] all? 2nip
|
||||||
|
@ -20,7 +20,7 @@ IN: generic
|
||||||
: class ( object -- class )
|
: class ( object -- class )
|
||||||
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
|
dup tuple? [ 2 slot ] [ type type>class ] if ; inline
|
||||||
|
|
||||||
: tuple-predicate ( word -- )
|
: tuple-predicate ( class -- )
|
||||||
dup predicate-word [
|
dup predicate-word [
|
||||||
[ dup tuple? ] %
|
[ dup tuple? ] %
|
||||||
[ [ 2 slot ] % over literalize , \ eq? , ] [ ] make ,
|
[ [ 2 slot ] % over literalize , \ eq? , ] [ ] make ,
|
||||||
|
@ -30,7 +30,7 @@ IN: generic
|
||||||
: forget-tuple ( class -- )
|
: forget-tuple ( class -- )
|
||||||
dup forget "predicate" word-prop first [ forget ] when* ;
|
dup forget "predicate" word-prop first [ forget ] when* ;
|
||||||
|
|
||||||
: check-shape ( word slots -- )
|
: check-shape ( class slots -- )
|
||||||
>r in get lookup dup [
|
>r in get lookup dup [
|
||||||
dup "tuple-size" word-prop r> length 2 + =
|
dup "tuple-size" word-prop r> length 2 + =
|
||||||
[ drop ] [ forget-tuple ] if
|
[ drop ] [ forget-tuple ] if
|
||||||
|
@ -40,7 +40,7 @@ IN: generic
|
||||||
|
|
||||||
: delegate-slots { { 3 object delegate set-delegate } } ;
|
: delegate-slots { { 3 object delegate set-delegate } } ;
|
||||||
|
|
||||||
: tuple-slots ( tuple slots -- )
|
: tuple-slots ( class slots -- )
|
||||||
2dup "slot-names" set-word-prop
|
2dup "slot-names" set-word-prop
|
||||||
2dup length 2 + "tuple-size" set-word-prop
|
2dup length 2 + "tuple-size" set-word-prop
|
||||||
dupd 4 simple-slots
|
dupd 4 simple-slots
|
||||||
|
@ -61,13 +61,13 @@ TUPLE: check-tuple class ;
|
||||||
\ <tuple> , %
|
\ <tuple> , %
|
||||||
] [ ] make define-compound ;
|
] [ ] make define-compound ;
|
||||||
|
|
||||||
: default-constructor ( tuple -- )
|
: default-constructor ( class -- )
|
||||||
dup create-constructor 2dup "constructor" set-word-prop
|
dup create-constructor 2dup "constructor" set-word-prop
|
||||||
swap dup "slots" word-prop unclip drop <reversed>
|
swap dup "slots" word-prop unclip drop <reversed>
|
||||||
[ [ tuck ] swap peek add ] map concat >quotation
|
[ [ tuck ] swap peek add ] map concat >quotation
|
||||||
define-constructor ;
|
define-constructor ;
|
||||||
|
|
||||||
: define-tuple ( tuple slots -- )
|
: define-tuple ( class slots -- )
|
||||||
2dup check-shape
|
2dup check-shape
|
||||||
>r create-in
|
>r create-in
|
||||||
dup intern-symbol
|
dup intern-symbol
|
||||||
|
@ -91,7 +91,7 @@ M: tuple equal?
|
||||||
: delegates ( obj -- seq )
|
: delegates ( obj -- seq )
|
||||||
[ (delegates) ] { } make ;
|
[ (delegates) ] { } make ;
|
||||||
|
|
||||||
: is? ( obj pred -- ? )
|
: is? ( obj quot -- ? )
|
||||||
>r delegates r> contains? ; inline
|
>r delegates r> contains? ; inline
|
||||||
|
|
||||||
: >tuple ( seq -- tuple )
|
: >tuple ( seq -- tuple )
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
USING: generic help kernel kernel-internals ;
|
USING: generic help kernel kernel-internals ;
|
||||||
|
|
||||||
HELP: tuple= "( tuple1 tuple2 -- ? )"
|
HELP: tuple=
|
||||||
{ $values { "tuple1" "a tuple" } { "tuple2" "a tuple" } }
|
{ $values { "tuple1" "a tuple" } { "tuple2" "a tuple" } }
|
||||||
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
|
{ $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." } ;
|
{ $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
|
HELP: tuple
|
||||||
{ $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."
|
{ $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
|
$terpri
|
||||||
"Tuple classes have additional word properties:"
|
"Tuple classes have additional word properties:"
|
||||||
{ $list
|
{ $list
|
||||||
|
@ -14,74 +14,78 @@ $terpri
|
||||||
{ { $snippet "\"tuple-size\"" } " - the number of slots" }
|
{ { $snippet "\"tuple-size\"" } " - the number of slots" }
|
||||||
} } ;
|
} } ;
|
||||||
|
|
||||||
HELP: class "( object -- class )"
|
HELP: class
|
||||||
{ $values { "object" "an object" } { "class" "a class word" } }
|
{ $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." }
|
{ $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" } } ;
|
{ $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" } }
|
{ $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." }
|
{ $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 ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: check-shape "( class slots -- )"
|
HELP: check-shape
|
||||||
{ $values { "class" "a tuple class word" } { "slots" "a sequence of strings" } }
|
{ $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."
|
{ $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
|
$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." }
|
"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 ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: tuple-slots "( class slots -- )"
|
HELP: tuple-slots
|
||||||
{ $values { "class" "a tuple class word" } { "slots" "a sequence of strings" } }
|
{ $values { "class" "a tuple class word" } { "slots" "a sequence of strings" } }
|
||||||
{ $description "Defines slot accessor and mutator words for the tuple." }
|
{ $description "Defines slot accessor and mutator words for the tuple." }
|
||||||
$low-level-note ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: tuple-class f
|
HELP: tuple-class
|
||||||
{ $description "The class of tuple class words." }
|
{ $class-description "The class of tuple class words." }
|
||||||
{ $examples { $example "TUPLE: name title first last ;\nname tuple-class? ." "t" } } ;
|
{ $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" } }
|
{ $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 } "." }
|
{ $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: } ;
|
{ $see-also POSTPONE: C: } ;
|
||||||
|
|
||||||
HELP: check-tuple "( class -- )"
|
HELP: check-tuple
|
||||||
{ $values { "word" "a word" } }
|
{ $values { "class" "a class" } }
|
||||||
{ $description "Throws an error if " { $snippet "word" } " is not a tuple class word." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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 }" } } ;
|
{ $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" } }
|
{ $values { "class" "a new word" } { "slots" "a sequence of strings" } }
|
||||||
{ $description "Defines a tuple class with slots named by " { $snippet "slots" } "." }
|
{ $description "Defines a tuple class with slots named by " { $snippet "slots" } "." }
|
||||||
{ $see-also POSTPONE: TUPLE: } ;
|
{ $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" } }
|
{ $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."
|
{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
|
||||||
$terpri
|
$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." } ;
|
"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" } }
|
{ $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."
|
{ $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
|
$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 } "." }
|
"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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "array" "a array" } { "tuple" "a new tuple" } }
|
||||||
{ $description "Outputs a tuple having the same slot values as the array." }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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" } "." } ;
|
||||||
|
|
|
@ -18,7 +18,7 @@ M: word article-content
|
||||||
] ?if
|
] ?if
|
||||||
] { } make ;
|
] { } make ;
|
||||||
|
|
||||||
: $title ( article -- )
|
: $title ( topic -- )
|
||||||
title-style [
|
title-style [
|
||||||
title-style [
|
title-style [
|
||||||
dup [ 1array $link ] ($block) $doc-path
|
dup [ 1array $link ] ($block) $doc-path
|
||||||
|
@ -34,7 +34,7 @@ M: word article-content
|
||||||
|
|
||||||
: handbook ( -- ) "handbook" help ;
|
: handbook ( -- ) "handbook" help ;
|
||||||
|
|
||||||
: $subtopic ( object -- )
|
: $subtopic ( element -- )
|
||||||
[
|
[
|
||||||
subtopic-style [
|
subtopic-style [
|
||||||
unclip f rot [ print-content ] curry write-outliner
|
unclip f rot [ print-content ] curry write-outliner
|
||||||
|
@ -46,7 +46,7 @@ M: word article-content
|
||||||
dup [ (help) ] curry
|
dup [ (help) ] curry
|
||||||
write-outliner ;
|
write-outliner ;
|
||||||
|
|
||||||
: $subsection ( object -- )
|
: $subsection ( element -- )
|
||||||
[
|
[
|
||||||
subsection-style [ first ($subsection) ] with-style
|
subsection-style [ first ($subsection) ] with-style
|
||||||
] ($block) ;
|
] ($block) ;
|
||||||
|
@ -56,5 +56,5 @@ M: word article-content
|
||||||
sort-articles [ ($subsection) terpri ] each
|
sort-articles [ ($subsection) terpri ] each
|
||||||
] with-style ;
|
] with-style ;
|
||||||
|
|
||||||
: $outliner ( content -- )
|
: $outliner ( element -- )
|
||||||
first call help-outliner ;
|
first call help-outliner ;
|
||||||
|
|
|
@ -1,47 +1,43 @@
|
||||||
IN: help
|
IN: help
|
||||||
USING: definitions io prettyprint ;
|
USING: definitions io prettyprint ;
|
||||||
|
|
||||||
HELP: $title "( topic -- )"
|
HELP: $title
|
||||||
{ $values { "topic" "a help article name or a word" } }
|
{ $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" } "." } ;
|
{ $description "Prints a help article's title, or a word's " { $link synopsis } ", depending on the type of " { $snippet "topic" } "." } ;
|
||||||
|
|
||||||
HELP: print-content "( element -- )"
|
HELP: (help)
|
||||||
{ $values { "element" "a markup element" } }
|
|
||||||
{ $description "Prints a top-level markup element to the " { $link stdio } " stream." } ;
|
|
||||||
|
|
||||||
HELP: (help) "( topic -- )"
|
|
||||||
{ $values { "topic" "an article name or a word" } }
|
{ $values { "topic" "an article name or a word" } }
|
||||||
{ $description
|
{ $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."
|
"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 } ;
|
{ $see-also help see-help } ;
|
||||||
|
|
||||||
HELP: help "( topic -- )"
|
HELP: help
|
||||||
{ $values { "topic" "an article name or a word" } }
|
{ $values { "topic" "an article name or a word" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Displays a help article or documentation associated to a word on the " { $link stdio } " stream."
|
"Displays a help article or documentation associated to a word on the " { $link stdio } " stream."
|
||||||
}
|
}
|
||||||
{ $see-also (help) see-help } ;
|
{ $see-also (help) see-help } ;
|
||||||
|
|
||||||
HELP: see-help "( word -- )"
|
HELP: see-help
|
||||||
{ $values { "word" "a word" } }
|
{ $values { "word" "a word" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Display the documentation and definition of a word on the " { $link stdio } " stream."
|
"Display the documentation and definition of a word on the " { $link stdio } " stream."
|
||||||
}
|
}
|
||||||
{ $see-also (help) help see } ;
|
{ $see-also (help) help see } ;
|
||||||
|
|
||||||
HELP: handbook "( -- )"
|
HELP: handbook
|
||||||
{ $description "Displays the Factor developer's handbook." }
|
{ $description "Displays the Factor developer's handbook." }
|
||||||
{ $see-also help } ;
|
{ $see-also help } ;
|
||||||
|
|
||||||
HELP: $subsection "( element -- )"
|
HELP: $subsection
|
||||||
{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
|
{ $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" } "." }
|
{ $description "Prints an expandable outliner containing the body of the help topic named by the first string element of " { $snippet "element" } "." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $markup-example { $subsection "sequences" } }
|
{ $markup-example { $subsection "sequences" } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $subtopic "( element -- )"
|
HELP: $subtopic
|
||||||
{ $values { "element" "a markup element of the form " { $snippet "{ title content }" } } }
|
{ $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." }
|
{ $description "Prints an expandable outliner with the given title containing an arbitrary markup element." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
@ -51,6 +47,10 @@ HELP: $subtopic "( element -- )"
|
||||||
"their own help article." } }
|
"their own help article." } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $outliner "( element -- )"
|
HELP: $outliner
|
||||||
{ $values { "element" "a markup element of the form " { $snippet "( quot -- )" } } }
|
{ $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." } ;
|
{ $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." } ;
|
||||||
|
|
|
@ -37,6 +37,8 @@ SYMBOL: table
|
||||||
span last-element set
|
span last-element set
|
||||||
call ; inline
|
call ; inline
|
||||||
|
|
||||||
|
GENERIC: print-element ( element -- )
|
||||||
|
|
||||||
M: simple-element print-element [ print-element ] each ;
|
M: simple-element print-element [ print-element ] each ;
|
||||||
M: string print-element [ write ] ($span) ;
|
M: string print-element [ write ] ($span) ;
|
||||||
M: array print-element unclip execute ;
|
M: array print-element unclip execute ;
|
||||||
|
@ -75,7 +77,7 @@ M: word print-element { } swap execute ;
|
||||||
: ($heading)
|
: ($heading)
|
||||||
last-element get [ terpri ] when ($block) ; inline
|
last-element get [ terpri ] when ($block) ; inline
|
||||||
|
|
||||||
: $heading
|
: $heading ( element -- )
|
||||||
[ heading-style print-element* ] ($heading) ;
|
[ heading-style print-element* ] ($heading) ;
|
||||||
|
|
||||||
: ($code) ( presentation quot -- )
|
: ($code) ( presentation quot -- )
|
||||||
|
@ -87,34 +89,37 @@ M: word print-element { } swap execute ;
|
||||||
] with-style
|
] with-style
|
||||||
] ($block) ; inline
|
] ($block) ; inline
|
||||||
|
|
||||||
: $code ( content -- )
|
: $code ( element -- )
|
||||||
"\n" join dup <input> [ write ] ($code) ;
|
"\n" join dup <input> [ write ] ($code) ;
|
||||||
|
|
||||||
: $description ( content -- )
|
: $description ( element -- )
|
||||||
"Word description" $heading print-element ;
|
"Word description" $heading print-element ;
|
||||||
|
|
||||||
: $class-description ( content -- )
|
: $class-description ( element -- )
|
||||||
"Class description" $heading print-element ;
|
"Class description" $heading print-element ;
|
||||||
|
|
||||||
: $error-description ( content -- )
|
: $error-description ( element -- )
|
||||||
"Error description" $heading print-element ;
|
"Error description" $heading print-element ;
|
||||||
|
|
||||||
: $contract ( content -- )
|
: $var-description ( element -- )
|
||||||
|
"Variable description" $heading print-element ;
|
||||||
|
|
||||||
|
: $contract ( element -- )
|
||||||
"Generic word contract" $heading print-element ;
|
"Generic word contract" $heading print-element ;
|
||||||
|
|
||||||
: $examples ( content -- )
|
: $examples ( element -- )
|
||||||
"Examples" $heading print-element ;
|
"Examples" $heading print-element ;
|
||||||
|
|
||||||
: $example ( content -- )
|
: $example ( element -- )
|
||||||
1 swap cut* swap "\n" join dup <input> [
|
1 swap cut* swap "\n" join dup <input> [
|
||||||
input-style format terpri print-element
|
input-style format terpri print-element
|
||||||
] ($code) ;
|
] ($code) ;
|
||||||
|
|
||||||
: $markup-example ( content -- )
|
: $markup-example ( element -- )
|
||||||
first dup unparse " print-element" append 1array $code
|
first dup unparse " print-element" append 1array $code
|
||||||
print-element ;
|
print-element ;
|
||||||
|
|
||||||
: $warning ( content -- )
|
: $warning ( element -- )
|
||||||
[
|
[
|
||||||
warning-style [
|
warning-style [
|
||||||
last-element off
|
last-element off
|
||||||
|
@ -129,27 +134,27 @@ M: word >link ;
|
||||||
M: link >link ;
|
M: link >link ;
|
||||||
M: object >link <link> ;
|
M: object >link <link> ;
|
||||||
|
|
||||||
: $link ( article -- )
|
: $link ( element -- )
|
||||||
first link-style [
|
first link-style [
|
||||||
dup article-title swap >link write-object
|
dup article-title swap >link write-object
|
||||||
] with-style ;
|
] with-style ;
|
||||||
|
|
||||||
: $vocab-link ( content -- )
|
: $vocab-link ( element -- )
|
||||||
first link-style [
|
first link-style [
|
||||||
dup <vocab-link> write-object
|
dup <vocab-link> write-object
|
||||||
] with-style ;
|
] with-style ;
|
||||||
|
|
||||||
: $vocabulary ( content -- )
|
: $vocabulary ( element -- )
|
||||||
[ word-vocabulary ] map
|
[ word-vocabulary ] map
|
||||||
[ "Vocabulary" $heading terpri $vocab-link ] when* ;
|
[ "Vocabulary" $heading terpri $vocab-link ] when* ;
|
||||||
|
|
||||||
: textual-list ( seq quot -- )
|
: textual-list ( seq quot -- )
|
||||||
[ ", " print-element ] interleave ; inline
|
[ ", " print-element ] interleave ; inline
|
||||||
|
|
||||||
: $links ( content -- )
|
: $links ( topics -- )
|
||||||
[ [ 1array $link ] textual-list ] ($span) ;
|
[ [ 1array $link ] textual-list ] ($span) ;
|
||||||
|
|
||||||
: $see-also ( content -- )
|
: $see-also ( topics -- )
|
||||||
"See also" $heading $links ;
|
"See also" $heading $links ;
|
||||||
|
|
||||||
: $doc-path ( article -- )
|
: $doc-path ( article -- )
|
||||||
|
@ -170,17 +175,17 @@ M: object >link <link> ;
|
||||||
] with-style
|
] with-style
|
||||||
] ($block) table last-element set ;
|
] ($block) table last-element set ;
|
||||||
|
|
||||||
: $list ( content -- )
|
: $list ( element -- )
|
||||||
[ "-" swap 2array ] map list-style $grid ;
|
[ "-" swap 2array ] map list-style $grid ;
|
||||||
|
|
||||||
: $table ( content -- )
|
: $table ( element -- )
|
||||||
table-style $grid ;
|
table-style $grid ;
|
||||||
|
|
||||||
: $values ( content -- )
|
: $values ( element -- )
|
||||||
"Arguments and values" $heading
|
"Arguments and values" $heading
|
||||||
[ unclip \ $snippet swap 2array swap 2array ] map $table ;
|
[ unclip \ $snippet swap 2array swap 2array ] map $table ;
|
||||||
|
|
||||||
: $predicate ( content -- )
|
: $predicate ( element -- )
|
||||||
{ { "object" "an object" } } $values
|
{ { "object" "an object" } } $values
|
||||||
[
|
[
|
||||||
"Tests if the object is an instance of the " ,
|
"Tests if the object is an instance of the " ,
|
||||||
|
@ -188,14 +193,14 @@ M: object >link <link> ;
|
||||||
" class." ,
|
" class." ,
|
||||||
] { } make $description ;
|
] { } make $description ;
|
||||||
|
|
||||||
: $errors ( content -- )
|
: $errors ( element -- )
|
||||||
"Errors" $heading print-element ;
|
"Errors" $heading print-element ;
|
||||||
|
|
||||||
: $side-effects ( content -- )
|
: $side-effects ( element -- )
|
||||||
"Side effects" $heading "Modifies " print-element
|
"Side effects" $heading "Modifies " print-element
|
||||||
[ $snippet ] textual-list ;
|
[ $snippet ] textual-list ;
|
||||||
|
|
||||||
: $notes ( content -- )
|
: $notes ( element -- )
|
||||||
"Notes" $heading print-element ;
|
"Notes" $heading print-element ;
|
||||||
|
|
||||||
: ($see) ( word -- )
|
: ($see) ( word -- )
|
||||||
|
@ -205,19 +210,19 @@ M: object >link <link> ;
|
||||||
] with-style
|
] with-style
|
||||||
] ($block) ;
|
] ($block) ;
|
||||||
|
|
||||||
: $see ( content -- ) first ($see) ;
|
: $see ( element -- ) first ($see) ;
|
||||||
|
|
||||||
: $definition ( content -- )
|
: $definition ( word -- )
|
||||||
"Definition" $heading ($see) ;
|
"Definition" $heading ($see) ;
|
||||||
|
|
||||||
: $curious ( content -- )
|
: $curious ( element -- )
|
||||||
"For the curious..." $heading print-element ;
|
"For the curious..." $heading print-element ;
|
||||||
|
|
||||||
: $references ( content -- )
|
: $references ( element -- )
|
||||||
"References" $heading
|
"References" $heading
|
||||||
unclip print-element [ \ $link swap 2array ] map $list ;
|
unclip print-element [ \ $link swap 2array ] map $list ;
|
||||||
|
|
||||||
: $shuffle ( content -- )
|
: $shuffle ( element -- )
|
||||||
drop
|
drop
|
||||||
"Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
|
"Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
|
||||||
|
|
||||||
|
|
|
@ -2,25 +2,33 @@ IN: help
|
||||||
USING: arrays definitions inspector io math prettyprint
|
USING: arrays definitions inspector io math prettyprint
|
||||||
sequences ;
|
sequences ;
|
||||||
|
|
||||||
HELP: simple-element f
|
HELP: print-element
|
||||||
{ $description "Class of simple elements, which are just arrays of elements." } ;
|
{ $values { "element" "a markup element" } }
|
||||||
|
{ $description "Prints a markup element to the " { $link stdio } " stream." } ;
|
||||||
|
|
||||||
HELP: ($span) "( content style -- )"
|
HELP: print-content
|
||||||
{ $values { "content" "a markup element" } { "style" "a hashtable" } }
|
{ $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." } ;
|
{ $description "Prints an inline markup element." } ;
|
||||||
|
|
||||||
HELP: ($block) "( quot -- )"
|
HELP: ($block)
|
||||||
{ $values { "quot" "a quotation" } }
|
{ $values { "quot" "a quotation" } }
|
||||||
{ $description "Prints a block markup element with newlines before and after." } ;
|
{ $description "Prints a block markup element with newlines before and after." } ;
|
||||||
|
|
||||||
HELP: $heading "( element -- )"
|
HELP: $heading
|
||||||
{ $values { "element" "a markup element" } }
|
{ $values { "element" "a markup element" } }
|
||||||
{ $description "Prints a markup element, usually a string, as a block with the " { $link heading-style } "." }
|
{ $description "Prints a markup element, usually a string, as a block with the " { $link heading-style } "." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $markup-example { $heading "What remains to be discovered" } }
|
{ $markup-example { $heading "What remains to be discovered" } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $code "( element -- )"
|
HELP: $code
|
||||||
{ $values { "element" "a markup element of the form " { $snippet "{ string... }" } } }
|
{ $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." }
|
{ $description "Prints code examples, as seen in many help articles. The markup element must be an array of strings." }
|
||||||
{ $notes
|
{ $notes
|
||||||
|
@ -32,29 +40,29 @@ HELP: $code "( element -- )"
|
||||||
{ $markup-example { $code "2 2 + ." } }
|
{ $markup-example { $code "2 2 + ." } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $vocabulary "( word -- )"
|
HELP: $vocabulary
|
||||||
{ $values { "word" "a markup element of the form " { $snippet "{ word }" } } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "element" "a markup element" } }
|
||||||
{ $description "Prints the description subheading found on the help page of most words." } ;
|
{ $description "Prints the description subheading found on the help page of most words." } ;
|
||||||
|
|
||||||
HELP: $contract "( element -- )"
|
HELP: $contract
|
||||||
{ $values { "element" "a markup element" } }
|
{ $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." }
|
{ $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
|
{ $examples
|
||||||
{ $markup-example { $contract "Methods of this generic word must always crash." } }
|
{ $markup-example { $contract "Methods of this generic word must always crash." } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $examples "( element -- )"
|
HELP: $examples
|
||||||
{ $values { "element" "a markup element" } }
|
{ $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." }
|
{ $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
|
{ $examples
|
||||||
{ $markup-example { $examples { $example "2 2 + ." "4" } } }
|
{ $markup-example { $examples { $example "2 2 + ." "4" } } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $example "( element -- )"
|
HELP: $example
|
||||||
{ $values { "element" "a markup element of the form " { $snippet "{ inputs... output }" } } }
|
{ $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." }
|
{ $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
|
{ $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."
|
"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" } }
|
{ $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." }
|
{ $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
|
{ $examples
|
||||||
{ $markup-example { $markup-example { $emphasis "Hi" } } }
|
{ $markup-example { $markup-example { $emphasis "Hi" } } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $warning "( element -- )"
|
HELP: $warning
|
||||||
{ $values { "element" "a markup element" } }
|
{ $values { "element" "a markup element" } }
|
||||||
{ $description "Prints an element inset in a block styled as so to draw the reader's attention towards it." }
|
{ $description "Prints an element inset in a block styled as so to draw the reader's attention towards it." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $markup-example { $warning "Incorrect use of this product may cause serious injury or death." } }
|
{ $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 }" } } }
|
{ $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
|
||||||
{ $description "Prints a link to a help article or word." }
|
{ $description "Prints a link to a help article or word." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
@ -87,14 +95,14 @@ HELP: $link "( element -- )"
|
||||||
{ $markup-example { $link + } }
|
{ $markup-example { $link + } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: textual-list "( seq -- str )"
|
HELP: textual-list
|
||||||
{ $values { "seq" "a sequence of strings" } { "str" "a string" } }
|
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
|
||||||
{ $description "Concatenates a sequence of strings together, separated by " { $snippet "\", \"" } "." }
|
{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." }
|
||||||
{ $examples
|
{ $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" } }
|
{ $values { "topics" "a sequence of article names or words" } }
|
||||||
{ $description "Prints a series of links to help articles or word documentation." }
|
{ $description "Prints a series of links to help articles or word documentation." }
|
||||||
{ $notes "This markup element is used to implement " { $link $links } "." }
|
{ $notes "This markup element is used to implement " { $link $links } "." }
|
||||||
|
@ -102,14 +110,14 @@ HELP: $links "( topics -- )"
|
||||||
{ $markup-example { $links + - * / } }
|
{ $markup-example { $links + - * / } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $see-also "( topics -- )"
|
HELP: $see-also
|
||||||
{ $values { "topics" "a sequence of article names or words" } }
|
{ $values { "topics" "a sequence of article names or words" } }
|
||||||
{ $description "Prints a heading followed by a series of links." }
|
{ $description "Prints a heading followed by a series of links." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $markup-example { $see-also "graphs" "queues" } }
|
{ $markup-example { $see-also "graphs" "queues" } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $table "( element -- )"
|
HELP: $table
|
||||||
{ $values { "element" "an array of arrays of markup elements" } }
|
{ $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." }
|
{ $description "Prints a table given as an array of rows, where each row must have the same number of columns." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
@ -121,15 +129,15 @@ HELP: $table "( element -- )"
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $values "( element -- )"
|
HELP: $values
|
||||||
{ $values { "element" "an array of pairs of markup elements" } }
|
{ $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." } ;
|
{ $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 }" } } }
|
{ $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? } "." } ;
|
{ $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" } }
|
{ $values { "element" "an array of markup elements" } }
|
||||||
{ $description "Prints a bulleted list of markup elements." }
|
{ $description "Prints a bulleted list of markup elements." }
|
||||||
{ $notes
|
{ $notes
|
||||||
|
@ -149,14 +157,14 @@ HELP: $list "( element -- )"
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $errors "( element -- )"
|
HELP: $errors
|
||||||
{ $values { "element" "a markup element" } }
|
{ $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." }
|
{ $description "Prints the errors subheading found on the help page of some words. This section should document any errors thrown by the word." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $markup-example { $errors "I/O errors, network errors, hardware errors... oh my!" } }
|
{ $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... }" } } }
|
{ $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." }
|
{ $description "Prints a heading followed by a list of input values or variables which are modified by the word being documented." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
@ -165,38 +173,34 @@ HELP: $side-effects "( element -- )"
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $notes "( element -- )"
|
HELP: $notes
|
||||||
{ $values { "element" "a markup element" } }
|
{ $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." } ;
|
{ $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 }" } } }
|
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
|
||||||
{ $description "Prints the definition of " { $snippet "word" } " by calling " { $link see } "." }
|
{ $description "Prints the definition of " { $snippet "word" } " by calling " { $link see } "." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $markup-example { "Here is a word definition:" { $see reverse } } }
|
{ $markup-example { "Here is a word definition:" { $see reverse } } }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $definition "( word -- )"
|
HELP: $definition
|
||||||
{ $values { "word" "a word" } }
|
{ $values { "word" "a word" } }
|
||||||
{ $description "Prints a heading followed by the definition of " { $snippet "word" } " by calling " { $link see } "." }
|
{ $description "Prints a heading followed by the definition of " { $snippet "word" } " by calling " { $link see } "." }
|
||||||
{ $notes
|
{ $notes
|
||||||
"This markup element is output by " { $link see-help } " but not " { $link help } "."
|
"This markup element is output by " { $link see-help } " but not " { $link help } "."
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: $curious "( element -- )"
|
HELP: $curious
|
||||||
{ $values { "element" "a markup element" } }
|
{ $values { "element" "a markup element" } }
|
||||||
{ $description "Prints a heading followed by 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" } "." } ;
|
{ $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... }" } } }
|
{ $values { "element" "a markup element of the form " { $snippet "{ topic... }" } } }
|
||||||
{ $description "Prints a heading followed by a series of links." }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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." } ;
|
|
||||||
|
|
|
@ -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
|
IN: porter-stemmer
|
||||||
USING: kernel math parser sequences ;
|
USING: kernel math parser sequences ;
|
||||||
|
|
||||||
|
@ -80,27 +68,7 @@ USING: kernel math parser sequences ;
|
||||||
|
|
||||||
: butlast ( seq -- seq ) 1 head-slice* ;
|
: butlast ( seq -- seq ) 1 head-slice* ;
|
||||||
|
|
||||||
! step1a and step1b get rid of plurals and -ed or -ing. e.g.
|
: step1a ( str -- newstr )
|
||||||
!
|
|
||||||
! 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 )
|
|
||||||
dup peek CHAR: s = [
|
dup peek CHAR: s = [
|
||||||
{
|
{
|
||||||
{ [ "sses" ?tail ] [ "ss" append ] }
|
{ [ "sses" ?tail ] [ "ss" append ] }
|
||||||
|
@ -138,7 +106,7 @@ USING: kernel math parser sequences ;
|
||||||
}
|
}
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: step1b ( str -- str )
|
: step1b ( str -- newstr )
|
||||||
{
|
{
|
||||||
{ [ "eed" ?tail ] [ -eed ] }
|
{ [ "eed" ?tail ] [ -eed ] }
|
||||||
{
|
{
|
||||||
|
@ -153,17 +121,12 @@ USING: kernel math parser sequences ;
|
||||||
{ [ t ] [ ] }
|
{ [ t ] [ ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: step1c ( str -- str )
|
: step1c ( str -- newstr )
|
||||||
#! step1c turns terminal y to i when there is another vowel
|
|
||||||
#! in the stem.
|
|
||||||
dup butlast stem-vowel? [
|
dup butlast stem-vowel? [
|
||||||
"y" ?tail [ "i" append ] when
|
"y" ?tail [ "i" append ] when
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: step2 ( str -- str )
|
: step2 ( str -- newstr )
|
||||||
#! 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.
|
|
||||||
{
|
{
|
||||||
{ [ "ational" ?tail ] [ "ational" "ate" r ] }
|
{ [ "ational" ?tail ] [ "ational" "ate" r ] }
|
||||||
{ [ "tional" ?tail ] [ "tional" "tion" r ] }
|
{ [ "tional" ?tail ] [ "tional" "tion" r ] }
|
||||||
|
@ -189,9 +152,7 @@ USING: kernel math parser sequences ;
|
||||||
{ [ t ] [ ] }
|
{ [ t ] [ ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: step3 ( str -- str )
|
: step3 ( str -- newstr )
|
||||||
#! step3 deals with -ic-, -full, -ness etc. similar
|
|
||||||
#! jstrategy to step2.
|
|
||||||
{
|
{
|
||||||
{ [ "icate" ?tail ] [ "icate" "ic" r ] }
|
{ [ "icate" ?tail ] [ "icate" "ic" r ] }
|
||||||
{ [ "ative" ?tail ] [ "ative" "" r ] }
|
{ [ "ative" ?tail ] [ "ative" "" r ] }
|
||||||
|
@ -203,14 +164,14 @@ USING: kernel math parser sequences ;
|
||||||
{ [ t ] [ ] }
|
{ [ t ] [ ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: -ion ( str -- str )
|
: -ion ( str -- newstr )
|
||||||
dup empty? [
|
dup empty? [
|
||||||
drop "ion"
|
drop "ion"
|
||||||
] [
|
] [
|
||||||
dup "st" last-is? [ "ion" append ] unless
|
dup "st" last-is? [ "ion" append ] unless
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: step4 ( str -- str )
|
: step4 ( str -- newstr )
|
||||||
dup {
|
dup {
|
||||||
{ [ "al" ?tail ] [ ] }
|
{ [ "al" ?tail ] [ ] }
|
||||||
{ [ "ance" ?tail ] [ ] }
|
{ [ "ance" ?tail ] [ ] }
|
||||||
|
@ -239,14 +200,12 @@ USING: kernel math parser sequences ;
|
||||||
[ 2drop t ]
|
[ 2drop t ]
|
||||||
[ 1 = [ butlast cvc? not ] [ drop f ] if ] if ;
|
[ 1 = [ butlast cvc? not ] [ drop f ] if ] if ;
|
||||||
|
|
||||||
: remove-e ( str -- str )
|
: remove-e ( str -- newstr )
|
||||||
#! removes a final -e if consonant-seq > 1
|
|
||||||
dup peek CHAR: e = [
|
dup peek CHAR: e = [
|
||||||
dup remove-e? [ butlast ] when
|
dup remove-e? [ butlast ] when
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: ll->l ( str -- str )
|
: ll->l ( str -- newstr )
|
||||||
#! changes -ll to -l if consonant-seq > 1.
|
|
||||||
{
|
{
|
||||||
{ [ dup peek CHAR: l = not ] [ ] }
|
{ [ dup peek CHAR: l = not ] [ ] }
|
||||||
{ [ dup length 1- over double-consonant? not ] [ ] }
|
{ [ dup length 1- over double-consonant? not ] [ ] }
|
||||||
|
@ -254,9 +213,9 @@ USING: kernel math parser sequences ;
|
||||||
{ [ t ] [ ] }
|
{ [ t ] [ ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: step5 ( str -- str ) remove-e ll->l ;
|
: step5 ( str -- newstr ) remove-e ll->l ;
|
||||||
|
|
||||||
: stem ( str -- str )
|
: stem ( str -- newstr )
|
||||||
dup length 2 <= [
|
dup length 2 <= [
|
||||||
step1a step1b step1c step2 step3 step4 step5 "" like
|
step1a step1b step1c step2 step3 step4 step5 "" like
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
|
@ -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." } ;
|
|
@ -7,7 +7,7 @@ namespaces porter-stemmer prettyprint sequences strings words ;
|
||||||
! Right now this code is specific to the help. It will be
|
! Right now this code is specific to the help. It will be
|
||||||
! generalized to an abstract full text search engine later.
|
! 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? ;
|
{ "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 )
|
: 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
|
dup ignored-word? over length 1 = or swap empty? or not
|
||||||
] subset ;
|
] subset ;
|
||||||
|
|
||||||
: index-text ( article string -- )
|
: index-text ( topic string -- )
|
||||||
tokenize [ 1 -rot nest hash+ ] each-with ;
|
tokenize [ 1 -rot nest hash+ ] each-with ;
|
||||||
|
|
||||||
SYMBOL: term-index
|
SYMBOL: term-index
|
||||||
|
|
||||||
: index-article ( article -- )
|
: index-article ( topic -- )
|
||||||
term-index get [
|
term-index get [
|
||||||
[ dup [ help ] string-out index-text ] bind
|
[ dup [ help ] string-out index-text ] bind
|
||||||
] [
|
] [
|
||||||
|
@ -36,7 +36,7 @@ SYMBOL: term-index
|
||||||
drop
|
drop
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
: discard-irrelevant ( results -- results )
|
: discard-irrelevant ( results -- newresults )
|
||||||
#! Discard results in the low 33%
|
#! Discard results in the low 33%
|
||||||
dup 0 [ second max ] reduce
|
dup 0 [ second max ] reduce
|
||||||
swap [ first2 rot / 2array ] map-with
|
swap [ first2 rot / 2array ] map-with
|
||||||
|
|
|
@ -1,43 +1,43 @@
|
||||||
IN: help
|
IN: help
|
||||||
USING: namespaces ;
|
USING: namespaces ;
|
||||||
|
|
||||||
HELP: ignored-word? "( string -- ? )"
|
HELP: ignored-word?
|
||||||
{ $values { "string" "a string" } } { $description "Tests for English stop words." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "topic" "a help article name or a word" } { "string" "a string" } }
|
||||||
{ $description "Tokenizes the string and adds each token to the term index." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "topic" "a help article name or a word" } }
|
||||||
{ $description "Adds the tokens making up the article to the term index." } ;
|
{ $description "Adds the tokens making up the article to the term index." } ;
|
||||||
|
|
||||||
HELP: term-index f
|
HELP: term-index
|
||||||
{ $description "Variable. A hashtable mapping stemmed search terms to hashtables mapping help topics to relevancy scores."
|
{ $var-description "A hashtable mapping stemmed search terms to hashtables mapping help topics to relevancy scores."
|
||||||
$terpri
|
$terpri
|
||||||
"The " { $link search-help } " word searches the term index and the " { $link index-help } " word updates it." }
|
"The " { $link search-help } " word searches the term index and the " { $link index-help } " word updates it." }
|
||||||
{ $see-also help } ;
|
{ $see-also help } ;
|
||||||
|
|
||||||
HELP: discard-irrelevant "( results -- results )"
|
HELP: discard-irrelevant
|
||||||
{ $values }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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. } "." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $description "Performs a full-text search in the term index for help topics relating to " { $snippet "phrase" } ", and prints an outliner with the results." } ;
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
USING: help ;
|
USING: help ;
|
||||||
|
|
||||||
HELP: HELP: "word stack-effect content..."
|
HELP: HELP: "word content..."
|
||||||
{ $values { "word" "a word" } { "stack-effect" "a stack effect or syntax string" } { "content" "markup elements" } }
|
{ $values { "word" "a word" } { "content" "markup elements" } }
|
||||||
{ $description "Defines documentation for a word." }
|
{ $description "Defines documentation for a word." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $code
|
{ $code
|
||||||
": foo 2 + ;"
|
": foo 2 + ;"
|
||||||
"HELP: foo \"( m -- n )\""
|
"HELP: foo
|
||||||
"{ $values { \"m\" \"an integer\" } { \"n\" \"an integer\" } }"
|
"{ $values { \"m\" \"an integer\" } { \"n\" \"an integer\" } }"
|
||||||
"{ $description \"Increments a value by 2.\" } ;"
|
"{ $description \"Increments a value by 2.\" } ;"
|
||||||
"\ foo help"
|
"\ foo help"
|
||||||
|
|
|
@ -4,9 +4,6 @@ IN: help
|
||||||
USING: arrays definitions errors generic graphs hashtables
|
USING: arrays definitions errors generic graphs hashtables
|
||||||
inspector io kernel namespaces prettyprint sequences words ;
|
inspector io kernel namespaces prettyprint sequences words ;
|
||||||
|
|
||||||
! Markup
|
|
||||||
GENERIC: print-element ( element -- )
|
|
||||||
|
|
||||||
! Help articles
|
! Help articles
|
||||||
SYMBOL: articles
|
SYMBOL: articles
|
||||||
|
|
||||||
|
@ -54,23 +51,23 @@ SYMBOL: parent-graph
|
||||||
|
|
||||||
DEFER: $subsection
|
DEFER: $subsection
|
||||||
|
|
||||||
: children ( article -- seq )
|
: children ( topic -- seq )
|
||||||
article-content { $subsection } collect-elements ;
|
article-content { $subsection } collect-elements ;
|
||||||
|
|
||||||
: parents ( article -- seq )
|
: parents ( topic -- seq )
|
||||||
dup link? [ link-name ] when parent-graph get in-edges ;
|
dup link? [ link-name ] when parent-graph get in-edges ;
|
||||||
|
|
||||||
: (doc-path) ( article -- )
|
: (doc-path) ( topic -- )
|
||||||
dup , parents [ word? not ] subset dup empty?
|
dup , parents [ word? not ] subset dup empty?
|
||||||
[ drop ] [ [ (doc-path) ] each ] if ;
|
[ drop ] [ [ (doc-path) ] each ] if ;
|
||||||
|
|
||||||
: doc-path ( article -- seq )
|
: doc-path ( topic -- seq )
|
||||||
[ (doc-path) ] { } make 1 tail prune ;
|
[ (doc-path) ] { } make 1 tail prune ;
|
||||||
|
|
||||||
: xref-article ( article -- )
|
: xref-article ( topic -- )
|
||||||
[ children ] parent-graph get add-vertex ;
|
[ children ] parent-graph get add-vertex ;
|
||||||
|
|
||||||
: unxref-article ( article -- )
|
: unxref-article ( topic -- )
|
||||||
[ children ] parent-graph get remove-vertex ;
|
[ children ] parent-graph get remove-vertex ;
|
||||||
|
|
||||||
: xref-help ( -- )
|
: xref-help ( -- )
|
||||||
|
|
|
@ -1,71 +1,67 @@
|
||||||
IN: help
|
IN: help
|
||||||
USING: io ;
|
USING: io ;
|
||||||
|
|
||||||
HELP: print-element "( element -- )"
|
HELP: articles
|
||||||
{ $values { "element" "a markup element" } }
|
{ $var-description "Hashtable mapping article names to " { $link article } " instances." } ;
|
||||||
{ $description "Prints a markup element to the " { $link stdio } " stream." } ;
|
|
||||||
|
|
||||||
HELP: articles f
|
HELP: no-article
|
||||||
{ $description "Variable. Hashtable mapping article names to " { $link article } " instances." } ;
|
|
||||||
|
|
||||||
HELP: no-article "( name -- )"
|
|
||||||
{ $values { "name" "an article name" } }
|
{ $values { "name" "an article name" } }
|
||||||
{ $description "Throws a " { $link no-article } " error." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "name" "an article name" } { "article" "an " { $link article } " object" } }
|
||||||
{ $description "Outputs a named " { $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" } }
|
{ $values { "topic" "an article name or a word" } { "string" "a string" } }
|
||||||
{ $description "Outputs the title of a specific help article." } ;
|
{ $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" } }
|
{ $values { "topic" "an article name or a word" } { "element" "a markup element" } }
|
||||||
{ $description "Outputs the content of a specific help article." } ;
|
{ $description "Outputs the content of a specific help article." } ;
|
||||||
|
|
||||||
HELP: all-articles "( -- seq )"
|
HELP: all-articles
|
||||||
{ $values { "seq" "a sequence" } }
|
{ $values { "seq" "a sequence" } }
|
||||||
{ $description "Outputs a sequence of all help article names, and all words with documentation." } ;
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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" } "." }
|
{ $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 } "." } ;
|
{ $notes "Used to implement " { $link children } "." } ;
|
||||||
|
|
||||||
HELP: parent-graph f
|
HELP: parent-graph
|
||||||
{ $description "Variable. A graph whose vertices are help articles and edges are subsections. See " { $link "graphs" } "." }
|
{ $var-description "A graph whose vertices are help articles and edges are subsections. See " { $link "graphs" } "." }
|
||||||
{ $see-also children parents xref-help } ;
|
{ $see-also children parents xref-help } ;
|
||||||
|
|
||||||
HELP: children "( topic -- seq )"
|
HELP: children
|
||||||
{ $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
|
{ $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
|
||||||
{ $description "Outputs a sequence of all subsections of " { $snippet "topic" } "." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $description "Outputs a sequence of all help articles which contain " { $snippet "topic" } " as a subsection, traversing all the way up to the root." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $example "\"sequences\" doc-path ." "{ \"collections\" \"handbook\" }" }
|
{ $example "\"sequences\" doc-path ." "{ \"collections\" \"handbook\" }" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: xref-article "( topic -- )"
|
HELP: xref-article
|
||||||
{ $values { "topic" "an article name or a word" } }
|
{ $values { "topic" "an article name or a word" } }
|
||||||
{ $description "Adds an article to the " { $link parent-graph } " graph." }
|
{ $description "Adds an article to the " { $link parent-graph } " graph." }
|
||||||
$low-level-note ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: unxref-article "( topic -- )"
|
HELP: unxref-article
|
||||||
{ $values { "topic" "an article name or a word" } }
|
{ $values { "topic" "an article name or a word" } }
|
||||||
{ $description "Removes an article to the " { $link parent-graph } " graph." }
|
{ $description "Removes an article to the " { $link parent-graph } " graph." }
|
||||||
$low-level-note ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: xref-help "( -- )"
|
HELP: xref-help
|
||||||
{ $description "Update the " { $link parent-graph } ". Usually this is done automatically." } ;
|
{ $description "Update the " { $link parent-graph } ". Usually this is done automatically." } ;
|
||||||
|
|
|
@ -8,5 +8,5 @@ USING: kernel math sequences strings ;
|
||||||
|
|
||||||
: nth-byte ( x n -- b ) -8 * shift HEX: ff bitand ;
|
: nth-byte ( x n -- b ) -8 * shift HEX: ff bitand ;
|
||||||
|
|
||||||
: >le ( x n -- string ) [ nth-byte ] map-with >string ;
|
: >le ( x n -- str ) [ nth-byte ] map-with >string ;
|
||||||
: >be ( x n -- string ) >le reverse ;
|
: >be ( x n -- str ) >le reverse ;
|
||||||
|
|
|
@ -1,21 +1,21 @@
|
||||||
USING: help io ;
|
USING: help io ;
|
||||||
|
|
||||||
HELP: be> "( seq -- x )"
|
HELP: be>
|
||||||
{ $values { "seq" "a sequence of bytes" } { "x" "a non-negative integer" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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))" } "." } ;
|
{ $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" } }
|
{ $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))" } "." } ;
|
{ $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))" } "." } ;
|
||||||
|
|
|
@ -7,7 +7,7 @@ strings ;
|
||||||
|
|
||||||
TUPLE: buffer size ptr fill pos ;
|
TUPLE: buffer size ptr fill pos ;
|
||||||
|
|
||||||
C: buffer ( size -- buffer )
|
C: buffer ( n -- buffer )
|
||||||
2dup set-buffer-size
|
2dup set-buffer-size
|
||||||
[ >r malloc check-ptr alien-address r> set-buffer-ptr ] keep
|
[ >r malloc check-ptr alien-address r> set-buffer-ptr ] keep
|
||||||
0 over set-buffer-fill
|
0 over set-buffer-fill
|
||||||
|
@ -20,10 +20,10 @@ C: buffer ( size -- buffer )
|
||||||
dup buffer-ptr over buffer-pos +
|
dup buffer-ptr over buffer-pos +
|
||||||
over buffer-fill rot buffer-pos - memory>string ;
|
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 ;
|
[ set-buffer-fill ] keep 0 swap set-buffer-pos ;
|
||||||
|
|
||||||
: buffer-consume ( count buffer -- )
|
: buffer-consume ( n buffer -- )
|
||||||
[ buffer-pos + ] keep
|
[ buffer-pos + ] keep
|
||||||
[ buffer-fill min ] keep
|
[ buffer-fill min ] keep
|
||||||
[ set-buffer-pos ] keep
|
[ set-buffer-pos ] keep
|
||||||
|
@ -32,33 +32,33 @@ C: buffer ( size -- buffer )
|
||||||
0 over set-buffer-fill
|
0 over set-buffer-fill
|
||||||
] when drop ;
|
] 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
|
[ dup buffer-fill swap buffer-pos - min ] keep
|
||||||
buffer@ swap memory>string ;
|
buffer@ swap memory>string ;
|
||||||
|
|
||||||
: buffer> ( count buffer -- string )
|
: buffer> ( n buffer -- string )
|
||||||
[ buffer-first-n ] 2keep buffer-consume ;
|
[ buffer-first-n ] 2keep buffer-consume ;
|
||||||
|
|
||||||
: buffer>> ( buffer -- string )
|
: buffer>> ( buffer -- string )
|
||||||
[ buffer-contents ] keep 0 swap buffer-reset ;
|
[ buffer-contents ] keep 0 swap buffer-reset ;
|
||||||
|
|
||||||
: buffer-length ( buffer -- length )
|
: buffer-length ( buffer -- n )
|
||||||
dup buffer-fill swap buffer-pos - ;
|
dup buffer-fill swap buffer-pos - ;
|
||||||
|
|
||||||
: buffer-capacity ( buffer -- int )
|
: buffer-capacity ( buffer -- n )
|
||||||
dup buffer-size swap buffer-fill - ;
|
dup buffer-size swap buffer-fill - ;
|
||||||
|
|
||||||
: buffer-empty? ( buffer -- ? ) buffer-fill zero? ;
|
: buffer-empty? ( buffer -- ? ) buffer-fill zero? ;
|
||||||
|
|
||||||
: extend-buffer ( length buffer -- )
|
: extend-buffer ( n buffer -- )
|
||||||
2dup buffer-ptr <alien> swap realloc check-ptr alien-address
|
2dup buffer-ptr <alien> swap realloc check-ptr alien-address
|
||||||
over set-buffer-ptr set-buffer-size ;
|
over set-buffer-ptr set-buffer-size ;
|
||||||
|
|
||||||
: check-overflow ( length buffer -- )
|
: check-overflow ( n buffer -- )
|
||||||
2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
|
2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
|
||||||
|
|
||||||
: >buffer ( string buffer -- )
|
: >buffer ( string buffer -- )
|
||||||
|
@ -66,7 +66,7 @@ C: buffer ( size -- buffer )
|
||||||
[ buffer-end string>memory ] 2keep
|
[ buffer-end string>memory ] 2keep
|
||||||
[ buffer-fill swap length + ] keep set-buffer-fill ;
|
[ buffer-fill swap length + ] keep set-buffer-fill ;
|
||||||
|
|
||||||
: ch>buffer ( char buffer -- )
|
: ch>buffer ( ch buffer -- )
|
||||||
1 over check-overflow
|
1 over check-overflow
|
||||||
[ buffer-end f swap set-alien-unsigned-1 ] keep
|
[ buffer-end f swap set-alien-unsigned-1 ] keep
|
||||||
[ buffer-fill 1+ ] keep set-buffer-fill ;
|
[ buffer-fill 1+ ] keep set-buffer-fill ;
|
||||||
|
@ -74,13 +74,13 @@ C: buffer ( size -- buffer )
|
||||||
: buffer-bound ( buffer -- n )
|
: buffer-bound ( buffer -- n )
|
||||||
dup buffer-ptr swap buffer-size + ;
|
dup buffer-ptr swap buffer-size + ;
|
||||||
|
|
||||||
: n>buffer ( count buffer -- )
|
: n>buffer ( n buffer -- )
|
||||||
[ buffer-fill + ] keep
|
[ buffer-fill + ] keep
|
||||||
[ buffer-bound > [ "Buffer overflow" throw ] when ] 2keep
|
[ buffer-bound > [ "Buffer overflow" throw ] when ] 2keep
|
||||||
set-buffer-fill ;
|
set-buffer-fill ;
|
||||||
|
|
||||||
: buffer-peek ( buffer -- char )
|
: buffer-peek ( buffer -- ch )
|
||||||
buffer@ f swap alien-unsigned-1 ;
|
buffer@ f swap alien-unsigned-1 ;
|
||||||
|
|
||||||
: buffer-pop ( buffer -- char )
|
: buffer-pop ( buffer -- ch )
|
||||||
[ buffer-peek 1 ] keep buffer-consume ;
|
[ buffer-peek 1 ] keep buffer-consume ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
USING: help io-internals ;
|
USING: help io-internals ;
|
||||||
|
|
||||||
HELP: buffer f
|
HELP: buffer
|
||||||
{ $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."
|
{ $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
|
$terpri
|
||||||
"Buffers have two internal pointers:"
|
"Buffers have two internal pointers:"
|
||||||
{ $list
|
{ $list
|
||||||
|
@ -9,88 +9,92 @@ $terpri
|
||||||
{ "the position -- a read index where data is consumed; accessor: " { $link buffer-pos } }
|
{ "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" } }
|
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
|
||||||
{ $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ;
|
{ $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ;
|
||||||
|
|
||||||
HELP: buffer-free "( buffer -- )"
|
HELP: buffer-free
|
||||||
{ $values { "buffer" "a buffer" } }
|
{ $values { "buffer" "a buffer" } }
|
||||||
{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "buffer" "a buffer" } { "string" "a string" } }
|
||||||
{ $description "Collects the entire contents of the buffer into 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" } }
|
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
|
||||||
{ $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
|
||||||
{ $description "Outputs the memory address of the current buffer position." } ;
|
{ $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" } }
|
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
|
||||||
{ $description "Outputs the memory address of the current fill-pointer." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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> } ;
|
{ $see-also buffer> } ;
|
||||||
|
|
||||||
HELP: buffer> "( n buffer -- string )"
|
HELP: buffer>
|
||||||
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } { "string" "a string" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
|
||||||
{ $description "Outputs the number of unconsumed bytes in the buffer." } ;
|
{ $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" } }
|
{ $values { "buffer" "a buffer" } { "n" "a non-negative integer" } }
|
||||||
{ $description "Outputs the buffer's maximum capacity before growing." } ;
|
{ $description "Outputs the buffer's maximum capacity before growing." } ;
|
||||||
|
|
||||||
HELP: buffer-empty? "( buffer -- ? )"
|
HELP: buffer-empty?
|
||||||
{ $values { "buffer" "a buffer" } { "?" "a boolean" } }
|
{ $values { "buffer" "a buffer" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if the buffer contains no more data to be read." } ;
|
{ $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" } }
|
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
|
||||||
{ $description "Grows a buffer to fit " { $snippet "n" } " bytes of data." } ;
|
{ $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" } }
|
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
|
||||||
{ $description "Grows the buffer, if possible, so it can accomodate " { $snippet "n" } " bytes." }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "string" "a string" } { "buffer" "a buffer" } }
|
||||||
{ $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ;
|
{ $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" } }
|
{ $values { "ch" "a character" } { "buffer" "a buffer" } }
|
||||||
{ $description "Appends a single byte to 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" } }
|
{ $values { "n" "a non-negative integer" } { "buffer" "a buffer" } }
|
||||||
{ $description "Advances the fill pointer by " { $snippet "n" } " bytes." }
|
{ $description "Advances the fill pointer by " { $snippet "n" } " bytes." }
|
||||||
{ $errors "Throws an error if the buffer does not contain " { $snippet "n" } " bytes of data." } ;
|
{ $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" } }
|
{ $values { "buffer" "a buffer" } { "ch" "a character" } }
|
||||||
{ $description "Outputs the byte at the buffer position." }
|
{ $description "Outputs the byte at the buffer position." }
|
||||||
{ $see-also buffer-pop } ;
|
{ $see-also buffer-pop } ;
|
||||||
|
|
||||||
HELP: buffer-pop "( buffer -- ch )"
|
HELP: buffer-pop
|
||||||
{ $values { "buffer" "a buffer" } { "ch" "a character" } }
|
{ $values { "buffer" "a buffer" } { "ch" "a character" } }
|
||||||
{ $description "Outputs the byte at the buffer position and advances the position." } ;
|
{ $description "Outputs the byte at the buffer position and advances the position." } ;
|
||||||
|
|
|
@ -49,6 +49,6 @@ TUPLE: client-stream host port ;
|
||||||
TUPLE: c-stream-error ;
|
TUPLE: c-stream-error ;
|
||||||
: c-stream-error ( -- * ) <c-stream-error> throw ;
|
: c-stream-error ( -- * ) <c-stream-error> throw ;
|
||||||
|
|
||||||
: <client> c-stream-error ;
|
: <client> ( host port -- stream ) c-stream-error ;
|
||||||
: <server> c-stream-error ;
|
: <server> ( port -- server ) c-stream-error ;
|
||||||
: accept c-stream-error ;
|
: accept ( server -- stream ) c-stream-error ;
|
||||||
|
|
|
@ -1,26 +1,26 @@
|
||||||
USING: help io io-internals threads ;
|
USING: help io io-internals threads ;
|
||||||
|
|
||||||
HELP: io-multiplex "( ms -- )"
|
HELP: io-multiplex
|
||||||
{ $values { "ms" "a non-negative integer" } }
|
{ $values { "ms" "a non-negative integer" } }
|
||||||
{ $description "Waits up to " { $snippet "ms" } " milliseconds for pending I/O requests to complete." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "path" "a string" } { "stream" "an input stream" } }
|
||||||
{ $description "Outputs an input stream for reading from the specified path name." }
|
{ $description "Outputs an input stream for reading from the specified path name." }
|
||||||
{ $errors "Throws an error if the file is unreadable." } ;
|
{ $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" } }
|
{ $values { "path" "a string" } { "stream" "an output stream" } }
|
||||||
{ $description "Outputs an input stream for writing to the specified path name." }
|
{ $description "Outputs an input stream for writing to the specified path name." }
|
||||||
{ $errors "Throws an error if the file is unreadable." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "port" "an integer between 0 and 65535" } { "server" "a handle" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Begins listening for connections to " { $snippet "port" } " on all network interfaces. The returned object responds to two generic words:"
|
"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." } ;
|
{ $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" } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
|
@ -39,35 +39,35 @@ $terpri
|
||||||
{ $list { $link client-stream-host } { $link client-stream-port } } }
|
{ $list { $link client-stream-host } { $link client-stream-port } } }
|
||||||
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "string" "a string" } { "alien" "a C FILE* handle" } }
|
||||||
{ $description "Writes a string of text to a C FILE* handle." }
|
{ $description "Writes a string of text to a C FILE* handle." }
|
||||||
{ $errors "Throws an error if the output operation failed." } ;
|
{ $errors "Throws an error if the output operation failed." } ;
|
||||||
|
|
||||||
HELP: fflush "( alien -- )"
|
HELP: fflush ( alien -- )
|
||||||
{ $values { "alien" "a C FILE* handle" } }
|
{ $values { "alien" "a C FILE* handle" } }
|
||||||
{ $description "Forces pending output on a C FILE* handle to complete." }
|
{ $description "Forces pending output on a C FILE* handle to complete." }
|
||||||
{ $errors "Throws an error if the output operation failed." } ;
|
{ $errors "Throws an error if the output operation failed." } ;
|
||||||
|
|
||||||
HELP: fclose "( alien -- )"
|
HELP: fclose ( alien -- )
|
||||||
{ $values { "alien" "a C FILE* handle" } }
|
{ $values { "alien" "a C FILE* handle" } }
|
||||||
{ $description "Closes 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" } }
|
{ $values { "alien" "a C FILE* handle" } { "ch" "a character" } }
|
||||||
{ $description "Reads a single character from a C FILE* handle." }
|
{ $description "Reads a single character from a C FILE* handle." }
|
||||||
{ $errors "Throws an error if the input operation failed." } ;
|
{ $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." } ;
|
{ $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." } ;
|
||||||
|
|
|
@ -13,7 +13,8 @@ C: duplex-stream ( in out -- stream )
|
||||||
[ set-duplex-stream-in ] keep ;
|
[ set-duplex-stream-in ] keep ;
|
||||||
|
|
||||||
TUPLE: check-closed ;
|
TUPLE: check-closed ;
|
||||||
: check-closed ( duplex -- )
|
|
||||||
|
: check-closed ( stream -- )
|
||||||
duplex-stream-closed? [ <check-closed> throw ] when ;
|
duplex-stream-closed? [ <check-closed> throw ] when ;
|
||||||
|
|
||||||
: duplex-stream-in+ ( duplex -- stream )
|
: duplex-stream-in+ ( duplex -- stream )
|
||||||
|
|
|
@ -6,28 +6,28 @@ strings styles ;
|
||||||
|
|
||||||
! Words for accessing filesystem meta-data.
|
! Words for accessing filesystem meta-data.
|
||||||
|
|
||||||
: path+ ( path path -- path )
|
: path+ ( str1 str2 -- str )
|
||||||
over "/" tail? [ append ] [ "/" swap append3 ] if ;
|
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)
|
(directory)
|
||||||
[ { "." ".." } member? not ] subset natural-sort ;
|
[ { "." ".." } 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
|
CHAR: / over last-index CHAR: \\ pick last-index max
|
||||||
dup -1 = [ 2drop "." ] [ head ] if ;
|
dup -1 = [ 2drop "." ] [ head ] if ;
|
||||||
|
|
||||||
: resource-path ( path -- path )
|
: resource-path ( resource -- path )
|
||||||
\ resource-path get [ image parent-dir ] unless*
|
\ resource-path get [ image parent-dir ] unless*
|
||||||
swap path+ ;
|
swap path+ ;
|
||||||
|
|
||||||
: <resource-reader> ( path -- stream )
|
: <resource-reader> ( resource -- stream )
|
||||||
resource-path <file-reader> ;
|
resource-path <file-reader> ;
|
||||||
|
|
||||||
TUPLE: pathname string ;
|
TUPLE: pathname string ;
|
||||||
|
@ -45,5 +45,5 @@ DEFER: directory.
|
||||||
tuck path+
|
tuck path+
|
||||||
dup directory? [ (directory.) ] [ (file.) terpri ] if ;
|
dup directory? [ (directory.) ] [ (file.) terpri ] if ;
|
||||||
|
|
||||||
: directory. ( dir -- )
|
: directory. ( path -- )
|
||||||
dup directory [ file. ] each-with ;
|
dup directory [ file. ] each-with ;
|
||||||
|
|
|
@ -1,16 +1,16 @@
|
||||||
USING: help io ;
|
USING: help io styles ;
|
||||||
|
|
||||||
HELP: cwd "( -- path )"
|
HELP: cwd ( -- path )
|
||||||
{ $values { "path" "a path name string" } }
|
{ $values { "path" "a path name string" } }
|
||||||
{ $description "Outputs the current working directory of the Factor process." }
|
{ $description "Outputs the current working directory of the Factor process." }
|
||||||
{ $see-also cd } ;
|
{ $see-also cd } ;
|
||||||
|
|
||||||
HELP: cd "( path -- )"
|
HELP: cd ( path -- )
|
||||||
{ $values { "path" "a path name string" } }
|
{ $values { "path" "a path name string" } }
|
||||||
{ $description "Changes the current working directory of the Factor process." }
|
{ $description "Changes the current working directory of the Factor process." }
|
||||||
{ $see-also cwd } ;
|
{ $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 } } }
|
{ $values { "path" "a path name string" } { "array/f" "a four-element array or " { $link f } } }
|
||||||
{ $description
|
{ $description
|
||||||
"If the file does not exist, outputs " { $link f } ". Otherwise, outputs a four-element array:"
|
"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" } }
|
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
||||||
{ $description "Concatenates two path names." } ;
|
{ $description "Concatenates two path names." } ;
|
||||||
|
|
||||||
HELP: exists? "( path -- ? )"
|
HELP: exists?
|
||||||
{ $values { "path" "a string" } { "?" "a boolean" } }
|
{ $values { "path" "a string" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
|
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
|
||||||
|
|
||||||
|
@ -34,22 +34,30 @@ HELP: directory? "( path -- ? )"
|
||||||
{ $values { "path" "a string" } { "?" "a boolean" } }
|
{ $values { "path" "a string" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $snippet "path" } " names a directory." } ;
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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 } } }
|
{ $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." } ;
|
{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
|
||||||
|
|
||||||
HELP: resource-path "( resource -- path )"
|
HELP: parent-dir
|
||||||
{ $values { "resource" "a string" } { "path" "a string" } }
|
{ $values { "path" "a string" } { "parent" "a string" } }
|
||||||
{ $description "Resolve a path relative to the Factor source code location." } ;
|
{ $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" } }
|
{ $values { "resource" "a string" } { "stream" "an input stream" } }
|
||||||
{ $description "Opens a file relative to the Factor source code location." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $description "Prints a directory listing to the " { $link stdio } " stream. If the stream supports it, subdirectories are shown as expandable outliners." } ;
|
||||||
|
|
|
@ -6,7 +6,7 @@ vectors ;
|
||||||
|
|
||||||
TUPLE: line-reader cr ;
|
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 ;
|
: cr> dup line-reader-cr f rot set-line-reader-cr ;
|
||||||
|
|
||||||
|
@ -41,6 +41,6 @@ M: line-reader stream-read
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: (lines) ( seq -- seq ) readln [ , (lines) ] when* ;
|
: (lines) ( -- ) readln [ , (lines) ] when* ;
|
||||||
|
|
||||||
: lines ( stream -- seq ) [ [ (lines) ] { } make ] with-stream ;
|
: lines ( stream -- seq ) [ [ (lines) ] { } make ] with-stream ;
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
USING: help io ;
|
USING: help io ;
|
||||||
|
|
||||||
HELP: <line-reader> "( stream -- new-stream )"
|
HELP: <line-reader>
|
||||||
{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ;
|
||||||
|
|
|
@ -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 } "." } ;
|
|
@ -1,6 +1,7 @@
|
||||||
USING: help io ;
|
USING: help io ;
|
||||||
|
|
||||||
HELP: <plain-writer> "( stream -- new-stream )"
|
HELP: <plain-writer>
|
||||||
{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } }
|
{ $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." }
|
{ $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" } ;
|
||||||
|
|
|
@ -6,12 +6,12 @@ threads ;
|
||||||
|
|
||||||
SYMBOL: log-stream
|
SYMBOL: log-stream
|
||||||
|
|
||||||
: log-message ( msg -- )
|
: log-message ( str -- )
|
||||||
log-stream get [ stream-print ] keep stream-flush ;
|
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 " %
|
"Accepted connection from " %
|
||||||
dup client-stream-host %
|
dup client-stream-host %
|
||||||
|
@ -19,7 +19,7 @@ SYMBOL: log-stream
|
||||||
client-stream-port #
|
client-stream-port #
|
||||||
] "" make log-message ;
|
] "" make log-message ;
|
||||||
|
|
||||||
: with-log-file ( file quot -- )
|
: with-log-file ( path quot -- )
|
||||||
[ swap <file-writer> log-stream set call ] with-scope ;
|
[ swap <file-writer> log-stream set call ] with-scope ;
|
||||||
|
|
||||||
: with-logging ( quot -- )
|
: with-logging ( quot -- )
|
||||||
|
|
|
@ -1,40 +1,40 @@
|
||||||
USING: help io ;
|
USING: help io ;
|
||||||
|
|
||||||
HELP: log-stream f
|
HELP: log-stream
|
||||||
{ $description "Variable. Holds an output stream for logging messages." }
|
{ $var-description "Holds an output stream for logging messages." }
|
||||||
{ $see-also log-error log-client with-log-file with-logging } ;
|
{ $see-also log-error log-client with-log-file with-logging } ;
|
||||||
|
|
||||||
HELP: log-message "( str -- )"
|
HELP: log-message
|
||||||
{ $values { "str" "a string" } }
|
{ $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." }
|
{ $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 } ;
|
{ $see-also log-error log-client } ;
|
||||||
|
|
||||||
HELP: log-error "( str -- )"
|
HELP: log-error
|
||||||
{ $values { "str" "a string" } }
|
{ $values { "str" "a string" } }
|
||||||
{ $description "Logs an error message." }
|
{ $description "Logs an error message." }
|
||||||
{ $see-also log-message log-client } ;
|
{ $see-also log-message log-client } ;
|
||||||
|
|
||||||
HELP: log-client "( client -- )"
|
HELP: log-client
|
||||||
{ $values { "client" "a client socket stream" } }
|
{ $values { "client" "a client socket stream" } }
|
||||||
{ $description "Logs an incoming client connection." }
|
{ $description "Logs an incoming client connection." }
|
||||||
{ $see-also log-message log-error } ;
|
{ $see-also log-message log-error } ;
|
||||||
|
|
||||||
HELP: with-log-file "( path quot -- )"
|
HELP: with-log-file
|
||||||
{ $values { "path" "a string" } { "quot" "a quotation" } }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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
|
HELP: server-stream
|
||||||
{ $description "Variable. Current server socket, set by " { $link with-server } "." } ;
|
{ $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" } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
|
|
|
@ -9,16 +9,16 @@ SYMBOL: stdio
|
||||||
|
|
||||||
: close ( -- ) stdio get stream-close ;
|
: close ( -- ) stdio get stream-close ;
|
||||||
|
|
||||||
: readln ( -- string/f ) stdio get stream-readln ;
|
: readln ( -- str/f ) stdio get stream-readln ;
|
||||||
: read1 ( -- char/f ) stdio get stream-read1 ;
|
: read1 ( -- ch/f ) stdio get stream-read1 ;
|
||||||
: read ( count -- string ) stdio get stream-read ;
|
: read ( n -- str/f ) stdio get stream-read ;
|
||||||
|
|
||||||
: write1 ( char -- ) stdio get stream-write1 ;
|
: write1 ( ch -- ) stdio get stream-write1 ;
|
||||||
: write ( string -- ) stdio get stream-write ;
|
: write ( str -- ) stdio get stream-write ;
|
||||||
: flush ( -- ) stdio get stream-flush ;
|
: flush ( -- ) stdio get stream-flush ;
|
||||||
|
|
||||||
: terpri ( -- ) stdio get stream-terpri ;
|
: terpri ( -- ) stdio get stream-terpri ;
|
||||||
: format ( string style -- ) stdio get stream-format ;
|
: format ( str style -- ) stdio get stream-format ;
|
||||||
|
|
||||||
: with-nesting ( style quot -- )
|
: with-nesting ( style quot -- )
|
||||||
swap stdio get with-nested-stream ;
|
swap stdio get with-nested-stream ;
|
||||||
|
@ -40,8 +40,8 @@ SYMBOL: stdio
|
||||||
|
|
||||||
: bl ( -- ) " " write ;
|
: bl ( -- ) " " write ;
|
||||||
|
|
||||||
: write-object ( string object -- )
|
: write-object ( str obj -- )
|
||||||
presented associate format ;
|
presented associate format ;
|
||||||
|
|
||||||
: write-outliner ( string object content -- )
|
: write-outliner ( str obj content -- )
|
||||||
outline associate [ write-object ] with-nesting ;
|
outline associate [ write-object ] with-nesting ;
|
||||||
|
|
|
@ -1,88 +1,95 @@
|
||||||
USING: help io ;
|
USING: help io ;
|
||||||
|
|
||||||
HELP: stdio f
|
HELP: stdio
|
||||||
{ $description "Variable. Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
|
{ $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." }
|
{ $contract "Closes the " { $link stdio } " stream." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: readln "( -- str/f )"
|
HELP: readln
|
||||||
{ $values { "str/f" "a string or " { $link f } } }
|
{ $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." }
|
{ $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: read1 "( -- ch/f )"
|
HELP: read1
|
||||||
{ $values { "ch/f" "a character or " { $link f } } }
|
{ $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." }
|
{ $contract "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: read "( n -- str/f )"
|
HELP: read
|
||||||
{ $values { "str/f" "a string or " { $link f } } }
|
{ $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." }
|
{ $contract "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: write1 "( ch -- )"
|
HELP: write1
|
||||||
{ $values { "ch" "a character" } }
|
{ $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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: write1 "( ch -- )"
|
HELP: write
|
||||||
{ $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 -- )"
|
|
||||||
{ $values { "str" "a string" } }
|
{ $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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: flush "( -- )"
|
HELP: flush
|
||||||
{ $contract "Waits for any pending output to the " { $link stdio } " stream to complete." }
|
{ $contract "Waits for any pending output to the " { $link stdio } " stream to complete." }
|
||||||
$io-error ;
|
$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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: format "( str style -- )"
|
HELP: format
|
||||||
{ $values { "str" "a string" } { "style" "a hashtable" } }
|
{ $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." }
|
{ $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 } "." }
|
{ $notes "Details are in the documentation for " { $link stream-format } "." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: with-nesting "( style quot -- )"
|
HELP: with-nesting
|
||||||
{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
|
{ $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." }
|
{ $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 } "." }
|
{ $notes "Details are in the documentation for " { $link stream-format } "." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: print "( style -- )"
|
HELP: tabular-output
|
||||||
{ $values { "style" "a hashtable" } }
|
{ $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." }
|
{ $description "Writes a newline-terminated string to the " { $link stdio } " stream." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: with-stream "( stream quot -- )"
|
HELP: with-stream
|
||||||
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
|
{ $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." }
|
{ $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* } ;
|
{ $see-also with-stream* } ;
|
||||||
|
|
||||||
HELP: with-stream* "( stream quot -- )"
|
HELP: with-stream*
|
||||||
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
|
{ $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" } "." }
|
{ $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." }
|
{ $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 } ;
|
{ $see-also with-stream } ;
|
||||||
|
|
||||||
HELP: bl "( -- )"
|
HELP: bl
|
||||||
{ $description "Outputs a space character (" { $snippet "\" \"" } ")." }
|
{ $description "Outputs a space character (" { $snippet "\" \"" } ")." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: write-object "( str obj -- )"
|
HELP: write-object
|
||||||
{ $values { "str" "a string" } { "obj" "an 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 } "." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: write-outliner "( str obj content -- )"
|
HELP: write-outliner
|
||||||
{ $values { "str" "a string" } { "obj" "an object" } { "content" "a quotation" } }
|
{ $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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
|
@ -5,15 +5,15 @@ USING: errors hashtables generic kernel math namespaces
|
||||||
sequences strings ;
|
sequences strings ;
|
||||||
|
|
||||||
GENERIC: stream-close ( stream -- )
|
GENERIC: stream-close ( stream -- )
|
||||||
GENERIC: set-timeout ( timeout stream -- )
|
GENERIC: set-timeout ( n stream -- )
|
||||||
GENERIC: stream-readln ( stream -- string )
|
GENERIC: stream-readln ( stream -- str )
|
||||||
GENERIC: stream-read1 ( stream -- char/f )
|
GENERIC: stream-read1 ( stream -- ch/f )
|
||||||
GENERIC: stream-read ( count stream -- string )
|
GENERIC: stream-read ( n stream -- str/f )
|
||||||
GENERIC: stream-write1 ( char stream -- )
|
GENERIC: stream-write1 ( ch stream -- )
|
||||||
GENERIC: stream-write ( string stream -- )
|
GENERIC: stream-write ( str stream -- )
|
||||||
GENERIC: stream-flush ( stream -- )
|
GENERIC: stream-flush ( stream -- )
|
||||||
GENERIC: stream-terpri ( 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-nested-stream ( quot style stream -- )
|
||||||
GENERIC: with-stream-table ( grid quot style stream -- )
|
GENERIC: with-stream-table ( grid quot style stream -- )
|
||||||
GENERIC: with-stream-style ( quot style stream -- )
|
GENERIC: with-stream-style ( quot style stream -- )
|
||||||
|
|
|
@ -1,53 +1,53 @@
|
||||||
USING: help io ;
|
USING: help io ;
|
||||||
|
|
||||||
HELP: stream-close "( stream -- )"
|
HELP: stream-close
|
||||||
{ $values { "stream" "a stream" } }
|
{ $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." }
|
{ $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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: set-timeout "( n stream -- )"
|
HELP: set-timeout
|
||||||
{ $values { "n" "an integer" } { "stream" "a stream" } }
|
{ $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." }
|
{ $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-readln "( stream -- str )"
|
HELP: stream-readln
|
||||||
{ $values { "stream" "an input stream" } { "str" "a string" } }
|
{ $values { "stream" "an input stream" } { "str" "a string" } }
|
||||||
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-read1 "( stream -- ch/f )"
|
HELP: stream-read1
|
||||||
{ $values { "stream" "an input stream" } }
|
{ $values { "stream" "an input stream" } }
|
||||||
{ $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
{ $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-read "( n stream -- str )"
|
HELP: stream-read
|
||||||
{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str" "a string" } }
|
{ $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." }
|
{ $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-write1 "( ch stream -- )"
|
HELP: stream-write1
|
||||||
{ $values { "ch" "a character" } { "stream" "an output stream" } }
|
{ $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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-write "( str stream -- )"
|
HELP: stream-write
|
||||||
{ $values { "str" "a string" } { "stream" "an output stream" } }
|
{ $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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-flush "( stream -- )"
|
HELP: stream-flush
|
||||||
{ $values { "stream" "an output stream" } }
|
{ $values { "stream" "an output stream" } }
|
||||||
{ $contract "Waits for any pending output to complete." }
|
{ $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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-terpri "( stream -- )"
|
HELP: stream-terpri
|
||||||
{ $values { "stream" "an output stream" } }
|
{ $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." }
|
{ $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 ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-format "( str style stream -- )"
|
HELP: stream-format
|
||||||
{ $values { "str" "a string" } { "style" "a hashtable" } { "stream" "an output stream" } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
|
@ -58,15 +58,32 @@ HELP: with-nested-stream "( quot style stream -- )"
|
||||||
{ $values { "quot" "a quotation" } { "style" "a hashtable" } { "stream" "an output 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."
|
{ $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
|
$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" } "." }
|
"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
|
||||||
$io-error ;
|
$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" } }
|
{ $values { "str" "a string" } { "stream" "an output stream" } }
|
||||||
{ $description "Writes a newline-terminated string." }
|
{ $description "Writes a newline-terminated string." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
||||||
HELP: stream-copy "( in out -- )"
|
HELP: stream-copy
|
||||||
{ $values { "in" "an input stream" } { "out" "an output stream" } }
|
{ $values { "in" "an input stream" } { "out" "an output stream" } }
|
||||||
{ $description "Copies the contents of one stream into another, closing both streams when done." }
|
{ $description "Copies the contents of one stream into another, closing both streams when done." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
|
@ -3,7 +3,6 @@
|
||||||
IN: io
|
IN: io
|
||||||
USING: io kernel math namespaces sequences strings ;
|
USING: io kernel math namespaces sequences strings ;
|
||||||
|
|
||||||
! String buffers support the stream output protocol.
|
|
||||||
M: sbuf stream-write1 push ;
|
M: sbuf stream-write1 push ;
|
||||||
M: sbuf stream-write swap nappend ;
|
M: sbuf stream-write swap nappend ;
|
||||||
M: sbuf stream-close drop ;
|
M: sbuf stream-close drop ;
|
||||||
|
@ -35,7 +34,6 @@ M: plain-writer with-stream-table
|
||||||
[ print ] each
|
[ print ] each
|
||||||
] with-stream* ;
|
] with-stream* ;
|
||||||
|
|
||||||
! Reversed string buffers support the stream input protocol.
|
|
||||||
M: sbuf stream-read1
|
M: sbuf stream-read1
|
||||||
dup empty? [ drop f ] [ pop ] if ;
|
dup empty? [ drop f ] [ pop ] if ;
|
||||||
|
|
||||||
|
@ -47,12 +45,11 @@ M: sbuf stream-read
|
||||||
[ [ drop pop ] inject-with ] keep
|
[ [ drop pop ] inject-with ] keep
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: <string-reader> ( string -- stream )
|
: <string-reader> ( str -- stream )
|
||||||
<reversed> >sbuf <line-reader> ;
|
<reversed> >sbuf <line-reader> ;
|
||||||
|
|
||||||
: string-in ( str quot -- )
|
: string-in ( str quot -- )
|
||||||
>r <string-reader> r> with-stream ; inline
|
>r <string-reader> r> with-stream ; inline
|
||||||
|
|
||||||
: contents ( stream -- string )
|
: contents ( stream -- str )
|
||||||
#! Read the entire stream into a string.
|
|
||||||
<string-writer> [ stream-copy ] keep >string ;
|
<string-writer> [ stream-copy ] keep >string ;
|
||||||
|
|
|
@ -1,23 +1,23 @@
|
||||||
USING: help io strings ;
|
USING: help io strings ;
|
||||||
|
|
||||||
HELP: <string-writer> "( -- stream )"
|
HELP: <string-writer>
|
||||||
{ $values { "stream" "an output stream" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "str" "a string" } { "stream" "an input stream" } }
|
||||||
{ $description "Creates a new stream for reading " { $snippet "str" } " from beginning to end." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "stream" "an input stream" } { "str" "a string" } }
|
||||||
{ $description "Reads the contents of a stream into a string." }
|
{ $description "Reads the contents of a stream into a string." }
|
||||||
$io-error ;
|
$io-error ;
|
||||||
|
|
|
@ -1,18 +1,18 @@
|
||||||
USING: help styles io ;
|
USING: help styles io ;
|
||||||
|
|
||||||
HELP: plain f
|
HELP: plain
|
||||||
{ $description "A value for the " { $link font-style } " character style denoting plain text." } ;
|
{ $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." } ;
|
{ $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." } ;
|
{ $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." } ;
|
{ $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)." }
|
{ $description "Character style. Text color, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $code
|
{ $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)." }
|
{ $description "Character style. Background color, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $code
|
{ $code
|
||||||
|
@ -34,59 +34,71 @@ HELP: background f
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: font f
|
HELP: font
|
||||||
{ $description "Character style. Font family named by a string." }
|
{ $description "Character style. Font family named by a string." }
|
||||||
{ $examples
|
{ $examples
|
||||||
"This example outputs some different font sizes:"
|
"This example outputs some different font sizes:"
|
||||||
{ $code "{ \"Monospaced\" \"Serif\" \"Sans Serif\" }\n[ dup font associate format terpri ] each" }
|
{ $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." }
|
{ $description "Character style. Font size, an integer." }
|
||||||
{ $examples
|
{ $examples
|
||||||
"This example outputs some different font sizes:"
|
"This example outputs some different font sizes:"
|
||||||
{ $code "\"Bigger\" { 12 18 24 72 }\n[ font-size associate format terpri ] each-with" }
|
{ $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 } "." }
|
{ $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." }
|
||||||
{ $examples
|
{ $examples
|
||||||
"This example outputs text in all three styles:"
|
"This example outputs text in all three styles:"
|
||||||
{ $code "{ plain bold italic bold-italic }\n[ [ word-name ] keep font-style associate format terpri ] each" }
|
{ $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." }
|
{ $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 } ;
|
{ $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)." }
|
{ $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
|
{ $examples
|
||||||
{ $code "H{ { page-color { 1 0.8 0.5 1 } } }\n[ \"A background\" write ] with-nesting terpri" }
|
{ $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)." }
|
{ $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
|
{ $examples
|
||||||
{ $code "H{ { border-color { 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting terpri" }
|
{ $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." }
|
{ $description "Paragraph style. Pixels between edge of text and border color, an integer." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $code "H{ { border-width 10 } }\n[ \"Some inset text\" write ] with-nesting terpri" }
|
{ $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." }
|
{ $description "Paragraph style. Pixels between left margin and right margin where text is wrapped, an integer." }
|
||||||
{ $see-also bl } ;
|
{ $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." }
|
{ $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 } ;
|
{ $see-also write-outliner } ;
|
||||||
|
|
||||||
HELP: input f
|
HELP: table-gap
|
||||||
{ $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." }
|
{ $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
|
{ $examples
|
||||||
"This presentation class is used for the code examples you see in the online help:"
|
"This presentation class is used for the code examples you see in the online help:"
|
||||||
{ $code "\"2 3 + .\" dup <input> write-object terpri" }
|
{ $code "\"2 3 + .\" dup <input> write-object terpri" }
|
||||||
|
|
|
@ -146,7 +146,7 @@ GENERIC: task-container ( task -- vector )
|
||||||
read-fdset/tasks init-fdset
|
read-fdset/tasks init-fdset
|
||||||
write-fdset/tasks init-fdset f ;
|
write-fdset/tasks init-fdset f ;
|
||||||
|
|
||||||
: io-multiplex ( timeout -- )
|
: io-multiplex ( ms -- )
|
||||||
>r FD_SETSIZE init-fdsets r> make-timeval select io-error
|
>r FD_SETSIZE init-fdsets r> make-timeval select io-error
|
||||||
read-fdset/tasks handle-fdset
|
read-fdset/tasks handle-fdset
|
||||||
write-fdset/tasks handle-fdset ;
|
write-fdset/tasks handle-fdset ;
|
||||||
|
|
|
@ -10,7 +10,7 @@ USING: compiler namespaces kernel win32-io-internals win32-stream win32-api
|
||||||
|
|
||||||
IN: io-internals
|
IN: io-internals
|
||||||
|
|
||||||
: io-multiplex ( timeout -- )
|
: io-multiplex ( ms -- )
|
||||||
#! FIXME: needs to work given a timeout
|
#! FIXME: needs to work given a timeout
|
||||||
dup -1 = [ drop INFINITE ] when cancel-timedout wait-for-io
|
dup -1 = [ drop INFINITE ] when cancel-timedout wait-for-io
|
||||||
swap [ schedule-thread-with ] [ drop ] if* ;
|
swap [ schedule-thread-with ] [ drop ] if* ;
|
||||||
|
|
|
@ -3,16 +3,32 @@
|
||||||
IN: math
|
IN: math
|
||||||
USING: kernel math math-internals ;
|
USING: kernel math math-internals ;
|
||||||
|
|
||||||
: acosh dup sq 1- sqrt + log ; inline
|
: acosh ( x -- y ) dup sq 1- sqrt + log ; inline
|
||||||
: asech recip acosh ; inline
|
|
||||||
: asinh dup sq 1+ sqrt + log ; inline
|
: asech ( x -- y ) recip acosh ; inline
|
||||||
: acosech recip asinh ; inline
|
|
||||||
: atanh dup 1+ swap 1- neg / log 2 / ; inline
|
: asinh ( x -- y ) dup sq 1+ sqrt + log ; inline
|
||||||
: acoth recip atanh ; inline
|
|
||||||
: [-1,1]? ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] if ; inline
|
: acosech ( x -- y ) recip asinh ; inline
|
||||||
: asin dup [-1,1]? [ fasin ] [ i * asinh -i * ] if ; inline
|
|
||||||
: acos dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline
|
: atanh ( x -- y ) dup 1+ swap 1- neg / log 2 / ; inline
|
||||||
: atan dup [-1,1]? [ fatan ] [ i * atanh i * ] if ; inline
|
|
||||||
: asec recip acos ; inline
|
: acoth ( x -- y ) recip atanh ; inline
|
||||||
: acosec recip asin ; inline
|
|
||||||
: acot recip atan ; 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
|
||||||
|
|
|
@ -1,57 +1,57 @@
|
||||||
USING: help math ;
|
USING: help math ;
|
||||||
|
|
||||||
HELP: acosh "( x -- y )"
|
HELP: acosh
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse hyperbolic cosine." } ;
|
{ $description "Inverse hyperbolic cosine." } ;
|
||||||
|
|
||||||
HELP: asech "( x -- y )"
|
HELP: asech
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse hyperbolic secant." } ;
|
{ $description "Inverse hyperbolic secant." } ;
|
||||||
|
|
||||||
HELP: asinh "( x -- y )"
|
HELP: asinh
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse hyperbolic sine." } ;
|
{ $description "Inverse hyperbolic sine." } ;
|
||||||
|
|
||||||
HELP: asinh "( x -- y )"
|
HELP: asinh
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse hyperbolic sine." } ;
|
{ $description "Inverse hyperbolic sine." } ;
|
||||||
|
|
||||||
HELP: acosech "( x -- y )"
|
HELP: acosech
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse hyperbolic cosecant." } ;
|
{ $description "Inverse hyperbolic cosecant." } ;
|
||||||
|
|
||||||
HELP: atanh "( x -- y )"
|
HELP: atanh
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse hyperbolic tangent." } ;
|
{ $description "Inverse hyperbolic tangent." } ;
|
||||||
|
|
||||||
HELP: acoth "( x -- y )"
|
HELP: acoth
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse hyperbolic cotangent." } ;
|
{ $description "Inverse hyperbolic cotangent." } ;
|
||||||
|
|
||||||
HELP: acos "( x -- y )"
|
HELP: acos
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse trigonometric cosine." } ;
|
{ $description "Inverse trigonometric cosine." } ;
|
||||||
|
|
||||||
HELP: asec "( x -- y )"
|
HELP: asec
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse trigonometric secant." } ;
|
{ $description "Inverse trigonometric secant." } ;
|
||||||
|
|
||||||
HELP: asin "( x -- y )"
|
HELP: asin
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse trigonometric sine." } ;
|
{ $description "Inverse trigonometric sine." } ;
|
||||||
|
|
||||||
HELP: asin "( x -- y )"
|
HELP: asin
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse trigonometric sine." } ;
|
{ $description "Inverse trigonometric sine." } ;
|
||||||
|
|
||||||
HELP: acosec "( x -- y )"
|
HELP: acosec
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse trigonometric cosecant." } ;
|
{ $description "Inverse trigonometric cosecant." } ;
|
||||||
|
|
||||||
HELP: atan "( x -- y )"
|
HELP: atan
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse trigonometric tangent." } ;
|
{ $description "Inverse trigonometric tangent." } ;
|
||||||
|
|
||||||
HELP: acot "( x -- y )"
|
HELP: acot
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Inverse trigonometric cotangent." } ;
|
{ $description "Inverse trigonometric cotangent." } ;
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
IN: math-internals
|
IN: math-internals
|
||||||
USING: errors generic kernel kernel-internals math ;
|
USING: errors generic kernel kernel-internals math ;
|
||||||
|
|
||||||
: (rect>) ( xr xi -- x )
|
: (rect>) ( x y -- z )
|
||||||
dup zero? [ drop ] [ <complex> ] if ; inline
|
dup zero? [ drop ] [ <complex> ] if ; inline
|
||||||
|
|
||||||
IN: math
|
IN: math
|
||||||
|
@ -15,14 +15,14 @@ M: real imaginary drop 0 ;
|
||||||
|
|
||||||
M: number equal? number= ;
|
M: number equal? number= ;
|
||||||
|
|
||||||
: rect> ( xr xi -- x )
|
: rect> ( x y -- z )
|
||||||
over real? over real? and [
|
over real? over real? and [
|
||||||
(rect>)
|
(rect>)
|
||||||
] [
|
] [
|
||||||
"Complex number must have real components" throw
|
"Complex number must have real components" throw
|
||||||
] if ; inline
|
] 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
|
: conjugate ( z -- z* ) >rect neg rect> ; inline
|
||||||
|
|
||||||
|
@ -31,7 +31,7 @@ M: number equal? number= ;
|
||||||
: >polar ( z -- abs arg )
|
: >polar ( z -- abs arg )
|
||||||
dup abs swap >rect swap fatan2 ; inline
|
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
|
: polar> ( abs arg -- z ) cis * ; inline
|
||||||
|
|
||||||
|
|
|
@ -1,59 +1,59 @@
|
||||||
USING: help math math-internals ;
|
USING: help math math-internals ;
|
||||||
|
|
||||||
HELP: complex f
|
HELP: complex
|
||||||
{ $description "The class of complex numbers with non-zero imaginary part." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "z" "a complex number" } { "y" "a real number" } }
|
||||||
{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } }
|
||||||
{ $description "Creates a complex number from real and imaginary components." }
|
{ $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." } ;
|
{ $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
|
HELP: number
|
||||||
{ $description "The class of numbers." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } }
|
||||||
{ $description "Creates a complex number from real and imaginary components." } ;
|
{ $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" } }
|
{ $values { "z" "a complex number" } { "x" "a real number" } { "y" "a real number" } }
|
||||||
{ $description "Extracts the real and imaginary components of a complex 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" } }
|
{ $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" } "." } ;
|
{ $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]" } } }
|
{ $values { "z" "a complex number" } { "arg" "a number in the interval " { $snippet "(-pi,pi]" } } }
|
||||||
{ $description "Computes the complex argument." } ;
|
{ $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]" } } }
|
{ $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)." } ;
|
{ $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" } }
|
{ $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)" } "." }
|
{ $description "Computes a point on the unit circle using Euler's formula for " { $snippet "exp(arg*i)" } "." }
|
||||||
{ $see-also exp } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } } }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a complex number" } { "y" "a complex number" } { "r" "a real number" } { "i" "a real number" } { "m" "a real number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Complex division kernel. If we use the notation from " { $link 2>rect } ", this word computes:"
|
"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" } }
|
{ $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." } ;
|
{ $description "Low-level complex number constructor. User code should call " { $link rect> } " instead." } ;
|
||||||
|
|
|
@ -4,10 +4,10 @@ IN: kernel-internals
|
||||||
USING: kernel namespaces math ;
|
USING: kernel namespaces math ;
|
||||||
|
|
||||||
: bootstrap-cell \ cell get ; inline
|
: bootstrap-cell \ cell get ; inline
|
||||||
: cells cell * ; inline
|
: cells ( m -- n ) cell * ; inline
|
||||||
: bootstrap-cells bootstrap-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
|
: bootstrap-cell-bits 8 bootstrap-cells ; inline
|
||||||
|
|
||||||
: tag-address ( x tag -- tagged ) swap tag-bits shift bitor ;
|
: tag-address ( x tag -- tagged ) swap tag-bits shift bitor ;
|
||||||
|
@ -15,11 +15,14 @@ USING: kernel namespaces math ;
|
||||||
|
|
||||||
IN: math
|
IN: math
|
||||||
|
|
||||||
: i C{ 0 1 } ; inline
|
: i ( -- i ) C{ 0 1 } ; inline
|
||||||
: -i C{ 0 -1 } ; inline
|
: -i ( -- -i ) C{ 0 -1 } ; inline
|
||||||
: e 2.7182818284590452354 ; inline
|
: e ( -- e ) 2.7182818284590452354 ; inline
|
||||||
: pi 3.14159265358979323846 ; inline
|
: pi ( -- pi ) 3.14159265358979323846 ; inline
|
||||||
: epsilon 2.2204460492503131e-16 ; inline
|
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
|
||||||
: first-bignum 1 bootstrap-cell-bits tag-bits - 1- shift ;
|
|
||||||
: most-positive-fixnum first-bignum 1- ;
|
: first-bignum ( -- n )
|
||||||
: most-negative-fixnum first-bignum neg ;
|
1 bootstrap-cell-bits tag-bits - 1- shift ;
|
||||||
|
|
||||||
|
: most-positive-fixnum ( -- n ) first-bignum 1- ;
|
||||||
|
: most-negative-fixnum ( -- n ) first-bignum neg ;
|
||||||
|
|
|
@ -1,33 +1,33 @@
|
||||||
USING: help kernel-internals math ;
|
USING: help kernel-internals math ;
|
||||||
|
|
||||||
HELP: cells "( m -- n )"
|
HELP: cells
|
||||||
{ $values { "m" "an integer" } { "n" "an integer" } }
|
{ $values { "m" "an integer" } { "n" "an integer" } }
|
||||||
{ $description "Computes the number of bytes corresponding to " { $snippet "m" } " CPU operand-sized cells." } ;
|
{ $description "Computes the number of bytes corresponding to " { $snippet "m" } " CPU operand-sized cells." } ;
|
||||||
|
|
||||||
HELP: cell-bits "( m -- n )"
|
HELP: cell-bits
|
||||||
{ $values { "m" "an integer" } { "n" "an integer" } }
|
{ $values { "n" "an integer" } }
|
||||||
{ $description "Computes the number of bits corresponding to " { $snippet "m" } " CPU operand-sized cells." } ;
|
{ $description "Outputs the number of bits in one CPU operand-sized cell." } ;
|
||||||
|
|
||||||
HELP: i "( -- i )"
|
HELP: i
|
||||||
{ $values { "i" "the imaginary unit" } } ;
|
{ $values { "i" "the imaginary unit" } } ;
|
||||||
|
|
||||||
HELP: -i "( -- -i )"
|
HELP: -i
|
||||||
{ $values { "i" "the negated imaginary unit" } } ;
|
{ $values { "-i" "the negated imaginary unit" } } ;
|
||||||
|
|
||||||
HELP: e "( -- e )"
|
HELP: e
|
||||||
{ $values { "e" "base of natural logarithm" } } ;
|
{ $values { "e" "base of natural logarithm" } } ;
|
||||||
|
|
||||||
HELP: pi "( -- pi )"
|
HELP: pi
|
||||||
{ $values { "pi" "circumference of circle with diameter 1" } } ;
|
{ $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" } } ;
|
{ $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" } } ;
|
{ $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" } } ;
|
{ $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" } } ;
|
{ $values { "n" "smallest negative integer representable by a fixnum" } } ;
|
||||||
|
|
|
@ -1,74 +1,74 @@
|
||||||
USING: help math math-internals ;
|
USING: help math math-internals ;
|
||||||
|
|
||||||
HELP: float f
|
HELP: float
|
||||||
{ $description "The class of double-precision floating point numbers." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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 } ;
|
{ $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" } }
|
{ $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." }
|
{ $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 } ;
|
{ $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" } }
|
{ $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." }
|
{ $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 } ;
|
{ $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" } }
|
{ $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." }
|
{ $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 } ;
|
{ $see-also bits>double bits>float double>bits } ;
|
||||||
|
|
||||||
! Unsafe primitives
|
! Unsafe primitives
|
||||||
HELP: float+ "( x y -- z )"
|
HELP: float+ ( x y -- z )
|
||||||
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
|
||||||
{ $description "Primitive version of " { $link + } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
|
||||||
{ $description "Primitive version of " { $link - } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
|
||||||
{ $description "Primitive version of " { $link * } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
|
||||||
{ $description "Primitive version of " { $link mod } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "z" "a float" } }
|
||||||
{ $description "Primitive version of " { $link /f } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link < } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link <= } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link > } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a float" } { "y" "a float" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link >= } "." }
|
{ $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." } ;
|
{ $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." } ;
|
||||||
|
|
|
@ -26,13 +26,13 @@ UNION: integer fixnum bignum ;
|
||||||
>r 1 shift r> (next-power-of-2)
|
>r 1 shift r> (next-power-of-2)
|
||||||
] if ;
|
] 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
|
dup HEX: ffffffff bitand
|
||||||
swap -32 shift 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
|
dup HEX: ffff bitand
|
||||||
swap -16 shift HEX: ffff bitand ;
|
swap -16 shift HEX: ffff bitand ;
|
||||||
|
|
||||||
|
|
|
@ -1,219 +1,228 @@
|
||||||
USING: errors help math math-internals ;
|
USING: errors help math math-internals ;
|
||||||
|
|
||||||
HELP: fixnum f
|
HELP: fixnum
|
||||||
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "n" "a fixnum" } }
|
||||||
{ $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ;
|
{ $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ;
|
||||||
|
|
||||||
HELP: bignum f
|
HELP: bignum
|
||||||
{ $description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "n" "a bignum" } }
|
||||||
{ $description "Converts a real number to a bignum, with a possible loss of precision." } ;
|
{ $description "Converts a real number to a bignum, with a possible loss of precision." } ;
|
||||||
|
|
||||||
HELP: integer f
|
HELP: integer
|
||||||
{ $description "The class of integers, which is a disjoint union of fixnums and bignums." } ;
|
{ $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" } }
|
{ $values { "n" "an integer" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if an integer is even." } ;
|
{ $description "Tests if an integer is even." } ;
|
||||||
|
|
||||||
HELP: odd? "( n -- ? )"
|
HELP: odd?
|
||||||
{ $values { "n" "an integer" } { "?" "a boolean" } }
|
{ $values { "n" "an integer" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if an integer is odd." } ;
|
{ $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" } }
|
{ $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" } }
|
{ $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" } "." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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
|
! Unsafe primitives
|
||||||
HELP: fixnum+ "( x y -- z )"
|
HELP: fixnum+ ( x y -- z )
|
||||||
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
|
||||||
{ $description "Primitive version of " { $link + } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
|
||||||
{ $description "Primitive version of " { $link - } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
|
||||||
{ $description "Primitive version of " { $link * } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a float" } }
|
||||||
{ $description "Primitive version of " { $link /f } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
|
||||||
{ $description "Primitive version of " { $link /i } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
|
||||||
{ $description "Primitive version of " { $link mod } ". The result always fits in 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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link < } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "an integer" } }
|
||||||
{ $description "Primitive version of " { $link <= } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link > } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link >= } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
|
||||||
{ $description "Primitive version of " { $link bitand } ". The result always fits in 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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
|
||||||
{ $description "Primitive version of " { $link bitor } ". The result always fits in 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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
|
||||||
{ $description "Primitive version of " { $link bitxor } ". The result always fits in 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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } }
|
||||||
{ $description "Primitive version of " { $link bitnot } ". The result always fits in 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." } ;
|
{ $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" } }
|
{ $values { "x" "a fixnum" } { "y" "a fixnum" } { "z" "a fixnum" } }
|
||||||
{ $description "Primitive version of " { $link shift } ". The result may overflow to a bignum." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link + } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link - } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link * } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a float" } }
|
||||||
{ $description "Primitive version of " { $link /f } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link /i } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } { "w" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link mod } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link /mod } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link < } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link <= } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link > } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link >= } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "?" "a boolean" } }
|
||||||
{ $description "Primitive version of " { $link number= } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link bitand } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link bitor } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link bitxor } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link bitnot } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a bignum" } { "y" "a bignum" } { "z" "a bignum" } }
|
||||||
{ $description "Primitive version of " { $link shift } "." }
|
{ $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." } ;
|
{ $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." }
|
{ $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. } ")." } ;
|
{ $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. } ")." } ;
|
||||||
|
|
|
@ -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 -- ? ) math-combination ; foldable
|
G: >= ( x y -- ? ) math-combination ; foldable
|
||||||
|
|
||||||
G: + ( x y -- x+y ) math-combination ; foldable
|
G: + ( x y -- z ) math-combination ; foldable
|
||||||
G: - ( x y -- x-y ) math-combination ; foldable
|
G: - ( x y -- z ) math-combination ; foldable
|
||||||
G: * ( x y -- x*y ) math-combination ; foldable
|
G: * ( x y -- z ) math-combination ; foldable
|
||||||
G: / ( x y -- x/y ) math-combination ; foldable
|
G: / ( x y -- z ) math-combination ; foldable
|
||||||
G: /i ( x y -- x/y ) math-combination ; foldable
|
G: /i ( x y -- z ) math-combination ; foldable
|
||||||
G: /f ( x y -- x/y ) math-combination ; foldable
|
G: /f ( x y -- z ) math-combination ; foldable
|
||||||
G: mod ( x y -- x%y ) 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: bitand ( x y -- z ) math-combination ; foldable
|
||||||
G: bitor ( x y -- z ) math-combination ; foldable
|
G: bitor ( x y -- z ) math-combination ; foldable
|
||||||
G: bitxor ( x y -- z ) math-combination ; foldable
|
G: bitxor ( x y -- z ) math-combination ; foldable
|
||||||
G: shift ( x n -- y ) 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: abs ( x -- y ) foldable
|
||||||
GENERIC: absq ( n -- |n|^2 ) foldable
|
GENERIC: absq ( x -- y ) foldable
|
||||||
|
|
||||||
GENERIC: zero? ( x -- ? ) foldable
|
GENERIC: zero? ( x -- ? ) foldable
|
||||||
M: object zero? drop f ;
|
M: object zero? drop f ;
|
||||||
|
|
||||||
: 1+ 1 + ; foldable
|
: 1+ ( x -- y ) 1 + ; foldable
|
||||||
: 1- 1 - ; foldable
|
: 1- ( x -- y ) 1 - ; foldable
|
||||||
: sq dup * ; foldable
|
: sq ( x -- y ) dup * ; foldable
|
||||||
: neg 0 swap - ; foldable
|
: neg ( x -- -x ) 0 swap - ; foldable
|
||||||
: recip 1 swap / ; foldable
|
: recip ( x -- y ) 1 swap / ; foldable
|
||||||
: max ( x y -- z ) [ > ] 2keep ? ; foldable
|
: max ( x y -- z ) [ > ] 2keep ? ; foldable
|
||||||
: min ( 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
|
: 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
|
: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
|
||||||
: truncate ( x -- y ) dup 1 mod - ; foldable
|
: truncate ( x -- y ) dup 1 mod - ; foldable
|
||||||
|
|
||||||
|
|
|
@ -1,27 +1,27 @@
|
||||||
USING: help kernel math ;
|
USING: help kernel math ;
|
||||||
|
|
||||||
HELP: number= "( x y -- ? )"
|
HELP: number=
|
||||||
{ $values { "x" "a number" } { "y" "a number" } { "?" "a boolean" } }
|
{ $values { "x" "a number" } { "y" "a number" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if two numbers have the same numerical value." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
|
{ $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" } }
|
{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Adds two numbers."
|
"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" } }
|
{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Subtracts " { $snippet "y" } " from " { $snippet "x" } "."
|
"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" } }
|
{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Multiplies two numbers."
|
"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" } }
|
{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Divides " { $snippet "x" } " by " { $snippet "y" } ", retaining as much precision as possible."
|
"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." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Divides " { $snippet "x" } " by " { $snippet "y" } ", truncating the result to an integer."
|
"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." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Divides " { $snippet "x" } " by " { $snippet "y" } ", representing the result as a floating point number."
|
"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." } ;
|
{ $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" } }
|
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative."
|
"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." }
|
{ $errors "Throws an error if the denominator is 0." }
|
||||||
{ $see-also rem } ;
|
{ $see-also rem } ;
|
||||||
|
|
||||||
HELP: /mod "( x y -- z w )"
|
HELP: /mod
|
||||||
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } { "w" "an integer" } }
|
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } { "w" "an integer" } }
|
||||||
{ $description
|
{ $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."
|
"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." } ;
|
{ $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" } }
|
{ $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." }
|
{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in both inputs." }
|
||||||
{ $examples
|
{ $examples
|
||||||
|
@ -127,7 +127,7 @@ HELP: bitand "( x y -- z )"
|
||||||
{ $example "BIN: 110 BIN: 10 bitand .b" "10" }
|
{ $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" } }
|
{ $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." }
|
{ $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
|
{ $examples
|
||||||
|
@ -135,7 +135,7 @@ HELP: bitor "( x y -- z )"
|
||||||
{ $example "BIN: 110 BIN: 10 bitor .b" "110" }
|
{ $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" } }
|
{ $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." }
|
{ $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
|
{ $examples
|
||||||
|
@ -143,80 +143,80 @@ HELP: bitxor "( x y -- z )"
|
||||||
{ $example "BIN: 110 BIN: 10 bitxor .b" "100" }
|
{ $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" } }
|
{ $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." }
|
{ $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" } } ;
|
{ $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" } }
|
{ $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." }
|
{ $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-" } } ;
|
{ $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" } }
|
{ $values { "x" "a number" } { "y" "a number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Increments a number by 1. The following two lines are equivalent, but the first is more efficient:"
|
"Increments a number by 1. The following two lines are equivalent, but the first is more efficient:"
|
||||||
{ $code "1+" "1 +" }
|
{ $code "1+" "1 +" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: 1- "( x -- y )"
|
HELP: 1-
|
||||||
{ $values { "x" "a number" } { "y" "a number" } }
|
{ $values { "x" "a number" } { "y" "a number" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Decrements a number by 1. The following two lines are equivalent, but the first is more efficient:"
|
"Decrements a number by 1. The following two lines are equivalent, but the first is more efficient:"
|
||||||
{ $code "1-" "1 -" }
|
{ $code "1-" "1 -" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: truncate "( x -- y )"
|
HELP: truncate
|
||||||
{ $values { "x" "a real number" } { "y" "a whole real number" } }
|
{ $values { "x" "a real number" } { "y" "a whole real number" } }
|
||||||
{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." }
|
{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." }
|
||||||
{ $notes "The result is not necessarily an integer." } ;
|
{ $notes "The result is not necessarily an integer." } ;
|
||||||
|
|
||||||
HELP: floor "( x -- y )"
|
HELP: floor
|
||||||
{ $values { "x" "a real number" } { "y" "a whole real number" } }
|
{ $values { "x" "a real number" } { "y" "a whole real number" } }
|
||||||
{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." }
|
{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." }
|
||||||
{ $notes "The result is not necessarily an integer." } ;
|
{ $notes "The result is not necessarily an integer." } ;
|
||||||
|
|
||||||
HELP: ceiling "( x -- y )"
|
HELP: ceiling
|
||||||
{ $values { "x" "a real number" } { "y" "a whole real number" } }
|
{ $values { "x" "a real number" } { "y" "a whole real number" } }
|
||||||
{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." }
|
{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." }
|
||||||
{ $notes "The result is not necessarily an integer." } ;
|
{ $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" } }
|
{ $values { "x" "a complex number" } { "y" "a non-negative real number" } }
|
||||||
{ $description "Computes the absolute value of a complex 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" } }
|
{ $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 } "." } ;
|
{ $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" } }
|
{ $values { "x" "a number" } { "y" "a number" } }
|
||||||
{ $description "Multiplies a number by itself." } ;
|
{ $description "Multiplies a number by itself." } ;
|
||||||
|
|
||||||
HELP: neg "( x -- -x )"
|
HELP: neg
|
||||||
{ $values { "x" "a number" } { "-x" "a number" } }
|
{ $values { "x" "a number" } { "-x" "a number" } }
|
||||||
{ $description "Computes a number's additive inverse." } ;
|
{ $description "Computes a number's additive inverse." } ;
|
||||||
|
|
||||||
HELP: recip "( x -- -x )"
|
HELP: recip
|
||||||
{ $values { "x" "a number" } { "-x" "a number" } }
|
{ $values { "x" "a number" } { "y" "a number" } }
|
||||||
{ $description "Computes a number's multiplicative inverse." }
|
{ $description "Computes a number's multiplicative inverse." }
|
||||||
{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } }
|
||||||
{ $description "Outputs the greatest of two real numbers." } ;
|
{ $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" } }
|
{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } }
|
||||||
{ $description "Outputs the smallest of two real numbers." } ;
|
{ $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" } }
|
{ $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]" } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive."
|
"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." }
|
{ $errors "Throws an error if the denominator is 0." }
|
||||||
{ $see-also mod } ;
|
{ $see-also mod } ;
|
||||||
|
|
||||||
HELP: sgn "( x -- n )"
|
HELP: sgn
|
||||||
{ $values { "x" "a real number" } { "n" "-1, 0 or 1" } }
|
{ $values { "x" "a real number" } { "n" "-1, 0 or 1" } }
|
||||||
{ $description
|
{ $description
|
||||||
"Outputs one of the following:"
|
"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" } } }
|
{ $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" } "." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "n" "a real number" } { "str" "a string" } }
|
||||||
{ $description "Converts a real number to a string." }
|
{ $description "Converts a real number to a string." }
|
||||||
{ $notes "Printing complex numbers requires the more general prettyprinter facility (see " { $link "prettyprint" } ")." } ;
|
{ $notes "Printing complex numbers requires the more general prettyprinter facility (see " { $link "prettyprint" } ")." } ;
|
||||||
|
|
|
@ -30,17 +30,17 @@ M: object digit> drop f ;
|
||||||
: string>integer ( string radix -- n )
|
: string>integer ( string radix -- n )
|
||||||
swap "-" ?head >r (string>integer) dup r> and [ neg ] when ;
|
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? ] [ string>ratio ] }
|
||||||
{ [ CHAR: . pick member? ] [ drop string>float ] }
|
{ [ CHAR: . pick member? ] [ drop string>float ] }
|
||||||
{ [ t ] [ string>integer ] }
|
{ [ t ] [ string>integer ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: string>number ( string -- num ) 10 base> ;
|
: string>number ( str -- n ) 10 base> ;
|
||||||
: bin> ( string -- num ) 2 base> ;
|
: bin> ( str -- n ) 2 base> ;
|
||||||
: oct> ( string -- num ) 8 base> ;
|
: oct> ( str -- n ) 8 base> ;
|
||||||
: hex> ( string -- num ) 16 base> ;
|
: hex> ( str -- n ) 16 base> ;
|
||||||
|
|
||||||
: >digit ( n -- ch )
|
: >digit ( n -- ch )
|
||||||
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
|
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
|
||||||
|
@ -49,7 +49,7 @@ M: object digit> drop f ;
|
||||||
dup >r /mod >digit , dup 0 >
|
dup >r /mod >digit , dup 0 >
|
||||||
[ r> integer, ] [ r> 2drop ] if ;
|
[ r> integer, ] [ r> 2drop ] if ;
|
||||||
|
|
||||||
G: >base ( num radix -- string ) 1 standard-combination ;
|
G: >base ( n radix -- str ) 1 standard-combination ;
|
||||||
|
|
||||||
M: integer >base
|
M: integer >base
|
||||||
[
|
[
|
||||||
|
@ -78,7 +78,7 @@ M: float >base
|
||||||
{ [ t ] [ float>string fix-float ] }
|
{ [ t ] [ float>string fix-float ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: number>string ( num -- string ) 10 >base ;
|
: number>string ( n -- str ) 10 >base ;
|
||||||
: >bin ( num -- string ) 2 >base ;
|
: >bin ( num -- string ) 2 >base ;
|
||||||
: >oct ( num -- string ) 8 >base ;
|
: >oct ( num -- string ) 8 >base ;
|
||||||
: >hex ( num -- string ) 16 >base ;
|
: >hex ( num -- string ) 16 >base ;
|
||||||
|
|
|
@ -1,70 +1,70 @@
|
||||||
USING: help math math-internals prettyprint ;
|
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 } } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
"Outputs " { $link f } " if the string does not represent a number." }
|
"Outputs " { $link f } " if the string does not represent a number." }
|
||||||
{ $see-also >base } ;
|
{ $see-also >base } ;
|
||||||
|
|
||||||
HELP: string>number "( str -- n )"
|
HELP: string>number
|
||||||
{ $values { "str" "a string" } { "n/f" "a real number or " { $link f } } }
|
{ $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."
|
{ $description "Creates a real number from a string representation of a number in base 10."
|
||||||
$terpri
|
$terpri
|
||||||
"Outputs " { $link f } " if the string does not represent a number." }
|
"Outputs " { $link f } " if the string does not represent a number." }
|
||||||
{ $see-also number>string } ;
|
{ $see-also number>string } ;
|
||||||
|
|
||||||
HELP: bin> "( str -- n )"
|
HELP: bin>
|
||||||
{ $values { "str" "a string" } { "n/f" "a real number or " { $link f } } }
|
{ $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."
|
{ $description "Creates a real number from a string representation of a number in base 2."
|
||||||
$terpri
|
$terpri
|
||||||
"Outputs " { $link f } " if the string does not represent a number." }
|
"Outputs " { $link f } " if the string does not represent a number." }
|
||||||
{ $see-also POSTPONE: BIN: } ;
|
{ $see-also POSTPONE: BIN: } ;
|
||||||
|
|
||||||
HELP: oct> "( str -- n )"
|
HELP: oct>
|
||||||
{ $values { "str" "a string" } { "n/f" "a real number or " { $link f } } }
|
{ $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."
|
{ $description "Creates a real number from a string representation of a number in base 8."
|
||||||
$terpri
|
$terpri
|
||||||
"Outputs " { $link f } " if the string does not represent a number." }
|
"Outputs " { $link f } " if the string does not represent a number." }
|
||||||
{ $see-also POSTPONE: OCT: } ;
|
{ $see-also POSTPONE: OCT: } ;
|
||||||
|
|
||||||
HELP: hex> "( str -- n )"
|
HELP: hex>
|
||||||
{ $values { "str" "a string" } { "n" "a real number" } }
|
{ $values { "str" "a string" } { "n" "a real number" } }
|
||||||
{ $description "Creates a real number from a string representation of a number in base 16."
|
{ $description "Creates a real number from a string representation of a number in base 16."
|
||||||
$terpri
|
$terpri
|
||||||
"Outputs " { $link f } " if the string does not represent a number." }
|
"Outputs " { $link f } " if the string does not represent a number." }
|
||||||
{ $see-also POSTPONE: HEX: } ;
|
{ $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" } }
|
{ $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." }
|
{ $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> } ;
|
{ $see-also base> } ;
|
||||||
|
|
||||||
HELP: number>string "( n -- str )"
|
HELP: number>string
|
||||||
{ $values { "n" "a real number" } { "str" "a string" } }
|
{ $values { "n" "a real number" } { "str" "a string" } }
|
||||||
{ $description "Outputs a string representation of a number using base 10." } ;
|
{ $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" } }
|
{ $values { "n" "a real number" } { "str" "a string" } }
|
||||||
{ $description "Outputs a string representation of a number using base 2." }
|
{ $description "Outputs a string representation of a number using base 2." }
|
||||||
{ $see-also .b } ;
|
{ $see-also .b } ;
|
||||||
|
|
||||||
HELP: >oct "( n -- str )"
|
HELP: >oct
|
||||||
{ $values { "n" "a real number" } { "str" "a string" } }
|
{ $values { "n" "a real number" } { "str" "a string" } }
|
||||||
{ $description "Outputs a string representation of a number using base 8." }
|
{ $description "Outputs a string representation of a number using base 8." }
|
||||||
{ $see-also .o } ;
|
{ $see-also .o } ;
|
||||||
|
|
||||||
HELP: >hex "( n -- str )"
|
HELP: >hex
|
||||||
{ $values { "n" "a real number" } { "str" "a string" } }
|
{ $values { "n" "a real number" } { "str" "a string" } }
|
||||||
{ $description "Outputs a string representation of a number using base 16." }
|
{ $description "Outputs a string representation of a number using base 16." }
|
||||||
{ $see-also .h } ;
|
{ $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 } } }
|
{ $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."
|
{ $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
|
$terpri
|
||||||
"Outputs " { $link f } " if the string does not represent a float." } ;
|
"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" } }
|
{ $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." } ;
|
{ $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." } ;
|
||||||
|
|
|
@ -3,17 +3,17 @@
|
||||||
IN: math
|
IN: math
|
||||||
USING: errors kernel math math-internals ;
|
USING: errors kernel math math-internals ;
|
||||||
|
|
||||||
: exp >rect swap fexp swap polar> ; inline
|
: exp ( x -- y ) >rect swap fexp swap polar> ; inline
|
||||||
: log >polar swap flog swap rect> ; 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: complex sqrt >polar swap fsqrt swap 2 / polar> ;
|
||||||
M: real sqrt dup 0 < [ neg fsqrt 0 swap rect> ] [ fsqrt ] if ;
|
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? [
|
over zero? [
|
||||||
dup zero?
|
dup zero?
|
||||||
[ 2drop 0.0/0.0 ] [ 0 < [ drop 1.0/0.0 ] when ] if
|
[ 2drop 0.0/0.0 ] [ 0 < [ drop 1.0/0.0 ] when ] if
|
||||||
|
|
|
@ -1,27 +1,27 @@
|
||||||
USING: help math ;
|
USING: help math ;
|
||||||
|
|
||||||
HELP: exp "( x -- y )"
|
HELP: exp
|
||||||
{ $values { "x" "a complex number" } { "y" "a complex number" } }
|
{ $values { "x" "a complex number" } { "y" "a complex number" } }
|
||||||
{ $description "Computes the exponential function." } ;
|
{ $description "Computes the exponential function." } ;
|
||||||
|
|
||||||
HELP: log "( x -- y )"
|
HELP: log
|
||||||
{ $values { "x" "a complex number" } { "y" "a complex number" } }
|
{ $values { "x" "a complex number" } { "y" "a complex number" } }
|
||||||
{ $description "Computes the natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
|
{ $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" } }
|
{ $values { "x" "a complex number" } { "y" "a complex number" } }
|
||||||
{ $description "Computes the square root function." } ;
|
{ $description "Computes the square root function." } ;
|
||||||
|
|
||||||
HELP: ^ "( x y -- z )"
|
HELP: ^
|
||||||
{ $values { "x" "a complex number" } { "y" "a complex number" } { "z" "a complex number" } }
|
{ $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." }
|
{ $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." } ;
|
{ $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" } }
|
{ $values { "n" "an integer" } { "?" "a boolean" } }
|
||||||
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
|
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
|
||||||
|
|
||||||
HELP: log2 "( n -- b )"
|
HELP: log2
|
||||||
{ $values { "n" "a positive integer" } { "b" "an integer" } }
|
{ $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" } "." }
|
{ $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." } ;
|
{ $errors "Throws an error if " { $snippet "n" } " is zero or negative." } ;
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
USING: help math ;
|
USING: help math ;
|
||||||
|
|
||||||
HELP: (random-int) "( -- rand )"
|
HELP: (random-int)
|
||||||
{ $values { "rand" "an integer between 0 and 2^32-1" } }
|
{ $values { "rand" "an integer between 0 and 2^32-1" } }
|
||||||
{ $description "Generates a random 32-bit unsigned integer." } ;
|
{ $description "Generates a random 32-bit unsigned integer." } ;
|
||||||
|
|
||||||
HELP: random-int "( n -- rand )"
|
HELP: random-int
|
||||||
{ $values { "rand" "an integer between 0 and n" } }
|
{ $values { "rand" "an integer between 0 and n" } }
|
||||||
{ $description "Outputs a pseudo-random integer in the interval " { $snippet "[0,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." } ;
|
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
|
||||||
|
|
|
@ -1,27 +1,27 @@
|
||||||
USING: help math math-internals ;
|
USING: help math math-internals ;
|
||||||
|
|
||||||
HELP: ratio f
|
HELP: ratio
|
||||||
{ $description "The class of rational numbers with denominator not equal to 1." } ;
|
{ $class-description "The class of rational numbers with denominator not equal to 1." } ;
|
||||||
|
|
||||||
HELP: rational f
|
HELP: rational
|
||||||
{ $description "The class of rational numbers, a disjoint union of integers and ratios." } ;
|
{ $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" } }
|
{ $values { "a/b" "a rational number" } { "a" "an integer" } }
|
||||||
{ $description "Outputs the numerator of a rational number. Acts as the identity on integers." } ;
|
{ $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" } }
|
{ $values { "a/b" "a rational number" } { "b" "a positive integer" } }
|
||||||
{ $description "Outputs the denominator of a rational number. Always outputs 1 with integers." } ;
|
{ $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" } }
|
{ $values { "a/b" "a rational number" } { "a" "an integer" } { "b" "a positive integer" } }
|
||||||
{ $description "Extracts the numerator and denominator of a rational number." } ;
|
{ $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" } }
|
{ $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." } ;
|
{ $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" } }
|
{ $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." } ;
|
||||||
|
|
|
@ -3,35 +3,35 @@
|
||||||
IN: math
|
IN: math
|
||||||
USING: kernel math math-internals ;
|
USING: kernel math math-internals ;
|
||||||
|
|
||||||
: cos ( z -- cos )
|
: cos ( x -- y )
|
||||||
>rect 2dup
|
>rect 2dup
|
||||||
fcosh swap fcos * -rot
|
fcosh swap fcos * -rot
|
||||||
fsinh swap fsin neg * rect> ; inline
|
fsinh swap fsin neg * rect> ; inline
|
||||||
|
|
||||||
: sec cos recip ; inline
|
: sec ( x -- y ) cos recip ; inline
|
||||||
|
|
||||||
: cosh ( z -- cosh )
|
: cosh ( x -- y )
|
||||||
>rect 2dup
|
>rect 2dup
|
||||||
fcos swap fcosh * -rot
|
fcos swap fcosh * -rot
|
||||||
fsin swap fsinh * rect> ; inline
|
fsin swap fsinh * rect> ; inline
|
||||||
|
|
||||||
: sech cosh recip ; inline
|
: sech ( x -- y ) cosh recip ; inline
|
||||||
|
|
||||||
: sin ( z -- sin )
|
: sin ( x -- y )
|
||||||
>rect 2dup
|
>rect 2dup
|
||||||
fcosh swap fsin * -rot
|
fcosh swap fsin * -rot
|
||||||
fsinh swap fcos * rect> ; inline
|
fsinh swap fcos * rect> ; inline
|
||||||
|
|
||||||
: cosec sin recip ; inline
|
: cosec ( x -- y ) sin recip ; inline
|
||||||
|
|
||||||
: sinh ( z -- sinh )
|
: sinh ( x -- y )
|
||||||
>rect 2dup
|
>rect 2dup
|
||||||
fcos swap fsinh * -rot
|
fcos swap fsinh * -rot
|
||||||
fsin swap fcosh * rect> ; inline
|
fsin swap fcosh * rect> ; inline
|
||||||
|
|
||||||
: cosech sinh recip ; inline
|
: cosech ( x -- y ) sinh recip ; inline
|
||||||
|
|
||||||
: tan dup sin swap cos / ; inline
|
: tan ( x -- y ) dup sin swap cos / ; inline
|
||||||
: tanh dup sinh swap cosh / ; inline
|
: tanh ( x -- y ) dup sinh swap cosh / ; inline
|
||||||
: cot dup cos swap sin / ; inline
|
: cot ( x -- y ) dup cos swap sin / ; inline
|
||||||
: coth dup cosh swap sinh / ; inline
|
: coth ( x -- y ) dup cosh swap sinh / ; inline
|
||||||
|
|
|
@ -1,57 +1,57 @@
|
||||||
USING: help math ;
|
USING: help math ;
|
||||||
|
|
||||||
HELP: cosh "( x -- y )"
|
HELP: cosh
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Hyperbolic cosine." } ;
|
{ $description "Hyperbolic cosine." } ;
|
||||||
|
|
||||||
HELP: sech "( x -- y )"
|
HELP: sech
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Hyperbolic secant." } ;
|
{ $description "Hyperbolic secant." } ;
|
||||||
|
|
||||||
HELP: sinh "( x -- y )"
|
HELP: sinh
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Hyperbolic sine." } ;
|
{ $description "Hyperbolic sine." } ;
|
||||||
|
|
||||||
HELP: sinh "( x -- y )"
|
HELP: sinh
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Hyperbolic sine." } ;
|
{ $description "Hyperbolic sine." } ;
|
||||||
|
|
||||||
HELP: cosech "( x -- y )"
|
HELP: cosech
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Hyperbolic cosecant." } ;
|
{ $description "Hyperbolic cosecant." } ;
|
||||||
|
|
||||||
HELP: tanh "( x -- y )"
|
HELP: tanh
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Hyperbolic tangent." } ;
|
{ $description "Hyperbolic tangent." } ;
|
||||||
|
|
||||||
HELP: coth "( x -- y )"
|
HELP: coth
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Hyperbolic cotangent." } ;
|
{ $description "Hyperbolic cotangent." } ;
|
||||||
|
|
||||||
HELP: cos "( x -- y )"
|
HELP: cos
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Trigonometric cosine." } ;
|
{ $description "Trigonometric cosine." } ;
|
||||||
|
|
||||||
HELP: sec "( x -- y )"
|
HELP: sec
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Trigonometric secant." } ;
|
{ $description "Trigonometric secant." } ;
|
||||||
|
|
||||||
HELP: sin "( x -- y )"
|
HELP: sin
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Trigonometric sine." } ;
|
{ $description "Trigonometric sine." } ;
|
||||||
|
|
||||||
HELP: sin "( x -- y )"
|
HELP: sin
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Trigonometric sine." } ;
|
{ $description "Trigonometric sine." } ;
|
||||||
|
|
||||||
HELP: cosec "( x -- y )"
|
HELP: cosec
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Trigonometric cosecant." } ;
|
{ $description "Trigonometric cosecant." } ;
|
||||||
|
|
||||||
HELP: tan "( x -- y )"
|
HELP: tan
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Trigonometric tangent." } ;
|
{ $description "Trigonometric tangent." } ;
|
||||||
|
|
||||||
HELP: cot "( x -- y )"
|
HELP: cot
|
||||||
$values-x/y
|
$values-x/y
|
||||||
{ $description "Trigonometric cotangent." } ;
|
{ $description "Trigonometric cotangent." } ;
|
||||||
|
|
|
@ -3,27 +3,27 @@
|
||||||
IN: math
|
IN: math
|
||||||
USING: arrays generic kernel sequences ;
|
USING: arrays generic kernel sequences ;
|
||||||
|
|
||||||
: vneg ( v -- v ) [ neg ] map ;
|
: vneg ( u -- v ) [ neg ] map ;
|
||||||
|
|
||||||
: n*v ( n v -- v ) [ * ] map-with ;
|
: n*v ( n u -- v ) [ * ] map-with ;
|
||||||
: v*n ( v n -- v ) swap n*v ;
|
: v*n ( n u -- v ) swap n*v ;
|
||||||
: n/v ( n v -- v ) [ / ] map-with ;
|
: n/v ( n u -- v ) [ / ] map-with ;
|
||||||
: v/n ( v n -- v ) swap [ swap / ] map-with ;
|
: v/n ( u n -- v ) swap [ swap / ] map-with ;
|
||||||
|
|
||||||
: v+ ( v v -- v ) [ + ] 2map ;
|
: v+ ( u v -- w ) [ + ] 2map ;
|
||||||
: v- ( v v -- v ) [ - ] 2map ;
|
: v- ( u v -- w ) [ - ] 2map ;
|
||||||
: [v-] ( v v -- v ) [ [-] ] 2map ;
|
: [v-] ( u v -- w ) [ [-] ] 2map ;
|
||||||
: v* ( v v -- v ) [ * ] 2map ;
|
: v* ( u v -- w ) [ * ] 2map ;
|
||||||
: v/ ( v v -- v ) [ / ] 2map ;
|
: v/ ( u v -- w ) [ / ] 2map ;
|
||||||
: vmax ( v v -- v ) [ max ] 2map ;
|
: vmax ( u v -- w ) [ max ] 2map ;
|
||||||
: vmin ( v v -- v ) [ min ] 2map ;
|
: vmin ( u v -- w ) [ min ] 2map ;
|
||||||
|
|
||||||
: v. ( v v -- x ) 0 [ * + ] 2reduce ;
|
: v. ( v v -- x ) 0 [ * + ] 2reduce ;
|
||||||
: norm-sq ( v -- n ) 0 [ absq + ] reduce ;
|
: norm-sq ( v -- x ) 0 [ absq + ] reduce ;
|
||||||
: norm ( vec -- n ) norm-sq sqrt ;
|
: norm ( vec -- x ) norm-sq sqrt ;
|
||||||
: normalize ( vec -- uvec ) dup norm v/n ;
|
: 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 ;
|
dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ;
|
||||||
|
|
||||||
: sum ( seq -- n ) 0 [ + ] reduce ;
|
: sum ( seq -- n ) 0 [ + ] reduce ;
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue