diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2021-06-03 10:11:00 -0700 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-06-03 10:47:00 -0700 |
commit | 0812d212b9d8c6414bc40e6b738f4cef91adb174 (patch) | |
tree | e36a4df7eb571a0d55983b818b9387d6c98a8874 | |
parent | 57311c9b05166f81a2fdeee544252e580a46e3a4 (diff) | |
download | consfigurator-0812d212b9d8c6414bc40e6b738f4cef91adb174.tar.gz |
DISK:SUBVOLUMES-OF-TYPE: return list of immediate parents as 2nd val
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
-rw-r--r-- | src/package.lisp | 1 | ||||
-rw-r--r-- | src/property/disk.lisp | 21 | ||||
-rw-r--r-- | 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)) |