[Git][cmucl/cmucl][issue-242-c-call-char-result-wrong] Make out unwanted bits for boolean result

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl


Commits:
3522814e by Raymond Toy at 2023-07-01T11:06:10-07:00
Make out unwanted bits for boolean result

- - - - -


1 changed file:

- src/code/alieneval.lisp


Changes:

=====================================
src/code/alieneval.lisp
=====================================
@@ -666,8 +666,8 @@
 		     ,val)))
 	  (t alien)))
       (case (alien-integer-type-bits type)
-	(8 `(ldb (byte 8 0) ,alien))
-	(16 `(ldb (byte 16 0) ,alien))
+	(8 `(ldb (byte 8 0) (truly-the (unsigned-byte 32) ,alien)))
+	(16 `(ldb (byte 16 0) (truly-the (unsigned-byte 32) ,alien)))
 	(t alien))))
 
 ;; signed numbers <= 32 bits need to be sign extended.
@@ -715,8 +715,8 @@
 
 (def-alien-type-class (boolean :include integer :include-args (signed)))
 
-(def-alien-type-translator boolean (&optional (bits vm:word-bits))
-  (make-alien-boolean-type :bits bits :signed nil))
+(def-alien-type-translator boolean (&optional (bits 8))
+  (make-alien-boolean-type :bits bits :signed t))
 
 (def-alien-type-method (boolean :unparse) (type)
   `(boolean ,(alien-boolean-type-bits type)))
@@ -726,8 +726,10 @@
   `(member t nil))
 
 (def-alien-type-method (boolean :naturalize-gen) (type alien)
-  (declare (ignore type))
-  `(not (zerop ,alien)))
+  ;; Mask out any unwanted bits.  Important if the C code returns
+  ;; values in %al, or %ax
+  `(not (zerop (ldb (byte ,(alien-boolean-type-bits type) 0)
+		    ,alien))))
 
 (def-alien-type-method (boolean :deport-gen) (type value)
   (declare (ignore type))



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3522814e013a7092890be8e9952d244d6c4b386c

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3522814e013a7092890be8e9952d244d6c4b386c
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/20230701/9867e95f/attachment-0001.html>