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

More thorough ratio-to-float test

Browse source
This commit is contained in:
Stas Boukarev 2026-01-28 01:11:37 +03:00
parent b8e87d6164
commit e251cf9c08
1 changed files with 10 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
tests/float-2.pure.lisp
View file

@ -815,14 +815,20 @@ fractional bits."
(values (ftruncate x -1.0))) (values (ftruncate x -1.0)))
(single-float 0.0 0.0))) (single-float 0.0 0.0)))
(defun floats-around (float)
(multiple-value-bind (sig exp) (integer-decode-float float)
(let* ((prev-float (if (= sig (ash 1 (1- (float-digits float))))
(scale-float (float (1- (ash 1 (float-digits float))) float) (1- exp))
(scale-float (float (1- sig) float) exp)))
(next-float (scale-float (float (1+ sig) float) exp)))
(values prev-float next-float sig))))
(defun check-ratio-to-float (ratio type) (defun check-ratio-to-float (ratio type)
(declare (ratio ratio)) (declare (ratio ratio))
(let* ((result (float ratio type)) (let* ((result (float ratio type))
(new-ratio (rational result))) (new-ratio (rational result)))
(multiple-value-bind (sig exp sign) (integer-decode-float result) (multiple-value-bind (prev-float next-float sig) (floats-around result)
(let* ((prev-float (scale-float (float (* sign (1- sig)) type) exp)) (let* ((error (abs (- ratio new-ratio)))
(next-float (scale-float (float (* sign (1+ sig)) type) exp))
(error (abs (- ratio new-ratio)))
(error-prev (abs (- ratio (rational prev-float)))) (error-prev (abs (- ratio (rational prev-float))))
(error-next (abs (- ratio (rational next-float))))) (error-next (abs (- ratio (rational next-float)))))
(cond (cond