From 0812d212b9d8c6414bc40e6b738f4cef91adb174 Mon Sep 17 00:00:00 2001
From: Sean Whitton <spwhitton@spwhitton.name>
Date: Thu, 3 Jun 2021 10:11:00 -0700
Subject: DISK:SUBVOLUMES-OF-TYPE: return list of immediate parents as 2nd val

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
---
 src/package.lisp       |  1 +
 src/property/disk.lisp | 21 +++++++++++++--------
 src/util.lisp          | 17 +++++++++++++++++
 3 files changed, 31 insertions(+), 8 deletions(-)

diff --git a/src/package.lisp b/src/package.lisp
index 2fd2a95..07c87f7 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -65,6 +65,7 @@
            #:compile-file-pathname*
 
            ;; util.lisp
+           #:multiple-value-mapcan
            #:lines
            #:unlines
            #:words
diff --git a/src/property/disk.lisp b/src/property/disk.lisp
index 82da591..398969f 100644
--- a/src/property/disk.lisp
+++ b/src/property/disk.lisp
@@ -91,16 +91,21 @@ subsequently replace the copied values of some slots.")
 (defgeneric subvolumes-of-type (type volume)
   (:documentation
    "Recursively examine VOLUME and its VOLUME-CONTENTS and return a list of all
-volumes encountered whose type is a subtype of TYPE.")
+volumes encountered whose type is a subtype of TYPE.
+Returns as a second value a corresponding list of the immediate parents of
+each returned volume.")
   (:method ((type symbol) (volume volume))
-    (labels ((walk (volume)
-               (let ((contents
-                       (and (slot-boundp volume 'volume-contents)
-                            (mapcan #'walk
-                                    (ensure-cons (volume-contents volume))))))
+    (labels ((walk (volume parent &aux (second-arg (list volume)))
+               (multiple-value-bind (contents contents-parents)
+                   (and (slot-boundp volume 'volume-contents)
+                        (multiple-value-mapcan
+                         #'walk (ensure-cons (volume-contents volume))
+                         (rplacd second-arg second-arg)))
                  (if (subtypep (type-of volume) type)
-                     (cons volume contents) contents))))
-      (walk volume))))
+                     (values (cons volume contents)
+                             (cons parent contents-parents))
+                     (values contents contents-parents)))))
+      (walk volume nil))))
 
 (defgeneric all-subvolumes (volume)
   (:documentation
diff --git a/src/util.lisp b/src/util.lisp
index 9d50a17..3675698 100644
--- a/src/util.lisp
+++ b/src/util.lisp
@@ -18,6 +18,23 @@
 (in-package :consfigurator)
 (named-readtables:in-readtable :consfigurator)
 
+(defun multiple-value-mapcan (function &rest lists)
+  "Variant of MAPCAN which preserves multiple return values."
+  (let ((lists (copy-list lists))
+        (results (make-array '(2) :initial-element nil :adjustable t)))
+    (loop for new-results
+            = (multiple-value-list
+               (apply function
+                      (loop for list on lists
+                            if (car list)
+                              collect (pop (car list))
+                            else do (return-from multiple-value-mapcan
+                                      (values-list (coerce results 'list))))))
+          do (adjust-array results (max (length results) (length new-results))
+                           :initial-element nil)
+             (loop for result in new-results and i upfrom 0
+                   do (nconcf (aref results i) result)))))
+
 (defun noop (&rest args)
   "Accept any arguments and do nothing."
   (declare (ignore args))
-- 
cgit v1.2.3