diff options
| author | Matthias Benkard <code@mail.matthias.benkard.de> | 2008-03-06 23:26:35 +0100 |
|---|---|---|
| committer | Matthias Benkard <code@mail.matthias.benkard.de> | 2008-03-06 23:26:35 +0100 |
| commit | 016f543b4726b8c46415c78eb0efea86488a4641 (patch) | |
| tree | 920758a64946e7a1b8624ecec9f9298ede8851d1 | |
| parent | 2764ecfdb8adf6ae57668f173e55628cb721e96f (diff) | |
DEFINE-OBJECTIVE-C-METHOD: Silently define a suitable OBJECTIVE-C-GENERIC-FUNCTION if needed.
darcs-hash:fa3bfc33170f12fd7d965c08eafd4005e9ac8a8d
| -rw-r--r-- | Lisp/method-definition.lisp | 46 |
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) |