Make compile-time selector warnings work on the NeXT runtime, clean the Objective-C layer up a bit.

darcs-hash:bff1454e2749c658ed0d0ad4eb51c4b1802e6f40

2 files changed, 114 insertions, 16 deletions

diff --git a/Lisp/compiler-macros.lisp b/Lisp/compiler-macros.lisp
index 97aecb7..3ffba63 100644
--- a/Lisp/compiler-macros.lisp
+++ b/Lisp/compiler-macros.lisp
@@ -28,7 +28,7 @@
                      (eq 'load-time-value (car method-name)))))
       `(primitive-invoke ,receiver
                          (load-time-value (handler-case
-                                              (selector ,method-name)
+                                              (find-selector ,method-name t)
                                             (serious-condition ()
                                               (warn
                                                (make-condition
@@ -52,7 +52,7 @@
       `(invoke-by-name
         ,receiver
         (load-time-value (handler-case
-                             (selector ,method-name)
+                             (find-selector ,method-name t)
                            (serious-condition ()
                              (warn
                               (make-condition 'simple-style-warning
@@ -70,11 +70,15 @@
 ;; ones.
 (define-compiler-macro invoke (receiver message-start &rest message-components)
   (multiple-value-bind (method-name args)
-      (split-method-call message-start message-components)
+      (split-method-call (if (and (consp message-start)
+                                  (eq (first message-start) 'quote))
+                             (second message-start)
+                             message-start)
+                         message-components)
     `(invoke-by-name
       ,receiver
       (load-time-value (handler-case
-                           (selector ',method-name)
+                           (find-selector ',method-name t)
                          (serious-condition ()
                            (warn
                             (make-condition 'simple-style-warning
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index eeb6d0d..a18f373 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -61,6 +61,9 @@
 (defcfun ("objcl_find_selector" %objcl-find-selector) :pointer
   (selector-name :string))
 
+(defcfun ("objcl_intern_selector" %objcl-intern-selector) :pointer
+  (selector-name :string))
+
 (defcfun ("objcl_selector_name" %objcl-selector-name) :string
   (selector :pointer))
 
@@ -267,6 +270,14 @@ conventional case for namespace identifiers in Objective C."
         (make-pointer-wrapper 'selector :pointer selector-ptr))))
 
 
+(defun intern-selector-by-name (selector-name)
+  (let ((selector-ptr (%objcl-intern-selector selector-name)))
+    (assert (not (cffi:null-pointer-p selector-ptr))
+            (selector-ptr)
+            "%OBJCL-INTERN-SELECTOR must always return a selector.")
+    (make-pointer-wrapper 'selector :pointer selector-ptr)))
+
+
 (declaim (ftype (function ((or objc-class id exception)) string)
                 objc-class-name))
 (defun objc-class-name (class)
@@ -355,14 +366,17 @@ If *name* is the name of an existing selector:
                                     (pointer-to selector)))
 
 
-(declaim (ftype (function ((or selector string list)) (or null selector))
+(declaim (ftype (function ((or selector symbol string list) &optional t)
+                          (or null selector))
                 find-selector))
-(defun find-selector (selector-name)
+(defun find-selector (selector-name &optional errorp)
   "Retrieve a method selector by name.
 
 ## Arguments and Values:
 
-*selector-name* --- a **string** or a **list** of **symbol**s.
+*selector-name* --- a **string**, a **symbol**, or a **list** of **symbol**s.
+
+*errorp* --- a **generalized boolean**.
 
 Returns: *selector* --- a __selector__ object, or __nil__.
 
@@ -371,7 +385,11 @@ Returns: *selector* --- a __selector__ object, or __nil__.
 
 If *selector-name* is a **string**, the __selector__ named by that
 string is returned.  If no __selector__ with the given name exists,
-__nil__ is returned.
+either __nil__ is returned if errorp is **false**, or an error of type
+__no-such-selector__ is signaled if errorp is **true**.
+
+If *selector-name* is a **symbol**, it is treated the same as a **list**
+whose only element is the **symbol**.
 
 If *selector-name* is a **list** of **symbol**s, all **symbol**s are
 first split into parts separated by hyphens and each part converted into
@@ -399,17 +417,94 @@ by which __invoke__ converts its arguments into a *message name*.
 
     (find-selector \"self\")       ;=> #<SELECTOR `self'>
     (find-selector '(self))      ;=> #<SELECTOR `self'>
+    (find-selector 'self)        ;=> #<SELECTOR `self'>
 
     (find-selector \"stringWithCString:encoding:\")
       ;=> #<SELECTOR `stringWithCString:encoding:'>
 
     (find-selector '(:string-with-c-string :encoding))
-      ;=> #<SELECTOR `stringWithCString:encoding:'>"
+      ;=> #<SELECTOR `stringWithCString:encoding:'>
+
+
+## See also:
+
+  __intern-selector__"
+
+  (or (typecase selector-name
+        (string (find-selector-by-name selector-name))
+        (symbol (find-selector-by-name (symbol-list->message-name
+                                        (list selector-name))))
+        (list   (find-selector-by-name (symbol-list->message-name
+                                        selector-name))))
+      (and errorp
+           (error (make-condition 'no-such-selector :designator selector-name)))))
+
+
+(defun intern-selector (selector-name)
+  "Retrieve a method selector by name, or create it if it does not exist.
+
+## Arguments and Values:
+
+*selector-name* --- a **string**, a **symbol**, or a **list** of **symbol**s.
+
+Returns: *selector* --- a __selector__ object.
+
+
+## Description:
+
+If *selector-name* is a **string**, the __selector__ named by that
+string is returned.  If no __selector__ with the given name exists, such
+a selector is created and registered with the Objective-C runtime, after
+which it is returned.
+
+If *selector-name* is a **symbol**, it is treated the same as a **list**
+whose only element is the **symbol**.
+
+If *selector-name* is a **list** of **symbol**s, all **symbol**s are
+first split into parts separated by hyphens and each part converted into
+a **string** according to the following rules:
+
+1. The first part is fully converted to **lowercase**.
+
+2. Any additional parts are also fully converted to **lowercase** except
+   for their first letters, which are left intact.
+
+3. If the symbol is a **keyword**, the resulting **string** is suffixed
+   by a **colon** (`:').
+
+After that, all parts are concatenated in order to form a
+single *selector name component*.  The *selector name components* are in
+turn concatenated in order to form the **string** that identifies the
+selector, which is used as if given directly as an argument to a call to
+__intern-selector__.
+
+Note that the conversion rules for selector names are identical to those
+by which __invoke__ converts its arguments into a *message name*.
+
+
+## Examples:
+
+    (intern-selector \"self\")       ;=> #<SELECTOR `self'>
+    (intern-selector '(self))      ;=> #<SELECTOR `self'>
+    (intern-selector 'self)        ;=> #<SELECTOR `self'>
+
+    (intern-selector \"stringWithCString:encoding:\")
+      ;=> #<SELECTOR `stringWithCString:encoding:'>
+
+    (intern-selector '(:string-with-c-string :encoding))
+      ;=> #<SELECTOR `stringWithCString:encoding:'>
+
+
+## See also:
+
+  __find-selector__"
 
   (typecase selector-name
-    (string (find-selector-by-name selector-name))
-    (list   (find-selector-by-name (symbol-list->message-name
-                                    selector-name)))))
+    (string (intern-selector-by-name selector-name))
+    (symbol (intern-selector-by-name (symbol-list->message-name
+                                      (list selector-name))))
+    (list   (intern-selector-by-name (symbol-list->message-name
+                                      selector-name)))))
 
 
 (defun object-is-class-p (obj)
@@ -433,6 +528,7 @@ by which __invoke__ converts its arguments into a *message name*.
         ((object-is-class-p obj) (object-get-meta-class obj))
         (t (object-get-class obj))))
 
+
 ;;; (@* "Low-level Data Conversion")
 (eval-when (:compile-toplevel :load-toplevel)
   ;; In order to be able to dispatch over pointer types, we need to
@@ -464,8 +560,7 @@ either a __selector__ object or one of a **symbol**, a **string**, or a
 **list** of **symbol**s representing a __selector__.
 
 If *selector-designator* is a **string** or a **list** of **symbol**s,
-__find-selector__ is called and the value returned, except that if
-__find-selector__ returns __nil__, an **error** is **signal**ed.
+__intern-selector__ is called and the value returned.
 
 If *selector-designator* is a single **symbol**, it is treated as if it
 were a **list** whose **car** is the **symbol** and whose **cdr** is
@@ -493,8 +588,7 @@ If *selector-designator* is a __selector__, it is simply returned.
     (selector designator)
     (symbol (selector (list designator)))
     ((or string list)
-     (or (find-selector designator)
-         (error (make-condition 'no-such-selector :designator designator))))))
+     (intern-selector designator))))
 
 
 ;;;; (@* "Helper functions")