エスケープのオプションや戻り値に対して異議を唱える者もいるだろう。 SLIB や Common Lisp の FORMAT 手続きのように、複雑なオプションを望む者は、 上位互換性を持つ「高度な書式文字列」に関する SRFI を定義するとよい。
特に、ここで示した参照実装は (~F を除いては) 数値引数を受け取らない。 したがって SRFI-29 をサポートしていない。
基礎となるライブラリは小さく、ヒープ割り当てやスタックを使用しないことが望ましい。 このことは特に組み込みシステムでは重要である。 これを実現するためには、文字列を作成するのではなく、ポートに直接出力すればよい。 ただし、~W や ~F はサポートせず、 (display (number->string n r) p) を中間文字列を作成しないように注意深く書かれた (display:number->string n r p) に置換する必要がある。
この SRFI で定義する書式文字列は、 中級的な (intermediate) 書式文字列であるため、 非常に便利な ~F と ~W を仕様からはずしたくはなかった。 ~H オプションはユーザーに使用法を表示するために便利であり、 使用できる指令をプログラムで問い合わせることもできるし、 どの書式指令がサポートされているかを知るためにも有用である。
MacLisp に始まるほとんどの Lisp や Scheme 処理系は何らかの FORMAT 関数を提供しており、 様々な書式指令をサポートしている。 この SRFI では共通に使用できるオプションを定義することで、 コードの移植性を高めることを目的としている。
参照実装は R5RS 準拠であり移植は容易である。 (~W と ~F を除く) 高度な機能が不要であれば、 実装のコードサイズを小さくすることが可能である。 たとえば、参照実装は副作用 (代入) を使用しておらず、 コードサイズは最新の SLIB の FORMAT 手続きの３分の１以下のである (~F をサポートしなければ１０分の１以下にできる)。
書式テンプレート (Scheme 文字列) を受け取り、 その中の書式指令を順に別の文字列に置換する。 どのような文字列に置換されるかは、 書式指令の意味論により決定される。 各書式指令は１つのオブジェクト obj を必要とすることがある。 書式指令が必要とする個数のオブジェクトを渡さなかったり、 多く渡し過ぎると、エラーになる。
port 引数を指定する場合は、出力ポートか、あるいは、ブール値でなければならない。 出力ポートを指定すると、書式化された文字列がそのポートに出力される。 ポートに #t を指定すると、current-output-port に出力される。 ポートに #f を指定した場合、または、ポートを指定しなかった場合は、 書式化された文字列が戻り値として返される。 ポートに #t または出力ポートを指定した場合は、 この手続きの戻り値は不定である。
出力にどのようなエンコーディング (たとえば ASCII, EBCDIC, UNICODE) が使われるかは未定義である。 どのようなエンコーディングが使われるかは、この手続きの実装が定義しなければならない。 実装によっては、エンコーディングを選択することや変更することを許すかも知れないし、 許さないかも知れない。
書式指令が obj 引数を使用したとき、 その値が下表で定められた型を持たなければ、エラーである。
pretty-print を (define pretty-print write). のように定義してもよいが、非常に推奨しない。
書式指令は 2 文字のシーケンスで、最初の文字はチルダ '~' である 書式文字は大小文字を区別しない。 つまり、大文字であれ小文字であれ同じように解釈される。 指令コードの意味は次のとおり。
指令 文字の意味 処理内容 引数が必要? ~a Any (display obj) と同じ。人間のための文字列を出力する。 ○ ~s Slashified (write obj) と同じ。パーサのための文字列を出力する。/td> ○ ~w WriteCircular (write-with-shared-structure obj) と同じ。~s と同様だが再帰的構造も処理できる。 ○ ~d Decimal obj 引数は数値であり、10進数で出力する。 ○ ~x heXadecimal obj 引数は数値であり、16進数で出力する。 ○ ~o Octal obj 引数は数値であり、8進数で出力する。 ○ ~b Binary obj 引数は数値であり、2進数で出力する。 ○ ~c Character obj 引数は 1 文字であり、write-char により出力する。 ○ ~y Yuppify obj 引数はリストであり、pretty-print により出力する。 ○ ~? Indirection obj 引数は別の書式文字列であり、後続の obj はその引数である。format が再帰的に呼び出される。 ○ ~K Indirection ~? と同じ。既存の実装の後方互換性のためにある。 ○ ~[w[,d]]F Fixed ~w,dF は数値を幅 w で小数点以下の桁数 d で出力する。
~wF は文字列または数値を幅 w で出力する。○ ~~ Tilde チルダを出力する。 × ~t Tab タブ文字を出力する。 × ~% Newline 改行 (newline) を出力する。 × ~& Freshline 直前の出力が改行でない場合にのみ、改行を出力する。 × ~_ Space スペース文字を出力する。 × ~h Help format 手続きの呼び出し方を 1 行、コメントを 1 行、各書式指令に対する 1 行の説明 (先頭は指令) を出力する。 ×
固定長書式化 ~F 指令については、説明が必要だろう。
~wF は文字列や数値に対して使用する。 文字列 (数値の場合は number->string で変換した文字列) が幅 w より短い場合は、その文字列の左側にスペース文字がパディングされる。
~w,dF は通常は数値に対してのみ使用する。 文字列に対しては桁数 d の指定は無視される。 数値に対しては桁数 d は小数点以下の桁数を指定する。 w も d も 0 以上の整数でなければならない。
桁数 d を指定した場合は、数値に 0.0 が加算されたかのように処理される。 つまり、不正確数に変換される。
(format "~8,2F" 1/3) => " 0.33"桁数 d を指定しない場合は、数値は不正確数に変換されない。(format "~6F" 32) => " 32"数字の右側に 0 がパディングされる。(format "~8,2F" 32) => " 32.00"数値が大き過ぎて指定幅に収まり切らない場合は、 指定幅より長い文字列が出力される。(format "~1,2F" 4321) => "4321.00"数値が複素数の場合、桁数 d は実部と虚部の両方に適用される。(format "~1,2F" (sqrt -3.9)) => "0.00+1.97i"非常に大きな数値、あるいは、非常に小さな数値に対しては、 指数表現が使われる基準は実装依存である。
(format "~8F" 32e5) => " 3.2e6" or "3200000.0"
(format "~h") ; => "(format [<port>] <format-string> [<arg>...]) -- <port> is #t, #f or an output-port OPTION [MNEMONIC] DESCRIPTION -- This implementation Assumes ASCII Text Encoding ~H [Help] output this text ~A [Any] (display arg) for humans ~S [Slashified] (write arg) for parsers ~~ [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 arg is a format-string and the following arg a list of arguments ~K [Indirection] same as ~? " (format "Hello, ~a" "World!") ; => "Hello, World!" (format "Error, list is too short: ~s" '(one "two" 3)) ; => "Error, list is too short: (one \"two\" 3))" (format "test me") ; => "test me" (format "~a ~s ~a ~s" 'this 'is "a" "test") ; => "this is a \"test\"" (format #t "#d~d #x~x #o~o #b~b~%" 32 32 32 32) ;; Prints: #d32 #x20 #o40 #b100000 ; => <unspecified> (format "~a ~? ~a" 'a "~s" '(new) 'test) ; =>"a new test" (format #f "~&1~&~&2~&~&~&3~%") ; => " 1 2 3 " (format #f "~a ~? ~a ~%" 3 " ~s ~s " '(2 2) 3) ; => "3 2 2 3 " (format "~w" (let ( (c '(a b c)) ) (set-cdr! (cddr c) c) c)) ; => "#1=(a b c . #1#)" (format "~8,2F" 32) ; => " 32.00" (format "~8,3F" (sqrt -3.8)) ; => "0.000+1.949i" (format "~8,2F" 3.4567e11) ; => " 3.45e11" (format "~6,3F" 1/3) ; => " 0.333" (format "~4F" 12) ; => " 12" (format "~8,3F" 123.3456) ; => " 123.346" (format "~6,3F" 123.3456) ; => "123.346" (format "~2,3F" 123.3456) ; => "123.346" (format "~8,3F" "foo") ; => " foo" (format "~a~a~&" (list->string (list #\newline)) "") ; => " "
;; 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 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
(substring temp-str 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-str (number->string (exact->inexact real)))
(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 1)))
)
(dot-index
(substring num-str 0 dot-index)
)
(else
num-str))
)
(exp-string
(if exp-index (substring num-str exp-index length) "")
)
(frac-string
(if exp-index
(substring num-str (+ dot-index 1) exp-index)
(substring num-str (+ dot-index 1) length))
)
)
(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
Copyright (C) Kenneth A Dickey (2003). All Rights Reserved.
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.