[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv26913

Modified Files:
	format.lisp 
Log Message:
Tune-up of format-float: Round off the last digit properly.

Date: Fri Jul 30 15:15:23 2004
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.6 movitz/losp/muerte/format.lisp:1.7
--- movitz/losp/muerte/format.lisp:1.6	Thu Jul 29 09:21:39 2004
+++ movitz/losp/muerte/format.lisp	Fri Jul 30 15:15:23 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Mar 23 01:18:36 2002
 ;;;;                
-;;;; $Id: format.lisp,v 1.6 2004/07/29 16:21:39 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.7 2004/07/30 22:15:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -59,21 +59,27 @@
 	  (*print-readably* nil))
       (write x))))
 
-(defun format-float (x &optional at-sign-p colon-p w d k overflowchar padchar)
-  (declare (ignore w k overflowchar padchar at-sign-p colon-p))
-  (multiple-value-bind (integer-part decimal-part)
-      (truncate x)
-    (write-integer integer-part *standard-output* 10 t)
-    (do ((remainder decimal-part)
-	 (i 0 (1+ i)))
-	((if (not d)
-	     (or (and (plusp i) (zerop decimal-part))
-		 (>= i 16))
-	   (= i d)))
-      (multiple-value-bind (next-digit next-remainder)
-	  (truncate (* 10 remainder))
-	(setf remainder next-remainder)
-	(write-integer next-digit *standard-output* 10 nil)))))
+(defun format-float (x &optional at-sign-p colon-p w d (k 0) overflowchar padchar)
+  (declare (ignore w overflowchar padchar at-sign-p colon-p))
+  (if (eql 0 d)
+      (write-integer (round x) *standard-output* 10 nil)
+    (multiple-value-bind (integer-part decimal-part)
+	(truncate x)
+      (write-integer integer-part *standard-output* 10 nil)
+      (dotimes (i k)
+	(write-char #\0))
+      (write-char #\.)
+      (do ((remainder decimal-part)
+	   (last-i (if d (1- d) 15))
+	   (i 0 (1+ i)))
+	  ((or (and (not d) (plusp i) (zerop remainder))
+	       (> i last-i)))
+	(multiple-value-bind (next-digit next-remainder)
+	    (if (= i last-i)
+		(round (* 10 remainder))
+	      (truncate (* 10 remainder)))
+	  (setf remainder next-remainder)
+	  (write-digit next-digit *standard-output*))))))
 
 (defun find-directive (string i directive &optional recursive-skip-start
 						    (recursive-skip-end directive))