mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Minor tweak to truncate-bits

Browse source 
* module/system/base/types/internal.scm (truncate-bits): Use bits-case
in all cases.
This commit is contained in:
Andy Wingo 2021-05-07 16:13:09 +02:00
parent 93a242c0ec
commit 1432088f27
1 changed files with 5 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

13
module/system/base/types/internal.scm
View file

@ -231,21 +231,18 @@ may not fit into a word on the target platform."
(define (truncate-bits x bits signed?) (define (truncate-bits x bits signed?)
(define-syntax-rule (bits-case bits) (define-syntax-rule (bits-case bits)
(let ((umax (1- (ash 1 bits))) (let ((umax (1- (ash 1 bits))))
(smin (ash -1 (1- bits)))
(smax (1- (ash 1 (1- bits)))))
(and (if signed? (and (if signed?
(<= smin x smax) (let ((smin (ash -1 (1- bits)))
(smax (1- (ash 1 (1- bits)))))
(<= smin x smax))
(<= 0 x umax)) (<= 0 x umax))
(logand x umax)))) (logand x umax))))
(case bits (case bits
((16) (bits-case 16)) ((16) (bits-case 16))
((32) (bits-case 32)) ((32) (bits-case 32))
((64) (bits-case 64)) ((64) (bits-case 64))
(else (else (bits-case bits))))
(let ((x' (logand x (1- (ash 1 bits)))))
(and (eq? x (if signed? (sign-extend x' bits) x'))
x')))))
;; See discussion in tags.h and boolean.h. ;; See discussion in tags.h and boolean.h.
(eval-when (expand) (eval-when (expand)