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