[movitz-cvs] CVS update: movitz/losp/muerte/format.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Jul 29 16:21:40 UTC 2004
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)))
+
More information about the Movitz-cvs
mailing list