+;;; Return a DO loop, mapping a function FUN to elements of
+;;; sequences. SEQS is a list of lvars, SEQ-NAMES - list of variables,
+;;; bound to sequences, INTO - a variable, which is used in
+;;; MAP-INTO. RESULT and BODY are forms, which can use variables
+;;; FUNCALL-RESULT, containing the result of application of FUN, and
+;;; INDEX, containing the current position in sequences.
+(defun build-sequence-iterator (seqs seq-names &key result into body)
+ (declare (type list seqs seq-names)
+ (type symbol into))
+ (collect ((bindings)
+ (declarations)
+ (vector-lengths)
+ (tests)
+ (places))
+ (let ((found-vector-p nil))
+ (flet ((process-vector (length)
+ (unless found-vector-p
+ (setq found-vector-p t)
+ (bindings `(index 0 (1+ index)))
+ (declarations `(type index index)))
+ (vector-lengths length)))
+ (loop for seq of-type lvar in seqs
+ for seq-name in seq-names
+ for type = (lvar-type seq)
+ do (cond ((csubtypep type (specifier-type 'list))
+ (with-unique-names (index)
+ (bindings `(,index ,seq-name (cdr ,index)))
+ (declarations `(type list ,index))
+ (places `(car ,index))
+ (tests `(endp ,index))))
+ ((csubtypep type (specifier-type 'vector))
+ (process-vector `(length ,seq-name))
+ (places `(aref ,seq-name index)))
+ (t
+ (give-up-ir1-transform
+ "can't determine sequence argument type"))))
+ (when into
+ (process-vector `(array-dimension ,into 0))))
+ (when found-vector-p
+ (bindings `(length (min ,@(vector-lengths))))
+ (tests `(= index length)))
+ `(do (,@(bindings))
+ ((or ,@(tests)) ,result)
+ (declare ,@(declarations))
+ (let ((funcall-result (funcall fun ,@(places))))
+ (declare (ignorable funcall-result))
+ ,body)))))
+