* From: Jens Axel Søgaard <xxxxxx@soegaard.net>
 * Date: Tue, 23 Mar 2004 17:17:32 +0100
 * Subj: Comments and some bugs

Thank you for your comments.

   - the name OBJECT->STRING is more "Schemy"
     (it's pretty long though)
Yes, it's too long.

   - I find the name of the parameter DEPTH in the documentation
     confusing. (It makes me think in two dimensional output)
How about 'precision'?

    where a negative number is truncated:
      > (fmt -1.55555 3 2)
      "-1.54"
Yes, it's a bug.
I've corrected it.

(define (fmt expr . rest)
  (if (number? expr)
      (receive (width depth char radix plus exactness space . str-list)
	  (opt-values rest
		      (cons #f (lambda (x) (and (integer? x) (exact? x))))
		      (cons #f (lambda (x)
				 (and (integer? x) (exact? x) (<= 0 x))))
		      (cons #f char?)
		      (list 'd 'b 'o 'x)
		      (cons #f (lambda (x) (eq? x +)))
		      (cons #f (lambda (x) (memq x '(e i))))
		      (cons #f (lambda (x)
				 (and (list? x)
				      (<= 1 (length x) 2)
				      (every (lambda (x)
					       (and (integer? x)
						    (exact? x)
						    (<= 0 x)))
					     x)))))
	(arg-ors ("fmt: bad argument"  str-list
		  (not (every string? str-list)))
		 ("fmt: non-decimal cannot be inexact" radix
		  (and (memq radix '(b o x))
		       (or depth
			   (and (inexact? expr) (not (eq? exactness 'e)))
			   (eq? exactness 'i))))
		 ("fmt: exact number cannot have a decimal point" depth
		  (and depth (eq? exactness 'e)))
		 ("fmt: unnecessary padding character" char
		  (and char (not width))))
	(let* ((width (or width 0))
	       (char (or char #\space))
	       (sign (if (< width 0) '- '+))
	       (str (number->string
		     (if exactness
			 (if (eq? exactness 'e)
			     (if (inexact? expr) (inexact->exact expr) expr)
			     (if (exact? expr) (exact->inexact expr) expr))
			 (if (and depth (exact? expr))
			     (exact->inexact expr)
			     expr))
		     (cdr (assq radix '((b . 2) (d . 10) (o . 8) (x . 16))))))
	       (str
		(if depth
		    (let ((e-index (or (string-index str #\e)
				       (string-index str #\E)))
			  (+-index (string-index str #\+ 1)))
		      (define (mold str dep)
			(let ((len (string-length str))
			      (index (string-index str #\.)))
			  (if index
			      (let ((d-len (- len index 1)))
				(if (<= d-len dep)
				    (string-append str
						   (make-string (- dep d-len)
								#\0))
				    (mold
				     (number->string
				      ;; begin correction
				      (let ((num
					     (string->number
					      (substring str 0
							 (+ (if (= dep 0) 0 1)
							    index dep)))))
					((if (< num 0) - +)
					 ;; end correction
					 num
					 (if (< 4 (string->number
						   (string
						    (string-ref
						     str
						     (+ 1 index dep)))))
					     (expt 0.1 dep) 0))))
				     dep)))
			      (string-append str "." (make-string dep #\0)))))
		      (cond
		       (e-index
			(string-append (mold (substring str 0 e-index) depth)
				       (substring str e-index
						  (string-length str))))
		       (+-index
			(string-append (mold (substring str 0 +-index) depth)
				       "+"
				       (mold (substring str (+ 1 +-index)
							(- (string-length str)
							   1)) depth)
				       (string (string-ref
						str
						(- (string-length str) 1)))))
		       (else
			(mold str depth))))
		    str))
	       (str (if (and (< 0 (real-part expr))
			     (not (eqv? #\+ (string-ref str 0)))
			     plus)
			(string-append "+" str)
			str))
	       (len (string-length str))
	       (lt (if space (car space) 0))
	       (rt (if (and space (not (null? (cdr space)))) (cadr space) 0))
	       (pad (- (abs width) len lt rt)))
	  (apply string-append
		 (make-string lt #\space)
		 (cond
		  ((<= pad 0) str)
		  ((eq? sign '+)
		   (if (and (eqv? char #\0)
			    (or (eqv? #\+ (string-ref str 0))
				(eqv? #\- (string-ref str 0))))
		       (string-append (string (string-ref str 0))
				      (make-string pad char)
				      (substring str 1 len))
		       (string-append (make-string pad char) str)))
		  (else
		   (string-append str (make-string pad char))))
		 (make-string rt #\space)
		 str-list)))
      (receive (width depth char show case space . str-list)
	  (opt-values rest
		      (cons #f (lambda (x) (and (integer? x) (exact? x))))
		      (cons #f (lambda (x)
				 (and (integer? x) (exact? x) (<= 0 x))))
		      (cons #f char?)
		      (list display write)
		      (cons #f (lambda (x) (memq x '(d u t))))
		      (cons #f (lambda (x)
				 (and (list? x)
				      (<= 1 (length x) 2)
				      (every (lambda (x)
					       (and (integer? x)
						    (exact? x)
						    (<= 0 x)))
					     x)))))
	(arg-ors ("fmt: bad argument" str-list
		  (not (every string? str-list)))
		 ("fmt: unnecessary padding character" char
		  (and char (not width))))
	(let* ((width (or width 0))
	       (char (or char #\space))
	       (sign (if (< width 0) '- '+))
	       (str (get-output-string
		     (let ((str-port (open-output-string)))
		       (show expr str-port)
		       str-port)))
	       (str (if (and depth (< depth (string-length str)))
			(substring str 0 depth)
			str))
	       (str (if case
			((cdr (assq case `((d . ,string-downcase)
					   (u . ,string-upcase)
					   (t . ,string-titlecase)))) str)
			str))
	       (lt (if space (car space) 0))
	       (rt (if (and space (not (null? (cdr space)))) (cadr space) 0))
	       (pad (- (abs width) (string-length str) lt rt)))
	  (apply string-append
		 (make-string lt #\space)
		 (cond
		  ((<= pad 0) str)
		  ((eq? sign '+) (string-append (make-string pad char) str))
		  (else (string-append str (make-string pad char))))
		 (make-string rt #\space)
		 str-list)))))

 |....
 |....
 |....
Please check the revised version in `a preface'.

Thanks.
--
INITERM