Merge branch 'row-polymorphism' of git://factorcode.org/git/factor into row-polymorphism

basis/binary-search/binary-search.factor

@@ -21,7 +21,7 @@ DEFER: (search)
 : 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
     ] [

basis/circular/circular.factor

@@ -64,7 +64,7 @@ TUPLE: circular-iterator
 
 <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 = [
@@ -75,5 +75,5 @@ TUPLE: circular-iterator
 
 PRIVATE>
 
-: circular-while ( circular quot: ( obj -- ? ) -- )
+: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
     [ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline

basis/cocoa/enumeration/enumeration.factor

@@ -15,7 +15,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
         @
     ] 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
@@ -23,10 +23,10 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
         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
 

basis/compiler/cfg/cfg.factor

@@ -39,7 +39,7 @@ predecessors-valid? dominance-valid? loops-valid? ;
 : 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 ;

basis/compiler/cfg/representations/preferred/preferred.factor

@@ -67,16 +67,16 @@ PRIVATE>
     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 ] [
             [

basis/compiler/cfg/representations/representations.factor

@@ -187,7 +187,7 @@ SYMBOLS: renaming-set needs-renaming? ;
 : 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 ]

basis/compiler/cfg/rpo/rpo.factor

@@ -38,7 +38,7 @@ SYMBOL: visited
     [ 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' )

basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor

@@ -47,7 +47,7 @@ SYMBOLS: visited merge-sets levels again? ;
         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
 
@@ -101,7 +101,7 @@ PRIVATE>
     [ 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

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -27,7 +27,7 @@ IN: compiler.cfg.stacks.finalize
     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 ;

basis/compiler/cfg/tco/tco.factor

@@ -29,7 +29,7 @@ IN: compiler.cfg.tco
 : 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

basis/compiler/cfg/utilities/utilities.factor

@@ -65,14 +65,14 @@ SYMBOL: visited
 : 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
 

basis/compiler/tests/curry.factor

@@ -32,7 +32,7 @@ IN: compiler.tests.curry
     compile-call
 ] unit-test
 
-: foobar ( quot: ( -- ) -- )
+: foobar ( quot: ( ..a -- ..b ) -- )
     [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
 
 [ ] [ [ [ f ] foobar ] compile-call ] unit-test

basis/compiler/tests/optimizer.factor

@@ -198,7 +198,7 @@ USE: sorting
 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>>
     ] [

basis/compiler/tree/combinators/combinators.factor

@@ -5,7 +5,7 @@ arrays stack-checker.inlining namespaces compiler.tree
 math.order ;
 IN: compiler.tree.combinators
 
-: each-node ( nodes quot: ( node -- ) -- )
+: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
     dup dup '[
         _ [
             dup #branch? [
@@ -18,7 +18,7 @@ IN: compiler.tree.combinators
         ] bi
     ] each ; inline recursive
 
-: map-nodes ( nodes quot: ( node -- node' ) -- nodes )
+: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
     dup dup '[
         @
         dup #branch? [
@@ -30,7 +30,7 @@ IN: compiler.tree.combinators
         ] if
     ] map-flat ; inline recursive
 
-: contains-node? ( nodes quot: ( node -- ? ) -- ? )
+: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
     dup dup '[
         _ keep swap [ drop t ] [
             dup #branch? [
@@ -49,7 +49,7 @@ IN: compiler.tree.combinators
 : 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 ;

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -168,7 +168,7 @@ IN: compiler.tree.dead-code.tests
 
 [ ] [ [ [ 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

basis/compiler/tree/escape-analysis/nodes/nodes.factor

@@ -10,7 +10,7 @@ GENERIC: escape-analysis* ( node -- )
 
 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 -- )

basis/compiler/tree/normalization/normalization-tests.factor

@@ -14,7 +14,7 @@ IN: compiler.tree.normalization.tests
 
 [ 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 ;

basis/compiler/tree/propagation/info/info.factor

@@ -31,7 +31,6 @@ class
 interval
 literal
 literal?
-length
 slots ;
 
 CONSTANT: null-info T{ value-info f null empty-interval }
@@ -48,9 +47,7 @@ CONSTANT: object-info T{ value-info f object full-interval }
             { [ over interval-length 0 > ] [ 3drop f f ] }
             { [ pick bignum class<= ] [ 2nip >bignum t ] }
             { [ pick integer class<= ] [ 2nip >fixnum t ] }
-            { [ pick float class<= ] [
+            { [ pick float class<= ] [ 2nip dup zero? [ drop f f ] [ >float t ] if ] }
-                2nip dup zero? [ drop f f ] [ >float t ] if
-            ] }
             [ 3drop f f ]
         } cond
     ] if ;
@@ -74,13 +71,19 @@ UNION: fixed-length array byte-array string ;
         ] unless
     ] unless ;
 
+: (slots-with-length) ( length class -- slots )
+    "slots" word-prop length 1 - f <array> swap prefix ;
+
+: slots-with-length ( seq -- slots )
+    [ length <literal-info> ] [ class ] bi (slots-with-length) ;
+
 : init-literal-info ( info -- info )
     empty-interval >>interval
     dup literal>> literal-class >>class
     dup literal>> {
         { [ dup real? ] [ [a,a] >>interval ] }
         { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
-        { [ dup fixed-length? ] [ length <literal-info> >>length ] }
+        { [ dup fixed-length? ] [ slots-with-length >>slots ] }
         [ drop ]
     } cond ; inline
 
@@ -158,11 +161,11 @@ UNION: fixed-length array byte-array string ;
         t >>literal?
     init-value-info ; foldable
 
-: <sequence-info> ( value -- info )
+: <sequence-info> ( length class -- info )
     <value-info>
-        object >>class
+        over >>class
-        swap value-info >>length
+        [ (slots-with-length) ] dip swap >>slots
-    init-value-info ; foldable
+    init-value-info ;
 
 : <tuple-info> ( slots class -- info )
     <value-info>
@@ -185,13 +188,6 @@ DEFER: value-info-intersect
 
 DEFER: (value-info-intersect)
 
-: intersect-lengths ( info1 info2 -- length )
-    [ length>> ] bi@ {
-        { [ dup not ] [ drop ] }
-        { [ over not ] [ nip ] }
-        [ value-info-intersect ]
-    } cond ;
-
 : intersect-slot ( info1 info2 -- info )
     {
         { [ dup not ] [ nip ] }
@@ -215,7 +211,6 @@ DEFER: (value-info-intersect)
         [ [ class>> ] bi@ class-and >>class ]
         [ [ interval>> ] bi@ interval-intersect >>interval ]
         [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
-        [ intersect-lengths >>length ]
         [ intersect-slots >>slots ]
     } 2cleave
     init-value-info ;
@@ -236,13 +231,6 @@ DEFER: value-info-union
 
 DEFER: (value-info-union)
 
-: union-lengths ( info1 info2 -- length )
-    [ length>> ] bi@ {
-        { [ dup not ] [ nip ] }
-        { [ over not ] [ drop ] }
-        [ value-info-union ]
-    } cond ;
-
 : union-slot ( info1 info2 -- info )
     {
         { [ dup not ] [ nip ] }
@@ -261,7 +249,6 @@ DEFER: (value-info-union)
         [ [ class>> ] bi@ class-or >>class ]
         [ [ interval>> ] bi@ interval-union >>interval ]
         [ union-literals [ >>literal ] [ >>literal? ] bi* ]
-        [ union-lengths >>length ]
         [ union-slots >>slots ]
     } 2cleave
     init-value-info ;
@@ -293,7 +280,6 @@ DEFER: (value-info-union)
                 { [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
                 { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
                 { [ 2dup literals<= not ] [ f ] }
-                { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
                 { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
                 [ t ]
             } cond 2nip

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -45,8 +45,7 @@ IN: compiler.tree.propagation.recursive
             [ clone ] dip
             [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ]
             [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
-            [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
+            bi
-            tri
         ] if
     ] if ;
 

basis/compiler/tree/propagation/slots/slots.factor

@@ -9,8 +9,6 @@ IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
 
-UNION: fixed-length-sequence array byte-array string ;
-
 : sequence-constructor? ( word -- ? )
     { <array> <byte-array> (byte-array) <string> } member-eq? ;
 
@@ -23,9 +21,9 @@ UNION: fixed-length-sequence array byte-array string ;
     } at ;
 
 : propagate-sequence-constructor ( #call word -- infos )
-    [ in-d>> first <sequence-info> ]
+    [ in-d>> first value-info ]
-    [ constructor-output-class <class-info> ]
+    [ constructor-output-class ] bi*
-    bi* value-info-intersect 1array ;
+    <sequence-info> 1array ;
 
 : fold-<tuple-boa> ( values class -- info )
     [ [ literal>> ] map ] dip prefix >tuple
@@ -72,7 +70,6 @@ UNION: fixed-length-sequence array byte-array string ;
 : value-info-slot ( slot info -- info' )
     {
         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
-        { [ 2dup length-accessor? ] [ nip length>> ] }
         { [ dup literal?>> ] [ literal>> literal-info-slot ] }
         [ [ 1 - ] [ slots>> ] bi* ?nth ]
     } cond [ object-info ] unless* ;

basis/compiler/tree/recursive/recursive.factor

@@ -102,7 +102,7 @@ SYMBOL: changed?
         recursive-nesting get pop*
     ] each ;
 
-: while-changing ( quot: ( -- ) -- )
+: while-changing ( ... quot: ( ... -- ... ) -- ... )
     changed? off
     [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
     inline recursive

basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -38,10 +38,10 @@ TUPLE: empty-tuple ;
 } [ [ ] 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

basis/compression/huffman/huffman.factor

@@ -30,7 +30,7 @@ TUPLE: huffman-code
     [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
     [ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
 
-:: huffman-each ( tdesc quot: ( huffman-code -- ) -- )
+:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )
     <huffman-code> :> code
     tdesc
     [

basis/concurrency/mailboxes/mailboxes-docs.factor

@@ -21,7 +21,7 @@ HELP: block-unless-pred
 { $values
     { "mailbox" mailbox }
     { "timeout" "a " { $link duration } " or " { $link f } }
-    { "pred" { $quotation "( obj -- ? )" } } 
+    { "pred" { $quotation "( ... message -- ... ? )" } } 
 }
 { $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." } ;
 

basis/concurrency/mailboxes/mailboxes.factor

@@ -23,7 +23,7 @@ TUPLE: mailbox threads data ;
 : 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

basis/debugger/debugger.factor

@@ -328,6 +328,10 @@ M: lexer-error error-help
 
 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

basis/dlists/dlists.factor

@@ -54,16 +54,16 @@ M: dlist-node node-value obj>> ;
 : 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 -- )
@@ -114,10 +114,10 @@ M: dlist pop-back* ( dlist -- )
     ] 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 -- ? )
@@ -130,7 +130,7 @@ M: dlist delete-node ( dlist-node 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
@@ -141,7 +141,7 @@ M: dlist delete-node ( dlist-node dlist -- )
         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 -- )
@@ -149,7 +149,7 @@ 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 )
@@ -157,7 +157,7 @@ M: dlist clear-deque ( dlist -- )
 
 : 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

basis/documents/documents-docs.factor

@@ -42,7 +42,7 @@ HELP: doc-lines
 { $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." } ;

basis/documents/documents.factor

@@ -55,12 +55,12 @@ TUPLE: document < model locs undos redos inside-undo? ;
     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 )
@@ -109,7 +109,7 @@ CONSTANT: doc-start { 0 0 }
 : 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>

basis/farkup/farkup.factor

@@ -70,7 +70,7 @@ DEFER: (parse-paragraph)
         { 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 )

basis/furnace/auth/auth.factor

@@ -14,6 +14,7 @@ furnace.redirection
 furnace.boilerplate
 furnace.auth.providers
 furnace.auth.providers.db ;
+FROM: assocs => change-at ;
 IN: furnace.auth
 
 SYMBOL: logged-in-user

basis/furnace/scopes/scopes.factor

@@ -2,6 +2,7 @@
 ! 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? ;

basis/help/lint/checks/checks.factor

@@ -36,11 +36,27 @@ SYMBOL: vocab-articles
         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
@@ -73,6 +89,13 @@ SYMBOL: vocab-articles
         ] 
     } 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?

basis/help/lint/lint.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs continuations fry help help.lint.checks
+USING: assocs combinators continuations fry help
-help.topics io kernel namespaces parser sequences
+help.lint.checks help.topics io kernel namespaces parser
-source-files.errors vocabs.hierarchy vocabs words classes
+sequences source-files.errors vocabs.hierarchy vocabs words
-locals tools.errors listener ;
+classes locals tools.errors listener ;
 FROM: help.lint.checks => all-vocabs ;
 FROM: vocabs => child-vocabs ;
 IN: help.lint
@@ -49,10 +49,12 @@ PRIVATE>
     [ with-file-vocabs ] vocabs-quot set
     dup word-help [
         [ >link ] keep '[
-            _ dup word-help
+            _ dup word-help {
                 [ check-values ]
+                [ check-value-effects ]
                 [ check-class-description ]
-            [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
+                [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ]
+            } 2cleave
         ] check-something
     ] [ drop ] if ;
 

basis/io/directories/search/search.factor

@@ -41,7 +41,7 @@ TUPLE: directory-iterator path bfs queue ;
         [ 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*

basis/lists/lists-docs.factor

@@ -127,19 +127,19 @@ HELP: unswons
 { 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

basis/lists/lists.factor

@@ -55,16 +55,16 @@ M: object nil? drop f ;
 
 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
@@ -87,7 +87,7 @@ PRIVATE>
 : 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 )  

basis/math/matrices/elimination/elimination.factor

@@ -11,7 +11,7 @@ SYMBOL: matrix
 
 : 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 ;

basis/math/rectangles/rectangles.factor

@@ -20,7 +20,7 @@ SYNTAX: RECT: scan-object scan-object <rect> suffix! ;
 
 : 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> ;

basis/regexp/minimize/minimize.factor

@@ -3,6 +3,7 @@
 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 )
@@ -51,7 +52,7 @@ IN: regexp.minimize
     <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 =

basis/regexp/regexp.factor

@@ -69,7 +69,7 @@ PRIVATE>
     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)
@@ -80,10 +80,10 @@ PRIVATE>
 
 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 )

basis/sequences/deep/deep-docs.factor

@@ -2,27 +2,27 @@ USING: help.syntax help.markup kernel sequences ;
 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? } ;
 
@@ -31,7 +31,7 @@ HELP: flatten
 { $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! } ;
 

basis/sequences/deep/deep.factor

@@ -12,30 +12,30 @@ M: integer branch? drop f ;
 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 -- ? )
@@ -48,7 +48,7 @@ M: object branch? drop f ;
         _ 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

basis/sequences/parser/parser.factor

@@ -39,7 +39,7 @@ TUPLE: sequence-parser sequence n ;
 : 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
@@ -47,7 +47,7 @@ TUPLE: sequence-parser sequence n ;
 
 : 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
     ] [
@@ -56,7 +56,7 @@ TUPLE: sequence-parser sequence n ;
         [ 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 )

basis/sorting/insertion/insertion.factor

@@ -2,7 +2,7 @@ USING: locals sequences kernel math ;
 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

basis/stack-checker/backend/backend-tests.factor

@@ -8,6 +8,7 @@ IN: stack-checker.backend.tests
     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

basis/stack-checker/backend/backend.factor

@@ -3,9 +3,10 @@
 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 ;
@@ -16,8 +17,13 @@ IN: stack-checker.backend
     [ #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 ;
 
@@ -30,13 +36,17 @@ IN: stack-checker.backend
         [ 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 ;
 
@@ -126,7 +136,7 @@ M: bad-call summary
 : 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
@@ -160,3 +170,27 @@ M: bad-call summary
 
 : (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 ;
+

basis/stack-checker/branches/branches.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry vectors sequences assocs math math.order accessors kernel
+USING: arrays effects fry vectors sequences assocs math math.order accessors kernel
-combinators quotations namespaces grouping stack-checker.state
+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
@@ -45,11 +45,17 @@ SYMBOLS: +bottom+ +top+ ;
 
 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 ;
 
@@ -61,7 +67,9 @@ SYMBOL: quotations
     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* ;
 
@@ -80,7 +88,8 @@ SYMBOL: quotations
 : copy-inference ( -- )
     \ meta-d [ clone ] change
     literals [ clone ] change
-    input-count [ ] change ;
+    input-count [ ] change
+    inner-d-index [ ] change ;
 
 GENERIC: infer-branch ( literal -- namespace )
 
@@ -91,6 +100,9 @@ M: literal infer-branch
         [ value>> quotation set ] [ infer-literal-quot ] bi
     ] H{ } make-assoc ;
 
+M: declared-effect infer-branch
+    known>> infer-branch ;
+
 M: callable infer-branch
     [
         copy-inference
@@ -107,12 +119,26 @@ M: callable infer-branch
     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
+        drop 2 ensure-d
-        dup [ known [ curried? ] [ composed? ] bi or ] any? [
+        declare-if-effects
+        2 shorten-d
+        dup [ known curried/composed? ] any? [
             output-d
             [ rot [ drop call ] [ nip call ] if ]
             infer-quot-here

basis/stack-checker/errors/errors-docs.factor

@@ -63,15 +63,16 @@ HELP: bad-macro-input
 } ;
 
 HELP: unbalanced-branches-error
-{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } }
+{ $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." }
-{ $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." }
 { $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

basis/stack-checker/errors/errors.factor

@@ -10,8 +10,6 @@ ERROR: bad-macro-input < inference-error macro ;
 
 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 ;
@@ -34,9 +32,5 @@ ERROR: transform-expansion-error < inference-error error continuation word ;
 
 ERROR: bad-declaration-error < inference-error declaration ;
 
-ERROR: invalid-quotation-input < inference-error word branches quots ;
+ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ;
-
-ERROR: invalid-effect-variable < inference-error effect ;
-
-ERROR: effect-variable-can't-have-type < inference-error effect ;
 

basis/stack-checker/errors/prettyprint/prettyprint.factor

@@ -10,17 +10,6 @@ M: unknown-macro-input summary
 M: bad-macro-input summary
     macro>> name>> "Cannot apply “" "” to a run-time computed value" surround ;
 
-M: unbalanced-branches-error summary
-    drop "Unbalanced branches" ;
-
-: quots-and-branches. ( quots branches -- )
-    zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
-
-M: unbalanced-branches-error error.
-    dup summary print
-    [ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
-    quots-and-branches. ;
-
 M: too-many->r summary
     drop "Quotation pushes elements on retain stack without popping them" ;
 
@@ -65,16 +54,12 @@ M: transform-expansion-error error.
 M: do-not-compile summary
     word>> name>> "Cannot compile call to " prepend ;
 
-M: invalid-quotation-input summary
+M: unbalanced-branches-error summary
     word>> name>>
     "The input quotations to " " don't match their expected effects" surround ;
 
-M: invalid-quotation-input error.
+M: unbalanced-branches-error error.
     dup summary print
-    [ quots>> ] [ branches>> ] bi quots-and-branches. ;
+    [ quots>> ] [ declareds>> ] [ actuals>> ] tri 3array flip
-
+    { "Input" "Expected" "Got" } prefix simple-table. ;
-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" ;
 

basis/stack-checker/inlining/inlining.factor

@@ -119,9 +119,15 @@ SYMBOL: enter-out
 : 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 -- )
@@ -142,7 +148,7 @@ SYMBOL: enter-out
 : inline-word ( word -- )
     commit-literals
     [ depends-on-definition ]
-    [ infer-polymorphic? get [ check-polymorphic-effect ] [ drop ] if ]
+    [ declare-input-effects ]
     [
         dup inline-recursive-label [
             call-recursive-inline-word

basis/stack-checker/known-words/known-words.factor

@@ -22,7 +22,8 @@ stack-checker.backend
 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 -- )
@@ -98,6 +99,9 @@ M: composed infer-call*
     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 ;
 

basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor

@@ -1,71 +0,0 @@
-! (c)2010 Joe Groff bsd license
-USING: effects fry io kernel math namespaces sequences
-system tools.test
-stack-checker.backend
-stack-checker.errors
-stack-checker.row-polymorphism
-stack-checker.state
-stack-checker.values ;
-IN: stack-checker.row-polymorphism.tests
-
-: infer-polymorphic-quot ( quot -- vars )
-    t infer-polymorphic? [
-        unclip-last [
-            dup current-word set
-            init-inference
-            init-known-values
-            [ [ <literal> <value> [ set-known ] [ push-d ] bi ] each ]
-            [ stack-effect ] bi*
-            infer-polymorphic-vars
-        ] with-scope
-    ] with-variable ;
-
-: test-poly-infer ( effect quot -- )
-    [ '[ _ ] ] [ '[ _ infer-polymorphic-quot ] ] bi* unit-test ; inline
-
-: poly-infer-must-fail ( quot -- )
-    '[ _ infer-polymorphic-quot ] [ invalid-quotation-input? ] must-fail-with ; inline
-: poly-infer-must-fail-unknown ( quot -- )
-    '[ _ infer-polymorphic-quot ] [ unknown-macro-input? ] must-fail-with ; inline
-
-H{ { "." 0 } } [ [ write      ] each ] test-poly-infer
-H{ { "." 1 } } [ [ append     ] each ] test-poly-infer
-H{ { "." 0 } } [ [            ] map  ] test-poly-infer
-H{ { "." 0 } } [ [ reverse    ] map  ] test-poly-infer
-H{ { "." 1 } } [ [ append dup ] map  ] test-poly-infer
-H{ { "." 1 } } [ [ swap nth suffix dup ] map-index ] test-poly-infer
-
-H{ { "a" 3 } { "b" 1 } } [ [ 2drop ] [ 2nip    ] if ] test-poly-infer
-H{ { "a" 2 } { "b" 3 } } [ [ dup   ] [ over    ] if ] test-poly-infer
-H{ { "a" 0 } { "b" 1 } } [ [ os    ] [ cpu     ] if ] test-poly-infer
-H{ { "a" 1 } { "b" 2 } } [ [ os    ] [ 1 + cpu ] if ] test-poly-infer
-
-H{ { "a" 0 } { "b" 0 } } [ [ write     ] [ "(f)" write ] if* ] test-poly-infer
-H{ { "a" 0 } { "b" 1 } } [ [           ] [ f           ] if* ] test-poly-infer
-H{ { "a" 1 } { "b" 1 } } [ [ nip       ] [ drop f      ] if* ] test-poly-infer
-H{ { "a" 1 } { "b" 1 } } [ [ nip       ] [             ] if* ] test-poly-infer
-H{ { "a" 2 } { "b" 2 } } [ [ 3append f ] [             ] if* ] test-poly-infer
-H{ { "a" 0 } { "b" 0 } } [ [ drop      ] [             ] if* ] test-poly-infer
-
-[ [ write write ] each      ] poly-infer-must-fail
-[ [             ] each      ] poly-infer-must-fail
-[ [ dup         ] map       ] poly-infer-must-fail
-[ [ drop        ] map       ] poly-infer-must-fail
-[ [ 1 +         ] map-index ] poly-infer-must-fail
-
-[ [ dup  ] [      ] if ] poly-infer-must-fail
-[ [ 2dup ] [ over ] if ] poly-infer-must-fail
-[ [ drop ] [      ] if ] poly-infer-must-fail
-
-[ [      ] [       ] if* ] poly-infer-must-fail
-[ [ dup  ] [       ] if* ] poly-infer-must-fail
-[ [ drop ] [ drop  ] if* ] poly-infer-must-fail
-[ [      ] [ drop  ] if* ] poly-infer-must-fail
-[ [      ] [ 2dup  ] if* ] poly-infer-must-fail
-
-[ "derp" each ] poly-infer-must-fail
-[ each ] poly-infer-must-fail-unknown
-[ "derp" [ "derp" ] if ] poly-infer-must-fail
-[ [ "derp" ] "derp" if ] poly-infer-must-fail
-[ [ "derp" ] if ] poly-infer-must-fail-unknown
-

basis/stack-checker/row-polymorphism/row-polymorphism.factor

@@ -1,6 +1,6 @@
 ! (c)2010 Joe Groff bsd license
 USING: accessors arrays assocs combinators combinators.short-circuit
-continuations effects fry kernel locals math namespaces
+continuations effects fry kernel locals math math.order namespaces
 quotations sequences splitting
 stack-checker.backend
 stack-checker.errors
@@ -10,91 +10,63 @@ stack-checker.values
 stack-checker.visitor ;
 IN: stack-checker.row-polymorphism
 
-<PRIVATE
+:: with-inner-d ( quot -- inner-d )
-SYMBOLS: current-effect-variables current-word-effect current-meta-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
 
-: quotation-effect? ( in -- ? )
+:: with-effect-here ( quot -- effect )
-    dup pair? [ second effect? ] [ drop f ] if ;
+    input-count get :> old-input-count
+    meta-d length :> old-meta-d-length
 
-SYMBOL: (unknown)
+    quot with-inner-d :> inner-d
         
-GENERIC: >error-quot ( known -- quot )
+    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
 
-M: object >error-quot drop (unknown) ;
+:: check-variable ( actual-count declared-count variable vars -- difference ? )
-M: literal >error-quot value>> ;
-M: composed >error-quot
-    [ quot1>> known >error-quot ] [ quot2>> known >error-quot ] bi
-    \ compose [ ] 3sequence ;
-M: curried >error-quot
-    [ obj>> known >error-quot ] [ quot>> known >error-quot ] bi
-    \ curry [ ] 3sequence ;
-
-: >error-branches-and-quots ( branch/values -- branches quots )
-    [ [ second ] [ known >error-quot ] bi* ] assoc-map unzip ;
-
-: abandon-check ( -- * )
-    current-word get
-    current-word-effect get in>> current-meta-d get zip
-    [ first quotation-effect? ] filter
-    >error-branches-and-quots
-    invalid-quotation-input ;
-
-:: check-variable ( actual-count declared-count variable -- difference )
     actual-count declared-count -
     variable [
-        variable current-effect-variables get at* nip
+        variable vars at* nip
-        [ variable current-effect-variables get at -     ]
+        [ variable vars at -     ]
-        [ variable current-effect-variables get set-at 0 ] if
+        [ variable vars set-at 0 ] if
-    ] [
+        t
-        dup [ abandon-check ] unless-zero
+    ] [ dup 0 <= ] if ;
-    ] if ;
 
-: adjust-variable ( diff var -- )
+: adjust-variable ( diff var vars -- )
-    over 0 >=
+    pick 0 >=
-    [ current-effect-variables get at+ ]
+    [ at+ ]
-    [ 2drop ] if ; inline
+    [ 3drop ] if ; inline
 
-:: (check-input) ( declared actual -- )
+:: check-variables ( vars declared actual -- ? )
+    actual terminated?>> [ t ] [
         actual declared [ in>>  length ] bi@ declared in-var>>
-        [ check-variable ] keep :> ( in-diff in-var ) 
+            [ vars check-variable ] keep :> ( in-diff in-ok? in-var ) 
         actual declared [ out>> length ] bi@ declared out-var>>
-        [ check-variable ] keep :> ( out-diff out-var )
+            [ vars check-variable ] keep :> ( out-diff out-ok? out-var )
-    { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
+        { [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&&
-    [
+        dup [
-        in-var  [ in-diff  swap adjust-variable ] when*
+            in-var  [ in-diff  swap vars adjust-variable ] when*
-        out-var [ out-diff swap adjust-variable ] when*
+            out-var [ out-diff swap vars adjust-variable ] when*
-    ] [
+        ] when
-        abandon-check
     ] if ;
 
-: infer-value ( value -- effect )
+: complex-unbalanced-branches-error ( known -- * )
-    dup known [ nest-visitor init-inference infer-call* current-effect ] with-scope ; inline
+    [ word>> ] [
+        branches>> <reversed>
+        [ [ known>callable ] { } map-as ]
+        [ [ effect>> ] { } map-as ]
+        [ [ actual>> ] { } map-as ] tri
+    ] bi unbalanced-branches-error ;
 
-: check-input ( in value -- )
+: check-declared-effect ( known effect -- )
-    over quotation-effect? [
+    [ >>actual ] keep
-        [ second ] dip infer-value (check-input)
+    2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
-    ] [ 2drop ] if ;
+    [ 2drop ] [ drop complex-unbalanced-branches-error ] if ;
 
-: normalize-variables ( -- variables' )
-    current-effect-variables get dup values [
-        infimum dup 0 <
-        [ '[ _ - ] assoc-map ] [ drop ] if
-    ] unless-empty ;
-
-PRIVATE>
-
-: infer-polymorphic-vars ( effect -- variables )
-    H{ } clone current-effect-variables set
-    dup current-word-effect set
-    in>> dup length ensure-d dup current-meta-d set
-    [ check-input ] 2each
-    normalize-variables ;
-
-: check-polymorphic-effect ( word -- )
-    current-word get [
-        dup current-word set stack-effect
-        dup { [ in-var>> ] [ out-var>> ] } 1||
-        [ infer-polymorphic-vars ] when drop
-    ] dip current-word set ;
-
-SYMBOL: infer-polymorphic?

basis/stack-checker/stack-checker-docs.factor

@@ -27,6 +27,8 @@ ARTICLE: "inference-combinators" "Combinator stack effects"
   { "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 } ":"

basis/stack-checker/stack-checker-tests.factor

@@ -234,10 +234,12 @@ DEFER: blah4
 
 ! 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
 
@@ -378,7 +380,10 @@ DEFER: eee'
 
 [ [ 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
 
@@ -402,3 +407,64 @@ DEFER: eee'
     [ "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
+

basis/stack-checker/state/state.factor

@@ -11,6 +11,7 @@ SYMBOL: terminated?
 
 ! Number of inputs current word expects from the stack
 SYMBOL: input-count
+SYMBOL: inner-d-index
 
 DEFER: commit-literals
 
@@ -46,4 +47,5 @@ SYMBOL: literals
     terminated? off
     V{ } clone \ meta-d set
     V{ } clone literals set
-    0 input-count set ;
+    0 input-count set
+    0 inner-d-index set ;

basis/stack-checker/transforms/transforms.factor

@@ -18,7 +18,7 @@ IN: stack-checker.transforms
 
 :: ((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? ;

basis/stack-checker/values/values.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel assocs sequences
+USING: accessors namespaces fry kernel assocs sequences
-stack-checker.recursive-state stack-checker.errors ;
+stack-checker.recursive-state stack-checker.errors
+quotations ;
 IN: stack-checker.values
 
 ! Values
@@ -97,9 +98,41 @@ M: input-parameter (literal-value?) drop f ;
 
 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 ;
+
+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 ;
+

basis/tools/disassembler/udis/udis.factor

@@ -103,7 +103,7 @@ FUNCTION: c-string ud_lookup_mnemonic ( int c ) ;
     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

basis/windows/ddk/hid/tags.txt

@@ -1 +1 @@
-unportable bindings
+bindings

basis/windows/ddk/setupapi/tags.txt

@@ -1 +1 @@
-unportable bindings
+bindings

basis/windows/ddk/winusb/tags.txt

@@ -1 +1 @@
-unportable bindings
+bindings

basis/xml/syntax/syntax.factor

@@ -44,7 +44,7 @@ SYNTAX: XML-NS:
 : 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 ] }

basis/xml/tokenize/tokenize.factor

@@ -59,14 +59,14 @@ HINTS: next* { spot } ;
     ! 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 )

core/alien/alien-docs.factor

@@ -71,7 +71,7 @@ HELP: alien-invoke-error
 } ;
 
 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." } ;
@@ -85,7 +85,7 @@ HELP: alien-indirect-error
 } ;
 
 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."
 }
@@ -128,7 +128,7 @@ HELP: alien-assembly-error
 } ;
 
 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."
 }

core/alien/alien.factor

@@ -70,17 +70,17 @@ ERROR: alien-callback-error ;
 
 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

core/assocs/assocs.factor

@@ -44,7 +44,7 @@ M: assoc assoc-like drop ; inline
 : 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>

core/bootstrap/primitives.factor

@@ -420,7 +420,7 @@ tuple
     { "(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 )) }

core/classes/tuple/tuple-docs.factor

@@ -421,8 +421,8 @@ HELP: <tuple> ( layout -- tuple )
 { $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 )
+HELP: <tuple-boa> ( slots... layout -- tuple )
-{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" 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
@@ -439,7 +439,7 @@ 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" } ")." } ;

core/combinators/combinators-docs.factor

@@ -295,7 +295,7 @@ HELP: spread
 { 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

core/combinators/combinators.factor

@@ -193,5 +193,5 @@ M: hashtable hashcode*
         [ 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

core/continuations/continuations-docs.factor

@@ -182,7 +182,7 @@ HELP: cleanup
 { $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

core/continuations/continuations.factor

@@ -119,7 +119,7 @@ SYMBOL: thread-error-hook
     ] 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 -- )
@@ -130,7 +130,7 @@ SYMBOL: thread-error-hook
 
 ERROR: attempt-all-error ;
 
-: attempt-all ( seq quot -- obj )
+: attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
     over empty? [
         attempt-all-error
     ] [

core/effects/effects-docs.factor

@@ -1,4 +1,4 @@
-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"
@@ -6,11 +6,9 @@ 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."
+"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
-"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. 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
@@ -29,9 +27,82 @@ $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

core/generic/math/math.factor

@@ -74,7 +74,7 @@ PRIVATE>
 
 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
 
@@ -93,7 +93,7 @@ SYMBOL: generic-word
 : 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

core/io/io.factor

@@ -87,7 +87,7 @@ SYMBOL: error-stream
 
 : 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

core/kernel/kernel-docs.factor

@@ -169,7 +169,7 @@ HELP: xor
 { $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
 
 HELP: both?
-{ $values { "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" }
@@ -177,7 +177,7 @@ HELP: both?
 } ;
 
 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" }
@@ -214,22 +214,22 @@ HELP: call-clear ( quot -- * )
 { $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:"
@@ -595,7 +595,7 @@ $nl
 "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."
@@ -618,7 +618,7 @@ HELP: unless*
 { $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:"
@@ -771,15 +771,15 @@ HELP: 4dip
 } ;
 
 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

core/kernel/kernel.factor

@@ -177,10 +177,10 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
 : 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
@@ -226,7 +226,7 @@ M: callstack clone (clone) ; inline
 ! 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

core/lexer/lexer-docs.factor

@@ -67,13 +67,13 @@ HELP: still-parsing?
 { $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 ;
 

core/lexer/lexer.factor

@@ -100,10 +100,10 @@ PREDICATE: unexpected-eof < unexpected
 : (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 )

core/math/math-docs.factor

@@ -410,22 +410,22 @@ HELP: power-of-2?
 { $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 } "." } ;
 

core/sequences/sequences-docs.factor

@@ -253,15 +253,15 @@ HELP: set-array-nth
 { $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" }
@@ -269,7 +269,7 @@ HELP: reduce
 
 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 ."
@@ -277,7 +277,7 @@ HELP: 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."
@@ -285,7 +285,7 @@ $nl
 "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."
@@ -296,7 +296,7 @@ $nl
 } ;
 
 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."
@@ -307,11 +307,11 @@ $nl
 } ;
 
 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:"
@@ -321,7 +321,7 @@ HELP: map-as
 
 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"
@@ -330,7 +330,7 @@ HELP: 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 ."
@@ -338,13 +338,13 @@ HELP: 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" } ;
@@ -358,44 +358,44 @@ HELP: max-length
 { $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." } ;
@@ -403,51 +403,51 @@ HELP: find
 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" } ;
 
@@ -622,7 +622,7 @@ HELP: reverse!
 { $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
@@ -961,7 +961,7 @@ HELP: supremum
 { $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:"
@@ -971,7 +971,7 @@ HELP: produce
 } ;
 
 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." } ;
 
@@ -995,8 +995,8 @@ HELP: count
 
 HELP: selector
 { $values
-     { "quot" { $quotation "( elt -- ? )" } }
+     { "quot" { $quotation "( ... elt -- ... ? )" } }
-     { "selector" { $quotation "( elt -- )" } } { "accum" vector } }
+     { "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 ."
@@ -1140,7 +1140,7 @@ HELP: set-fourth
 
 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 
@@ -1152,7 +1152,7 @@ HELP: replicate
 
 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 
@@ -1190,7 +1190,7 @@ HELP: virtual@
 
 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." }
@@ -1236,7 +1236,7 @@ HELP: collector
 
 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:"
@@ -1247,7 +1247,7 @@ HELP: binary-reduce
 
 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:"
@@ -1365,11 +1365,11 @@ HELP: assert-sequence=
 } ;
 
 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

core/sequences/sequences.factor

@@ -417,19 +417,19 @@ PRIVATE>
 : map-integers ( len quot exemplar -- newseq )
     [ over ] dip [ [ collect ] keep ] new-like ; inline
 
-: map-as ( ... seq quot: ( ... x -- ... newx ) exemplar -- ... newseq )
+: map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
     [ (each) ] dip map-integers ; inline
 
-: map ( ... seq quot: ( ... x -- ... newx ) -- ... newseq )
+: map ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
     over map-as ; inline
 
-: replicate-as ( ... len quot: ( ... -- ... newx ) exemplar -- ... newseq )
+: replicate-as ( ... len quot: ( ... -- ... newelt ) exemplar -- ... newseq )
     [ [ drop ] prepose ] dip map-integers ; inline
 
-: replicate ( ... len quot: ( ... -- ... newx ) -- ... newseq )
+: replicate ( ... len quot: ( ... -- ... newelt ) -- ... newseq )
     { } replicate-as ; inline
 
-: map! ( ... seq quot: ( ... x -- ... x' ) -- ... seq )
+: map! ( ... seq quot: ( ... elt -- ... newelt ) -- ... seq )
     over [ map-into ] keep ; inline
 
 : accumulate-as ( ... seq identity quot: ( ... prev elt -- ... next ) exemplar -- ... final newseq )
@@ -441,31 +441,31 @@ PRIVATE>
 : accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
     (accumulate) map! ; inline
 
-: 2each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
+: 2each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
     (2each) each-integer ; inline
 
-: 2reverse-each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
+: 2reverse-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
     [ [ <reversed> ] bi@ ] dip 2each ; inline
 
 : 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
     [ -rot ] dip 2each ; inline
 
-: 2map-as ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) exemplar -- ... newseq )
+: 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq )
     [ (2each) ] dip map-integers ; inline
 
-: 2map ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) -- ... newseq )
+: 2map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
     pick 2map-as ; inline
 
 : 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
     (2each) all-integers? ; inline
 
-: 3each ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... ) -- ... )
+: 3each ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) -- ... )
     (3each) each-integer ; inline
 
-: 3map-as ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) exemplar -- ... newseq )
+: 3map-as ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) exemplar -- ... newseq )
     [ (3each) ] dip map-integers ; inline
 
-: 3map ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) -- ... newseq )
+: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq )
     [ pick ] dip swap 3map-as ; inline
 
 : find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
@@ -483,7 +483,7 @@ PRIVATE>
 : all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
     (each) all-integers? ; inline
 
-: push-if ( ... elt quot: ( ... elt -- ... ? ) accum -- ... )
+: push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b )
     [ keep ] dip rot [ push ] [ 2drop ] if ; inline
 
 : selector-for ( quot exemplar -- selector accum )
@@ -498,7 +498,7 @@ PRIVATE>
 : filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
     over filter-as ; inline
 
-: push-either ( ... elt quot: ( ... elt -- ... ? ) accum1 accum2 -- ... )
+: push-either ( ..a elt quot: ( ..a elt -- ..b ? ) accum1 accum2 -- ..b )
     [ keep swap ] 2dip ? push ; inline
 
 : 2selector ( quot -- selector accum1 accum2 )
@@ -513,16 +513,16 @@ PRIVATE>
 : collector ( quot -- quot' vec )
     V{ } collector-for ; inline
 
-: produce-as ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) 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: ( ... -- ... obj ) -- ... seq )
+: produce ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) -- ..b seq )
     { } produce-as ; inline
 
 : follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq )
     [ dup ] swap [ keep ] curry produce nip ; inline
 
