Format fix
Ken Dickey <[email protected]> Sun, 05 Jun 2005 16:51:27 +0200
| Newsgroups | gmane.lisp.scheme.srfi.srfi-48 |
|---|---|
| Message-ID | <[email protected]> |
--=-=-=
Content-Disposition: inline
Oops!
Here is a fixed version of "format.scm" (found 2 bugs as noted below) as well
as some simple test code.
I'd like you'all to try this out for a bit before updating the SRFI page yet
again. Please feel free to send me test cases.
Thanks for the help!
-KenD
================================
In mzscheme,
Welcome to MzScheme version 299.100, Copyright (c) 2004-2005 PLT Scheme,
Inc.
>
> (format "~10,0F" -3e-4)
" -0."
> (format "~10,1F" -3e-4)
" -0.0"
> (format "~10,2F" -3e-4)
" -0.0." ---> error?
> (format "~10,3F" -3e-4)
" -0.0.0" ---> error?
> (format "~10,4F" -3e-4)
" -0.0003"
> 3e-5
3e-005
> (format "~10,4F" 3e-5)
> +: expects type <number> as 1st argument, given: #f; other arguments
were: 1
--=-=-=
Content-Type: application/octet-stream; name=format-test.scm
Content-Disposition: attachment; filename=format-test.scm
Content-Transfer-Encoding: base64
CihkZWZpbmUtc3ludGF4IGV4cGVjdAogIChzeW50YXgtcnVsZXMgKCkKICAgICgoZXhwZWN0
ID9leHBlY3RlZCA/Zm9ybSkgOz0+CiAgICAgKGV4cGVjdCA/ZXhwZWN0ZWQgP2Zvcm0gZXF1
YWw/KQogICAgKQogICAgKChleHBlY3QgP2V4cGVjdGVkID9mb3JtID9jb21wYXJlKSA7PT4K
ICAgICAobGV0ICggKGV4cGVjdGVkID9leHBlY3RlZCkKICAgICAgICAgICAgKGFjdHVhbCAg
ID9mb3JtKQogICAgICAgICAgKQogICAgICAgKGlmICg/Y29tcGFyZSBleHBlY3RlZCBhY3R1
YWwpCgkgICAoZm9ybWF0ICN0ICJQQVNTRUQ6ICB+d34lIiAnP2Zvcm0pCiAgICAgICAgICAg
KGZvcm1hdCAjdCAKCQkgICAgIn4lKipGQUlMOiBleHBlY3RlZDogfnd+JSBnb3Q6IH53fiUg
ZnJvbTogfnd+JSIKCQkgICAgZXhwZWN0ZWQKCQkgICAgYWN0dWFsCgkJICAgICc/Zm9ybSkp
KQogICAgKQopICkKCjs7IE9yIG9sZCBzdHlsZSBtYWNyb3MgW0dhbWJpdF0KOwo7IChkZWZp
bmUtbWFjcm8gKGV4cGVjdCBleHBlY3RlZCBmb3JtIC4gY29tcGFyZSkKOyAgIChsZXQqICgg
KHNhbWU/IChpZiAobnVsbD8gY29tcGFyZSkgZXF1YWw/IChldmFsIChjYXIgYCxjb21wYXJl
KSkpKQo7ICAgICAgICAgICAod2FudGVkIChldmFsIGAsZXhwZWN0ZWQpKQo7ICAgICAgICAg
ICAoYWN0dWFsIChldmFsIGAsZm9ybSkpCjsgICAgICAgICApCjsgICAgIChpZiAoc2FtZT8g
d2FudGVkIGFjdHVhbCkKOyAgICAgICAgIChmb3JtYXQgI3QgIlBBU1NFRDogIH5zfiUiIGZv
cm0pCjsgICAgICAgICAoZm9ybWF0ICN0IAo7ICAgICAgICAgICAgICAgICAifiUqKkZBSUw6
IGV4cGVjdGVkOiB+c34lIGdvdDogIH5zfiUgZnJvbTogfnN+JSIKOyAgICAgICAgICAgICAg
ICAgd2FudGVkCjsgICAgICAgICAgICAgICAgIGFjdHVhbAo7ICAgICAgICAgICAgICAgICBm
b3JtKSkKOyApICkKICAgICAgICAKCjs7Oz09PT09PT09PT09PT09PT09PT09PT09PT09PT09
PT09PT09PT09PT09PT09PT09PT09PQoKKGV4cGVjdCAoZm9ybWF0ICJ0ZXN0IH5zIiAnbWUp
IChmb3JtYXQgI2YgInRlc3QgfmEiICJtZSIpKQoKKGV4cGVjdCAgIiAwLjMzMyIgKGZvcm1h
dCAifjYsM0YiIDEvMykpIDs7OyAiICAuMzMzIiBPSwoKKGV4cGVjdCAiICAxMiIgKGZvcm1h
dCAifjRGIiAxMikpCgooZXhwZWN0ICIgIDEyLjM0NiIgKGZvcm1hdCAifjgsM0YiIDEyLjM0
NTYpKQoKKGV4cGVjdCAiMTIzLjM0NiIgKGZvcm1hdCAifjYsM0YiIDEyMy4zNDU2KSkKCihl
eHBlY3QgIjEyMy4zNDYiIChmb3JtYXQgIn40LDNGIiAxMjMuMzQ1NikpCgooZXhwZWN0ICIw
LjAwMCsxLjk0OWkiIChmb3JtYXQgIn44LDNGIiAoc3FydCAtMy44KSkpCgooZXhwZWN0ICIg
MzIuMDAiIChmb3JtYXQgIn42LDJGIiAzMikpCgooZXhwZWN0ICIgICAgMzIiIChmb3JtYXQg
In42RiIgMzIpKQoKKGV4cGVjdCAiICAgMzIuIiAoZm9ybWF0ICJ+NkYiIDMyLikpIDs7ICIg
IDMyLjAiIE9LCjs7IE5COiAobm90IChhbmQgKGV4YWN0PyAzMi4pIChpbnRlZ2VyPyAzMi4p
KSkKCihleHBlY3QgIiAgMy4yZTQ2IiAoZm9ybWF0ICJ+OEYiIDMyZTQ1KSkKCihleHBlY3Qg
IiAzLjJlLTQ0IiAoZm9ybWF0ICJ+OEYiIDMyZS00NSkpCgooZXhwZWN0ICIgIDMuMmUyMSIg
KGZvcm1hdCAifjhGIiAzMmUyMCkpCgo7OyhleHBlY3QgIiAgIDMuMmU2IiAoZm9ybWF0ICJ+
OEYiIDMyZTUpKSA7OyBvay4gIGNvbnZlcnRlZCBpbiBpbnB1dCB0byAzMjAwMDAwLjAKCihl
eHBlY3QgIiAgIDMyMDAuIiAoZm9ybWF0ICJ+OEYiIDMyZTIpKSA7OyAiICAzMjAwLjAiIE9L
CgooZXhwZWN0ICIgMy4yMGUxMSIgKGZvcm1hdCAifjgsMkYiIDMyZTEwKSkKCihleHBlY3Qg
IiAgICAgIDEuMjM0NSIgKGZvcm1hdCAifjEyRiIgMS4yMzQ1KSkKCihleHBlY3QgIiAgICAg
ICAgMS4yMyIgKGZvcm1hdCAifjEyLDJGIiAxLjIzNDUpKQoKKGV4cGVjdCAiICAgICAgIDEu
MjM0IiAoZm9ybWF0ICJ+MTIsM0YiIDEuMjM0NSkpCgooZXhwZWN0ICIgICAgICAgIDAuMDAw
KzEuOTQ5aSIgKGZvcm1hdCAifjIwLDNGIiAoc3FydCAtMy44KSkpCgooZXhwZWN0ICIwLjAw
MCsxLjk0OWkiIChmb3JtYXQgIn44LDNGIiAoc3FydCAtMy44KSkpCgooZXhwZWN0ICIgMy40
NmUxMSIgKGZvcm1hdCAifjgsMkYiIDMuNDU2N2UxMSkpCgo7IChleHBlY3QgIiMxPShhIGIg
YyAuICMxIykiCjsgICAgICAgICAoZm9ybWF0ICJ+dyIgKGxldCAoIChjICcoYSBiIGMpKSAp
IChzZXQtY2RyISAoY2RkciBjKSBjKSBjKSkpCgooZXhwZWN0ICIKIgogICAgICAgIChmb3Jt
YXQgIn5BfkF+JiIgKGxpc3QtPnN0cmluZyAobGlzdCAjXG5ld2xpbmUpKSAiIikpCgooZXhw
ZWN0ICJhIG5ldyB0ZXN0IgogICAgICAgIChmb3JtYXQgIn5hIH4/IH5hIiAnYSAifnMiICco
bmV3KSAndGVzdCkpCgooZXhwZWN0ICJhIG5ldyB0ZXN0LCB5ZXMhIgogICAgICAgIChmb3Jt
YXQgIn5hIH4/LCB+YSEiICdhICJ+cyB+YSIgJyhuZXcgdGVzdCkgJ3llcykpCgooZXhwZWN0
ICIgMy40NmUyMCIgKGZvcm1hdCAifjgsMkYiIDMuNDU2N2UyMCkpCgooZXhwZWN0ICIgMy40
NmUyMSIgKGZvcm1hdCAifjgsMkYiIDMuNDU2N2UyMSkpCgooZXhwZWN0ICIgMy40NmUyMiIg
KGZvcm1hdCAifjgsMkYiIDMuNDU2N2UyMikpCgooZXhwZWN0ICIgMy40NmUyMyIgKGZvcm1h
dCAifjgsMkYiIDMuNDU2N2UyMykpCgooZXhwZWN0ICIgICAzLmUyNCIgKGZvcm1hdCAifjgs
MEYiIDMuNDU2N2UyNCkpCgooZXhwZWN0ICIgIDMuNWUyNCIgKGZvcm1hdCAifjgsMUYiIDMu
NDU2N2UyNCkpCgooZXhwZWN0ICIgMy40NmUyNCIgKGZvcm1hdCAifjgsMkYiIDMuNDU2N2Uy
NCkpCgooZXhwZWN0ICIzLjQ1N2UyNCIgKGZvcm1hdCAifjgsM0YiIDMuNDU2N2UyNCkpCgoo
ZXhwZWN0ICIgICA0LmUyNCIgKGZvcm1hdCAifjgsMEYiIDMuNTU2N2UyNCkpCgooZXhwZWN0
ICIgIDMuNmUyNCIgKGZvcm1hdCAifjgsMUYiIDMuNTU2N2UyNCkpCgooZXhwZWN0ICIgMy41
NmUyNCIgKGZvcm1hdCAifjgsMkYiIDMuNTU2N2UyNCkpCgooZXhwZWN0ICIgICAgICAgLTAu
IiAoZm9ybWF0ICJ+MTAsMEYiIC0zZS00KSkKCihleHBlY3QgIiAgICAgIC0wLjAiIChmb3Jt
YXQgIn4xMCwxRiIgLTNlLTQpKQoKKGV4cGVjdCAiICAgICAtMC4wMCIgKGZvcm1hdCAifjEw
LDJGIiAtM2UtNCkpCgooZXhwZWN0ICIgICAgLTAuMDAwIiAoZm9ybWF0ICJ+MTAsM0YiIC0z
ZS00KSkKCihleHBlY3QgIiAgIC0wLjAwMDMiIChmb3JtYXQgIn4xMCw0RiIgLTNlLTQpKQoK
KGV4cGVjdCAiICAtMC4wMDAzMCIgKGZvcm1hdCAifjEwLDVGIiAtM2UtNCkpCgo7OyAgIC0t
LSAgIEUgTyBGICAgLS0tICAgOzsK
--=-=-=
Content-Type: text/plain; name=format.scm
Content-Disposition: attachment; filename=format.scm
;; FILE: format.scm
;; IMPLEMENTATION DEPENDENT options
(define ascii-tab (integer->char 9)) ;; NB: assumes ASCII encoding
(define dont-print (if (eq? #t #f) 1))
;;(define DONT-PRINT (string->symbol ""))
;;(define DONT-PRINT (void))
(define pretty-print write) ; ugly but permitted
;; ( require 'srfi-38) ;; write-with-shared-structure
;; FORMAT
(define (format . args)
(cond
((null? args)
(error "FORMAT: required format-string argument is missing")
)
((string? (car args))
(apply format (cons #f args)))
((< (length args) 2)
(error (format #f "FORMAT: too few arguments ~s" (cons 'format args)))
)
(else
(let ( (output-port (car args))
(format-string (cadr args))
(args (cddr args))
)
(letrec ( (port
(cond ((output-port? output-port) output-port)
((eq? output-port #t) (current-output-port))
((eq? output-port #f) (open-output-string))
(else (error
(format #f "FORMAT: bad output-port argument: ~s"
output-port)))
) )
(return-value
(if (eq? output-port #f) ;; if format into a string
(lambda () (get-output-string port)) ;; then return the string
(lambda () dont-print)) ;; else do something harmless
)
)
(define (string-index str c)
(let ( (len (string-length str)) )
(let loop ( (i 0) )
(cond ((= i len) #f)
((eqv? c (string-ref str i)) i)
(else (loop (+ i 1)))))))
(define (string-grow str len char)
(let ( (off (- len (string-length str))) )
(if (positive? off)
(string-append (make-string off char) str)
str)))
(define (compose-with-digits digits pre-str frac-str exp-str)
(let ( (frac-len (string-length frac-str)) )
(cond
((< frac-len digits) ;; grow frac part, pad with zeros
(string-append pre-str "."
frac-str (make-string (- digits frac-len) #\0)
exp-str)
)
((= frac-len digits) ;; frac-part is exactly the right size
(string-append pre-str "."
frac-str
exp-str)
)
(else ;; must round to shrink it
(let* ( (first-part (substring frac-str 0 digits))
(last-part (substring frac-str digits frac-len))
(temp-str
(number->string
(round (string->number
(string-append first-part "." last-part)))))
(dot-pos (string-index temp-str #\.))
(carry?
(and (> dot-pos digits)
(> (round (string->number
(string-append "0." frac-str)))
0)))
(new-frac
(let* ( (frac (substring temp-str 0 dot-pos))
(frac-len (string-length frac)) )
(if (< frac-len digits)
(string-append frac
(make-string (- digits frac-len) #\0))
(substring frac 0 digits))))
)
(string-append
(if carry? (number->string (+ 1 (string->number pre-str))) pre-str)
"."
new-frac
exp-str)))
) ) )
(define (format-fixed number-or-string width digits) ; returns a string
(cond
((string? number-or-string)
(string-grow number-or-string width #\space)
)
((number? number-or-string)
(let ( (real (real-part number-or-string))
(imag (imag-part number-or-string))
)
(cond
((not (zero? imag))
(string-grow
(string-append (format-fixed real 0 digits)
(if (negative? imag) "" "+")
(format-fixed imag 0 digits)
"i")
width
#\space)
)
(digits
(let* ( (num (exact->inexact real))
(small? (< (abs num) 1))
(nega? (negative? num))
;; want to display digits around the decimal
(num-str
(number->string
(if small? ((if nega? - +) num 1) num)))
(dot-index (string-index num-str #\.))
(exp-index (string-index num-str #\e))
(length (string-length num-str))
(pre-string
(cond
(exp-index
(if dot-index
(substring num-str 0 dot-index)
(substring num-str 0 exp-index))
)
(dot-index
(substring num-str 0 dot-index)
)
(else
num-str))
)
(exp-string
(if exp-index (substring num-str exp-index length) "")
)
(frac-string
(cond
(dot-index
(if exp-index
(substring num-str (+ dot-index 1) exp-index)
(substring num-str (+ dot-index 1) length))
)
(else ""))
)
)
(if (zero? (string-length pre-string))
(set! pre-string "0"))
(if small? (string-set! pre-string
(- (string-length pre-string) 1)
#\0))
(string-grow
(if dot-index
(compose-with-digits digits
pre-string
frac-string
exp-string)
(string-append pre-string exp-string))
width
#\space)
))
(else ;; no digits
(string-grow (number->string real) width #\space)))
))
(else
(error
(format "FORMAT: ~F requires a number or a string, got ~s" number-or-string)))
))
(define documentation-string
"(format [<port>] <format-string> [<arg>...]) -- <port> is #t, #f or an output-port
OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Encoding
~H [Help] output this text
~A [Any] (display arg) for humans
~S [Slashified] (write arg) for parsers
~W [WriteCircular] like ~s but outputs circular and recursive data structures
~~ [tilde] output a tilde
~T [Tab] output a tab character
~% [Newline] output a newline character
~& [Freshline] output a newline character if the previous output was not a newline
~D [Decimal] the arg is a number which is output in decimal radix
~X [heXadecimal] the arg is a number which is output in hexdecimal radix
~O [Octal] the arg is a number which is output in octal radix
~B [Binary] the arg is a number which is output in binary radix
~w,dF [Fixed] the arg is a string or number which has width w and d digits after the decimal
~C [Character] charater arg is output by write-char
~_ [Space] a single space character is output
~Y [Yuppify] the list arg is pretty-printed to the output
~? [Indirection] recursive format: next 2 args are format-string and list of arguments
~K [Indirection] same as ~?
"
)
(define (require-an-arg args)
(if (null? args)
(error "FORMAT: too few arguments" ))
)
(define (format-help format-strg arglist)
(letrec (
(length-of-format-string (string-length format-strg))
(anychar-dispatch
(lambda (pos arglist last-was-newline)
(if (>= pos length-of-format-string)
arglist ; return unused args
(let ( (char (string-ref format-strg pos)) )
(cond
((eqv? char #\~)
(tilde-dispatch (+ pos 1) arglist last-was-newline))
(else
(write-char char port)
(anychar-dispatch (+ pos 1) arglist #f)
))
))
)) ; end anychar-dispatch
(has-newline?
(lambda (whatever last-was-newline)
(or (eqv? whatever #\newline)
(and (string? whatever)
(let ( (len (string-length whatever)) )
(if (zero? len)
last-was-newline
(eqv? #\newline (string-ref whatever (- len 1)))))))
)) ; end has-newline?
(tilde-dispatch
(lambda (pos arglist last-was-newline)
(cond
((>= pos length-of-format-string)
(write-char #\~ port) ; tilde at end of string is just output
arglist ; return unused args
)
(else
(case (char-upcase (string-ref format-strg pos))
((#\A) ; Any -- for humans
(require-an-arg arglist)
(let ( (whatever (car arglist)) )
(display whatever port)
(anychar-dispatch (+ pos 1)
(cdr arglist)
(has-newline? whatever last-was-newline))
))
((#\S) ; Slashified -- for parsers
(require-an-arg arglist)
(let ( (whatever (car arglist)) )
(write whatever port)
(anychar-dispatch (+ pos 1)
(cdr arglist)
(has-newline? whatever last-was-newline))
))
((#\W)
(require-an-arg arglist)
(let ( (whatever (car arglist)) )
(write-with-shared-structure whatever port) ;; srfi-38
(anychar-dispatch (+ pos 1)
(cdr arglist)
(has-newline? whatever last-was-newline))
))
((#\D) ; Decimal
(require-an-arg arglist)
(display (number->string (car arglist) 10) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\X) ; HeXadecimal
(require-an-arg arglist)
(display (number->string (car arglist) 16) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\O) ; Octal
(require-an-arg arglist)
(display (number->string (car arglist) 8) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\B) ; Binary
(require-an-arg arglist)
(display (number->string (car arglist) 2) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\C) ; Character
(require-an-arg arglist)
(write-char (car arglist) port)
(anychar-dispatch (+ pos 1) (cdr arglist) (eqv? (car arglist) #\newline))
)
((#\~) ; Tilde
(write-char #\~ port)
(anychar-dispatch (+ pos 1) arglist #f)
)
((#\%) ; Newline
(newline port)
(anychar-dispatch (+ pos 1) arglist #t)
)
((#\&) ; Freshline
(if (not last-was-newline) ;; (unless last-was-newline ..
(newline port))
(anychar-dispatch (+ pos 1) arglist #t)
)
((#\_) ; Space
(write-char #\space port)
(anychar-dispatch (+ pos 1) arglist #f)
)
((#\T) ; Tab -- IMPLEMENTATION DEPENDENT ENCODING
(write-char ascii-tab port)
(anychar-dispatch (+ pos 1) arglist #f)
)
((#\Y) ; Pretty-print
(pretty-print (car arglist) port) ;; IMPLEMENTATION DEPENDENT
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\F)
(require-an-arg arglist)
(display (format-fixed (car arglist) 0 #f) port)
(anychar-dispatch (+ pos 1) (cdr arglist) #f)
)
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ;; gather "~w[,d]F" w and d digits
(let loop ( (index (+ pos 1))
(w-digits (list (string-ref format-strg pos)))
(d-digits '())
(in-width? #t)
)
(if (>= index length-of-format-string)
(error
(format "FORMAT: improper numeric format directive in ~s" format-strg))
(let ( (next-char (string-ref format-strg index)) )
(cond
((char-numeric? next-char)
(if in-width?
(loop (+ index 1)
(cons next-char w-digits)
d-digits
in-width?)
(loop (+ index 1)
w-digits
(cons next-char d-digits)
in-width?))
)
((char=? next-char #\F)
(let ( (width (string->number (list->string (reverse w-digits))))
(digits (if (zero? (length d-digits))
#f
(string->number (list->string (reverse d-digits)))))
)
(display (format-fixed (car arglist) width digits) port)
(anychar-dispatch (+ index 1) (cdr arglist) #f))
)
((char=? next-char #\,)
(if in-width?
(loop (+ index 1)
w-digits
d-digits
#f)
(error
(format "FORMAT: too many commas in directive ~s" format-strg)))
)
(else
(error (format "FORMAT: ~~w.dF directive ill-formed in ~s" format-strg))))))
))
((#\? #\K) ; indirection -- take next arg as format string
(cond ; and following arg as list of format args
((< (length arglist) 2)
(error
(format "FORMAT: less arguments than specified for ~~?: ~s" arglist))
)
((not (string? (car arglist)))
(error
(format "FORMAT: ~~? requires a string: ~s" (car arglist)))
)
(else
(format-help (car arglist) (cadr arglist))
(anychar-dispatch (+ pos 1) (cddr arglist) #f)
)))
((#\H) ; Help
(display documentation-string port)
(anychar-dispatch (+ pos 1) arglist #t)
)
(else
(error (format "FORMAT: unknown tilde escape: ~s"
(string-ref format-strg pos))))
)))
)) ; end tilde-dispatch
) ; end letrec
; format-help main
(anychar-dispatch 0 arglist #f)
)) ; end format-help
; format main
(let ( (unused-args (format-help format-string args)) )
(if (not (null? unused-args))
(error
(format "FORMAT: unused arguments ~s" unused-args)))
(return-value))
)) ; end letrec, if
))) ; end format
--=-=-=--