mvfold.lisp

(declaim (inline mvfold mvfold!))
#-sbcl
(defun mvfold (f initf &rest lsts)
  (declare (dynamic-extent lsts))
  (declare (optimize (speed 3)))
  (when (or (null lsts) (some #'null lsts))
    (return-from mvfold (funcall initf)))
  (let ((acc (multiple-value-list (funcall initf))))
    (do ()
      ((progn
         (setf acc
               (multiple-value-list
                 (multiple-value-call
                   f
                   (values-list acc)
                   (values-list (mapcar #'car lsts)))))
         (do ((rst lsts (cdr rst)))
             ((null rst))
           (setf (car rst) (cdar rst)))
         (some #'null lsts))
       (values-list acc)))))

#+sbcl
(defun mvfold (f initf &rest lsts)
  (declare (dynamic-extent lsts))
  (declare (optimize (speed 3)))
  (when (null lsts)
    (return-from mvfold (funcall initf)))
  (labels ((iter (&rest acc)
             (declare (dynamic-extent acc))
             (if (some #'null lsts)
               (values-list acc)
               (multiple-value-call #'iter
                 (multiple-value-call f
                   (values-list acc)
                   (values-list
                     (prog1 (mapcar #'car lsts)
                       (do ((rst lsts (cdr rst)))
                           ((null rst))
                         (setf (car rst) (cdar rst))))))))))
    (multiple-value-call #'iter (funcall initf))))

#-sbcl
(defun mvfold! (f initf &rest lsts)
  (declare (dynamic-extent lsts))
  (declare (optimize (speed 3)))
  (when (or (null lsts) (some #'null lsts))
    (return-from mvfold! (funcall initf)))
  (let ((acc (multiple-value-list (funcall initf))))
    (do ()
      ((progn
         (setf acc
               (multiple-value-list
                 (multiple-value-call f
                   (values-list acc)
                   (values-list
                     (let* ((lst (car lsts))
                            (vals lst))
                       (rplaca lsts (cdr lst))
                       (rplacd lst nil)
                       (do ((lsts-rest (cdr lsts) (cdr lsts-rest))
                            (vals-last vals (cdr vals-last)))
                           ((null lsts-rest) vals)
                         (let ((lst (car lsts-rest)))
                           (rplaca lsts-rest (cdr lst))
                           (rplacd vals-last lst)
                           (rplacd lst nil))))))))
         (some #'null lsts))
       (values-list acc)))))

#+sbcl
(defun mvfold! (f initf &rest lsts)
  (declare (dynamic-extent lsts))
  (declare (optimize (speed 3)))
  (when (null lsts)
    (return-from mvfold! (funcall initf)))
  (labels ((iter (&rest acc)
             (declare (dynamic-extent acc))
             (if (some #'null lsts)
               (values-list acc)
               (multiple-value-call #'iter
                 (multiple-value-call f
                   (values-list acc)
                   (values-list
                     (let ((lst (car lsts)) vals)
                       (psetf vals lst
                              (car lsts) (cdr lst)
                              (cdr lst) nil)
                       (do ((lsts-rest (cdr lsts) (cdr lsts-rest))
                            (vals-last vals (cdr vals-last)))
                           ((null lsts-rest) vals)
                         (let ((lst (car lsts-rest)))
                           (psetf (car lsts-rest) (cdr lst)
                                  (cdr vals-last) lst
                                  (cdr lst) nil))))))))))
    (multiple-value-call #'iter (funcall initf))))

mvfold.ss

(define-values (mvfold mvfold!)
  (begin
    (define (any f xs)
      (if (null? xs)
        #f
        (or (f (car xs)) (any f (cdr xs)))))
    (define (mvfold f initf . lsts)
      (define (acc . vals)
        (if (any null? lsts)
          (apply values vals)
          (call-with-values
           (lambda ()
             (apply f
              (append
               vals
               (let ((xs (map car lsts)))
                 (do ((rst lsts (cdr rst)))
                     ((null? rst) xs)
                   (set-car! rst (cdar rst)))))))
           acc)))
      (if (null? lsts)
        (initf)
        (call-with-values initf acc)))
    (define (mvfold! f initf . lsts)
      (define (acc . vals)
        (if (any null? lsts)
          (apply values vals)
          (call-with-values
           (lambda ()
             (apply f
              (append!
               vals
               (let* ((lst (car lsts))
                      (vals lst))
                 (set-car! lsts (cdr lst))
                 (set-cdr! lst '())
                 (do ((lsts-rest (cdr lsts) (cdr lsts-rest))
                      (vals-last vals (cdr vals-last)))
                     ((null? lsts-rest) vals)
                   (let ((lst (car lsts-rest)))
                     (set-car! lsts-rest (cdr lst))
                     (set-cdr! vals-last lst)
                     (set-cdr! lst '())))))))
           acc)))
      (if (null? lsts)
        (initf)
        (call-with-values initf acc)))
    (values mvfold mvfold!)))