From 95657e57423881995346b7630c8e2959b219ee89 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 18 Aug 2008 20:13:24 -0500 Subject: [PATCH] Remove some funny retain stack usage --- core/classes/tuple/tuple.factor | 12 +++---- core/combinators/combinators.factor | 6 ++-- core/generic/standard/engines/engines.factor | 6 ++-- core/io/encodings/encodings.factor | 4 +-- core/math/parser/parser.factor | 4 +-- core/sequences/sequences.factor | 34 +++++++++++--------- core/sorting/sorting.factor | 24 +++++++------- 7 files changed, 45 insertions(+), 45 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 42b5826e95..94d3a64c45 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -104,8 +104,7 @@ ERROR: bad-superclass class ; [ tuple-instance? ] 2curry define-predicate ; : superclass-size ( class -- n ) - superclasses but-last-slice - [ "slots" word-prop length ] sigma ; + superclasses but-last [ "slots" word-prop length ] sigma ; : (instance-check-quot) ( class -- quot ) [ @@ -203,11 +202,11 @@ ERROR: bad-superclass class ; M: tuple-class update-class { + [ define-boa-check ] [ define-tuple-layout ] [ define-tuple-slots ] [ define-tuple-predicate ] [ define-tuple-prototype ] - [ define-boa-check ] } cleave ; : define-new-tuple-class ( class superclass slots -- ) @@ -280,11 +279,8 @@ M: tuple-class reset-class ] with each ] [ [ call-next-method ] - [ - { - "layout" "slots" "boa-check" "prototype" - } reset-props - ] bi + [ { "layout" "slots" "boa-check" "prototype" } reset-props ] + bi ] bi ; M: tuple-class rank-class drop 0 ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 188dcb3d11..d0c83d0ca2 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -117,10 +117,10 @@ ERROR: no-case ; ] [ drop f ] if ; : dispatch-case ( value from to default array -- ) - >r >r 3dup between? [ - drop - >fixnum r> drop r> dispatch + >r >r 3dup between? r> r> rot [ + >r 2drop - >fixnum r> dispatch ] [ - 2drop r> call r> drop + drop 2nip call ] if ; inline : dispatch-case-quot ( default assoc -- quot ) diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index f60ee6d0d1..6a5e8d1bb0 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -34,10 +34,10 @@ GENERIC: engine>quot ( engine -- quot ) [ [ nip class<= ] curry assoc-filter ] 2bi ; : convert-methods ( assoc class word -- assoc' ) - over >r >r split-methods dup assoc-empty? [ - r> r> 3drop + over [ split-methods ] 2dip pick assoc-empty? [ + 3drop ] [ - r> execute r> pick set-at + [ execute ] dip pick set-at ] if ; inline : (picker) ( n -- quot ) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 3df441ae03..15ee233dbc 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -61,8 +61,8 @@ M: decoder stream-read1 : (read) ( n quot -- n string ) over 0 [ [ - >r call dup - [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if + slip over + [ swapd set-nth-unsafe f ] [ 3drop t ] if ] 2curry find-integer ] keep ; inline diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 1cb2ae6cdf..78705266ee 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -96,8 +96,8 @@ PRIVATE> : integer, ( num radix -- ) dup 1 <= [ "Invalid radix" throw ] when - dup >r /mod >digit , dup 0 > - [ r> integer, ] [ r> 2drop ] if ; + [ /mod >digit , ] keep over 0 > + [ integer, ] [ 2drop ] if ; PRIVATE> diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 8678c9c4ef..ef67d23aaa 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -33,7 +33,7 @@ M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; : first ( seq -- first ) 0 swap nth ; inline : second ( seq -- second ) 1 swap nth ; inline : third ( seq -- third ) 2 swap nth ; inline -: fourth ( seq -- fourth ) 3 swap nth ; inline +: fourth ( seq -- fourth ) 3 swap nth ; inline : set-first ( first seq -- ) 0 swap set-nth ; inline : set-second ( second seq -- ) 1 swap set-nth ; inline @@ -173,13 +173,6 @@ M: reversed length seq>> length ; INSTANCE: reversed virtual-sequence -: reverse ( seq -- newseq ) - [ - dup [ length ] keep new-sequence - [ 0 swap copy ] keep - [ reverse-here ] keep - ] keep like ; - ! A slice of another sequence. TUPLE: slice { from read-only } @@ -341,11 +334,10 @@ M: immutable-sequence clone-like like ; pick >r >r (each) r> call r> finish-find ; inline : (find-from) ( n seq quot quot' -- i elt ) - >r >r 2dup bounds-check? [ - r> r> (find) - ] [ - r> r> 2drop 2drop f f - ] if ; inline + [ 2dup bounds-check? ] 2dip + [ (find) ] 2curry + [ 2drop f f ] + if ; inline : (monotonic) ( seq quot -- ? ) [ 2dup nth-unsafe rot 1+ rot nth-unsafe ] @@ -606,6 +598,13 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; tuck - 1- rot exchange-unsafe ] each 2drop ; +: reverse ( seq -- newseq ) + [ + dup [ length ] keep new-sequence + [ 0 swap copy ] keep + [ reverse-here ] keep + ] keep like ; + : sum-lengths ( seq -- n ) 0 [ length + ] reduce ; @@ -629,8 +628,10 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; ] keep like ; : padding ( seq n elt quot -- newseq ) - >r >r over length [-] dup zero? - [ r> r> 3drop ] [ r> r> call ] if ; inline + [ + [ over length [-] dup zero? [ drop ] ] dip + [ ] curry + ] dip compose if ; inline : pad-left ( seq n elt -- padded ) [ swap dup (append) ] padding ; @@ -735,9 +736,11 @@ PRIVATE> [ left-trim ] [ right-trim ] bi ; inline : sum ( seq -- n ) 0 [ + ] binary-reduce ; + : product ( seq -- n ) 1 [ * ] binary-reduce ; : infimum ( seq -- n ) dup first [ min ] reduce ; + : supremum ( seq -- n ) dup first [ max ] reduce ; : flip ( matrix -- newmatrix ) @@ -749,4 +752,3 @@ PRIVATE> : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline - diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index b7bb71f602..a7946f6740 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -25,19 +25,19 @@ TUPLE: merge : dump ( from to seq accum -- ) #! Optimize common case where to - from = 1, 2, or 3. - >r >r 2dup swap - dup 1 = - [ 2drop r> nth-unsafe r> push ] [ - dup 2 = [ - 2drop dup 1+ + >r >r 2dup swap - r> r> pick 1 = + [ >r >r 2drop r> nth-unsafe r> push ] [ + pick 2 = [ + >r >r 2drop dup 1+ r> [ nth-unsafe ] curry bi@ r> [ push ] curry bi@ ] [ - dup 3 = [ - 2drop dup 1+ dup 1+ + pick 3 = [ + >r >r 2drop dup 1+ dup 1+ r> [ nth-unsafe ] curry tri@ r> [ push ] curry tri@ ] [ - drop r> subseq r> push-all + >r nip subseq r> push-all ] if ] if ] if ; inline @@ -120,11 +120,13 @@ TUPLE: merge [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline : (sort-pairs) ( i1 i2 seq quot accum -- ) - >r >r 2dup length = [ - nip nth r> drop r> push + [ 2dup length = ] 2dip rot [ + [ drop nip nth ] dip push ] [ - tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq? - [ swap ] when r> tuck [ push ] 2bi@ + [ + [ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq? + [ swap ] when + ] dip tuck [ push ] 2bi@ ] if ; inline : sort-pairs ( merge quot -- )