From 89994d1bdaa674e92d3c647249cb7ff9bb85f2d9 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sat, 16 Feb 2008 16:19:04 +0100
Subject: Simplify compiler macros.

darcs-hash:b94237b9f0fd396e56186a7f3b62c9cce9971c55
---
 Lisp/compiler-macros.lisp | 63 ++++++++++++++---------------------------------
 1 file changed, 18 insertions(+), 45 deletions(-)

(limited to 'Lisp')

diff --git a/Lisp/compiler-macros.lisp b/Lisp/compiler-macros.lisp
index 79fd0a6..71f944b 100644
--- a/Lisp/compiler-macros.lisp
+++ b/Lisp/compiler-macros.lisp
@@ -18,6 +18,20 @@
 (in-package #:mulk.objective-cl)
 
 
+(defun selector-load-time-form (method-name)
+  `(load-time-value (handler-case
+                        (find-selector ',method-name)
+                      (serious-condition ()
+                        (warn
+                         (make-condition 'simple-style-warning
+                                         :format-control
+                                         "~S designates an unknown ~
+                                               method selector."
+                                         :format-arguments
+                                         (list ',method-name)))
+                        ',method-name))))
+
+
 ;; Optimise constant method names away by converting them to selectors
 ;; at load-time.
 (define-compiler-macro primitive-invoke (&whole form
@@ -27,18 +41,7 @@
            (not (and (listp method-name)
                      (eq 'load-time-value (car method-name)))))
       `(primitive-invoke ,receiver
-                         (load-time-value (handler-case
-                                              (find-selector ,method-name)
-                                            (serious-condition ()
-                                              (warn
-                                               (make-condition
-                                                'simple-style-warning
-                                                :format-control
-                                                "~S designates an unknown ~
-                                                 method selector."
-                                                :format-arguments
-                                                (list ,method-name)))
-                                              ,method-name)))
+                         ,(selector-load-time-form (eval method-name))
                          ,return-type ,@args)
       form))
 
@@ -51,17 +54,7 @@
                      (eq 'load-time-value (car method-name)))))
       `(invoke-by-name
         ,receiver
-        (load-time-value (handler-case
-                             (find-selector ,method-name)
-                           (serious-condition ()
-                             (warn
-                              (make-condition 'simple-style-warning
-                                              :format-control
-                                              "~S designates an unknown ~
-                                               method selector."
-                                              :format-arguments
-                                              (list ,method-name)))
-                             ,method-name)))
+        ,(selector-load-time-form (eval method-name))
         ,@args)
       form))
 
@@ -72,17 +65,7 @@
   (if (and (constantp method-name)
            (not (and (listp method-name)
                      (eq 'load-time-value (car method-name)))))
-      `(load-time-value (handler-case
-                            (find-selector ,method-name)
-                          (serious-condition ()
-                            (warn
-                             (make-condition 'simple-style-warning
-                                             :format-control
-                                             "~S designates an unknown ~
-                                               method selector."
-                                             :format-arguments
-                                             (list ,method-name)))
-                            ,method-name)))
+      (selector-load-time-form (eval method-name))
       form))
 
 
@@ -97,15 +80,5 @@
                          message-components)
     `(invoke-by-name
       ,receiver
-      (load-time-value (handler-case
-                           (find-selector ',method-name)
-                         (serious-condition ()
-                           (warn
-                            (make-condition 'simple-style-warning
-                                            :format-control
-                                            "~S designates an unknown ~
-                                               method selector."
-                                            :format-arguments
-                                            (list ',method-name)))
-                           ',method-name)))
+      ,(selector-load-time-form method-name)
       ,@args)))
-- 
cgit v1.2.3