From 230184a4f786ee656871fe30abc20033c669b90d Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Thu, 6 Mar 2008 22:52:59 +0100
Subject: Make OBJECTIVE-C-METHODs dispatch on the class they have been defined
 for.

darcs-hash:93ae22beaabb2a9f162a297a8c314d36e882a4ab
---
 Lisp/method-definition.lisp | 19 ++++++++++++++-----
 1 file changed, 14 insertions(+), 5 deletions(-)

diff --git a/Lisp/method-definition.lisp b/Lisp/method-definition.lisp
index 7218f48..741c6ca 100644
--- a/Lisp/method-definition.lisp
+++ b/Lisp/method-definition.lisp
@@ -207,12 +207,16 @@ __super__"
                 collect :id into type-specifiers
                 and collect arg into arg-names
               finally (let ((super-args-sym (gensym))
-                            (captured-args-sym (gensym)))
+                            (captured-args-sym (gensym))
+                            (class-arg-sym (gensym))
+                            (class-name (class-name (find-objc-class
+                                                     (cadar lambda-list)))))
                         (return
                           `(defmethod ,(intern (symbol-name name)
                                                '#:objective-c-methods)
                                argtypes-start ,@type-specifiers argtypes-end
-                               ,@qualifiers ,lambda-list
+                               ,@qualifiers ((,class-arg-sym (eql ',class-name))
+                                             ,@lambda-list)
                                (let ((,captured-args-sym (list ,@arg-names)))
                                  (flet ((super (&rest ,super-args-sym)
                                           (invoke-by-name-super-v
@@ -220,7 +224,7 @@ __super__"
                                            ,(generic-function-name->method-name
                                              name)
                                            (objcl-class-superclass
-                                            (find-objc-class ',(cadar lambda-list)))
+                                            (find-objc-class ',class-name))
                                            (or ,super-args-sym
                                                (rest ,captured-args-sym)))))
                                    (declare (ignorable (function super)))
@@ -340,7 +344,7 @@ __define-objective-c-generic-function__.
 
   __define-objective-c-method__, __define-objective-c-class__"
   `(defgeneric ,(intern (symbol-name name) '#:objective-c-methods)
-       ,lambda-list
+       (,(gensym "CLASS") ,@lambda-list)
      ,@(unless (position :generic-function-class
                          options
                          :key #'car)
@@ -369,7 +373,7 @@ __define-objective-c-generic-function__.
 (defmethod add-method :after ((gf objective-c-generic-function)
                               (method objective-c-method))
   ;; FIXME: Support &REST arguments.
-  (let* ((class (first (method-specializers method)))
+  (let* ((class (second (method-specializers method)))
          (method-name (generic-function-name->selector
                        (generic-function-name gf)))
          (registered-p (foreign-class-registered-p class))
@@ -406,6 +410,11 @@ __define-objective-c-generic-function__.
                              (unwind-protect
                                  (coerce-object
                                   (,(generic-function-name gf)
+                                    ;; Pass the class this method is
+                                    ;; being defined for as the first
+                                    ;; argument.  This is needed so that
+                                    ;; super calls can work.
+                                    ',(class-name class)
                                     ;; Leave the second argument (the
                                     ;; selector) out.
                                     ,@(list* (car arguments) (cddr arguments)))
-- 
cgit v1.2.3