add OS:TYPECASE

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

1 files changed, 24 insertions, 0 deletions

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))))))