: keep-searching ( seq quot -- slice )
[ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
-: (search) ( quot: ( elt -- <=> ) seq -- i elt )
+: (search) ( ... quot: ( ... elt -- ... <=> ) seq -- ... i elt )
dup length 1 <= [
finish
] [
<PRIVATE
-: (circular-while) ( iterator quot: ( obj -- ? ) -- )
+: (circular-while) ( ... iterator quot: ( ... obj -- ... ? ) -- ... )
[ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
rot [ [ dup n>> >>last-start ] dip ] when
over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
PRIVATE>
-: circular-while ( circular quot: ( obj -- ? ) -- )
+: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
[ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline
@
] with-destructors ; inline
-:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
+:: (NSFastEnumeration-each) ( ... object quot: ( ... elt -- ) state stackbuf count -- ... )
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
object quot state stackbuf count (NSFastEnumeration-each)
] unless ; inline recursive
-: NSFastEnumeration-each ( object quot -- )
+: NSFastEnumeration-each ( ... object quot: ( ... elt -- ... ) -- ... )
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
-: NSFastEnumeration-map ( object quot -- vector )
+: NSFastEnumeration-map ( ... object quot: ( ... elt -- ... newelt ) -- ... vector )
NS-EACH-BUFFER-SIZE <vector>
[ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline
: predecessors-changed ( cfg -- cfg )
f >>predecessors-valid? ;
-: with-cfg ( cfg quot: ( cfg -- ) -- )
+: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
[ dup cfg ] dip with-variable ; inline
TUPLE: mr { instructions array } word label ;
: successors ( bb -- first second ) successors>> first2 ; inline
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label ... )
+:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
bb insn
conditional-quot
[ drop dup successors>> second useless-branch? ] 2bi
tri
] with-compilation-unit
-: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
-: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
-: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
-: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
+: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
'[
[ basic-block set ] [
[
: record-renaming ( from to -- )
2array renaming-set get push needs-renaming? on ;
-:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
+:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
vreg rep-of :> preferred
preferred required eq?
[ vreg no-renaming ]
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
-: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
+: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
dupd '[ _ optimize-basic-block ] each-basic-block ; inline
: needs-post-order ( cfg -- cfg' )
- dup post-order drop ;
\ No newline at end of file
+ dup post-order drop ;
tmp dom-parent to tmp walk
] [ lnode ] if ;
-: each-incoming-j-edge ( bb quot: ( from to -- ) -- )
+: each-incoming-j-edge ( ... bb quot: ( ... from to -- ... ) -- ... )
[ [ predecessors>> ] keep ] dip
'[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
[ compute-merge-set-loop ]
tri ;
-: merge-set-each ( bbs quot: ( bb -- ) -- )
+: merge-set-each ( ... bbs quot: ( ... bb -- ... ) -- ... )
[ (merge-set) ] dip '[
swap _ [ drop ] if
] 2each ; inline
to dead-in to live-in to anticip-in assoc-diff assoc-diff
assoc-diff ;
-: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
+: each-insertion ( ... assoc bb quot: ( ... vreg loc -- ... ) -- ... )
'[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
ERROR: bad-peek dst loc ;
: word-tail-call? ( bb -- ? )
instructions>> penultimate ##call? ;
-: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
+: convert-tail-call ( ..a bb quot: ( ..a insn -- ..a tail-insn ) -- ..b )
'[
instructions>>
[ pop* ] [ pop ] [ ] tri
: optimize-tail-calls ( cfg -- cfg' )
dup [ optimize-tail-call ] each-basic-block
- cfg-changed predecessors-changed ;
\ No newline at end of file
+ cfg-changed predecessors-changed ;
: cfg-has-phis? ( cfg -- ? )
post-order [ has-phis? ] any? ;
-: if-has-phis ( bb quot: ( bb -- ) -- )
+: if-has-phis ( ..a bb quot: ( ..a bb -- ..b ) -- ..b )
[ dup has-phis? ] dip [ drop ] if ; inline
-: each-phi ( bb quot: ( ##phi -- ) -- )
+: each-phi ( ... bb quot: ( ... ##phi -- ... ) -- ... )
[ instructions>> ] dip
'[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
-: each-non-phi ( bb quot: ( insn -- ) -- )
+: each-non-phi ( ... bb quot: ( ... insn -- ... ) -- ... )
[ instructions>> ] dip
'[ dup ##phi? [ drop ] _ if ] each ; inline
compile-call
] unit-test
-: foobar ( quot: ( -- ) -- )
+: foobar ( quot: ( ..a -- ..b ) -- )
[ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ f ] foobar ] compile-call ] unit-test
USE: binary-search
USE: binary-search.private
-: old-binsearch ( elt quot: ( -- ) seq -- elt quot i )
+: old-binsearch ( elt quot: ( ..a -- ..b ) seq -- elt quot i )
dup length 1 <= [
from>>
] [
math.order ;
IN: compiler.tree.combinators
-: each-node ( nodes quot: ( node -- ) -- )
+: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
dup dup '[
_ [
dup #branch? [
] bi
] each ; inline recursive
-: map-nodes ( nodes quot: ( node -- node' ) -- nodes )
+: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
dup dup '[
@
dup #branch? [
] if
] map-flat ; inline recursive
-: contains-node? ( nodes quot: ( node -- ? ) -- ? )
+: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
dup dup '[
_ keep swap [ drop t ] [
dup #branch? [
: sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ;
-: until-fixed-point ( #recursive quot: ( node -- ) -- )
+: until-fixed-point ( ... #recursive quot: ( ... node -- ... ) -- ... )
over label>> t >>fixed-point drop
[ with-scope ] 2keep
over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ;
[ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test
-: call-recursive-dce-6 ( i quot: ( i -- ? ) -- i )
+: call-recursive-dce-6 ( i quot: ( ..a -- ..b ) -- i )
dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
[ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
SYMBOL: next-node
-: each-with-next ( seq quot: ( elt -- ) -- )
+: each-with-next ( ... seq quot: ( ... elt -- ... ) -- ... )
dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline
: (escape-analysis) ( node -- )
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
-: foo ( quot: ( -- ) -- ) call ; inline recursive
+: foo ( ..a quot: ( ..a -- ..b ) -- ..b ) call ; inline recursive
: recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ;
M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri
pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
- [ [ "x" <array> ] bi@ ] dip effect boa ;
+ [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
M: curry cached-effect
quot>> cached-effect curry-effect ;
recursive-nesting get pop*
] each ;
-: while-changing ( quot: ( -- ) -- )
+: while-changing ( ... quot: ( ... -- ... ) -- ... )
changed? off
[ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
inline recursive
} [ [ ] swap [ test-unboxing ] curry unit-test ] each
! A more complicated example
-: impeach-node ( quot: ( node -- ) -- )
+: impeach-node ( quot: ( ..a -- ..b ) -- )
[ call ] keep impeach-node ; inline recursive
-: bleach-node ( quot: ( node -- ) -- )
+: bleach-node ( quot: ( ..a -- ..b ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test
[ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]\r
[ huffman-code code>> free-bits neg 2^ /i 1array ] if ;\r
\r
-:: huffman-each ( tdesc quot: ( huffman-code -- ) -- )\r
+:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )\r
<huffman-code> :> code\r
tdesc\r
[\r
{ $values\r
{ "mailbox" mailbox }\r
{ "timeout" "a " { $link duration } " or " { $link f } }\r
- { "pred" { $quotation "( obj -- ? )" } } \r
+ { "pred" { $quotation "( ... message -- ... ? )" } } \r
}\r
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;\r
\r
: wait-for-mailbox ( mailbox timeout -- )
[ threads>> ] dip "mailbox" wait ;
-:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
+:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
mailbox data>> pred dlist-any? [
mailbox timeout wait-for-mailbox
mailbox timeout pred block-unless-pred
M: bad-effect summary
drop "Bad stack effect declaration" ;
+M: invalid-effect-variable summary
+ drop "Stack effect variables can only occur as the first input or output" ;
+M: effect-variable-can't-have-type summary
+ drop "Stack effect variables cannot have a declared type" ;
M: bad-escape error.
"Bad escape code: \\" write
: set-front-to-back ( dlist -- )
dup front>> [ dup back>> >>front ] unless drop ; inline
-: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
+: (dlist-find-node) ( ... dlist-node quot: ( ... node -- ... ? ) -- ... node/f ? )
over [
[ call ] 2keep rot
[ drop t ] [ [ next>> ] dip (dlist-find-node) ] if
] [ 2drop f f ] if ; inline recursive
-: dlist-find-node ( dlist quot -- node/f ? )
+: dlist-find-node ( ... dlist quot: ( ... node -- ... ? ) -- ... node/f ? )
[ front>> ] dip (dlist-find-node) ; inline
-: dlist-each-node ( dlist quot -- )
+: dlist-each-node ( ... dlist quot: ( ... node -- ... ) -- ... )
'[ @ f ] dlist-find-node 2drop ; inline
: unlink-node ( dlist-node -- )
] keep
normalize-front ;
-: dlist-find ( dlist quot -- obj/f ? )
+: dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
-: dlist-any? ( dlist quot -- ? )
+: dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? )
dlist-find nip ; inline
M: dlist deque-member? ( value dlist -- ? )
[ drop unlink-node ]
} cond ;
-: delete-node-if* ( dlist quot -- obj/f ? )
+: delete-node-if* ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
dupd dlist-find-node [
dup [
[ swap delete-node ] keep obj>> t
2drop f f
] if ; inline
-: delete-node-if ( dlist quot -- obj/f )
+: delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f )
'[ obj>> @ ] delete-node-if* drop ; inline
M: dlist clear-deque ( dlist -- )
f >>back
drop ;
-: dlist-each ( dlist quot -- )
+: dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... )
'[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
-: dlist-filter ( dlist quot -- dlist' )
+: dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' )
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
M: dlist clone
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
HELP: each-line
-{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( string -- )" } } }
+{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( ... line -- ... )" } } }
{ $description "Applies the quotation to each line in the range." }
{ $notes "The range is created by calling " { $link <slice> } "." }
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
to first line# =
[ to second ] [ line# document doc-line length ] if ;
-: each-line ( from to quot -- )
+: each-line ( ... from to quot: ( ... line -- ... ) -- ... )
2over = [ 3drop ] [
[ [ first ] bi@ [a,b] ] dip each
] if ; inline
-: map-lines ( from to quot -- results )
+: map-lines ( ... from to quot: ( ... line -- ... result ) -- ... results )
collector [ each-line ] dip ; inline
: start/end-on-line ( from to line# document -- n1 n2 )
: entire-doc ( document -- start end document )
[ [ doc-start ] dip doc-end ] keep ;
-: with-undo ( document quot: ( document -- ) -- )
+: with-undo ( ..a document quot: ( ..a document -- ..b ) -- ..b )
[ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline
PRIVATE>
{ CHAR: % inline-code }
} at ;
-: or-simple-title ( url title/f quot: ( title -- title' ) -- url title' )
+: or-simple-title ( ... url title/f quot: ( ... title -- ... title' ) -- ... url title' )
[ "" like dup simple-link-title ] if* ; inline
: parse-link ( string -- paragraph-list )
furnace.boilerplate\r
furnace.auth.providers\r
furnace.auth.providers.db ;\r
+FROM: assocs => change-at ;\r
IN: furnace.auth\r
\r
SYMBOL: logged-in-user\r
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors assocs destructors
db.tuples db.types furnace.cache ;
+FROM: assocs => change-at ;
IN: furnace.scopes
TUPLE: scope < server-state namespace changed? ;
{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ;\r
\r
HELP: apply-curry\r
-{ $values { "...a" { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }\r
+{ $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }\r
{ $description "Curries each of the top " { $snippet "n" } " items of the datastack onto " { $snippet "quot" } ", leaving " { $snippet "n" } " quotations on the datastack. A generalization of " { $link bi-curry@ } " and " { $link tri-curry@ } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry@ bi" } ", " { $snippet "tri-curry@ tri" } ", " { $snippet "bi-curry@ bi*" } ", and " { $snippet "tri-curry@ tri*" } "." } ;\r
\r
HELP: cleave-curry\r
-{ $values { "a" object } { "...quot" { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
+{ $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
{ $description "Curries " { $snippet "a" } " onto the " { $snippet "n" } " quotations on the top of the datastack. A generalization of " { $link bi-curry } " and " { $link tri-curry } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry bi" } ", " { $snippet "tri-curry tri" } ", " { $snippet "bi-curry bi*" } ", and " { $snippet "tri-curry tri*" } "." } ;\r
\r
HELP: spread-curry\r
-{ $values { "...a" { $snippet "n" } " objects on the datastack" } { "...quot" { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
+{ $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;\r
\r
: mnapply ( quot m n -- )
[ nip dupn ] [ nspread* ] 2bi ; inline
-: apply-curry ( ...a quot n -- )
+: apply-curry ( a... quot n -- )
[ [curry] ] dip napply ; inline
-: cleave-curry ( a ...quot n -- )
+: cleave-curry ( a quot... n -- )
[ [curry] ] swap [ napply ] [ cleave* ] bi ; inline
-: spread-curry ( ...a ...quot n -- )
+: spread-curry ( a... quot... n -- )
[ [curry] ] swap [ napply ] [ spread* ] bi ; inline
MACRO: mnswap ( m n -- )
first rest [ first ] map
] unless ;
+: extract-value-effects ( element -- seq )
+ \ $values swap elements dup empty? [
+ first rest [
+ \ $quotation swap elements dup empty? [ drop f ] [
+ first second
+ ] if
+ ] map
+ ] unless ;
+
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
[ dup pair? [ first ] when effect>string ] map prune ;
+: effect-effects ( word -- seq )
+ stack-effect in>> [
+ dup pair?
+ [ second dup effect? [ effect>string ] [ drop f ] if ]
+ [ drop f ] if
+ ] map ;
+
: contains-funky-elements? ( element -- ? )
{
$shuffle
[ effect-values ]
[ extract-values ]
bi* sequence=
- ]
+ ]
} 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
+: check-value-effects ( word element -- )
+ [ effect-effects ]
+ [ extract-value-effects ]
+ bi* [ 2dup and [ = ] [ 2drop t ] if ] 2all?
+ [ "$quotation documentation in $values don't match stack effect" simple-lint-error ]
+ unless ;
+
: check-nulls ( element -- )
\ $values swap elements
null swap deep-member?
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs continuations fry help help.lint.checks
-help.topics io kernel namespaces parser sequences
-source-files.errors vocabs.hierarchy vocabs words classes
-locals tools.errors listener ;
+USING: assocs combinators continuations fry help
+help.lint.checks help.topics io kernel namespaces parser
+sequences source-files.errors vocabs.hierarchy vocabs words
+classes locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ;
FROM: vocabs => child-vocabs ;
IN: help.lint
[ with-file-vocabs ] vocabs-quot set
dup word-help [
[ >link ] keep '[
- _ dup word-help
- [ check-values ]
- [ check-class-description ]
- [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
+ _ dup word-help {
+ [ check-values ]
+ [ check-value-effects ]
+ [ check-class-description ]
+ [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ]
+ } 2cleave
] check-something
] [ drop ] if ;
[ nip ] if
] if ;
-:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
+:: iterate-directory-entries ( ... iter quot: ( ... obj -- ... obj ) -- ... directory-entry/f )
iter next-directory-entry [
quot call
[ iter quot iterate-directory-entries ] unless*
{ leach foldl lmap>array } related-words
HELP: leach
-{ $values { "list" list } { "quot" { $quotation "( obj -- )" } } }
+{ $values { "list" list } { "quot" { $quotation "( ... elt -- ... )" } } }
{ $description "Call the quotation for each item in the list." } ;
HELP: foldl
-{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
+{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
HELP: foldr
-{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
+{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
HELP: lmap
-{ $values { "list" list } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } }
+{ $values { "list" list } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "result" "the final result" } }
{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
HELP: lreverse
PRIVATE>
-: leach ( list quot: ( elt -- ) -- )
+: leach ( ... list quot: ( ... elt -- ... ) -- ... )
over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
-: lmap ( list quot: ( elt -- ) -- result )
+: lmap ( ... list quot: ( ... elt -- ... newelt ) -- ... result )
over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive
-: foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+: foldl ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd leach ; inline
-:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+:: foldr ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
list nil? [ identity ] [
list cdr identity quot foldr
list car quot call
: sequence>list ( sequence -- list )
<reversed> nil [ swons ] reduce ;
-: lmap>array ( list quot -- array )
+: lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array )
collector [ leach ] dip { } like ; inline
: list>array ( list -- array )
: nth-row ( row# -- seq ) matrix get nth ;
-: change-row ( row# quot: ( seq -- seq ) -- )
+: change-row ( ..a row# quot: ( ..a seq -- ..b seq ) -- ..b )
matrix get swap change-nth ; inline
: exchange-rows ( row# row# -- ) matrix get exchange ;
: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
-: with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
+: with-rect-extents ( ..a+b rect1 rect2 loc-quot: ( ..a loc1 loc2 -- ..c ) ext-quot: ( ..b ext1 ext2 -- ..d ) -- ..c+d )
[ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
USING: kernel sequences regexp.transition-tables fry assocs
accessors locals math sorting arrays sets hashtables regexp.dfa
combinators.short-circuit regexp.classes ;
+FROM: assocs => change-at ;
IN: regexp.minimize
: table>state-numbers ( table -- assoc )
<reversed>
>hashtable ;
-:: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj )
+:: (while-changes) ( ..a obj quot: ( ..a obj -- ..b obj' ) comp: ( ..b obj' -- ..a key ) old-key -- ..a obj )
obj quot call :> new-obj
new-obj comp call :> new-key
new-key old-key =
dup next-match>>
execute( i string regexp -- i start end ? ) ; inline
-:: (each-match) ( i string regexp quot: ( start end string -- ) -- )
+:: (each-match) ( ... i string regexp quot: ( ... start end string -- ... ) -- ... )
i string regexp do-next-match [| i' start end |
start end string quot call
i' string regexp quot (each-match)
PRIVATE>
-: each-match ( string regexp quot: ( start end string -- ) -- )
+: each-match ( ... string regexp quot: ( ... start end string -- ... ) -- ... )
[ prepare-match-iterator ] dip (each-match) ; inline
-: map-matches ( string regexp quot: ( start end string -- obj ) -- seq )
+: map-matches ( ... string regexp quot: ( ... start end string -- ... obj ) -- ... seq )
collector [ each-match ] dip >array ; inline
: all-matching-slices ( string regexp -- seq )
IN: sequences.deep
HELP: deep-each
-{ $values { "obj" object } { "quot" { $quotation "( elt -- )" } } }
+{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... )" } } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder." }
{ $see-also each } ;
HELP: deep-map
-{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "newobj" "the mapped object" } }
+{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... elt' )" } } { "newobj" "the mapped object" } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." }
{ $see-also map } ;
HELP: deep-filter
-{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a sequence" } }
+{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "seq" "a sequence" } }
{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." }
{ $see-also filter } ;
HELP: deep-find
-{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "elt" "an element" } }
+{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "elt" "an element" } }
{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." }
{ $see-also find } ;
HELP: deep-any?
-{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests whether the given object or any subnode satisfies the given quotation." }
{ $see-also any? } ;
{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ;
HELP: deep-map!
-{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } }
+{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... elt' )" } } }
{ $description "Modifies each sub-node of an object in place, in preorder, and returns that object." }
{ $see-also map! } ;
M: string branch? drop f ;
M: object branch? drop f ;
-: deep-each ( obj quot: ( elt -- ) -- )
+: deep-each ( ... obj quot: ( ... elt -- ... ) -- ... )
[ call ] 2keep over branch?
[ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive
-: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
+: deep-map ( ... obj quot: ( ... elt -- ... elt' ) -- ... newobj )
[ call ] keep over branch?
[ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
-: deep-filter ( obj quot: ( elt -- ? ) -- seq )
+: deep-filter ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
over [ selector [ deep-each ] dip ] dip
dup branch? [ like ] [ drop ] if ; inline recursive
-: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
+: (deep-find) ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
[ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean
] [ 2drop f f ] if
] if ; inline recursive
-: deep-find ( obj quot -- elt ) (deep-find) drop ; inline
+: deep-find ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ) (deep-find) drop ; inline
-: deep-any? ( obj quot -- ? ) (deep-find) nip ; inline
+: deep-any? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? ) (deep-find) nip ; inline
-: deep-all? ( obj quot -- ? )
+: deep-all? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? )
'[ @ not ] deep-any? not ; inline
: deep-member? ( obj seq -- ? )
_ swap dup branch? [ subseq? ] [ 2drop f ] if
] deep-find >boolean ;
-: deep-map! ( obj quot: ( elt -- elt' ) -- obj )
+: deep-map! ( ... obj quot: ( ... elt -- ... elt' ) -- ... obj )
over branch? [
'[ _ [ call ] keep over [ deep-map! drop ] dip ] map!
] [ drop ] if ; inline recursive
IN: sequences.generalizations
HELP: neach
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- )" } } { "n" integer } }
{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
HELP: nmap
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
HELP: nmap-as
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
HELP: mnmap
{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
HELP: nproduce-as
-{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "exemplar..." { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
dup 1 - [ min ] n*quot
'[ [ length ] _ napply @ ] ;
-: nnth-unsafe ( n ...seq n -- )
+: nnth-unsafe ( n seq... n -- )
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
MACRO: nset-nth-unsafe ( n -- )
[ [ drop ] ]
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
if-zero ;
-: (neach) ( ...seq quot n -- len quot' )
+: (neach) ( seq... quot n -- len quot' )
dup dup dup
'[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
-: neach ( ...seq quot n -- )
+: neach ( seq... quot n -- )
(neach) each-integer ; inline
-: nmap-as ( ...seq quot exemplar n -- result )
+: nmap-as ( seq... quot exemplar n -- result )
'[ _ (neach) ] dip map-integers ; inline
-: nmap ( ...seq quot n -- result )
+: nmap ( seq... quot n -- result )
dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
MACRO: nnew-sequence ( n -- )
[ [ drop ] ]
[ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
-: nnew-like ( len ...exemplar quot n -- result... )
+: nnew-like ( len exemplar... quot n -- result... )
5 dupn '[
_ nover
[ [ _ nnew-sequence ] dip call ]
3 dupn 1 +
'[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
-: ncollect ( len quot ...into n -- )
+: ncollect ( len quot into... n -- )
(ncollect) each-integer ; inline
-: nmap-integers ( len quot ...exemplar n -- result... )
+: nmap-integers ( len quot exemplar... n -- result... )
4 dupn
'[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
: mnmap ( m*seq quot m n -- result*n )
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
-: ncollector-for ( quot ...exemplar n -- quot' vec... )
+: ncollector-for ( quot exemplar... n -- quot' vec... )
5 dupn '[
[ [ length ] keep new-resizable ] _ napply
[ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
: ncollector ( quot n -- quot' vec... )
[ V{ } swap dupn ] keep ncollector-for ; inline
-: nproduce-as ( pred quot ...exemplar n -- seq... )
+: nproduce-as ( pred quot exemplar... n -- seq... )
7 dupn '[
_ ndup
[ _ ncollector-for [ while ] _ ndip ]
: get+increment ( sequence-parser -- char/f )
[ current ] [ advance drop ] bi ; inline
-:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+:: skip-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... )
sequence-parser current [
sequence-parser quot call
[ sequence-parser advance quot skip-until ] unless
: sequence-parse-end? ( sequence-parser -- ? ) current not ;
-: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+: take-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
over sequence-parse-end? [
2drop f
] [
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
] if ; inline
-: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+: take-while ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
[ not ] compose take-until ; inline
: <safe-slice> ( from to seq -- slice/f )
IN: sorting.insertion
<PRIVATE
-:: insert ( seq quot: ( elt -- elt' ) n -- )
+:: insert ( ... seq quot: ( ... elt -- ... elt' ) n -- ... )
n zero? [
n n 1 - [ seq nth quot call ] bi@ >= [
n n 1 - seq exchange
V{ } clone \ literals set
H{ } clone known-values set
0 input-count set
+ 0 inner-d-index set
] unit-test
[ 0 ] [ 0 ensure-d length ] unit-test
USING: fry arrays generic io io.streams.string kernel math namespaces
parser sequences strings vectors words quotations effects classes
continuations assocs combinators compiler.errors accessors math.order
-definitions sets hints macros stack-checker.state
+definitions locals sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state stack-checker.dependencies summary ;
+FROM: sequences.private => from-end ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
[ #introduce, ]
tri ;
+: update-inner-d ( new -- )
+ inner-d-index get min inner-d-index set ;
+
: pop-d ( -- obj )
- meta-d [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
+ meta-d
+ [ <value> dup 1array introduce-values ]
+ [ pop meta-d length update-inner-d ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
[ introduce-values ] [ meta-d push-all ] bi
meta-d push-all
- ] when swap tail* ;
+ ] when
+ swap from-end [ tail ] [ update-inner-d ] bi ;
: shorten-by ( n seq -- )
[ length swap - ] keep shorten ; inline
+: shorten-d ( n -- )
+ meta-d shorten-by meta-d length update-inner-d ;
+
: consume-d ( n -- seq )
- [ ensure-d ] [ meta-d shorten-by ] bi ;
+ [ ensure-d ] [ shorten-d ] bi ;
: output-d ( values -- ) meta-d push-all ;
: infer-r> ( n -- )
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
-: consume/produce ( effect quot: ( inputs outputs -- ) -- )
+: consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b )
'[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
[ terminated?>> [ terminate ] when ]
bi ; inline
current-effect
stack-visitor get
] with-scope ; inline
+
+: (infer) ( quot -- effect )
+ [ infer-quot-here ] with-infer drop ;
+
+: ?quotation-effect ( in -- effect/f )
+ dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
+
+:: declare-effect-d ( word effect variables branches n -- )
+ meta-d length :> d-length
+ n d-length < [
+ d-length 1 - n - :> n'
+ n' meta-d nth :> value
+ value known :> known
+ known word effect variables branches <declared-effect> :> known'
+ known' value set-known
+ known' branches push
+ ] [ word unknown-macro-input ] if ;
+
+:: declare-input-effects ( word -- )
+ H{ } clone :> variables
+ V{ } clone :> branches
+ word stack-effect in>> <reversed> [| in n |
+ in ?quotation-effect [| effect |
+ word effect variables branches n declare-effect-d
+ ] when*
+ ] each-index ;
+
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry vectors sequences assocs math math.order accessors kernel
-combinators quotations namespaces grouping stack-checker.state
+USING: arrays effects fry vectors sequences assocs math math.order accessors kernel
+combinators quotations namespaces grouping locals stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.branches
SYMBOL: quotations
+: simple-unbalanced-branches-error ( branches quots -- * )
+ [ \ if ] 2dip swap
+ [ length [ (( ..a -- ..b )) ] replicate ]
+ [ [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
+ unbalanced-branches-error ;
+
: unify-branches ( ins stacks -- in phi-in phi-out )
zip [ 0 { } { } ] [
[ keys supremum ] [ ] [ balanced? ] tri
[ dupd phi-inputs dup phi-outputs ]
- [ quotations get unbalanced-branches-error ]
+ [ quotations get simple-unbalanced-branches-error ]
if
] if-empty ;
branch-variable ;
: datastack-phi ( seq -- phi-in phi-out )
- [ input-count branch-variable ] [ \ meta-d active-variable ] bi
+ [ input-count branch-variable ]
+ [ inner-d-index branch-variable infimum inner-d-index set ]
+ [ \ meta-d active-variable ] tri
unify-branches
[ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ;
: copy-inference ( -- )
\ meta-d [ clone ] change
literals [ clone ] change
- input-count [ ] change ;
+ input-count [ ] change
+ inner-d-index [ ] change ;
GENERIC: infer-branch ( literal -- namespace )
[ value>> quotation set ] [ infer-literal-quot ] bi
] H{ } make-assoc ;
+M: declared-effect infer-branch
+ known>> infer-branch ;
+
M: callable infer-branch
[
copy-inference
infer-branches
[ first2 #if, ] dip compute-phi-function ;
+GENERIC: curried/composed? ( known -- ? )
+M: object curried/composed? drop f ;
+M: curried curried/composed? drop t ;
+M: composed curried/composed? drop t ;
+M: declared-effect curried/composed? known>> curried/composed? ;
+
+:: declare-if-effects ( -- )
+ H{ } clone :> variables
+ V{ } clone :> branches
+ \ if (( ..a -- ..b )) variables branches 0 declare-effect-d
+ \ if (( ..a -- ..b )) variables branches 1 declare-effect-d ;
+
: infer-if ( -- )
2 literals-available? [
(infer-if)
] [
- drop 2 consume-d
- dup [ known [ curried? ] [ composed? ] bi or ] any? [
+ drop 2 ensure-d
+ declare-if-effects
+ 2 shorten-d
+ dup [ known curried/composed? ] any? [
output-d
[ rot [ drop call ] [ nip call ] if ]
infer-quot-here
} ;
HELP: unbalanced-branches-error
-{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } }
-{ $description "Throws an " { $link unbalanced-branches-error } "." }
-{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." }
-{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." }
+{ $error-description "Thrown when inference encounters an inline combinator whose input quotations do not match their declared effects, or when it encounters an " { $link if } " or " { $link dispatch } " whose branches do not all exit with the same stack height. See " { $link "inference-combinators" } " and " { $link "inference-branches" } " for details." }
{ $examples
{ $code
- ": unbalanced-branches-example ( a b c -- )"
+ ": if-unbalanced-branches-example ( a b c -- )"
" [ + ] [ dup ] if ;"
}
+ { $code
+ ": each-unbalanced-branches-example ( x seq -- x' )"
+ " [ 3append ] each ;"
+ }
} ;
HELP: too-many->r
ERROR: unknown-macro-input < inference-error macro ;
-ERROR: unbalanced-branches-error < inference-error branches quots ;
-
ERROR: too-many->r < inference-error ;
ERROR: too-many-r> < inference-error ;
ERROR: transform-expansion-error < inference-error error continuation word ;
-ERROR: bad-declaration-error < inference-error declaration ;
\ No newline at end of file
+ERROR: bad-declaration-error < inference-error declaration ;
+
+ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ;
+
M: bad-macro-input summary
macro>> name>> "Cannot apply “" "” to a run-time computed value" surround ;
-M: unbalanced-branches-error summary
- drop "Unbalanced branches" ;
-
-M: unbalanced-branches-error error.
- dup summary print
- [ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi zip
- [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
-
M: too-many->r summary
drop "Quotation pushes elements on retain stack without popping them" ;
tri ;
M: do-not-compile summary
- word>> name>> "Cannot compile call to " prepend ;
\ No newline at end of file
+ word>> name>> "Cannot compile call to " prepend ;
+
+M: unbalanced-branches-error summary
+ word>> name>>
+ "The input quotations to " " don't match their expected effects" surround ;
+
+M: unbalanced-branches-error error.
+ dup summary print
+ [ quots>> ] [ declareds>> ] [ actuals>> ] tri 3array flip
+ { "Input" "Expected" "Got" } prefix simple-table. ;
+
stack-checker.branches
stack-checker.known-words
stack-checker.dependencies
+stack-checker.row-polymorphism
stack-checker.recursive-state ;
IN: stack-checker.inlining
: trimmed-enter-out ( label -- stack )
dup enter-out>> trim-stack ;
+GENERIC: (undeclared-known) ( value -- known )
+M: object (undeclared-known) ;
+M: declared-effect (undeclared-known) known>> (undeclared-known) ;
+
+: undeclared-known ( value -- known ) known (undeclared-known) ;
+
: check-call-site-stack ( label -- )
[ ] [ call-site-stack ] [ trimmed-enter-out ] tri
- [ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
+ [ dup undeclared-known [ [ undeclared-known ] bi@ = ] [ 2drop t ] if ] 2all?
[ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
: check-call ( label -- )
: inline-word ( word -- )
commit-literals
[ depends-on-definition ]
+ [ declare-input-effects ]
[
dup inline-recursive-label [
call-recursive-inline-word
[ dup infer-inline-word-def ]
if
] if*
- ] bi ;
+ ] tri ;
M: word apply-object
dup inline? [ inline-word ] [ non-inline-word ] if ;
stack-checker.branches
stack-checker.transforms
stack-checker.dependencies
-stack-checker.recursive-state ;
+stack-checker.recursive-state
+stack-checker.row-polymorphism ;
IN: stack-checker.known-words
: infer-primitive ( word -- )
1 infer->r infer-call
terminated? get [ 1 infer-r> infer-call ] unless ;
+M: declared-effect infer-call*
+ [ [ known>> infer-call* ] keep ] with-effect-here check-declared-effect ;
+
M: input-parameter infer-call* \ call unknown-macro-input ;
M: object infer-call* \ call bad-macro-input ;
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs combinators combinators.short-circuit
+continuations effects fry kernel locals math math.order namespaces
+quotations sequences splitting
+stack-checker.backend
+stack-checker.errors
+stack-checker.known-words
+stack-checker.state
+stack-checker.values
+stack-checker.visitor ;
+IN: stack-checker.row-polymorphism
+
+:: with-inner-d ( quot -- inner-d )
+ inner-d-index get :> old-inner-d-index
+ meta-d length inner-d-index set
+ quot call
+ inner-d-index get :> new-inner-d-index
+ old-inner-d-index new-inner-d-index min inner-d-index set
+ new-inner-d-index ; inline
+
+:: with-effect-here ( quot -- effect )
+ input-count get :> old-input-count
+ meta-d length :> old-meta-d-length
+
+ quot with-inner-d :> inner-d
+
+ input-count get :> new-input-count
+ old-meta-d-length inner-d -
+ new-input-count old-input-count - + :> in
+ meta-d length inner-d - :> out
+ in "x" <array> out "x" <array> terminated? get <terminated-effect> ; inline
+
+:: check-variable ( actual-count declared-count variable vars -- difference ? )
+ actual-count declared-count -
+ variable [
+ variable vars at* nip
+ [ variable vars at - ]
+ [ variable vars set-at 0 ] if
+ t
+ ] [ dup 0 <= ] if ;
+
+: adjust-variable ( diff var vars -- )
+ pick 0 >=
+ [ at+ ]
+ [ 3drop ] if ; inline
+
+:: check-variables ( vars declared actual -- ? )
+ actual terminated?>> [ t ] [
+ actual declared [ in>> length ] bi@ declared in-var>>
+ [ vars check-variable ] keep :> ( in-diff in-ok? in-var )
+ actual declared [ out>> length ] bi@ declared out-var>>
+ [ vars check-variable ] keep :> ( out-diff out-ok? out-var )
+ { [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&&
+ dup [
+ in-var [ in-diff swap vars adjust-variable ] when*
+ out-var [ out-diff swap vars adjust-variable ] when*
+ ] when
+ ] if ;
+
+: complex-unbalanced-branches-error ( known -- * )
+ [ word>> ] [
+ branches>> <reversed>
+ [ [ known>callable ] { } map-as ]
+ [ [ effect>> ] { } map-as ]
+ [ [ actual>> ] { } map-as ] tri
+ ] bi unbalanced-branches-error ;
+
+: check-declared-effect ( known effect -- )
+ [ >>actual ] keep
+ 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
+ [ 2drop ] [ drop complex-unbalanced-branches-error ] if ;
+
{ "If the word is declared " { $link POSTPONE: inline } ", the combinator may additionally be called on one of the word's input parameters or with quotations built from the word's input parameters, literal quotations, " { $link curry } ", and " { $link compose } ". When inline, a word is itself considered to be a combinator, and its callers must in turn satisfy these conditions." }
}
"If neither condition holds, the stack checker throws a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error. To make the code compile, a runtime checking combinator such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by " { $link curry } "ing the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "."
+{ $heading "Input stack effects" }
+"Inline combinators will verify the stack effect of their input quotations if they are declared in the combinator's stack effect. See " { $link "effects-variables" } " for details."
{ $heading "Examples" }
{ $subheading "Calling a combinator" }
"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":"
! Test some curry stuff
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
+{ 3 1 } [ [ ] curry [ [ ] curry ] dip if ] must-infer-as
{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] curry [ [ ] 2curry ] dip if ] infer ] [ unbalanced-branches-error? ] must-fail-with
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
[ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with
[ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
-[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+
+[ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with
+[ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
+[ [ [ "derp" ] if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
[ "special" word-prop not ] filter
[ "shuffle" word-prop not ] filter
] unit-test
+
+{ 1 0 } [ [ drop ] each ] must-infer-as
+{ 2 1 } [ [ append ] each ] must-infer-as
+{ 1 1 } [ [ ] map ] must-infer-as
+{ 1 1 } [ [ reverse ] map ] must-infer-as
+{ 2 2 } [ [ append dup ] map ] must-infer-as
+{ 2 2 } [ [ swap nth suffix dup ] map-index ] must-infer-as
+
+{ 4 1 } [ [ 2drop ] [ 2nip ] if ] must-infer-as
+{ 3 3 } [ [ dup ] [ over ] if ] must-infer-as
+{ 1 1 } [ [ 1 ] [ 0 ] if ] must-infer-as
+{ 2 2 } [ [ t ] [ 1 + f ] if ] must-infer-as
+
+{ 1 0 } [ [ write ] [ "(f)" write ] if* ] must-infer-as
+{ 1 1 } [ [ ] [ f ] if* ] must-infer-as
+{ 2 1 } [ [ nip ] [ drop f ] if* ] must-infer-as
+{ 2 1 } [ [ nip ] [ ] if* ] must-infer-as
+{ 3 2 } [ [ 3append f ] [ ] if* ] must-infer-as
+{ 1 0 } [ [ drop ] [ ] if* ] must-infer-as
+
+{ 1 1 } [ [ 1 + ] [ "oops" throw ] if* ] must-infer-as
+
+: strict-each ( seq quot: ( x -- ) -- )
+ each ; inline
+: strict-map ( seq quot: ( x -- x' ) -- seq' )
+ map ; inline
+: strict-2map ( xs ys quot: ( x y -- z ) -- zs )
+ 2map ; inline
+
+{ 1 0 } [ [ drop ] strict-each ] must-infer-as
+{ 1 1 } [ [ 1 + ] strict-map ] must-infer-as
+{ 1 1 } [ [ ] strict-map ] must-infer-as
+{ 2 1 } [ [ + ] strict-2map ] must-infer-as
+{ 2 1 } [ [ drop ] strict-2map ] must-infer-as
+[ [ [ append ] strict-each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ 1 + ] strict-2map ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+! ensure that polymorphic checking works on recursive combinators
+FROM: splitting.private => split, ;
+{ 2 0 } [ [ member? ] curry split, ] must-infer-as
+
+[ [ [ write write ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ dup ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ 1 + ] map-index ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ dup ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ 2dup ] [ over ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ [ ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ dup ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ drop ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ ] [ 2dup ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+! M\ declared-effect infer-call* didn't properly unify branches
+{ 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as
+
GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect )
- [ infer-quot-here ] with-infer drop ;
+ (infer) ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
! Number of inputs current word expects from the stack
SYMBOL: input-count
+SYMBOL: inner-d-index
DEFER: commit-literals
: current-effect ( -- effect )
input-count get "x" <array>
meta-d length "x" <array>
- terminated? get effect boa ;
+ terminated? get <terminated-effect> ;
: init-inference ( -- )
terminated? off
V{ } clone \ meta-d set
V{ } clone literals set
- 0 input-count set ;
+ 0 input-count set
+ 0 inner-d-index set ;
:: ((apply-transform)) ( quot values stack rstate -- )
rstate recursive-state [ stack quot call-transformer ] with-variable
- values [ length meta-d shorten-by ] [ #drop, ] bi
+ values [ length shorten-d ] [ #drop, ] bi
rstate infer-quot ;
: literal-values? ( values -- ? ) [ literal-value? ] all? ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel assocs sequences
-stack-checker.recursive-state stack-checker.errors ;
+USING: accessors namespaces fry kernel assocs sequences
+stack-checker.recursive-state stack-checker.errors
+quotations ;
IN: stack-checker.values
! Values
M: input-parameter (literal) current-word get unknown-macro-input ;
+! Argument corresponding to polymorphic declared input of inline combinator
+
+TUPLE: declared-effect known word effect variables branches actual ;
+
+C: (declared-effect) declared-effect
+
+: <declared-effect> ( known word effect variables branches -- declared-effect )
+ f (declared-effect) ; inline
+
+M: declared-effect (input-value?) known>> (input-value?) ;
+
+M: declared-effect (literal-value?) known>> (literal-value?) ;
+
+M: declared-effect (literal) known>> (literal) ;
+
! Computed values
M: f (input-value?) drop f ;
M: f (literal-value?) drop f ;
-M: f (literal) current-word get bad-macro-input ;
\ No newline at end of file
+M: f (literal) current-word get bad-macro-input ;
+
+GENERIC: known>callable ( known -- quot )
+
+: ?@ ( x -- y )
+ dup callable? [ drop [ @ ] ] unless ;
+
+M: object known>callable drop \ _ ;
+M: literal known>callable value>> ;
+M: composed known>callable
+ [ quot1>> known known>callable ?@ ] [ quot2>> known known>callable ?@ ] bi
+ append ;
+M: curried known>callable
+ [ quot>> known known>callable ] [ obj>> known known>callable ] bi
+ prefix ;
+M: declared-effect known>callable
+ known>> known>callable ;
+
dup cell-bits ud_set_mode
dup UD_SYN_INTEL ud_set_syntax ;
-: with-ud ( quot: ( ud -- ) -- )
+: with-ud ( ..a quot: ( ..a ud -- ..b ) -- ..b )
[ [ [ <ud> ] dip call ] with-destructors ] with-code-blocks ; inline
SINGLETON: udis-disassembler
: each-attrs ( attrs quot -- )
[ values [ interpolated? ] filter ] dip each ; inline
-: (each-interpolated) ( item quot: ( interpolated -- ) -- )
+: (each-interpolated) ( ... item quot: ( ... interpolated -- ... ) -- ... )
{
{ [ over interpolated? ] [ call ] }
{ [ over tag? ] [ [ attrs>> ] dip each-attrs ] }
! with-input-stream implicitly creates a new scope which we use
swap [ init-parser call ] with-input-stream ; inline
-:: (skip-until) ( quot: ( -- ? ) spot -- )
+:: (skip-until) ( ... quot: ( ... -- ... ? ) spot -- ... )
spot char>> [
quot call [
spot next* quot spot (skip-until)
] unless
] when ; inline recursive
-: skip-until ( quot: ( -- ? ) -- )
+: skip-until ( ... quot: ( ... -- ... ? ) -- ... )
spot get (skip-until) ; inline
: take-until ( quot -- string )
} ;
HELP: alien-invoke
-{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
+{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } { "return..." "the return value of the function, if not " { $link void } } }
{ $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 " { $link void } " indicates that no value is to be expected." }
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
{ $errors "Throws an " { $link alien-invoke-error } " if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler." } ;
} ;
HELP: alien-indirect
-{ $values { "..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
+{ $values { "args..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "return..." "the return value of the function, if not " { $link void } } }
{ $description
"Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected."
}
} ;
HELP: alien-assembly
-{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } }
+{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } { "return..." "the return value of the function, if not " { $link void } } }
{ $description
"Invokes arbitrary machine code, generated at compile-time by the quotation. 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 " { $link void } " indicates that no value is to be expected."
}
ERROR: alien-indirect-error ;
-: alien-indirect ( ... funcptr return parameters abi -- ... )
+: alien-indirect ( args... funcptr return parameters abi -- return... )
alien-indirect-error ;
ERROR: alien-invoke-error library symbol ;
-: alien-invoke ( ... return library function parameters -- ... )
+: alien-invoke ( args... return library function parameters -- return... )
2over alien-invoke-error ;
ERROR: alien-assembly-error code ;
-: alien-assembly ( ... return parameters abi quot -- ... )
+: alien-assembly ( args... return parameters abi quot -- return... )
dup alien-assembly-error ;
! Callbacks are registered in a global hashtable. Note that they
: substituter ( assoc -- quot )
[ ?at drop ] curry ; inline
-: with-assoc ( assoc quot: ( value key assoc -- ) -- quot: ( key value -- ) )
+: with-assoc ( assoc quot: ( ..a value key assoc -- ..b ) -- quot: ( ..a key value -- ..b ) )
curry [ swap ] prepose ; inline
PRIVATE>
{ "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
{ "<byte-array>" "byte-arrays" "primitive_byte_array" (( n -- byte-array )) }
{ "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- newbyte-array )) }
- { "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( ... layout -- tuple )) }
+ { "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( slots... layout -- tuple )) }
{ "<tuple>" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) }
{ "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist update-existing? reset-pics? -- )) }
{ "lookup-method" "generic.single.private" "primitive_lookup_method" (( object methods -- method )) }
{ $values { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
-HELP: <tuple-boa> ( ... layout -- tuple )
-{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
+HELP: <tuple-boa> ( slots... layout -- tuple )
+{ $values { "slots..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: new
} ;
HELP: boa
-{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
+{ $values { "slots..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." }
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;
{ bi* tri* spread } related-words
HELP: to-fixed-point
-{ $values { "object" object } { "quot" { $quotation "( object(n) -- object(n+1) )" } } { "object(n)" object } }
+{ $values { "object" object } { "quot" { $quotation "( ... object(n) -- ... object(n+1) )" } } { "object(n)" object } }
{ $description "Applies the quotation repeatedly with " { $snippet "object" } " as the initial input until the output of the quotation equals the input." }
{ $examples
{ $example
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
-: to-fixed-point ( object quot: ( object(n) -- object(n+1) ) -- object(n) )
+: to-fixed-point ( ... object quot: ( ... object(n) -- ... object(n+1) ) -- ... object(n) )
[ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive
{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
HELP: recover
-{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
+{ $values { "try" { $quotation "( ..a -- ..b )" } } { "recovery" { $quotation "( ..a error -- ..b )" } } }
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
HELP: ignore-errors
] when
c> continue-with ;
-: recover ( try recovery -- )
+: recover ( ..a try: ( ..a -- ..b ) recovery: ( ..a error -- ..b ) -- ..b )
[ [ swap >c call c> drop ] curry ] dip ifcc ; inline
: ignore-errors ( quot -- )
ERROR: attempt-all-error ;
-: attempt-all ( seq quot -- obj )
+: attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
over empty? [
attempt-all-error
] [
-USING: help.markup help.syntax math strings words kernel combinators ;
+USING: arrays classes help.markup help.syntax math strings words kernel combinators sequences ;
IN: effects
ARTICLE: "effects" "Stack effect declarations"
{ $code "( input1 input2 ... -- output1 ... )" }
"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:"
{ $synopsis + }
-"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:"
+"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration. If the number of inputs or outputs depends on the stack effects of quotation parameters, " { $link "effects-variables" } " can be used to declare this:"
{ $synopsis while }
-"Only the number of inputs and outputs carries semantic meaning."
-$nl
-"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "."
+"For words that are not " { $link POSTPONE: inline } ", only the number of inputs and outputs carries semantic meaning, and effect variables are ignored. However, nested quotation declarations are enforced for inline words. Nested quotation declarations are optional for non-recursive inline combinators and only provide better error messages. However, quotation inputs to " { $link POSTPONE: recursive } " combinators must have an effect declared. See " { $link "inference-recursive-combinators" } "."
$nl
"In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters."
$nl
{ { $snippet "loc" } "a screen location specified as a two-element array holding x and y co-ordinates" }
{ { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" }
{ { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" }
+ { { $snippet ".." } { "indicates " { $link "effects-variables" } ". only valid as the first input or first output" } }
+}
+"For reflection and metaprogramming, you can use " { $link "syntax-effects" } " to include literal stack effects in your code, or these constructor words to construct stack effect objects at runtime:"
+{ $subsections
+ <effect>
+ <terminated-effect>
+ <variable-effect>
}
+$nl
{ $see-also "inference" } ;
+HELP: <effect>
+{ $values
+ { "in" "a sequence of strings or string–type pairs" }
+ { "out" "a sequence of strings or string–type pairs" }
+ { "effect" effect }
+}
+{ $description "Constructs an " { $link effect } " object. Each element of " { $snippet "in" } " and " { $snippet "out" } " must be either a string (which is equivalent to a " { $snippet "name" } " in literal stack effect syntax), or a " { $link pair } " where the first element is a string and the second is either a " { $link class } " or effect (which is equivalent to " { $snippet "name: class" } " or " { $snippet "name: ( nested -- effect )" } " in the literal syntax. If the " { $snippet "out" } " array consists of a single string element " { $snippet "\"*\"" } ", a terminating stack effect will be constructed." }
+{ $notes "This word cannot construct effects with " { $link "effects-variables" } ". Use " { $link <variable-effect> } " to construct variable stack effects." }
+{ $examples
+{ $example """USING: effects prettyprint ;
+{ "a" "b" } { "c" } <effect> .""" """(( a b -- c ))""" }
+{ $example """USING: arrays effects prettyprint ;
+{ "a" { "b" array } } { "c" } <effect> .""" """(( a b: array -- c ))""" }
+{ $example """USING: effects prettyprint ;
+{ "a" { "b" (( x y -- z )) } } { "c" } <effect> .""" """(( a b: ( x y -- z ) -- c ))""" }
+{ $example """USING: effects prettyprint ;
+{ "a" { "b" (( x y -- z )) } } { "*" } <effect> .""" """(( a b: ( x y -- z ) -- * ))""" }
+} ;
+
+HELP: <terminated-effect>
+{ $values
+ { "in" "a sequence of strings or string–type pairs" }
+ { "out" "a sequence of strings or string–type pairs" }
+ { "terminated?" boolean }
+ { "effect" effect }
+}
+{ $description "Constructs an " { $link effect } " object like " { $link <effect> } ". If " { $snippet "terminated?" } " is true, the value of " { $snippet "out" } " is ignored, and a terminating stack effect is constructed." }
+{ $notes "This word cannot construct effects with " { $link "effects-variables" } ". Use " { $link <variable-effect> } " to construct variable stack effects." }
+{ $examples
+{ $example """USING: effects prettyprint ;
+{ "a" { "b" (( x y -- z )) } } { "c" } f <terminated-effect> .""" """(( a b: ( x y -- z ) -- c ))""" }
+{ $example """USING: effects prettyprint ;
+{ "a" { "b" (( x y -- z )) } } { } t <terminated-effect> .""" """(( a b: ( x y -- z ) -- * ))""" }
+} ;
+
+HELP: <variable-effect>
+{ $values
+ { "in-var" { $maybe string } }
+ { "in" "a sequence of strings or string–type pairs" }
+ { "out-var" { $maybe string } }
+ { "out" "a sequence of strings or string–type pairs" }
+ { "effect" effect }
+}
+{ $description "Constructs an " { $link effect } " object like " { $link <effect> } ". If " { $snippet "in-var" } " or " { $snippet "out-var" } " are not " { $link f } ", they are used as the names of the " { $link "effects-variables" } " for the inputs and outputs of the effect object." }
+{ $examples
+{ $example """USING: effects prettyprint ;
+f { "a" "b" } f { "c" } <variable-effect> .""" """(( a b -- c ))""" }
+{ $example """USING: effects prettyprint ;
+"x" { "a" "b" } "y" { "c" } <variable-effect> .""" """(( ..x a b -- ..y c ))""" }
+{ $example """USING: arrays effects prettyprint ;
+"y" { "a" { "b" (( ..x -- ..y )) } } "x" { "c" } <variable-effect> .""" """(( ..y a b: ( ..x -- ..y ) -- ..x c ))""" }
+{ $example """USING: effects prettyprint ;
+"." { "a" "b" } f { "*" } <variable-effect> .""" """(( ... a b -- * ))""" }
+} ;
+
+
+{ <effect> <terminated-effect> <variable-effect> } related-words
+
+ARTICLE: "effects-variables" "Stack effect variables"
+{ $link POSTPONE: inline } " combinators can have variable stack effects, depending on the effect of the quotation they call. For example, while " { $link each } " inputs elements of its sequence to its quotation, the quotation can also manipulate values on the stack below the element, as long as it leaves the same number of elements on the stack. This ability is used to implement " { $link reduce } " in terms of " { $snippet "each" } ". This variable stack effect is indicated by starting the list of inputs and outputs with a name starting with " { $snippet ".." } ":"
+{ $synopsis each }
+"In combinators with multiple quotation inputs, the number of inputs or outputs represented by a particular " { $snippet ".." } " name must match. For example, the predicate for a " { $link while } " loop can take an arbitrary number of inputs and leave an arbitrary number of outputs on the stack in addition to the predicate result; however, for the loop to leave the stack balanced, the body of the while loop must consume all of the predicate's outputs and leave a number of its own outputs equal to the initial number of stack values before the predicate was called. This is expressed with the following stack effect:"
+{ $synopsis while }
+"Stack effect variables can only occur as the first input or first output of a stack effect; names starting in " { $snippet ".." } " cause a syntax error if they occur elsewhere in the effect. For words that are not " { $link POSTPONE: inline } ", effect variables are currently ignored by the stack checker." ;
+
ABOUT: "effects"
HELP: effect
-USING: effects kernel tools.test prettyprint accessors
+USING: effects effects.parser eval kernel tools.test prettyprint accessors
quotations sequences ;
IN: effects.tests
[ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
[ { object sequence } ] [ (( a b: sequence -- )) effect-in-types ] unit-test
+
+[ f ] [ (( a b c -- d )) in-var>> ] unit-test
+[ f ] [ (( -- d )) in-var>> ] unit-test
+[ "a" ] [ (( ..a b c -- d )) in-var>> ] unit-test
+[ { "b" "c" } ] [ (( ..a b c -- d )) in>> ] unit-test
+
+[ f ] [ (( ..a b c -- e )) out-var>> ] unit-test
+[ "d" ] [ (( ..a b c -- ..d e )) out-var>> ] unit-test
+[ { "e" } ] [ (( ..a b c -- ..d e )) out>> ] unit-test
+
+[ "(( a ..b c -- d ))" eval( -- effect ) ]
+[ error>> invalid-effect-variable? ] must-fail-with
+
+[ "(( ..a: integer b c -- d ))" eval( -- effect ) ]
+[ error>> effect-variable-can't-have-type? ] must-fail-with
TUPLE: effect
{ in array read-only }
{ out array read-only }
-{ terminated? read-only } ;
+{ terminated? read-only }
+{ in-var read-only }
+{ out-var read-only } ;
+
+: ?terminated ( out -- out terminated? )
+ dup { "*" } = [ drop { } t ] [ f ] if ;
: <effect> ( in out -- effect )
- dup { "*" } = [ drop { } t ] [ f ] if
- effect boa ;
+ ?terminated f f effect boa ;
+
+: <terminated-effect> ( in out terminated? -- effect )
+ f f effect boa ; inline
+
+: <variable-effect> ( in-var in out-var out -- effect )
+ swap [ rot ] dip [ ?terminated ] 2dip effect boa ;
: effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline
: stack-picture ( seq -- string )
[ [ effect>string % CHAR: \s , ] each ] "" make ;
+: var-picture ( var -- string )
+ [ ".." " " surround ]
+ [ "" ] if* ;
+
M: effect effect>string ( effect -- string )
[
"( " %
- [ in>> stack-picture % "-- " % ]
- [ out>> stack-picture % ]
- [ terminated?>> [ "* " % ] when ]
- tri
+ dup in-var>> var-picture %
+ dup in>> stack-picture % "-- " %
+ dup out-var>> var-picture %
+ dup out>> stack-picture %
+ dup terminated?>> [ "* " % ] when
+ drop
")" %
] "" make ;
shuffle-mapping swap nths ;
: add-effect-input ( effect -- effect' )
- [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
+ [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri <terminated-effect> ;
: compose-effects ( effect1 effect2 -- effect' )
over terminated?>> [
[ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
[ [ "x" <array> ] bi@ ] dip
- effect boa
+ <terminated-effect>
] if ; inline
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects
-combinators arrays vocabs.parser classes parser ;
+combinators arrays make vocabs.parser classes parser ;
IN: effects.parser
DEFER: parse-effect
ERROR: bad-effect ;
-
-: parse-effect-token ( end -- token/f )
- scan [ nip ] [ = ] 2bi [ drop f ] [
- dup { f "(" "((" } member? [ bad-effect ] [
- ":" ?tail [
- scan {
- { [ dup "(" = ] [ drop ")" parse-effect ] }
- { [ dup f = ] [ ")" unexpected-eof ] }
- [ parse-word dup class? [ bad-effect ] unless ]
- } cond 2array
- ] when
+ERROR: invalid-effect-variable ;
+ERROR: effect-variable-can't-have-type ;
+ERROR: stack-effect-omits-dashes ;
+
+SYMBOL: effect-var
+
+: parse-var ( first? var name -- var )
+ nip
+ [ ":" ?tail [ effect-variable-can't-have-type ] when ] curry
+ [ invalid-effect-variable ] if ;
+
+: parse-effect-token ( first? var end -- var more? )
+ scan [ nip ] [ = ] 2bi [ drop nip f ] [
+ dup { f "(" "((" "--" } member? [ bad-effect ] [
+ dup { ")" "))" } member? [ stack-effect-omits-dashes ] [
+ ".." ?head [ parse-var t ] [
+ [ drop ] 2dip
+ ":" ?tail [
+ scan {
+ { [ dup "(" = ] [ drop ")" parse-effect ] }
+ { [ dup f = ] [ ")" unexpected-eof ] }
+ [ parse-word dup class? [ bad-effect ] unless ]
+ } cond 2array
+ ] when , t
+ ] if
+ ] if
] if
] if ;
-: parse-effect-tokens ( end -- tokens )
- [ parse-effect-token dup ] curry [ ] produce nip ;
-
-ERROR: stack-effect-omits-dashes tokens ;
+: parse-effect-tokens ( end -- var tokens )
+ [
+ [ t f ] dip [ parse-effect-token [ f ] 2dip ] curry [ ] while nip
+ ] { } make ;
: parse-effect ( end -- effect )
- parse-effect-tokens { "--" } split1 dup
- [ <effect> ] [ drop stack-effect-omits-dashes ] if ;
+ [ "--" parse-effect-tokens ] dip parse-effect-tokens
+ <variable-effect> ;
: complete-effect ( -- effect )
"(" expect ")" parse-effect ;
SYMBOL: generic-word
-: make-math-method-table ( classes quot: ( class -- quot ) -- alist )
+: make-math-method-table ( classes quot: ( ... class -- ... quot ) -- alist )
[ bootstrap-words ] dip
[ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline
: tuple-dispatch ( picker alist -- alist' )
swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
-: math-dispatch-step ( picker quot: ( class -- quot ) -- quot )
+: math-dispatch-step ( picker quot: ( ... class -- ... quot ) -- quot )
[ [ { bignum float fixnum } ] dip make-math-method-table ]
[ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi
tuple swap 2array prefix tag-dispatch ; inline
: bl ( -- ) " " write ;
-: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
+: each-morsel ( ..a handler: ( ..a data -- ..b ) reader: ( ..b -- ..a data ) -- ..a )
[ dup ] compose swap while drop ; inline
<PRIVATE
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?
-{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( ... obj -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" }
} ;
HELP: either?
-{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( ... obj -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" }
{ $notes "Used to implement " { $link "threads" } "." } ;
HELP: keep
-{ $values { "x" object } { "quot" { $quotation "( x -- ... )" } } }
+{ $values { "x" object } { "quot" { $quotation "( ..a x -- ..b )" } } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
{ $examples
{ $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ <array> ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" }
} ;
HELP: 2keep
-{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ... )" } } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( ..a x y -- ..b )" } } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
-{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( x y z -- ... )" } } }
+{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( ..a x y z -- ..b )" } } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
-{ $values { "x" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( x -- ... )" } } }
+{ $values { "x" object } { "p" { $quotation "( ..a x -- ..b )" } } { "q" { $quotation "( ..c x -- ..d )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } "." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: if*
-{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" quotation } }
+{ $values { "?" "a generalized boolean" } { "true" { $quotation "( ..a ? -- ..b )" } } { "false" { $quotation "( ..a -- ..b )" } } }
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
$nl
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
-{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" { $quotation "( default -- ... )" } } }
+{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( ..a cond -- ..b )" } } { "false" { $quotation "( ..a default -- ..b )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"
} ;
HELP: while
-{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
+{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } }
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ;
HELP: until
-{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
+{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } }
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ;
HELP: do
-{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
+{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } }
{ $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ;
HELP: loop
#! two literal quotations.
rot [ drop ] [ nip ] if ; inline
-: if ( ? true false -- ) ? call ;
+: if ( ..a ? true: ( ..a -- ..b ) false: ( ..a -- ..b ) -- ..b ) ? call ;
! Single branch
: unless ( ? false -- )
swap [ call ] [ drop ] if ; inline
! Anaphoric
-: if* ( ? true false -- )
+: if* ( ..a ? true: ( ..a ? -- ..b ) false: ( ..a -- ..b ) -- ..b )
pick [ drop call ] [ 2nip call ] if ; inline
: when* ( ? true -- )
over [ drop ] [ nip call ] if ; inline
! Default
-: ?if ( default cond true false -- )
+: ?if ( ..a default cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
! Dippers.
: most ( x y quot -- z ) 2keep ? ; inline
! Loops
-: loop ( pred: ( -- ? ) -- )
+: loop ( ... pred: ( ... -- ... ? ) -- ... )
[ call ] keep [ loop ] curry when ; inline recursive
: do ( pred body -- pred body )
dup 2dip ; inline
-: while ( pred: ( -- ? ) body: ( -- ) -- )
+: while ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b )
swap do compose [ loop ] curry when ; inline
-: until ( pred: ( -- ? ) body: ( -- ) -- )
+: until ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b )
[ [ not ] compose ] dip while ; inline
! Object protocol
! Tuple construction
GENERIC: new ( class -- tuple )
-GENERIC: boa ( ... class -- tuple )
+GENERIC: boa ( slots... class -- tuple )
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
HELP: each-token
-{ $values { "end" string } { "quot" { $quotation "( token -- )" } } }
+{ $values { "end" string } { "quot" { $quotation "( ... token -- ... )" } } }
{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read." }
{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
$parsing-note ;
HELP: map-tokens
-{ $values { "end" string } { "quot" { $quotation "( token -- object )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } }
+{ $values { "end" string } { "quot" { $quotation "( ... token -- ... elt )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } }
{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read, and the results are collected into a new output sequence." }
$parsing-note ;
: (each-token) ( end quot -- pred quot )
[ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline
-: each-token ( end quot -- )
+: each-token ( ... end quot: ( ... token -- ... ) -- ... )
(each-token) while drop ; inline
-: map-tokens ( end quot -- seq )
+: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
(each-token) produce nip ; inline
: parse-tokens ( end -- seq )
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: each-integer
-{ $values { "n" integer } { "quot" { $quotation "( i -- )" } } }
+{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... )" } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }
{ $notes "This word is used to implement " { $link each } "." } ;
HELP: all-integers?
-{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "?" "a boolean" } }
+{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "?" "a boolean" } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iteration stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." }
{ $notes "This word is used to implement " { $link all? } "." } ;
HELP: find-integer
-{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } }
+{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs a true value or the end is reached. If the quotation yields a true value for some integer, this word outputs that integer. Otherwise, this word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find } "." } ;
HELP: find-last-integer
-{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } }
+{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find-last } "." } ;
: even? ( n -- ? ) 1 bitand zero? ;
: odd? ( n -- ? ) 1 bitand 1 number= ;
-: if-zero ( n quot1 quot2 -- )
+: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
[ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-zero ( n quot -- ) [ ] if-zero ; inline
PRIVATE>
-: (each-integer) ( i n quot: ( i -- ) -- )
+: (each-integer) ( ... i n quot: ( ... i -- ... ) -- ... )
[ iterate-step iterate-next (each-integer) ]
[ 3drop ] if-iterate? ; inline recursive
-: (find-integer) ( i n quot: ( i -- ? ) -- i )
+: (find-integer) ( ... i n quot: ( ... i -- ... ? ) -- ... i )
[
iterate-step
[ [ ] ] 2dip
[ iterate-next (find-integer) ] 2curry bi-curry if
] [ 3drop f ] if-iterate? ; inline recursive
-: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
+: (all-integers?) ( ... i n quot: ( ... i -- ... ? ) -- ... ? )
[
iterate-step
[ iterate-next (all-integers?) ] 3curry
: all-integers? ( n quot -- ? )
iterate-prep (all-integers?) ; inline
-: find-last-integer ( n quot: ( i -- ? ) -- i )
+: find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i )
over 0 < [
2drop f
] [
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory. User code must use " { $link set-nth } " instead." } ;
HELP: collect
-{ $values { "n" "a non-negative integer" } { "quot" { $quotation "( n -- value )" } } { "into" "a sequence of length at least " { $snippet "n" } } }
+{ $values { "n" "a non-negative integer" } { "quot" { $quotation "( ... n -- ... value )" } } { "into" "a sequence of length at least " { $snippet "n" } } }
{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. User code should use " { $link map } " instead." } ;
HELP: each
-{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... x -- ... )" } } }
{ $description "Applies the quotation to each element of the sequence in order." } ;
HELP: reduce
-{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." }
{ $examples
{ $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" }
HELP: reduce-index
{ $values
- { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt index -- result )" } } }
+ { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt index -- ... next )" } } { "result" object } }
{ $description "Combines successive elements of the sequence and their indices binary operations, and outputs the final result. On the first iteration, the three inputs to the quotation are " { $snippet "identity" } ", the first element of the sequence, and its index, 0. On successive iterations, the first input is the result of the previous iteration, the second input is the corresponding element of the sequence, and the third is its index." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 50 90 } 0 [ + + ] reduce-index ."
} } ;
HELP: accumulate-as
-{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of the same type as " { $snippet "exemplar" } " containing intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } ;
HELP: accumulate
-{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "final" "the final result" } { "newseq" "a new array" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs an array of intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
} ;
HELP: accumulate!
-{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "final" "the final result" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs the original sequence of intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
} ;
HELP: map
-{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: map-as
-{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
{ $examples
"The following example converts a string into an array of one-element strings:"
HELP: each-index
{ $values
- { "seq" sequence } { "quot" { $quotation "( elt index -- )" } } }
+ { "seq" sequence } { "quot" { $quotation "( ... elt index -- ... )" } } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack." }
{ $examples { $example "USING: arrays sequences prettyprint ;"
"{ 10 20 30 } [ 2array . ] each-index"
HELP: map-index
{ $values
- { "seq" sequence } { "quot" { $quotation "( elt index -- result )" } } { "newseq" sequence } }
+ { "seq" sequence } { "quot" { $quotation "( ... elt index -- ... newelt )" } } { "newseq" sequence } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." }
{ $examples { $example "USING: arrays sequences prettyprint ;"
"{ 10 20 30 } [ 2array ] map-index ."
} } ;
HELP: change-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( elt -- newelt )" } } }
+{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( ... elt -- ... newelt )" } } }
{ $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
{ $errors "Throws an error if the sequence is immutable, if the index is out of bounds, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
HELP: map!
-{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } }
+{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( ... elt -- ... newelt )" } } }
{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence. Returns the original sequence." }
{ $errors "Throws an error if the sequence is immutable, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
{ $description "Outputs the maximum of the lengths of the two sequences." } ;
HELP: 2each
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... )" } } }
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: 3each
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- )" } } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... )" } } }
{ $description "Applies the quotation to triples of elements from " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } "." } ;
HELP: 2reduce
{ $values { "seq1" sequence }
{ "seq2" sequence }
{ "identity" object }
- { "quot" { $quotation "( prev elt1 elt2 -- next )" } }
+ { "quot" { $quotation "( ... prev elt1 elt2 -- ... next )" } }
{ "result" "the final result" } }
{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
HELP: 2map
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
HELP: 3map
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "newseq" "a new sequence" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... newelt )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
HELP: 2map-as
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 3map-as
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 2all?
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: find
{ $values { "seq" sequence }
- { "quot" { $quotation "( elt -- ? )" } }
+ { "quot" { $quotation "( ... elt -- ... ? )" } }
{ "i" "the index of the first match, or " { $link f } }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-from } " where the starting index is 0." } ;
HELP: find-from
{ $values { "n" "a starting index" }
{ "seq" sequence }
- { "quot" { $quotation "( elt -- ? )" } }
+ { "quot" { $quotation "( ... elt -- ... ? )" } }
{ "i" "the index of the first match, or " { $link f } }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in turn, until it outputs a true value or the end of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
HELP: find-last
-{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-last-from } " where the starting index is one less than the length of the sequence." } ;
HELP: find-last-from
-{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
+{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
HELP: map-find
-{ $values { "seq" sequence } { "quot" { $quotation "( elt -- result/f )" } } { "result" "the first non-false result of the quotation" } { "elt" "the first matching element, or " { $link f } } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... result/f )" } } { "result" "the first non-false result of the quotation" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence, until the quotation outputs a true value. If the quotation ever yields a result which is not " { $link f } ", then the value is output, along with the element of the sequence which yielded this." } ;
HELP: any?
-{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ;
HELP: all?
-{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
HELP: push-if
-{ $values { "elt" object } { "quot" { $quotation "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
+{ $values { "elt" object } { "quot" { $quotation "( ..a elt -- ..b ? )" } } { "accum" "a resizable mutable sequence" } }
{ $description "Adds the element at the end of the sequence if the quotation yields a true value." }
{ $notes "This word is a factor of " { $link filter } "." } ;
HELP: filter
-{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter-as
-{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } }
+{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter!
-{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
+{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( ... elt -- ... ? )" } } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
{ $side-effects "seq" } ;
HELP: interleave
-{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( elt -- )" } } }
+{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( ... elt -- ... )" } } }
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
{ $side-effects "seq" } ;
HELP: padding
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( ... seq1 seq2 -- ... newseq )" } } { "newseq" "a new sequence" } }
{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
HELP: pad-head
{ $errors "Throws an error if the sequence is empty." } ;
HELP: produce
-{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "seq" "a sequence" } }
+{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "quot" { $quotation "( ..b -- ..a obj )" } } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
} ;
HELP: produce-as
-{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "exemplar" sequence } { "seq" "a sequence" } }
+{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "quot" { $quotation "( ..b -- ..a obj )" } } { "exemplar" sequence } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." }
{ $examples "See " { $link produce } " for examples." } ;
HELP: selector
{ $values
- { "quot" { $quotation "( elt -- ? )" } }
- { "selector" { $quotation "( elt -- )" } } { "accum" vector } }
+ { "quot" { $quotation "( ... elt -- ... ? )" } }
+ { "selector" { $quotation "( ... elt -- ... )" } } { "accum" vector } }
{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the collector if the test yields true. The collector is left on the stack for convenience." }
{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
"10 iota [ even? ] selector [ each ] dip ."
HELP: replicate
{ $values
- { "len" integer } { "quot" { $quotation "( -- elt )" } }
+ { "len" integer } { "quot" { $quotation "( ... -- ... newelt )" } }
{ "newseq" sequence } }
{ $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new array." }
{ $examples
HELP: replicate-as
{ $values
- { "len" integer } { "quot" { $quotation "( -- elt )" } } { "exemplar" sequence }
+ { "len" integer } { "quot" { $quotation "( ... -- ... newelt )" } } { "exemplar" sequence }
{ "newseq" sequence } }
{ $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
{ $examples
HELP: 2map-reduce
{ $values
- { "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation "( elt1 elt2 -- intermediate )" } } { "reduce-quot" { $quotation "( prev intermediate -- result )" } }
+ { "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation "( ..a elt1 elt2 -- ..b intermediate )" } } { "reduce-quot" { $quotation "( ..b prev intermediate -- ..a next )" } }
{ "result" object } }
{ $description "Calls " { $snippet "map-quot" } " on each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } " and combines the results using " { $snippet "reduce-quot" } " in the same manner as " { $link reduce } ", except that there is no identity element, and the sequence must have a length of at least 1." }
{ $errors "Throws an error if the sequence is empty." }
HELP: binary-reduce
{ $values
- { "seq" sequence } { "start" integer } { "quot" { $quotation "( elt1 elt2 -- newelt )" } }
+ { "seq" sequence } { "start" integer } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } }
{ "value" object } }
{ $description "Like " { $link reduce } ", but splits the sequence in half recursively until each sequence is small enough, and calls the quotation on these smaller sequences. If the quotation computes values that depend on the size of their input, such as bignum arithmetic, then this algorithm can be more efficient than using " { $link reduce } "." }
{ $examples "Computing factorial:"
HELP: follow
{ $values
- { "obj" object } { "quot" { $quotation "( prev -- result/f )" } }
+ { "obj" object } { "quot" { $quotation "( ... prev -- ... result/f )" } }
{ "seq" sequence } }
{ $description "Outputs a sequence containing the input object and all of the objects generated by successively feeding the result of the quotation called on the input object to the quotation recursuively. Objects yielded by the quotation are added to the output sequence until the quotation yields " { $link f } ", at which point the recursion terminates." }
{ $examples "Get random numbers until zero is reached:"
} ;
HELP: cartesian-each
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... )" } } }
{ $description "Applies the quotation to every possible pairing of elements from the two sequences." } ;
HELP: cartesian-map
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- result )" } } { "newseq" "a new sequence of sequences" } }
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "newseq" "a new sequence of sequences" } }
{ $description "Applies the quotation to every possible pairing of elements from the two sequences, collecting results into a new sequence of sequences." } ;
HELP: cartesian-product
: empty? ( seq -- ? ) length 0 = ; inline
-: if-empty ( seq quot1 quot2 -- )
+: if-empty ( ..a seq quot1: ( ..a -- ..b ) quot2: ( ..a seq -- ..b ) -- ..b )
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-empty ( seq quot -- ) [ ] if-empty ; inline
PRIVATE>
-: each ( seq quot -- )
+: each ( ... seq quot: ( ... x -- ... ) -- ... )
(each) each-integer ; inline
-: reduce ( seq identity quot -- result )
+: reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd each ; inline
: map-integers ( len quot exemplar -- newseq )
[ over ] dip [ [ collect ] keep ] new-like ; inline
-: map-as ( seq quot exemplar -- newseq )
+: map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
[ (each) ] dip map-integers ; inline
-: map ( seq quot -- newseq )
+: map ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
over map-as ; inline
-: replicate-as ( len quot exemplar -- newseq )
+: replicate-as ( ... len quot: ( ... -- ... newelt ) exemplar -- ... newseq )
[ [ drop ] prepose ] dip map-integers ; inline
-: replicate ( len quot -- newseq )
+: replicate ( ... len quot: ( ... -- ... newelt ) -- ... newseq )
{ } replicate-as ; inline
-: map! ( seq quot -- seq )
+: map! ( ... seq quot: ( ... elt -- ... newelt ) -- ... seq )
over [ map-into ] keep ; inline
-: accumulate-as ( seq identity quot exemplar -- final newseq )
+: accumulate-as ( ... seq identity quot: ( ... prev elt -- ... next ) exemplar -- ... final newseq )
[ (accumulate) ] dip map-as ; inline
-: accumulate ( seq identity quot -- final newseq )
+: accumulate ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final newseq )
{ } accumulate-as ; inline
-: accumulate! ( seq identity quot -- final seq )
+: accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
(accumulate) map! ; inline
-: 2each ( seq1 seq2 quot -- )
+: 2each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
(2each) each-integer ; inline
-: 2reverse-each ( seq1 seq2 quot -- )
+: 2reverse-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
[ [ <reversed> ] bi@ ] dip 2each ; inline
-: 2reduce ( seq1 seq2 identity quot -- result )
+: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline
-: 2map-as ( seq1 seq2 quot exemplar -- newseq )
+: 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq )
[ (2each) ] dip map-integers ; inline
-: 2map ( seq1 seq2 quot -- newseq )
+: 2map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
pick 2map-as ; inline
-: 2all? ( seq1 seq2 quot -- ? )
+: 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
(2each) all-integers? ; inline
-: 3each ( seq1 seq2 seq3 quot -- )
+: 3each ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) -- ... )
(3each) each-integer ; inline
-: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
+: 3map-as ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) exemplar -- ... newseq )
[ (3each) ] dip map-integers ; inline
-: 3map ( seq1 seq2 seq3 quot -- newseq )
+: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq )
[ pick ] dip swap 3map-as ; inline
-: find-from ( n seq quot -- i elt )
+: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ (find-integer) ] (find-from) ; inline
-: find ( seq quot -- i elt )
+: find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ find-integer ] (find) ; inline
-: find-last-from ( n seq quot -- i elt )
+: find-last-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ nip find-last-integer ] (find-from) ; inline
-: find-last ( seq quot -- i elt )
+: find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ [ 1 - ] dip find-last-integer ] (find) ; inline
-: all? ( seq quot -- ? )
+: all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
(each) all-integers? ; inline
-: push-if ( elt quot accum -- )
+: push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
: selector-for ( quot exemplar -- selector accum )
: selector ( quot -- selector accum )
V{ } selector-for ; inline
-: filter-as ( seq quot exemplar -- subseq )
+: filter-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... subseq )
dup [ selector-for [ each ] dip ] curry dip like ; inline
-: filter ( seq quot -- subseq )
+: filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
over filter-as ; inline
-: push-either ( elt quot accum1 accum2 -- )
+: push-either ( ..a elt quot: ( ..a elt -- ..b ? ) accum1 accum2 -- ..b )
[ keep swap ] 2dip ? push ; inline
: 2selector ( quot -- selector accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
-: partition ( seq quot -- trueseq falseseq )
+: partition ( ... seq quot: ( ... elt -- ... ? ) -- ... trueseq falseseq )
over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: collector-for ( quot exemplar -- quot' vec )
: collector ( quot -- quot' vec )
V{ } collector-for ; inline
-: produce-as ( pred quot exemplar -- seq )
+: produce-as ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) exemplar -- ..b seq )
dup [ collector-for [ while ] dip ] curry dip like ; inline
-: produce ( pred quot -- seq )
+: produce ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) -- ..b seq )
{ } produce-as ; inline
-: follow ( obj quot -- seq )
+: follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq )
[ dup ] swap [ keep ] curry produce nip ; inline
-: each-index ( seq quot -- )
+: each-index ( ... seq quot: ( ... elt index -- ... ) -- ... )
(each-index) each-integer ; inline
: interleave ( seq between quot -- )
3bi
] if ; inline
-: map-index ( seq quot -- newseq )
+: map-index ( ... seq quot: ( ... elt index -- ... newelt ) -- ... newseq )
[ dup length iota ] dip 2map ; inline
-: reduce-index ( seq identity quot -- )
+: reduce-index ( ... seq identity quot: ( ... prev elt index -- ... next ) -- ... result )
swapd each-index ; inline
: index ( obj seq -- n )
: nths ( indices seq -- seq' )
[ nth ] curry map ;
-: any? ( seq quot -- ? )
+: any? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
find drop >boolean ; inline
: member? ( elt seq -- ? )
<PRIVATE
-: (filter!) ( quot: ( elt -- ? ) store scan seq -- )
+: (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
2dup length < [
[ move ] 3keep
[ nth-unsafe pick call [ 1 + ] when ] 2keep
PRIVATE>
-: filter! ( seq quot -- seq )
+: filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
swap [ [ 0 0 ] dip (filter!) ] keep ; inline
: remove! ( elt seq -- seq )
] keep like
] if ;
-: padding ( seq n elt quot -- newseq )
+: padding ( ... seq n elt quot: ( ... seq1 seq2 -- ... newseq ) -- ... newseq )
[
[ over length [-] dup 0 = [ drop ] ] dip
[ <repetition> ] curry
: halves ( seq -- first-slice second-slice )
dup midpoint@ cut-slice ;
-: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
+: binary-reduce ( ... seq start quot: ( ... elt1 elt2 -- ... newelt ) -- ... value )
#! We can't use case here since combinators depends on
#! sequences
pick length dup 0 3 between? [
: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
[ unclip-slice ] bi@ swapd ; inline
-: map-reduce ( seq map-quot reduce-quot -- result )
+: map-reduce ( ..a seq map-quot: ( ..a x -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
[ [ unclip-slice ] dip [ call ] keep ] dip
compose reduce ; inline
-: 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result )
+: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a elt1 elt2 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
[ [ prepare-2map-reduce ] keep ] dip
compose compose each-integer ; inline
PRIVATE>
-: map-find ( seq quot -- result elt )
+: map-find ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt )
[ find ] (map-find) ; inline
-: map-find-last ( seq quot -- result elt )
+: map-find-last ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt )
[ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last )
PRIVATE>
-: trim-head-slice ( seq quot -- slice )
+: trim-head-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-head) tail-slice ; inline
-: trim-head ( seq quot -- newseq )
+: trim-head ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-head) tail ; inline
-: trim-tail-slice ( seq quot -- slice )
+: trim-tail-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-tail) head-slice ; inline
-: trim-tail ( seq quot -- newseq )
+: trim-tail ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-tail) head ; inline
-: trim-slice ( seq quot -- slice )
+: trim-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
[ trim-head-slice ] [ trim-tail-slice ] bi ; inline
-: trim ( seq quot -- newseq )
+: trim ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
[ trim-slice ] [ drop ] 2bi like ; inline
GENERIC: sum ( seq -- n )
: supremum ( seq -- n ) [ ] [ max ] map-reduce ;
-: map-sum ( seq quot -- n )
+: map-sum ( ... seq quot: ( ... elt -- ... n ) -- ... n )
[ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
-: count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline
+: count ( ... seq quot: ( ... elt -- ... ? ) -- ... n ) [ 1 0 ? ] compose map-sum ; inline
-: cartesian-each ( seq1 seq2 quot -- )
+: cartesian-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
[ with each ] 2curry each ; inline
-: cartesian-map ( seq1 seq2 quot -- newseq )
+: cartesian-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
[ with map ] 2curry map ; inline
: cartesian-product ( seq1 seq2 -- newseq )
[ drop [ swap [ tail ] unless-zero , ] 2curry ]
3tri if* ; inline recursive
-: split, ( seq quot -- ) [ 0 ] 2dip (split) ; inline
+: split, ( ... seq quot: ( ... elt -- ... ? ) -- ... ) [ 0 ] 2dip (split) ; inline
PRIVATE>
: process-day ( account date -- )
2dup accumulate-interest ?pay-interest ;
-: each-day ( quot: ( -- ) start end -- )
+: each-day ( ... quot: ( ... day -- ... ) start end -- ... )
2dup before? [
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
body-array{ } output>sequence
dup init-bodies ; inline
-:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
+:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- )
bodies [| body i |
body each-quot call
bodies i 1 + tail-slice [
[ <sun> <jupiter> <saturn> <uranus> <neptune> ] output>array nbody-system boa
dup bodies>> init-bodies ; inline
-:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
+:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- ... )
bodies [| body i |
body each-quot call
bodies i 1 + tail-slice [
: ensure-buffer ( -- )
(buffer) drop ; inline
-: with-buffer ( quot: ( -- ) -- byte-vector )
+: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
[ (buffer) [ reset-buffer ] keep dup ] dip
with-output-stream* ; inline
-: with-length ( quot: ( -- ) -- bytes-written start-index )
+: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
[ (buffer) [ length ] keep ] dip
call length swap [ - ] keep ; inline
-: (with-length-prefix) ( quot: ( -- ) length-quot: ( bytes-written -- length ) -- )
+: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
[ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
[ call ] dip (buffer) copy ; inline
-: with-length-prefix ( quot: ( -- ) -- )
+: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
[ INT32-SIZE >le ] (with-length-prefix) ; inline
-: with-length-prefix-excl ( quot: ( -- ) -- )
+: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
[ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
<PRIVATE
: mdb-special-value? ( value -- ? )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
- [ oid? ] [ byte-array? ] } 1|| ; inline
\ No newline at end of file
+ [ oid? ] [ byte-array? ] } 1|| ; inline
PRIVATE>
-: fuel-use-suggested-vocabs ( suggestions quot -- ... )
+: fuel-use-suggested-vocabs ( ..a suggestions quot: ( ..a -- ..b ) -- ..b )
[ :uses-suggestions set ] dip
[ try-suggested-restarts rethrow ] recover ; inline
: fuel-run-file ( path -- )
[ fuel-set-use-hook run-file ] curry with-scope ; inline
-: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... )
+: fuel-with-autouse ( ..a quot: ( ..a -- ..b ) -- ..b )
[ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline
: fuel-get-uses ( lines -- )
HELP: with-mapped-buffer
{ $values
- { "buffer" buffer } { "access" buffer-access-mode } { "quot" { $quotation "( alien -- )" } }
+ { "buffer" buffer } { "access" buffer-access-mode } { "quot" { $quotation "( ..a alien -- ..b )" } }
}
{ $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;
from-buffer-ptr offset>> to-buffer-ptr offset>>
size glCopyBufferSubData ;
-:: with-mapped-buffer ( buffer access quot: ( alien -- ) -- )
+:: with-mapped-buffer ( ..a buffer access quot: ( ..a alien -- ..b ) -- ..b )
buffer bind-buffer :> target
target access gl-access glMapBuffer
target glUnmapBuffer drop ; inline
-:: with-bound-buffer ( buffer target quot: ( -- ) -- )
+:: with-bound-buffer ( ..a buffer target quot: ( ..a -- ..b ) -- ..b )
target gl-target buffer glBindBuffer
quot call ; inline
-: with-buffer-ptr ( buffer-ptr target quot: ( c-ptr -- ) -- )
+: with-buffer-ptr ( ..a buffer-ptr target quot: ( ..a c-ptr -- ..b ) -- ..b )
[ [ offset>> <alien> ] [ buffer>> handle>> ] bi ] 2dip
with-bound-buffer ; inline
-: with-gpu-data-ptr ( gpu-data-ptr target quot: ( c-ptr -- ) -- )
+: with-gpu-data-ptr ( ..a gpu-data-ptr target quot: ( ..a c-ptr -- ..b ) -- ..b )
pick buffer-ptr?
[ with-buffer-ptr ]
[ [ gl-target 0 glBindBuffer ] dip call ] if ; inline
: chats> ( -- seq ) irc> chats>> values ;
: me? ( string -- ? ) irc> nick>> = ;
-: with-irc ( irc-client quot: ( -- ) -- )
+: with-irc ( ..a irc-client quot: ( ..a -- ..b ) -- ..b )
\ current-irc-client swap with-variable ; inline
UNION: to-target privmsg notice ;
c1 c2 c3 c4 columns 4 set-firstn-unsafe
c ; inline
-: make-matrix4 ( quot: ( -- c1 c2 c3 c4 ) -- c )
+: make-matrix4 ( ..a quot: ( ..a -- ..b c1 c2 c3 c4 ) -- ..b c )
matrix4 (struct) swap dip set-columns ; inline
:: 2map-columns ( a b quot -- c )
a4 b4 quot call
] make-matrix4 ; inline
-: map-columns ( a quot -- c )
+: map-columns ( ... a quot: ( ... col -- ... newcol ) -- ... c )
'[ columns _ 4 napply ] make-matrix4 ; inline
PRIVATE>
: rectangles-count ( a b -- n )
2dup [ 1 + ] bi@ * * * 4 /i ; inline
-:: each-unique-product ( a b quot: ( i j -- ) -- )
+:: each-unique-product ( ... a b quot: ( ... i j -- ... ) -- ... )
a b [a,b] [| i |
i b [a,b] [| j |
i j quot call
projects / factor.git / commitdiff