From 25cc1a489ff21bedae0a9ebfc9b462113ccc56c7 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 14 Sep 2007 20:21:46 +0200
Subject: Introduce PRIMITIVE-INVOKE, a lower-level INVOKE-BY-NAME alternative
 written in Lisp only.

darcs-hash:cc01d5054194e3be05efa9fc002da30e04d7068e
---
 Lisp/data-types.lisp        | 16 ++++++++--------
 Lisp/libobjcl.lisp          |  2 +-
 Lisp/method-invocation.lisp | 34 ++++++++++++++++++++++++++++++++++
 3 files changed, 43 insertions(+), 9 deletions(-)

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index b22057f..35acb2f 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -172,10 +172,10 @@ an __exception__, you can simply send it the `self' message.
 (defmethod print-object ((object id) stream)
   (print-unreadable-object (object stream)
     (format stream "~A `~A' {~X}"
-            (objcl-class-name (invoke-by-name object "class"))
-            (invoke-by-name (invoke-by-name object "description")
-                            "UTF8String")
-            (invoke-by-name object "hash"))))
+            (objcl-class-name (primitive-invoke object "class" :id))
+            (primitive-invoke (primitive-invoke object "description" :id)
+                              "UTF8String" :string)
+            (primitive-invoke object "hash" :unsigned-int))))
 
 
 (defmethod print-object ((class objc-class) stream)
@@ -183,7 +183,7 @@ an __exception__, you can simply send it the `self' message.
     (format stream "~S ~A {~X}"
             'objc-class
             (objcl-class-name class)
-            (invoke-by-name class "hash"))))
+            (primitive-invoke class "hash" :unsigned-int))))
 
 
 (defmethod print-object ((selector selector) stream)
@@ -197,9 +197,9 @@ an __exception__, you can simply send it the `self' message.
   (print-unreadable-object (exception stream)
     (format stream "~S ~A {~X}"
             'exception
-            (invoke-by-name (invoke-by-name exception "name")
-                            "UTF8String")
-            (invoke-by-name exception "hash"))))
+            (primitive-invoke (primitive-invoke exception "name" :id)
+                              "UTF8String" :string)
+            (primitive-invoke exception "hash" :unsigned-int))))
 
 
 ;;;; (@* "Convenience types")
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index bf80c30..d5d7379 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -290,7 +290,7 @@ by which __invoke__ converts its arguments into a *message name*.
     '(satisfies cffi:pointerp)))
 
 
-(declaim (ftype (function ((or selector string list)) selector)
+(declaim (ftype (function ((or selector string symbol list)) selector)
                 selector))
 (defun selector (designator)
   "Convert an object into a selector.
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 99ebf7b..5da06b8 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -147,6 +147,40 @@ Returns: *result* --- the return value of the method invocation.
         (dealloc-objc-arglist objc-arglist)))))
 
 
+(defmacro primitive-invoke (receiver method-name return-type &rest args)
+  (let ((real-return-type (if (member return-type '(:id :class :exception))
+                              :pointer
+                              return-type))
+        (real-receiver (gensym))
+        (real-selector (gensym))
+        (selector (selector method-name)))
+    `(progn
+       (let ((,real-receiver ,receiver)
+             (,real-selector (selector ,method-name)))
+         (check-type ,real-receiver (or id objc-class exception)
+                     "an Objective C instance (ID, OBJC-CLASS or EXCEPTION)")
+         (let ((method (get-method-implementation ,real-receiver ,real-selector))
+               (objc-arglist (arglist->objc-arglist (list ,@args))))
+           (unwind-protect
+               (let ((return-value
+                      (apply-macro 'foreign-funcall-pointer method
+                                   ()
+                                   (append (list :pointer (pointer-to ,real-receiver))
+                                           (list :pointer (pointer-to ,real-selector))
+                                           objc-arglist
+                                           (list ,real-return-type)))))
+                 ,(if (member return-type '(:id :class :exception))
+                      `(let (,@(when (constructor-name-p (selector-name selector))
+                                 `((*skip-retaining* t))))
+                         (make-instance ',(case return-type
+                                            ((:id) 'id)
+                                            ((:class) 'objc-class)
+                                            ((:exception) 'exception))
+                            :pointer return-value))
+                      `return-value))
+             (dealloc-objc-arglist objc-arglist)))))))
+
+
 ;;; (@* "Helper functions")
 (defun arglist->objc-arglist (arglist)
   (arglist-intersperse-types (mapcar #'lisp->obj-data arglist)))
-- 
cgit v1.2.3