;;;; 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))
(defmacro define-objective-c-method (name &rest args)
"Define a new Objective-C method.
## Arguments and Values:
*name* --- a *symbol*.
*qualifier* --- a **method qualifier**.
*return-type* --- a *typespec*.
*lambda-list* --- a **modified lambda list**.
*body* --- 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)))