From f98c79811e81eff07f967f28c108b76a4a7d1343 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Mon, 17 Sep 2007 23:29:58 +0200
Subject: INVOKE-WITH-CONVERSION: Support classes as message receivers.

darcs-hash:f27d973190d6ada1ef35ab041229d1c0b88ee11c
---
 Lisp/internal-utilities.lisp | 29 ++++++++++++++++++-----------
 Lisp/method-invocation.lisp  | 34 ++++++++++++++++++++++++----------
 2 files changed, 42 insertions(+), 21 deletions(-)

diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp
index 4e9d481..13d4e47 100644
--- a/Lisp/internal-utilities.lisp
+++ b/Lisp/internal-utilities.lisp
@@ -90,14 +90,21 @@ collector."
   (let ((hash-table (gensym))
         (value (gensym))
         (default-value (gensym))
-        (hash-key (gensym)))
-    `(let ((,hash-table (tg:make-weak-hash-table :weakness :key
-                                                 :test 'equal)))
-       (defun ,name ,lambda-list
-         (let* ((,hash-key ,hashing-form)
-                (,value (gethash ,hash-key ,hash-table ',default-value)))
-           (if (eq ',default-value ,value)
-               (values-list
-                (setf (gethash ,hash-key ,hash-table)
-                      (multiple-value-list (progn ,@body))))
-               (values-list ,value)))))))
+        (hash-key (gensym))
+        (no-weak-hashing-p (handler-case
+                               (prog1 nil
+                                 (tg:make-weak-hash-table :weakness :key
+                                                          :test 'equal))
+                             (serious-condition () t))))
+    (if no-weak-hashing-p
+        `(defun ,name ,lambda-list ,@body)
+        `(let ((,hash-table (tg:make-weak-hash-table :weakness :key
+                                                     :test 'equal)))
+           (defun ,name ,lambda-list
+             (let* ((,hash-key ,hashing-form)
+                    (,value (gethash ,hash-key ,hash-table ',default-value)))
+               (if (eq ',default-value ,value)
+                   (values-list
+                    (setf (gethash ,hash-key ,hash-table)
+                          (multiple-value-list (progn ,@body))))
+                   (values-list ,value))))))))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 40d1d5d..bc6cc2d 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -266,22 +266,32 @@ Returns: *result* --- the return value of the method invocation.
                   ((id objc-class exception selector)
                    (let ((*skip-retaining*
                           (or *skip-retaining*
-                              (constructor-name-p (selector-name selector)))))
-                     (make-instance return-type
-                        :pointer (cffi:mem-ref return-value-cell
-                                               return-c-type))))
+                              (constructor-name-p (selector-name selector))))
+                         (pointer (cffi:mem-ref return-value-cell
+                                                return-c-type)))
+                     (if (cffi:null-pointer-p pointer)
+                         nil
+                         (make-instance return-type
+                            :pointer pointer))))
                   ((:void) (values))
                   (otherwise (cffi:mem-ref return-value-cell
                                            return-c-type)))))))))))
 
 
-(define-cached-function retrieve-method-signature-info (class selector)
+(define-cached-function retrieve-method-signature-info
+    (class selector &optional (instance-or-class :instance))
     (cons (cffi:pointer-address (pointer-to class))
           (cffi:pointer-address (pointer-to selector)))
-  (let* ((signature (primitive-invoke class
-                                      :instance-method-signature-for-selector
-                                      'id
-                                      selector))
+  (let* ((signature
+          (if (eq instance-or-class :instance)
+              (primitive-invoke class
+                                :instance-method-signature-for-selector
+                                'id
+                                selector)
+              (primitive-invoke class
+                                :method-signature-for-selector
+                                'id
+                                selector)))
          (argc (primitive-invoke signature 'number-of-arguments :unsigned-int))
          (method-return-typestring (primitive-invoke signature
                                                      'method-return-type
@@ -388,7 +398,11 @@ Returns: *result* --- the return value of the method invocation.
                           method-return-type
                           method-arg-typestrings
                           method-arg-types)
-        (retrieve-method-signature-info class selector)
+        (retrieve-method-signature-info class selector
+                                        (if (cffi:pointer-eq (pointer-to receiver)
+                                                             (pointer-to class))
+                                            :class
+                                            :instance))
       (assert (= argc (+ 2 (length args)))
               (args)
               "Wrong number of arguments (expected ~A, got ~A)."
-- 
cgit v1.2.3