mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Extend float infinity handling in MAKE-NUMERIC-TYPE
This commit is contained in:
Jan Moringen
parent
d23a2ff60d
commit
088a277579
|
|
@ -2608,24 +2608,83 @@ expansion happened."
|
|||
(case type
|
||||
(rational
|
||||
#+sb-xc-host (return-from coerce-numeric-bound)
|
||||
#-sb-xc-host (rational thing))
|
||||
#-sb-xc-host (if (and (floatp thing) (float-infinity-p thing))
|
||||
(return-from coerce-numeric-bound nil)
|
||||
(rational thing)))
|
||||
((float single-float)
|
||||
(cond #-sb-xc-host
|
||||
((<= most-negative-single-float thing most-positive-single-float)
|
||||
(coerce thing 'single-float))
|
||||
(t
|
||||
(return-from coerce-numeric-bound))))
|
||||
(return-from coerce-numeric-bound nil))))
|
||||
(double-float
|
||||
(cond #-sb-xc-host
|
||||
((<= most-negative-double-float thing most-positive-double-float)
|
||||
(coerce thing 'double-float))
|
||||
(t
|
||||
(return-from coerce-numeric-bound)))))))
|
||||
(return-from coerce-numeric-bound nil)))))))
|
||||
(when bound
|
||||
(if (consp bound)
|
||||
(list (c (car bound)))
|
||||
(c bound)))))
|
||||
|
||||
(defun %make-union-numeric-type (class format complexp low high enumerable)
|
||||
(declare (type (member integer rational float nil) class))
|
||||
(macrolet ((unionize (&rest specs)
|
||||
`(type-union
|
||||
,@(loop for (class format coerce simple-coerce) in specs
|
||||
collect `(make-numeric-type
|
||||
:class ',class
|
||||
:format ',format
|
||||
:complexp complexp
|
||||
:low ,(if simple-coerce
|
||||
`(coerce low ',coerce)
|
||||
`(coerce-numeric-bound low ',coerce))
|
||||
:high ,(if simple-coerce
|
||||
`(coerce high ',coerce)
|
||||
`(coerce-numeric-bound high ',coerce))
|
||||
:enumerable enumerable)))))
|
||||
(cond ((and (null class) (member complexp '(:real :complex)))
|
||||
(cond ((not (bounds-unbounded-p low high))
|
||||
(cond ((and (floatp low) (float-infinity-p low)
|
||||
(eql low high))
|
||||
;; low and high are some float
|
||||
;; infinity. not representable as a
|
||||
;; rational.
|
||||
(let ((complexp :real)) ; TODO what if complexp was :complex?
|
||||
(unionize (float single-float single-float t)
|
||||
(float double-float double-float t))))
|
||||
(t
|
||||
(unionize (rational nil rational)
|
||||
(float single-float single-float)
|
||||
(float double-float double-float)))))
|
||||
((eq complexp :complex)
|
||||
(specifier-type 'complex))
|
||||
(t
|
||||
(specifier-type 'real))))
|
||||
((and (eq class 'float) (member complexp '(:real :complex))
|
||||
(eq format nil))
|
||||
(cond ((not (bounds-unbounded-p low high))
|
||||
(if (and (floatp low) (float-infinity-p low)
|
||||
(eql low high))
|
||||
(let ((complexp :real))
|
||||
(unionize (float single-float single-float t)
|
||||
(float double-float double-float t)
|
||||
#+long-float((error "long-float"))))
|
||||
(unionize (float single-float single-float)
|
||||
(float double-float double-float)
|
||||
#+long-float((error "long-float")))))
|
||||
((eq complexp :complex)
|
||||
(specifier-type '(complex float)))
|
||||
(t
|
||||
(specifier-type 'float))))
|
||||
((and (null complexp)
|
||||
(or class format low high))
|
||||
(type-union (make-numeric-type :class class :format format :complexp :complex
|
||||
:low low :high high :enumerable enumerable)
|
||||
(make-numeric-type :class class :format format :complexp :real
|
||||
:low low :high high :enumerable enumerable))))))
|
||||
|
||||
;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
|
||||
;;; cases, despite the name, we return *EMPTY-TYPE* or a UNION-TYPE instead of a
|
||||
;;; NUMERIC-TYPE.
|
||||
|
|
@ -2643,50 +2702,9 @@ expansion happened."
|
|||
(defun make-numeric-type (&key class format (complexp :real) low high
|
||||
enumerable)
|
||||
(declare (type (member integer rational float nil) class))
|
||||
(macrolet ((unionize (types classes formats)
|
||||
`(let (types)
|
||||
(loop for thing in ',types
|
||||
for class in ',classes
|
||||
for format in ',formats
|
||||
do
|
||||
(let ((low (coerce-numeric-bound low thing))
|
||||
(high (coerce-numeric-bound high thing)))
|
||||
(push (make-numeric-type
|
||||
:format format
|
||||
:class class
|
||||
:complexp complexp
|
||||
:low low
|
||||
:high high
|
||||
:enumerable enumerable)
|
||||
types)))
|
||||
(apply #'type-union types))))
|
||||
(when (and (null class) (member complexp '(:real :complex)))
|
||||
(return-from make-numeric-type
|
||||
(if (bounds-unbounded-p low high)
|
||||
(if (eq complexp :complex)
|
||||
(specifier-type 'complex)
|
||||
(specifier-type 'real))
|
||||
(unionize (rational single-float double-float)
|
||||
(rational float float)
|
||||
(nil single-float double-float)))))
|
||||
(when (and (eql class 'float) (member complexp '(:complex :real)) (eql format nil))
|
||||
(return-from make-numeric-type
|
||||
(if (bounds-unbounded-p low high)
|
||||
(if (eq complexp :complex)
|
||||
(specifier-type '(complex float))
|
||||
(specifier-type 'float))
|
||||
(unionize (single-float double-float #+long-float (error "long-float"))
|
||||
(float float)
|
||||
(single-float double-float)))))
|
||||
(when (and (null complexp)
|
||||
(or class format low high))
|
||||
(return-from make-numeric-type
|
||||
(type-union (make-numeric-type :class class :format format
|
||||
:low low :high high :enumerable enumerable
|
||||
:complexp :complex)
|
||||
(make-numeric-type :class class :format format
|
||||
:low low :high high :enumerable enumerable
|
||||
:complexp :real)))))
|
||||
(let ((union-type (%make-union-numeric-type
|
||||
class format complexp low high enumerable)))
|
||||
(when union-type (return-from make-numeric-type union-type)))
|
||||
(multiple-value-bind (low high)
|
||||
(case class
|
||||
(integer
|
||||
|
|
@ -2710,12 +2728,12 @@ expansion happened."
|
|||
(or (case class
|
||||
(float
|
||||
(macrolet ((float-type (fmt complexp
|
||||
&aux (spec (if (eq complexp :complex)
|
||||
`(complex ,fmt) fmt)))
|
||||
&aux (spec (if (eq complexp :complex)
|
||||
`(complex ,fmt) fmt)))
|
||||
`(literal-ctype (interned-numeric-type ',spec
|
||||
:class 'float :complexp ,complexp
|
||||
:format ',fmt :enumerable nil)
|
||||
,spec)))
|
||||
,spec)))
|
||||
(when (bounds-unbounded-p low high)
|
||||
(ecase format
|
||||
(single-float
|
||||
|
|
@ -2729,10 +2747,10 @@ expansion happened."
|
|||
(integer
|
||||
(macrolet ((int-type (low high)
|
||||
`(literal-ctype
|
||||
(interned-numeric-type nil
|
||||
:class 'integer :low ,low :high ,high
|
||||
:enumerable (if (and ,low ,high) t nil))
|
||||
(integer ,(or low '*) ,(or high '*)))))
|
||||
(interned-numeric-type nil
|
||||
:class 'integer :low ,low :high ,high
|
||||
:enumerable (if (and ,low ,high) t nil))
|
||||
(integer ,(or low '*) ,(or high '*)))))
|
||||
(cond ((neq complexp :real) nil)
|
||||
((and (eql low 0) (eql high (1- array-dimension-limit)))
|
||||
(int-type 0 #.(1- array-dimension-limit))) ; INDEX type
|
||||
|
|
|
|||
|
|
@ -670,10 +670,42 @@
|
|||
(assert (eq (sb-int:info :type :kind s) :primitive))
|
||||
(assert (eq (sb-int:info :type :kind s) :instance)))))))
|
||||
|
||||
(with-test (:name :make-numeric-type)
|
||||
(with-test (:name (make-numeric-type :smoke))
|
||||
(assert (eq (make-numeric-type :class 'integer :low '(4) :high '(5))
|
||||
*empty-type*)))
|
||||
|
||||
(with-test (:name (make-numeric-type :union))
|
||||
(assert (equal (type-specifier (make-numeric-type :low '(-79106810381456307)))
|
||||
`(or (rational (-79106810381456307))
|
||||
(single-float (-7.910681e16))
|
||||
(double-float (-7.91068103814563d16))))))
|
||||
|
||||
(with-test (:name (make-numeric-type :infinities))
|
||||
;; Without class
|
||||
(assert (equal (type-specifier
|
||||
(make-numeric-type :low sb-ext:single-float-negative-infinity
|
||||
:high sb-ext:single-float-negative-infinity))
|
||||
`(or (single-float ,sb-ext:single-float-negative-infinity
|
||||
,sb-ext:single-float-negative-infinity)
|
||||
(double-float ,sb-ext:double-float-negative-infinity
|
||||
,sb-ext:double-float-negative-infinity))))
|
||||
(assert (equal (type-specifier
|
||||
(make-numeric-type :low sb-ext:single-float-negative-infinity))
|
||||
'real))
|
||||
;; With FLOAT class
|
||||
(assert (equal (type-specifier
|
||||
(make-numeric-type :class 'float
|
||||
:low sb-ext:single-float-negative-infinity
|
||||
:high sb-ext:single-float-negative-infinity))
|
||||
`(or (single-float ,sb-ext:single-float-negative-infinity
|
||||
,sb-ext:single-float-negative-infinity)
|
||||
(double-float ,sb-ext:double-float-negative-infinity
|
||||
,sb-ext:double-float-negative-infinity))))
|
||||
(assert (equal (type-specifier
|
||||
(make-numeric-type :class 'float
|
||||
:low sb-ext:single-float-negative-infinity))
|
||||
`float)))
|
||||
|
||||
(with-test (:name :prettier-union-types :skipped-on (not :sb-unicode))
|
||||
;; (OR STRING BIGNUM) used to unparse as
|
||||
;; (OR (VECTOR CHARACTER) BASE-STRING (INTEGER * -4611686018427387905)
|
||||
|
|
@ -734,16 +766,10 @@
|
|||
(assert (eq (type-of (eval '(sb-kernel:%make-instance 12)))
|
||||
'sb-kernel:instance)))
|
||||
|
||||
(with-test (:name :make-numeric-type-union)
|
||||
(assert (equal (sb-kernel:type-specifier
|
||||
(sb-kernel:make-numeric-type :low '(-79106810381456307)))
|
||||
'(or (double-float (-7.91068103814563d16)) (single-float (-7.910681e16))
|
||||
(rational (-79106810381456307))))))
|
||||
|
||||
(with-test (:name (:cons-union :lp1912863))
|
||||
(let ((c (cons 2 4)))
|
||||
(assert (not (typep c '(or (cons (integer 0 8) (integer 5 15))
|
||||
(cons (integer 3 15) (integer 4 14))))))))
|
||||
(cons (integer 3 15) (integer 4 14))))))))
|
||||
|
||||
(with-test (:name (:rational-union :equivalent-to-t))
|
||||
(let ((type '(or (integer * -1) (rational -1/2 1/2) (integer 1) (not integer))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue