diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2021-04-02 16:10:04 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-04-02 16:13:32 -0700 |
| commit | 76c3ac60450fb144bf6cfd0fb4197b91af5a3f87 (patch) | |
| tree | e243c625c95625cd3ac7635b9ff764037eb86a73 /src/property/os.lisp | |
| parent | fc6d35b5bf33d6a5fcba9c44a769e653fa6712fa (diff) | |
| download | consfigurator-76c3ac60450fb144bf6cfd0fb4197b91af5a3f87.tar.gz | |
factor out DEFINE-CHOOSING-PROPERTY-COMBINATOR
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
Diffstat (limited to 'src/property/os.lisp')
| -rw-r--r-- | src/property/os.lisp | 35 |
1 files changed, 11 insertions, 24 deletions
diff --git a/src/property/os.lisp b/src/property/os.lisp index 934dec8..04ac5ab 100644 --- a/src/property/os.lisp +++ b/src/property/os.lisp @@ -83,30 +83,17 @@ ;;;; Property combinators -(define-function-property-combinator os-etypecase* (host &rest cases) - (flet ((choose-propapp () - (or (loop with os = (class-of (if host - (car (getf (hostattrs host) :os)) - (get-hostattrs-car :os))) - for (type propapp) on cases by #'cddr - when (subtypep os type) return propapp) - (inapplicable-property - "Host's OS ~S fell through OS:ETYPECASE." - (class-of (get-hostattrs-car :os)))))) - (:retprop :type (collapse-types (loop for propapp in (cdr cases) by #'cddr - collect (propapptype propapp))) - :desc (lambda (&rest args) - (declare (ignore args)) - (propappdesc (choose-propapp))) - :hostattrs (lambda (&rest args) - (declare (ignore args)) - (propappattrs (choose-propapp))) - :apply (lambda (&rest args) - (declare (ignore args)) - (propappapply (choose-propapp))) - :unapply (lambda (&rest args) - (declare (ignore args)) - (propappunapply (choose-propapp)))))) +(define-choosing-property-combinator os-etypecase* (host &rest cases) + :type (collapse-types (loop for propapp in (cdr cases) by #'cddr + collect (propapptype propapp))) + :choose (or (loop with os = (class-of (if host + (car (getf (hostattrs host) :os)) + (get-hostattrs-car :os))) + for (type propapp) on cases by #'cddr + when (subtypep os type) return propapp) + (inapplicable-property + "Host's OS ~S fell through OS:ETYPECASE." + (class-of (get-hostattrs-car :os))))) (defmacro etypecase (&body cases) `(host-etypecase nil ,@cases)) |