summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-03-03 17:30:46 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-03-03 17:30:46 +0100
commit2e26057818b48da27a5355e2d2101cb8605b840f (patch)
treecfa916870cdc83e35a12dcabc4ae62c86b63fa2b /Lisp
parent68041467b00a878bd7325bf2f385bd58de7a2a20 (diff)
Implement ADD-METHOD :AFTER (OBJECTIVE-C-GENERIC-FUNCTION OBJECTIVE-C-METHOD).
darcs-hash:16207045b44287e0f3f332937d826d1cc6c44296
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/method-definition.lisp53
-rw-r--r--Lisp/method-invocation.lisp2
-rw-r--r--Lisp/name-conversion.lisp4
-rw-r--r--Lisp/tests.lisp21
4 files changed, 78 insertions, 2 deletions
diff --git a/Lisp/method-definition.lisp b/Lisp/method-definition.lisp
index a3126db..b4ba605 100644
--- a/Lisp/method-definition.lisp
+++ b/Lisp/method-definition.lisp
@@ -38,6 +38,10 @@
qualifiers))
+(defmacro defobjcmethod (name &rest args)
+ `(define-objective-c-method ,name ,@args))
+
+
(defmacro define-objective-c-method (name &rest args)
(let ((qualifiers (list)))
(loop until (listp (first args))
@@ -73,6 +77,55 @@
(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 (gensym (selector-name method-name)))
+ (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
+ (,(generic-function-name gf) ,@arguments)))))
+ (let ((callback (get-callback callback-name)))
+ (with-foreign-object (arg-typestring-buffer :string (length arg-typestrings))
+ (with-foreign-string-pool (register-temp allocate-temp)
+ (loop for i from 0
+ for typestring in arg-typestrings
+ do (setf (mem-aref arg-typestring-buffer :string i)
+ (allocate-temp typestring)))
+ (%objcl-add-method (pointer-to 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))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 03e2ab7..bbbee68 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -313,7 +313,7 @@ easier to use with __apply__.
(defun typespec->c-type (typespec)
(case (typespec-primary-type typespec)
((:pointer pointer struct union id objective-c-class exception array
- selector)
+ selector :id :class :exception :selector)
:pointer)
((:string) :string)
(otherwise (typespec-primary-type typespec))))
diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp
index eb46ee4..a82cfc5 100644
--- a/Lisp/name-conversion.lisp
+++ b/Lisp/name-conversion.lisp
@@ -35,6 +35,10 @@
:initial-value ""))
+(defun generic-function-name->selector (gf-name)
+ (selector (symbol-name gf-name)))
+
+
;;; (@* "Class names")
(defun symbol->objc-class-name (symbol)
(let* ((name (symbol-name symbol))
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index f5344df..cd87823 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -26,7 +26,9 @@
#:primitive-invoke #:print-typespec-to-string
#:nominally #:find-objc-meta-class
#:objcl-object-backed-by-lisp-class-p
- #:foreign-class-registered-p))
+ #:foreign-class-registered-p
+ #:define-objective-c-method #:defobjcmethod
+ #:objective-c-generic-function #:objective-c-method))
(in-package #:mulk.objective-cl.tests)
(in-root-suite)
@@ -419,6 +421,20 @@
;; Class initialisation.
(is (not (foreign-class-registered-p class)))
+ ;; Method definition.
+ (is (eval `(defgeneric |foo:bar:stuff:do:| (a b c d e &rest f)
+ (:generic-function-class objective-c-generic-function)
+ (:method-class objective-c-method))))
+ (is (eval `(define-objective-c-method |foo:bar:stuff:do:| :int
+ ((x ,class-name)
+ (y :int)
+ z
+ (a (eql t))
+ (b number)
+ &rest rest)
+ (declare (ignore z rest))
+ (+ y 150))))
+
;; Sanity checks.
(is (typep class 'objective-c-class))
(setq instance (is (invoke (invoke class 'alloc) 'init)))
@@ -427,6 +443,9 @@
;; creation.)
(is (foreign-class-registered-p class))
+ ;; Method calls.
+ (is (= 170 (invoke instance :foo 150 :bar nil :stuff t :do 100)))
+
;; Object identity preservation.
(is (eql instance
(invoke instance 'self)))