Merge branch 'master' into new_optimizer

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
+    superclasses but-last [ "slots" word-prop length ] sigma ;
-    [ "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 ;

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? [
+    >r >r 3dup between? r> r> rot [
-        drop - >fixnum r> drop r> dispatch
+        >r 2drop - >fixnum r> dispatch
     ] [
-        2drop r> call r> drop
+        drop 2nip call
     ] if ; inline
 
 : dispatch-case-quot ( default assoc -- quot )

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? [
+    over [ split-methods ] 2dip pick assoc-empty? [
-        r> r> 3drop
+        3drop
     ] [
-        r> execute r> pick set-at
+        [ execute ] dip pick set-at
     ] if ; inline
 
 : (picker) ( n -- quot )

core/io/encodings/encodings.factor

@@ -61,8 +61,8 @@ M: decoder stream-read1
 : (read) ( n quot -- n string )
     over 0 <string> [
         [
-            >r call dup
+            slip over
-            [ swap r> set-nth-unsafe f ] [ r> 3drop t ] if
+            [ swapd set-nth-unsafe f ] [ 3drop t ] if
         ] 2curry find-integer
     ] keep ; inline
 

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 >
+    [ /mod >digit , ] keep over 0 >
-    [ r> integer, ] [ r> 2drop ] if ;
+    [ integer, ] [ 2drop ] if ;
 
 PRIVATE>
 

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? [
+    [ 2dup bounds-check? ] 2dip
-        r> r> (find)
+    [ (find) ] 2curry
-    ] [
+    [ 2drop f f ]
-        r> r> 2drop 2drop f f
+    if ; inline
-    ] if ; inline
 
 : (monotonic) ( seq quot -- ? )
     [ 2dup nth-unsafe rot 1+ rot nth-unsafe ]
@@ -609,6 +601,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 ;
 
@@ -632,8 +631,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 ;
@@ -738,9 +739,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 )
@@ -752,4 +755,3 @@ PRIVATE>
 : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
 
 : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
-

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 =
+    >r >r 2dup swap - r> r> pick 1 = 
-    [ 2drop r> nth-unsafe r> push ] [
+    [ >r >r 2drop r> nth-unsafe r> push ] [
-        dup 2 = [
+        pick 2 = [
-            2drop dup 1+
+            >r >r 2drop dup 1+
             r> [ nth-unsafe ] curry bi@
             r> [ push ] curry bi@
         ] [
-            dup 3 = [
+            pick 3 = [
-                2drop dup 1+ dup 1+
+                >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 = [
+    [ 2dup length = ] 2dip rot [
-        nip nth r> drop r> push
+        [ 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 -- )