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

move some words to private, make stack effects for slices contain explicit -slice

db4
Doug Coleman 2008-09-17 18:37:57 -05:00
parent 8fd119ede2
commit affc0b4830
1 changed files with 23 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
core/sequences/sequences.factor
View File

@ -289,6 +289,8 @@ M: immutable-sequence clone-like like ;
: push-all ( src dest -- ) [ length ] [ copy ] bi ; : push-all ( src dest -- ) [ length ] [ copy ] bi ;
<PRIVATE
: ((append)) ( seq1 seq2 accum -- accum ) : ((append)) ( seq1 seq2 accum -- accum )
[ >r over length r> copy ] [ >r over length r> copy ]
[ 0 swap copy ] [ 0 swap copy ]
@ -304,6 +306,8 @@ M: immutable-sequence clone-like like ;
[ ((append)) ] bi [ ((append)) ] bi
] new-like ; inline ] new-like ; inline
PRIVATE>
: append ( seq1 seq2 -- newseq ) over (append) ; : append ( seq1 seq2 -- newseq ) over (append) ;
: prepend ( seq1 seq2 -- newseq ) swap append ; inline : prepend ( seq1 seq2 -- newseq ) swap append ; inline
@ -402,7 +406,7 @@ PRIVATE>
: 2map ( seq1 seq2 quot -- newseq ) : 2map ( seq1 seq2 quot -- newseq )
pick 2map-as ; inline pick 2map-as ; inline
: 2change-each ( seq1 seq2 quot -- newseq ) : 2change-each ( seq1 seq2 quot -- )
pick 2map-into ; inline pick 2map-into ; inline
: 2all? ( seq1 seq2 quot -- ? ) : 2all? ( seq1 seq2 quot -- ? )
@ -543,6 +547,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
2over number= 2over number=
[ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline [ 3drop ] [ [ nth swap ] [ set-nth ] bi ] if ; inline
<PRIVATE
: (delete) ( elt store scan seq -- elt store scan seq ) : (delete) ( elt store scan seq -- elt store scan seq )
2dup length < [ 2dup length < [
3dup move 3dup move
@ -550,6 +556,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
[ >r >r 1+ r> r> ] unless >r 1+ r> (delete) [ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
] when ; ] when ;
PRIVATE>
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ; : delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
: prefix ( seq elt -- newseq ) : prefix ( seq elt -- newseq )
@ -568,6 +576,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ; : pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
<PRIVATE
: move-backward ( shift from to seq -- ) : move-backward ( shift from to seq -- )
2over number= [ 2over number= [
2drop 2drop 2drop 2drop
@ -591,6 +601,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
>r >r over - r> r> move-backward >r >r over - r> r> move-backward
] if ; ] if ;
PRIVATE>
: open-slice ( shift from seq -- ) : open-slice ( shift from seq -- )
pick zero? [ pick zero? [
3drop 3drop
@ -650,9 +662,13 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
first like first like
] if-empty ; ] if-empty ;
<PRIVATE
: joined-length ( seq glue -- n ) : joined-length ( seq glue -- n )
>r dup sum-lengths swap length 1 [-] r> length * + ; >r dup sum-lengths swap length 1 [-] r> length * + ;
PRIVATE>
: join ( seq glue -- newseq ) : join ( seq glue -- newseq )
[ [
2dup joined-length over new-resizable spin 2dup joined-length over new-resizable spin
@ -671,7 +687,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: pad-right ( seq n elt -- padded ) : pad-right ( seq n elt -- padded )
[ append ] padding ; [ append ] padding ;
: shorter? ( seq1 seq2 -- ? ) >r length r> length < ; : shorter? ( seq1 seq2 -- ? ) [ length ] bi@ < ;
: head? ( seq begin -- ? ) : head? ( seq begin -- ? )
2dup shorter? [ 2dup shorter? [
@ -687,7 +703,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
tuck length tail-slice* sequence= tuck length tail-slice* sequence=
] if ; ] if ;
: cut-slice ( seq n -- before after ) : cut-slice ( seq n -- before-slice after-slice )
[ head-slice ] [ tail-slice ] 2bi ; [ head-slice ] [ tail-slice ] 2bi ;
: insert-nth ( elt n seq -- seq' ) : insert-nth ( elt n seq -- seq' )
@ -695,7 +711,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: midpoint@ ( seq -- n ) length 2/ ; inline : midpoint@ ( seq -- n ) length 2/ ; inline
: halves ( seq -- first second ) : 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 )
@ -749,10 +765,10 @@ PRIVATE>
: unclip-last ( seq -- butlast last ) : unclip-last ( seq -- butlast last )
[ but-last ] [ peek ] bi ; [ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first ) : unclip-slice ( seq -- rest-slice first )
[ rest-slice ] [ first ] bi ; inline [ rest-slice ] [ first ] bi ; inline
: 2unclip-slice ( seq1 seq2 -- seq1' seq2' elt1 elt2 ) : 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 ( seq map-quot reduce-quot -- result )
@ -763,7 +779,7 @@ PRIVATE>
[ [ 2unclip-slice ] dip [ call ] keep ] dip [ [ 2unclip-slice ] dip [ call ] keep ] dip
compose 2reduce ; inline compose 2reduce ; inline
: unclip-last-slice ( seq -- butlast last ) : unclip-last-slice ( seq -- butlast-slice last )
[ but-last-slice ] [ peek ] bi ; inline [ but-last-slice ] [ peek ] bi ; inline
: <flat-slice> ( seq -- slice ) : <flat-slice> ( seq -- slice )