diff --git a/code/pred.lisp b/code/pred.lisp index d04096430af572a1380f590167bf9225e4dca7b3..1da31992f9f0cb987d629dacb81b19fdbcb5cc40 100644 --- a/code/pred.lisp +++ b/code/pred.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/code/pred.lisp,v 1.43 1997/11/29 20:13:11 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.44 1998/01/05 22:34:54 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -209,6 +209,7 @@ (long-float (typep num 'long-float)) ((nil) (floatp num)))) ((nil) t))) + #-negative-zero-is-not-zero (flet ((bound-test (val) (let ((low (numeric-type-low type)) (high (numeric-type-high type))) @@ -218,6 +219,37 @@ (cond ((null high) t) ((listp high) (< val (car high))) (t (<= val high))))))) + (ecase (numeric-type-complexp type) + ((nil) t) + (:complex + (and (complexp object) + (bound-test (realpart object)) + (bound-test (imagpart object)))) + (:real + (and (not (complexp object)) + (bound-test object))))) + #+negative-zero-is-not-zero + (labels ((signed-> (x y) + (if (and (zerop x) (zerop y) (floatp x) (floatp y)) + (> (float-sign x) (float-sign y)) + (> x y))) + (signed->= (x y) + (if (and (zerop x) (zerop y) (floatp x) (floatp y)) + (>= (float-sign x) (float-sign y)) + (>= x y))) + (bound-test (val) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + (and (cond ((null low) t) + ((listp low) + (signed-> val (car low))) + (t + (signed->= val low))) + (cond ((null high) t) + ((listp high) + (signed-> (car high) val)) + (t + (signed->= high val))))))) (ecase (numeric-type-complexp type) ((nil) t) (:complex diff --git a/code/type.lisp b/code/type.lisp index 1d6d512b93e5dfd1d9524dfadbab248e5c9f1877..851e409fc102e70910e60853bd553f406d6dc895 100644 --- a/code/type.lisp +++ b/code/type.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/code/type.lisp,v 1.23 1997/12/18 16:49:10 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.24 1998/01/05 22:34:56 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1118,6 +1118,7 @@ ;;; This is for comparing bounds of the same kind, e.g. upper and upper. ;;; Use Numeric-Bound-Test* for different kinds of bounds. ;;; +#-negative-zero-is-not-zero (defmacro numeric-bound-test (x y closed open) `(cond ((not ,y) t) ((not ,x) nil) @@ -1130,6 +1131,24 @@ (,open ,x (car ,y)) (,closed ,x ,y))))) +#+negative-zero-is-not-zero +(defmacro numeric-bound-test-zero (op x y) + `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y)) + (,op (float-sign ,x) (float-sign ,y)) + (,op ,x ,y))) + +#+negative-zero-is-not-zero +(defmacro numeric-bound-test (x y closed open) + `(cond ((not ,y) t) + ((not ,x) nil) + ((consp ,x) + (if (consp ,y) + (numeric-bound-test-zero ,closed (car ,x) (car ,y)) + (numeric-bound-test-zero ,closed (car ,x) ,y))) + (t + (if (consp ,y) + (numeric-bound-test-zero ,open ,x (car ,y)) + (numeric-bound-test-zero ,closed ,x ,y))))) ;;; Numeric-Bound-Test* -- Internal ;;; @@ -1140,6 +1159,7 @@ ;;; -- an open inner bound is "greater" and also squeezes the interval, causing ;;; us to use the Open test for those cases as well. ;;; +#-negative-zero-is-not-zero (defmacro numeric-bound-test* (x y closed open) `(cond ((not ,y) t) ((not ,x) t) @@ -1152,6 +1172,19 @@ (,open ,x (car ,y)) (,closed ,x ,y))))) +#+negative-zero-is-not-zero +(defmacro numeric-bound-test* (x y closed open) + `(cond ((not ,y) t) + ((not ,x) t) + ((consp ,x) + (if (consp ,y) + (numeric-bound-test-zero ,open (car ,x) (car ,y)) + (numeric-bound-test-zero ,open (car ,x) ,y))) + (t + (if (consp ,y) + (numeric-bound-test-zero ,open ,x (car ,y)) + (numeric-bound-test-zero ,closed ,x ,y))))) + ;;; Numeric-Bound-Max -- Internal ;;; diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index db6899ee00e9a5578c7c0e11134c7cc48b35bb3f..a5fa991ad65bc8d11a2741dcd2938e6631e9bdce 100644 --- a/compiler/typetran.lisp +++ b/compiler/typetran.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/typetran.lisp,v 1.31 1997/11/15 04:38:57 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.32 1998/01/05 22:35:00 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -175,6 +175,7 @@ ;;; specified by Type. Base is the name of the base type, for declaration. We ;;; make safety locally 0 to inhibit any checking of this assertion. ;;; +#-negative-zero-is-not-zero (defun transform-numeric-bound-test (n-object type base) (declare (type numeric-type type)) (let ((low (numeric-type-low type)) @@ -190,6 +191,25 @@ `((< (the ,base ,n-object) ,(car high))) `((<= (the ,base ,n-object) ,high)))))))) +#+negative-zero-is-not-zero +(defun transform-numeric-bound-test (n-object type base) + (declare (type numeric-type type)) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + `(locally + (declare (optimize (safety 0))) + (and ,@(when low + (if (consp low) + `((kernel::numeric-bound-test-zero + > (the ,base ,n-object) ,(car low))) + `((kernel::numeric-bound-test-zero + >= (the ,base ,n-object) ,low)))) + ,@(when high + (if (consp high) + `((kernel::numeric-bound-test-zero + < (the ,base ,n-object) ,(car high))) + `((kernel::numeric-bound-test-zero + <= (the ,base ,n-object) ,high)))))))) ;;; Source-Transform-Numeric-Typep -- Internal ;;; diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp index c3b2b952c2fa2fdd9438cb360a9b2a1dbd4dce24..d2d41933988edc5741e6dfe38b2dab79db776bb6 100644 --- a/compiler/x86/float.lisp +++ b/compiler/x86/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.17 1997/11/30 22:53:51 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.18 1998/01/05 22:35:04 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1230,34 +1230,52 @@ (define-vop (=0/single-float float-test) (:translate =) (:args (x :scs (single-reg))) + #-negative-zero-is-not-zero (:arg-types single-float (:constant (single-float 0f0 0f0))) + #+negative-zero-is-not-zero + (:arg-types single-float (:constant (single-float -0f0 0f0))) (:variant #x40)) (define-vop (=0/double-float float-test) (:translate =) (:args (x :scs (double-reg))) + #-negative-zero-is-not-zero (:arg-types double-float (:constant (double-float 0d0 0d0))) + #+negative-zero-is-not-zero + (:arg-types double-float (:constant (double-float -0d0 0d0))) (:variant #x40)) (define-vop (<0/single-float float-test) (:translate <) (:args (x :scs (single-reg))) + #-negative-zero-is-not-zero (:arg-types single-float (:constant (single-float 0f0 0f0))) + #+negative-zero-is-not-zero + (:arg-types single-float (:constant (single-float -0f0 0f0))) (:variant #x01)) (define-vop (<0/double-float float-test) (:translate <) (:args (x :scs (double-reg))) + #-negative-zero-is-not-zero (:arg-types double-float (:constant (double-float 0d0 0d0))) + #+negative-zero-is-not-zero + (:arg-types double-float (:constant (double-float -0d0 0d0))) (:variant #x01)) (define-vop (>0/single-float float-test) (:translate >) (:args (x :scs (single-reg))) + #-negative-zero-is-not-zero (:arg-types single-float (:constant (single-float 0f0 0f0))) + #+negative-zero-is-not-zero + (:arg-types single-float (:constant (single-float -0f0 0f0))) (:variant #x00)) (define-vop (>0/double-float float-test) (:translate >) (:args (x :scs (double-reg))) + #-negative-zero-is-not-zero (:arg-types double-float (:constant (double-float 0d0 0d0))) + #+negative-zero-is-not-zero + (:arg-types double-float (:constant (double-float -0d0 0d0))) (:variant #x00))