[uim-commit] r3166 - in branches/r5rs/sigscheme: src test
yamaken at freedesktop.org
yamaken at freedesktop.org
Fri Mar 17 22:38:07 PST 2006
Author: yamaken
Date: 2006-03-17 22:38:03 -0800 (Fri, 17 Mar 2006)
New Revision: 3166
Added:
branches/r5rs/sigscheme/test/test-srfi48.scm
Modified:
branches/r5rs/sigscheme/src/format.c
branches/r5rs/sigscheme/test/test-srfi28.scm
Log:
* sigscheme/src/format.c
- (format_str_peek): Fix "~" case
- (scm_pretty_print): Fix symbol-bound? check
- (read_number): Expand max column to accept leading zero ("099")
- (format_raw_c_directive): Change return type and return last char
- (format_directive):
* Ditto
* Fix broken prefix check
- (format_internal): Fix broken freshline handling
* sigscheme/test/test-srfi48.scm
- New file
- Add tests for SRFI-48
- tests for ~w,dF is failed, others are passed
* sigscheme/test/test-srfi28.scm
- All tests has been passed
- Comment in the previously failed test
- Add tests for invalid form
Modified: branches/r5rs/sigscheme/src/format.c
===================================================================
--- branches/r5rs/sigscheme/src/format.c 2006-03-12 15:51:30 UTC (rev 3165)
+++ branches/r5rs/sigscheme/src/format.c 2006-03-18 06:38:03 UTC (rev 3166)
@@ -39,6 +39,7 @@
=======================================*/
#include <stddef.h>
#include <stdarg.h>
+#include <string.h>
/*=======================================
Local Include
@@ -140,14 +141,14 @@
static void format_int(ScmObj port,
ScmValueFormat vfmt, uintmax_t n, int radix);
#if SCM_USE_RAW_C_FORMAT
-static scm_bool format_raw_c_directive(ScmObj port,
- format_string_t *fmt, va_list *args);
+static scm_ichar_t format_raw_c_directive(ScmObj port,
+ format_string_t *fmt, va_list *args);
#endif
#if SCM_USE_SRFI28
-static scm_bool format_directive(ScmObj port, scm_ichar_t prev_ch,
- enum ScmFormatCapability fcap,
- format_string_t *fmt,
- struct format_args *args);
+static scm_ichar_t format_directive(ScmObj port, scm_ichar_t last_ch,
+ enum ScmFormatCapability fcap,
+ format_string_t *fmt,
+ struct format_args *args);
#endif
static ScmObj format_internal(ScmObj port, enum ScmFormatCapability fcap,
const char *fmt, struct format_args *args);
@@ -169,7 +170,8 @@
static scm_ichar_t
format_str_peek(ScmMultibyteString mbs_fmt, const char *caller)
{
- return scm_charcodec_read_char(scm_current_char_codec, &mbs_fmt, caller);
+ return (FORMAT_STR_ENDP(mbs_fmt)) ? '\0' :
+ scm_charcodec_read_char(scm_current_char_codec, &mbs_fmt, caller);
}
#endif /* SCM_USE_MULTIBYTE_CHAR */
@@ -177,13 +179,17 @@
scm_pretty_print(ScmObj port, ScmObj obj)
{
ScmObj proc_pretty_print;
+ DECLARE_INTERNAL_FUNCTION("scm_pretty_print");
- proc_pretty_print = scm_symbol_value(sym_pretty_print,
- SCM_INTERACTION_ENV);
- if (!EQ(proc_pretty_print, SCM_UNBOUND))
+ /* FIXME: search pretty-print in current env */
+ proc_pretty_print = SCM_SYMBOL_VCELL(sym_pretty_print);
+
+ if (!EQ(proc_pretty_print, SCM_UNBOUND)) {
+ ENSURE_PROCEDURE(proc_pretty_print);
scm_call(proc_pretty_print, LIST_1(obj));
- else
+ } else {
scm_write(port, obj);
+ }
}
static signed char
@@ -193,7 +199,7 @@
scm_int_t ret;
scm_bool err;
char *bufp;
- char buf[sizeof("99")];
+ char buf[sizeof("099")];
DECLARE_INTERNAL_FUNCTION("format");
for (bufp = buf;
@@ -247,11 +253,13 @@
}
#if SCM_USE_RAW_C_FORMAT
-/* ([CP]|(0?[0-9]+(,0?[0-9]+)?)?(S|([MWQLGJTZ]?[UDXOB]))) */
-static scm_bool
+/* returns '\0' if no valid directive handled */
+/* ([CP]|(0?[0-9]+(,0?[0-9]+)?)?(S|[MWQLGJTZ]?[UDXOB])) */
+static scm_ichar_t
format_raw_c_directive(ScmObj port, format_string_t *fmt, va_list *args)
{
const void *orig_pos;
+ const char *str;
scm_ichar_t c;
uintmax_t n; /* FIXME: sign extension */
int radix;
@@ -265,8 +273,9 @@
switch (c) {
case 'C': /* Character */
FORMAT_STR_SKIP_CHAR(*fmt);
- scm_port_put_char(port, va_arg(*args, scm_ichar_t));
- return scm_true;
+ c = va_arg(*args, scm_ichar_t);
+ scm_port_put_char(port, c);
+ return c;
case 'P': /* Pointer */
FORMAT_STR_SKIP_CHAR(*fmt);
@@ -274,7 +283,7 @@
SCM_VALUE_FORMAT_INIT4(vfmt, sizeof(void *) * CHAR_BIT / 4,
-1, '0', scm_false);
format_int(port, vfmt, (uintptr_t)va_arg(*args, void *), 16);
- return scm_true;
+ return c;
default:
break;
@@ -285,8 +294,9 @@
if (c == 'S') { /* String */
FORMAT_STR_SKIP_CHAR(*fmt);
/* FIXME: reflect vfmt.width */
- scm_port_puts(port, va_arg(*args, const char *));
- return scm_true;
+ str = va_arg(*args, const char *);
+ scm_port_puts(port, str);
+ return (*str) ? str[strlen(str) - 1] : c;
}
/* size modifiers (ordered by size) */
@@ -357,25 +367,26 @@
default:
/* no internal directives found */
SCM_ASSERT(FORMAT_STR_POS(*fmt) == orig_pos);
- return scm_false;
+ return '\0';
}
FORMAT_STR_SKIP_CHAR(*fmt);
if (!modifiedp)
n = va_arg(*args, unsigned int);
format_int(port, vfmt, n, radix);
- return scm_true;
+ return c;
}
#endif /* SCM_USE_RAW_C_FORMAT */
#if SCM_USE_SRFI28
-static scm_bool
-format_directive(ScmObj port, scm_ichar_t prev_ch,
+static scm_ichar_t
+format_directive(ScmObj port, scm_ichar_t last_ch,
enum ScmFormatCapability fcap,
format_string_t *fmt, struct format_args *args)
{
const void *orig_pos;
char directive;
+ scm_bool eolp;
#if SCM_USE_SRFI48
ScmObj obj, indirect_fmt, indirect_args;
scm_bool prefixedp;
@@ -390,33 +401,8 @@
prefixedp = (FORMAT_STR_POS(*fmt) != orig_pos);
#endif /* SCM_USE_SRFI48 */
directive = ICHAR_DOWNCASE(FORMAT_STR_PEEK(*fmt));
+ eolp = scm_false;
- if (fcap & SCM_FMT_SRFI28) {
- if (prefixedp)
- goto err_invalid_prefix;
-
- switch (directive) {
- case 'a': /* Any */
- scm_display(port, POP_FORMAT_ARG(args));
- goto fin;
-
- case 's': /* Slashified */
- scm_write(port, POP_FORMAT_ARG(args));
- goto fin;
-
- case '%': /* Newline */
- scm_port_newline(port);
- goto fin;
-
- case '~': /* Tilde */
- scm_port_put_char(port, '~');
- goto fin;
-
- default:
- break;
- }
- }
-
#if SCM_USE_SRFI48
if (fcap & SCM_FMT_SRFI48_ADDENDUM) {
radix = -1;
@@ -458,11 +444,39 @@
format_int(port, vfmt, SCM_INT_VALUE(obj), radix);
goto fin;
}
+ }
+#endif /* SCM_USE_SRFI48 */
- if (prefixedp)
- goto err_invalid_prefix;
+ if (prefixedp)
+ ERR("invalid prefix for directive ~%c", directive);
+ if (fcap & SCM_FMT_SRFI28) {
switch (directive) {
+ case 'a': /* Any */
+ scm_display(port, POP_FORMAT_ARG(args));
+ goto fin;
+
+ case 's': /* Slashified */
+ scm_write(port, POP_FORMAT_ARG(args));
+ goto fin;
+
+ case '%': /* Newline */
+ scm_port_newline(port);
+ eolp = scm_true;
+ goto fin;
+
+ case '~': /* Tilde */
+ scm_port_put_char(port, '~');
+ goto fin;
+
+ default:
+ break;
+ }
+ }
+
+#if SCM_USE_SRFI48
+ if (fcap & SCM_FMT_SRFI48_ADDENDUM) {
+ switch (directive) {
case 'w': /* WriteCircular */
scm_write_ss(port, POP_FORMAT_ARG(args));
goto fin;
@@ -496,8 +510,9 @@
goto fin;
case '&': /* Freshline */
- if (prev_ch != NEWLINE_CHAR)
+ if (last_ch != NEWLINE_CHAR)
scm_port_newline(port);
+ eolp = scm_true;
goto fin;
case 'h': /* Help */
@@ -519,12 +534,9 @@
* reference implementation treats it as error. */
ERR("invalid escape sequence: ~%c", directive);
- err_invalid_prefix:
- ERR("invalid prefix for directive ~%c", directive);
-
fin:
FORMAT_STR_SKIP_CHAR(*fmt);
- return scm_true;
+ return (eolp) ? NEWLINE_CHAR : directive;
}
#endif /* SCM_USE_SRFI28 */
@@ -532,7 +544,7 @@
format_internal(ScmObj port, enum ScmFormatCapability fcap,
const char *fmt, struct format_args *args)
{
- scm_ichar_t c, prev_c;
+ scm_ichar_t c, last_c;
format_string_t cur;
scm_bool implicit_portp;
DECLARE_INTERNAL_FUNCTION("format");
@@ -549,15 +561,16 @@
implicit_portp = scm_false;
}
- prev_c = '\0';
- FORMAT_STR_INIT(cur, fmt);
- for (; !FORMAT_STR_ENDP(cur); prev_c = c) {
+ last_c = '\0';
+ FORMAT_STR_INIT(cur, fmt);
+ while (!FORMAT_STR_ENDP(cur)) {
c = FORMAT_STR_READ(cur);
if (c == '~') {
#if SCM_USE_RAW_C_FORMAT
if (fcap & SCM_FMT_RAW_C) {
SCM_ASSERT(args->type == ARG_VA_LIST);
- if (format_raw_c_directive(port, &cur, &args->lst.va))
+ last_c = format_raw_c_directive(port, &cur, &args->lst.va);
+ if (last_c)
continue;
}
#endif /* SCM_USE_RAW_C_FORMAT */
@@ -565,13 +578,14 @@
if (fcap & (SCM_FMT_SRFI28 | SCM_FMT_SRFI48 | SCM_FMT_SSCM)) {
SCM_ASSERT(args->type == ARG_VA_LIST
|| args->type == ARG_SCM_LIST);
- if (format_directive(port, prev_c, fcap, &cur, args))
- continue;
+ last_c = format_directive(port, last_c, fcap, &cur, args);
+ continue;
}
#endif /* SCM_USE_SRFI28 */
SCM_ASSERT(scm_false);
} else {
scm_port_put_char(port, c);
+ last_c = c;
}
}
Modified: branches/r5rs/sigscheme/test/test-srfi28.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi28.scm 2006-03-12 15:51:30 UTC (rev 3165)
+++ branches/r5rs/sigscheme/test/test-srfi28.scm 2006-03-18 06:38:03 UTC (rev 3166)
@@ -30,10 +30,10 @@
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; All tests in this file are passed against r3166 (new repository)
+
(load "./test/unittest.scm")
-;;(set! *test-track-progress* #t)
-
(use srfi-28)
(define tn test-name)
@@ -42,8 +42,8 @@
(assert-error (tn) (lambda () (format)))
(assert-error (tn) (lambda () (format #f)))
(assert-error (tn) (lambda () (format #\a)))
-;; FIXME: assertion failed
-;;(assert-error (tn) (lambda () (format "~")))
+(assert-error (tn) (lambda () (format "~")))
+(assert-error (tn) (lambda () (format "a" "a")))
(tn "format unknown directives")
(assert-error (tn) (lambda () (format "~z")))
@@ -84,6 +84,7 @@
(tn "format ~a")
(assert-error (tn) (lambda () (format "~a")))
(assert-error (tn) (lambda () (format "~a" 0 1)))
+(assert-error (tn) (lambda () (format "~1a" 1)))
(assert-equal? (tn)
(if (and (provided? "sigscheme")
(provided? "siod-bugs"))
@@ -109,6 +110,7 @@
(tn "format ~A")
(assert-error (tn) (lambda () (format "~A")))
(assert-error (tn) (lambda () (format "~A" 0 1)))
+(assert-error (tn) (lambda () (format "~1A" 1)))
(assert-equal? (tn)
(if (and (provided? "sigscheme")
(provided? "siod-bugs"))
@@ -134,6 +136,7 @@
(tn "format ~s")
(assert-error (tn) (lambda () (format "~s")))
(assert-error (tn) (lambda () (format "~s" 0 1)))
+(assert-error (tn) (lambda () (format "~1s" 1)))
(assert-equal? (tn)
(if (and (provided? "sigscheme")
(provided? "siod-bugs"))
@@ -159,6 +162,7 @@
(tn "format ~S")
(assert-error (tn) (lambda () (format "~S")))
(assert-error (tn) (lambda () (format "~S" 0 1)))
+(assert-error (tn) (lambda () (format "~1S" 1)))
(assert-equal? (tn)
(if (and (provided? "sigscheme")
(provided? "siod-bugs"))
Added: branches/r5rs/sigscheme/test/test-srfi48.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi48.scm 2006-03-12 15:51:30 UTC (rev 3165)
+++ branches/r5rs/sigscheme/test/test-srfi48.scm 2006-03-18 06:38:03 UTC (rev 3166)
@@ -0,0 +1,649 @@
+#! /usr/bin/env sscm -C UTF-8
+
+;; FileName : test-srfi48.scm
+;; About : unit test for SRFI-48
+;;
+;; Copyright (C) 2006 YamaKen <yamaken AT bp.iij4u.or.jp>
+;;
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(load "./test/unittest.scm")
+
+(use srfi-6)
+(use srfi-38)
+(use srfi-48)
+
+;; test SRFI-28 compatible part of SRFI-48
+(load "./test/test-srfi28.scm")
+(newline)
+
+(define tn test-name)
+
+(define cl (list 0 1))
+(set-cdr! (cdr cl) cl)
+
+(tn "SRFI-48 format invalid form")
+(assert-error (tn) (lambda () (format 0 "~~")))
+(assert-error (tn) (lambda () (format #\a "~~")))
+(assert-error (tn) (lambda () (format "a" "~~")))
+(assert-error (tn) (lambda () (format '(0 1) "~~")))
+(assert-error (tn) (lambda () (format '#(0 1) "~~")))
+(assert-error (tn) (lambda () (format 0 "~s" 0)))
+(assert-error (tn) (lambda () (format #\a "~s" #\a)))
+(assert-error (tn) (lambda () (format "a" "~s" "aBc")))
+(assert-error (tn) (lambda () (format '(0 1) "~s" '(0 1))))
+(assert-error (tn) (lambda () (format '#(0 1) "~s" '#(0 1))))
+
+(tn "SRFI-48 format explicit port")
+(assert-equal? (tn)
+ "\"aBc\""
+ (format #f "~s" "aBc"))
+(display "expected output: \"aBc\"")
+(newline)
+(display "actual output: ")
+(assert-equal? (tn)
+ (undef)
+ (format #t "~s" "aBc"))
+(newline)
+(let ((port (open-output-string)))
+ (assert-equal? (tn)
+ (undef)
+ (format port "~s" "aBc"))
+ (assert-equal? (tn)
+ "\"aBc\""
+ (get-output-string port)))
+
+(tn "format ~w")
+(assert-error (tn) (lambda () (format "~w")))
+(assert-error (tn) (lambda () (format "~w" 0 1)))
+(assert-error (tn) (lambda () (format "~1w" 1)))
+(assert-equal? (tn)
+ (if (and (provided? "sigscheme")
+ (provided? "siod-bugs"))
+ "()"
+ "#f")
+ (format "~w" #f))
+(assert-equal? (tn)
+ "#t"
+ (format "~w" #t))
+(assert-equal? (tn)
+ "123"
+ (format "~w" 123))
+(assert-equal? (tn)
+ "#\\a"
+ (format "~w" #\a))
+(assert-equal? (tn)
+ "\"\""
+ (format "~w" ""))
+(assert-equal? (tn)
+ "\"\\\"\""
+ (format "~w" "\""))
+(assert-equal? (tn)
+ "\"aBc\""
+ (format "~w" "aBc"))
+(assert-equal? (tn)
+ "(#t 123 #\\a \"aBc\" (0))"
+ (format "~w" '(#t 123 #\a "aBc" (0))))
+(assert-equal? (tn)
+ "#(#t 123 #\\a \"aBc\" (0))"
+ (format "~w" '#(#t 123 #\a "aBc" (0))))
+(assert-equal? (tn)
+ (if (provided? "sigscheme")
+ "#1=(0 1 . #1#)" ;; SigScheme starts the index with 1
+ "#0=(0 1 . #0#)")
+ (format "~w" cl))
+(assert-equal? (tn)
+ "#t"
+ (format "~W" #t))
+
+(tn "format ~d")
+(assert-error (tn) (lambda () (format "~d")))
+(assert-error (tn) (lambda () (format "~d" 0 1)))
+(assert-error (tn) (lambda () (format "~d" #t)))
+(assert-error (tn) (lambda () (format "~d" #\a)))
+(assert-error (tn) (lambda () (format "~d" "aBc")))
+(assert-error (tn) (lambda () (format "~d" '(0 1))))
+(assert-error (tn) (lambda () (format "~d" '#(0 1))))
+(assert-error (tn) (lambda () (format "~1d" 1)))
+(assert-equal? (tn) "-100" (format "~d" -100))
+(assert-equal? (tn) "-10" (format "~d" -10))
+(assert-equal? (tn) "-1" (format "~d" -1))
+(assert-equal? (tn) "0" (format "~d" 0))
+(assert-equal? (tn) "1" (format "~d" 1))
+(assert-equal? (tn) "10" (format "~d" 10))
+(assert-equal? (tn) "100" (format "~d" 100))
+(assert-equal? (tn) "10" (format "~D" 10))
+
+(tn "format ~x")
+(assert-error (tn) (lambda () (format "~x")))
+(assert-error (tn) (lambda () (format "~x" 0 1)))
+(assert-error (tn) (lambda () (format "~x" #t)))
+(assert-error (tn) (lambda () (format "~x" #\a)))
+(assert-error (tn) (lambda () (format "~x" "aBc")))
+(assert-error (tn) (lambda () (format "~x" '(0 1))))
+(assert-error (tn) (lambda () (format "~x" '#(0 1))))
+(assert-error (tn) (lambda () (format "~1x" 1)))
+(assert-equal? (tn) "-64" (format "~x" -100))
+(assert-equal? (tn) "-a" (format "~x" -10))
+(assert-equal? (tn) "-1" (format "~x" -1))
+(assert-equal? (tn) "0" (format "~x" 0))
+(assert-equal? (tn) "1" (format "~x" 1))
+(assert-equal? (tn) "a" (format "~x" 10))
+(assert-equal? (tn) "64" (format "~x" 100))
+(assert-equal? (tn) "a" (format "~X" 10))
+
+(tn "format ~o")
+(assert-error (tn) (lambda () (format "~o")))
+(assert-error (tn) (lambda () (format "~o" 0 1)))
+(assert-error (tn) (lambda () (format "~o" #t)))
+(assert-error (tn) (lambda () (format "~o" #\a)))
+(assert-error (tn) (lambda () (format "~o" "aBc")))
+(assert-error (tn) (lambda () (format "~o" '(0 1))))
+(assert-error (tn) (lambda () (format "~o" '#(0 1))))
+(assert-error (tn) (lambda () (format "~1o" 1)))
+(assert-equal? (tn) "-144" (format "~o" -100))
+(assert-equal? (tn) "-12" (format "~o" -10))
+(assert-equal? (tn) "-1" (format "~o" -1))
+(assert-equal? (tn) "0" (format "~o" 0))
+(assert-equal? (tn) "1" (format "~o" 1))
+(assert-equal? (tn) "12" (format "~o" 10))
+(assert-equal? (tn) "144" (format "~o" 100))
+(assert-equal? (tn) "12" (format "~O" 10))
+
+(tn "format ~b")
+(assert-error (tn) (lambda () (format "~b")))
+(assert-error (tn) (lambda () (format "~b" 0 1)))
+(assert-error (tn) (lambda () (format "~b" #t)))
+(assert-error (tn) (lambda () (format "~b" #\a)))
+(assert-error (tn) (lambda () (format "~b" "aBc")))
+(assert-error (tn) (lambda () (format "~b" '(0 1))))
+(assert-error (tn) (lambda () (format "~b" '#(0 1))))
+(assert-error (tn) (lambda () (format "~1b" 1)))
+(assert-equal? (tn) "-1100100" (format "~b" -100))
+(assert-equal? (tn) "-1010" (format "~b" -10))
+(assert-equal? (tn) "-1" (format "~b" -1))
+(assert-equal? (tn) "0" (format "~b" 0))
+(assert-equal? (tn) "1" (format "~b" 1))
+(assert-equal? (tn) "1010" (format "~b" 10))
+(assert-equal? (tn) "1100100" (format "~b" 100))
+(assert-equal? (tn) "1010" (format "~B" 10))
+
+(if (and (symbol-bound? 'greatest-fixnum)
+ (symbol-bound? 'least-fixnum))
+ (let ((greatest (number->string (greatest-fixnum))))
+ (cond
+ ((string=? greatest "2147483647")
+ (tn "format 32bit fixnum")
+ (assert-equal? (tn)
+ "-2147483648"
+ (format "~d" (least-fixnum)))
+ (assert-equal? (tn)
+ "1111111111111111111111111111111"
+ (format "~b" (greatest-fixnum)))
+ (assert-equal? (tn)
+ "-10000000000000000000000000000000"
+ (format "~b" (least-fixnum)))
+ (assert-equal? (tn)
+ "-1111111111111111111111111111111"
+ (format "~b" (+ (least-fixnum) 1))))
+
+ ((string=? greatest "9223372036854775807")
+ (tn "format 64bit fixnum")
+ (assert-equal? (tn)
+ "-9223372036854775808"
+ (format "~d" (least-fixnum)))
+ (assert-equal? (tn)
+ "111111111111111111111111111111111111111111111111111111111111111"
+ (format "~b" (greatest-fixnum)))
+ (assert-equal? (tn)
+ "-1000000000000000000000000000000000000000000000000000000000000000"
+ (format "~b" (least-fixnum)))
+ (assert-equal? (tn)
+ "-111111111111111111111111111111111111111111111111111111111111111"
+ (format "~b" (+ (least-fixnum) 1))))
+
+ (else
+ (error "unknown int bitwidth")))))
+
+(tn "format ~c")
+(assert-error (tn) (lambda () (format "~c")))
+(assert-error (tn) (lambda () (format "~c" #\a #\b)))
+(assert-error (tn) (lambda () (format "~c" #t)))
+(assert-error (tn) (lambda () (format "~c" 0)))
+(assert-error (tn) (lambda () (format "~c" "aBc")))
+(assert-error (tn) (lambda () (format "~c" '(#\a #\b))))
+(assert-error (tn) (lambda () (format "~c" '#(#\a #\b))))
+(assert-error (tn) (lambda () (format "~1c" #\a)))
+(assert-equal? (tn) "a" (format "~c" #\a))
+(assert-equal? (tn) "\"" (format "~c" #\"))
+(assert-equal? (tn) "あ" (format "~c" #\あ))
+
+;; FIXME: prefixed format
+(tn "format ~f (number)")
+(assert-error (tn) (lambda () (format "~f")))
+(assert-error (tn) (lambda () (format "~f" 0 1)))
+(assert-error (tn) (lambda () (format "~f" #t)))
+(assert-error (tn) (lambda () (format "~f" #\a)))
+(assert-error (tn) (lambda () (format "~f" '(0 1))))
+(assert-error (tn) (lambda () (format "~f" '#(0 1))))
+(assert-error (tn) (lambda () (format "0100f" 1)))
+(assert-error (tn) (lambda () (format "0100,1f" 1)))
+(assert-error (tn) (lambda () (format "1,0100f" 1)))
+(assert-error (tn) (lambda () (format "~-1f" 1)))
+(assert-error (tn) (lambda () (format "~-0f" 1)))
+(assert-error (tn) (lambda () (format "~0,-0f" 1)))
+(assert-error (tn) (lambda () (format "~0,-1f" 1)))
+(assert-error (tn) (lambda () (format "~1,-0f" 1)))
+(assert-error (tn) (lambda () (format "~1,-1f" 1)))
+(assert-error (tn) (lambda () (format "~-0,0f" 1)))
+(assert-error (tn) (lambda () (format "~-0,1f" 1)))
+(assert-error (tn) (lambda () (format "~-1,0f" 1)))
+(assert-error (tn) (lambda () (format "~-1,1f" 1)))
+(assert-error (tn) (lambda () (format "~-0,-0f" 1)))
+(assert-error (tn) (lambda () (format "~-0,-1f" 1)))
+(assert-error (tn) (lambda () (format "~-1,-0f" 1)))
+(assert-error (tn) (lambda () (format "~-1,-1f" 1)))
+(assert-equal? (tn) "-100" (format "~f" -100))
+(assert-equal? (tn) "-10" (format "~f" -10))
+(assert-equal? (tn) "-1" (format "~f" -1))
+(assert-equal? (tn) "0" (format "~f" 0))
+(assert-equal? (tn) "1" (format "~f" 1))
+(assert-equal? (tn) "10" (format "~f" 10))
+(assert-equal? (tn) "100" (format "~f" 100))
+
+(assert-equal? (tn) "-100" (format "~0f" -100))
+(assert-equal? (tn) "-10" (format "~0f" -10))
+(assert-equal? (tn) "-1" (format "~0f" -1))
+(assert-equal? (tn) "0" (format "~0f" 0))
+(assert-equal? (tn) "1" (format "~0f" 1))
+(assert-equal? (tn) "10" (format "~0f" 10))
+(assert-equal? (tn) "100" (format "~0f" 100))
+
+(assert-equal? (tn) "-100" (format "~1f" -100))
+(assert-equal? (tn) "-10" (format "~1f" -10))
+(assert-equal? (tn) "-1" (format "~1f" -1))
+(assert-equal? (tn) "0" (format "~1f" 0))
+(assert-equal? (tn) "1" (format "~1f" 1))
+(assert-equal? (tn) "10" (format "~1f" 10))
+(assert-equal? (tn) "100" (format "~1f" 100))
+
+(assert-equal? (tn) "-100" (format "~2f" -100))
+(assert-equal? (tn) "-10" (format "~2f" -10))
+(assert-equal? (tn) "-1" (format "~2f" -1))
+(assert-equal? (tn) " 0" (format "~2f" 0))
+(assert-equal? (tn) " 1" (format "~2f" 1))
+(assert-equal? (tn) "10" (format "~2f" 10))
+(assert-equal? (tn) "100" (format "~2f" 100))
+
+(assert-equal? (tn) "-100" (format "~3f" -100))
+(assert-equal? (tn) "-10" (format "~3f" -10))
+(assert-equal? (tn) " -1" (format "~3f" -1))
+(assert-equal? (tn) " 0" (format "~3f" 0))
+(assert-equal? (tn) " 1" (format "~3f" 1))
+(assert-equal? (tn) " 10" (format "~3f" 10))
+(assert-equal? (tn) "100" (format "~3f" 100))
+
+(assert-equal? (tn) "-100" (format "~4f" -100))
+(assert-equal? (tn) " -10" (format "~4f" -10))
+(assert-equal? (tn) " -1" (format "~4f" -1))
+(assert-equal? (tn) " 0" (format "~4f" 0))
+(assert-equal? (tn) " 1" (format "~4f" 1))
+(assert-equal? (tn) " 10" (format "~4f" 10))
+(assert-equal? (tn) " 100" (format "~4f" 100))
+
+(assert-equal? (tn) " -100" (format "~5f" -100))
+(assert-equal? (tn) " -10" (format "~5f" -10))
+(assert-equal? (tn) " -1" (format "~5f" -1))
+(assert-equal? (tn) " 0" (format "~5f" 0))
+(assert-equal? (tn) " 1" (format "~5f" 1))
+(assert-equal? (tn) " 10" (format "~5f" 10))
+(assert-equal? (tn) " 100" (format "~5f" 100))
+
+(assert-equal? (tn) " -100" (format "~05f" -100))
+(assert-equal? (tn) " -10" (format "~05f" -10))
+(assert-equal? (tn) " -1" (format "~05f" -1))
+(assert-equal? (tn) " 0" (format "~05f" 0))
+(assert-equal? (tn) " 1" (format "~05f" 1))
+(assert-equal? (tn) " 10" (format "~05f" 10))
+(assert-equal? (tn) " 100" (format "~05f" 100))
+
+(if (symbol-bound? 'exact->inexact)
+ (begin
+ (assert-equal? (tn) "-100.0" (format "~5,0f" -100))
+ (assert-equal? (tn) "-10.0" (format "~5,0f" -10))
+ (assert-equal? (tn) " -1.0" (format "~5,0f" -1))
+ (assert-equal? (tn) " 0.0" (format "~5,0f" 0))
+ (assert-equal? (tn) " 1.0" (format "~5,0f" 1))
+ (assert-equal? (tn) " 10.0" (format "~5,0f" 10))
+ (assert-equal? (tn) "100.0" (format "~5,0f" 100))
+
+ (assert-equal? (tn) "-100.0" (format "~5,1f" -100))
+ (assert-equal? (tn) "-10.0" (format "~5,1f" -10))
+ (assert-equal? (tn) " -1.0" (format "~5,1f" -1))
+ (assert-equal? (tn) " 0.0" (format "~5,1f" 0))
+ (assert-equal? (tn) " 1.0" (format "~5,1f" 1))
+ (assert-equal? (tn) " 10.0" (format "~5,1f" 10))
+ (assert-equal? (tn) "100.0" (format "~5,1f" 100))
+
+ (assert-equal? (tn) "-100.00" (format "~5,2f" -100))
+ (assert-equal? (tn) "-10.00" (format "~5,2f" -10))
+ (assert-equal? (tn) "-1.00" (format "~5,2f" -1))
+ (assert-equal? (tn) " 0.00" (format "~5,2f" 0))
+ (assert-equal? (tn) " 1.00" (format "~5,2f" 1))
+ (assert-equal? (tn) "10.00" (format "~5,2f" 10))
+ (assert-equal? (tn) "100.00" (format "~5,2f" 100))
+
+ (assert-equal? (tn) "-100.00" (format "~05,02f" -100))
+ (assert-equal? (tn) "-10.00" (format "~05,02f" -10))
+ (assert-equal? (tn) "-1.00" (format "~05,02f" -1))
+ (assert-equal? (tn) " 0.00" (format "~05,02f" 0))
+ (assert-equal? (tn) " 1.00" (format "~05,02f" 1))
+ (assert-equal? (tn) "10.00" (format "~05,02f" 10))
+ (assert-equal? (tn) "100.00" (format "~05,02f" 100))
+
+ (assert-equal? (tn) "100.0" (format "~5,1F" 100))))
+
+(assert-equal? (tn) "10" (format "~F" 10))
+(assert-equal? (tn) " 100" (format "~5F" 100))
+
+;; FIXME: prefixed format
+(tn "format ~f (string)")
+(assert-error (tn) (lambda () (format "~f" "a" "b")))
+(assert-error (tn) (lambda () (format "~f" '("a" "b"))))
+(assert-error (tn) (lambda () (format "~f" '#("a" "b"))))
+(assert-error (tn) (lambda () (format "0100f" "a")))
+(assert-error (tn) (lambda () (format "0100,1f" "a")))
+(assert-error (tn) (lambda () (format "1,0100f" "a")))
+(assert-error (tn) (lambda () (format "~-1f" "a")))
+(assert-error (tn) (lambda () (format "~-0f" "a")))
+(assert-error (tn) (lambda () (format "~0,-0f" "a")))
+(assert-error (tn) (lambda () (format "~0,-1f" "a")))
+(assert-error (tn) (lambda () (format "~1,-0f" "a")))
+(assert-error (tn) (lambda () (format "~1,-1f" "a")))
+(assert-error (tn) (lambda () (format "~-0,0f" "a")))
+(assert-error (tn) (lambda () (format "~-0,1f" "a")))
+(assert-error (tn) (lambda () (format "~-1,0f" "a")))
+(assert-error (tn) (lambda () (format "~-1,1f" "a")))
+(assert-error (tn) (lambda () (format "~-0,-0f" "a")))
+(assert-error (tn) (lambda () (format "~-0,-1f" "a")))
+(assert-error (tn) (lambda () (format "~-1,-0f" "a")))
+(assert-error (tn) (lambda () (format "~-1,-1f" "a")))
+(assert-equal? (tn) "" (format "~f" ""))
+(assert-equal? (tn) "\"" (format "~f" "\""))
+(assert-equal? (tn) "aBc" (format "~f" "aBc"))
+(assert-equal? (tn) "あbう" (format "~f" "あbう"))
+
+(assert-equal? (tn) "" (format "~0f" ""))
+(assert-equal? (tn) "\"" (format "~0f" "\""))
+(assert-equal? (tn) "aBc" (format "~0f" "aBc"))
+(assert-equal? (tn) "あbう" (format "~0f" "あbう"))
+
+(assert-equal? (tn) " " (format "~1f" ""))
+(assert-equal? (tn) "\"" (format "~1f" "\""))
+(assert-equal? (tn) "aBc" (format "~1f" "aBc"))
+(assert-equal? (tn) "あbう" (format "~1f" "あbう"))
+
+(assert-equal? (tn) " " (format "~2f" ""))
+(assert-equal? (tn) " \"" (format "~2f" "\""))
+(assert-equal? (tn) "aBc" (format "~2f" "aBc"))
+(assert-equal? (tn) "あbう" (format "~2f" "あbう"))
+
+(assert-equal? (tn) " " (format "~3f" ""))
+(assert-equal? (tn) " \"" (format "~3f" "\""))
+(assert-equal? (tn) "aBc" (format "~3f" "aBc"))
+(assert-equal? (tn) "あbう" (format "~3f" "あbう"))
+
+(assert-equal? (tn) " " (format "~4f" ""))
+(assert-equal? (tn) " \"" (format "~4f" "\""))
+(assert-equal? (tn) " aBc" (format "~4f" "aBc"))
+(assert-equal? (tn) " あbう" (format "~4f" "あbう"))
+
+(assert-equal? (tn) " " (format "~5f" ""))
+(assert-equal? (tn) " \"" (format "~5f" "\""))
+(assert-equal? (tn) " aBc" (format "~5f" "aBc"))
+(assert-equal? (tn) " あbう" (format "~5f" "あbう"))
+
+(assert-equal? (tn) " " (format "~05f" ""))
+(assert-equal? (tn) " \"" (format "~05f" "\""))
+(assert-equal? (tn) " aBc" (format "~05f" "aBc"))
+(assert-equal? (tn) " あbう" (format "~05f" "あbう"))
+
+(assert-equal? (tn) " " (format "~5,2f" ""))
+(assert-equal? (tn) " \"" (format "~5,2f" "\""))
+(assert-equal? (tn) " aBc" (format "~5,2f" "aBc"))
+(assert-equal? (tn) " あbう" (format "~5,2f" "あbう"))
+
+(assert-equal? (tn) " " (format "~05,02f" ""))
+(assert-equal? (tn) " \"" (format "~05,02f" "\""))
+(assert-equal? (tn) " aBc" (format "~05,02f" "aBc"))
+(assert-equal? (tn) " あbう" (format "~05,02f" "あbう"))
+
+(assert-equal? (tn) "aBc" (format "~F" "aBc"))
+(assert-equal? (tn) " aBc" (format "~5F" "aBc"))
+(assert-equal? (tn) " aBc" (format "~05F" "aBc"))
+(assert-equal? (tn) " aBc" (format "~5,2F" "aBc"))
+
+(tn "format ~?")
+(assert-error (tn) (lambda () (format "~?")))
+(assert-error (tn) (lambda () (format "~?" "~~")))
+(assert-error (tn) (lambda () (format "~?" "a")))
+(assert-error (tn) (lambda () (format "~?" "a" '() "b")))
+(assert-error (tn) (lambda () (format "~1?" "a" '())))
+(assert-error (tn) (lambda () (format "~?" "~a" '())))
+(assert-error (tn) (lambda () (format "~?" "~a" '(0 1))))
+(assert-error (tn) (lambda () (format "~?" "~?" '("~a"))))
+(assert-error (tn) (lambda () (format "~?" "~?" '("~a" (0 1)))))
+(assert-error (tn) (lambda () (format "~?" #t '())))
+(assert-error (tn) (lambda () (format "~?" 0 '())))
+(assert-error (tn) (lambda () (format "~?" #\a '())))
+(assert-error (tn) (lambda () (format "~?" '(0 1) '())))
+(assert-error (tn) (lambda () (format "~?" '#(0 1) '())))
+(assert-equal? (tn) "~" (format "~?" "~~" '()))
+(assert-equal? (tn) " " (format "~?" "~_" '()))
+(assert-equal? (tn) "\n" (format "~?" "~%" '()))
+(assert-equal? (tn) "\n" (format "~?" "~&" '()))
+;; hard to be this on current port implementation
+;;(assert-equal? (tn) "\n" (format "~?" "~%~?" '("~&" ())))
+(assert-equal? (tn) "\n\n" (format "~?" "~%~?" '("~&" ())))
+(assert-equal? (tn) "\n \n" (format "~?" "~% ~?" '("~&" ())))
+(assert-equal? (tn) "\n \n" (format "~?" "~%~?" '(" ~&" ())))
+(assert-equal? (tn) "aBc" (format "~?" "aBc" '()))
+(assert-equal? (tn) "0aBc1" (format "~?" "0~a1" '("aBc")))
+(assert-equal? (tn) "02aBc31" (format "~?" "0~?1" '("2~a3" ("aBc"))))
+(assert-equal? (tn) "024aBc531"
+ (format "~?" "0~?1" '("2~?3" ("4~a5" ("aBc")))))
+(assert-equal? (tn)
+ (if (and (provided? "sigscheme")
+ (provided? "siod-bugs"))
+ "()"
+ "#f")
+ (format "~?" "~w" '(#f)))
+(assert-equal? (tn)
+ "#t"
+ (format "~?" "~w" '(#t)))
+(assert-equal? (tn)
+ "123"
+ (format "~?" "~w" '(123)))
+(assert-equal? (tn)
+ "#\\a"
+ (format "~?" "~w" '(#\a)))
+(assert-equal? (tn)
+ "\"\""
+ (format "~?" "~w" '("")))
+(assert-equal? (tn)
+ "\"\\\"\""
+ (format "~?" "~w" '("\"")))
+(assert-equal? (tn)
+ "\"aBc\""
+ (format "~?" "~w" '("aBc")))
+(assert-equal? (tn)
+ "(#t 123 #\\a \"aBc\" (0))"
+ (format "~?" "~w" '((#t 123 #\a "aBc" (0)))))
+(assert-equal? (tn)
+ "#(#t 123 #\\a \"aBc\" (0))"
+ (format "~?" "~w" '(#(#t 123 #\a "aBc" (0)))))
+(assert-equal? (tn)
+ (if (provided? "sigscheme")
+ "#1=(0 1 . #1#)" ;; SigScheme starts the index with 1
+ "#0=(0 1 . #0#)")
+ (format "~?" "~w" (list cl)))
+
+;; alias of ~?
+(tn "format ~k")
+(assert-error (tn) (lambda () (format "~k")))
+(assert-error (tn) (lambda () (format "~k" "~~")))
+(assert-error (tn) (lambda () (format "~k" "a")))
+(assert-error (tn) (lambda () (format "~k" "a" '() "b")))
+(assert-error (tn) (lambda () (format "~1k" "a" '())))
+(assert-error (tn) (lambda () (format "~k" "~a" '())))
+(assert-error (tn) (lambda () (format "~k" "~a" '(0 1))))
+(assert-error (tn) (lambda () (format "~k" "~k" '("~a"))))
+(assert-error (tn) (lambda () (format "~k" "~k" '("~a" (0 1)))))
+(assert-error (tn) (lambda () (format "~k" #t '())))
+(assert-error (tn) (lambda () (format "~k" 0 '())))
+(assert-error (tn) (lambda () (format "~k" #\a '())))
+(assert-error (tn) (lambda () (format "~k" '(0 1) '())))
+(assert-error (tn) (lambda () (format "~k" '#(0 1) '())))
+(assert-equal? (tn) "~" (format "~k" "~~" '()))
+(assert-equal? (tn) "02aBc31" (format "~k" "0~k1" '("2~a3" ("aBc"))))
+(assert-error (tn) (lambda () (format "~K")))
+(assert-error (tn) (lambda () (format "~K" "~~")))
+(assert-error (tn) (lambda () (format "~K" "a")))
+(assert-error (tn) (lambda () (format "~K" "a" '() "b")))
+(assert-error (tn) (lambda () (format "~1K" "a" '())))
+(assert-error (tn) (lambda () (format "~K" "~a" '())))
+(assert-error (tn) (lambda () (format "~K" "~a" '(0 1))))
+(assert-error (tn) (lambda () (format "~K" "~K" '("~a"))))
+(assert-error (tn) (lambda () (format "~K" "~K" '("~a" (0 1)))))
+(assert-error (tn) (lambda () (format "~K" #t '())))
+(assert-error (tn) (lambda () (format "~K" 0 '())))
+(assert-error (tn) (lambda () (format "~K" #\a '())))
+(assert-error (tn) (lambda () (format "~K" '(0 1) '())))
+(assert-error (tn) (lambda () (format "~K" '#(0 1) '())))
+(assert-equal? (tn) "~" (format "~K" "~~" '()))
+(assert-equal? (tn) "02aBc31" (format "~K" "0~K1" '("2~a3" ("aBc"))))
+
+(tn "format ~y")
+(assert-error (tn) (lambda () (format "~y")))
+(assert-error (tn) (lambda () (format "~y" 0 1)))
+(assert-error (tn) (lambda () (format "~1y" 1)))
+(assert-equal? (tn)
+ (if (and (provided? "sigscheme")
+ (provided? "siod-bugs"))
+ "()"
+ "#f")
+ (format "~y" #f))
+(assert-equal? (tn)
+ "#t"
+ (format "~y" #t))
+(assert-equal? (tn)
+ "123"
+ (format "~y" 123))
+(assert-equal? (tn)
+ "#\\a"
+ (format "~y" #\a))
+(assert-equal? (tn)
+ "\"\""
+ (format "~y" ""))
+(assert-equal? (tn)
+ "\"\\\"\""
+ (format "~y" "\""))
+(assert-equal? (tn)
+ "\"aBc\""
+ (format "~y" "aBc"))
+;; no pretty-print procedure
+(assert-equal? (tn)
+ "(#t 123 #\\a \"aBc\" (0))"
+ (format "~y" '(#t 123 #\a "aBc" (0))))
+(assert-equal? (tn)
+ "#(#t 123 #\\a \"aBc\" (0))"
+ (format "~y" '#(#t 123 #\a "aBc" (0))))
+
+(tn "format ~t")
+(assert-error (tn) (lambda () (format "~t" #t)))
+(assert-error (tn) (lambda () (format "~t" 0)))
+(assert-error (tn) (lambda () (format "~t" #\a)))
+(assert-error (tn) (lambda () (format "~t" "aBc")))
+(assert-error (tn) (lambda () (format "~t" '(0 1))))
+(assert-error (tn) (lambda () (format "~t" '#(0 1))))
+(assert-error (tn) (lambda () (format "~1t")))
+(assert-equal? (tn) " " (format "~t"))
+(assert-equal? (tn) "\t" (format "~t"))
+(assert-equal? (tn) "\t" (format "~T"))
+
+(tn "format ~_")
+(assert-error (tn) (lambda () (format "~_" #t)))
+(assert-error (tn) (lambda () (format "~_" 0)))
+(assert-error (tn) (lambda () (format "~_" #\a)))
+(assert-error (tn) (lambda () (format "~_" "aBc")))
+(assert-error (tn) (lambda () (format "~_" '(0 1))))
+(assert-error (tn) (lambda () (format "~_" '#(0 1))))
+(assert-error (tn) (lambda () (format "~1_")))
+(assert-equal? (tn) " " (format "~_"))
+
+;; FIXME: failed
+(tn "format ~&")
+(assert-error (tn) (lambda () (format "~&" #t)))
+(assert-error (tn) (lambda () (format "~&" 0)))
+(assert-error (tn) (lambda () (format "~&" #\a)))
+(assert-error (tn) (lambda () (format "~&" "aBc")))
+(assert-error (tn) (lambda () (format "~&" '(0 1))))
+(assert-error (tn) (lambda () (format "~&" '#(0 1))))
+(assert-error (tn) (lambda () (format "~1&")))
+(assert-equal? (tn) "
+" (format "~&"))
+(assert-equal? (tn) "\n" (format "~&"))
+(assert-equal? (tn) "\n" (format "~&~&"))
+(assert-equal? (tn) "\n" (format "~&~&~&"))
+(assert-equal? (tn) "\n" (format "~%~&"))
+(assert-equal? (tn) "\n" (format "~%~&~&"))
+(assert-equal? (tn) "\n\n" (format "~&~%"))
+(assert-equal? (tn) "\n\n" (format "~&~%~&"))
+(assert-equal? (tn) "\n" (format "\n~&"))
+(assert-equal? (tn) "\n\n" (format "~&\n"))
+(assert-equal? (tn) "\n\n" (format "~&\n~&"))
+(assert-equal? (tn) " \n" (format " ~&"))
+(assert-equal? (tn) "\n \n \n" (format "\n ~& ~&"))
+
+(tn "format ~h")
+(define help-str
+"
+
+
+")
+(assert-error (tn) (lambda () (format "~h" #t)))
+(assert-error (tn) (lambda () (format "~h" 0)))
+(assert-error (tn) (lambda () (format "~h" #\a)))
+(assert-error (tn) (lambda () (format "~h" "aBc")))
+(assert-error (tn) (lambda () (format "~h" '(0 1))))
+(assert-error (tn) (lambda () (format "~h" '#(0 1))))
+(assert-error (tn) (lambda () (format "~1h")))
+(assert-equal? (tn) help-str (format "~h"))
+(assert-equal? (tn) help-str (format "~H"))
+
+(total-report)
More information about the uim-commit
mailing list