summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Lisp/compiler-macros.lisp70
-rw-r--r--Lisp/method-invocation.lisp84
-rw-r--r--objective-cl.asd4
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)