diff options
| -rw-r--r-- | Lisp/method-definition.lisp | 53 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 2 | ||||
| -rw-r--r-- | Lisp/name-conversion.lisp | 4 | ||||
| -rw-r--r-- | Lisp/tests.lisp | 21 |
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))) |