From 6b7bbf81c281587766961638f44f2a0a9f8f0d98 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Sun, 27 Apr 2003 13:58:59 +0000
Subject: [PATCH] Borrow SBCL's new deftransform for map-into to speed up
 map-into.

---
 compiler/fndb.lisp    |  7 ++++++-
 compiler/seqtran.lisp | 33 ++++++++++++++++++++++++++++++++-
 2 files changed, 38 insertions(+), 2 deletions(-)

diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
index e72e45933..99428b6c5 100644
--- a/compiler/fndb.lisp
+++ b/compiler/fndb.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.112 2003/04/26 19:34:52 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.113 2003/04/27 13:58:59 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -416,6 +416,11 @@
 ;  :derive-type 'type-spec-arg1  Nope... (map nil ...) returns null, not nil.
   )
 
+(defknown map-into (sequence callable &rest sequence)
+  sequence
+  (call)
+  :derive-type #'result-type-first-arg)
+
 ;;; Returns predicate result... 
 (defknown some (callable sequence &rest sequence) t
   (foldable flushable call))
diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp
index 79fba8c07..ead63aeb6 100644
--- a/compiler/seqtran.lisp
+++ b/compiler/seqtran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.26 2003/04/21 15:56:31 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.27 2003/04/27 13:58:59 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -70,6 +70,37 @@
 (def-source-transform mapcon (function list &rest more-lists)
   (mapper-transform function (cons list more-lists) :nconc nil))
 
+
+;;; MAP-INTO
+(deftransform map-into ((result fun &rest seqs)
+                        (vector * &rest *)
+                        *)
+  "open code"
+  (let ((seqs-names (mapcar (lambda (x)
+                              (declare (ignore x))
+                              (gensym))
+                            seqs)))
+    `(lambda (result fun ,@seqs-names)
+       (let ((length (array-dimension result 0))
+             (i 0))
+         (declare (type index i))
+         (declare (ignorable i))
+         ,(cond ((null seqs)
+                 `(dotimes (j length (setq i length))
+                    (setf (aref result j) (funcall fun))))
+                (t
+                 `(block nil
+                    (map nil
+                         (lambda (,@seqs-names)
+                           (when (= i length) (return))
+                           (setf (aref result i)
+                                 (funcall fun ,@seqs-names))
+                           (incf i))
+                         ,@seqs-names))))
+         (when (array-has-fill-pointer-p result)
+           (setf (fill-pointer result) i))
+         result))))
+
 (deftransform elt ((s i) ((simple-array * (*)) *) * :when :both)
   '(aref s i))
 
-- 
GitLab