-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro map-to-list (function sequences)
- `(do ((seqs more-sequences (cdr seqs))
- (min-length (length first-sequence)))
- ((null seqs)
- (let ((result (list nil)))
- (do ((index 0 (1+ index))
- (splice result))
- ((= index min-length) (cdr result))
- (declare (fixnum index))
- (setq splice
- (cdr (rplacd splice
- (list (apply ,function (elt-slice ,sequences
- index)))))))))
- (declare (fixnum min-length))
- (let ((length (length (car seqs))))
- (declare (fixnum length))
- (if (< length min-length)
- (setq min-length length)))))
-
-(sb!xc:defmacro map-to-simple (output-type-spec function sequences)
- `(do ((seqs more-sequences (cdr seqs))
- (min-length (length first-sequence)))
- ((null seqs)
- (do ((index 0 (1+ index))
- (result (make-sequence-of-type ,output-type-spec min-length)))
- ((= index min-length) result)
- (declare (fixnum index))
- (setf (aref result index)
- (apply ,function (elt-slice ,sequences index)))))
- (declare (fixnum min-length))
- (let ((length (length (car seqs))))
- (declare (fixnum length))
- (if (< length min-length)
- (setq min-length length)))))
-
-(sb!xc:defmacro map-for-effect (function sequences)
- `(do ((seqs more-sequences (cdr seqs))
- (min-length (length first-sequence)))
- ((null seqs)
- (do ((index 0 (1+ index)))
- ((= index min-length) nil)
- (apply ,function (elt-slice ,sequences index))))
- (declare (fixnum min-length))
- (let ((length (length (car seqs))))
- (declare (fixnum length))
- (if (< length min-length)
- (setq min-length length)))))
-
-) ; EVAL-WHEN
-
-#!+high-security-support
-(defun get-minimum-length-sequences (sequences)
- #!+sb-doc "Gets the minimum length of the sequences. This is
-needed to check whether the supplied type is appropriate."
- (let ((min nil))
- (dolist (i sequences)
- (when (or (listp i) (vectorp i))
- (let ((l (length i)))
- (when (or (null min)
- (> min l)))
- (setf min l))))
- min))
-
-(defun map (output-type-spec function first-sequence &rest more-sequences)
- #!+sb-doc
- "FUNCTION must take as many arguments as there are sequences provided. The
- result is a sequence such that element i is the result of applying FUNCTION
- to element i of each of the argument sequences."
- (let ((really-function (if (functionp function)
- function
- (%coerce-name-to-function function))))
- ;; Pick off the easy non-consing arity-1 special case and handle
- ;; it without consing, since the user probably didn't expect us to
- ;; cons here. (Notably, the super duper users who wrote PCL in
- ;; terms of quantifiers without declaring the types of their
- ;; sequence arguments didn't expect to end up consing when SBCL
- ;; transforms the quantifiers into calls to MAP NIL.)
- (when (and (null more-sequences)
- (null output-type-spec))
- (macrolet ((frob () '(return-from map
- (map nil really-function first-sequence))))
- (etypecase first-sequence
- (simple-vector (frob))
- (list (frob))
- (vector (frob)))))
- ;; Otherwise, if the user didn't give us enough information to
- ;; simplify at compile time, we cons and cons and cons..
- (let ((sequences (cons first-sequence more-sequences)))
- (case (type-specifier-atom output-type-spec)
- ((nil) (map-for-effect really-function sequences))
- (list (map-to-list really-function sequences))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string simple-base-string)
- #!+high-security
- (let ((min-length-sequences (get-minimum-length-sequences
- sequences))
- (dimensions (array-type-dimensions (specifier-type
- output-type-spec))))
- (when (or (/= (length dimensions) 1)
- (and (not (eq (car dimensions) '*))
- (/= (car dimensions) min-length-sequences)))
- (error 'simple-type-error
- :datum output-type-spec
- :expected-type
- (ecase (type-specifier-atom output-type-spec)
- ((simple-vector bit-vector simple-bit-vector string simple-string base-string)
- `(,(type-specifier-atom output-type-spec) ,min-length-sequences))
- ((array vector simple-array) `(,(type-specifier-atom output-type-spec) * ,min-length-sequences)))
- :format-control "Minimum length of sequences is ~S, this is not compatible with the type ~S."
- :format-arguments
- (list min-length-sequences output-type-spec))))
- (let ((result (map-to-simple output-type-spec
- really-function
- sequences)))
- #!+high-security
- (check-type-var result output-type-spec)
- result))
- (t
- (apply #'map (result-type-or-lose output-type-spec t)
- really-function sequences))))))
-
-#!+high-security-support
-(defun map-without-errorchecking
- (output-type-spec function first-sequence &rest more-sequences)
- #!+sb-doc
- "FUNCTION must take as many arguments as there are sequences provided. The
- result is a sequence such that element i is the result of applying FUNCTION
- to element I of each of the argument sequences. This version has no
- error-checking, to pass cold-load."
- (let ((sequences (cons first-sequence more-sequences)))
- (case (type-specifier-atom output-type-spec)
- ((nil) (map-for-effect function sequences))
- (list (map-to-list function sequences))
- ((simple-vector simple-string vector string array simple-array
- bit-vector simple-bit-vector base-string simple-base-string)
- (map-to-simple output-type-spec function sequences))
- (t
- (apply #'map (result-type-or-lose output-type-spec t)
- function sequences)))))
-
+;;; %MAP is just MAP without the final just-to-be-sure check that
+;;; length of the output sequence matches any length specified
+;;; in RESULT-TYPE.
+(defun %map (result-type function first-sequence &rest more-sequences)
+ (let ((really-fun (%coerce-callable-to-fun function))
+ (type (specifier-type result-type)))
+ ;; Handle one-argument MAP NIL specially, using ETYPECASE to turn
+ ;; it into something which can be DEFTRANSFORMed away. (It's
+ ;; fairly important to handle this case efficiently, since
+ ;; quantifiers like SOME are transformed into this case, and since
+ ;; there's no consing overhead to dwarf our inefficiency.)
+ (if (and (null more-sequences)
+ (null result-type))
+ (%map-for-effect-arity-1 really-fun first-sequence)
+ ;; Otherwise, use the industrial-strength full-generality
+ ;; approach, consing O(N-ARGS) temporary storage (which can have
+ ;; DYNAMIC-EXTENT), then using O(N-ARGS * RESULT-LENGTH) time.
+ (let ((sequences (cons first-sequence more-sequences)))
+ (cond
+ ((eq type *empty-type*) (%map-for-effect really-fun sequences))
+ ((csubtypep type (specifier-type 'list))
+ (%map-to-list really-fun sequences))
+ ((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))
+ (t
+ (bad-sequence-type-error result-type)))))))
+
+(defun map (result-type function first-sequence &rest more-sequences)
+ (apply #'%map
+ result-type
+ function
+ first-sequence
+ more-sequences))
+
+;;;; MAP-INTO
+
+(defmacro map-into-lambda (sequences params &body body)
+ (check-type sequences symbol)
+ `(flet ((f ,params ,@body))
+ (declare (truly-dynamic-extent #'f))
+ ;; Note (MAP-INTO SEQ (LAMBDA () ...)) is a different animal,
+ ;; hence the awkward flip between MAP and LOOP.
+ (if ,sequences
+ (apply #'map nil #'f ,sequences)
+ (loop (f)))))
+
+(define-array-dispatch vector-map-into (data start end fun sequences)
+ (declare (optimize speed (safety 0))
+ (type index start end)
+ (type function fun)
+ (type list sequences))
+ (let ((index start))
+ (declare (type index index))
+ (block mapping
+ (map-into-lambda sequences (&rest args)
+ (declare (truly-dynamic-extent args))
+ (when (eql index end)
+ (return-from mapping))
+ (setf (aref data index) (apply fun args))
+ (incf index)))
+ index))
+
+;;; Uses the machinery of (MAP NIL ...). For non-vectors we avoid
+;;; computing the length of the result sequence since we can detect
+;;; the end during mapping (if MAP even gets that far).
+;;;
+;;; For each result type, define a mapping function which is
+;;; responsible for replacing RESULT-SEQUENCE elements and for
+;;; terminating itself if the end of RESULT-SEQUENCE is reached.
+;;; The mapping function is defined with MAP-INTO-LAMBDA.
+;;;
+;;; MAP-INTO-LAMBDAs are optimized since they are the inner loops.
+;;; Because we are manually doing bounds checking with known types,
+;;; safety is turned off for vectors and lists but kept for generic
+;;; sequences.