;;;; Objective-CL, an Objective-C bridge for Common Lisp. ;;;; Copyright (C) 2007, 2008 Matthias Andreas Benkard. ;;;; ;;;; This program is free software: you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public License ;;;; as published by the Free Software Foundation, either version 3 of ;;;; the License, or (at your option) any later version. ;;;; ;;;; This program is distributed in the hope that it will be useful, but ;;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. ;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this program. If not, see ;;;; . (in-package #:objective-cl) (defclass objective-c-generic-function (standard-generic-function) () (:metaclass funcallable-standard-class) (:documentation "An Objective-C dispatch function for a given selector. ## Description: Every Lisp-defined __objective-c-method__ belongs to a corresponding __objective-c-generic-function__ that handles **method combination** and registration of newly added **method**s with the Objective-C runtime. It is recommended to create all __objective-c-generic-functions__ by means of the macro __define-objective-c-generic-function__. If you subclass this **class**, be aware that there is no protocol that describes its behaviour, so the consequences of overriding any **generic function**s **applicable** to the **class** are undefined.")) (defclass objective-c-method (standard-method) ((return-type :initarg :return-type :accessor method-return-type) (argument-types :initarg :argument-types :accessor method-argument-types)) (:metaclass standard-class) (:documentation "An Objective-C method implemented in Lisp. ## Description: Instances of __objective-c-method__ are similar to instances of __standard-method__ except that they know about their foreign argument and return types and recognise different **qualifier**s that they communicate to the __objective-c-generic-function__ that they belong to. It is recommended to create all __objective-c-methods__ by means of the macro __define-objective-c-method__. There is no protocol that defines the behaviour of this **class**, so the consequences of subclassing it and overriding its **method**s is undefined.")) (defun qualifiers-return-type (qualifiers) (find-if #'(lambda (x) (or (not (keywordp x)) (typep x 'objective-c-type-keyword))) qualifiers)) (defmacro defobjcmethod (name &rest args) `(define-objective-c-method ,name ,@args)) ;; Put simply, a DEFINE-OBJECTIVE-C-METHOD form is transformed into a ;; DEFMETHOD form along with the code needed for initialisation of the ;; corresponding Objective-C method and registration of the callback. ;; ;; Note that mapping Objective-C methods to generic functions in a naive ;; way breaks super calls, because the following can (and will) happen: ;; ;; 1. Someone sends a message to a Lisp-based instance. ;; ;; 2. The callback is entered. It calls the generic function of the ;; same name, which invokes the effective method applying to the ;; object and method arguments. ;; ;; 2. The method calls super. ;; ;; 3. The callback for the parent class is entered. It, in turn, calls ;; the generic function of the same name, which invokes the same ;; effective method called in step 1. Oops. ;; ;; There are two solutions to this problem: ;; ;; 1. Do not use generic functions and methods at all, but define a ;; function for each callback. ;; ;; 2. Pass the class name as the first argument so that the dispatch ;; mechanism may dispatch over it. ;; ;; Option (2), which is what we do, is preferable because it allows the ;; user to dispatch over an arbitrary set of arguments other than the ;; first by reusing the standard CLOS generic function dispatch ;; mechanism. (defmacro define-objective-c-method (name &rest args) "Define a new Objective-C method. *args* ::= \\{*qualifier*\\}\\* *lambda-list* [[\\{*declaration*\\}\\* | *docstring*]] \\{*form*\\}\\* ## Arguments and Values: *name* --- a **symbol**. *qualifier* --- a **method qualifier**. *return-type* --- a *typespec*. *lambda-list* --- a **modified lambda list**. *docstring* --- a **string** (not evaluated). *declaration* --- a **local declaration** (not evaluated). *forms* --- an **implicit progn**. ## Description: _define-objective-c-generic-function_ is like __defgeneric__ except in the following aspects: 1. *name* is immediately replaced by a *symbol* **intern**ed in package _objective-c-methods_. 2. The default value for the _:generic-function-class_ option is _objective-cl:objective-c-generic-function_. 3. The default value for the _:method-class_ option is _objective-cl:objective-c-method_. _define-objective-c-generic-function_ recognises the same *options* as __defgeneric__, including _:generic-function-class_ and _:method-class_. The **lexical environment** of *body* is augmented to include the function __super__. ## Example: #.(enable-method-syntax) (define-objective-c-class ns::mlk-my-class (ns::ns-object) ((foos :initargs :foos) (foo-count :foreign-type :int))) => NS::MLK-MY-CLASS (define-objective-c-generic-function #/foo:bar:stuff:do: (self y z a b)) => # (define-objective-c-method #/foo:bar:stuff:do: :int ((self ns::mlk-my-class) (y :int) z a (b ns::ns-number)) (format t \"Hello! Z and A are ~A and~ ~&~A, respectively.~ ~&Have a nice day.\" z a) (+ y 20)) => # (#/foo:bar:stuff:do: (#/new (find-objc-class 'ns::mlk-my-class)) 100 30 \"FOO!\" 5) => Output: Hello! Z and A are # and #, respectively. Have a nice day. => 120 #.(disable-method-syntax) ## Note 1: It is not generally possible to define methods after a class has already been registered with the Objective-C runtime. The latter inevitably happens when Objective-CL first sees an instance of the class. ## Note 2: If you do not call __define-objective-c-generic-function__ before using __define-objective-c-method__, it will be called implicitly by the latter. There is nothing wrong with relying on this; in fact, if you do not want to set any options for the generic function, your code will probably seem less cramped if you leave the redundant __define-objective-c-generic-function__ calls out. ## Note 3: It is customary to use the #/ notation enabled by __enable-method-syntax__ to write method names for __define-objective-c-generic-function__. ## Note 4: Do not call __call-next-method__ in the body of an __objective-c-method__. Its behaviour is quite different from __super__, ill-defined, and probably not desirable anyway. Use __super__ instead. ## See also: __define-objective-c-generic-function__, __define-objective-c-class__, __super__" (let ((qualifiers (list))) (loop until (listp (first args)) do (push (pop args) qualifiers)) (setq qualifiers (nreverse qualifiers)) (destructuring-bind (lambda-list . body) args (let ((lambda-list (copy-list lambda-list))) (loop for arg-cons on lambda-list for arg = (car arg-cons) until (member arg lambda-list-keywords) if (listp arg) if (typep (second arg) 'objective-c-type-keyword) collect (second arg) into type-specifiers and collect (first arg) into arg-names and do (setf (car arg-cons) (first arg)) else ;; We simply map all non-OBJECTIVE-C-TYPE-KEYWORD ;; specialisers to :ID. This makes sense: If the ;; specialiser is an Objective-C type, the type ;; specifier should obviously be :ID. If it's a ;; non-Objective-C CLOS class, we're going to pass ;; Objective-C objects of the LISP-VALUE-WRAPPER-MIXIN ;; kind to the method, whose type specifier is :ID as ;; well. collect :id into type-specifiers and collect (first arg) into arg-names else collect :id into type-specifiers and collect arg into arg-names finally (let ((super-args-sym (gensym)) (captured-args-sym (gensym)) (class-arg-sym (gensym)) (class-name (intern (symbol-name (cadar lambda-list)) '#:objective-c-classes)) (real-name (intern (symbol-name name) '#:objective-c-methods))) (return `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (unless (fboundp ',real-name) ;; Note that we need not specify a ;; :LAMBDA-LIST here, as not supplying ;; it means it's simply going to be ;; initialised when a method is first ;; added to the generic function. ;; ;; For some reason, ;; ENSURE-GENERIC-FUNCTION raises an ;; error on Allegro CL claiming that ;; MAKE-INSTANCE of ;; OBJECTIVE-C-GENERIC-FUNCTION does ;; not understand the ;; :GENERIC-FUNCTION-CLASS initarg. ;; Calling ;; ENSURE-GENERIC-FUNCTION-USING-CLASS ;; instead does not display this ;; behaviour. Weird. (ensure-generic-function-using-class nil ',real-name :generic-function-class 'objective-c-generic-function :method-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) "Send a super message to the receiver of the current message. ## Arguments and Values: *args* --- a **list**. ## Description: A _super_ call is only valid inside the body of a **method** defined by means of __define-objective-c-method__. In this case, the Objective-C **method** of the same name defined in the superclass of the class specialised over by the method is called. In other words, a super call is made. The behaviour is similar in spirit to calling __call-next-method__ in the body of a __standard-method__ except that it will be done by the Objective-C runtime, thereby ignoring any pure-Lisp superclasses. __super__ is therefore single-inheritance only. If __super__ is called with no arguments, the original method arguments are passed to the super method. Otherwise, the supplied arguments are passed. ## Note: Do not call __call-next-method__ in the body of an __objective-c-method__. Its behaviour is quite different from __super__, ill-defined, and probably not desirable anyway. ## Examples: (define-objective-c-method #/characterAtIndex: :short ((self ns::my-string) (index :unsigned-long)) (if (weird-string-p self) (super (1+ index)) (super)))" (declare (ignore args)) (error "Tried to call ~S outside an Objective-C method." 'super)) (defmacro defobjcgeneric (name lambda-list &body options) "Define a new Objective-C generic function. ## Arguments and Values: *name* --- a *symbol*. *lambda-list* --- a **generic function lambda list**. *options* --- a *list* (not evaluated). ## Description: This macro is equivalent to __define-objective-c-generic-function__. ## See also: __define-objective-c-generic-function__, __defobjcmethod__" `(define-objective-c-generic-function ,name ,lambda-list ,@options)) (defmacro define-objective-c-generic-function (name lambda-list &body options) "Define a new Objective-C generic function. ## Arguments and Values: *name* --- a *symbol*. *lambda-list* --- a **generic function lambda list**. *options* --- a *list* (not evaluated). ## Description: _define-objective-c-generic-function_ is like __defgeneric__ except in the following aspects: 1. *name* is immediately replaced by a *symbol* **intern**ed in package _objective-c-methods_. 2. The default value for the _:generic-function-class_ option is _objective-cl:objective-c-generic-function_. 3. The default value for the _:method-class_ option is _objective-cl:objective-c-method_. _define-objective-c-generic-function_ recognises the same *options* as __defgeneric__, including _:generic-function-class_ and _:method-class_. ## Example: See __define-objective-c-method__. ## Note: It is customary to use the #/ notation enabled by __enable-method-syntax__ to write method names for __define-objective-c-generic-function__. ## See also: __define-objective-c-method__, __define-objective-c-class__" `(defgeneric ,(intern (symbol-name name) '#:objective-c-methods) (,(gensym "CLASS") ,@lambda-list) ,@(unless (position :generic-function-class options :key #'car) `((:generic-function-class objcl:objective-c-generic-function))) ,@(unless (position :method-class options :key #'car) `((:method-class objcl:objective-c-method))) ,@options)) (defvar *callback-names* (make-hash-table :test #'eql)) (defun intern-callback-name (method) (or (gethash method *callback-names* nil) (setf (gethash method *callback-names* nil) (intern (format nil "~A ~S ~A" (generic-function-name (method-generic-function method)) (class-name (second (method-specializers method))) (sort (copy-list (method-qualifiers method)) #'string< :key #'string)) '#:objective-cl)))) (defmethod add-method :after ((gf objective-c-generic-function) (method objective-c-method)) ;; FIXME: Support &REST arguments. (let* ((class (second (method-specializers method))) (method-name (generic-function-name->selector (generic-function-name gf))) (registered-p (foreign-class-registered-p class)) (return-type (typespec (method-return-type method))) (method-argument-types (method-argument-types method)) (argument-types (list* (first method-argument-types) :selector (rest method-argument-types))) (return-typestring (print-typespec-to-string return-type)) (arg-typestrings (mapcar #'print-typespec-to-string argument-types)) (callback-name (intern-callback-name method)) (arg-symbols (mapcar #'(lambda (x) (declare (ignore x)) (gensym "ARG")) argument-types))) (eval (loop for type in argument-types for typespec = (typespec type) for symbol in arg-symbols collect (list symbol (typespec->c-type typespec)) into cffi-lambda-list if (member (typespec-primary-type typespec) '(:id :class :selector)) collect `(intern-pointer-wrapper ',type :pointer ,symbol) into arguments else collect symbol into arguments finally (return `(defcallback ,callback-name ,(typespec->c-type return-type) ,cffi-lambda-list (declare (ignorable ,(cadr arg-symbols))) (unwind-protect (,(if (member (typespec-primary-type return-type) '(:id :class :selector)) 'pointer 'progn) (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))) ',return-type)) ;; FIXME: We may want to wrap signalled ;; SERIOUS-CONDITIONS in some kind of ;; Objective-C exception object and put ;; it into *OBJCL-CURRENT-EXCEPTION*. Or ;; maybe we don't, assuming the Lisp ;; system can handle a few layers of C ;; functions between a condition's ;; signalling and handling, in which case ;; we'd only destroy the restart ;; mechanism by pseudo-handling ;; conditions in this way. (%objcl-acquire-lock *objcl-current-exception-lock*)))))) (let ((callback (get-callback callback-name))) (with-foreign-object (arg-typestring-buffer :string (- (length arg-typestrings) 2)) (with-foreign-string-pool (register-temp allocate-temp) (loop for i from 0 for typestring in (cddr arg-typestrings) do (setf (mem-aref arg-typestring-buffer :string i) (allocate-temp typestring))) (%objcl-add-method (pointer-to class) (symbol->objc-class-name (class-name class)) (pointer-to method-name) callback (- (length arg-typestrings) 2) return-typestring arg-typestring-buffer (apply #'concatenate 'string return-typestring arg-typestrings) (if registered-p 1 0)))))) #+(or) (format t "~&ADD-METHOD:~& ~A, ~A" gf method)) (defmethod initialize-instance :around ((method objective-c-method) &rest initargs &key documentation function lambda-list qualifiers specializers &allow-other-keys) (declare (ignore documentation function lambda-list specializers)) #+(or) (format t "~&INITIALIZE-INSTANCE:~& ~S" initargs) (let* ((argtypes-start (position 'argtypes-start qualifiers)) (argtypes-end (position 'argtypes-end qualifiers)) (argument-types (subseq qualifiers (1+ argtypes-start) argtypes-end)) (qualifiers (append (subseq qualifiers 0 argtypes-start) (subseq qualifiers (1+ argtypes-end)))) (new-initargs (copy-list initargs)) (return-type (qualifiers-return-type qualifiers))) (setf (getf new-initargs :qualifiers) (remove return-type qualifiers)) (apply #'call-next-method method :return-type (or return-type :id) :argument-types argument-types new-initargs)))