;;;; 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*.
*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:
#.(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:
At present, it is important to call
__define-objective-c-generic-function__ before using
__define-objective-c-method__, because otherwise the generic function
automatically created by __define-objective-c-method__ may get the wrong
class.
## Note 3:
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-generic-function__, __define-objective-c-class__"
(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 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
else
collect :id into type-specifiers
finally (return
`(defmethod ,(intern (symbol-name name)
'#:objective-c-methods)
argtypes-start ,@type-specifiers argtypes-end
,@qualifiers ,lambda-list
,@body)))))))
(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)
,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 ~A"
(generic-function-name
(method-generic-function 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 (first (method-specializers method)))
(method-name (generic-function-name->selector
(generic-function-name gf)))
(registered-p (foreign-class-registered-p class))
(return-type (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 symbol in arg-symbols
collect (list symbol (typespec->c-type type)) into cffi-lambda-list
if (member type '(: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)))
#+(or) (progn ;for debugging
(print '(,(generic-function-name gf)
,@arguments))
(format t "~&~A" (list ,@arg-symbols)))
(unwind-protect
(,(generic-function-name gf)
;; Leave the second argument (the
;; selector) out.
,@(list* (car arguments) (cddr arguments)))
;; 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)))
#+(or)
(defgeneric bla (x y z &rest r)
(:generic-function-class objective-c-generic-function)
(:method-class objective-c-method))
#+(or)
(defmethod bla :abc ((x number) (y symbol) c &rest r)
(declare (ignore c r))
(+ x 3))