summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-02-15 13:33:38 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-02-15 13:33:38 +0100
commit17aeae082fda67704ec0835b20e2412573775b2b (patch)
treed2995d1d150375db8a191f434c37aa14ca1c248a
parent2e244d781b1b1096cddfd0df558ec7cee19b33a1 (diff)
Wrap returned structs with TAGGED-STRUCT instances.
darcs-hash:ddf05fa12ece35775cbf4cf25fad2903db1f3753
-rw-r--r--Lisp/data-types.lisp54
-rw-r--r--Lisp/method-invocation.lisp4
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)))))))))