* module/srfi/srfi-48.sld: New file.
* module/srfi/srfi-48/48.body.scm: Likewise.
* am/bootstrap.am (srfi/srfi-48.go): New target.
(SOURCES): Register srfi/srfi-48.sld.
(NOCOMP_SOURCES): Register srfi/srfi-48/48.upstream.scm.
* test-suite/tests/srfi-48.test: New test.
* test-suite/Makefile.am (SCM_TESTS): Register it.
---
(no changes since v1)
NEWS | 1 +
am/bootstrap.am | 5 +-
doc/ref/guile.texi | 6 +-
doc/ref/srfi-modules.texi | 264 ++++++++++++++++++
module/srfi/srfi-48.sld | 14 +
module/srfi/srfi-48/48.upstream.scm | 409 ++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-48.test | 320 ++++++++++++++++++++++
8 files changed, 1016 insertions(+), 4 deletions(-)
create mode 100644 module/srfi/srfi-48.sld
create mode 100644 module/srfi/srfi-48/48.upstream.scm
create mode 100644 test-suite/tests/srfi-48.test
diff --git a/NEWS b/NEWS
index a269e0776..1c4dd7b56 100644
--- a/NEWS
+++ b/NEWS
@@ -21,6 +21,7 @@ definitely unused---this is notably the case for modules that
are only
used at macro-expansion time, such as (srfi srfi-26). In those cases,
the compiler reports it as "possibly unused".
+** Add (srfi 48), a string format library
** Add (srfi 126), a hash tables library
** Add (srfi 128), a comparators library
** Add (scheme comparator)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 343fe6dcd..67460b32d 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -54,8 +54,10 @@ COMPILE = $(AM_V_GUILEC)
\
.el.go:
$(COMPILE) --from=elisp -o "$@" "$<"
+# Rebuild modules when their included sources have changes.
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm
ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
+srfi/srfi-48.go: srfi/srfi-48/48.upstream.scm
srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
# Keep this rule in sync with that in `am/guilec'.
@@ -358,6 +360,7 @@ SOURCES = \
srfi/srfi-43.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \
+ srfi/srfi-48.sld \
srfi/srfi-60.scm \
srfi/srfi-64.scm \
srfi/srfi-67.scm \
@@ -474,7 +477,7 @@ NOCOMP_SOURCES = \
ice-9/quasisyntax.scm \
scheme/features.scm \
srfi/srfi-42/ec.scm \
- srfi/srfi-64/testing.scm \
+ srfi/srfi-48/48.upstream.scm \
srfi/srfi-67/compare.scm \
srfi/srfi-125/125.body.scm \
srfi/srfi-128/128.body1.scm \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index f2a2d08f4..9be1b7540 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -24,9 +24,9 @@ Invariant Sections, no Front-Cover Texts, and no Back-Cover
Texts. A
copy of the license is included in the section entitled ``GNU Free
Documentation License.''
-Additionally, the documentation of the 125, 126, 128, 151, 160, 178 and
-209 SRFI modules is adapted from their specification text, which is made
-available under the following Expat license:
+Additionally, the documentation of the 48, 125, 126, 128, 151, 160, 178
+and 209 SRFI modules is adapted from their specification text, which is
+made available under the following Expat license:
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 3ca18979f..650d7f27f 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -2,6 +2,7 @@
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017, 2018, 2019, 2020
@c Free Software Foundation, Inc.
+@c Copyright (C) 2003 Kenneth A Dickey
@c Copyright (C) 2015-2016 Taylan Ulrich Bayırlı/Kammer
@c Copyright (C) 2015-2016, 2018, 2020 John Cowan
@c See the file guile.texi for copying conditions.
@@ -53,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-43:: Vector Library.
* SRFI-45:: Primitives for expressing iterative lazy
algorithms
* SRFI-46:: Basic syntax-rules Extensions.
+* SRFI 48:: Intermediate Format Strings.
* SRFI-55:: Requiring Features.
* SRFI-60:: Integers as bits.
* SRFI-61:: A more general `cond' clause
@@ -5108,6 +5110,268 @@ SRFI-46/R7RS. Tail patterns have been supported since
at least Guile
2.0, and custom ellipsis identifiers have been supported since Guile
2.0.10. @xref{Syntax Rules}.
+@node SRFI 48
+@subsection SRFI 48: Intermediate Format Strings
+@cindex SRFI 48
+
+@menu
+* SRFI 48 Abstract::
+* SRFI 48 Rationale::
+* SRFI 48 Specification::
+@end menu
+
+@node SRFI 48 Abstract
+@subsubsection SRFI 48 Abstract
+
+This document specifies Format Strings, a method of interpreting a
+Scheme string which contains a number of format directives that are
+replaced with other string data according to the semantics of each
+directive. This SRFI extends SRFI 28 in being more generally useful but
+is less general than advanced format strings in that it does not allow,
+aside from ~F, for controlled positioning of text within fields.
+
+@node SRFI 48 Rationale
+@subsubsection SRFI 48 Rationale
+
+Inheriting from MacLisp, nearly all Lisp and Scheme implementations
+support some form of FORMAT function with support for various numbers of
+format directives. By agreeing to the options here, we raise the bar
+for portable code.
+
+The reference implementation is R5RS compliant and easy to port. In not
+requiring advanced features (aside from @samp{~W} and @samp{~F}) small
+implementations are possible. E.g.@: the reference code does not use
+side effects (assignment) and is less than a third the source size of
+the latest SLIB implementation of FORMAT (less than a tenth if @samp{~F}
+support is elided).
+
+The optional @var{port} argument allows for compatibility with older
+code written for, e.g.@: scheme48, MIT Scheme, T, et cetera, which
+required a port argument. It is also useful in cases where a synoptic
+implementation of Scheme and CommonLisp is maintained.
+
+@node SRFI 48 Specification
+@subsubsection SRFI 48 Specification
+
+@deffn format [port] format-string [obj @dots{}]
+
+Accepts a format template (a Scheme String), and processes it, replacing
+any format directives in order with one or more characters, the
+characters themselves dependent on the semantics of the format directive
+encountered. Each directive may consume one @var{obj}. It is an error
+if fewer or more @var{obj} values are provided than format directives
+that require them.
+
+When @var{port} is specified it must be either an output port or a
+boolean. If an output port is specified, the formatted output is output
+into that port. If the @var{port} argument is @code{#t}, output is to
+the @code{current-output-port}. If @var{port} is @code{#f} or no port
+is specified, the output is returned as a string. If @var{port} is
+specified and is @code{#t} or an output port, the result of the format
+function is unspecified.
+
+It is unspecified which encoding is used (e.g.@: ASCII, EBCDIC,
+UNICODE). A given implementation must specify which encoding is used.
+The implementation may or may not allow the encoding to be selected or
+changed.
+
+It is an error if a format directive consumes an @var{obj} argument and
+that argument does not confirm to a required type as noted in the table
+below.
+
+It is permissible, but highly discouraged, to implement
+@code{pretty-print} as @samp{(define pretty-print write)}.
+
+A format directive is a two character sequence in the string where the
+first character is a tilde '~'. Directive characters are
+case-independent, i.e.@: upper and lower case characters are interpreted
+the same. Each directive code's meaning is described in the following
+table:
+
+@multitable @columnfractions .125 .20 .55 .125
+@headitem Directive @tab Mnemonic @tab Action @tab Consumes?
+@item ~a @tab Any @tab (display obj) for humans @tab yes
+@item ~s @tab Slashified @tab (write obj) for parsers @tab yes
+
+@item ~w @tab WriteCircular
+@tab (write-with-shared-structure obj) like ~s, but handles recursive
structures
+@tab yes
+
+@item ~d @tab Decimal
+@tab the obj is a number which is output in decimal radix @tab yes
+
+@item ~x @tab heXadecimal
+@tab the obj is a number which is output in hexdecimal radix @tab yes
+
+@item ~o @tab Octal
+@tab the obj is a number which is output in octal radix @tab yes
+
+@item ~b @tab Binary
+@tab the obj is a number which is output in binary radix @tab yes
+
+@item ~c @tab Character
+@tab the single charater obj is output by write-char @tab yes
+
+@item ~y @tab Yuppify
+@tab the list obj is pretty-printed to the output @tab yes
+
+@item ~? @tab Indirection
+@tab the obj is another format-string and the following obj is a list
+of arguments; format is called recursively @tab yes
+
+@item ~K @tab Indirection
+@tab the same as ~? for backward compatibility with
+some existing implementations @tab yes
+
+@item ~[w[,d]]F @tab Fixed
+@tab ~w,dF outputs a number with width w and d digits after the decimal;
+~wF outputs a string or number with width w. @tab yes
+
+@item ~~ @tab Tilde @tab output a tilde @tab no
+@item ~t @tab Tab @tab output a tab character @tab no
+@item ~% @tab Newline @tab output a newline character @tab no
+
+@item ~& @tab Freshline
+@tab output a newline character if it is known that the previous
+output was not a newline @tab no
+
+@item ~_ @tab Space @tab a single space character is output @tab no
+
+@item ~h @tab Help
+@tab outputs one line of call synopsis, one line of comment, and one line of
+synopsis for each format directive, starting with the directive (e.g. "~t")
+@tab no
+@end multitable
+
+The @samp{~F}, fixed format, directive requires some elucidation.
+
+@samp{~wF} is useful for strings or numbers. Where the string (or
+@code{number->string} of the number) has fewer characters than the
+integer width @samp{w}, the string is padded on the left with space
+characters.
+
+@samp{~w,dF} is typically used only on numbers. For strings, the
+@samp{d} specifier is ignored. For numbers, the integer @samp{d}
+specifies the number of decimal digits after the decimal place. Both
+@samp{w} and @samp{d} must be zero or positive.
+
+If @samp{d} is specified, the number is processed as if added to 0.0,
+i.e.@: it is converted to an inexact value.
+
+@lisp
+(format "~8,2F" 1/3) => " 0.33"
+@end lisp
+
+If no @samp{d} is specified, the number is @emph{not} coerced to
+inexact.
+
+@lisp
+(format "~6F" 32) => " 32"
+@end lisp
+
+Digits are padded to the right with zeros.
+
+@lisp
+(format "~8,2F" 32) => " 32.00"
+@end lisp
+
+If the number is too large to fit in the width specified, a string
+longer than the width is returned.
+
+@lisp
+(format "~1,2F" 4321) => "4321.00"
+@end lisp
+
+If the number is complex, @samp{d} is applied to both real and imaginal
+parts.
+
+@lisp
+(format "~1,2F" (sqrt -3.9)) => "0.00+1.97i"
+@end lisp
+
+For very large or very small numbers, the point where exponential
+notation is used is implementation defined.
+
+@lisp
+(format "~8F" 32e5) => " 3.2e6" or "3200000.0"
+@end lisp
+
+@subsubheading Examples
+
+@lisp
+(format "~h")
+; =>
+"(format [<port>] <format-string> [<arg>@dots{}]) -- <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)) "")
+; =>
+"
+"
+@end lisp
+@end deffn
+
@node SRFI-55
@subsection SRFI-55 - Requiring Features
@cindex SRFI-55
diff --git a/module/srfi/srfi-48.sld b/module/srfi/srfi-48.sld
new file mode 100644
index 000000000..f488ca088
--- /dev/null
+++ b/module/srfi/srfi-48.sld
@@ -0,0 +1,14 @@
+;;;; SPDX-FileCopyrightText: 2014 Taylan Kammer <taylan.kam...@gmail.com>
+;;;;
+;;;; SPDX-License-Identifier: MIT
+
+(define-library (srfi 48)
+ (export format)
+ (import (rename (scheme base)
+ (exact inexact->exact)
+ (inexact exact->inexact))
+ (scheme char)
+ (scheme complex)
+ (rename (scheme write)
+ (write-shared write-with-shared-structure)))
+ (include "srfi-48/48.upstream.scm"))
diff --git a/module/srfi/srfi-48/48.upstream.scm
b/module/srfi/srfi-48/48.upstream.scm
new file mode 100644
index 000000000..960d1a6b4
--- /dev/null
+++ b/module/srfi/srfi-48/48.upstream.scm
@@ -0,0 +1,409 @@
+;;; SPDX-FileCopyrightText: 2003 Kenneth A Dickey <ken.dic...@allvantage.com>
+;;; SPDX-FileCopyrightText: 2017 Hamayama <hamay1...@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;; 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
+
+;; Following three procedures are used by format ~F .
+;; 'inexact-number->string' determines whether output is fixed-point
+;; notation or exponential notation. In the current definition,
+;; the notation depends on the implementation of 'number->string'.
+;; 'exact-number->string' is expected to output only numeric characters
+;; (not including such as '#', 'e', '.', '/') if the input is an positive
+;; integer or zero.
+;; 'real-number->string' is used when the digits of ~F is not specified.
+(define (inexact-number->string x) (number->string (exact->inexact x)))
+(define (exact-number->string x) (number->string (inexact->exact x)))
+(define (real-number->string x) (number->string x))
+
+;; 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* ( (minus-flag (and (> (string-length pre-str) 0)
+ (char=? (string-ref pre-str 0) #\-)))
+ (pre-str* (if minus-flag
+ (substring pre-str 1 (string-length
pre-str))
+ pre-str))
+ (first-part (substring frac-str 0 digits))
+ (last-part (substring frac-str digits frac-len))
+ (temp-str
+ (string-grow
+ (exact-number->string
+ (round (string->number
+ (string-append pre-str* first-part "."
last-part))))
+ digits
+ #\0))
+ (temp-len (string-length temp-str))
+ (new-pre (substring temp-str 0 (- temp-len digits)))
+ (new-frac (substring temp-str (- temp-len digits)
temp-len))
+ )
+ (string-append
+ (if minus-flag "-" "")
+ (if (string=? new-pre "")
+ ;; check if the system displays integer part of numbers
+ ;; whose absolute value is 0 < x < 1.
+ (if (and (string=? pre-str* "")
+ (> digits 0)
+ (not (= (string->number new-frac) 0)))
+ "" "0")
+ new-pre)
+ "."
+ 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 (inexact-number->string real))
+ (dot-index (string-index num-str #\.))
+ (exp-index (string-index num-str #\e))
+ (length (string-length num-str))
+ (pre-string
+ (if dot-index
+ (substring num-str 0 dot-index)
+ (if exp-index
+ (substring num-str 0 exp-index)
+ num-str))
+ )
+ (exp-string
+ (if exp-index
+ (substring num-str exp-index length)
+ "")
+ )
+ (frac-string
+ (if dot-index
+ (if exp-index
+ (substring num-str (+ dot-index 1) exp-index)
+ (substring num-str (+ dot-index 1) length))
+ "")
+ )
+ )
+ ;; check +inf.0, -inf.0, +nan.0, -nan.0
+ (if (string-index num-str #\n)
+ (string-grow num-str width #\space)
+ (string-grow
+ (compose-with-digits digits
+ pre-string
+ frac-string
+ exp-string)
+ width
+ #\space))
+ ))
+ (else ;; no digits
+ (string-grow (real-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=? (char-upcase 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
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 2b5156923..612f6935c 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -153,6 +153,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-42.test \
tests/srfi-43.test \
tests/srfi-45.test \
+ tests/srfi-48.test \
tests/srfi-60.test \
tests/srfi-64.test \
tests/srfi-67.test \
diff --git a/test-suite/tests/srfi-48.test b/test-suite/tests/srfi-48.test
new file mode 100644
index 000000000..9d97a863d
--- /dev/null
+++ b/test-suite/tests/srfi-48.test
@@ -0,0 +1,320 @@
+;;; SPDX-FileCopyrightText: 2017 Hamayama <hamay1...@gmail.com>
+;;;
+;;; SPDX-License-Identifier: MIT
+
+;;
+;; srfi-48 format test for Gauche, Sagittarius, Guile, Chez Scheme
+;;
+
+;;; START Guile-specific modifications.
+(use-modules (srfi srfi-48)
+ (test-suite lib))
+
+(define-syntax-rule (test-start name)
+ #t)
+
+(define-syntax-rule (test-end)
+ #t)
+
+(define-syntax-rule (test-section name)
+ #t)
+
+(define-syntax expect
+ (syntax-rules ()
+ ((_ expected result)
+ (pass-if (equal? expected result)))
+ ((_ expected result check)
+ (pass-if (check expected result)))))
+;;; END Guile-specific modifications.
+
+(cond-expand
+ (gauche)
+ (else
+ (define (x->number x)
+ (cond
+ ((number? x) x)
+ ((string? x) (string->number x))
+ (else (error "x->number error"))))
+ ))
+
+(define (nearly=? a b)
+ (let* ((a1 (x->number a))
+ (b1 (x->number b))
+ (e1 (abs (- a1 b1))))
+ ;(format #t "(a1 = ~s, b1 = ~s, e1 = ~s)~%" a1 b1 e1)
+ (< e1 1.0e-10)))
+
+(define pi 3.141592653589793)
+
+(test-start "srfi-48 format test")
+
+(test-section "original")
+(expect (format "test ~s" 'me) (format #f "test ~a" "me"))
+(expect " 0.333" (format "~6,3F" 1/3)) ;;; " .333" OK
+(expect " 12" (format "~4F" 12))
+(expect " 12.346" (format "~8,3F" 12.3456))
+(expect "123.346" (format "~6,3F" 123.3456))
+(expect "123.346" (format "~4,3F" 123.3456))
+(expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8)))
+(expect " 32.00" (format "~6,2F" 32))
+(expect " 32" (format "~6F" 32))
+;(expect " 32." (format "~6F" 32.)) ;; " 32.0" OK
+(expect " 32.0" (format "~6F" 32.))
+;; NB: (not (and (exact? 32.) (integer? 32.)))
+(expect " 3.2e46" (format "~8F" 32e45))
+(expect " 3.2e-44" (format "~8F" 32e-45))
+(expect " 3.2e21" (format "~8F" 32e20))
+;;(expect " 3.2e6" (format "~8F" 32e5)) ;; ok. converted in input to
3200000.0
+;(expect " 3200." (format "~8F" 32e2)) ;; " 3200.0" OK
+(expect " 3200.0" (format "~8F" 32e2))
+(expect " 3.20e11" (format "~8,2F" 32e10))
+(expect " 1.2345" (format "~12F" 1.2345))
+(expect " 1.23" (format "~12,2F" 1.2345))
+(expect " 1.234" (format "~12,3F" 1.2345))
+(expect " 0.000+1.949i" (format "~20,3F" (sqrt -3.8)))
+(expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8)))
+(expect " 3.46e11" (format "~8,2F" 3.4567e11))
+; (expect "#1=(a b c . #1#)"
+; (format "~w" (let ( (c '(a b c)) ) (set-cdr! (cddr c) c) c)))
+(expect "
+"
+ (format "~A~A~&" (list->string (list #\newline)) ""))
+(expect "a new test"
+ (format "~a ~? ~a" 'a "~s" '(new) 'test))
+(expect "a new test, yes!"
+ (format "~a ~?, ~a!" 'a "~s ~a" '(new test) 'yes))
+(expect " 3.46e20" (format "~8,2F" 3.4567e20))
+(expect " 3.46e21" (format "~8,2F" 3.4567e21))
+(expect " 3.46e22" (format "~8,2F" 3.4567e22))
+(expect " 3.46e23" (format "~8,2F" 3.4567e23))
+(expect " 3.e24" (format "~8,0F" 3.4567e24))
+(expect " 3.5e24" (format "~8,1F" 3.4567e24))
+(expect " 3.46e24" (format "~8,2F" 3.4567e24))
+(expect "3.457e24" (format "~8,3F" 3.4567e24))
+(expect " 4.e24" (format "~8,0F" 3.5567e24))
+(expect " 3.6e24" (format "~8,1F" 3.5567e24))
+(expect " 3.56e24" (format "~8,2F" 3.5567e24))
+(expect " -3.e-4" (format "~10,0F" -3e-4))
+(expect " -3.0e-4" (format "~10,1F" -3e-4))
+(expect " -3.00e-4" (format "~10,2F" -3e-4))
+(expect " -3.000e-4" (format "~10,3F" -3e-4))
+(expect "-3.0000e-4" (format "~10,4F" -3e-4))
+(expect "-3.00000e-4" (format "~10,5F" -3e-4))
+(expect " 1.020" (format "~10,3F" 1.02))
+(expect " 1.025" (format "~10,3F" 1.025))
+(expect " 1.026" (format "~10,3F" 1.0256))
+(expect " 1.002" (format "~10,3F" 1.002))
+(expect " 1.002" (format "~10,3F" 1.0025))
+(expect " 1.003" (format "~10,3F" 1.00256))
+
+
+(test-section "examples")
+(expect " 0.33" (format "~8,2F" 1/3))
+(expect " 32" (format "~6F" 32))
+(expect " 32.00" (format "~8,2F" 32))
+(expect "4321.00" (format "~1,2F" 4321))
+(expect "0.00+1.97i" (format "~1,2F" (sqrt -3.9)))
+(expect "3200000.0" (format "~8F" 32e5))
+;(expect " 3.2e6" (format "~8F" 32e5))
+(expect "<string>" (format "~h") (lambda (e r) (string? r)))
+(expect "Hello, World!" (format "Hello, ~a" "World!"))
+(expect "Error, list is too short: (one \"two\" 3)" (format "Error, list is
too short: ~s" '(one "two" 3)))
+(expect "test me" (format "test me"))
+(expect "this is a \"test\"" (format "~a ~s ~a ~s" 'this 'is "a" "test"))
+(expect (if #f #f) (format #t "#d~d #x~x #o~o #b~b~%" 32 32 32 32))
+(expect "a new test" (format "~a ~? ~a" 'a "~s" '(new) 'test))
+(expect "\n1\n2\n3\n" (format #f "~&1~&~&2~&~&~&3~%"))
+(expect "3 2 2 3 \n" (format #f "~a ~? ~a ~%" 3 " ~s ~s " '(2 2) 3))
+;; incorrect mutation of literal list in example
+;(expect "#1=(a b c . #1#)" (format "~w" (let ( (c '(a b c)) ) (set-cdr! (cddr
c) c) c)))
+(cond-expand
+ (chezscheme)
+ (guile
+ (expect "#1=(a b c . #1#)" (format "~w" (let ( (c (list 'a 'b 'c)) )
(set-cdr! (cddr c) c) c)))
+ )
+ (else
+ (expect "#0=(a b c . #0#)" (format "~w" (let ( (c (list 'a 'b 'c)) )
(set-cdr! (cddr c) c) c)))
+ ))
+(expect " 32.00" (format "~8,2F" 32))
+(expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8)))
+;(expect " 3.45e11" (format "~8,2F" 3.4567e11))
+(expect " 3.46e11" (format "~8,2F" 3.4567e11))
+(expect " 0.333" (format "~6,3F" 1/3))
+(expect " 12" (format "~4F" 12))
+(expect " 123.346" (format "~8,3F" 123.3456))
+(expect "123.346" (format "~6,3F" 123.3456))
+(expect "123.346" (format "~2,3F" 123.3456))
+(expect " foo" (format "~8,3F" "foo"))
+(expect "\n" (format "~a~a~&" (list->string (list #\newline)) ""))
+
+
+(test-section "~F normal")
+(expect "0" (format "~F" 0))
+(expect "1" (format "~F" 1))
+(expect "123" (format "~F" 123))
+(expect "0.456" (format "~F" 0.456))
+(expect "123.456" (format "~F" 123.456))
+(expect "-1" (format "~F" -1))
+(expect "-123" (format "~F" -123))
+(expect "-0.456" (format "~F" -0.456))
+(expect "-123.456" (format "~F" -123.456))
+
+
+(test-section "~F width")
+(expect "123" (format "~0F" 123))
+(expect "123" (format "~1F" 123))
+(expect "123" (format "~2F" 123))
+(expect "123" (format "~3F" 123))
+(expect " 123" (format "~4F" 123))
+(expect " 123" (format "~5F" 123))
+(expect "-123" (format "~3F" -123))
+(expect "-123" (format "~4F" -123))
+(expect " -123" (format "~5F" -123))
+(expect " -123" (format "~6F" -123))
+
+
+(test-section "~F digits")
+(expect "123." (format "~1,0F" 123))
+(expect "123.0" (format "~1,1F" 123))
+(expect "123.00" (format "~1,2F" 123))
+(expect "0.12" (format "~1,2F" 0.123))
+(expect "0.123" (format "~1,3F" 0.123))
+(expect "0.1230" (format "~1,4F" 0.123))
+(expect "-123." (format "~1,0F" -123))
+(expect "-123.0" (format "~1,1F" -123))
+(expect "-123.00" (format "~1,2F" -123))
+(expect "-0.12" (format "~1,2F" -0.123))
+(expect "-0.123" (format "~1,3F" -0.123))
+(expect "-0.1230" (format "~1,4F" -0.123))
+
+
+(test-section "~F rounding (banker's rounding)")
+(expect "123." (format "~1,0F" 123.456))
+(expect "123.5" (format "~1,1F" 123.456))
+(expect "123.46" (format "~1,2F" 123.456))
+(expect "-123." (format "~1,0F" -123.456))
+(expect "-123.5" (format "~1,1F" -123.456))
+(expect "-123.46" (format "~1,2F" -123.456))
+(expect "123.0" (format "~1,1F" 123.05))
+(expect "123.2" (format "~1,1F" 123.15))
+(expect "124.0" (format "~1,1F" 123.95))
+(expect "-123.0" (format "~1,1F" -123.05))
+(expect "-123.2" (format "~1,1F" -123.15))
+(expect "-124.0" (format "~1,1F" -123.95))
+(expect "1000.00" (format "~1,2F" 999.995))
+(expect "-1000.00" (format "~1,2F" -999.995))
+(expect "1." (format "~1,0F" 1.49))
+(expect "2." (format "~1,0F" 1.5))
+(expect "2." (format "~1,0F" 1.51))
+(expect "2." (format "~1,0F" 2.49))
+(expect "2." (format "~1,0F" 2.5))
+(expect "3." (format "~1,0F" 2.51))
+
+
+(test-section "~F misc")
+(expect "+inf.0" (format "~F" +inf.0))
+(expect "-inf.0" (format "~F" -inf.0))
+(expect "+nan.0" (format "~F" +nan.0))
+(expect "0.0" (format "~F" 0.0))
+(expect "-0.0" (format "~F" -0.0))
+(expect "+inf.0" (format "~1F" +inf.0))
+(expect "-inf.0" (format "~1F" -inf.0))
+(expect "+nan.0" (format "~1F" +nan.0))
+(expect "0.0" (format "~1F" 0.0))
+(expect "-0.0" (format "~1F" -0.0))
+(expect "+inf.0" (format "~1,0F" +inf.0))
+(expect "-inf.0" (format "~1,0F" -inf.0))
+(expect "+nan.0" (format "~1,0F" +nan.0))
+(expect "0." (format "~1,0F" 0.0))
+(expect "-0." (format "~1,0F" -0.0))
+(expect "+inf.0" (format "~1,1F" +inf.0))
+(expect "-inf.0" (format "~1,1F" -inf.0))
+(expect "+nan.0" (format "~1,1F" +nan.0))
+(expect "0.0" (format "~1,1F" 0.0))
+(expect "-0.0" (format "~1,1F" -0.0))
+(expect "31.41592653589793" (format "~F" (* pi 10)))
+(expect "0.33333" (format "~1,5F" 1/3))
+(expect "-0.33333" (format "~1,5F" -1/3))
+(expect "0.142857142857" (format "~1,12F" 1/7))
+(expect "299999999.999999999" (format "~F" 299999999999999999/1000000000)
nearly=?)
+(expect "1.797693e308" (format "~F" 1.797693e308))
+(expect "1.797693e308" (format "~1F" 1.797693e308))
+(expect "2.e308" (format "~1,0F" 1.797693e308))
+(expect "1.8e308" (format "~1,1F" 1.797693e308))
+(expect "-1.797693e308" (format "~F" -1.797693e308))
+(expect "-1.797693e308" (format "~1F" -1.797693e308))
+(expect "-2.e308" (format "~1,0F" -1.797693e308))
+(expect "-1.8e308" (format "~1,1F" -1.797693e308))
+(expect "2.225074e-308" (format "~F" 2.225074e-308))
+(expect "5.02" (format "~1,2F" 5.015))
+(expect "6.00" (format "~1,2F" 5.999))
+(expect "123." (format "~1,0F" 123.00))
+(expect "0.1" (format "~F" .1))
+(expect "1" (format "~1f" 1)) ; lower case f
+(expect "1.e100" (format "~1,0F" 1e100))
+(expect "1." (format "~1,0F" 1))
+(expect "0." (format "~1,0F" .1))
+(expect "0.0" (format "~1,1F" .01))
+
+
+(cond-expand
+ (guile)
+ (else
+ (test-section "~F error")
+ (expect "<error>" (guard (e (else "<error>")) (format "~-1F" 1)))
+ (expect "<error>" (guard (e (else "<error>")) (format "~1,-1F" 1)))
+ ))
+
+
+(test-section "from mailing list 2004-05-27")
+(expect "1.230e20" (format "~0,3F" 1.23e20))
+(expect "1.230e-20" (format "~0,3F" 1.23e-20))
+
+
+(test-section "from mailing list 2004-06-11")
+(expect "3.457e15" (format "~8,3F" 3.4569e15))
+(expect " 3.457" (format "~8,3F" 3.4569))
+(expect " 3.46e15" (format "~8,2F" 3.456e15))
+(expect " 3.46" (format "~8,2F" 3.456))
+
+
+(test-section "from mailing list 2005-06-03")
+(expect " -3.e-4" (format "~10,0F" -3e-4))
+(expect " -3.0e-4" (format "~10,1F" -3e-4))
+(expect " -3.00e-4" (format "~10,2F" -3e-4))
+(expect " -3.000e-4" (format "~10,3F" -3e-4))
+(expect "-3.0000e-4" (format "~10,4F" -3e-4))
+(expect " 3.0000e-5" (format "~10,4F" 3e-5))
+
+
+(test-section "from mailing list 2005-06-07")
+(expect " 1.020" (format "~10,3F" 1.02))
+(expect " 1.025" (format "~10,3F" 1.025))
+(expect " 1.026" (format "~10,3F" 1.0256))
+(expect " 1.002" (format "~10,3F" 1.002))
+(expect " 1.002" (format "~10,3F" 1.0025))
+(expect " 1.003" (format "~10,3F" 1.00256))
+
+
+(test-section "from mailing list 2005-06-07")
+(expect "1.000012" (format "~8,6F" 1.00001234))
+
+
+(test-section "from mailing list 2005-07-02")
+(expect "abc\ndef\nghi\n" (format "abc~%~&def~&ghi~%"))
+(expect "\ndef\nghi\n" (format "~&def~&ghi~%"))
+
+
+(test-section "from mailing list 2017-10-11")
+(expect " 1.00" (format "~7,2F" .997554209949891))
+(expect " 1.00" (format "~7,2F" .99755))
+(expect " 1.00" (format "~7,2F" .9975))
+(expect " 1.00" (format "~7,2F" .997))
+(expect " 0.99" (format "~7,2F" .99))
+
+
+(test-section "from mailing list 2017-10-13")
+(expect " 18.00" (format "~7,2F" 18.0000000000008))
+(expect " -15." (format "~8,0F" -14.99995999999362))
+
+(test-end)
--
2.41.0
