This page is part of the web mail archives of SRFI 54 from before July 7th, 2015. The new archives for SRFI 54 contain all messages, not just those from before July 7th, 2015.
* From: Jens Axel Søgaard <jensaxel@xxxxxxxxxxxx>
* 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