common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix a typep transform when mixing integers and rationals

Browse source
This commit is contained in:
Stas Boukarev 2026-09-08 07:10:40 +03:00
parent a42c09f297
commit 4df6bfd828
3 changed files with 48 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
src/code/type.lisp
View file

@ -7153,15 +7153,28 @@ expansion happened."
(declare (dynamic-extent function))
(let ((ranges (numeric-union-type-ranges type))
(aspects (numeric-union-type-aspects type)))
(if (memq (numtype-aspects-class aspects) '(integer rational))
(loop for i below (length ranges) by 3
for low = (aref ranges (+ i 1))
for high = (aref ranges (+ i 2))
do (funcall function low high))
(loop for i below (length ranges) by 2
for low = (aref ranges i)
for high = (aref ranges (1+ i))
do (funcall function low high)))))
(case (numtype-aspects-class aspects)
(integer
(loop for i below (length ranges) by 3
for low = (aref ranges (+ i 1))
for high = (aref ranges (+ i 2))
do (funcall function low high 'integer)))
(rational
(loop for i below (length ranges) by 3
for run = (aref ranges i)
for low = (aref ranges (+ i 1))
for high = (aref ranges (+ i 2))
do (funcall function low high
(case run
(#.range-integer-run 'integer)
(#.range-rational-run 'rational)
(#.range-ratio-run 'ratio)))))
(t
(let ((format (numtype-aspects-precision aspects)))
(loop for i below (length ranges) by 2
for low = (aref ranges i)
for high = (aref ranges (1+ i))
do (funcall function low high format)))))))
;; (or (integer * -3) (integer 5)) => -3, 5
;; (integer 5) => nil, 5
@ -7171,7 +7184,8 @@ expansion happened."
(let (min-left
min-right)
(block nil
(map-numeric-union-ranges (lambda (low high)
(map-numeric-union-ranges (lambda (low high type)
(declare (ignore type))
(cond ((not (fp-high-ge-high-p high 0))
(setf min-left high))
((not (fp-low-le-low-p low 0))

35
src/compiler/typetran.lisp
View file

@ -881,30 +881,23 @@
;; call to MEMBER
((flet ((transform-numeric (type)
(when (eq (numeric-type-complexp type) :real)
(let ((singletons))
(let (singletons left-over)
(sb-kernel::map-numeric-union-ranges
(lambda (low high)
(when (and low high
(eql low high))
(push low singletons)))
(lambda (low high class)
(if (and low
(eql low high))
(push low singletons)
(push
(let ((bounds (list (or low '*) (or high '*))))
(if (eq class 'ratio)
`(and (rational ,@bounds) (not integer))
(list* class bounds)))
left-over)))
type)
(when singletons
(let* (left-over
(class (numeric-type-class type))
(type-name (ecase class
((integer rational)
class)
(float
(numeric-type-format type)))))
(sb-kernel::map-numeric-union-ranges
(lambda (low high)
(unless (and low high
(eql low high))
(push (list type-name (or low '*) (or high '*)) left-over)))
type)
`(boolean-or (member ,object '(,@singletons))
,@ (and left-over
`((typep ,object '(or ,@left-over)))))))))))
`(boolean-or (member ,object '(,@singletons))
,@(and left-over
`((typep ,object '(or ,@left-over))))))))))
(if (numeric-union-type-p type)
(transform-numeric type)
(let (tests

10
tests/type.pure.lisp
View file

@ -1315,3 +1315,13 @@
(not (type/= (specifier-type '(and unknown unknown2)) (specifier-type '(or vector cons)))))
(assert
(not (type/= (specifier-type '(or unknown unknown2)) (specifier-type '(or vector cons))))))
(with-test (:name :numeric-union-rational-split)
(checked-compile-and-assert
()
`(lambda (j) (typep j '(or (rational 1/2 3) (integer 0))))
((9/2) nil)
((10) t)
((-1) nil)
((1/2) t)
((4/3) t)))