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/util.lisp | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 'src/util.lisp') 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