From 2e26057818b48da27a5355e2d2101cb8605b840f Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Mon, 3 Mar 2008 17:30:46 +0100
Subject: Implement ADD-METHOD :AFTER (OBJECTIVE-C-GENERIC-FUNCTION
 OBJECTIVE-C-METHOD).

darcs-hash:16207045b44287e0f3f332937d826d1cc6c44296
---
 Lisp/method-definition.lisp | 53 +++++++++++++++++++++++++++++++++++++++++++++
 Lisp/method-invocation.lisp |  2 +-
 Lisp/name-conversion.lisp   |  4 ++++
 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)))
-- 
cgit v1.2.3