[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-serv22690

Modified Files:
	format.lisp 
Log Message:
Added an imbecile format-float, for ~F.

Date: Thu Jul 29 09:21:39 2004
Author: ffjeld

Index: movitz/losp/muerte/format.lisp
diff -u movitz/losp/muerte/format.lisp:1.5 movitz/losp/muerte/format.lisp:1.6
--- movitz/losp/muerte/format.lisp:1.5	Thu May 20 10:47:24 2004
+++ movitz/losp/muerte/format.lisp	Thu Jul 29 09:21:39 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.5 2004/05/20 17:47:24 ffjeld Exp $
+;;;; $Id: format.lisp,v 1.6 2004/07/29 16:21:39 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -59,6 +59,22 @@
 	  (*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 find-directive (string i directive &optional recursive-skip-start
 						    (recursive-skip-end directive))
   "Return position of <directive> in <string>, starting search at <i>. Also return
@@ -142,6 +158,7 @@
 				   (nreverse prefix-parameters)))
 	      (#\X (format-integer (pop args) 16 at-sign-p colon-p
 				   (nreverse prefix-parameters)))
+	      (#\F (apply 'format-float (pop args) at-sign-p colon-p (nreverse prefix-parameters)))
 	      (#\C (if colon-p
 		       (let ((c (pop args)))
 			 (write-string (or (char-name c) c)))
@@ -292,3 +309,4 @@
      end-loop)
     (values i args)))
 
+