From 0812d212b9d8c6414bc40e6b738f4cef91adb174 Mon Sep 17 00:00:00 2001 From: Sean Whitton 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 --- src/property/disk.lisp | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) (limited to 'src/property/disk.lisp') 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 -- cgit v1.2.3