[Git][cmucl/cmucl][issue-242-c-call-char-result-wrong] 2 commits: Fix bug in sign-extension.

[Raymond Toy (@rtoy)]

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
Fix bug in sign-extension.

Stupidly forgot to handle the case where the value is positive.  We
accidentally returned nil.

- - - - -
2cc3c60e by Raymond Toy at 2023-06-15T20:58:27-07:00
Add tests for different foreign integer return types

Add a C file, test-return.c, that has functions that return different
length integer types.

Compile it in run-tests.sh so that the tests can load it.

Add tests that we get the right values from the functions.  Only the
signed integer types are tested right now.  We need to add the
unsigned tests.

- - - - -


4 changed files:

- bin/run-tests.sh
- src/code/alieneval.lisp
- tests/issues.lisp
- + tests/test-return.c


Changes:

=====================================
bin/run-tests.sh
=====================================
@@ -47,6 +47,10 @@ function cleanup {
 
 trap cleanup EXIT
 
+echo $PWD
+ls tests/*.c
+(cd tests; gcc -m32 -O3 -c test-return.c)
+
 if [ $# -eq 0 ]; then
     # No args so run all the tests
     $LISP -noinit -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)'


=====================================
src/code/alieneval.lisp
=====================================
@@ -649,16 +649,19 @@
   ;; Mask out any unwanted bits.  Important if the C code returns
   ;; values in %al, or %ax
   (if (alien-integer-type-signed type)
-      (case (alien-integer-type-bits type)
-	;; First, get just the low part of the alien and then
-	;; sign-extend it appropriately.
-	(8 `(let ((val (ldb (byte 8 0) ,alien)))
-	      (if (> val #x7f)
-		  (- val #x100))))
-	(16 `(let ((val (ldb (byte 16 0) ,alien)))
-	      (if (> val #x7fff)
-		  (- val #x10000))))
-	(t alien))
+      (let ((val (gensym "VAL-")))
+	(case (alien-integer-type-bits type)
+	  ;; First, get just the low part of the alien and then
+	  ;; sign-extend it appropriately.
+	  (8 `(let ((,val (ldb (byte 8 0) ,alien)))
+		(if (> ,val #x7f)
+		    (- ,val #x100)
+		    ,val)))
+	  (16 `(let ((,val (ldb (byte 16 0) ,alien)))
+		 (if (> ,val #x7fff)
+		     (- ,val #x10000)
+		     ,val)))
+	  (t alien)))
       (case (alien-integer-type-bits type)
 	(8 `(ldb (byte 8 0) ,alien))
 	(16 `(ldb (byte 16 0) ,alien))


=====================================
tests/issues.lisp
=====================================
@@ -986,3 +986,53 @@
       ;; This is the condition from the CLHS entry for enough-namestring
       (assert-equal (merge-pathnames enough defaults)
 		    (merge-pathnames (parse-namestring pathname nil defaults) defaults))))))
+
+(define-test issue.242-load-foreign
+  ;; load-foreign apparently returns NIL if it succeeds.
+  (assert-true (eql nil (ext:load-foreign (merge-pathnames "test-return.o" *test-path*)))))
+
+(defun return-unsigned-int (x)
+  ((alien:alien-funcall
+    (alien:extern-alien "int_to_unsigned_int"
+			(function c-call:unsigned-int c-call:unsigned-int))
+    n)))
+
+(define-test issue.242.test-alien-return-signed-char
+  (:tag :issues)
+  (flet ((fun (n)
+	   (alien:alien-funcall
+	    (alien:extern-alien "int_to_signed_char"
+				(function c-call:char c-call:int))
+	    n))
+	 (sign-extend (n)
+	   (let ((n (ldb (byte 8 0) n)))
+	     (if (> n #x7f)
+		 (- n #x100)
+		 n))))
+    (dolist (x '(99 -99 1023 -1023))
+      (assert-equal (sign-extend x) (fun x)))))
+
+(define-test issue.242.test-alien-return-signed-short
+  (:tag :issues)
+  (flet ((fun (n)
+	   (alien:alien-funcall
+	    (alien:extern-alien "int_to_short"
+				(function c-call:short c-call:int))
+	    n))
+	 (sign-extend (n)
+	   (let ((n (ldb (byte 16 0) n)))
+	     (if (> n #x7fff)
+		 (- n #x10000)
+		 n))))
+    (dolist (x '(1023 -1023 100000 -100000))
+      (assert-equal (sign-extend x) (fun x)))))
+
+(define-test issue.242.test-alien-return-signed-int
+  (:tag :issues)
+  (flet ((fun (n)
+	   (alien:alien-funcall
+	    (alien:extern-alien "int_to_int"
+				(function c-call:int c-call:int))
+	    n)))
+    (dolist (x '(1023 -1023 #x7fffffff #x-80000000))
+      (assert-equal x (fun x)))))


=====================================
tests/test-return.c
=====================================
@@ -0,0 +1,36 @@
+signed char
+int_to_signed_char(int x)
+{
+  return (signed char) x;
+}
+
+signed short
+int_to_short(int x)
+{
+  return (signed short) x;
+}
+
+int
+int_to_int(int x)
+{
+  return (int) x;
+}
+
+unsigned char
+int_to_unsigned_char(int x)
+{
+  return (signed char) x;
+}
+
+unsigned short
+int_to_unsigned_short(int x)
+{
+  return (signed short) x;
+}
+
+unsigned int
+int_to_unsigned_int(int x)
+{
+  return (int) x;
+}
+



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d5391d9a0e25c687937e86fc16e67127671896e1...2cc3c60e2692a1709fcf4852f7fdc413b4accf81

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d5391d9a0e25c687937e86fc16e67127671896e1...2cc3c60e2692a1709fcf4852f7fdc413b4accf81
You're receiving this email because of your account on gitlab.common-lisp.net.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230616/98e3d626/attachment-0001.html>