diff options
| -rw-r--r-- | src/combinator.lisp | 18 | ||||
| -rw-r--r-- | src/package.lisp | 1 | ||||
| -rw-r--r-- | src/property/os.lisp | 35 |
3 files changed, 30 insertions, 24 deletions
diff --git a/src/combinator.lisp b/src/combinator.lisp index ee70d62..3c1d21d 100644 --- a/src/combinator.lisp +++ b/src/combinator.lisp @@ -33,6 +33,24 @@ (return-from ,name (list* psym args))))) ,@forms)))) +(defmacro define-choosing-property-combinator + (name lambda-list &key type choose) + `(define-function-property-combinator ,name ,lambda-list + (flet ((choose-propapp () ,choose)) + (:retprop :type ,type + :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))))))) + (defmacro with-skip-failed-changes (&body forms) `(handler-bind ((failed-change (lambda (c) diff --git a/src/package.lisp b/src/package.lisp index 24e4b2a..c870ad2 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -144,6 +144,7 @@ ;; combinator.lisp #:define-function-property-combinator + #:define-choosing-property-combinator #:seqprops #:eseqprops #:with-requirements 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)) |