Add a compiler macro for INVOKE.

darcs-hash:93b465085160cfe9dc8978554acdfca73670f6f6

3 files changed, 92 insertions, 66 deletions

diff --git a/Lisp/compiler-macros.lisp b/Lisp/compiler-macros.lisp
new file mode 100644
index 0000000..ba29c2d
--- /dev/null
+++ b/Lisp/compiler-macros.lisp
@@ -0,0 +1,70 @@
+(in-package #:mulk.objective-cl)
+
+
+;; Optimise constant method names away by converting them to selectors
+;; at load-time.
+(define-compiler-macro primitive-invoke (&whole form
+                                         receiver method-name return-type
+                                         &rest args)
+  (if (and (constantp method-name)
+           (not (and (listp method-name)
+                     (eq 'load-time-value (car method-name)))))
+      `(primitive-invoke ,receiver
+                         (load-time-value (handler-case
+                                              (selector ,method-name)
+                                            (serious-condition ()
+                                              (warn
+                                               (make-condition
+                                                'style-warning
+                                                :format-control
+                                                "~S designates an unknown ~
+                                                 method selector."
+                                                :format-arguments
+                                                (list ,method-name)))
+                                              ,method-name)))
+                         ,return-type ,@args)
+      form))
+
+
+;; Do the same optimisations for INVOKE-BY-NAME as for PRIMITIVE-INVOKE.
+(define-compiler-macro invoke-by-name (&whole form
+                                       receiver method-name &rest args)
+  (if (and (constantp method-name)
+           (not (and (listp method-name)
+                     (eq 'load-time-value (car method-name)))))
+      `(invoke-by-name
+        ,receiver
+        (load-time-value (handler-case
+                             (selector ,method-name)
+                           (serious-condition ()
+                             (warn
+                              (make-condition 'style-warning
+                                              :format-control
+                                              "~S designates an unknown ~
+                                               method selector."
+                                              :format-arguments
+                                              (list ,method-name)))
+                             ,method-name)))
+        ,@args)
+      form))
+
+
+;; This compiler macro is a bit more complicated than the preceding
+;; ones.
+(define-compiler-macro invoke (receiver message-start &rest message-components)
+  (multiple-value-bind (method-name args)
+      (split-method-call message-start message-components)
+    `(invoke-by-name
+      ,receiver
+      (load-time-value (handler-case
+                           (selector ',method-name)
+                         (serious-condition ()
+                           (warn
+                            (make-condition 'style-warning
+                                            :format-control
+                                            "~S designates an unknown ~
+                                               method selector."
+                                            :format-arguments
+                                            (list ',method-name)))
+                           ',method-name)))
+      ,@args)))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 7334fc3..c66661c 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -65,23 +65,9 @@ if as the second **argument** to __invoke-by-name__.
 
   __invoke-by-name__"
 
-  (check-type receiver (or id objc-class exception)
-              "an Objective C instance (ID, OBJC-CLASS or EXCEPTION)")
-  (do* ((components-left (cons message-start message-components)
-                         (cddr components-left))
-        (message-list    (list message-start)
-                         (cons (first components-left) message-list))
-        (arglist         (if (null (rest components-left))
-                             nil
-                             (list (second components-left)))
-                         (if (null (rest components-left))
-                             arglist
-                             (cons (second components-left) arglist))))
-       ((null (cddr components-left))
-        (apply #'invoke-by-name
-               receiver
-               (nreverse message-list)
-               (nreverse arglist)))))
+  (multiple-value-bind (message arglist)
+      (split-method-call message-start message-components)
+    (apply #'invoke-by-name receiver message arglist)))
 
 
 (defun invoke-by-name (receiver method-name &rest args)
@@ -145,6 +131,22 @@ Returns: *result* --- the return value of the method invocation.
                         args))))
 
 
+(defun split-method-call (message-start message-components)
+  (do* ((components-left (cons message-start message-components)
+                         (cddr components-left))
+        (message-list    (list message-start)
+                         (cons (first components-left) message-list))
+        (arglist         (if (null (rest components-left))
+                             nil
+                             (list (second components-left)))
+                         (if (null (rest components-left))
+                             arglist
+                             (cons (second components-left) arglist))))
+       ((null (cddr components-left))
+        (values (nreverse message-list)
+                (nreverse arglist)))))
+
+
 (defun primitive-invoke (receiver method-name return-type &rest args)
   "An invocation mechanism with ad-hoc argument conversion."
   (with-foreign-string-pool (register-temporary-string)
@@ -391,54 +393,6 @@ Returns: *result* --- the return value of the method invocation.
                                        return-c-type)))))))))
 
 
-;; Optimise constant method names away by converting them to selectors
-;; at load-time.
-(define-compiler-macro primitive-invoke (&whole form
-                                         receiver method-name return-type
-                                         &rest args)
-  (if (and (constantp method-name)
-           (not (and (listp method-name)
-                     (eq 'load-time-value (car method-name)))))
-      `(primitive-invoke ,receiver
-                         (load-time-value (handler-case
-                                              (selector ,method-name)
-                                            (serious-condition ()
-                                              (warn
-                                               (make-condition
-                                                'style-warning
-                                                :format-control
-                                                "~S designates an unknown ~
-                                                 method selector."
-                                                :format-arguments
-                                                (list ,method-name)))
-                                              ,method-name)))
-                         ,return-type ,@args)
-      form))
-
-
-;; Do the same optimisations for INVOKE-BY-NAME as for PRIMITIVE-INVOKE.
-(define-compiler-macro invoke-by-name (&whole form
-                                       receiver method-name &rest args)
-  (if (and (constantp method-name)
-           (not (and (listp method-name)
-                     (eq 'load-time-value (car method-name)))))
-      `(invoke-by-name
-        ,receiver
-        (load-time-value (handler-case
-                             (selector ,method-name)
-                           (serious-condition ()
-                             (warn
-                              (make-condition 'style-warning
-                                              :format-control
-                                              "~S designates an unknown ~
-                                               method selector."
-                                              :format-arguments
-                                              (list ,method-name)))
-                             ,method-name)))
-        ,@args)
-      form))
-
-
 ;;; (@* "Helper functions")
 (defun constructor-name-p (method-name)
   (flet ((method-name-starts-with (prefix)
diff --git a/objective-cl.asd b/objective-cl.asd
index 0942370..d0bff56 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -41,5 +41,7 @@
                  (:file "utilities"          :depends-on ("init"
                                                           "defpackage"
                                                           "method-invocation"
-                                                          "data-types")))))
+                                                          "data-types"))
+                 (:file "compiler-macros"    :depends-on ("defpackage"
+                                                          "method-invocation")))))
   :serial t)