: keep-searching ( seq quot -- slice )
[ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
-: (search) ( quot: ( elt -- <=> ) seq -- i elt )
+: (search) ( ... quot: ( ... elt -- ... <=> ) seq -- ... i elt )
dup length 1 <= [
finish
] [
<PRIVATE
-: (circular-while) ( iterator quot: ( obj -- ? ) -- )
+: (circular-while) ( ... iterator quot: ( ... obj -- ... ? ) -- ... )
[ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
rot [ [ dup n>> >>last-start ] dip ] when
over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
PRIVATE>
-: circular-while ( circular quot: ( obj -- ? ) -- )
+: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
[ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline
@
] with-destructors ; inline
-:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
+:: (NSFastEnumeration-each) ( ... object quot: ( ... elt -- ) state stackbuf count -- ... )
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
object quot state stackbuf count (NSFastEnumeration-each)
] unless ; inline recursive
-: NSFastEnumeration-each ( object quot -- )
+: NSFastEnumeration-each ( ... object quot: ( ... elt -- ... ) -- ... )
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
-: NSFastEnumeration-map ( object quot -- vector )
+: NSFastEnumeration-map ( ... object quot: ( ... elt -- ... newelt ) -- ... vector )
NS-EACH-BUFFER-SIZE <vector>
[ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline
: predecessors-changed ( cfg -- cfg )
f >>predecessors-valid? ;
-: with-cfg ( cfg quot: ( cfg -- ) -- )
+: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
[ dup cfg ] dip with-variable ; inline
TUPLE: mr { instructions array } word label ;
tri
] with-compilation-unit
-: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
-: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
-: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
-: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
+: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
'[
[ basic-block set ] [
[
: record-renaming ( from to -- )
2array renaming-set get push needs-renaming? on ;
-:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
+:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
vreg rep-of :> preferred
preferred required eq?
[ vreg no-renaming ]
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
-: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
+: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
dupd '[ _ optimize-basic-block ] each-basic-block ; inline
: needs-post-order ( cfg -- cfg' )
- dup post-order drop ;
\ No newline at end of file
+ dup post-order drop ;
tmp dom-parent to tmp walk
] [ lnode ] if ;
-: each-incoming-j-edge ( bb quot: ( from to -- ) -- )
+: each-incoming-j-edge ( ... bb quot: ( ... from to -- ... ) -- ... )
[ [ predecessors>> ] keep ] dip
'[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
[ compute-merge-set-loop ]
tri ;
-: merge-set-each ( bbs quot: ( bb -- ) -- )
+: merge-set-each ( ... bbs quot: ( ... bb -- ... ) -- ... )
[ (merge-set) ] dip '[
swap _ [ drop ] if
] 2each ; inline
to dead-in to live-in to anticip-in assoc-diff assoc-diff
assoc-diff ;
-: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
+: each-insertion ( ... assoc bb quot: ( ... vreg loc -- ... ) -- ... )
'[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
ERROR: bad-peek dst loc ;
: word-tail-call? ( bb -- ? )
instructions>> penultimate ##call? ;
-: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
+: convert-tail-call ( ..a bb quot: ( ..a insn -- ..a tail-insn ) -- ..b )
'[
instructions>>
[ pop* ] [ pop ] [ ] tri
: optimize-tail-calls ( cfg -- cfg' )
dup [ optimize-tail-call ] each-basic-block
- cfg-changed predecessors-changed ;
\ No newline at end of file
+ cfg-changed predecessors-changed ;
: cfg-has-phis? ( cfg -- ? )
post-order [ has-phis? ] any? ;
-: if-has-phis ( bb quot: ( bb -- ) -- )
+: if-has-phis ( ..a bb quot: ( ..a bb -- ..b ) -- ..b )
[ dup has-phis? ] dip [ drop ] if ; inline
-: each-phi ( bb quot: ( ##phi -- ) -- )
+: each-phi ( ... bb quot: ( ... ##phi -- ... ) -- ... )
[ instructions>> ] dip
'[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
-: each-non-phi ( bb quot: ( insn -- ) -- )
+: each-non-phi ( ... bb quot: ( ... insn -- ... ) -- ... )
[ instructions>> ] dip
'[ dup ##phi? [ drop ] _ if ] each ; inline
math.order ;
IN: compiler.tree.combinators
-: each-node ( nodes quot: ( node -- ) -- )
+: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
dup dup '[
_ [
dup #branch? [
] bi
] each ; inline recursive
-: map-nodes ( nodes quot: ( node -- node' ) -- nodes )
+: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
dup dup '[
@
dup #branch? [
] if
] map-flat ; inline recursive
-: contains-node? ( nodes quot: ( node -- ? ) -- ? )
+: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
dup dup '[
_ keep swap [ drop t ] [
dup #branch? [
: sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ;
-: until-fixed-point ( #recursive quot: ( node -- ) -- )
+: until-fixed-point ( ... #recursive quot: ( ... node -- ... ) -- ... )
over label>> t >>fixed-point drop
[ with-scope ] 2keep
over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ;
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 -- )
recursive-nesting get pop*
] each ;
-: while-changing ( quot: ( -- ) -- )
+: while-changing ( ... quot: ( ... -- ... ) -- ... )
changed? off
[ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
inline recursive
[ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]\r
[ huffman-code code>> free-bits neg 2^ /i 1array ] if ;\r
\r
-:: huffman-each ( tdesc quot: ( huffman-code -- ) -- )\r
+:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )\r
<huffman-code> :> code\r
tdesc\r
[\r
: 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
: set-front-to-back ( dlist -- )
dup front>> [ dup back>> >>front ] unless drop ; inline
-: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
+: (dlist-find-node) ( ... dlist-node quot: ( ... node -- ... ? ) -- ... node/f ? )
over [
[ call ] 2keep rot
[ drop t ] [ [ next>> ] dip (dlist-find-node) ] if
] [ 2drop f f ] if ; inline recursive
-: dlist-find-node ( dlist quot -- node/f ? )
+: dlist-find-node ( ... dlist quot: ( ... node -- ... ? ) -- ... node/f ? )
[ front>> ] dip (dlist-find-node) ; inline
-: dlist-each-node ( dlist quot -- )
+: dlist-each-node ( ... dlist quot: ( ... node -- ... ) -- ... )
'[ @ f ] dlist-find-node 2drop ; inline
: unlink-node ( dlist-node -- )
] keep
normalize-front ;
-: dlist-find ( dlist quot -- obj/f ? )
+: dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
-: dlist-any? ( dlist quot -- ? )
+: dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? )
dlist-find nip ; inline
M: dlist deque-member? ( value dlist -- ? )
[ drop unlink-node ]
} cond ;
-: delete-node-if* ( dlist quot -- obj/f ? )
+: delete-node-if* ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
dupd dlist-find-node [
dup [
[ swap delete-node ] keep obj>> t
2drop f f
] if ; inline
-: delete-node-if ( dlist quot -- obj/f )
+: delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f )
'[ obj>> @ ] delete-node-if* drop ; inline
M: dlist clear-deque ( dlist -- )
f >>back
drop ;
-: dlist-each ( dlist quot -- )
+: dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... )
'[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
-: dlist-filter ( dlist quot -- dlist' )
+: dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' )
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
M: dlist clone
to first line# =
[ to second ] [ line# document doc-line length ] if ;
-: each-line ( from to quot -- )
+: each-line ( ... from to quot: ( ... line -- ... ) -- ... )
2over = [ 3drop ] [
[ [ first ] bi@ [a,b] ] dip each
] if ; inline
-: map-lines ( from to quot -- results )
+: map-lines ( ... from to quot: ( ... line -- ... result ) -- ... results )
collector [ each-line ] dip ; inline
: start/end-on-line ( from to line# document -- n1 n2 )
: entire-doc ( document -- start end document )
[ [ doc-start ] dip doc-end ] keep ;
-: with-undo ( document quot: ( document -- ) -- )
+: with-undo ( ..a document quot: ( ..a document -- ..b ) -- ..b )
[ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline
PRIVATE>
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
: 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 )
: 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> ;
dup next-match>>
execute( i string regexp -- i start end ? ) ; inline
-:: (each-match) ( i string regexp quot: ( start end string -- ) -- )
+:: (each-match) ( ... i string regexp quot: ( ... start end string -- ... ) -- ... )
i string regexp do-next-match [| i' start end |
start end string quot call
i' string regexp quot (each-match)
PRIVATE>
-: each-match ( string regexp quot: ( start end string -- ) -- )
+: each-match ( ... string regexp quot: ( ... start end string -- ... ) -- ... )
[ prepare-match-iterator ] dip (each-match) ; inline
-: map-matches ( string regexp quot: ( start end string -- obj ) -- seq )
+: map-matches ( ... string regexp quot: ( ... start end string -- ... obj ) -- ... seq )
collector [ each-match ] dip >array ; inline
: all-matching-slices ( string regexp -- seq )
M: string branch? drop f ;
M: object branch? drop f ;
-: deep-each ( obj quot: ( elt -- ) -- )
+: deep-each ( ... obj quot: ( ... elt -- ... ) -- ... )
[ call ] 2keep over branch?
[ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive
-: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
+: deep-map ( ... obj quot: ( ... elt -- ... elt' ) -- ... newobj )
[ call ] keep over branch?
[ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
-: deep-filter ( obj quot: ( elt -- ? ) -- seq )
+: deep-filter ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
over [ selector [ deep-each ] dip ] dip
dup branch? [ like ] [ drop ] if ; inline recursive
-: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
+: (deep-find) ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
[ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean
] [ 2drop f f ] if
] if ; inline recursive
-: deep-find ( obj quot -- elt ) (deep-find) drop ; inline
+: deep-find ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ) (deep-find) drop ; inline
-: deep-any? ( obj quot -- ? ) (deep-find) nip ; inline
+: deep-any? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? ) (deep-find) nip ; inline
-: deep-all? ( obj quot -- ? )
+: deep-all? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? )
'[ @ not ] deep-any? not ; inline
: deep-member? ( obj seq -- ? )
_ swap dup branch? [ subseq? ] [ 2drop f ] if
] deep-find >boolean ;
-: deep-map! ( obj quot: ( elt -- elt' ) -- obj )
+: deep-map! ( ... obj quot: ( ... elt -- ... elt' ) -- ... obj )
over branch? [
'[ _ [ call ] keep over [ deep-map! drop ] dip ] map!
] [ drop ] if ; inline recursive
: get+increment ( sequence-parser -- char/f )
[ current ] [ advance drop ] bi ; inline
-:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+:: skip-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... )
sequence-parser current [
sequence-parser quot call
[ sequence-parser advance quot skip-until ] unless
: sequence-parse-end? ( sequence-parser -- ? ) current not ;
-: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+: take-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
over sequence-parse-end? [
2drop f
] [
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
] if ; inline
-: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+: take-while ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
[ not ] compose take-until ; inline
: <safe-slice> ( from to seq -- slice/f )
IN: sorting.insertion
<PRIVATE
-:: insert ( seq quot: ( elt -- elt' ) n -- )
+:: insert ( ... seq quot: ( ... elt -- ... elt' ) n -- ... )
n zero? [
n n 1 - [ seq nth quot call ] bi@ >= [
n n 1 - seq exchange
: 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
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
: 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>
[ 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
SYMBOL: generic-word
-: make-math-method-table ( classes quot: ( class -- quot ) -- alist )
+: make-math-method-table ( classes quot: ( ... class -- ... quot ) -- alist )
[ bootstrap-words ] dip
[ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline
: tuple-dispatch ( picker alist -- alist' )
swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
-: math-dispatch-step ( picker quot: ( class -- quot ) -- quot )
+: math-dispatch-step ( picker quot: ( ... class -- ... quot ) -- quot )
[ [ { bignum float fixnum } ] dip make-math-method-table ]
[ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi
tuple swap 2array prefix tag-dispatch ; inline
from-buffer-ptr offset>> to-buffer-ptr offset>>
size glCopyBufferSubData ;
-:: with-mapped-buffer ( buffer access quot: ( alien -- ) -- )
+:: with-mapped-buffer ( ..a buffer access quot: ( ..a alien -- ..b ) -- ..b )
buffer bind-buffer :> target
target access gl-access glMapBuffer
target glUnmapBuffer drop ; inline
-:: with-bound-buffer ( buffer target quot: ( -- ) -- )
+:: with-bound-buffer ( ..a buffer target quot: ( ..a -- ..b ) -- ..b )
target gl-target buffer glBindBuffer
quot call ; inline
-: with-buffer-ptr ( buffer-ptr target quot: ( c-ptr -- ) -- )
+: with-buffer-ptr ( ..a buffer-ptr target quot: ( ..a c-ptr -- ..b ) -- ..b )
[ [ offset>> <alien> ] [ buffer>> handle>> ] bi ] 2dip
with-bound-buffer ; inline
-: with-gpu-data-ptr ( gpu-data-ptr target quot: ( c-ptr -- ) -- )
+: with-gpu-data-ptr ( ..a gpu-data-ptr target quot: ( ..a c-ptr -- ..b ) -- ..b )
pick buffer-ptr?
[ with-buffer-ptr ]
[ [ gl-target 0 glBindBuffer ] dip call ] if ; inline
c1 c2 c3 c4 columns 4 set-firstn-unsafe
c ; inline
-: make-matrix4 ( quot: ( -- c1 c2 c3 c4 ) -- c )
+: make-matrix4 ( ..a quot: ( ..a -- ..b c1 c2 c3 c4 ) -- ..b c )
matrix4 (struct) swap dip set-columns ; inline
:: 2map-columns ( a b quot -- c )
a4 b4 quot call
] make-matrix4 ; inline
-: map-columns ( a quot -- c )
+: map-columns ( ... a quot: ( ... col -- ... newcol ) -- ... c )
'[ columns _ 4 napply ] make-matrix4 ; inline
PRIVATE>