-: each-index ( ... seq quot: ( ... x i -- ... ) -- ... )
+: each-index ( ... seq quot: ( ... elt index -- ... ) -- ... )
     (each-index) each-integer ; inline
 
 : interleave ( seq between quot -- )
@@ -532,10 +532,10 @@ PRIVATE>
         3bi
     ] if ; inline
 
-: map-index ( ... seq quot: ( ... x i -- ... newx ) -- ... newseq )
+: map-index ( ... seq quot: ( ... elt index -- ... newelt ) -- ... newseq )
     [ dup length iota ] dip 2map ; inline
 
-: reduce-index ( ... seq identity quot: ( ... prev x i -- ... next ) -- ... result )
+: reduce-index ( ... seq identity quot: ( ... prev elt index -- ... next ) -- ... result )
     swapd each-index ; inline
 
 : index ( obj seq -- n )
@@ -877,7 +877,7 @@ PRIVATE>
     [ [ unclip-slice ] dip [ call ] keep ] dip
     compose reduce ; inline
 
-: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a x1 x2 -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a 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
 
@@ -889,10 +889,10 @@ PRIVATE>
 
 PRIVATE>
 
-: map-find ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
+: map-find ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt )
     [ find ] (map-find) ; inline
 
-: map-find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
+: map-find-last ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt )
     [ find-last ] (map-find) ; inline
 
 : unclip-last-slice ( seq -- butlast-slice last )

