steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

generalize stack effects so we can bootstrap with the stricter stack effect checking

db4
Joe Groff 2010-03-08 23:38:10 -08:00
parent 3abf1f1ef7
commit 191ac353fd
31 changed files with 75 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/binary-search/binary-search.factor
View File

@ -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
] [

4
basis/circular/circular.factor
View File

@ -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

6
basis/cocoa/enumeration/enumeration.factor
View File

@ -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

2
basis/compiler/cfg/cfg.factor
View File

@ -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 ;

8
basis/compiler/cfg/representations/preferred/preferred.factor
View File

@ -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 ] [
[

2
basis/compiler/cfg/representations/representations.factor
View File

@ -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 ]

4
basis/compiler/cfg/rpo/rpo.factor
View File

@ -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 ;
dup post-order drop ;

4
basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
View File

@ -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

2
basis/compiler/cfg/stacks/finalize/finalize.factor
View File

@ -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 ;

4
basis/compiler/cfg/tco/tco.factor
View File

@ -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 ;
cfg-changed predecessors-changed ;

6
basis/compiler/cfg/utilities/utilities.factor
View File

@ -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

8
basis/compiler/tree/combinators/combinators.factor
View File

@ -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 ;

2
basis/compiler/tree/escape-analysis/nodes/nodes.factor
View File

@ -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 -- )

2
basis/compiler/tree/recursive/recursive.factor
View File

@ -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

2
basis/compression/huffman/huffman.factor
View File

@ -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
[

2
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -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

18
basis/dlists/dlists.factor
View File

@ -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

6
basis/documents/documents.factor
View File

@ -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>

10
basis/lists/lists.factor
View File

@ -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 )
<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 )

2
basis/math/rectangles/rectangles.factor
View File

@ -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> ;

6
basis/regexp/regexp.factor
View File

@ -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 )

16
basis/sequences/deep/deep.factor
View File

@ -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

6
basis/sequences/parser/parser.factor
View File

@ -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 )

2
basis/sorting/insertion/insertion.factor
View File

@ -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

2
basis/stack-checker/backend/backend.factor
View File

@ -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

2
basis/tools/disassembler/udis/udis.factor
View File

@ -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

2
core/assocs/assocs.factor
View File

@ -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>

2
core/combinators/combinators.factor
View File

@ -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

4
core/generic/math/math.factor
View File

@ -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

8
extra/gpu/buffers/buffers.factor
View File

@ -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

4
extra/math/matrices/simd/simd.factor
View File

@ -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>