Adding stack effects.

db4
John Benediktsson 2011-09-22 17:19:51 -07:00
parent f6b6e17b00
commit 3c1356bf69
13 changed files with 23 additions and 22 deletions

View File

@ -99,7 +99,7 @@ INSTANCE: sliced-clumps abstract-clumps
: clump ( seq n -- array ) <clumps> { } like ;
: monotonic? ( seq quot -- ? )
: monotonic? ( seq quot: ( obj1 obj2 -- ? ) -- ? )
over length 2 < [ 2drop t ] [
over length 2 = [
[ first2-unsafe ] dip call

View File

@ -34,7 +34,7 @@ M: product-sequence length lengths>> product ;
: carry-ns ( ns lengths -- )
0 (carry-n) ;
: product-iter ( ns lengths -- )
[ 0 over [ 1 + ] change-nth ] dip carry-ns ;
@ -46,17 +46,17 @@ M: product-sequence length lengths>> product ;
PRIVATE>
M: product-sequence nth
M: product-sequence nth
product@ nths ;
:: product-each ( sequences quot -- )
:: product-each ( sequences quot: ( seq -- ) -- )
sequences start-product-iter :> ( ns lengths )
lengths [ 0 = ] any? [
[ ns lengths end-product-iter? ]
[ ns sequences nths quot call ns lengths product-iter ] until
] unless ; inline
:: product-map-as ( sequences quot exemplar -- sequence )
:: product-map-as ( sequences quot: ( seq -- value ) exemplar -- sequence )
0 :> i!
sequences [ length ] [ * ] map-reduce exemplar
[| result |
@ -64,10 +64,10 @@ M: product-sequence nth
result
] new-like ; inline
: product-map ( sequences quot -- sequence )
: product-map ( sequences quot: ( seq -- value ) -- sequence )
over product-map-as ; inline
:: product-map>assoc ( sequences quot exemplar -- assoc )
:: product-map>assoc ( sequences quot: ( seq -- key value ) exemplar -- assoc )
0 :> i!
sequences [ length ] [ * ] map-reduce { }
[| result |

View File

@ -11,6 +11,6 @@ IN: sorting.insertion
] unless ; inline recursive
PRIVATE>
: insertion-sort ( seq quot -- )
: insertion-sort ( ... seq quot: ( ... elt -- ... elt' ) -- ... )
! quot is a transformation on elements
over length [ insert ] with with each-integer ; inline

View File

@ -18,7 +18,7 @@ IN: sorting.slots
] when execute-comparator
] with with map-find drop +eq+ or ;
: sort-by-with ( seq sort-specs quot -- seq' )
: sort-by-with ( seq sort-specs quot: ( obj -- key ) -- seq' )
swap '[ _ bi@ _ compare-slots ] sort ; inline
: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ;

View File

@ -18,7 +18,7 @@ IN: splitting.monotonic
PRIVATE>
: monotonic-split ( seq quot -- newseq )
: monotonic-split ( seq quot: ( obj1 obj2 -- ? ) -- newseq )
over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline
<PRIVATE
@ -36,7 +36,7 @@ PRIVATE>
PRIVATE>
: monotonic-slice ( seq quot class -- slices )
: monotonic-slice ( seq quot: ( obj1 obj2 -- ? ) class -- slices )
pick length {
{ 0 [ 2drop ] }
{ 1 [ nip [ 0 1 rot ] dip boa 1array ] }

View File

@ -75,7 +75,7 @@ sleep-entry ;
: tset ( value key -- )
tnamespace set-at ;
: tchange ( key quot -- )
: tchange ( ..a key quot: ( ..a value -- ..b newvalue ) -- ..b )
[ tnamespace ] dip change-at ; inline
: threads ( -- assoc )

View File

@ -142,7 +142,7 @@ SYMBOL: ui-thread
PRIVATE>
: find-window ( quot -- world )
: find-window ( quot: ( world -- ? ) -- world )
[ windows get values ] dip
'[ dup children>> [ ] [ nip first ] if-empty @ ]
find-last nip ; inline

View File

@ -76,9 +76,9 @@ ERROR: log2-expects-positive x ;
: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
[ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-zero ( n quot -- ) [ ] if-zero ; inline
: when-zero ( ..a n quot: ( ..a -- ..b ) -- ..b ) [ ] if-zero ; inline
: unless-zero ( n quot -- ) [ ] swap if-zero ; inline
: unless-zero ( ..a n quot: ( ..a -- ..b ) -- ..b ) [ ] swap if-zero ; inline
UNION: integer fixnum bignum ;

View File

@ -45,4 +45,4 @@ M: object max [ after? ] most ; inline
: [-] ( x y -- z ) - 0 max ; inline
: compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline
: compare ( obj1 obj2 quot: ( obj -- newobj ) -- <=> ) bi@ <=> ; inline

View File

@ -121,7 +121,7 @@ M: sequence cardinality
[ [ [ members ] map concat ] [ first ] bi set-like ]
if-empty ;
: gather ( seq quot -- newseq )
: gather ( ... seq quot: ( ... elt -- ... elt' ) -- ... newseq )
map concat members ; inline
: adjoin-at ( value key assoc -- )

View File

@ -148,16 +148,17 @@ TUPLE: merge
PRIVATE>
: sort ( seq quot -- sortedseq )
: sort ( seq quot: ( obj1 obj2 -- <=> ) -- sortedseq )
[ <merge> ] dip
[ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ;
inline
: natural-sort ( seq -- sortedseq ) [ <=> ] sort ;
: sort-with ( seq quot -- sortedseq )
: sort-with ( seq quot: ( elt -- key ) -- sortedseq )
[ compare ] curry sort ; inline
: inv-sort-with ( seq quot -- sortedseq )
: inv-sort-with ( seq quot: ( elt -- key ) -- sortedseq )
[ compare invert-comparison ] curry sort ; inline
GENERIC: sort-keys ( obj -- sortedseq )

View File

@ -68,7 +68,7 @@ PRIVATE>
: split ( seq separators -- pieces )
[ [ member? ] curry split, ] { } make ;
: split-when ( seq quot -- pieces )
: split-when ( ... seq quot: ( ... elt -- ... ? ) -- ... pieces )
[ split, ] { } make ; inline
GENERIC: string-lines ( str -- seq )

View File

@ -31,7 +31,7 @@ M: word definition def>> ;
[ pick props>> ?set-at >>props drop ]
[ nip remove-word-prop ] if ;
: change-word-prop ( word prop quot -- )
: change-word-prop ( ..a word prop quot: ( ..a value -- ..b newvalue ) -- ..b )
[ swap props>> ] dip change-at ; inline
: reset-props ( word seq -- ) [ remove-word-prop ] with each ;