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

spray some polymorphic stack effects on kernel, math, and sequences

db4
Joe Groff 2010-03-05 00:21:10 -08:00
parent 1b1ccb71a4
commit 85f30987e2
3 changed files with 66 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/kernel/kernel.factor
View File

@ -29,7 +29,7 @@ DEFER: if
#! two literal quotations. #! two literal quotations.
rot [ drop ] [ nip ] if ; inline rot [ drop ] [ nip ] if ; inline
: if ( ? true false -- ) ? call ; : if ( ..a ? true: ( ..a -- ..b ) false: ( ..a -- ..b ) -- ..b ) ? call ;
! Single branch ! Single branch
: unless ( ? false -- ) : unless ( ? false -- )
@ -39,7 +39,7 @@ DEFER: if
swap [ call ] [ drop ] if ; inline swap [ call ] [ drop ] if ; inline
! Anaphoric ! Anaphoric
: if* ( ? true false -- ) : if* ( ..a ? true: ( ..a ? -- ..b ) false: ( ..a -- ..b ) -- ..b )
pick [ drop call ] [ 2nip call ] if ; inline pick [ drop call ] [ 2nip call ] if ; inline
: when* ( ? true -- ) : when* ( ? true -- )
@ -49,7 +49,7 @@ DEFER: if
over [ drop ] [ nip call ] if ; inline over [ drop ] [ nip call ] if ; inline
! Default ! Default
: ?if ( default cond true false -- ) : ?if ( ..a default cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
! Dippers. ! Dippers.
@ -171,16 +171,16 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
: most ( x y quot -- z ) 2keep ? ; inline : most ( x y quot -- z ) 2keep ? ; inline
! Loops ! Loops
: loop ( pred: ( -- ? ) -- ) : loop ( ... pred: ( ... -- ... ? ) -- ... )
[ call ] keep [ loop ] curry when ; inline recursive [ call ] keep [ loop ] curry when ; inline recursive
: do ( pred body -- pred body ) : do ( pred body -- pred body )
dup 2dip ; inline dup 2dip ; inline
: while ( pred: ( -- ? ) body: ( -- ) -- ) : while ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- ... )
swap do compose [ loop ] curry when ; inline swap do compose [ loop ] curry when ; inline
: until ( pred: ( -- ? ) body: ( -- ) -- ) : until ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- )
[ [ not ] compose ] dip while ; inline [ [ not ] compose ] dip while ; inline
! Object protocol ! Object protocol

10
core/math/math.factor
View File

