From 0583c47459320ebe9fd7ede055ca93a1853a235d Mon Sep 17 00:00:00 2001
From: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
Date: Sun, 3 Aug 2014 10:04:54 +0200
Subject: [PATCH] MAP calls SB-SEQUENCE:MAP for extended sequences

---
 package-data-list.lisp-expr |  1 +
 src/code/seq.lisp           | 28 +++++---------------------
 src/pcl/sequence.lisp       | 48 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 54 insertions(+), 23 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 514554080..a6ed05846 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2445,6 +2445,7 @@ be submitted as a CDR"
                "EMPTYP" "LENGTH" "ELT"
                "MAKE-SEQUENCE-LIKE" "ADJUST-SEQUENCE"
 
+               "MAP"
                "COUNT" "COUNT-IF" "COUNT-IF-NOT"
                "FIND" "FIND-IF" "FIND-IF-NOT"
                "POSITION" "POSITION-IF" "POSITION-IF-NOT"
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index d69022982..dbeb4d306 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -1049,27 +1049,6 @@ many elements are copied."
         (declare (truly-dynamic-extent #'f))
         (%map-for-effect #'f sequences))
       result)))
-(defun %map-to-sequence (result-type fun sequences)
-  (declare (type function fun)
-           (type list sequences))
-  (let ((min-len 0))
-    (flet ((f (&rest args)
-             (declare (truly-dynamic-extent args))
-             (declare (ignore args))
-             (incf min-len)))
-      (declare (truly-dynamic-extent #'f))
-      (%map-for-effect #'f sequences))
-    (let ((result (make-sequence result-type min-len)))
-      (multiple-value-bind (state limit from-end step endp elt setelt)
-          (sb!sequence:make-sequence-iterator result)
-        (declare (ignore limit endp elt))
-        (flet ((f (&rest args)
-                 (declare (truly-dynamic-extent args))
-                 (funcall setelt (apply fun args) result state)
-                 (setq state (funcall step result state from-end))))
-          (declare (truly-dynamic-extent #'f))
-          (%map-for-effect #'f sequences)))
-      result)))
 
 ;;; %MAP is just MAP without the final just-to-be-sure check that
 ;;; length of the output sequence matches any length specified
@@ -1086,8 +1065,11 @@ many elements are copied."
                  ((csubtypep type (specifier-type 'vector))
                   (%map-to-vector result-type really-fun sequences))
                  ((and (csubtypep type (specifier-type 'sequence))
-                       (find-class result-type nil))
-                  (%map-to-sequence result-type really-fun sequences))
+                       (awhen (find-class result-type nil)
+                         (apply #'sb!sequence:map
+                                (sb!mop:class-prototype
+                                 (sb!pcl:ensure-class-finalized it))
+                                really-fun sequences))))
                  (t
                   (bad-sequence-type-error result-type)))))
            (slow-map ()
diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp
index 42581f75d..27c19e11d 100644
--- a/src/pcl/sequence.lisp
+++ b/src/pcl/sequence.lisp
@@ -378,6 +378,54 @@
 
 ;;;; generic implementations for sequence functions.
 
+(defgeneric sequence:map (result-prototype function sequence &rest sequences)
+  #+sb-doc
+  (:documentation
+   "Implements CL:MAP for extended sequences.
+
+    RESULT-PROTOTYPE corresponds to the RESULT-TYPE of CL:MAP but
+    receives a prototype instance of an extended sequence class
+    instead of a type specifier. By dispatching on RESULT-PROTOTYPE,
+    methods on this generic function specify how extended sequence
+    classes act when they are specified as the result type in a CL:MAP
+    call. RESULT-PROTOTYPE may not be fully initialized and thus
+    should only be used for dispatch and to determine its class.
+
+    Another difference to CL:MAP is that FUNCTION is a function, not a
+    function designator."))
+
+(defmethod sequence:map ((result-prototype sequence) (function function)
+                         (sequence sequence) &rest sequences)
+  (let ((sequences (list* sequence sequences))
+        (min-length 0))
+    (declare (dynamic-extent sequences))
+    ;; Visit elements of SEQUENCES in parallel to determine length of
+    ;; the result. Determining the length of the result like this
+    ;; allows cases like
+    ;;
+    ;;   (map 'my-sequence 'my-fun (circular-list 1 2 3) '(4 5 6))
+    ;;
+    ;; to return a sequence with three elements.
+    (flet ((counting-visit (&rest args)
+             (declare (truly-dynamic-extent args)
+                      (ignore args))
+             (incf min-length)))
+      (declare (truly-dynamic-extent #'counting-visit))
+      (%map-for-effect #'counting-visit sequences))
+    ;; Map local function over SEQUENCES that steps through the result
+    ;; sequence and stores results of applying FUNCTION.
+    (binding* ((result (make-sequence (class-of result-prototype) min-length))
+               ((state nil from-end step nil nil setelt)
+                (sequence:make-sequence-iterator result)))
+      (declare (type function state step setelt))
+      (flet ((one-element (&rest args)
+               (declare (truly-dynamic-extent args))
+               (funcall setelt (apply function args) result state)
+               (setq state (funcall step result state from-end))))
+        (declare (truly-dynamic-extent #'one-element))
+        (%map-for-effect #'one-element sequences))
+      result)))
+
 ;;; FIXME: COUNT, POSITION and FIND share an awful lot of structure.
 ;;; They could usefully be defined in an OAOO way.
 (defgeneric sequence:count
-- 
2.11.4.GIT