Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl
Commits:
-
de5d0be0
by Raymond Toy at 2023-06-15T20:54:26-07:00
-
2cc3c60e
by Raymond Toy at 2023-06-15T20:58:27-07:00
4 changed files:
Changes:
| ... | ... | @@ -47,6 +47,10 @@ function cleanup { |
| 47 | 47 | |
| 48 | 48 | trap cleanup EXIT
|
| 49 | 49 | |
| 50 | +echo $PWD
|
|
| 51 | +ls tests/*.c
|
|
| 52 | +(cd tests; gcc -m32 -O3 -c test-return.c)
|
|
| 53 | + |
|
| 50 | 54 | if [ $# -eq 0 ]; then
|
| 51 | 55 | # No args so run all the tests
|
| 52 | 56 | $LISP -noinit -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)'
|
| ... | ... | @@ -649,16 +649,19 @@ |
| 649 | 649 | ;; Mask out any unwanted bits. Important if the C code returns
|
| 650 | 650 | ;; values in %al, or %ax
|
| 651 | 651 | (if (alien-integer-type-signed type)
|
| 652 | - (case (alien-integer-type-bits type)
|
|
| 653 | - ;; First, get just the low part of the alien and then
|
|
| 654 | - ;; sign-extend it appropriately.
|
|
| 655 | - (8 `(let ((val (ldb (byte 8 0) ,alien)))
|
|
| 656 | - (if (> val #x7f)
|
|
| 657 | - (- val #x100))))
|
|
| 658 | - (16 `(let ((val (ldb (byte 16 0) ,alien)))
|
|
| 659 | - (if (> val #x7fff)
|
|
| 660 | - (- val #x10000))))
|
|
| 661 | - (t alien))
|
|
| 652 | + (let ((val (gensym "VAL-")))
|
|
| 653 | + (case (alien-integer-type-bits type)
|
|
| 654 | + ;; First, get just the low part of the alien and then
|
|
| 655 | + ;; sign-extend it appropriately.
|
|
| 656 | + (8 `(let ((,val (ldb (byte 8 0) ,alien)))
|
|
| 657 | + (if (> ,val #x7f)
|
|
| 658 | + (- ,val #x100)
|
|
| 659 | + ,val)))
|
|
| 660 | + (16 `(let ((,val (ldb (byte 16 0) ,alien)))
|
|
| 661 | + (if (> ,val #x7fff)
|
|
| 662 | + (- ,val #x10000)
|
|
| 663 | + ,val)))
|
|
| 664 | + (t alien)))
|
|
| 662 | 665 | (case (alien-integer-type-bits type)
|
| 663 | 666 | (8 `(ldb (byte 8 0) ,alien))
|
| 664 | 667 | (16 `(ldb (byte 16 0) ,alien))
|
| ... | ... | @@ -986,3 +986,53 @@ |
| 986 | 986 | ;; This is the condition from the CLHS entry for enough-namestring
|
| 987 | 987 | (assert-equal (merge-pathnames enough defaults)
|
| 988 | 988 | (merge-pathnames (parse-namestring pathname nil defaults) defaults))))))
|
| 989 | + |
|
| 990 | +(define-test issue.242-load-foreign
|
|
| 991 | + ;; load-foreign apparently returns NIL if it succeeds.
|
|
| 992 | + (assert-true (eql nil (ext:load-foreign (merge-pathnames "test-return.o" *test-path*)))))
|
|
| 993 | + |
|
| 994 | +(defun return-unsigned-int (x)
|
|
| 995 | + ((alien:alien-funcall
|
|
| 996 | + (alien:extern-alien "int_to_unsigned_int"
|
|
| 997 | + (function c-call:unsigned-int c-call:unsigned-int))
|
|
| 998 | + n)))
|
|
| 999 | + |
|
| 1000 | +(define-test issue.242.test-alien-return-signed-char
|
|
| 1001 | + (:tag :issues)
|
|
| 1002 | + (flet ((fun (n)
|
|
| 1003 | + (alien:alien-funcall
|
|
| 1004 | + (alien:extern-alien "int_to_signed_char"
|
|
| 1005 | + (function c-call:char c-call:int))
|
|
| 1006 | + n))
|
|
| 1007 | + (sign-extend (n)
|
|
| 1008 | + (let ((n (ldb (byte 8 0) n)))
|
|
| 1009 | + (if (> n #x7f)
|
|
| 1010 | + (- n #x100)
|
|
| 1011 | + n))))
|
|
| 1012 | + (dolist (x '(99 -99 1023 -1023))
|
|
| 1013 | + (assert-equal (sign-extend x) (fun x)))))
|
|
| 1014 | + |
|
| 1015 | +(define-test issue.242.test-alien-return-signed-short
|
|
| 1016 | + (:tag :issues)
|
|
| 1017 | + (flet ((fun (n)
|
|
| 1018 | + (alien:alien-funcall
|
|
| 1019 | + (alien:extern-alien "int_to_short"
|
|
| 1020 | + (function c-call:short c-call:int))
|
|
| 1021 | + n))
|
|
| 1022 | + (sign-extend (n)
|
|
| 1023 | + (let ((n (ldb (byte 16 0) n)))
|
|
| 1024 | + (if (> n #x7fff)
|
|
| 1025 | + (- n #x10000)
|
|
| 1026 | + n))))
|
|
| 1027 | + (dolist (x '(1023 -1023 100000 -100000))
|
|
| 1028 | + (assert-equal (sign-extend x) (fun x)))))
|
|
| 1029 | + |
|
| 1030 | +(define-test issue.242.test-alien-return-signed-int
|
|
| 1031 | + (:tag :issues)
|
|
| 1032 | + (flet ((fun (n)
|
|
| 1033 | + (alien:alien-funcall
|
|
| 1034 | + (alien:extern-alien "int_to_int"
|
|
| 1035 | + (function c-call:int c-call:int))
|
|
| 1036 | + n)))
|
|
| 1037 | + (dolist (x '(1023 -1023 #x7fffffff #x-80000000))
|
|
| 1038 | + (assert-equal x (fun x))))) |
| 1 | +signed char
|
|
| 2 | +int_to_signed_char(int x)
|
|
| 3 | +{
|
|
| 4 | + return (signed char) x;
|
|
| 5 | +}
|
|
| 6 | + |
|
| 7 | +signed short
|
|
| 8 | +int_to_short(int x)
|
|
| 9 | +{
|
|
| 10 | + return (signed short) x;
|
|
| 11 | +}
|
|
| 12 | + |
|
| 13 | +int
|
|
| 14 | +int_to_int(int x)
|
|
| 15 | +{
|
|
| 16 | + return (int) x;
|
|
| 17 | +}
|
|
| 18 | + |
|
| 19 | +unsigned char
|
|
| 20 | +int_to_unsigned_char(int x)
|
|
| 21 | +{
|
|
| 22 | + return (signed char) x;
|
|
| 23 | +}
|
|
| 24 | + |
|
| 25 | +unsigned short
|
|
| 26 | +int_to_unsigned_short(int x)
|
|
| 27 | +{
|
|
| 28 | + return (signed short) x;
|
|
| 29 | +}
|
|
| 30 | + |
|
| 31 | +unsigned int
|
|
| 32 | +int_to_unsigned_int(int x)
|
|
| 33 | +{
|
|
| 34 | + return (int) x;
|
|
| 35 | +}
|
|
| 36 | + |