From: John Benediktsson <mrjbq7@gmail.com>
Date: Mon, 30 Nov 2020 21:01:29 +0000 (-0800)
Subject: sequences.extras: make loop>array faster using produce.
X-Git-Tag: 0.99~2876
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=3a73685f26d7d6e122a18773c4710a330b16ca9c

sequences.extras: make loop>array faster using produce.
---

diff --git a/extra/sequences/extras/extras.factor b/extra/sequences/extras/extras.factor
index 5fa817f77b..86f00f293b 100644
--- a/extra/sequences/extras/extras.factor
+++ b/extra/sequences/extras/extras.factor
@@ -444,31 +444,23 @@ PRIVATE>
 : last? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) [ last ] dip call ; inline
 : nth? ( ... n seq quot: ( ... elt -- ... ? ) -- ... ? ) [ nth ] dip call ; inline
 
-: loop>sequence ( quot: ( ..a -- ..a obj/f ) exemplar -- seq )
-   [ '[ [ @ [ [ , ] when* ] keep ] loop ] ] dip make ; inline
+: loop>sequence** ( ... quot: ( ... -- ... obj ? ) exemplar -- ... seq )
+    [ ] swap produce-as nip ; inline
 
-: loop>array ( quot: ( ..a -- ..a obj/f ) -- array )
-   { } loop>sequence ; inline
+: loop>array** ( ... quot: ( ... -- ... obj ? ) -- ... array )
+    { } loop>sequence** ; inline
 
-: loop>sequence* ( quot: ( ..a -- ..a obj ? ) exemplar -- seq )
+: loop>sequence* ( ... quot: ( ... -- ... obj ? ) exemplar -- ... seq )
     [ '[ [ @ [ [ , ] when* ] [ ] bi* ] loop ] ] dip make ; inline
 
-: loop>array* ( quot: ( ..a -- ..a obj ? ) -- array )
-   { } loop>sequence* ; inline
+: loop>array* ( ... quot: ( ... -- ... obj ? ) -- ... array )
+    { } loop>sequence* ; inline
 
-: loop>sequence** ( quot: ( ..a -- ..a obj ? ) exemplar -- seq )
-    [
-        '[
-            [
-                @
-                [ [ , ] [ drop ] if ]
-                [ nip ] 2bi
-            ] loop
-        ]
-    ] dip make ; inline
-
-: loop>array** ( quot: ( ..a -- ..a obj ? ) -- array )
-   { } loop>sequence** ; inline
+: loop>sequence ( ... quot: ( ... -- ... obj/f ) exemplar -- ... seq )
+    [ [ dup ] compose ] dip loop>sequence** ; inline
+
+: loop>array ( ... quot: ( ... -- ... obj/f ) -- ... array )
+   { } loop>sequence ; inline
 
 : with-pre-incrementer ( quot: ( ..a n -- ..a obj/f ) seq -- quot: ( ..a n -- ..a obj/f ) )
     [ -1 ] 2dip