summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2008-02-12 18:20:54 +0100
committerMatthias Benkard <code@mail.matthias.benkard.de>2008-02-12 18:20:54 +0100
commit308b848cc4e6630356d84fc43530739a72374130 (patch)
tree5bc36df8d4fca2906951c473c508adbd75537dd5 /Lisp
parent1f87c8d3385203966e88711eae9bf0e5a7493b43 (diff)
When overriding a return type specification, save the nominal type for later use.
darcs-hash:40bdaeb5687e6ad142766f1ee041231e875c1d49
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/method-invocation.lisp10
-rw-r--r--Lisp/tests.lisp11
-rw-r--r--Lisp/type-handling.lisp26
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"