From: Taylor R. Campbell <net/mumble/campbell>
Date: Mon, 23 Feb 2009 22:40:12 +0000 (+0000)
Subject: In FIXNUM-LSH, if the count exceeds the Scheme datum width in absolute
X-Git-Tag: 20090517-FFI~64
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8837d8f77d1cc04c9e719bdcf75da077281a398d;p=mit-scheme.git

In FIXNUM-LSH, if the count exceeds the Scheme datum width in absolute
value, return zero.  Intel's brain-damaged shift instructions on the
i386 and later (but not the 8086 -- go figure) ignore all but the
low-order five bits of the count.
---

diff --git a/v7/src/compiler/machines/i386/rulfix.scm b/v7/src/compiler/machines/i386/rulfix.scm
index dd50cc0de..abc15ad8f 100644
--- a/v7/src/compiler/machines/i386/rulfix.scm
+++ b/v7/src/compiler/machines/i386/rulfix.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rulfix.scm,v 1.39 2008/01/30 20:01:50 cph Exp $
+$Id: rulfix.scm,v 1.40 2009/02/23 22:40:12 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -492,14 +492,22 @@ USA.
 	   (let ((with-target
 		   (lambda (target)
 		     (let ((jlabel (generate-label 'SHIFT-JOIN))
-			   (slabel (generate-label 'SHIFT-NEGATIVE)))
+			   (slabel (generate-label 'SHIFT-NEGATIVE))
+			   (zlabel (generate-label 'SHIFT-ZERO)))
 		       (LAP (MOV W (R ,ecx) ,source2)
 			    (SAR W (R ,ecx) (& ,scheme-type-width))
 			    (JS B (@PCR ,slabel))
+			    (CMP W (R ,ecx) (& ,scheme-datum-width))
+			    (JGE B (@PCR ,zlabel))
 			    (SHL W ,target (R ,ecx))
 			    (JMP B (@PCR ,jlabel))
+			    (LABEL ,zlabel)
+			    (XOR W ,target ,target)
+			    (JMP B (@PCR ,jlabel))
 			    (LABEL ,slabel)
 			    (NEG W (R ,ecx))
+			    (CMP W (R ,ecx) (& ,scheme-datum-width))
+			    (JGE W (@PCR ,zlabel))
 			    (SHR W ,target (R ,ecx))
 			    ,@(word->fixnum target)
 			    (LABEL ,jlabel))))))