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