Skip to content
Snippets Groups Projects
Commit 5b6d1bf2 authored by gerd's avatar gerd
Browse files

* src/code/numbers.lisp (round): Handle the case truncate

	returning a zero remainder specially.
parent 177c4804
No related branches found
No related tags found
No related merge requests found
......@@ -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/numbers.lisp,v 1.48 2003/08/19 12:23:36 gerd Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.49 2003/08/22 09:20:02 gerd Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -733,19 +733,21 @@
(if (eql divisor 1)
(round number)
(multiple-value-bind (tru rem) (truncate number divisor)
(let ((thresh (/ (abs divisor) 2)))
(cond ((or (> rem thresh)
(and (= rem thresh) (oddp tru)))
(if (minusp divisor)
(values (- tru 1) (+ rem divisor))
(values (+ tru 1) (- rem divisor))))
((let ((-thresh (- thresh)))
(or (< rem -thresh)
(and (= rem -thresh) (oddp tru))))
(if (minusp divisor)
(values (+ tru 1) (- rem divisor))
(values (- tru 1) (+ rem divisor))))
(t (values tru rem)))))))
(if (zerop rem)
(values (if (minusp tru) -1 1) rem)
(let ((thresh (/ (abs divisor) 2)))
(cond ((or (> rem thresh)
(and (= rem thresh) (oddp tru)))
(if (minusp divisor)
(values (- tru 1) (+ rem divisor))
(values (+ tru 1) (- rem divisor))))
((let ((-thresh (- thresh)))
(or (< rem -thresh)
(and (= rem -thresh) (oddp tru))))
(if (minusp divisor)
(values (+ tru 1) (- rem divisor))
(values (- tru 1) (+ rem divisor))))
(t (values tru rem))))))))
(defun rem (number divisor)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment