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

22
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))
(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))
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)))))
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))

29
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
(lambda (low high class)
(if (and low
(eql low high))
(push low singletons)))
(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)))))))))))
`((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)))