The implementation below requires SRFI-1 (List library), SRFI-6 (Basic string ports), SRFI-8 (Receive), SRFI-13 (String library), and SRFI-51 (Handling rest list).
This SRFI introduces the CAT procedure that converts any object to a string. It takes one object as the first argument and accepts a variable number of optional arguments, unlike the procedure called FORMAT.
It is difficult to gain a complete consensus for the design of a generic formatting procedure that performs a variety of necessary functions in addition to essential functions provided in C's PRINTF and Common lisp's FORMAT. One of such ways would be to devise a free (and/or floating) sequence method that easily handles optional arguments, in contrast to the conventional fixed sequence method, in order to obtain a handy optional and functional interface. With the concept of free sequencing, the CAT procedure is then defined, not to process optional arguments with default values, but to process default values with optional arguments.
In converting a number to a string, it has not been tried to uniformly express the exactness of a number. The CAT procedure makes it possible for the user to prefix an exact sign to the resulting string as well as not to prefix it to the resulting string as conventionally used when an exact number is made to have a decimal point. An inexact sign is prefixed to the resulting string in addition to an radix sign when an inexact number is converted to a non-decimal.
(CAT <object> [<exactness%>] [<radix%>] [<sign%>] [<precision%>] [<separator%>]
[<writer$>] [<pipe$>] [<take$>]
[<converter*>] [<width*>] [<char*>] [<port*>] [<string*>] ...)
The order of all optional arguments does not matter. The CAT procedure processes optional arguments in the following order; <exactness>, <radix>, <precision>, <separator>, <sign> for the number type of <object>, or in the following order; <writer>, <pipe>, <take> for all other types.
(cat 129.995 -10 2.) => "130.00 "
(cat 129.995 10 2.) => " 130.00"
(cat 129.985 10 2.) => " 129.98"
(cat 129.985001 10 2.) => " 129.99"
(cat 129.995 2. 'exact) => "#e130.00"
(cat 129 -2.) => "129.00"
(cat 129 2.) => "#e129.00"
(cat 129 10 2. #\0 'sign) => "#e+0129.00"
(cat 129 10 2. #\* 'sign) => "*#e+129.00"
(cat 1/3) => "1/3"
(cat 1/3 10 2.) => " #e0.33"
(cat 1/3 10 -2.) => " 0.33"
(cat 129.995 10 '(#\, 2)) => " 1,29.99,5"
(cat 129995 10 '(#\,) 'sign) => " +129,995"
(cat (cat 129.995 0.) '(0 -1)) => "130"
(cat 99.5 10 'sign 'octal) => "#i#o+307/2"
(cat 99.5 10 'sign 'octal 'exact) => " #o+307/2"
(cat #x123 'octal 'sign) => "#o+443"
(cat #x123 -10 2. 'sign #\*) => "#e+291.00*"
(cat -1.2345e+15+1.2355e-15i 3.) => "-1.234e15+1.236e-15i"
(cat 1.2345e+15 10 3. 'sign) => " +1.234e15"
(cat "string" -10) => "string "
(cat "string" 10 (list string-upcase)) => " STRING"
(cat "string" 10 (list string-upcase) '(-2)) => " RING"
(cat "string" 10 `(,string-titlecase) '(2 3)) => " Sting"
(cat "string" `(,string-reverse ,string-upcase) => "GNIRTS"
(cat #\a 10) => " a"
(cat 'symbol 10) => " symbol"
(cat '#(#\a "str" s)) => "#(#\\a \"str\" s)"
(cat '(#\a "str" s)) => "(#\\a \"str\" s)"
(cat '(#\a "str" s) #t) => (#\a "str" s)"(#\\a \"str\" s)"
(cat '(#\a "str" s) (current-output-port)) => (#\a "str" s)"(#\\a \"str\" s)"
(cat 3 (cat 's) " " (cat "str" write)) => "3s \"str\""
(cat 3 #t (cat 's) " " (cat "str" write)) => 3s "str""3s \"str\""
(cat 3 #t (cat 's #t) " " (cat "str" write)) => s3s "str""3s \"str\""
(define-record-type :example (make-example num str) example? (num get-num set-num!) (str get-str set-str!)) (define ex (make-example 123 "string")) (define (record->string object) (cat (get-num object) "-" (get-str object))) (define (record-writer object string-port) (if (example? object) (begin (display (get-num object) string-port) (display "-" string-port) (display (get-str object) string-port)) ((or (and (or (string? object) (char? object) (boolean? object)) display) write) object string-port))) ex => '#{:example} (cat ex) => "#{:example}" (cat ex 20 record-writer) => " 123-string" (cat ex 20 record-writer `(,(cut string-delete char-set:digit <>) ,string-upcase ,string-reverse) '(0 -1) #\-) => "--------------GNIRTS" (cat "string" 20 record-writer (list string-upcase) '(2 3) #\-) => "---------------STING" (cat 12 20 record-writer 3.) => " #e12.000" (cat ex 20 (cons example? record->string)) => " 123-string" (cat ex 20 (cons example? record->string) `(,(cut string-delete char-set:digit <>) ,string-upcase ,string-reverse) '(0 -1) #\-) => "----------123-string" (cat "string" 20 (cons example? record->string) (list string-upcase) '(2 3) #\-) => "---------------STING" (cat 12 20 (cons example? record->string) -3.) => " 12.000"
(define (cat object . rest)
(receive (str-list rest-list) (partition string? rest)
(if (null? rest-list)
(apply string-append
(cond
((number? object) (number->string object))
((string? object) object)
((char? object) (string object))
((boolean? object) (if object "#t" "#f"))
(else
(get-output-string
(let ((str-port (open-output-string)))
(write object str-port)
str-port))))
str-list)
(receive (width port char converter precision sign radix exactness
separator writer pipe take)
(rest-values "cat: bad argument" rest-list #t
(cons 0 (lambda (x) (and (integer? x) (exact? x))))
(cons #f (lambda (x) (or (boolean? x)
(output-port? x))))
(cons #\space char?)
(cons #f (lambda (x)
(and (pair? x)
(procedure? (car x))
(procedure? (cdr x)))))
(cons #f (lambda (x) (and (integer? x) (inexact? x))))
(cons #f (lambda (x) (eq? x 'sign)))
'(decimal octal binary hexadecimal)
(cons #f (lambda (x) (memq x '(exact inexact))))
(cons #f (lambda (x)
(and (list? x)
(< 0 (length x) 3)
(char? (car x))
(or (null? (cdr x))
(let ((n (cadr x)))
(and (integer? n)
(exact? n)
(< 0 n)))))))
(cons #f procedure?)
(cons #f (lambda (x)
(and (list? x)
(not (null? x))
(every procedure? x))))
(cons #f (lambda (x)
(and (list? x)
(< 0 (length x) 3)
(every (lambda (x)
(and (integer? x)
(exact? x)))
x)))))
(let ((port (if (eq? port #t) (current-output-port) port))
(str
(apply
string-append
(cond
((and converter
((car converter) object))
(let* ((str ((cdr converter) object))
(pad (- (abs width) (string-length str))))
(cond
((<= pad 0) str)
((< 0 width) (string-append (make-string pad char) str))
(else (string-append str (make-string pad char))))))
((number? object)
(arg-ors
("cat: non-decimal cannot have a decimal point" radix
(and (not (eq? radix 'decimal)) precision))
("cat: exact number cannot have a decimal point without exact sign" precision
(and precision (< precision 0) (eq? exactness 'exact))))
(let ((exact-sign
(and precision
(<= 0 precision)
(or (eq? exactness 'exact)
(and (exact? object)
(not (eq? exactness 'inexact))))
"#e"))
(inexact-sign
(and (not (eq? radix 'decimal))
(or (and (inexact? object)
(not (eq? exactness 'exact)))
(eq? exactness 'inexact))
"#i"))
(radix-sign
(cdr (assq radix '((decimal . #f) (octal . "#o")
(binary . "#b")
(hexadecimal . "#x")))))
(plus-sign (and sign (< 0 (real-part object)) "+")))
(let* ((exactness-sign (or exact-sign inexact-sign))
(str
(if precision
(let ((precision
(inexact->exact (abs precision)))
(imag (imag-part object)))
(define (e-mold num pre)
(let* ((str (number->string
(if (exact? num)
(exact->inexact num)
num)))
(e-index (string-index str #\e)))
(if e-index
(string-append
(mold (substring str 0 e-index)
pre)
(substring str e-index
(string-length str)))
(mold str pre))))
(define (mold str pre)
(let ((ind (string-index str #\.)))
(if ind
(let ((d-len (- (string-length str)
(+ ind 1))))
(cond
((= d-len pre) str)
((< d-len pre)
(string-append str
(make-string
(- pre d-len)
#\0)))
((or (charchar
(+ 1 (char->integer chr)))
(lp (- index 1) #f)))
(cons chr (lp (- index 1) raise))))))))))
(if minus (cons #\- char-list) char-list))))
(else
(substring str
0 (+ 1 ind pre)))))
(string-append
str "." (make-string pre #\0)))))
(if (= 0 imag)
(e-mold object precision)
(string-append
(e-mold (real-part object) precision)
(if (< 0 imag) "+" "")
(e-mold imag precision)
"i")))
(number->string
(cond
(inexact-sign
(if (inexact? object)
(inexact->exact object) object))
(exactness
(if (eq? exactness 'exact)
(if (inexact? object)
(inexact->exact object) object)
(if (exact? object)
(exact->inexact object) object)))
(else object))
(cdr (assq radix '((decimal . 10)
(octal . 8)
(binary . 2)
(hexadecimal . 16)))))))
(str
(if (and separator
(not (or (and (eq? radix 'decimal)
(string-index str #\e))
(string-index str #\i)
(string-index str #\/))))
(let ((sep (string (car separator)))
(num (if (null? (cdr separator))
3 (cadr separator)))
(dot-index (string-index str #\.)))
(define (separate str sep num opt)
(let* ((len (string-length str))
(pos
(if opt
(let ((pos
(remainder
(if (eq? opt 'minus)
(- len 1) len)
num)))
(if (= 0 pos) num pos))
num)))
(apply
string-append
(let loop ((ini 0)
(pos (if (eq? opt 'minus)
(+ pos 1) pos)))
(if (< pos len)
(cons (substring str ini pos)
(cons sep
(loop pos
(+ pos num))))
(list (substring str
ini len)))))))
(if dot-index
(string-append
(separate (substring str 0 dot-index)
sep num (if (< object 0)
'minus #t))
"."
(separate (substring
str (+ 1 dot-index)
(string-length str))
sep num #f))
(separate str sep num (if (< object 0)
'minus #t))))
str))
(pad (- (abs width)
(+ (string-length str)
(if exactness-sign 2 0)
(if radix-sign 2 0)
(if plus-sign 1 0))))
(pad (if (< 0 pad) pad 0)))
(if (< 0 width)
(if (char-numeric? char)
(if (< (real-part object) 0)
(string-append (or exactness-sign "")
(or radix-sign "")
"-"
(make-string pad char)
(substring str 1
(string-length
str)))
(string-append (or exactness-sign "")
(or radix-sign "")
(or plus-sign "")
(make-string pad char)
str))
(string-append (make-string pad char)
(or exactness-sign "")
(or radix-sign "")
(or plus-sign "")
str))
(string-append (or exactness-sign "")
(or radix-sign "")
(or plus-sign "")
str
(make-string pad char))))))
(else
(let* ((str (cond
(writer (get-output-string
(let ((str-port
(open-output-string)))
(writer object str-port)
str-port)))
((string? object) object)
((char? object) (string object))
((boolean? object) (if object "#t" "#f"))
(else (get-output-string
(let ((str-port (open-output-string)))
(write object str-port)
str-port)))))
(str (if pipe
(let loop ((str ((car pipe) str))
(fns (cdr pipe)))
(if (null? fns)
str
(loop ((car fns) str)
(cdr fns))))
str))
(str
(if take
(let ((left (car take))
(right (if (null? (cdr take))
0 (cadr take)))
(len (string-length str)))
(define (substr str beg end)
(let ((end (cond
((< end 0) 0)
((< len end) len)
(else end)))
(beg (cond
((< beg 0) 0)
((< len beg) len)
(else beg))))
(if (and (= beg 0) (= end len))
str
(substring str beg end))))
(string-append
(if (< left 0)
(substr str (abs left) len)
(substr str 0 left))
(if (< right 0)
(substr str 0 (+ len right))
(substr str (- len right) len))))
str))
(pad (- (abs width) (string-length str))))
(cond
((<= pad 0) str)
((< 0 width) (string-append (make-string pad char) str))
(else (string-append str (make-string pad char)))))))
str-list)))
(and port (display str port))
str)))))
I owe much to those who incite me to make this SRFI better. And I must thank Michael Sperber for his encouragement and guidance during the draft period of SRFI 51, as the important part of this SRFI is based on SRFI 51. Without him, neither SRFI 51 nor SRFI 54 would have been finilized. Again, I greatly appreciate his kindness and effort. Finally, I deeply apologize to Francisco Solsona for bringing disgrace upon him against my will early in the draft period.
This document and translations of it may be copied and furnished to others, and derivative works that comment on or otherwise explain it or assist in its implementation may be prepared, copied, published and distributed, in whole or in part, without restriction of any kind, provided that the above copyright notice and this paragraph are included on all such copies and derivative works. However, this document itself may not be modified in any way, such as by removing the copyright notice or references to the Scheme Request For Implementation process or editors, except as needed for the purpose of developing SRFIs in which case the procedures for copyrights defined in the SRFI process must be followed, or as required to translate it into languages other than English.
The limited permissions granted above are perpetual and will not be revoked by the authors or their successors or assigns.
This document and the information contained herein is provided on an "AS IS" basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.