summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-03-06 23:26:35 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-03-06 23:26:35 +0100
commit016f543b4726b8c46415c78eb0efea86488a4641 (patch)
tree920758a64946e7a1b8624ecec9f9298ede8851d1
parent2764ecfdb8adf6ae57668f173e55628cb721e96f (diff)
DEFINE-OBJECTIVE-C-METHOD: Silently define a suitable OBJECTIVE-C-GENERIC-FUNCTION if needed.
darcs-hash:fa3bfc33170f12fd7d965c08eafd4005e9ac8a8d
-rw-r--r--Lisp/method-definition.lisp46
1 files changed, 28 insertions, 18 deletions
diff --git a/Lisp/method-definition.lisp b/Lisp/method-definition.lisp
index a58b530..7c9c75f 100644
--- a/Lisp/method-definition.lisp
+++ b/Lisp/method-definition.lisp
@@ -210,25 +210,35 @@ __super__"
(captured-args-sym (gensym))
(class-arg-sym (gensym))
(class-name (intern (symbol-name (cadar lambda-list))
- '#:objective-c-classes)))
+ '#:objective-c-classes))
+ (real-name (intern (symbol-name name)
+ '#:objective-c-methods)))
(return
- `(defmethod ,(intern (symbol-name name)
- '#:objective-c-methods)
- argtypes-start ,@type-specifiers argtypes-end
- ,@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
- (first ,captured-args-sym)
- ,(generic-function-name->method-name
- name)
- (objcl-class-superclass
- (find-objc-class ',class-name))
- (or ,super-args-sym
- (rest ,captured-args-sym)))))
- (declare (ignorable (function super)))
- ,@body))))))))))
+ `(progn
+ (eval-when (:load-toplevel :execute)
+ (unless (fboundp ',real-name)
+ (ensure-generic-function
+ ',real-name
+ :generic-function-class
+ (find-class 'objective-c-generic-function)
+ :method-class
+ (find-class 'objective-c-method))))
+ (defmethod ,real-name
+ argtypes-start ,@type-specifiers argtypes-end
+ ,@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
+ (first ,captured-args-sym)
+ ,(generic-function-name->method-name
+ name)
+ (objcl-class-superclass
+ (find-objc-class ',class-name))
+ (or ,super-args-sym
+ (rest ,captured-args-sym)))))
+ (declare (ignorable (function super)))
+ ,@body)))))))))))
(defun super (&rest args)