Remove some funny retain stack usage

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 42b5826e9588b208a90e7a219bcdc0418b9aeb91..94d3a64c45be36eda587f1e38553e8d2c9ea2409 100755 (executable)
--- 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 188dcb3d11a7fffb5645641a06cb56dc2871475b..d0c83d0ca2887fa8f3ea3ef15248b4dc52592bc3 100755 (executable)
--- 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 f60ee6d0d18f0f250f7a03a39e1cb00a3597dc95..6a5e8d1bb0310fc09c09c89ef6e9d9f218d482e3 100644 (file)
--- 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 3df441ae0300246d9c46de9f5eec22b06032f4a1..15ee233dbc55cf2ac3fc356e4c5bd717563a1536 100755 (executable)
--- 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 <string> [
         [
-            >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 1cb2ae6cdf31a23ab76210efbe9b84df01f52b27..78705266ee27a1c2b844e052ea6ab5c8b8f67318 100755 (executable)
--- 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 8678c9c4efb0975e9c2d1ce731a211e1a7454d9c..ef67d23aaaeedc073a7cf6057fbba737eb21f33f 100755 (executable)
--- 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> <repetition> r> call ] if ; inline
+    [
+        [ over length [-] dup zero? [ drop ] ] dip
+        [ <repetition> ] 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 b7bb71f6021546ff97a8efb225868c00ab1eca0d..a7946f67404f33e89d598eaba0cbfd3a15a897a0 100755 (executable)
--- 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 -- )