Merge OneEyed's patch

[factor.git] / core / sorting / sorting.factor

diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor
old mode 100755 (executable)
new mode 100644 (file)
index b57e661..30ecb70
--- a/core/sorting/sorting.factor
+++ b/core/sorting/sorting.factor
@@ -25,32 +25,45 @@ TUPLE: merge
 
 : dump ( from to seq accum -- )
     #! Optimize common case where to - from = 1, 2, or 3.
-    >r >r 2dup swap - r> r> pick 1 = 
-    [ >r >r 2drop r> nth-unsafe r> push ] [
+    [ 2dup swap - ] 2dip pick 1 = 
+    [ [ [ 2drop ] dip nth-unsafe ] dip push ] [
         pick 2 = [
-            >r >r 2drop dup 1+
-            r> [ nth-unsafe ] curry bi@
-            r> [ push ] curry bi@
+            [
+                [ 2drop dup 1+ ] dip
+                [ nth-unsafe ] curry bi@
+            ] dip [ push ] curry bi@
         ] [
             pick 3 = [
-                >r >r 2drop dup 1+ dup 1+
-                r> [ nth-unsafe ] curry tri@
-                r> [ push ] curry tri@
-            ] [
-                >r nip subseq r> push-all
-            ] if
+                [
+                    [ 2drop dup 1+ dup 1+ ] dip
+                    [ nth-unsafe ] curry tri@
+                ] dip [ push ] curry tri@
+            ] [ [ nip subseq ] dip push-all ] if
         ] if
     ] if ; inline
 
-: l-elt   [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
-: r-elt   [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
-: l-done? [ from1>> ] [ to1>> ] bi number= ; inline
-: r-done? [ from2>> ] [ to2>> ] bi number= ; inline
-: dump-l  [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
-: dump-r  [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
-: l-next  [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
-: r-next  [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
-: decide  [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
+: l-elt ( merge -- elt ) [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
+
+: r-elt ( merge -- elt ) [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
+
+: l-done? ( merge -- ? ) [ from1>> ] [ to1>> ] bi eq? ; inline
+
+: r-done? ( merge -- ? ) [ from2>> ] [ to2>> ] bi eq? ; inline
+
+: dump-l ( merge -- )
+    [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+
+: dump-r ( merge -- )
+    [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+
+: l-next ( merge -- )
+    [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
+
+: r-next ( merge -- )
+    [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
+
+: decide ( merge -- ? )
+    [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
 
 : (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
     over r-done? [ drop dump-l ] [
@@ -113,7 +126,7 @@ TUPLE: merge
 : sort-loop ( merge quot -- )
     [ 2 [ over seq>> length over > ] ] dip
     [ [ 1 shift 2dup ] dip sort-pass ] curry
-    [ ] while 2drop ; inline
+    while 2drop ; inline
 
 : each-pair ( seq quot -- )
     [ [ length 1+ 2/ ] keep ] dip
@@ -124,9 +137,9 @@ TUPLE: merge
         [ drop nip nth ] dip push
     ] [
         [
-            [ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq?
+            [ [ nth-unsafe ] curry bi@ 2dup ] dip call +gt+ eq?
             [ swap ] when
-        ] dip tuck [ push ] 2bi@
+        ] dip [ push ] curry bi@
     ] if ; inline
 
 : sort-pairs ( merge quot -- )