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