Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv19109/src/code
Modified Files:
target-alieneval.lisp
Log Message:
1.0.38.9: Integer callback result fixes.
* Callback results should be typechecked based on their declared
type, but stored as if they were the full width of a machine register.
* Fixed sb-alien::alien-callback-lisp-wrapper-lambda to make this
happen properly.
* Updated corresponding tests (formerly callback.impure.lisp /
sign-extension and underflow-detection) to cover 16-bit cases, which
would have broken on all targets, not merely 64-bit targets.
* As a minor side note, assistance in testing the changes in 1.0.38.8
was provided by one Andreas Selfjord Eriksen, but I forgot to note this
fact in the commit message. Mea Culpa.
Index: target-alieneval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-alieneval.lisp,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -d -r1.58 -r1.59
--- target-alieneval.lisp 24 Apr 2009 10:44:10 -0000 1.58
+++ target-alieneval.lisp 21 May 2010 01:03:25 -0000 1.59
@@ -822,22 +822,31 @@
:local ,(alien-callback-accessor-form
spec 'args-sap offset))
do (incf offset (alien-callback-argument-bytes spec env)))
- ,(flet ((store (spec)
+ ,(flet ((store (spec real-type)
(if spec
`(setf (deref (sap-alien res-sap (* ,spec)))
- (funcall function ,@arguments))
+ ,(if real-type
+ `(the ,real-type
+ (funcall function ,@arguments))
+ `(funcall function ,@arguments)))
`(funcall function ,@arguments))))
(cond ((alien-void-type-p result-type)
- (store nil))
+ (store nil nil))
((alien-integer-type-p result-type)
+ ;; Integer types should be padded out to a full
+ ;; register width, to comply with most ABI calling
+ ;; conventions, but should be typechecked on the
+ ;; declared type width, hence the following:
(if (alien-integer-type-signed result-type)
(store `(signed
- ,(alien-type-word-aligned-bits result-type)))
+ ,(alien-type-word-aligned-bits result-type))
+ `(signed-byte ,(alien-type-bits result-type)))
(store
`(unsigned
- ,(alien-type-word-aligned-bits result-type)))))
+ ,(alien-type-word-aligned-bits result-type))
+ `(unsigned-byte ,(alien-type-bits result-type)))))
(t
- (store (unparse-alien-type result-type)))))))
+ (store (unparse-alien-type result-type) nil))))))
(values))))
(defun invalid-alien-callback (&rest arguments)
|