When overriding a return type specification, save the nominal type for later use.

darcs-hash:40bdaeb5687e6ad142766f1ee041231e875c1d49

3 files changed, 35 insertions, 12 deletions

diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp
index 929162f..dd36dd3 100644
--- a/Lisp/method-invocation.lisp
+++ b/Lisp/method-invocation.lisp
@@ -415,7 +415,15 @@ easier to use with __apply__.
                                             objc-arg-ptrs)))
             (unless (cffi:null-pointer-p error-cell)
               (error (make-condition 'exception :pointer error-cell)))
-            (case (car return-type)
+            (case (let ((nominal-type (find-if #'(lambda (x)
+                                                   (and (consp x)
+                                                        (eq (car x) 'nominally)))
+                                               (cadr return-type))))
+                    ;; Do the modifiers include something like
+                    ;; (NOMINALLY :UNSIGNED-CHAR)?
+                    (if nominal-type
+                        (cadr nominal-type)
+                        (car return-type)))
               ((id objective-c-class exception selector)
                (let ((*skip-retaining*
                       (or *skip-retaining*
diff --git a/Lisp/tests.lisp b/Lisp/tests.lisp
index 1a63d9d..60e9387 100644
--- a/Lisp/tests.lisp
+++ b/Lisp/tests.lisp
@@ -23,7 +23,8 @@
                           #:struct #:union #:pointer #:oneway #:out #:in
                           #:inout #:const #:parse-typespec #:objective-c-class
                           #:bit-field #:opaque #:bycopy #:byref
-                          #:primitive-invoke #:print-typespec-to-string))
+                          #:primitive-invoke #:print-typespec-to-string
+                          #:nominally))
 (in-package #:mulk.objective-cl.tests)
 (in-root-suite)
 
@@ -194,8 +195,8 @@
                    (:char ())
                    (:unsigned-char ()))
                   (struct () "?"
-                   (:int ())
-                   (:unsigned-int ())))
+                   (:int ((nominally :char)))
+                   (:unsigned-int ((nominally :unsigned-char)))))
                 :test #'equalp)))
   (let ((funky-spec (parse-typespec "{?=sS}")))
     (is (member funky-spec
@@ -203,8 +204,8 @@
                    (:short ())
                    (:unsigned-short ()))
                   (struct () "?"
-                   (:int ())
-                   (:unsigned-int ())))
+                   (:int ((nominally :short)))
+                   (:unsigned-int ((nominally :unsigned-short)))))
                 :test #'equalp)))
   (is (equal (parse-typespec "{Mulk=*{Untermulk={Unteruntermulk=}}i}")
              '(struct () "Mulk"
diff --git a/Lisp/type-handling.lisp b/Lisp/type-handling.lisp
index 601afab..b8ff2a2 100644
--- a/Lisp/type-handling.lisp
+++ b/Lisp/type-handling.lisp
@@ -175,22 +175,30 @@ Returns: (VALUES typespec byte-position string-position)"
                                  (#\c (if (and (eq +runtime-type+ :next)
                                                (or return-type-p
                                                    (featurep 'cffi-features:ppc32)))
-                                          :int
+                                          (prog1 :int
+                                            (push '(nominally :char)
+                                                  qualifiers))
                                           :char))
                                  (#\C (if (and (eq +runtime-type+ :next)
                                                (or return-type-p
                                                    (featurep 'cffi-features:ppc32)))
-                                          :unsigned-int
+                                          (prog1 :unsigned-int
+                                            (push '(nominally :unsigned-char)
+                                                  qualifiers))
                                           :unsigned-char))
                                  (#\s (if (and (eq +runtime-type+ :next)
                                                (or return-type-p
                                                    (featurep 'cffi-features:ppc32)))
-                                          :int
+                                          (prog1 :int
+                                            (push '(nominally :short)
+                                                  qualifiers))
                                           :short))
                                  (#\S (if (and (eq +runtime-type+ :next)
                                                (or return-type-p
                                                    (featurep 'cffi-features:ppc32)))
-                                          :unsigned-int
+                                          (prog1 :unsigned-int
+                                            (push '(nominally :unsigned-short)
+                                                  qualifiers))
                                           :unsigned-short))
                                  (#\i :int)
                                  (#\I :unsigned-int)
@@ -233,7 +241,7 @@ Returns: (VALUES typespec byte-position string-position)"
   (destructuring-bind (type-name modifiers &rest rest)
       typespec
     (dolist (modifier modifiers)
-      (format stream "~A" (ecase modifier
+      (format stream "~A" (case modifier
                             (const #\r)
                             (in #\n)
                             (inout #\N)
@@ -241,7 +249,13 @@ Returns: (VALUES typespec byte-position string-position)"
                             (bycopy #\O)
                             (oneway #\V)
                             (byref #\R)
-                            (opaque ""))))
+                            (opaque "")
+                            (otherwise
+                             (assert (listp modifier))
+                             (ecase (first modifier)
+                               ((nominally) (setq type-name
+                                                  (second modifier))))
+                             ""))))
     (case type-name
       ((struct union) (destructuring-bind (name . children) rest
                         (format stream "~C~A"