@ -77,7 +77,7 @@ ERROR: log2-expects-positive x ;
: even? ( n -- ? ) 1 bitand zero? ; : even? ( n -- ? ) 1 bitand zero? ;
: odd? ( n -- ? ) 1 bitand 1 number= ; : odd? ( n -- ? ) 1 bitand 1 number= ;
: if-zero ( n quot1 quot2 -- ) : if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
[ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline [ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-zero ( n quot -- ) [ ] if-zero ; inline : when-zero ( n quot -- ) [ ] if-zero ; inline
@ -141,18 +141,18 @@ GENERIC: prev-float ( m -- n )
PRIVATE> PRIVATE>
: (each-integer) ( i n quot: ( i -- ) -- ) : (each-integer) ( ... i n quot: ( ... i -- ... ) -- ... )
[ iterate-step iterate-next (each-integer) ] [ iterate-step iterate-next (each-integer) ]
[ 3drop ] if-iterate? ; inline recursive [ 3drop ] if-iterate? ; inline recursive
: (find-integer) ( i n quot: ( i -- ? ) -- i ) : (find-integer) ( ... i n quot: ( ... i -- ... ? ) -- ... i )
[ [
iterate-step iterate-step
[ [ ] ] 2dip [ [ ] ] 2dip
[ iterate-next (find-integer) ] 2curry bi-curry if [ iterate-next (find-integer) ] 2curry bi-curry if
] [ 3drop f ] if-iterate? ; inline recursive ] [ 3drop f ] if-iterate? ; inline recursive
: (all-integers?) ( i n quot: ( i -- ? ) -- ? ) : (all-integers?) ( ... i n quot: ( ... i -- ... ? ) -- ... ? )
[ [
iterate-step iterate-step
[ iterate-next (all-integers?) ] 3curry [ iterate-next (all-integers?) ] 3curry
@ -171,7 +171,7 @@ PRIVATE>
: all-integers? ( n quot -- ? ) : all-integers? ( n quot -- ? )
iterate-prep (all-integers?) ; inline iterate-prep (all-integers?) ; inline
: find-last-integer ( n quot: ( i -- ? ) -- i ) : find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i )
over 0 < [ over 0 < [
2drop f 2drop f
] [ ] [

110
core/sequences/sequences.factor
View File

@ -29,7 +29,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
: empty? ( seq -- ? ) length 0 = ; inline : empty? ( seq -- ? ) length 0 = ; inline
: if-empty ( seq quot1 quot2 -- ) : if-empty ( ..a seq quot1: ( ..a -- ..b ) quot2: ( ..a seq -- ..b ) -- ..b )
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-empty ( seq quot -- ) [ ] if-empty ; inline : when-empty ( seq quot -- ) [ ] if-empty ; inline
@ -408,82 +408,82 @@ PRIVATE>
PRIVATE> PRIVATE>
: each ( seq quot -- ) : each ( ... seq quot: ( ... x -- ... ) -- ... )
(each) each-integer ; inline (each) each-integer ; inline
: reduce ( seq identity quot -- result ) : reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd each ; inline swapd each ; inline
: map-integers ( len quot exemplar -- newseq ) : map-integers ( len quot exemplar -- newseq )
[ over ] dip [ [ collect ] keep ] new-like ; inline [ over ] dip [ [ collect ] keep ] new-like ; inline
: map-as ( seq quot exemplar -- newseq ) : map-as ( ... seq quot: ( ... x -- ... newx ) exemplar -- ... newseq )
[ (each) ] dip map-integers ; inline [ (each) ] dip map-integers ; inline
: map ( seq quot -- newseq ) : map ( ... seq quot: ( ... x -- ... newx ) -- ... newseq )
over map-as ; inline over map-as ; inline
: replicate-as ( len quot exemplar -- newseq ) : replicate-as ( ... len quot: ( ... -- ... newx ) exemplar -- ... newseq )
[ [ drop ] prepose ] dip map-integers ; inline [ [ drop ] prepose ] dip map-integers ; inline
: replicate ( len quot -- newseq ) : replicate ( ... len quot: ( ... -- ... newx ) -- ... newseq )
{ } replicate-as ; inline { } replicate-as ; inline
: map! ( seq quot -- seq ) : map! ( ... seq quot: ( ... x -- ... x' ) -- ... seq )
over [ map-into ] keep ; inline over [ map-into ] keep ; inline
: accumulate-as ( seq identity quot exemplar -- final newseq ) : accumulate-as ( ... seq identity quot: ( ... prev elt -- ... next ) exemplar -- ... final newseq )
[ (accumulate) ] dip map-as ; inline [ (accumulate) ] dip map-as ; inline
: accumulate ( seq identity quot -- final newseq ) : accumulate ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final newseq )
{ } accumulate-as ; inline { } accumulate-as ; inline
: accumulate! ( seq identity quot -- final seq ) : accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
(accumulate) map! ; inline (accumulate) map! ; inline
: 2each ( seq1 seq2 quot -- ) : 2each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
(2each) each-integer ; inline (2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- ) : 2reverse-each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
[ [ <reversed> ] bi@ ] dip 2each ; inline [ [ <reversed> ] bi@ ] dip 2each ; inline
: 2reduce ( seq1 seq2 identity quot -- result ) : 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline [ -rot ] dip 2each ; inline
: 2map-as ( seq1 seq2 quot exemplar -- newseq ) : 2map-as ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) exemplar -- ... newseq )
[ (2each) ] dip map-integers ; inline [ (2each) ] dip map-integers ; inline
: 2map ( seq1 seq2 quot -- newseq ) : 2map ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) -- ... newseq )
pick 2map-as ; inline pick 2map-as ; inline
: 2all? ( seq1 seq2 quot -- ? ) : 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
(2each) all-integers? ; inline (2each) all-integers? ; inline
: 3each ( seq1 seq2 seq3 quot -- ) : 3each ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... ) -- ... )
(3each) each-integer ; inline (3each) each-integer ; inline
: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq ) : 3map-as ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) exemplar -- ... newseq )
[ (3each) ] dip map-integers ; inline [ (3each) ] dip map-integers ; inline
: 3map ( seq1 seq2 seq3 quot -- newseq ) : 3map ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) -- ... newseq )
[ pick ] dip swap 3map-as ; inline [ pick ] dip swap 3map-as ; inline
: find-from ( n seq quot -- i elt ) : find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ (find-integer) ] (find-from) ; inline [ (find-integer) ] (find-from) ; inline
: find ( seq quot -- i elt ) : find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ find-integer ] (find) ; inline [ find-integer ] (find) ; inline
: find-last-from ( n seq quot -- i elt ) : find-last-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ nip find-last-integer ] (find-from) ; inline [ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt ) : find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ [ 1 - ] dip find-last-integer ] (find) ; inline [ [ 1 - ] dip find-last-integer ] (find) ; inline
: all? ( seq quot -- ? ) : all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
(each) all-integers? ; inline (each) all-integers? ; inline
: push-if ( elt quot accum -- ) : push-if ( ... elt quot: ( ... elt -- ... ? ) accum -- ... )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline [ keep ] dip rot [ push ] [ 2drop ] if ; inline
: selector-for ( quot exemplar -- selector accum ) : selector-for ( quot exemplar -- selector accum )
@ -492,19 +492,19 @@ PRIVATE>
: selector ( quot -- selector accum ) : selector ( quot -- selector accum )
V{ } selector-for ; inline V{ } selector-for ; inline
: filter-as ( seq quot exemplar -- subseq ) : filter-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... subseq )
dup [ selector-for [ each ] dip ] curry dip like ; inline dup [ selector-for [ each ] dip ] curry dip like ; inline
: filter ( seq quot -- subseq ) : filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
over filter-as ; inline over filter-as ; inline
: push-either ( elt quot accum1 accum2 -- ) : push-either ( ... elt quot: ( ... elt -- ... ? ) accum1 accum2 -- ... )
[ keep swap ] 2dip ? push ; inline [ keep swap ] 2dip ? push ; inline
: 2selector ( quot -- selector accum1 accum2 ) : 2selector ( quot -- selector accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq ) : partition ( ... seq quot: ( ... elt -- ... ? ) -- ... trueseq falseseq )
over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: collector-for ( quot exemplar -- quot' vec ) : collector-for ( quot exemplar -- quot' vec )
@ -513,16 +513,16 @@ PRIVATE>
: collector ( quot -- quot' vec ) : collector ( quot -- quot' vec )
V{ } collector-for ; inline V{ } collector-for ; inline
: produce-as ( pred quot exemplar -- seq ) : produce-as ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) exemplar -- ... seq )
dup [ collector-for [ while ] dip ] curry dip like ; inline dup [ collector-for [ while ] dip ] curry dip like ; inline
: produce ( pred quot -- seq ) : produce ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) -- ... seq )
{ } produce-as ; inline { } produce-as ; inline
: follow ( obj quot -- seq ) : follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq )
[ dup ] swap [ keep ] curry produce nip ; inline [ dup ] swap [ keep ] curry produce nip ; inline
: each-index ( seq quot -- ) : each-index ( ... seq quot: ( ... x i -- ... ) -- ... )
(each-index) each-integer ; inline (each-index) each-integer ; inline
: interleave ( seq between quot -- ) : interleave ( seq between quot -- )
@ -532,10 +532,10 @@ PRIVATE>
3bi 3bi
] if ; inline ] if ; inline
: map-index ( seq quot -- newseq ) : map-index ( ... seq quot: ( ... x i -- ... newx ) -- ... newseq )
[ dup length iota ] dip 2map ; inline [ dup length iota ] dip 2map ; inline
: reduce-index ( seq identity quot -- ) : reduce-index ( ... seq identity quot: ( ... prev x i -- ... next ) -- ... result )
swapd each-index ; inline swapd each-index ; inline
: index ( obj seq -- n ) : index ( obj seq -- n )
@ -564,7 +564,7 @@ PRIVATE>
: nths ( indices seq -- seq' ) : nths ( indices seq -- seq' )
[ nth ] curry map ; [ nth ] curry map ;
: any? ( seq quot -- ? ) : any? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
find drop >boolean ; inline find drop >boolean ; inline
: member? ( elt seq -- ? ) : member? ( elt seq -- ? )
@ -626,7 +626,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
<PRIVATE <PRIVATE
: (filter!) ( quot: ( elt -- ? ) store scan seq -- ) : (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
2dup length < [ 2dup length < [
[ move ] 3keep [ move ] 3keep
[ nth-unsafe pick call [ 1 + ] when ] 2keep [ nth-unsafe pick call [ 1 + ] when ] 2keep
@ -636,7 +636,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
PRIVATE> PRIVATE>
: filter! ( seq quot -- seq ) : filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
swap [ [ 0 0 ] dip (filter!) ] keep ; inline swap [ [ 0 0 ] dip (filter!) ] keep ; inline
: remove! ( elt seq -- seq ) : remove! ( elt seq -- seq )
@ -771,7 +771,7 @@ PRIVATE>
] keep like ] keep like
] if ; ] if ;
: padding ( seq n elt quot -- newseq ) : padding ( ... seq n elt quot: ( ... seq1 seq2 -- ... newseq ) -- ... newseq )
[ [
[ over length [-] dup 0 = [ drop ] ] dip [ over length [-] dup 0 = [ drop ] ] dip
[ <repetition> ] curry [ <repetition> ] curry
@ -810,7 +810,7 @@ PRIVATE>
: halves ( seq -- first-slice second-slice ) : halves ( seq -- first-slice second-slice )
dup midpoint@ cut-slice ; dup midpoint@ cut-slice ;
: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value ) : binary-reduce ( ... seq start quot: ( ... elt1 elt2 -- ... newelt ) -- ... value )
#! We can't use case here since combinators depends on #! We can't use case here since combinators depends on
#! sequences #! sequences
pick length dup 0 3 between? [ pick length dup 0 3 between? [
@ -873,11 +873,11 @@ PRIVATE>
: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 ) : 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
[ unclip-slice ] bi@ swapd ; inline [ unclip-slice ] bi@ swapd ; inline
: map-reduce ( seq map-quot reduce-quot -- result ) : map-reduce ( ..a seq map-quot: ( ..a x -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
[ [ unclip-slice ] dip [ call ] keep ] dip [ [ unclip-slice ] dip [ call ] keep ] dip
compose reduce ; inline compose reduce ; inline
: 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result ) : 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a x1 x2 -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
[ [ prepare-2map-reduce ] keep ] dip [ [ prepare-2map-reduce ] keep ] dip
compose compose each-integer ; inline compose compose each-integer ; inline
@ -889,10 +889,10 @@ PRIVATE>
PRIVATE> PRIVATE>
: map-find ( seq quot -- result elt ) : map-find ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
[ find ] (map-find) ; inline [ find ] (map-find) ; inline
: map-find-last ( seq quot -- result elt ) : map-find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
[ find-last ] (map-find) ; inline [ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last ) : unclip-last-slice ( seq -- butlast-slice last )
@ -915,22 +915,22 @@ PRIVATE>
PRIVATE> PRIVATE>
: trim-head-slice ( seq quot -- slice ) : trim-head-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-head) tail-slice ; inline (trim-head) tail-slice ; inline
: trim-head ( seq quot -- newseq ) : trim-head ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-head) tail ; inline (trim-head) tail ; inline
: trim-tail-slice ( seq quot -- slice ) : trim-tail-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-tail) head-slice ; inline (trim-tail) head-slice ; inline
: trim-tail ( seq quot -- newseq ) : trim-tail ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-tail) head ; inline (trim-tail) head ; inline
: trim-slice ( seq quot -- slice ) : trim-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
[ trim-head-slice ] [ trim-tail-slice ] bi ; inline [ trim-head-slice ] [ trim-tail-slice ] bi ; inline
: trim ( seq quot -- newseq ) : trim ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
[ trim-slice ] [ drop ] 2bi like ; inline [ trim-slice ] [ drop ] 2bi like ; inline
GENERIC: sum ( seq -- n ) GENERIC: sum ( seq -- n )
@ -942,15 +942,15 @@ M: object sum 0 [ + ] binary-reduce ; inline
: supremum ( seq -- n ) [ ] [ max ] map-reduce ; : supremum ( seq -- n ) [ ] [ max ] map-reduce ;
: map-sum ( seq quot -- n ) : map-sum ( ... seq quot: ( ... elt -- ... n ) -- ... n )
[ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline [ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline : count ( ... seq quot: ( ... elt -- ... ? ) -- ... n ) [ 1 0 ? ] compose map-sum ; inline
: cartesian-each ( seq1 seq2 quot -- ) : cartesian-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
[ with each ] 2curry each ; inline [ with each ] 2curry each ; inline
: cartesian-map ( seq1 seq2 quot -- newseq ) : cartesian-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
[ with map ] 2curry map ; inline [ with map ] 2curry map ; inline
: cartesian-product ( seq1 seq2 -- newseq ) : cartesian-product ( seq1 seq2 -- newseq )