summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-02-16 16:19:04 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-02-16 16:19:04 +0100
commit89994d1bdaa674e92d3c647249cb7ff9bb85f2d9 (patch)
treed3a17f3b0acf51b62008421089c1dff902da51f5 /Lisp
parent82f36a23a52b6e25703a70c40568feb0cd0e3fd2 (diff)
Simplify compiler macros.
darcs-hash:b94237b9f0fd396e56186a7f3b62c9cce9971c55
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/compiler-macros.lisp63
1 files changed, 18 insertions, 45 deletions
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)))