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/data-types.lisp        | 46 +++++++++++++++++++++++++++++++++++++++++
 Lisp/defpackage.lisp        |  4 ++++
 Lisp/method-invocation.lisp |  1 +
 Lisp/utilities.lisp         | 50 +++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 101 insertions(+)

(limited to 'Lisp')

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index c757070..1095e38 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -154,6 +154,52 @@ an __exception__, you can simply send it the `self' message.
   __id__"))
 
 
+(defclass opaque-struct (c-pointer-wrapper)
+  ((name :type (or null string)
+         :accessor struct-name
+         :initarg :name)))
+
+(defclass tagged-struct (c-pointer-wrapper)
+  ((name :type (or null string)
+         :accessor struct-name
+         :initarg :name)
+   (children :type list
+             :accessor struct-children
+             :initarg :children)))
+
+(defclass opaque-union (c-pointer-wrapper)
+  ((name :type (or null string)
+         :accessor struct-name
+         :initarg :name)))
+
+(defclass tagged-union (c-pointer-wrapper)
+  ((name :type (or null string)
+         :accessor struct-name
+         :initarg :name)
+   (children :type list
+             :accessor struct-children
+             :initarg :children)))
+
+(defclass tagged-array (c-pointer-wrapper)
+  ((element-type :type symbol
+                 :accessor tagged-array-element-type
+                 :initarg :element-type)))
+
+
+(defgeneric type-info (thing))
+
+(defmethod type-info ((thing opaque-struct))
+  (with-slots (name)
+        thing
+    (list* 'struct '(opaque) name)))
+
+(defmethod type-info ((thing tagged-struct))
+  (with-slots (name children)
+        thing
+    (list* 'struct '() name (mapcar #'type-info children))))
+
+
+
 (defgeneric objcl-eql (obj1 obj2))
 (defmethod objcl-eql ((obj1 c-pointer-wrapper) (obj2 c-pointer-wrapper))
   (pointer-eq (pointer-to obj1) (pointer-to obj2)))
diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index 46114d5..bdf1eed 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -17,6 +17,10 @@
            #:objc-eql
            #:objc-equal
 
+           ;; Macros
+           #:define-objc-struct
+           #:define-objc-union
+
            ;; Special variables
            #:*trace-method-calls*
 
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index a9e9336..826cc29 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -182,6 +182,7 @@ Returns: *result* --- the return value of the method invocation.
 
 
 (defun primitive-invoke (receiver method-name return-type &rest args)
+  "An invocation mechanism with ad-hoc argument conversion."
   (with-foreign-string-pool (register-temporary-string)
     (with-foreign-object-pool (register-temporary-object)
       (let ((return-c-type (case return-type
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