From c4ecc5719262bd9e360a21418826dbe1fa35f4b2 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 15 Mar 2021 20:41:49 -0700 Subject: add OS:TYPECASE Signed-off-by: Sean Whitton --- src/propspec.lisp | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) (limited to 'src/propspec.lisp') diff --git a/src/propspec.lisp b/src/propspec.lisp index 5f7b138..7f2019d 100644 --- a/src/propspec.lisp +++ b/src/propspec.lisp @@ -323,3 +323,27 @@ application specification expression to a property application specification." :apply (get psym 'unapply) :unapply (get psym 'apply) :args args))) + +;; TODO should move this into property/os.lisp once we determine the API for +;; property combinator helper macros +(define-function-property-combinator os-typecase* (&rest cases) + (flet ((choose-propapp () + (or (loop with host = (class-of (get-hostattrs-car :os)) + for (type propapp) on cases by #'cddr + when (subtypep host type) return propapp) + (error 'inapplicable-property + :text "Host's OS fell through OS:TYPECASE.")))) + (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))) + :check (lambda (&rest args) + (declare (ignore args)) + (propappcheck (choose-propapp))) + :apply (lambda (&rest args) + (declare (ignore args)) + (propappapply (choose-propapp))) + :unapply (lambda (&rest args) + (declare (ignore args)) + (propappunapply (choose-propapp)))))) -- cgit v1.2.3