From: Joe Groff Date: Tue, 9 Mar 2010 07:38:10 +0000 (-0800) Subject: generalize stack effects so we can bootstrap with the stricter stack effect checking X-Git-Tag: 0.97~4767^2~11 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=191ac353fd62d886b5e0ad1e2100444e092a85d3 generalize stack effects so we can bootstrap with the stricter stack effect checking --- diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor index 89a300202a..83bf9f13f4 100644 --- a/basis/binary-search/binary-search.factor +++ b/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 ] [ diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index ccb70c617f..0e1fe47fbb 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -64,7 +64,7 @@ TUPLE: circular-iterator > ] [ 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 [ ] dip (circular-while) ; inline diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index c7bdf625d9..f4d1053f0a 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/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 ] [ 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 [ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 5d815e3b0f..79f3b0d1fb 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/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 ; diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index 726521cfe1..9ba78dbf46 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/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 ] [ [ diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor index 005fe8c90b..b14390e980 100644 --- a/basis/compiler/cfg/representations/representations.factor +++ b/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 ] diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index b6322730ee..b569327c83 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -38,8 +38,8 @@ 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' ) - dup post-order drop ; \ No newline at end of file + dup post-order drop ; diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor index 4b459e90fb..837b41e47f 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor +++ b/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 diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index f1f7880c90..ad3453704b 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/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 ; diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor index 810b901013..bd8a7cf754 100644 --- a/basis/compiler/cfg/tco/tco.factor +++ b/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 @@ -65,4 +65,4 @@ IN: compiler.cfg.tco : optimize-tail-calls ( cfg -- cfg' ) dup [ optimize-tail-call ] each-basic-block - cfg-changed predecessors-changed ; \ No newline at end of file + cfg-changed predecessors-changed ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 3710f4974b..bee2226ec4 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/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 diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 1fffa06336..69c48c5f94 100644 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/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 ; diff --git a/basis/compiler/tree/escape-analysis/nodes/nodes.factor b/basis/compiler/tree/escape-analysis/nodes/nodes.factor index 3451750a34..4c9dc1ade7 100644 --- a/basis/compiler/tree/escape-analysis/nodes/nodes.factor +++ b/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 -- ) diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index bc6243e138..af76cda903 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/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 diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 9922048009..0c3db04993 100644 --- a/basis/compression/huffman/huffman.factor +++ b/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 -- ... ) -- ... ) :> code tdesc [ diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 221a5a1fa3..e245f93bd5 100644 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/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 diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 317ed81e3e..44140d3109 100644 --- a/basis/dlists/dlists.factor +++ b/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 ) [ 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 diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index dcd1bf5820..e84a993eea 100644 --- a/basis/documents/documents.factor +++ b/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> diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 29adcd47d6..bef9261468 100644 --- a/basis/lists/lists.factor +++ b/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: ( ... obj1 obj2 -- ... obj ) -- ... result ) swapd leach ; inline -:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) +:: foldr ( ... list identity quot: ( ... obj1 obj2 -- ... obj ) -- ... result ) list nil? [ identity ] [ list cdr identity quot foldr list car quot call @@ -87,7 +87,7 @@ PRIVATE> : sequence>list ( sequence -- list ) nil [ swons ] reduce ; -: lmap>array ( list quot -- array ) +: lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array ) collector [ leach ] dip { } like ; inline : list>array ( list -- array ) diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index bfde391884..db3794cbb0 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -20,7 +20,7 @@ SYNTAX: RECT: scan-object scan-object 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 : ( loc ext -- rect ) over [v-] ; diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 0b387acd2a..e5ac1df151 100644 --- a/basis/regexp/regexp.factor +++ b/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 ) diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor index c79d0b2002..6238962b6c 100644 --- a/basis/sequences/deep/deep.factor +++ b/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 diff --git a/basis/sequences/parser/parser.factor b/basis/sequences/parser/parser.factor index 44fa75239c..322d4cf488 100644 --- a/basis/sequences/parser/parser.factor +++ b/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 : ( from to seq -- slice/f ) diff --git a/basis/sorting/insertion/insertion.factor b/basis/sorting/insertion/insertion.factor index b7fefcad63..577d2f0b67 100644 --- a/basis/sorting/insertion/insertion.factor +++ b/basis/sorting/insertion/insertion.factor @@ -2,7 +2,7 @@ USING: locals sequences kernel math ; IN: sorting.insertion = [ n n 1 - seq exchange diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 7829f933aa..1e7ae5a9f3 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -136,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 diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index ae8827e093..5e46a34682 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/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 ) [ [ [ ] dip call ] with-destructors ] with-code-blocks ; inline SINGLETON: udis-disassembler diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index e8ed1637e6..b0509b27cb 100644 --- a/core/assocs/assocs.factor +++ b/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> diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 7b9481825b..d14564f7b2 100644 --- a/core/combinators/combinators.factor +++ b/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 diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 297684014b..277f40c34f 100644 --- a/core/generic/math/math.factor +++ b/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 diff --git a/extra/gpu/buffers/buffers.factor b/extra/gpu/buffers/buffers.factor index bc6f089db9..1f764cdfec 100644 --- a/extra/gpu/buffers/buffers.factor +++ b/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>> ] [ 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 diff --git a/extra/math/matrices/simd/simd.factor b/extra/math/matrices/simd/simd.factor index 01d831d6b0..26ad8bb4d7 100644 --- a/extra/math/matrices/simd/simd.factor +++ b/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>