From aa8645cdf28eb7b13d2813f5f0fe014df4d7b4b8 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Mon, 24 Mar 2008 13:28:45 +0100
Subject: When receiving a Lisp value wrapper from Objective-C, unwrap it
 automatically.

darcs-hash:f1b183f46c4d97c27121e0ada8614b9e9feb9955
---
 Lisp/data-types.lisp          |  6 ++++++
 Lisp/lisp-value-wrapping.lisp | 12 ++++--------
 Lisp/parameters.lisp          |  2 ++
 Lisp/type-conversion.lisp     | 14 +++++++++++---
 4 files changed, 23 insertions(+), 11 deletions(-)

(limited to 'Lisp')

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index d4e169e..2ab3fe4 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -582,6 +582,12 @@ seems like an acceptable trade-off.
           (trivial-garbage:finalize new-wrapper #'finaliser))))))
 
 
+(defclass lisp-value-wrapper-mixin ()
+     ((lisp-value :initarg :value
+                  :initform nil
+                  :accessor lisp-value)))
+
+
 (defgeneric objcl-eql (obj1 obj2))
 
 (with-compilation-unit ()
diff --git a/Lisp/lisp-value-wrapping.lisp b/Lisp/lisp-value-wrapping.lisp
index dbc9c6e..1406a95 100644
--- a/Lisp/lisp-value-wrapping.lisp
+++ b/Lisp/lisp-value-wrapping.lisp
@@ -26,12 +26,6 @@
   (find-objc-class "NSDictionary" t))
 
 
-(defclass lisp-value-wrapper-mixin ()
-     ((lisp-value :initarg :value
-                  :initform nil
-                  :accessor lisp-value)))
-
-
 ;; May usefully override, among others:
 ;;  - description
 (defclass ns::mlk-lisp-value (ns::ns-object lisp-value-wrapper-mixin)
@@ -62,12 +56,14 @@
 (defun make-lisp-value (value)
   ;; FIXME: The following won't work.  Make MAKE-INSTANCE more useful...
   ;(make-instance 'ns::mlk-lisp-value :value value)
-  (let ((instance (invoke (typecase value
+  (let* ((*skip-value-wrapper-unwrapping* t)
+         (instance
+          (invoke-by-name (typecase value
                             (string (find-class 'ns::mlk-lisp-string))
                             (vector (find-class 'ns::mlk-lisp-array))
                             (list (find-class 'ns::mlk-lisp-list))
                             (t (find-class 'ns::mlk-lisp-value)))
-                          'new)))
+                          "new")))
     (setf (lisp-value instance) value)
     instance))
 
diff --git a/Lisp/parameters.lisp b/Lisp/parameters.lisp
index 14a3f16..f6fce2d 100644
--- a/Lisp/parameters.lisp
+++ b/Lisp/parameters.lisp
@@ -26,6 +26,8 @@
 
 (defvar *skip-retaining* nil)
 
+(defvar *skip-value-wrapper-unwrapping* nil)
+
 (defvar *in-make-pointer-wrapper-p* nil
   "A debugging tool that helps identify direct MAKE-INSTANCE calls that
 ought not be there.")
diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp
index 9796104..5be0f12 100644
--- a/Lisp/type-conversion.lisp
+++ b/Lisp/type-conversion.lisp
@@ -25,9 +25,17 @@
               (typespec-primary-type typespec))
       ((id objective-c-class exception selector)
        (let ((*skip-retaining* skip-retaining-p))
-         (intern-pointer-wrapper (typespec-primary-type typespec)
-                                 :pointer (cffi:mem-ref foreign-value-cell
-                                                        c-type))))
+         (let ((instance
+                (intern-pointer-wrapper (typespec-primary-type typespec)
+                                        :pointer (cffi:mem-ref
+                                                  foreign-value-cell
+                                                  c-type))))
+           (typecase instance
+             (lisp-value-wrapper-mixin
+              (if *skip-value-wrapper-unwrapping*
+                  instance
+                  (lisp-value instance)))
+             (t instance)))))
       ((:char :unsigned-char)
        ;; FIXME?  This is non-trivial.  See policy.lisp for
        ;; details.
-- 
cgit v1.2.3