Wrap returned structs with TAGGED-STRUCT instances.

darcs-hash:ddf05fa12ece35775cbf4cf25fad2903db1f3753

2 files changed, 26 insertions, 32 deletions

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 333cc10..1b2beb7 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -36,9 +36,12 @@
        ((pointer :type     c-pointer
                  :reader   pointer-to
                  :initarg  :pointer
-                 :initform (cffi:null-pointer)))))
-
-
+                 :initform (cffi:null-pointer))
+        (lisp-managed :type boolean
+                      :accessor foreign-value-lisp-managed-p
+                      :initarg :lisp-managed
+                      :initform nil
+                      :documentation "Whether we need to handle deallocation."))))
 
 
 (defmethod make-load-form ((instance c-pointer-wrapper) &optional environment)
@@ -236,40 +239,29 @@ an __exception__, you can simply send it the `self' message.
   ((name :type (or null string)
          :accessor struct-name
          :initarg :name)
-   (children :type list
-             :accessor struct-children
-             :initarg :children)))
+   (typespec :accessor foreign-value-typespec
+             :initarg :typespec)))
 
-(defclass opaque-union (c-pointer-wrapper)
-  ((name :type (or null string)
-         :accessor struct-name
-         :initarg :name)))
+(defclass opaque-union (opaque-struct) ())
 
-(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-union (tagged-struct) ())
 
 (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))))
+                 :initarg :element-type)
+   (length :type integer
+           :accessor tagged-array-length)
+   (typespec :accessor foreign-value-typespec)))
+
+
+(defun make-struct-wrapper (pointer typespec managedp)
+  (make-instance (ecase (typespec-primary-type typespec)
+                   (struct 'tagged-struct)
+                   (union 'tagged-union))
+     :typespec typespec
+     :pointer pointer
+     :lisp-managed managedp))
 
 
 (defgeneric objcl-eql (obj1 obj2))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 85b8b0d..59b4ce4 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -464,7 +464,9 @@ easier to use with __apply__.
               ((struct union array)
                ;; The caller is responsible for FOREIGN-FREEing the
                ;; return value.
-               objc-struct-return-value-cell)
+               (make-struct-wrapper objc-struct-return-value-cell
+                                    return-type
+                                    t))
               ((:void) (values))
               (otherwise (cffi:mem-ref objc-return-value-cell
                                        return-c-type)))))))))