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

darcs-hash:bff1454e2749c658ed0d0ad4eb51c4b1802e6f40

5 files changed, 170 insertions, 19 deletions

diff --git a/JOURNAL b/JOURNAL
index 77f7021..55ad1ba 100644
--- a/JOURNAL
+++ b/JOURNAL
@@ -1,5 +1,36 @@
 -*- mode: muse -*-
 
+* 2007-10-10, 12:02:38 CEST
+
+I've cleaned the Objective-C code up by making the NeXT and GNU
+runtime-specific code converge a bit.  This also makes FIND-SELECTOR
+return NIL for unknown selectors on the NeXT runtime, so compile-time
+warnings about unknown methods are possible there now.  The latter
+relies on sel_isMapped, whose semantics are not entirely clear to me.
+On the one hand, Apple's reference manual states: “You can use this
+function to determine whether a given address is a valid selector,”
+which I interpret as meaning that it takes a selector pointer as an
+argument, not a string.  On the other hand, in the preceding section,
+the same document states: “You can still use the sel_isMapped function
+to determine whether a method name is mapped to a selector.”
+
+So if I have two strings that aren't the same under POINTER-EQ, but that
+both name the same valid selector that is registered with the runtime,
+like "self", say, does sel_isMapped work reliably in this case?  I'm not
+sure.
+
+On another note, I wonder what the difference between
+sel_get_uid/sel_getUid and sel_register_name/sel_registerName might be.
+They seem to do the same thing.
+
+Maybe this whole #ifdef mess isn't even strictly necessary, anyway.  I
+could just copy objc-gnu2next.h from the GNUstep project (LGPLv3, so the
+licensing is fine).
+
+http://svn.gna.org/svn/gnustep/libs/base/trunk/Headers/Additions/GNUstepBase/objc-gnu2next.h
+
+
+
 * 2007-10-04, 17:27:02 CEST
 
 ** `char' Does Actually Indicate a Char, Sometimes
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")
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index 56ba2d7..9a48a1e 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -49,6 +49,9 @@ objcl_find_meta_class (const char *class_name);
 SEL
 objcl_find_selector (const char *selector_name);
 
+SEL
+objcl_intern_selector (const char *selector_name);
+
 /* Return a null-terminated list of type information strings.
    The first entry describes the type of the method's return value. */
 char **
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index 6f09cfe..de899e3 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -131,7 +131,7 @@ objcl_find_class (const char *class_name)
 #ifdef __NEXT_RUNTIME__
   return objc_lookUpClass (class_name);
 #else
-  return NSClassFromString ([NSString stringWithUTF8String: class_name]);
+  return objc_lookup_class (class_name);
 #endif
 }
 
@@ -153,9 +153,28 @@ objcl_find_meta_class (const char *class_name)
 
 
 SEL
-objcl_find_selector (const char *class_name)
+objcl_find_selector (const char *selector_name)
 {
-  return NSSelectorFromString ([NSString stringWithUTF8String: class_name]);
+#ifdef __NEXT_RUNTIME__
+  if (!(sel_isMapped ((SEL) selector_name)))  /* XXX Does this work? */
+    return NULL;
+  else
+    return sel_getUid (selector_name);
+#else
+  return sel_get_any_uid (selector_name);
+#endif
+}
+
+
+SEL
+objcl_intern_selector (const char *selector_name)
+{
+  /* sel_registerName and sel_register_name seem not to be necessary here. */
+#ifdef __NEXT_RUNTIME__
+  return sel_getUid (selector_name);
+#else
+  return sel_get_uid (selector_name);
+#endif
 }