+(deftype flags (&rest args)
+ `(or (member ,@(%map-flags args :symbols)) list))
+
+(define-type-method alien-type ((type flags))
+ (declare (ignore type))
+ (alien-type 'unsigned))
+
+(define-type-method size-of ((type flags))
+ (declare (ignore type))
+ (size-of 'unsigned))
+
+(define-type-method to-alien-form ((type flags) flags)
+ `(reduce #'logior (mklist ,flags)
+ :key #'(lambda (flag)
+ (case flag
+ ,@(%map-flags (rest (type-expand-to 'flags type)) :symbol-int)
+ (t (error 'type-error :datum ,flags :expected-type ',type))))))
+
+(define-type-method from-alien-form ((type flags) value)
+ `(loop
+ for (int symbol) in ',(%map-flags (rest (type-expand-to 'flags type)) :int-symbol)
+ when (= (logand ,value int) int)
+ collect symbol))
+
+(define-type-method to-alien-function ((type flags))
+ (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :symbol-int)))
+ #'(lambda (flags)
+ (reduce #'logior (mklist flags)
+ :key #'(lambda (flag)
+ (or
+ (second (assoc flag mappings))
+ (error 'type-error :datum flags :expected-type type)))))))
+
+(define-type-method from-alien-function ((type flags))
+ (let ((mappings (%map-flags (rest (type-expand-to 'flags type)) :int-symbol)))
+ #'(lambda (value)
+ (loop
+ for (int symbol) in mappings
+ when (= (logand value int) int)
+ collect symbol))))
+
+(define-type-method writer-function ((type flags))
+ (let ((writer (writer-function 'unsigned))
+ (function (to-alien-function (type-expand-to 'flags type))))
+ #'(lambda (flags location &optional (offset 0))
+ (funcall writer (funcall function flags) location offset))))
+
+(define-type-method reader-function ((type flags))
+ (let ((reader (reader-function 'unsigned))
+ (function (from-alien-function (type-expand-to 'flags type))))
+ #'(lambda (location &optional (offset 0) weak-p)
+ (declare (ignore weak-p))
+ (funcall function (funcall reader location offset)))))
+
+
+;;;; Named flags types
+
+(defmacro define-flags-type (name &rest args)
+ (let ((flags-int (intern (format nil "~A-TO-INT" name)))
+ (int-flags (intern (format nil "INT-TO-~A" name)))
+ (satisfies (intern (format nil "~A-P" name))))
+ `(progn
+ (deftype ,name () '(satisfies ,satisfies))
+ (defun ,satisfies (object)
+ (flet ((valid-p (ob)
+ (find ob ',(%map-flags args :symbols))))
+ (typecase object
+ (symbol (valid-p object))
+ (list (every #'valid-p object)))))
+ (defun ,flags-int (flags)
+ (reduce #'logior (mklist flags)
+ :key #'(lambda (flag)
+ (case flag
+ ,@(%map-flags args :symbol-int)
+ (t (error 'type-error :datum flags
+ :expected-type ',name))))))
+ (defun ,int-flags (value)
+ (loop
+ for (int symbol) in ',(%map-flags args :int-symbol)
+ when(= (logand value int) int)
+ collect symbol))
+ (define-type-method alien-type ((type ,name))
+ (declare (ignore type))
+ (alien-type 'flags))
+ (define-type-method size-of ((type ,name))
+ (declare (ignore type))
+ (size-of 'flags))
+ (define-type-method to-alien-form ((type ,name) form)
+ (declare (ignore type))
+ (list ',flags-int form))
+ (define-type-method from-alien-form ((type ,name) form)
+ (declare (ignore type))
+ (list ',int-flags form))
+ (define-type-method to-alien-function ((type ,name))
+ (declare (ignore type))
+ #',flags-int)
+ (define-type-method from-alien-function ((type ,name))
+ (declare (ignore type))
+ #',int-flags)
+ (define-type-method writer-function ((type ,name))
+ (declare (ignore type))
+ (let ((writer (writer-function 'signed)))
+ #'(lambda (flags location &optional (offset 0))
+ (funcall writer (,flags-int flags) location offset))))
+ (define-type-method reader-function ((type ,name))
+ (declare (ignore type))
+ (let ((reader (reader-function 'signed)))
+ #'(lambda (location &optional (offset 0) weak-p)
+ (declare (ignore weak-p))
+ (,int-flags (funcall reader location offset))))))))
+
+
+
+;;;; Type definition by introspection