core/splitting/splitting.factor

@@ -61,7 +61,7 @@ PRIVATE>
     [ 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>
 

extra/astar/astar-docs.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: astar
+
+HELP: astar
+{ $description "This tuple must be subclassed and its method " { $link cost } ", "
+  { $link heuristic } ", and " { $link neighbours } " must be implemented. "
+  "Alternatively, the " { $link <astar> } " word can be used to build a non-specialized version." } ;
+
+HELP: cost
+{ $values
+  { "from" "a node" }
+  { "to" "a node" }
+  { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+  { "n" "a number" }
+}
+{ $description "Return the cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
+  { $snippet "to" } " is necessarily a neighbour of " { $snippet "from" } "."
+} ;
+
+HELP: heuristic
+{ $values
+  { "from" "a node" }
+  { "to" "a node" }
+  { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+  { "n" "a number" }
+}
+{ $description "Return the estimated (undervalued) cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
+  { $snippet "from" } " and " { $snippet "to" } " are not necessarily neighbours."
+} ;
+
+HELP: neighbours
+{ $values
+  { "node" "a node" }
+  { "astar" "an instance of a subclassed " { $link astar } " tuple" }
+  { "seq" "a sequence of nodes" }
+}
+{ $description "Return the list of nodes reachable from " { $snippet "node" } "." } ;
+
+HELP: <astar>
+{ $values
+  { "neighbours" "a quotation with stack effect ( node -- seq )" }
+  { "cost" "a quotation with stack effect ( from to -- cost )" }
+  { "heuristic" "a quotation with stack effect ( pos target -- cost )" }
+  { "astar" "a astar tuple" }
+}
+{ $description "Build an astar object from the given quotations. The "
+  { $snippet "neighbours" } " one builds the list of neighbours. The "
+  { $snippet "cost" } " and " { $snippet "heuristic" } " ones represent "
+  "respectively the cost for transitioning from a node to one of its neighbour, "
+  "and the underestimated cost for going from a node to the target. This solution "
+  "may not be as efficient as subclassing the " { $link astar } " tuple."
+} ;
+
+HELP: find-path
+{ $values
+  { "start" "a node" }
+  { "target" "a node" }
+  { "astar" "a astar tuple" }
+  { "path/f" "an optimal path from " { $snippet "start" } " to " { $snippet "target" }
+    ", or f if no such path exists" }
+}
+{ $description "Find a path between " { $snippet "start" } " and " { $snippet "target" }
+  " using the A* algorithm. The " { $snippet "astar" } " tuple must have been previously "
+  " built using " { $link <astar> } "."
+} ;
+
+HELP: considered
+{ $values
+  { "astar" "a astar tuple" }
+  { "considered" "a sequence" }
+}
+{ $description "When called after a call to " { $link find-path } ", return a list of nodes "
+  "which have been examined during the A* exploration."
+} ;

extra/astar/astar-tests.factor

@@ -0,0 +1,109 @@
+! Copyright (C) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs astar combinators hashtables kernel literals math math.functions
+math.vectors sequences sorting splitting strings tools.test ;
+IN: astar.tests
+
+<<
+
+! Use a 10x9 maze (see below) to try to go from s to e, f or g.
+! X means that a position is unreachable.
+! The costs model is:
+!   - going up costs 5 points
+!   - going down costs 1 point
+!   - going left or right costs 2 points
+
+: reachable? ( pos -- ? )
+    first2 [ 2 * 5 + ] [ 2 + ] bi* $[
+"    0 1 2 3 4 5 6 7 8 9
+
+  0  X X X X X X X X X X
+  1  X s           f X X
+  2  X X X X   X X X X X
+  3  X X X X   X X X X X
+  4  X X X X   X       X
+  5  X X       X   X   X
+  6  X X X X   X   X e X
+  7  X g   X           X
+  8  X X X X X X X X X X"
+        "\n" split ] nth nth CHAR: X = not ;
+
+: neighbours ( pos -- neighbours )
+     first2
+     { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
+     4array
+     [ reachable? ] filter ;
+
+: heuristic ( from to -- cost )
+    v- [ abs ] [ + ] map-reduce ;
+
+: cost ( from to -- cost )
+    2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
+
+: test1 ( to -- path considered )
+    { 1 1 } swap [ neighbours ] [ cost ] [ heuristic ] <astar> [ find-path ] [ considered ] bi ;
+>>
+
+! Existing path from s to f
+[
+    {
+        { 1 1 }
+        { 2 1 }
+        { 3 1 }
+        { 4 1 }
+        { 4 2 }
+        { 4 3 }
+        { 4 4 }
+        { 4 5 }
+        { 4 6 }
+        { 4 7 }
+        { 5 7 }
+        { 6 7 }
+        { 7 7 }
+        { 8 7 }
+        { 8 6 }
+    }
+] [
+    { 8 6 } test1 drop
+] unit-test
+
+! Check that only the right positions have been considered in the s to f path
+[ 7 ] [ { 7 1 } test1 nip length ] unit-test
+
+! Non-existing path from s to g -- all positions must have been considered
+[ f 26 ] [ { 1 7 } test1 length ] unit-test
+
+<<
+
+! Look for a path between A and C. The best path is A --> D --> C. C will be placed
+! in the open set early because B will be examined first. This checks that the evaluation
+! of C is correctly replaced in the open set.
+!
+! We use no heuristic here and always return 0.
+!
+!       (5)
+!     B ---> C <--------
+!                        \ (2)
+!     ^      ^            |
+!     |      |            |
+! (1) |      | (2)        |
+!     |      |            |
+!
+!     A ---> D ---------> E ---> F
+!       (2)       (1)       (1)
+
+: n ( pos -- neighbours )
+    $[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ;
+
+: c ( from to -- cost )
+    "" 2sequence H{ { "AB" 1 } { "AD" 2 } { "BC" 5 } { "DC" 2 } { "DE" 1 } { "EC" 2 } { "EF" 1 } } at ;
+
+: test2 ( fromto -- path considered )
+    first2 [ n ] [ c ] [ 2drop 0 ] <astar> [ find-path ] [ considered natural-sort >string ] bi ;
+>>
+
+! Check path from A to C -- all nodes but F must have been examined
+[ "ADC" "ABCDE" ] [ "AC" test2 [ >string ] dip ] unit-test
+
+! No path from D to B -- all nodes reachable from D must have been examined
+[ f "CDEF" ] [ "DB" test2 ] unit-test

extra/astar/astar.factor

@@ -0,0 +1,81 @@
+! Copyright (C) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs heaps kernel math sequences sets shuffle ;
+IN: astar
+
+! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A*
+
+TUPLE: astar g in-closed-set ;
+GENERIC: cost ( from to astar -- n )
+GENERIC: heuristic ( from to astar -- n )
+GENERIC: neighbours ( node astar -- seq )
+
+<PRIVATE
+
+TUPLE: (astar) astar goal origin in-open-set open-set ;
+
+: (add-to-open-set) ( h node astar -- )
+    2dup in-open-set>> at* [ over open-set>> heap-delete ] [ drop ] if
+    [ swapd open-set>> heap-push* ] [ in-open-set>> set-at ] 2bi ;
+
+: add-to-open-set ( node astar -- )
+    [ astar>> g>> at ] 2keep
+    [ [ goal>> ] [ astar>> heuristic ] bi + ] 2keep
+    (add-to-open-set) ;
+
+: ?add-to-open-set ( node astar -- )
+    2dup astar>> in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ;
+
+: move-to-closed-set ( node astar -- )
+    [ astar>> in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ;
+
+: get-first ( astar -- node )
+    [ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ;
+
+: set-g ( origin g node astar -- )
+    [ [ origin>> set-at ] [ astar>> g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ;
+
+: cost-through ( origin node astar -- cost )
+    [ astar>> cost ] [ nip astar>> g>> at ] 3bi + ;
+
+: ?set-g ( origin node astar -- )
+    [ cost-through ] 3keep [ swap ] 2dip
+    3dup astar>> g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ;
+
+: build-path ( target astar -- path )
+    [ over ] [ over [ [ origin>> at ] keep ] dip ] produce 2nip reverse ;
+
+: handle ( node astar -- )
+    dupd [ astar>> neighbours ] keep [ ?set-g ] curry with each ;
+
+: (find-path) ( astar -- path/f )
+    dup open-set>> heap-empty? [
+        drop f
+    ] [
+        [ get-first ] keep 2dup goal>> = [ build-path ] [ [ handle ] [ (find-path) ] bi ] if
+    ] if ;
+
+: (init) ( from to astar -- )
+    swap >>goal
+    H{ } clone over astar>> (>>g)
+    H{ } clone over astar>> (>>in-closed-set)
+    H{ } clone >>origin
+    H{ } clone >>in-open-set
+    <min-heap> >>open-set
+    [ 0 ] 2dip [ (add-to-open-set) ] [ astar>> g>> set-at ] 3bi ;
+
+TUPLE: astar-simple < astar cost heuristic neighbours ;
+M: astar-simple cost cost>> call( n1 n2 -- c ) ;
+M: astar-simple heuristic heuristic>> call( n1 n2 -- c ) ;
+M: astar-simple neighbours neighbours>> call( n -- neighbours ) ;
+
+PRIVATE>
+
+: find-path ( start target astar -- path/f )
+    (astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ;
+
+: <astar> ( neighbours cost heuristic -- astar )
+    astar-simple new swap >>heuristic swap >>cost swap >>neighbours ;
+
+: considered ( astar -- considered )
+    in-closed-set>> keys ;

extra/astar/authors.txt

@@ -0,0 +1 @@
+Samuel Tardieu

extra/astar/summary.txt

@@ -0,0 +1 @@
+A* path-finding algorithm

extra/bank/bank.factor

@@ -54,7 +54,7 @@ C: <transaction> transaction
 : 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
     ] [

extra/benchmark/nbody-simd/nbody-simd.factor

@@ -58,7 +58,7 @@ SPECIALIZED-ARRAY: body
     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 [

extra/benchmark/nbody/nbody.factor

@@ -58,7 +58,7 @@ TUPLE: nbody-system { bodies array read-only } ;
     [ <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 [

extra/bson/writer/writer.factor

@@ -32,22 +32,22 @@ PRIVATE>
 : 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

extra/fuel/fuel.factor

@@ -55,14 +55,14 @@ SYMBOL: :uses-suggestions
 
 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 -- )

extra/gpu/buffers/buffers-docs.factor

@@ -203,7 +203,7 @@ HELP: vertex-buffer
 
 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." } ;
 

extra/gpu/buffers/buffers.factor

@@ -132,7 +132,7 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size
     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
 
@@ -140,15 +140,15 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size
 
     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

extra/irc/client/base/base.factor

@@ -14,7 +14,7 @@ SYMBOL: current-irc-client
 : 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 ;

extra/math/matrices/simd/simd.factor

@@ -28,7 +28,7 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
     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 )
@@ -42,7 +42,7 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
         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>