From b008d6d206ecf424b48a3a57ff8532f660407a86 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Tue, 3 Aug 2004 00:12:28 +0000 Subject: [PATCH] Fix bug where things like (truncate x 0) were getting converted into a left shift of 1 because deftransforms were not checking for the case of a 0 arg. --- compiler/aliencomp.lisp | 5 +++-- compiler/srctran.lisp | 22 ++++++++++++++++------ 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp index 9cb21e6ad..f2c199874 100644 --- a/compiler/aliencomp.lisp +++ b/compiler/aliencomp.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.28 2004/05/24 22:52:34 cwang Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.29 2004/08/03 00:12:28 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -586,7 +586,8 @@ (give-up)) (let* ((denominator (continuation-value denominator)) (bits (1- (integer-length denominator)))) - (unless (= (ash 1 bits) denominator) + (unless (and (plusp denominator) + (= (ash 1 bits) denominator)) (give-up)) (let ((alignment (count-low-order-zeros numerator))) (unless (>= alignment bits) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index e444c5759..dff2b21a4 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.151 2004/07/21 04:01:00 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.152 2004/08/03 00:12:28 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2906,7 +2906,9 @@ (let* ((y (continuation-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) + (unless (and (plusp y-abs) + (= y-abs (ash 1 len))) + (give-up)) (if (minusp y) `(- (ash x ,len)) `(ash x ,len)))) @@ -3013,7 +3015,9 @@ (let* ((y (continuation-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) + (unless (and (plusp y-abs) + (= y-abs (ash 1 len))) + (give-up)) (let ((shift (- len)) (mask (1- y-abs)) (delta (if ceil-p (* (signum y) (1- y-abs)) 0))) @@ -3039,7 +3043,9 @@ (let* ((y (continuation-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) + (unless (and (plusp y-abs) + (= y-abs (ash 1 len))) + (give-up)) (let ((mask (1- y-abs))) (if (minusp y) `(- (logand (- x) ,mask)) @@ -3054,7 +3060,9 @@ (let* ((y (continuation-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) + (unless (and (plusp y-abs) + (= y-abs (ash 1 len))) + (give-up)) (let* ((shift (- len)) (mask (1- y-abs))) `(if (minusp x) @@ -3075,7 +3083,9 @@ (let* ((y (continuation-value y)) (y-abs (abs y)) (len (1- (integer-length y-abs)))) - (unless (= y-abs (ash 1 len)) (give-up)) + (unless (and (plusp y-abs) + (= y-abs (ash 1 len))) + (give-up)) (let ((mask (1- y-abs))) `(if (minusp x) (- (logand (- x) ,mask)) -- GitLab