-(macrolet ((dosequence ((i sequence) &body body)
- (once-only ((sequence sequence))
- `(etypecase ,sequence
- (list (dolist (,i ,sequence) ,@body))
- (simple-vector (dovector (,i sequence) ,@body))
- (vector (dovector (,i sequence) ,@body))))))
- (defun %map-to-list-arity-1 (fun sequence)
- (let ((reversed-result nil)
- (really-fun (%coerce-callable-to-fun fun)))
- (dosequence (element sequence)
- (push (funcall really-fun element)
- reversed-result))
- (nreverse reversed-result)))
- (defun %map-to-simple-vector-arity-1 (fun sequence)
- (let ((result (make-array (length sequence)))
- (index 0)
- (really-fun (%coerce-callable-to-fun fun)))
- (declare (type index index))
- (dosequence (element sequence)
- (setf (aref result index)
- (funcall really-fun element))
- (incf index))
- result))
- (defun %map-for-effect-arity-1 (fun sequence)
- (let ((really-fun (%coerce-callable-to-fun fun)))
- (dosequence (element sequence)
- (funcall really-fun element)))
- nil))
-
-;;; helper functions to handle arity-N subcases of MAP
-;;;
-;;; KLUDGE: This is hairier, and larger, than need be, because we
-;;; don't have DYNAMIC-EXTENT. With DYNAMIC-EXTENT, we could define
-;;; %MAP-FOR-EFFECT, and then implement the
-;;; other %MAP-TO-FOO functions reasonably efficiently by passing closures to
-;;; %MAP-FOR-EFFECT. (DYNAMIC-EXTENT would help a little by avoiding
-;;; consing each closure, and would help a lot by allowing us to define
-;;; a closure (LAMBDA (&REST REST) <do something with (APPLY FUN REST)>)
-;;; with the REST list allocated with DYNAMIC-EXTENT. -- WHN 20000920
-(macrolet (;; Execute BODY in a context where the machinery for
- ;; UPDATED-MAP-APPLY-ARGS has been set up.
- (with-map-state (sequences &body body)
- `(let* ((%sequences ,sequences)
- (%iters (mapcar (lambda (sequence)
- (etypecase sequence
- (list sequence)
- (vector 0)))
- %sequences))
- (%apply-args (make-list (length %sequences))))
- (declare (type list %sequences %iters %apply-args))
- ,@body))
- ;; Return a list of args to pass to APPLY for the next
- ;; function call in the mapping, or NIL if no more function
- ;; calls should be made (because we've reached the end of a
- ;; sequence arg).
- (updated-map-apply-args ()
- '(do ((in-sequences %sequences (cdr in-sequences))
- (in-iters %iters (cdr in-iters))
- (in-apply-args %apply-args (cdr in-apply-args)))
- ((null in-sequences)
- %apply-args)
- (declare (type list in-sequences in-iters in-apply-args))
- (let ((i (car in-iters)))
- (declare (type (or list index) i))
- (if (listp i)
- (if (null i) ; if end of this sequence
- (return nil)
- (setf (car in-apply-args) (car i)
- (car in-iters) (cdr i)))
- (let ((v (the vector (car in-sequences))))
- (if (>= i (length v)) ; if end of this sequence
- (return nil)
- (setf (car in-apply-args) (aref v i)
- (car in-iters) (1+ i)))))))))
- (defun %map-to-list (func sequences)
- (declare (type function func))
- (declare (type list sequences))
- (with-map-state sequences
- (loop with updated-map-apply-args
- while (setf updated-map-apply-args (updated-map-apply-args))
- collect (apply func updated-map-apply-args))))
- (defun %map-to-vector (output-type-spec func sequences)
- (declare (type function func))
- (declare (type list sequences))
- (let ((min-len (with-map-state sequences
- (do ((counter 0 (1+ counter)))
- ;; Note: Doing everything in
- ;; UPDATED-MAP-APPLY-ARGS here is somewhat
- ;; wasteful; we even do some extra consing.
- ;; And stepping over every element of
- ;; VECTORs, instead of just grabbing their
- ;; LENGTH, is also wasteful. But it's easy
- ;; and safe. (If you do rewrite it, please
- ;; try to make sure that
- ;; (MAP NIL #'F SOME-CIRCULAR-LIST #(1))
- ;; does the right thing.)
- ((not (updated-map-apply-args))
- counter)
- (declare (type index counter))))))
- (declare (type index min-len))
- (with-map-state sequences
- (let ((result (make-sequence output-type-spec min-len))
- (index 0))
- (declare (type index index))
- (loop with updated-map-apply-args
- while (setf updated-map-apply-args (updated-map-apply-args))
- do
- (setf (aref result index)
- (apply func updated-map-apply-args))
- (incf index))
- result))))
- (defun %map-for-effect (func sequences)
- (declare (type function func))
- (declare (type list sequences))
- (with-map-state sequences
- (loop with updated-map-apply-args
- while (setf updated-map-apply-args (updated-map-apply-args))
- do
- (apply func updated-map-apply-args))
- nil)))
-
- "FUNCTION must take as many arguments as there are sequences provided.
- The result is a sequence of type OUTPUT-TYPE-SPEC such that element I
- is the result of applying FUNCTION to element I of each of the argument
- sequences."
+(defun %map-to-list-arity-1 (fun sequence)
+ (let ((reversed-result nil)
+ (really-fun (%coerce-callable-to-fun fun)))
+ (sb!sequence:dosequence (element sequence)
+ (push (funcall really-fun element)
+ reversed-result))
+ (nreverse reversed-result)))
+(defun %map-to-simple-vector-arity-1 (fun sequence)
+ (let ((result (make-array (length sequence)))
+ (index 0)
+ (really-fun (%coerce-callable-to-fun fun)))
+ (declare (type index index))
+ (sb!sequence:dosequence (element sequence)
+ (setf (aref result index)
+ (funcall really-fun element))
+ (incf index))
+ result))
+(defun %map-for-effect-arity-1 (fun sequence)
+ (let ((really-fun (%coerce-callable-to-fun fun)))
+ (sb!sequence:dosequence (element sequence)
+ (funcall really-fun element)))
+ nil)
+
+(declaim (maybe-inline %map-for-effect))
+(defun %map-for-effect (fun sequences)
+ (declare (type function fun) (type list sequences))
+ (let ((%sequences sequences)
+ (%iters (mapcar (lambda (s)
+ (seq-dispatch s
+ s
+ 0
+ (multiple-value-list
+ (sb!sequence:make-sequence-iterator s))))
+ sequences))
+ (%apply-args (make-list (length sequences))))
+ ;; this is almost efficient (except in the general case where we
+ ;; trampoline to MAKE-SEQUENCE-ITERATOR; if we had DX allocation
+ ;; of MAKE-LIST, the whole of %MAP would be cons-free.
+ (declare (type list %sequences %iters %apply-args))
+ (loop
+ (do ((in-sequences %sequences (cdr in-sequences))
+ (in-iters %iters (cdr in-iters))
+ (in-apply-args %apply-args (cdr in-apply-args)))
+ ((null in-sequences) (apply fun %apply-args))
+ (let ((i (car in-iters)))
+ (declare (type (or list index) i))
+ (cond
+ ((listp (car in-sequences))
+ (if (null i)
+ (return-from %map-for-effect nil)
+ (setf (car in-apply-args) (car i)
+ (car in-iters) (cdr i))))
+ ((typep i 'index)
+ (let ((v (the vector (car in-sequences))))
+ (if (>= i (length v))
+ (return-from %map-for-effect nil)
+ (setf (car in-apply-args) (aref v i)
+ (car in-iters) (1+ i)))))
+ (t
+ (destructuring-bind (state limit from-end step endp elt &rest ignore)
+ i
+ (declare (type function step endp elt)
+ (ignore ignore))
+ (let ((s (car in-sequences)))
+ (if (funcall endp s state limit from-end)
+ (return-from %map-for-effect nil)
+ (progn
+ (setf (car in-apply-args) (funcall elt s state))
+ (setf (caar in-iters) (funcall step s state from-end)))))))))))))
+(defun %map-to-list (fun sequences)
+ (declare (type function fun)
+ (type list sequences))
+ (let ((result nil))
+ (flet ((f (&rest args)
+ (declare (truly-dynamic-extent args))
+ (push (apply fun args) result)))
+ (declare (truly-dynamic-extent #'f))
+ (%map-for-effect #'f sequences))
+ (nreverse result)))
+(defun %map-to-vector (output-type-spec 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 output-type-spec min-len))
+ (i 0))
+ (declare (type (simple-array * (*)) result))
+ (flet ((f (&rest args)
+ (declare (truly-dynamic-extent args))
+ (setf (aref result i) (apply fun args))
+ (incf i)))
+ (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)))
projects / sbcl.git / blobdiff