From 996fa5e19c1ec8603b99a4ce29b85b7af7468a78 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 15 Feb 2008 19:33:34 +0100
Subject: Refine the public interface to Lisp-managed foreign structs and
 unions.

darcs-hash:b3c869d86d1e4655ec1562dade69cbdb93600eed
---
 Lisp/data-types.lisp        | 37 +++++++++++++++++++++++--------------
 Lisp/defpackage.lisp        |  8 +++++++-
 Lisp/method-invocation.lisp |  7 ++++---
 Lisp/policy.lisp            |  2 ++
 4 files changed, 36 insertions(+), 18 deletions(-)

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 6726f70..91e10f3 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -232,23 +232,24 @@ an __exception__, you can simply send it the `self' message.
                          :documentation "Whether we need to handle deallocation.")))
 
 
-(defclass opaque-struct (foreign-value)
-  ((name :type (or null string)
-         :accessor struct-name
-         :initarg :name)))
-
-(defclass tagged-struct (foreign-value)
-  ((name :type (or null string)
-         :accessor struct-name
-         :initarg :name)
-   (typespec :accessor foreign-value-typespec
-             :initarg :typespec)))
+;; FIXME: Document.
+(defclass foreign-struct (foreign-value)
+     ((name :type (or null string)
+            :accessor struct-name
+            :initarg :name)))
 
-(defclass opaque-union (opaque-struct) ())
 
+;; The following are for private use only.
+(defclass opaque-struct (foreign-struct) ())
+(defclass tagged-struct (foreign-struct) ())
+(defclass opaque-union (opaque-struct) ())
 (defclass tagged-union (tagged-struct) ())
 
-(defclass tagged-array (foreign-value)
+
+;; FIXME: Either document or throw away.  (Does the C language actually
+;; support returning arrays from functions?  It certainly does not
+;; support passing them as arguments.)
+(defclass foreign-array (foreign-value)
   ((element-type :type symbol
                  :accessor tagged-array-element-type
                  :initarg :element-type)
@@ -257,17 +258,25 @@ an __exception__, you can simply send it the `self' message.
    (typespec :accessor foreign-value-typespec)))
 
 
+;; FIXME: Document.
 (defgeneric foreign-value-lisp-managed-p (foreign-value))
 (defmethod foreign-value-lisp-managed-p ((foreign-value foreign-value))
   (with-slots (lisp-managed-cell) foreign-value
     (aref lisp-managed-cell)))
 
 
+;; FIXME: Document.
 (defgeneric (setf foreign-value-lisp-managed-p) (managedp foreign-value))
 (defmethod (setf foreign-value-lisp-managed-p)
     (managedp (foreign-value foreign-value))
   (with-slots (lisp-managed-cell) foreign-value
-    (setf (aref lisp-managed-cell) managedp)))
+    (setf (aref lisp-managed-cell) (if managedp t nil))))
+
+
+;; FIXME: Document.
+(defgeneric foreign-value-pointer (foreign-value))
+(defmethod foreign-value-pointer ((foreign-value foreign-value))
+  (pointer-to foreign-value))
 
 
 (defun make-struct-wrapper (pointer typespec managedp)
diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index 1854cfd..3c2444b 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -31,6 +31,8 @@
            #:objc-class-name
            #:selector-name
            #:selector
+           #:define-returns-boolean-exception
+           #:undefine-returns-boolean-exception
 
            ;; Generic functions
            #:objc-eql
@@ -52,13 +54,17 @@
            #:id
            #:selector
            #:exception
+           #:foreign-value
+           #:foreign-struct
+           #:foreign-union
 
            ;; Conditions
            #:message-not-understood
            #:no-such-selector
 
            ;; Metaclasses
-           #:objective-c-class))
+           #:objective-c-class
+           #:objective-c-metaclass))
 
 
 (defpackage #:mulk.objective-cl-features
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 59b4ce4..750647f 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -455,15 +455,16 @@ easier to use with __apply__.
                                        :pointer (cffi:mem-ref objc-return-value-cell
                                                               return-c-type))))
               ((:char :unsigned-char)
-               ;; FIXME: This is non-trivial.  See policy.lisp for
+               ;; FIXME?  This is non-trivial.  See policy.lisp for
                ;; details.
                (objc-char->lisp-value (cffi:mem-ref objc-return-value-cell
                                                     return-c-type)
                                       receiver
                                       selector))
               ((struct union array)
-               ;; The caller is responsible for FOREIGN-FREEing the
-               ;; return value.
+               ;; The caller is responsible for preventing the return
+               ;; value from being garbage-collected by setting
+               ;; FOREIGN-VALUE-LISP-MANAGED-P to false.
                (make-struct-wrapper objc-struct-return-value-cell
                                     return-type
                                     t))
diff --git a/Lisp/policy.lisp b/Lisp/policy.lisp
index 41484fa..03b4e62 100644
--- a/Lisp/policy.lisp
+++ b/Lisp/policy.lisp
@@ -18,6 +18,7 @@
 (in-package #:mulk.objective-cl)
 
 
+;; FIXME: Document.
 (defun define-returns-boolean-exception (selector-designator)
   (let ((key (typecase selector-designator
                (string selector-designator)
@@ -25,6 +26,7 @@
     (setf (gethash key *boolean-return-exceptions*) t)))
 
 
+;; FIXME: Document.
 (defun undefine-returns-boolean-exceptions (selector-designator)
   (let ((key (typecase selector-designator
                (string selector-designator)
-- 
cgit v1.2.3