From 164950db293f283e5d1be7a9d6262ef1a331f359 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sun, 16 Sep 2007 18:34:04 +0200
Subject: Add classes for tagged pointers.

darcs-hash:93dc7a7ee851ab3947332487b00b990143b81e46
---
 Lisp/utilities.lisp | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)

(limited to 'Lisp/utilities.lisp')

diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index 405cacf..2e8839c 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -124,3 +124,53 @@
             (primitive-invoke (primitive-invoke exception "name" 'id)
                               "UTF8String" :string)
             (primitive-invoke exception "hash" :unsigned-int))))
+
+
+;;; (@* "Structure and Union Definition")
+(defun make-objc-struct/union-definer (type name-and-options c-names
+                                       doc-and-slots)
+  (let ((struct-name (ctypecase name-and-options
+                       (list (first name-and-options))
+                       (symbol name-and-options)))
+        (slots (typecase (first doc-and-slots)
+                 (string (rest doc-and-slots))
+                 (t doc-and-slots))))
+    `(progn
+       ,(if (eq type :struct)
+            `(defcstruct ,name-and-options ,@doc-and-slots)
+            `(defcunion ,name-and-options ,@doc-and-slots))
+       ,@(mapcar #'(lambda (slot)
+                     (let ((slot-name (first slot)))
+                       `(defun ,(intern (concatenate 'string
+                                                     (symbol-name struct-name)
+                                                     "-"
+                                                     (symbol-name slot-name))
+                                        (symbol-package slot-name))
+                            (struct)
+                          (check-type struct ,(if (eq type :struct)
+                                                  `(or c-pointer
+                                                       opaque-struct
+                                                       tagged-struct)
+                                                  `(or c-pointer
+                                                       opaque-union
+                                                       tagged-union)))
+                          (when (typep struct ,(if (eq type :struct)
+                                                   `'tagged-struct
+                                                   `'tagged-union))
+                            (assert (member (struct-name struct)
+                                            ',c-names
+                                            :test #'string=)))
+                          (cffi:foreign-slot-value struct
+                                                   ',struct-name
+                                                   ',slot-name))))
+                 slots))))
+
+(defmacro define-objc-struct (name-and-options c-names &rest doc-and-slots)
+  "Like CFFI:DEFCSTRUCT except that it provides accessors that check
+their arguments according to their struct names."
+  (make-objc-struct/union-definer :struct name-and-options c-names doc-and-slots))
+
+(defmacro define-objc-union (name-and-options c-names &rest doc-and-slots)
+  "Like CFFI:DEFCUNION except that it provides accessors that check
+their arguments according to their struct names."
+  (make-objc-struct/union-definer :union name-and-options c-names doc-and-slots))
-- 
cgit v1.2.3