diff options
| -rw-r--r-- | Lisp/compiler-macros.lisp | 70 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 84 | ||||
| -rw-r--r-- | objective-cl.asd | 4 |
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) |