Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

5 changed files:

Changes:

  • bin/run-tests.sh
    ... ... @@ -47,6 +47,11 @@ function cleanup {
    47 47
    48 48 
     trap cleanup EXIT
    49 49
    50 
    +# Compile up the C file that is used for testing alien funcalls to
    51 
    +# functions that return integer types of different lengths.  We use
    52 
    +# gcc since clang isn't always available.
    53 
    +(cd tests; gcc -m32 -O3 -c test-return.c)
    54 
    +
    50 55 
     if [ $# -eq 0 ]; then
    51 56 
         # No args so run all the tests
    52 57 
         $LISP -noinit -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)'

  • src/code/alieneval.lisp
    ... ... @@ -170,6 +170,9 @@
    170 170 
       (alien-rep nil :type (or null function))
    171 171 
       (extract-gen nil :type (or null function))
    172 172 
       (deposit-gen nil :type (or null function))
    173 
    +  ;;
    174 
    +  ;; Method that accepts the alien type and the alien value.  The
    175 
    +  ;; method converts the alien value into an appropriate lisp value.
    173 176 
       (naturalize-gen nil :type (or null function))
    174 177 
       (deport-gen nil :type (or null function))
    175 178 
       ;; Cast?
    ... ... @@ -646,8 +649,26 @@
    646 649
    647 650 
     #-amd64
    648 651 
     (def-alien-type-method (integer :naturalize-gen) (type alien)
    649 
    -  (declare (ignore type))
    650 
    -  alien)
    652 
    +  ;; Mask out any unwanted bits.  Important if the C code returns
    653 
    +  ;; values in %al, or %ax
    654 
    +  (if (alien-integer-type-signed type)
    655 
    +      (let ((val (gensym "VAL-")))
    656 
    +	(case (alien-integer-type-bits type)
    657 
    +	  ;; First, get just the low part of the alien and then
    658 
    +	  ;; sign-extend it appropriately.
    659 
    +	  (8 `(let ((,val (ldb (byte 8 0) ,alien)))
    660 
    +		(if (> ,val #x7f)
    661 
    +		    (- ,val #x100)
    662 
    +		    ,val)))
    663 
    +	  (16 `(let ((,val (ldb (byte 16 0) ,alien)))
    664 
    +		 (if (> ,val #x7fff)
    665 
    +		     (- ,val #x10000)
    666 
    +		     ,val)))
    667 
    +	  (t alien)))
    668 
    +      (case (alien-integer-type-bits type)
    669 
    +	(8 `(ldb (byte 8 0) (truly-the (unsigned-byte 32) ,alien)))
    670 
    +	(16 `(ldb (byte 16 0) (truly-the (unsigned-byte 32) ,alien)))
    671 
    +	(t alien))))
    651 672
    652 673 
     ;; signed numbers <= 32 bits need to be sign extended.
    653 674 
     ;; I really should use the movsxd instruction, but I don't
    ... ... @@ -694,8 +715,8 @@
    694 715
    695 716 
     (def-alien-type-class (boolean :include integer :include-args (signed)))
    696 717
    697 
    -(def-alien-type-translator boolean (&optional (bits vm:word-bits))
    698 
    -  (make-alien-boolean-type :bits bits :signed nil))
    718 
    +(def-alien-type-translator boolean (&optional (bits 8))
    719 
    +  (make-alien-boolean-type :bits bits :signed t))
    699 720
    700 721 
     (def-alien-type-method (boolean :unparse) (type)
    701 722 
       `(boolean ,(alien-boolean-type-bits type)))
    ... ... @@ -705,8 +726,10 @@
    705 726 
       `(member t nil))
    706 727
    707 728 
     (def-alien-type-method (boolean :naturalize-gen) (type alien)
    708 
    -  (declare (ignore type))
    709 
    -  `(not (zerop ,alien)))
    729 
    +  ;; Mask out any unwanted bits.  Important if the C code returns
    730 
    +  ;; values in %al, or %ax
    731 
    +  `(not (zerop (ldb (byte ,(alien-boolean-type-bits type) 0)
    732 
    +		    ,alien))))
    710 733
    711 734 
     (def-alien-type-method (boolean :deport-gen) (type value)
    712 735 
       (declare (ignore type))

  • src/compiler/x86/c-call.lisp
    ... ... @@ -141,59 +141,78 @@
    141 141 
     					(alien-function-type-result-type type)
    142 142 
     					(make-result-state))))))
    143 143
    144 
    -(deftransform %alien-funcall ((function type &rest args))
    145 
    -  (assert (c::constant-continuation-p type))
    144 
    +(defun %alien-funcall-aux (function type &rest args)
    145 
    +  (declare (ignorable function type args))
    146 146 
       (let* ((type (c::continuation-value type))
    147 147 
     	 (arg-types (alien-function-type-arg-types type))
    148 148 
     	 (result-type (alien-function-type-result-type type)))
    149 149 
         (assert (= (length arg-types) (length args)))
    150 
    -    (if (or (some #'(lambda (type)
    151 
    -		      (and (alien-integer-type-p type)
    152 
    -			   (> (alien::alien-integer-type-bits type) 32)))
    153 
    -		  arg-types)
    154 
    -	    (and (alien-integer-type-p result-type)
    155 
    -		 (> (alien::alien-integer-type-bits result-type) 32)))
    156 
    -	(collect ((new-args) (lambda-vars) (new-arg-types))
    157 
    -	  (dolist (type arg-types)
    158 
    -	    (let ((arg (gensym)))
    159 
    -	      (lambda-vars arg)
    160 
    -	      (cond ((and (alien-integer-type-p type)
    161 
    -			  (> (alien::alien-integer-type-bits type) 32))
    162 
    -		     (new-args `(logand ,arg #xffffffff))
    163 
    -		     (new-args `(ash ,arg -32))
    164 
    -		     (new-arg-types (parse-alien-type '(unsigned 32)))
    165 
    -		     (if (alien-integer-type-signed type)
    166 
    -			 (new-arg-types (parse-alien-type '(signed 32)))
    167 
    -			 (new-arg-types (parse-alien-type '(unsigned 32)))))
    168 
    -		    (t
    169 
    -		     (new-args arg)
    170 
    -		     (new-arg-types type)))))
    171 
    -	  (cond ((and (alien-integer-type-p result-type)
    172 
    -		      (> (alien::alien-integer-type-bits result-type) 32))
    173 
    -		 (let ((new-result-type
    174 
    -			(let ((alien::*values-type-okay* t))
    175 
    -			  (parse-alien-type
    176 
    -			   (if (alien-integer-type-signed result-type)
    177 
    -			       '(values (unsigned 32) (signed 32))
    178 
    -			       '(values (unsigned 32) (unsigned 32)))))))
    179 
    -		   `(lambda (function type ,@(lambda-vars))
    180 
    -		      (declare (ignore type))
    181 
    -		      (multiple-value-bind (low high)
    182 
    -			  (%alien-funcall function
    183 
    -					  ',(make-alien-function-type
    184 
    -					     :arg-types (new-arg-types)
    185 
    -					     :result-type new-result-type)
    186 
    -					  ,@(new-args))
    187 
    -			(logior low (ash high 32))))))
    150 
    +    (unless (or (some #'(lambda (type)
    151 
    +			  (and (alien-integer-type-p type)
    152 
    +			       (> (alien::alien-integer-type-bits type) 32)))
    153 
    +		      arg-types)
    154 
    +		(and (alien-integer-type-p result-type)
    155 
    +		     (/= (alien::alien-integer-type-bits result-type) 32)))
    156 
    +      (format t "give up~%")
    157 
    +      (c::give-up))
    158 
    +    (collect ((new-args) (lambda-vars) (new-arg-types))
    159 
    +      (dolist (type arg-types)
    160 
    +	(let ((arg (gensym)))
    161 
    +	  (lambda-vars arg)
    162 
    +	  (cond ((and (alien-integer-type-p type)
    163 
    +		      (> (alien::alien-integer-type-bits type) 32))
    164 
    +		 (new-args `(logand ,arg #xffffffff))
    165 
    +		 (new-args `(ash ,arg -32))
    166 
    +		 (new-arg-types (parse-alien-type '(unsigned 32)))
    167 
    +		 (if (alien-integer-type-signed type)
    168 
    +		     (new-arg-types (parse-alien-type '(signed 32)))
    169 
    +		     (new-arg-types (parse-alien-type '(unsigned 32)))))
    188 170 
     		(t
    189 
    -		 `(lambda (function type ,@(lambda-vars))
    190 
    -		    (declare (ignore type))
    191 
    -		    (%alien-funcall function
    192 
    -				    ',(make-alien-function-type
    193 
    -				       :arg-types (new-arg-types)
    194 
    -				       :result-type result-type)
    195 
    -				    ,@(new-args))))))
    196 
    -	(c::give-up))))
    171 
    +		 (new-args arg)
    172 
    +		 (new-arg-types type)))))
    173 
    +      (cond ((and (alien-integer-type-p result-type)
    174 
    +		  (< (alien::alien-integer-type-bits result-type) 32))
    175 
    +	     (let ((new-result-type
    176 
    +		     (parse-alien-type
    177 
    +		      (if (alien-integer-type-signed result-type)
    178 
    +			  '(signed 32)
    179 
    +			  '(unsigned 32)))))
    180 
    +	       `(lambda (function type ,@(lambda-vars))
    181 
    +		  (declare (ignore type))
    182 
    +		  (%alien-funcall function
    183 
    +				  ',(make-alien-function-type
    184 
    +				     :arg-types (new-arg-types)
    185 
    +				     :result-type new-result-type)
    186 
    +				  ,@(new-args)))))
    187 
    +	    ((and (alien-integer-type-p result-type)
    188 
    +		  (> (alien::alien-integer-type-bits result-type) 32))
    189 
    +	     (let ((new-result-type
    190 
    +		     (let ((alien::*values-type-okay* t))
    191 
    +		       (parse-alien-type
    192 
    +			(if (alien-integer-type-signed result-type)
    193 
    +			    '(values (unsigned 32) (signed 32))
    194 
    +			    '(values (unsigned 32) (unsigned 32)))))))
    195 
    +	       `(lambda (function type ,@(lambda-vars))
    196 
    +		  (declare (ignore type))
    197 
    +		  (multiple-value-bind (low high)
    198 
    +		      (%alien-funcall function
    199 
    +				      ',(make-alien-function-type
    200 
    +					 :arg-types (new-arg-types)
    201 
    +					 :result-type new-result-type)
    202 
    +				      ,@(new-args))
    203 
    +		    (logior low (ash high 32))))))
    204 
    +	    (t
    205 
    +	     `(lambda (function type ,@(lambda-vars))
    206 
    +		(declare (ignore type))
    207 
    +		(%alien-funcall function
    208 
    +				',(make-alien-function-type
    209 
    +				   :arg-types (new-arg-types)
    210 
    +				   :result-type result-type)
    211 
    +				,@(new-args))))))))
    212 
    +
    213 
    +(deftransform %alien-funcall ((function type &rest args))
    214 
    +  (assert (c::constant-continuation-p type))
    215 
    +  (apply #'%alien-funcall-aux function type args))
    197 216
    198 217 
     (define-vop (foreign-symbol-code-address)
    199 218 
       (:translate #+linkage-table foreign-symbol-code-address

  • tests/issues.lisp
    ... ... @@ -997,3 +997,111 @@
    997 997 
           ;; This is the condition from the CLHS entry for enough-namestring
    998 998 
           (assert-equal (merge-pathnames enough defaults)
    999 999 
     		    (merge-pathnames (parse-namestring pathname nil defaults) defaults))))))
    1000 
    +
    1001 
    +(define-test issue.242-load-foreign
    1002 
    +  ;; load-foreign apparently returns NIL if it succeeds.
    1003 
    +  (assert-true (eql nil (ext:load-foreign (merge-pathnames "test-return.o" *test-path*)))))
    1004 
    +
    1005 
    +(alien:def-alien-variable "test_arg" c-call:int)
    1006 
    +
    1007 
    +(define-test issue.242.test-alien-return-signed-char
    1008 
    +  (:tag :issues)
    1009 
    +  (flet ((fun (n)
    1010 
    +	   (setf test-arg n)
    1011 
    +	   (alien:alien-funcall
    1012 
    +	    (alien:extern-alien "int_to_signed_char"
    1013 
    +				(function c-call:char))))
    1014 
    +	 (sign-extend (n)
    1015 
    +	   (let ((n (ldb (byte 8 0) n)))
    1016 
    +	     (if (> n #x7f)
    1017 
    +		 (- n #x100)
    1018 
    +		 n))))
    1019 
    +    (dolist (x '(99 -99 1023 -1023))
    1020 
    +      (assert-equal (sign-extend x) (fun x) x))))
    1021 
    +
    1022 
    +(define-test issue.242.test-alien-return-signed-short
    1023 
    +  (:tag :issues)
    1024 
    +  (flet ((fun (n)
    1025 
    +	   (setf test-arg n)
    1026 
    +	   (alien:alien-funcall
    1027 
    +	    (alien:extern-alien "int_to_short"
    1028 
    +				(function c-call:short))))
    1029 
    +	 (sign-extend (n)
    1030 
    +	   (let ((n (ldb (byte 16 0) n)))
    1031 
    +	     (if (> n #x7fff)
    1032 
    +		 (- n #x10000)
    1033 
    +		 n))))
    1034 
    +    (dolist (x '(1023 -1023 100000 -100000))
    1035 
    +      (assert-equal (sign-extend x) (fun x) x))))
    1036 
    +
    1037 
    +(define-test issue.242.test-alien-return-signed-int
    1038 
    +  (:tag :issues)
    1039 
    +  (flet ((fun (n)
    1040 
    +	   (setf test-arg n)
    1041 
    +	   (alien:alien-funcall
    1042 
    +	    (alien:extern-alien "int_to_int"
    1043 
    +				(function c-call:int)))))
    1044 
    +    (dolist (x '(1023 -1023 #x7fffffff #x-80000000))
    1045 
    +      (assert-equal x (fun x) x))))
    1046 
    +
    1047 
    +(define-test issue.242.test-alien-return-unsigned-char
    1048 
    +  (:tag :issues)
    1049 
    +  (flet ((fun (n)
    1050 
    +	   (setf test-arg n)
    1051 
    +	   (alien:alien-funcall
    1052 
    +	    (alien:extern-alien "int_to_unsigned_char"
    1053 
    +				(function c-call:unsigned-char))))
    1054 
    +	 (expected (n)
    1055 
    +	   (ldb (byte 8 0) n)))
    1056 
    +    (dolist (x '(99 -99 1023 -1023))
    1057 
    +      (assert-equal (expected x) (fun x) x))))
    1058 
    +
    1059 
    +(define-test issue.242.test-alien-return-unsigned-short
    1060 
    +  (:tag :issues)
    1061 
    +  (flet ((fun (n)
    1062 
    +	   (setf test-arg n)
    1063 
    +	   (alien:alien-funcall
    1064 
    +	    (alien:extern-alien "int_to_unsigned_short"
    1065 
    +				(function c-call:unsigned-short))))
    1066 
    +	 (expected (n)
    1067 
    +	   (ldb (byte 16 0) n)))
    1068 
    +    (dolist (x '(1023 -1023 100000 -100000))
    1069 
    +      (assert-equal (expected x) (fun x) x))))
    1070 
    +
    1071 
    +(define-test issue.242.test-alien-return-unsigned-int
    1072 
    +  (:tag :issues)
    1073 
    +  (flet ((fun (n)
    1074 
    +	   (setf test-arg n)
    1075 
    +	   (alien:alien-funcall
    1076 
    +	    (alien:extern-alien "int_to_unsigned_int"
    1077 
    +				(function c-call:unsigned-int))))
    1078 
    +	 (expected (n)
    1079 
    +	   (ldb (byte 32 0) n)))
    1080 
    +    (dolist (x '(1023 -1023 #x7fffffff #x-80000000))
    1081 
    +      (assert-equal (expected x) (fun x) x))))
    1082 
    +
    1083 
    +(define-test issue.242.test-alien-return-bool
    1084 
    +  (:tag :issues)
    1085 
    +  (flet ((fun (n)
    1086 
    +	   (setf test-arg n)
    1087 
    +	   (alien:alien-funcall
    1088 
    +	    (alien:extern-alien "int_to_bool"
    1089 
    +				(function c-call:char))))
    1090 
    +	 (expected (n)
    1091 
    +	   (if (zerop n)
    1092 
    +	       0
    1093 
    +	       1)))
    1094 
    +    (dolist (x '(0 1 1000))
    1095 
    +      (assert-equal (expected x) (fun x) x))))
    1096 
    +
    1097 
    +(define-test issue.242.test-alien-return-bool.2
    1098 
    +  (:tag :issues)
    1099 
    +  (flet ((fun (n)
    1100 
    +	   (setf test-arg n)
    1101 
    +	   (alien:alien-funcall
    1102 
    +	    (alien:extern-alien "int_to_bool"
    1103 
    +				(function alien:boolean))))
    1104 
    +	 (expected (n)
    1105 
    +	   (not (zerop n))))
    1106 
    +    (dolist (x '(0 1 1000))
    1107 
    +      (assert-equal (expected x) (fun x) x))))

  • tests/test-return.c
    1 
    +#include <stdbool.h>
    2 
    +
    3 
    +int test_arg;
    4 
    +
    5 
    +signed char
    6 
    +int_to_signed_char()
    7 
    +{
    8 
    +  return (signed char) test_arg;
    9 
    +}
    10 
    +
    11 
    +short
    12 
    +int_to_short()
    13 
    +{
    14 
    +  return (short) test_arg;
    15 
    +}
    16 
    +
    17 
    +int
    18 
    +int_to_int()
    19 
    +{
    20 
    +  return (int) test_arg;
    21 
    +}
    22 
    +
    23 
    +unsigned char
    24 
    +int_to_unsigned_char()
    25 
    +{
    26 
    +  return (unsigned char) test_arg;
    27 
    +}
    28 
    +
    29 
    +unsigned short
    30 
    +int_to_unsigned_short()
    31 
    +{
    32 
    +  return (unsigned short) test_arg;
    33 
    +}
    34 
    +
    35 
    +unsigned int
    36 
    +int_to_unsigned_int()
    37 
    +{
    38 
    +  return (unsigned int) test_arg;
    39 
    +}
    40 
    +
    41 
    +_Bool int_to_bool()
    42 
    +{
    43 
    +  return (_Bool) test_arg;
    44 
    +}
    45 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help