Mimic the way PyObjC handles types.

darcs-hash:d7cf81f2dd93817e55a04816f3851fabce3dac55

5 files changed, 66 insertions, 19 deletions

diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp
index 1a117f8..6578971 100644
--- a/Lisp/internal-utilities.lisp
+++ b/Lisp/internal-utilities.lisp
@@ -23,6 +23,10 @@
   `(progn ,@body))
 
 
+(defun featurep (symbol)
+  (member symbol *features*))
+
+
 (defmacro with-foreign-string-pool ((register-fn-name) &body body)
   (let ((pool-var (gensym)))
     `(let ((,pool-var (list)))
diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 6169a59..8f80621 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -298,7 +298,7 @@ easier to use with __apply__.
          (method-return-typestring (primitive-invoke signature
                                                      'method-return-type
                                                      :string))
-         (method-return-type (parse-typespec method-return-typestring))
+         (method-return-type (parse-typespec method-return-typestring t))
          (method-arg-typestrings (loop for x from 0 below argc
                                        collect (primitive-invoke
                                                          signature
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index b8ac773..c3e6e5a 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -96,7 +96,8 @@
                                         "Klum.")))
    ((ensure-same +yes+
                  (primitive-invoke (find-objc-class 'ns-string)
-                                   :is-subclass-of-class :char
+                                   :is-subclass-of-class
+                                   (first (parse-typespec "c" t))
                                    (find-objc-class 'ns-object))))
    ;; performSelector:withObject: cannot be used with non-id return
    ;; types.
@@ -169,13 +170,9 @@
                  '(pointer ()
                    (array () 100
                     (struct () "?" (:int ()) (:int ()))))))
-   ((ensure-same (parse-typespec "{?=BcCsSiIlLqQfd@#:*?}")
+   ((ensure-same (parse-typespec "{?=BiIlLqQfd@#:*?}")
                  '(struct () "?"
                    (:boolean ())
-                   (:char ())
-                   (:unsigned-char ())
-                   (:short ())
-                   (:unsigned-short ())
                    (:int ())
                    (:unsigned-int ())
                    (:long ())
@@ -187,6 +184,24 @@
                    (id ()) (objc-class ()) (selector ())
                    (:string ())
                    (:unknown ()))))
+   ((ensure (let ((funky-spec (parse-typespec "{?=cC}")))
+              (member funky-spec
+                      '((struct () "?"
+                         (:char ())
+                         (:unsigned-char ()))
+                        (struct () "?"
+                         (:int ())
+                         (:unsigned-int ())))
+                      :test #'equalp))))
+   ((ensure (let ((funky-spec (parse-typespec "{?=sS}")))
+              (member funky-spec
+                      '((struct () "?"
+                         (:short ())
+                         (:unsigned-short ()))
+                        (struct () "?"
+                         (:int ())
+                         (:unsigned-int ())))
+                      :test #'equalp))))
    ((ensure-same (parse-typespec "{Mulk=*{Untermulk={Unteruntermulk=}}i}")
                  '(struct () "Mulk"
                    (:string ())
diff --git a/Lisp/type-handling.lisp b/Lisp/type-handling.lisp
index 152a016..abee5ae 100644
--- a/Lisp/type-handling.lisp
+++ b/Lisp/type-handling.lisp
@@ -18,7 +18,7 @@
 (in-package #:mulk.objective-cl)
 
 
-(defun parse-typespec (typestring &optional (start 0))
+(defun parse-typespec (typestring &optional return-type-p (start 0))
   "Parse a typestring like \"@0:4{_NSRange=II}8\" into something like (ID ()).
 
 \"rn{_NSRange=II}8\" is parsed into (STRUCT (CONST IN)
@@ -79,6 +79,7 @@ Returns: (VALUES typespec byte-position string-position)"
                                                               new-string-pos)
                                             (parse-typespec
                                              typestring
+                                             nil
                                              string-position)
                                           (declare (ignore byte-position))
                                           (setq string-position new-string-pos)
@@ -88,7 +89,9 @@ Returns: (VALUES typespec byte-position string-position)"
               (#\^ (list 'pointer
                          qualifiers
                          (multiple-value-bind (typespec byte-pos new-str-pos)
-                             (parse-typespec typestring (1+ string-position))
+                             (parse-typespec typestring
+                                             nil
+                                             (1+ string-position))
                            (declare (ignore byte-pos))
                            (prog1 typespec
                                   (setq string-position new-str-pos)))))
@@ -101,7 +104,7 @@ Returns: (VALUES typespec byte-position string-position)"
                            (prog1 count
                                   (setq string-position new-str-pos)))
                          (multiple-value-bind (typespec byte-pos new-str-pos)
-                             (parse-typespec typestring string-position)
+                             (parse-typespec typestring nil string-position)
                            (declare (ignore byte-pos))
                            ;; Skip end marker (right bracket).
                            (prog1 typespec
@@ -110,7 +113,7 @@ Returns: (VALUES typespec byte-position string-position)"
                (list 'complex
                      qualifiers
                      (multiple-value-bind (typespec byte-pos new-str-pos)
-                         (parse-typespec typestring (1+ string-position))
+                         (parse-typespec typestring nil (1+ string-position))
                        (declare (ignore byte-pos))
                        (prog1 typespec
                               (setq string-position new-str-pos)))))
@@ -126,7 +129,7 @@ Returns: (VALUES typespec byte-position string-position)"
                  (multiple-value-setq (bit-field-typespec
                                        byte-position
                                        string-position)
-                     (parse-typespec typestring string-position))
+                     (parse-typespec typestring nil string-position))
                  (multiple-value-setq (bit-field-length string-position)
                      (parse-integer typestring
                                     :start string-position
@@ -138,11 +141,31 @@ Returns: (VALUES typespec byte-position string-position)"
                        bit-field-typespec)))
               (otherwise
                (prog1 (list (case init-char
-                              (#\B :boolean)
-                              (#\c :char)
-                              (#\C :unsigned-char)
-                              (#\s :short)
-                              (#\S :unsigned-short)
+                              (#\B :boolean) ;XXX :int?
+                              (#\c (if (or return-type-p
+                                           (eq +runtime-type+ :gnu)
+                                           (and (eq +runtime-type+ :next)
+                                                (featurep 'cffi-features:ppc32)))
+                                       :int
+                                       :char))
+                              (#\C (if (or return-type-p
+                                           (eq +runtime-type+ :gnu)
+                                           (and (eq +runtime-type+ :next)
+                                                (featurep 'cffi-features:ppc32)))
+                                       :unsigned-int
+                                       :unsigned-char))
+                              (#\s (if (or return-type-p
+                                           (eq +runtime-type+ :gnu)
+                                           (and (eq +runtime-type+ :next)
+                                                (featurep 'cffi-features:ppc32)))
+                                       :int
+                                       :short))
+                              (#\S (if (or return-type-p
+                                           (eq +runtime-type+ :gnu)
+                                           (and (eq +runtime-type+ :next)
+                                                (featurep 'cffi-features:ppc32)))
+                                       :unsigned-int
+                                       :unsigned-short))
                               (#\i :int)
                               (#\I :unsigned-int)
                               (#\l :long)
diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp
index 5ead57a..a1b3c4e 100644
--- a/Lisp/utilities.lisp
+++ b/Lisp/utilities.lisp
@@ -152,12 +152,17 @@ invocations will return numbers.)
 
 
 (defun id-equal (x y)
+  ;; Note that we have to use INVOKE rather than PRIMITIVE-INVOKE here,
+  ;; because we don't know wheter BOOL == char.  We don't even know
+  ;; whether the typespec "c" indicates a char or an int, for that
+  ;; matter (it only does so on NeXT/x86, but neither on GNUstep nor on
+  ;; NeXT/ppc32).
   (or (id-eql x y)
       (truep (if (typep x '(or id objc-class exception))
-                 (primitive-invoke x :is-equal :char y)
+                 (invoke x :is-equal y)
                  (progn
                    (assert (typep y '(or id objc-class exception)))
-                   (primitive-invoke y :is-equal :char x))))))
+                   (invoke y :is-equal x))))))
 
 
 (defun objc-typep (x class-designator)