From 016f543b4726b8c46415c78eb0efea86488a4641 Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Thu, 6 Mar 2008 23:26:35 +0100 Subject: DEFINE-OBJECTIVE-C-METHOD: Silently define a suitable OBJECTIVE-C-GENERIC-FUNCTION if needed. darcs-hash:fa3bfc33170f12fd7d965c08eafd4005e9ac8a8d --- Lisp/method-definition.lisp | 46 +++++++++++++++++++++++++++------------------ 1 file changed, 28 insertions(+), 18 deletions(-) (limited to 'Lisp') 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) -- cgit v1.2.3