[lgtk-cvs] CVS update: lgtk/src/enums.lisp - lgtk-cvs@common-lisp.net - mailman3.common-lisp.net

15 Jun 2004

Update of /project/lgtk/cvsroot/lgtk/src
In directory common-lisp.net:/tmp/cvs-serv13382
Modified Files:
    enums.lisp 
Log Message:
Use a symbol for satisfies type specifier (patch by Tim Daly Jr.)
Date: Tue Jun 15 09:01:54 2004
Author: mmommer
Index: lgtk/src/enums.lisp
diff -u lgtk/src/enums.lisp:1.2 lgtk/src/enums.lisp:1.3

--- lgtk/src/enums.lisp:1.2	Wed Nov  5 09:49:56 2003
+++ lgtk/src/enums.lisp	Tue Jun 15 09:01:54 2004
@@ -98,44 +98,49 @@
     (ast (alistize stuff))
     (msk (if bitwise (reduce #'logior ast :key #'cdr)))
     (arg (gensym))
+	 (predicate-name (intern (format nil "~A-p" symb) :enum-land))
     tconds)
(if (and strict (not bitwise))
-	(push `(satisfies
-		(lambda (,arg)
-		  (rassoc ,arg (edata-alist ,symb)))) tconds))
+	(push `(lambda (,arg)
+		(rassoc ,arg (edata-alist ,symb)))
+	      tconds))
(if (and bitwise strict)
-	(push `(satisfies
-		(lambda (,arg)
-		  (= ,msk (logior ,arg ,msk))))
+	(push `(lambda (,arg)
+		(= ,msk (logior ,arg ,msk)))
          tconds))
;; always
-    (push `(satisfies
-	    (lambda (,arg)
-	      (assoc ,arg (edata-alist ,symb)))) tconds)
+    (push `(lambda (,arg)
+	    (assoc ,arg (edata-alist ,symb)))
+	  tconds)
(if (not strict)
-	(push '(satisfies fixnump) tconds))
+	(push 'fixnump tconds))
`(eval-when (:compile-toplevel :load-toplevel :execute)
-       (defparameter ,symb
-	 (make-edata :alist (quote ,ast)
-		     :strict ,strict
-		     :bitwise ,bitwise
-		     :mask ,msk))
-
-       (setf (get ',name 'enum) ,symb)
-
-       (deftype ,name ()
-	 `(or . ,',tconds))
-
-       (defmacro ,name (,arg)
-	 `(translated-form ,,symb ,,arg ,',name
-			   ,',(if bitwise '((:optor . logior)
-					  (:optand . logand)))))
-
-       (def-binding-type ,name
-	 :in ',name
-	 :alien :int))))
+      (defparameter ,symb
+	(make-edata :alist (quote ,ast)
+		    :strict ,strict
+		    :bitwise ,bitwise
+		    :mask ,msk))
+
+      (setf (get ',name 'enum) ,symb)
+
+      (defun ,predicate-name (,arg)
+	(or ,@(mapcar (lambda (pred)
+			`(,pred ,arg))
+		      tconds)))
+      
+      (deftype ,name ()
+	'(satisfies ,predicate-name))
+
+      (defmacro ,name (,arg)
+	`(translated-form ,,symb ,,arg ,',name
+	  ,',(if bitwise '((:optor . logior)
+			   (:optand . logand)))))
+
+      (def-binding-type ,name
+	  :in ',name
+	  :alien :int))))

    