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