1 /*===========================================================================
2 * Filename : format.c
3 * About : Format strings
4 *
5 * Copyright (C) 2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
6 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
7 *
8 * All rights reserved.
9 *
10 * Redistribution and use in source and binary forms, with or without
11 * modification, are permitted provided that the following conditions
12 * are met:
13 *
14 * 1. Redistributions of source code must retain the above copyright
15 * notice, this list of conditions and the following disclaimer.
16 * 2. Redistributions in binary form must reproduce the above copyright
17 * notice, this list of conditions and the following disclaimer in the
18 * documentation and/or other materials provided with the distribution.
19 * 3. Neither the name of authors nor the names of its contributors
20 * may be used to endorse or promote products derived from this software
21 * without specific prior written permission.
22 *
23 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
24 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
25 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
27 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
30 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
31 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
32 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
33 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34 ===========================================================================*/
35
36 /* The help strings (MSG_SRFI48_DIRECTIVE_HELP and MSG_SSCM_DIRECTIVE_HELP) are
37 * derived from the reference implementation of SRFI-48. Here is the copyright
38 * for the strings. No other part is covered by this copyright.
39 * -- 2006-03-18 YamaKen */
40 /*
41 * Copyright (C) Kenneth A Dickey (2003). All Rights Reserved.
42 *
43 * Permission is hereby granted, free of charge, to any person obtaining a copy
44 * of this software and associated documentation files (the "Software"), to
45 * deal in the Software without restriction, including without limitation the
46 * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
47 * sell copies of the Software, and to permit persons to whom the Software is
48 * furnished to do so, subject to the following conditions:
49 *
50 * The above copyright notice and this permission notice shall be included in
51 * all copies or substantial portions of the Software.
52 *
53 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
54 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
55 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
56 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
57 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
58 * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
59 * IN THE SOFTWARE.
60 */
61
62 #include <config.h>
63
64 #include <stddef.h>
65 #include <stdlib.h>
66 #include <stdarg.h>
67 #include <string.h>
68
69 #include "sigscheme.h"
70 #include "sigschemeinternal.h"
71 #if SCM_USE_MULTIBYTE_CHAR
72 #include "encoding.h"
73 #else
74 #include "encoding-dummy.h"
75 #endif
76
77 /*=======================================
78 File Local Macro Definitions
79 =======================================*/
80 #define ERRMSG_INVALID_ESCSEQ "invalid escape sequence"
81
82 #define MSG_SRFI48_DIRECTIVE_HELP \
83 "(format [<port>] <format-string> [<arg>...])\n" \
84 " - <port> is #t, #f or an output-port\n" \
85 " - any escape sequence is case insensitive\n" \
86 "\n" \
87 "SEQ MNEMONIC DESCRIPTION\n" \
88 "~H [Help] output this text\n" \
89 "~A [Any] (display arg) for humans\n" \
90 "~S [Slashified] (write arg) for parsers\n" \
91 "~W [WriteCircular] like ~s but outputs with write/ss\n" \
92 "~~ [Tilde] output a tilde\n" \
93 "~T [Tab] output a tab character\n" \
94 "~% [Newline] output a newline character\n" \
95 "~& [Freshline] output a newline if the previous output was not a newline\n" \
96 "~D [Decimal] the arg is a number which is output in decimal radix\n" \
97 "~X [heXadecimal] the arg is a number which is output in hexdecimal radix\n" \
98 "~O [Octal] the arg is a number which is output in octal radix\n" \
99 "~B [Binary] the arg is a number which is output in binary radix\n" \
100 "~F\n" \
101 "~wF [Fixed] the arg is a string or number which has width w and\n" \
102 "~w,dF d digits after the decimal\n" \
103 "~C [Character] character arg is output by write-char\n" \
104 "~_ [Space] a single space character is output\n" \
105 "~Y [Yuppify] the list arg is pretty-printed to the output\n" \
106 "~? [Indirection] recursive format: next 2 args are format-string and list\n" \
107 " of arguments\n" \
108 "~K [Indirection] same as ~?\n"
109
110 #if SCM_USE_SSCM_FORMAT_EXTENSION
111 #define MSG_SSCM_DIRECTIVE_HELP \
112 "(format+ [<port>] <format-string> [<arg>...])\n" \
113 " - <port> is #t, #f or an output-port\n" \
114 " - any escape sequence is case insensitive\n" \
115 "\n" \
116 " The format+ procedure is a SigScheme-specific superset of SRFI-48.\n" \
117 " Following directives accept optional width w and d digits after the decimal,\n" \
118 " and w accepts leading zero as zero-digit-padding specifier. All other rules\n" \
119 " are same as SRFI-48. See also the help message for SRFI-48.\n" \
120 "\n" \
121 "SEQ MNEMONIC DESCRIPTION\n" \
122 "~[w[,d]]D [Decimal] the arg is a number output in decimal radix\n" \
123 "~[w[,d]]X [heXadecimal] the arg is a number output in hexdecimal radix\n" \
124 "~[w[,d]]O [Octal] the arg is a number output in octal radix\n" \
125 "~[w[,d]]B [Binary] the arg is a number output in binary radix\n" \
126 "~[w[,d]]F [Fixed] the arg is a string or number\n"
127 #endif /* SCM_USE_SSCM_FORMAT_EXTENSION */
128
129 #define NEWLINE_CHAR \
130 (SCM_NEWLINE_STR[sizeof(SCM_NEWLINE_STR) - 1 - sizeof("")])
131
132 /*=======================================
133 File Local Type Definitions
134 =======================================*/
135 /* To allow non-ASCII string such as UCS2, format string is abstracted. */
136 #if SCM_USE_MULTIBYTE_CHAR
137 typedef ScmMultibyteString format_string_t;
138
139 #define FORMAT_STR_INIT(mbs_fmt, str) \
140 SCM_MBS_INIT2((mbs_fmt), (str), strlen(str))
141
142 #define FORMAT_STR_POS(mbs_fmt) (SCM_MBS_GET_STR(mbs_fmt))
143
144 #define FORMAT_STR_ENDP(mbs_fmt) (!SCM_MBS_GET_SIZE(mbs_fmt))
145
146 #define FORMAT_STR_READ(mbs_fmt) \
147 (SCM_CHARCODEC_READ_CHAR(scm_current_char_codec, (mbs_fmt)))
148
149 #define FORMAT_STR_PEEK(mbs_fmt) \
150 (format_str_peek((mbs_fmt), SCM_MANGLE(name)))
151
152 #else /* SCM_USE_MULTIBYTE_CHAR */
153
154 typedef const char *format_string_t;
155
156 #define FORMAT_STR_INIT(fmt, str) ((fmt) = (str))
157 #define FORMAT_STR_POS(fmt) (fmt)
158 #define FORMAT_STR_ENDP(fmt) (!*(fmt))
159 #define FORMAT_STR_READ(fmt) (*(fmt)++)
160 #define FORMAT_STR_PEEK(fmt) (*(fmt))
161 #endif /* SCM_USE_MULTIBYTE_CHAR */
162
163 #define FORMAT_STR_SKIP_CHAR(fmt) ((void)FORMAT_STR_READ(fmt))
164
165
166 enum scm_format_args_type {
167 ARG_VA_LIST,
168 ARG_SCM_LIST
169 };
170
171 struct scm_format_args {
172 enum scm_format_args_type type;
173 union {
174 va_list *va;
175 ScmObj *scm;
176 } lst;
177 };
178
179 #define POP_FORMAT_ARG(args) \
180 (((args).type == ARG_VA_LIST) ? va_arg(*(args).lst.va, ScmObj) \
181 : MUST_POP_ARG(*(args).lst.scm))
182
183 /*=======================================
184 Variable Definitions
185 =======================================*/
186 SCM_GLOBAL_VARS_BEGIN(static_format);
187 #define static
188 static ScmObj l_sym_pretty_print;
189 #undef static
190 SCM_GLOBAL_VARS_END(static_format);
191 #define l_sym_pretty_print SCM_GLOBAL_VAR(static_format, l_sym_pretty_print)
192 SCM_DEFINE_STATIC_VARS(static_format);
193
194 /*=======================================
195 File Local Function Declarations
196 =======================================*/
197 #if SCM_USE_MULTIBYTE_CHAR
198 static scm_ichar_t format_str_peek(ScmMultibyteString mbs_fmt,
199 const char *caller);
200 #endif
201 static signed char read_width(format_string_t *fmt);
202 static ScmValueFormat read_number_prefix(enum ScmFormatCapability fcap,
203 format_string_t *fmt);
204 static void format_int(ScmObj port,
205 ScmValueFormat vfmt, uintmax_t n, int radix);
206 #if SCM_USE_RAW_C_FORMAT
207 static scm_ichar_t format_raw_c_directive(ScmObj port,
208 format_string_t *fmt, va_list *args);
209 #endif
210 #if SCM_USE_SRFI28
211 static scm_ichar_t format_directive(ScmObj port, scm_ichar_t last_ch,
212 enum ScmFormatCapability fcap,
213 format_string_t *fmt,
214 struct scm_format_args args);
215 #endif
216 static ScmObj format_internal(ScmObj port, enum ScmFormatCapability fcap,
217 const char *fmt,
218 struct scm_format_args args);
219
220 /*=======================================
221 Function Definitions
222 =======================================*/
223 SCM_EXPORT void
scm_init_format(void)224 scm_init_format(void)
225 {
226 SCM_GLOBAL_VARS_INIT(static_format);
227
228 scm_gc_protect_with_init(&l_sym_pretty_print, scm_intern("pretty-print"));
229 }
230
231 #if SCM_USE_MULTIBYTE_CHAR
232 static scm_ichar_t
format_str_peek(ScmMultibyteString mbs_fmt,const char * caller)233 format_str_peek(ScmMultibyteString mbs_fmt, const char *caller)
234 {
235 return (FORMAT_STR_ENDP(mbs_fmt)) ? '\0' :
236 scm_charcodec_read_char(scm_current_char_codec, &mbs_fmt, caller);
237 }
238 #endif /* SCM_USE_MULTIBYTE_CHAR */
239
240 static signed char
read_width(format_string_t * fmt)241 read_width(format_string_t *fmt)
242 {
243 scm_ichar_t c;
244 scm_int_t ret;
245 scm_bool err;
246 char *bufp;
247 char buf[sizeof("0127")];
248 DECLARE_INTERNAL_FUNCTION("format");
249
250 for (bufp = buf;
251 (c = FORMAT_STR_PEEK(*fmt), ICHAR_NUMERICP(c))
252 && bufp < &buf[sizeof(buf) - 1];
253 FORMAT_STR_SKIP_CHAR(*fmt))
254 {
255 *bufp++ = c;
256 }
257 *bufp = '\0';
258 ret = scm_string2number(buf, 10, &err);
259 if (err) /* empty case */
260 ret = -1;
261
262 if (ret > 127)
263 ERR("too much column width: ~D", (int)ret);
264
265 return ret;
266 }
267
268 /* ([0-9]+(,[0-9]+)?)? */
269 static ScmValueFormat
read_number_prefix(enum ScmFormatCapability fcap,format_string_t * fmt)270 read_number_prefix(enum ScmFormatCapability fcap, format_string_t *fmt)
271 {
272 scm_ichar_t c;
273 ScmValueFormat vfmt;
274 DECLARE_INTERNAL_FUNCTION("format");
275
276 SCM_VALUE_FORMAT_INIT(vfmt);
277 c = FORMAT_STR_PEEK(*fmt);
278
279 if (c == '0' && (fcap & SCM_FMT_LEADING_ZEROS)) {
280 FORMAT_STR_SKIP_CHAR(*fmt);
281 vfmt.pad = '0';
282 vfmt.width = 0;
283 }
284 vfmt.width = read_width(fmt);
285 c = FORMAT_STR_PEEK(*fmt);
286
287 if (c == ',') {
288 if (vfmt.width < 0)
289 ERR(ERRMSG_INVALID_ESCSEQ ": ~~,");
290 FORMAT_STR_SKIP_CHAR(*fmt);
291 vfmt.frac_width = read_width(fmt);
292 if (vfmt.frac_width < 0)
293 ERR(ERRMSG_INVALID_ESCSEQ ": ~~~D,~C",
294 (int)vfmt.width, FORMAT_STR_PEEK(*fmt));
295 }
296
297 return vfmt;
298 }
299
300 static void
format_int(ScmObj port,ScmValueFormat vfmt,uintmax_t n,int radix)301 format_int(ScmObj port, ScmValueFormat vfmt, uintmax_t n, int radix)
302 {
303 char *str;
304
305 str = scm_int2string(vfmt, n, radix);
306 scm_port_puts(port, str);
307 free(str);
308 }
309
310 #if SCM_USE_RAW_C_FORMAT
311 /* returns '\0' if no valid directive handled */
312 /* ([CP]|([0-9]+(,[0-9]+)?)?(S|[MWQLGJTZ]?[UDXOB])) */
313 static scm_ichar_t
format_raw_c_directive(ScmObj port,format_string_t * fmt,va_list * args)314 format_raw_c_directive(ScmObj port, format_string_t *fmt, va_list *args)
315 {
316 format_string_t orig_fmt;
317 const void *orig_pos;
318 const char *str;
319 scm_int_t cstr_len, str_len, i;
320 scm_ichar_t c;
321 intmax_t n;
322 uintmax_t un;
323 int radix;
324 scm_bool modifiedp;
325 ScmValueFormat vfmt;
326 DECLARE_INTERNAL_FUNCTION("internal format");
327
328 orig_fmt = *fmt;
329 orig_pos = FORMAT_STR_POS(*fmt);
330
331 c = FORMAT_STR_PEEK(*fmt);
332 switch (c) {
333 case 'C': /* Character */
334 FORMAT_STR_SKIP_CHAR(*fmt);
335 c = va_arg(*args, scm_ichar_t);
336 scm_port_put_char(port, c);
337 return (c == '\0') ? ' ' : c;
338
339 case 'P': /* Pointer */
340 FORMAT_STR_SKIP_CHAR(*fmt);
341 scm_port_puts(port, "0x");
342 SCM_VALUE_FORMAT_INIT4(vfmt, sizeof(void *) * CHAR_BIT / 4,
343 -1, '0', scm_false);
344 format_int(port, vfmt, (uintptr_t)va_arg(*args, void *), 16);
345 return c;
346
347 default:
348 break;
349 }
350
351 vfmt = read_number_prefix(SCM_FMT_RAW_C | SCM_FMT_SSCM_ADDENDUM, fmt);
352 c = FORMAT_STR_PEEK(*fmt);
353 if (c == 'S') { /* String */
354 FORMAT_STR_SKIP_CHAR(*fmt);
355 str = va_arg(*args, const char *);
356 cstr_len = strlen(str);
357 #if SCM_USE_MULTIBYTE_CHAR
358 str_len = scm_mb_bare_c_strlen(scm_current_char_codec, str);
359 #else
360 str_len = cstr_len;
361 #endif
362 for (i = str_len; i < vfmt.width; i++)
363 scm_port_put_char(port, ' '); /* ignore leading zero */
364 scm_port_puts(port, str);
365 return (*str) ? str[cstr_len - 1] : c;
366 }
367
368 /* size modifiers (ordered by size) */
369 modifiedp = scm_true;
370 switch (c) {
371 case 'W': /* int32_t */
372 un = va_arg(*args, uint32_t);
373 n = (int32_t)un;
374 break;
375
376 case 'M': /* scm_int_t */
377 un = va_arg(*args, scm_uint_t);
378 n = (scm_int_t)un;
379 break;
380
381 case 'L': /* long */
382 un = va_arg(*args, unsigned long);
383 n = (long)un;
384 break;
385
386 case 'Q': /* int64_t */
387 un = va_arg(*args, uint64_t);
388 n = (int64_t)un;
389 break;
390
391 case 'J': /* intmax_t */
392 un = va_arg(*args, uintmax_t);
393 n = (intmax_t)un;
394 break;
395
396 case 'T': /* ptrdiff_t */
397 un = (uintmax_t)va_arg(*args, ptrdiff_t);
398 n = (ptrdiff_t)un;
399 break;
400
401 case 'Z': /* size_t */
402 un = va_arg(*args, size_t);
403 /* portable ssize_t replacement */
404 #if (SIZEOF_SIZE_T == SIZEOF_INTPTR_T)
405 n = (intptr_t)un;
406 #elif (SIZEOF_SIZE_T == SIZEOF_INT32_T)
407 n = (int32_t)un;
408 #elif (SIZEOF_SIZE_T == SIZEOF_INT64_T)
409 n = (int64_t)un;
410 #elif (SIZEOF_SIZE_T == SIZEOF_INTMAX_T)
411 n = (intmax_t)un;
412 #else
413 #error "This platform is not supported"
414 #endif
415 break;
416
417 default:
418 modifiedp = scm_false;
419 un = n = 0; /* dummy to suppress warning */
420 break;
421 }
422 if (modifiedp) {
423 FORMAT_STR_SKIP_CHAR(*fmt);
424 c = FORMAT_STR_PEEK(*fmt);
425 }
426
427 /* integer format specifiers */
428 switch (c) {
429 case 'U': /* Unsigned decimal */
430 vfmt.signedp = scm_false;
431 /* FALLTHROUGH */
432 case 'D': /* signed Decimal */
433 radix = 10;
434 break;
435
436 case 'X': /* unsigned heXadecimal */
437 radix = 16;
438 vfmt.signedp = scm_false;
439 break;
440
441 case 'O': /* unsigned Octal */
442 radix = 8;
443 vfmt.signedp = scm_false;
444 break;
445
446 case 'B': /* unsigned Binary */
447 radix = 2;
448 vfmt.signedp = scm_false;
449 break;
450
451 default:
452 /* no raw C directives found */
453 if (FORMAT_STR_POS(*fmt) != orig_pos)
454 *fmt = orig_fmt;
455 return '\0';
456 }
457 FORMAT_STR_SKIP_CHAR(*fmt);
458 if (!modifiedp) {
459 un = va_arg(*args, unsigned int);
460 n = (int)un;
461 }
462 format_int(port, vfmt, (vfmt.signedp) ? (uintmax_t)n : un, radix);
463
464 return c;
465 }
466 #endif /* SCM_USE_RAW_C_FORMAT */
467
468 #if SCM_USE_SRFI28
469 static scm_ichar_t
format_directive(ScmObj port,scm_ichar_t last_ch,enum ScmFormatCapability fcap,format_string_t * fmt,struct scm_format_args args)470 format_directive(ScmObj port, scm_ichar_t last_ch,
471 enum ScmFormatCapability fcap,
472 format_string_t *fmt, struct scm_format_args args)
473 {
474 const void *orig_pos;
475 char directive;
476 scm_bool eolp;
477 #if SCM_USE_SRFI48
478 ScmObj obj, indirect_fmt, indirect_args, proc_pretty_print;
479 scm_bool prefixedp;
480 int radix;
481 scm_int_t i;
482 ScmValueFormat vfmt;
483 #endif
484 DECLARE_INTERNAL_FUNCTION("format");
485
486 #if SCM_USE_SRFI48
487 orig_pos = FORMAT_STR_POS(*fmt);
488 vfmt = read_number_prefix(fcap, fmt);
489 prefixedp = (FORMAT_STR_POS(*fmt) != orig_pos);
490 #endif /* SCM_USE_SRFI48 */
491 directive = ICHAR_DOWNCASE(FORMAT_STR_PEEK(*fmt));
492 eolp = scm_false;
493
494 #if SCM_USE_SRFI48
495 if (fcap & SCM_FMT_SRFI48_ADDENDUM) {
496 radix = -1;
497 switch (directive) {
498 case 'f': /* Fixed */
499 obj = POP_FORMAT_ARG(args);
500 if (STRINGP(obj)) {
501 for (i = SCM_STRING_LEN(obj); i < vfmt.width; i++)
502 scm_port_put_char(port, ' '); /* ignore leading zero */
503 scm_display(port, obj);
504 goto fin;
505 }
506 #if SCM_USE_INT
507 if (INTP(obj)) {
508 format_int(port, vfmt, SCM_INT_VALUE(obj), 10);
509 goto fin;
510 }
511 #endif /* SCM_USE_INT */
512 ERR_OBJ("integer or string required but got", obj);
513
514 #if SCM_USE_INT
515 case 'd': /* Decimal */
516 radix = 10;
517 break;
518
519 case 'x': /* heXadecimal */
520 radix = 16;
521 break;
522
523 case 'o': /* Octal */
524 radix = 8;
525 break;
526
527 case 'b': /* Binary */
528 radix = 2;
529 break;
530 #endif /* SCM_USE_INT */
531
532 default:
533 break;
534 }
535 if (radix > 0 && (!prefixedp || (fcap & SCM_FMT_PREFIXED_RADIX))) {
536 obj = POP_FORMAT_ARG(args);
537 #if SCM_USE_INT
538 ENSURE_INT(obj);
539 format_int(port, vfmt, SCM_INT_VALUE(obj), radix);
540 #else /* SCM_USE_INT */
541 ERR("integer feature is not enabled");
542 #endif /* SCM_USE_INT */
543 goto fin;
544 }
545 }
546 #endif /* SCM_USE_SRFI48 */
547
548 if (prefixedp)
549 ERR("invalid prefix for directive ~~~C", (scm_ichar_t)directive);
550
551 if (fcap & SCM_FMT_SRFI28) {
552 switch (directive) {
553 case 'a': /* Any */
554 scm_display(port, POP_FORMAT_ARG(args));
555 goto fin;
556
557 case 's': /* Slashified */
558 scm_write(port, POP_FORMAT_ARG(args));
559 goto fin;
560
561 case '%': /* Newline */
562 scm_port_newline(port);
563 eolp = scm_true;
564 goto fin;
565
566 case '~': /* Tilde */
567 scm_port_put_char(port, '~');
568 goto fin;
569
570 default:
571 break;
572 }
573 }
574
575 #if SCM_USE_SRFI48
576 if (fcap & SCM_FMT_SRFI48_ADDENDUM) {
577 switch (directive) {
578 #if SCM_USE_SRFI38
579 case 'w': /* WriteCircular */
580 scm_write_ss(port, POP_FORMAT_ARG(args));
581 goto fin;
582 #endif /* SCM_USE_SRFI38 */
583
584 case 'y': /* Yuppify */
585 proc_pretty_print = SCM_SYMBOL_VCELL(l_sym_pretty_print);
586 if (EQ(proc_pretty_print, SCM_UNBOUND)) {
587 /* called internally when (use srfi-48) is not evaluated yet */
588 scm_write(port, POP_FORMAT_ARG(args));
589 } else {
590 ENSURE_PROCEDURE(proc_pretty_print);
591 obj = POP_FORMAT_ARG(args);
592 scm_call(proc_pretty_print, LIST_2(obj, port));
593 }
594 goto fin;
595
596 case 'k': /* Indirection (backward compatability) */
597 case '?': /* Indirection */
598 indirect_fmt = POP_FORMAT_ARG(args);
599 ENSURE_STRING(indirect_fmt);
600 indirect_args = POP_FORMAT_ARG(args);
601 ENSURE_LIST(indirect_args);
602 scm_lformat(port,
603 fcap & ~SCM_FMT_RAW_C,
604 SCM_STRING_STR(indirect_fmt), indirect_args);
605 goto fin;
606
607 #if SCM_USE_CHAR
608 case 'c': /* Character */
609 obj = POP_FORMAT_ARG(args);
610 ENSURE_CHAR(obj);
611 scm_port_put_char(port, SCM_CHAR_VALUE(obj));
612 goto fin;
613 #endif /* SCM_USE_CHAR */
614
615 case 't': /* Tab */
616 scm_port_put_char(port, '\t');
617 goto fin;
618
619 case '_': /* Space */
620 scm_port_put_char(port, ' ');
621 goto fin;
622
623 case '&': /* Freshline */
624 if (last_ch != NEWLINE_CHAR)
625 scm_port_newline(port);
626 eolp = scm_true;
627 goto fin;
628
629 case 'h': /* Help */
630 #if SCM_USE_SSCM_FORMAT_EXTENSION
631 if (fcap & SCM_FMT_SSCM_ADDENDUM)
632 scm_port_puts(port, MSG_SSCM_DIRECTIVE_HELP);
633 else
634 #endif
635 scm_port_puts(port, MSG_SRFI48_DIRECTIVE_HELP);
636 goto fin;
637
638 default:
639 break;
640 }
641 }
642 #endif /* SCM_USE_SRFI48 */
643
644 /* Although SRFI-48 does not specified about unknown directives, the
645 * reference implementation treats it as error. */
646 ERR(ERRMSG_INVALID_ESCSEQ ": ~~~C", (scm_ichar_t)directive);
647
648 fin:
649 FORMAT_STR_SKIP_CHAR(*fmt);
650 return (eolp) ? NEWLINE_CHAR : directive;
651 }
652 #endif /* SCM_USE_SRFI28 */
653
654 static ScmObj
format_internal(ScmObj port,enum ScmFormatCapability fcap,const char * fmt,struct scm_format_args args)655 format_internal(ScmObj port, enum ScmFormatCapability fcap,
656 const char *fmt, struct scm_format_args args)
657 {
658 scm_ichar_t c, last_c, handled;
659 format_string_t cur;
660 scm_bool implicit_portp;
661 DECLARE_INTERNAL_FUNCTION("format");
662
663 if (FALSEP(port)) {
664 #if SCM_USE_SRFI6
665 port = scm_p_srfi6_open_output_string();
666 implicit_portp = scm_true;
667 #else
668 ERR("format to string needs SRFI-6 feature");
669 #endif
670 } else if (EQ(port, SCM_TRUE)) {
671 port = scm_out;
672 implicit_portp = scm_false;
673 } else {
674 if (!PORTP(port))
675 ERR_OBJ("port or boolean required but got", port);
676 implicit_portp = scm_false;
677 }
678
679 last_c = '\0';
680 FORMAT_STR_INIT(cur, fmt);
681 while (!FORMAT_STR_ENDP(cur)) {
682 c = FORMAT_STR_READ(cur);
683 if (c == '~') {
684 #if SCM_USE_RAW_C_FORMAT
685 if (fcap & SCM_FMT_RAW_C) {
686 SCM_ASSERT(args.type == ARG_VA_LIST);
687 handled = format_raw_c_directive(port, &cur, args.lst.va);
688 if (handled) {
689 last_c = handled;
690 continue;
691 }
692 }
693 /* FALLTHROUGH */
694 #endif /* SCM_USE_RAW_C_FORMAT */
695 #if SCM_USE_SRFI28
696 if (fcap & (SCM_FMT_SRFI28 | SCM_FMT_SRFI48 | SCM_FMT_SSCM)) {
697 SCM_ASSERT(args.type == ARG_VA_LIST
698 || args.type == ARG_SCM_LIST);
699 last_c = format_directive(port, last_c, fcap, &cur, args);
700 continue;
701 }
702 #endif /* SCM_USE_SRFI28 */
703 SCM_NOTREACHED;
704 } else {
705 scm_port_put_char(port, c);
706 last_c = c;
707 }
708 }
709
710 if (args.type == ARG_SCM_LIST)
711 ENSURE_NO_MORE_ARG(*args.lst.scm);
712 #if SCM_USE_SRFI6
713 return (implicit_portp) ? scm_p_srfi6_get_output_string(port) : SCM_UNDEF;
714 #else
715 return SCM_UNDEF;
716 #endif
717 }
718
719 SCM_EXPORT ScmObj
scm_lformat(ScmObj port,enum ScmFormatCapability fcap,const char * fmt,ScmObj scm_args)720 scm_lformat(ScmObj port,
721 enum ScmFormatCapability fcap, const char *fmt, ScmObj scm_args)
722 {
723 struct scm_format_args args;
724
725 args.type = ARG_SCM_LIST;
726 args.lst.scm = &scm_args;
727 return format_internal(port, fcap, fmt, args);
728 }
729
730 SCM_EXPORT ScmObj
scm_vformat(ScmObj port,enum ScmFormatCapability fcap,const char * fmt,va_list c_args)731 scm_vformat(ScmObj port,
732 enum ScmFormatCapability fcap, const char *fmt, va_list c_args)
733 {
734 struct scm_format_args args;
735
736 args.type = ARG_VA_LIST;
737 #if HAVE_REFERENCEABLE_PASSED_VA_LIST
738 /* { va_list ap; return ≈ } and f(va_list ap) { return ≈ } returns
739 * same value */
740 args.lst.va = &c_args;
741 #elif HAVE_AUTOREFERRED_PASSED_VA_LIST
742 /* f(va_list ap) { return ≈ } returns invalid value */
743 /*
744 * x86_64 on gcc and some environemnts behaves such a way. See following
745 * bug reports of gcc for further information.
746 *
747 * http://gcc.gnu.org/bugzilla/show_bug.cgi?id=14557
748 * http://gcc.gnu.org/bugzilla/show_bug.cgi?id=20951
749 *
750 * To avoid taking an address of va_list that passed as a function argument
751 * is the best way to maximize the portability. But since it requires a
752 * combined function of format_internal(), format_raw_c_directive() and
753 * format_directive() which considerably makes the maintainability of
754 * format.c lost, I adopted this hack. -- YamaKen 2006-12-07
755 */
756 args.lst.va = (va_list *)c_args;
757 #else
758 #error "This platform is not supported"
759 #endif
760 return format_internal(port, fcap, fmt, args);
761 }
762
763 SCM_EXPORT ScmObj
scm_format(ScmObj port,enum ScmFormatCapability fcap,const char * fmt,...)764 scm_format(ScmObj port, enum ScmFormatCapability fcap, const char *fmt, ...)
765 {
766 va_list args;
767 ScmObj ret;
768
769 va_start(args, fmt);
770 ret = scm_vformat(port, fcap, fmt, args);
771 va_end(args);
772
773 return ret;
774 }
775