1 /*
2 * write.c - writer
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 */
33
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36 #include "gauche/class.h"
37 #include "gauche/writer.h"
38 #include "gauche/priv/builtin-syms.h"
39 #include "gauche/priv/macroP.h" /* PVREF stuff. Will go in future */
40 #include "gauche/priv/writerP.h"
41 #include "gauche/priv/portP.h"
42 #include "gauche/priv/stringP.h"
43 #include "gauche/char_attr.h"
44
45 #include <ctype.h>
46
47 static void write_walk(ScmObj obj, ScmPort *port);
48 static void write_ss(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
49 static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
50 static void write_object(ScmObj obj, ScmPort *out, ScmWriteContext *ctx);
51 static ScmObj write_object_fallback(ScmObj *args, int nargs, ScmGeneric *gf);
52 SCM_DEFINE_GENERIC(Scm_GenericWriteObject, write_object_fallback, NULL);
53
54 static const ScmWriteControls *defaultWriteControls;
55
56 /*============================================================
57 * Writers
58 */
59
60 /* Note: all internal routine (static functions) assumes the output
61 port is properly locked. */
62
63 /* Note: the current internal structure is in the transient state.
64 handling of writer mode and context should be much better.
65 Do not count on these APIs! */
66
67 /* Note: in order to support write/ss, we need to pass down the context
68 along the call tree.
69 For the time being, we attach transient extra info to the port during
70 the call. It's a bit ugly, though, to rely on such mutation. In
71 future we might introduce a 'wrapper' port, which operates just like
72 the inner (wrapped) port but can carry extra info. We can do it with
73 virtual port now, but it takes some overhead; we want it to be much
74 lighter.
75 */
76
77 #define SPBUFSIZ 50
78
79 /* Two bitmask used internally to indicate extra write mode */
80 #define WRITE_LIMITED 0x10 /* we're limiting the length of output. */
81
82 /* VM-default case mode */
83 #define DEFAULT_CASE \
84 (SCM_VM_RUNTIME_FLAG_IS_SET(Scm_VM(), SCM_CASE_FOLD)? \
85 SCM_WRITE_CASE_FOLD:SCM_WRITE_CASE_NOFOLD)
86
87 /* Whether we need 'walk' pass to find out shared and/or circular
88 structure. Now we use two-pass writing by default, and use one-pass
89 writing only when requested specifically. */
90 #define WRITER_NEED_2PASS(ctx) (SCM_WRITE_MODE(ctx) != SCM_WRITE_SIMPLE)
91
92 /*
93 * WriteContext public API
94 */
Scm_WriteContextMode(const ScmWriteContext * ctx)95 int Scm_WriteContextMode(const ScmWriteContext *ctx)
96 {
97 return SCM_WRITE_MODE(ctx);
98 }
99
Scm_WriteContextCase(const ScmWriteContext * ctx)100 int Scm_WriteContextCase(const ScmWriteContext *ctx)
101 {
102 return SCM_WRITE_CASE(ctx);
103 }
104
write_context_init(ScmWriteContext * ctx,int mode,int flags,int limit)105 static void write_context_init(ScmWriteContext *ctx, int mode, int flags, int limit)
106 {
107 ctx->mode = mode;
108 /* if case mode is not specified, use default taken from VM default */
109 if (SCM_WRITE_CASE(ctx) == 0) ctx->mode |= DEFAULT_CASE;
110 ctx->flags = flags;
111 ctx->limit = limit;
112 ctx->controls = NULL;
113 if (limit > 0) ctx->flags |= WRITE_LIMITED;
114 }
115
116 /*
117 * WriteControls
118 */
Scm_MakeWriteControls(const ScmWriteControls * proto)119 ScmWriteControls *Scm_MakeWriteControls(const ScmWriteControls *proto)
120 {
121 ScmWriteControls *p = SCM_NEW(ScmWriteControls);
122 SCM_SET_CLASS(p, SCM_CLASS_WRITE_CONTROLS);
123 if (proto) {
124 *p = *proto;
125 } else {
126 p->printLength = -1;
127 p->printLevel = -1;
128 p->printWidth = -1;
129 p->printBase = 10;
130 p->printRadix = FALSE;
131 p->printPretty = FALSE;
132 }
133 return p;
134 }
135
Scm_DefaultWriteControls(void)136 const ScmWriteControls *Scm_DefaultWriteControls(void)
137 {
138 return defaultWriteControls;
139 }
140
Scm_GetWriteControls(ScmWriteContext * ctx,ScmWriteState * st)141 const ScmWriteControls *Scm_GetWriteControls(ScmWriteContext *ctx,
142 ScmWriteState *st)
143 {
144 if (ctx && ctx->controls) return ctx->controls;
145 if (st && st->controls) return st->controls;
146 return defaultWriteControls;
147 }
148
149 /*
150 * WriteState
151 */
152 /* The class definition is in libio.scm */
153
154 /* NB: For the time being, proto argument is ignored. */
Scm_MakeWriteState(ScmWriteState * proto SCM_UNUSED)155 ScmWriteState *Scm_MakeWriteState(ScmWriteState *proto SCM_UNUSED)
156 {
157 ScmWriteState *z = SCM_NEW(ScmWriteState);
158 SCM_SET_CLASS(z, SCM_CLASS_WRITE_STATE);
159 z->sharedTable = NULL;
160 z->sharedCounter = 0;
161 z->currentLevel = 0;
162 z->controls = NULL;
163 return z;
164 }
165
166 /* Cleanup transient data attached to the port. */
cleanup_port_write_state(ScmPort * port)167 static void cleanup_port_write_state(ScmPort *port)
168 {
169 port->flags &= ~(SCM_PORT_WALKING|SCM_PORT_WRITESS);
170 ScmWriteState *s = Scm_PortWriteState(port);
171 if (s != NULL) {
172 Scm_PortWriteStateSet(port, NULL);
173 /* The table for recursive/shared detection should be GC'ed after
174 we drop the reference to it. However, the table can be quite big
175 after doing write-shared on a large graph, and our implementation of
176 big hashtables isn't particularly friendly to GC---it is prone
177 to be a victim of false pointers, especially on 32bit architecture.
178 It becomes an issue if the app repeatedly use write-shared on
179 large graph, for an incorrectly retained hashtable may have false
180 pointers to other incorrectly retained hashtable, making the amount
181 of retained garbage unbounded. So, we take extra step to clear
182 the table to avoid the risk. In vast majority of the case, the
183 table is used only for circle detection, in which case the table
184 is small and it won't add much overhead.
185 */
186 if (s && s->sharedTable) {
187 Scm_HashCoreClear(SCM_HASH_TABLE_CORE(s->sharedTable));
188 }
189 }
190 }
191
192 /*
193 * Entry points
194 *
195 * For shared/circular structure detection, we have to distinguish
196 * the "toplevel" call to write and the recursive calls. The catch
197 * is that Scm_Write etc. can be called recursively, via write-object
198 * method, and we can't rely on its arguments to determine which is
199 * the case. So we see the port to find out if we're in the recursive
200 * mode (see the above discussion about the context.)
201 */
202
203 /*
204 * Scm_Write - Standard Write, convenience version. Using default controls.
205 */
Scm_Write(ScmObj obj,ScmObj p,int mode)206 void Scm_Write(ScmObj obj, ScmObj p, int mode)
207 {
208 Scm_WriteWithControls(obj, p, mode, NULL);
209 }
210
211 /*
212 * Scm_WriteWithControls - the general entry
213 */
Scm_WriteWithControls(ScmObj obj,ScmObj p,int mode,const ScmWriteControls * ctrl)214 void Scm_WriteWithControls(ScmObj obj, ScmObj p, int mode,
215 const ScmWriteControls *ctrl)
216 {
217 if (!SCM_OPORTP(p)) Scm_Error("output port required, but got %S", p);
218
219 ScmPort *port = SCM_PORT(p);
220 ScmVM *vm = Scm_VM();
221 if (ctrl == NULL) ctrl = Scm_DefaultWriteControls();
222
223 if (PORT_LOCK_OWNER_P(port, vm) && PORT_RECURSIVE_P(port)) {
224 /* We're in the recursive call, so we just recurse into write_walk
225 or write_rec, according to the phase. NB: The controls passed
226 into the argument CTRL is ignored; the "root" control, passed
227 to the toplevel write API, will be used. */
228 if (PORT_WALKER_P(port)) {
229 /* Special treatment - if we're "display"-ing a string, we'll
230 bypass walk path even if we're in the middle of write/ss.
231 Using srfi-38 notation to show displayed strings doesn't
232 make sense at all. */
233 if (!((mode == SCM_WRITE_DISPLAY) && SCM_STRINGP(obj))) {
234 write_walk(obj, port);
235 }
236 } else {
237 ScmWriteContext ctx;
238 write_context_init(&ctx, mode, 0, 0);
239 write_rec(obj, port, &ctx);
240 }
241
242 } else {
243 /* We're in the toplevel call.*/
244 ScmWriteContext ctx;
245 write_context_init(&ctx, mode, 0, 0);
246 PORT_LOCK(port, vm);
247 if (WRITER_NEED_2PASS(&ctx)) {
248 ctx.controls = ctrl;
249 PORT_SAFE_CALL(port, write_ss(obj, port, &ctx),
250 cleanup_port_write_state(port));
251 } else {
252 /* write-simple case. CTRL is ignored. */
253 PORT_SAFE_CALL(port, write_rec(obj, port, &ctx), /*no cleanup*/);
254 }
255 PORT_UNLOCK(port);
256 }
257 }
258
259 /*
260 * Scm_WriteLimited - Write to limited length.
261 *
262 * Characters exceeding WIDTH are truncated.
263 * If the output fits within WIDTH, # of characters actually written
264 * is returned. Otherwise, -1 is returned.
265 *
266 * Currently this API is only used from Scm_Printf, for 'format' has been
267 * moved to libfmt.scm. I don't like the way this is implemented and would
268 * like to share this with libfmt.scm eventually.
269 */
Scm_WriteLimited(ScmObj obj,ScmObj p,int mode,int width)270 int Scm_WriteLimited(ScmObj obj, ScmObj p, int mode, int width)
271 {
272 if (!SCM_OPORTP(p)) {
273 Scm_Error("output port required, but got %S", p);
274 }
275
276 ScmPort *port = SCM_PORT(p);
277
278 /* The walk pass does not produce any output, so we don't bother to
279 create an intermediate string port. */
280 if (PORT_LOCK_OWNER_P(port, Scm_VM()) && PORT_WALKER_P(port)) {
281 SCM_ASSERT(PORT_RECURSIVE_P(port));
282 write_walk(obj, port);
283 return 0; /* doesn't really matter */
284 }
285
286 ScmObj out = Scm_MakeOutputStringPort(TRUE);
287 Scm_PortWriteStateSet(SCM_PORT(out), Scm_PortWriteState(port));
288 ScmWriteContext ctx;
289 write_context_init(&ctx, mode, 0, width);
290
291 /* We don't need to lock 'out', nor clean it up, for it is private. */
292 /* This part is a bit confusing - we only need to call write_ss
293 if we're at the toplevel call. */
294 if (PORT_RECURSIVE_P(SCM_PORT(port))) {
295 write_rec(obj, SCM_PORT(out), &ctx);
296 } else if (WRITER_NEED_2PASS(&ctx)) {
297 write_ss(obj, SCM_PORT(out), &ctx);
298 } else {
299 write_rec(obj, SCM_PORT(out), &ctx);
300 }
301
302 ScmString *str = SCM_STRING(Scm_GetOutputString(SCM_PORT(out), 0));
303 int nc = SCM_STRING_BODY_LENGTH(SCM_STRING_BODY(str));
304 if (nc > width) {
305 ScmObj sub = Scm_Substring(str, 0, width, FALSE);
306 SCM_PUTS(sub, port); /* this locks port */
307 return -1;
308 } else {
309 SCM_PUTS(str, port); /* this locks port */
310 return nc;
311 }
312 }
313
314 /* OBSOLETED: This is redundant. Will be gone in 1.0 release. */
Scm_WriteCircular(ScmObj obj,ScmObj port,int mode,int width)315 int Scm_WriteCircular(ScmObj obj, ScmObj port, int mode, int width)
316 {
317 if (width <= 0) {
318 Scm_Write(obj, port, mode);
319 return 0;
320 } else {
321 return Scm_WriteLimited(obj, port, mode, width);
322 }
323 }
324
325 /*===================================================================
326 * Internal writer
327 */
328
329 /* Obj is PTR, except pair and vector */
write_general(ScmObj obj,ScmPort * out,ScmWriteContext * ctx)330 static void write_general(ScmObj obj, ScmPort *out, ScmWriteContext *ctx)
331 {
332 ScmClass *c = Scm_ClassOf(obj);
333 if (c->print) c->print(obj, out, ctx);
334 else write_object(obj, out, ctx);
335 }
336
337 /* Default object printer delegates print action to generic function
338 write-object. We can't use VMApply here since this function can be
339 called deep in the recursive stack of Scm_Write, so the control
340 may not return to VM immediately. */
write_object(ScmObj obj,ScmPort * port,ScmWriteContext * ctx SCM_UNUSED)341 static void write_object(ScmObj obj, ScmPort *port,
342 ScmWriteContext *ctx SCM_UNUSED)
343 {
344 Scm_ApplyRec(SCM_OBJ(&Scm_GenericWriteObject),
345 SCM_LIST2(obj, SCM_OBJ(port)));
346 }
347
348 /* Default method for write-object */
write_object_fallback(ScmObj * args,int nargs,ScmGeneric * gf SCM_UNUSED)349 static ScmObj write_object_fallback(ScmObj *args, int nargs,
350 ScmGeneric *gf SCM_UNUSED)
351 {
352 if (nargs != 2 || (nargs == 2 && !SCM_OPORTP(args[1]))) {
353 Scm_Error("No applicable method for write-object with %S",
354 Scm_ArrayToList(args, nargs));
355 }
356 ScmClass *klass = Scm_ClassOf(args[0]);
357 Scm_Printf(SCM_PORT(args[1]), "#<%A%s%p>",
358 klass->name,
359 (SCM_FALSEP(klass->redefined)? " " : ":redefined "),
360 args[0]);
361 return SCM_TRUE;
362 }
363
364 /* character name table (first 33 chars of ASCII)*/
365 static const char *char_names[] = {
366 "null", "x01", "x02", "x03", "x04", "x05", "x06", "alarm",
367 "backspace","tab", "newline","x0b", "x0c", "return","x0e", "x0f",
368 "x10", "x11", "x12", "x13", "x14", "x15", "x16", "x17",
369 "x18", "x19", "x1a", "escape","x1c", "x1d", "x1e", "x1f",
370 "space"
371 };
372
373 /* Returns # of chars written.
374 This can be better in char.c, but to do so, we'd better to clean up
375 public interface for ScmWriteContext.
376 TODO: It would be nice to have a mode to print character in unicode
377 character name.
378 */
write_char(ScmChar ch,ScmPort * port,ScmWriteContext * ctx)379 static size_t write_char(ScmChar ch, ScmPort *port, ScmWriteContext *ctx)
380 {
381 if (SCM_WRITE_MODE(ctx) == SCM_WRITE_DISPLAY) {
382 Scm_PutcUnsafe(ch, port);
383 return 1;
384 } else {
385 const char *cname = NULL;
386 char buf[SPBUFSIZ];
387
388 Scm_PutzUnsafe("#\\", -1, port);
389 if (ch <= 0x20) cname = char_names[ch];
390 else if (ch == 0x7f) cname = "delete";
391 else {
392 switch (Scm_CharGeneralCategory(ch)) {
393 case SCM_CHAR_CATEGORY_Mn:
394 case SCM_CHAR_CATEGORY_Mc:
395 case SCM_CHAR_CATEGORY_Me:
396 case SCM_CHAR_CATEGORY_Zs:
397 case SCM_CHAR_CATEGORY_Zl:
398 case SCM_CHAR_CATEGORY_Zp:
399 case SCM_CHAR_CATEGORY_Cc:
400 case SCM_CHAR_CATEGORY_Cf:
401 case SCM_CHAR_CATEGORY_Cs:
402 case SCM_CHAR_CATEGORY_Co:
403 case SCM_CHAR_CATEGORY_Cn:
404 /* NB: Legacy Gauche uses native character code for #\xNNNN
405 notation, while R7RS uses Unicode codepoint. We eventually
406 need a write mode (legacy or r7rs) and switch the output
407 accordingly---the safe bet is to use #\uNNNN for legacy
408 mode and #\xNNNN for R7RS mode. */
409 snprintf(buf, SPBUFSIZ, "x%04x", (unsigned int)ch);
410 cname = buf;
411 break;
412 }
413 }
414
415 if (cname) {
416 Scm_PutzUnsafe(cname, -1, port);
417 return strlen(cname)+2; /* +2 for '#\' */
418 } else {
419 Scm_PutcUnsafe(ch, port);
420 return 3; /* +2 for '#\' */
421 }
422 }
423 }
424
425 /* If OBJ is a primitive object (roughly, immediate or number), write it to
426 PORT. Assumes the caller locks the PORT.
427 Returns the # of characters written, or #f if OBJ is not a primitive object.
428 */
Scm__WritePrimitive(ScmObj obj,ScmPort * port,ScmWriteContext * ctx)429 ScmObj Scm__WritePrimitive(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
430 {
431 const ScmWriteControls *wp =
432 Scm_GetWriteControls(ctx, Scm_PortWriteState(port));
433
434 #define CASE_ITAG_RET(obj, str) \
435 case SCM_ITAG(obj): \
436 Scm_PutzUnsafe(str, -1, port); \
437 return SCM_MAKE_INT(sizeof(str)-1);
438
439 if (SCM_IMMEDIATEP(obj)) {
440 switch (SCM_ITAG(obj)) {
441 CASE_ITAG_RET(SCM_FALSE, "#f");
442 CASE_ITAG_RET(SCM_TRUE, "#t");
443 CASE_ITAG_RET(SCM_NIL, "()");
444 CASE_ITAG_RET(SCM_EOF, "#<eof>");
445 CASE_ITAG_RET(SCM_UNDEFINED, "#<undef>");
446 /* The following two values should never be seen by the user; but
447 internal bugs may reveal them. */
448 CASE_ITAG_RET(SCM_UNBOUND, "#<unbound>");
449 CASE_ITAG_RET(SCM_UNINITIALIZED, "#<uninitialized>");
450 default:
451 Scm_Panic("write: unknown itag object: %08x", SCM_WORD(obj));
452 }
453 }
454 else if (SCM_INTP(obj) && wp->printBase == 10 && !wp->printRadix) {
455 /* Shortcut to avoid allocation */
456 char buf[SPBUFSIZ];
457 int k = snprintf(buf, SPBUFSIZ, "%ld", SCM_INT_VALUE(obj));
458 Scm_PutzUnsafe(buf, -1, port);
459 return SCM_MAKE_INT(k);
460 }
461 else if (SCM_CHARP(obj)) {
462 size_t k = write_char(SCM_CHAR_VALUE(obj), port, ctx);
463 return SCM_MAKE_INT(k);
464 }
465 else if (SCM_NUMBERP(obj)) {
466 ScmNumberFormat fmt;
467 Scm_NumberFormatInit(&fmt);
468 fmt.radix = wp->printBase;
469 if (wp->printRadix) fmt.flags |= SCM_NUMBER_FORMAT_ALT_RADIX;
470 return SCM_MAKE_INT(Scm_PrintNumber(port, obj, &fmt));
471 }
472 /* PVREF only appears in pattern temlate in the current macro expander.
473 It will be go away once we rewrite the expander. */
474 else if (SCM_PVREF_P(obj)) {
475 char buf[SPBUFSIZ];
476 int k = snprintf(buf, SPBUFSIZ, "#<pvar %" PRIdPTR ".%" PRIdPTR ">",
477 SCM_PVREF_LEVEL(obj), SCM_PVREF_COUNT(obj));
478 Scm_PutzUnsafe(buf, -1, port);
479 return SCM_MAKE_INT(k);
480 }
481 else if (SCM_STRING_CURSOR_SMALL_P(obj)) {
482 char buf[SPBUFSIZ];
483 int k = snprintf(buf, SPBUFSIZ, "#<string-cursor %ld>",
484 SCM_STRING_CURSOR_SMALL_OFFSET(obj));
485 Scm_PutzUnsafe(buf, -1, port);
486 return SCM_MAKE_INT(k);
487 }
488 return SCM_FALSE;
489 }
490
491 /* We need two passes to realize write/ss.
492
493 The first pass ("walk" pass) traverses the data and finds out
494 all shared substructures and/or cyclic references. It builds a
495 hash table of objects that need special treatment.
496
497 The second pass ("emit" pass) writes out the data.
498
499 For the walk pass, we can't use generic traversal algorithm
500 if the data contains user-defined structures. In which case,
501 we delegate the walk task to the user-defined print routine.
502 In the walk pass, we set SCM_PORT_WALKING flag of the port.
503 Port API recognizes this flag and just ignore any output to
504 this port. Writers recognize this flag and works as the
505 walk pass.
506
507 The walk pass sets up a hashtable that records how many times
508 each aggregate datum has been seen. If it's >1, emit pass
509 uses #n# and #n= notation.
510
511 NB: R7RS write-shared doesn't require datum labels on strings,
512 but srfi-38 does. We follow srfi-38.
513
514 NB: The walk pass is now written in Scheme (libio.scm: write-walk),
515 but the emit pass is in C (write_rec). Using naive recursion in write_rec
516 can bust the C stack when deep structure is passed, even if it is
517 not circular.
518 Thus we avoided recursion by managing traversal stack by our own
519 ('stack' local variable). It made the code ugly. Oh well.
520
521 We can't avoid recusion via class printer. It would need a major
522 overhaul to fix that. However, just preventing blowup by lists
523 and vectors is still useful.
524
525 The stack is a list, whose element can be (#t count . list) or
526 (index . vector). In the first case, the count part keeps
527 track of how many siblings we already printed, and the list part is the
528 rest of the list we should process after the current item is
529 written out. In the second case, we're processing the vector,
530 and the next item we should process is pointed by index.
531
532 We also set a limit of stack depth in write_rec; in case
533 car-circular list (e.g. #0=(#0#) ) is given to write-simple.
534 It used to SEGV by busting C stack. With the change of making it
535 non-recursive, it would hog all the heap before crash, which is
536 rather unpleasant, so we make it bail out before that.
537 */
538
539 /* pass 1 */
540 /* Implemented in Scheme */
write_walk(ScmObj obj,ScmPort * port)541 static void write_walk(ScmObj obj, ScmPort *port)
542 {
543 static ScmObj proc = SCM_UNDEFINED;
544 ScmWriteState *s = Scm_PortWriteState(port);
545 SCM_ASSERT(s);
546 ScmHashTable *ht = s->sharedTable;
547 SCM_ASSERT(ht != NULL);
548 SCM_BIND_PROC(proc, "%write-walk-rec", Scm_GaucheInternalModule());
549 Scm_ApplyRec3(proc, obj, SCM_OBJ(port), SCM_OBJ(ht));
550 }
551
552 /* pass 2 */
553
554 /* A limit of stack depth to detect (potential) car-circular structure
555 when we're writing out without shared structure notation. This is
556 an arbitrary limit, but we used to SEGVed in such case, so it's better
557 than that. */
558 #define STACK_LIMIT 0x1000000
559
560 /* Trick: The hashtable contains positive integer after the walk pass.
561 If we emit a reference tag N, we replace the entry's value to -N,
562 so that we can distinguish whether we've already emitted the object
563 or not. */
write_rec(ScmObj obj,ScmPort * port,ScmWriteContext * ctx)564 static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
565 {
566 char numbuf[50]; /* enough to contain long number */
567 ScmObj stack = SCM_NIL;
568 ScmWriteState *st = Scm_PortWriteState(port);
569 ScmHashTable *ht = (st? st->sharedTable : NULL);
570 const ScmWriteControls *wp = Scm_GetWriteControls(ctx, st);
571 int stack_depth = 0; /* only used when !ht */
572
573 #define PUSH(elt) \
574 do { \
575 stack = Scm_Cons(elt, stack); \
576 if (!ht && ++stack_depth > STACK_LIMIT) { \
577 Scm_Error("write recursed too deeply; " \
578 "maybe a circular structure?"); \
579 } \
580 } while (0)
581 #define POP() \
582 do { \
583 stack = SCM_CDR(stack); \
584 if (!ht) stack_depth--; \
585 } while (0)
586 #define CHECK_LEVEL() \
587 do { \
588 if (st) { \
589 if (wp->printLevel >= 0 && st->currentLevel >= wp->printLevel) { \
590 Scm_PutcUnsafe('#', port); \
591 goto next; \
592 } else { \
593 if (st) st->currentLevel++; \
594 } \
595 } \
596 } while (0)
597
598
599 for (;;) {
600 write1:
601 if (ctx->flags & WRITE_LIMITED) {
602 if (PORT_OSTR(port)->length >= ctx->limit) return;
603 }
604
605 /* number may be heap allocated, but we don't use srfi-38 notation. */
606 if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
607 if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
608 Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
609 }
610 goto next;
611 }
612 if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
613 || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
614 /* we don't put a reference tag for these */
615 write_general(obj, port, ctx);
616 goto next;
617 }
618
619 /* obj is heap allocated and we may use label notation. */
620 if (ht) {
621 ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
622 long k = SCM_INT_VALUE(e);
623 if (k <= 0) {
624 /* This object is already printed. */
625 snprintf(numbuf, 50, "#%ld#", -k);
626 Scm_PutzUnsafe(numbuf, -1, port);
627 goto next;
628 } else if (k > 1) {
629 /* This object will be seen again. Put a reference tag. */
630 ScmWriteState *s = Scm_PortWriteState(port);
631 snprintf(numbuf, 50, "#%d=", s->sharedCounter);
632 Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
633 s->sharedCounter++;
634 Scm_PutzUnsafe(numbuf, -1, port);
635 }
636 }
637
638 /* Writes aggregates */
639 if (SCM_PAIRP(obj)) {
640
641 CHECK_LEVEL();
642
643 /* special case for quote etc.
644 NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
645 get infinite recursion for the case like (cdr '#1='#1#). */
646 if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
647 && (!ht
648 || SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
649 const char *prefix = NULL;
650 if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
651 prefix = "'";
652 } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
653 prefix = "`";
654 } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
655 prefix = ",";
656 } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
657 prefix = ",@";
658 }
659 if (prefix) {
660 Scm_PutzUnsafe(prefix, -1, port);
661 obj = SCM_CADR(obj);
662 goto write1;
663 }
664 }
665
666 if (wp->printLength == 0) {
667 /* in this case we don't print the elements at all, so we need
668 to treat this specially. */
669 Scm_PutzUnsafe("(...)", -1, port);
670 if (st) st->currentLevel--;
671 goto next;
672 }
673
674 /* normal case */
675 Scm_PutcUnsafe('(', port);
676 PUSH(Scm_Cons(SCM_TRUE, Scm_Cons(SCM_MAKE_INT(1), SCM_CDR(obj))));
677 obj = SCM_CAR(obj);
678 goto write1;
679 } else if (SCM_VECTORP(obj)) {
680
681 CHECK_LEVEL();
682
683 if (wp->printLength == 0) {
684 /* in this case we don't print the elements at all, so we need
685 to treat this specially. */
686 Scm_PutzUnsafe("#(...)", -1, port);
687 if (st) st->currentLevel--;
688 goto next;
689 }
690 Scm_PutzUnsafe("#(", -1, port);
691 PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
692 obj = SCM_VECTOR_ELEMENT(obj, 0);
693 goto write1;
694 } else if (Scm_ClassOf(obj)->flags & SCM_CLASS_AGGREGATE) {
695 CHECK_LEVEL();
696 write_general(obj, port, ctx);
697 if (st) st->currentLevel--;
698 goto next;
699 } else {
700 write_general(obj, port, ctx);
701 goto next;
702 }
703
704 next:
705 while (SCM_PAIRP(stack)) {
706 ScmObj top = SCM_CAR(stack);
707 SCM_ASSERT(SCM_PAIRP(top));
708 if (SCM_INTP(SCM_CAR(top))) {
709 /* we're processing a vector */
710 ScmObj v = SCM_CDR(top);
711 int i = SCM_INT_VALUE(SCM_CAR(top));
712 int len = SCM_VECTOR_SIZE(v);
713
714 if (i == len) { /* we've done this vector */
715 Scm_PutcUnsafe(')', port);
716 POP();
717 } else if (wp->printLength >= 0 && wp->printLength <= i) {
718 Scm_PutzUnsafe(" ...)", -1, port);
719 POP();
720 } else {
721 Scm_PutcUnsafe(' ', port);
722 obj = SCM_VECTOR_ELEMENT(v, i);
723 SCM_SET_CAR_UNCHECKED(top, SCM_MAKE_INT(i+1));
724 goto write1;
725 }
726 } else {
727 /* we're processing a list */
728 SCM_ASSERT(SCM_PAIRP(SCM_CDR(top)));
729 long count = SCM_INT_VALUE(SCM_CADR(top));
730 ScmObj v = SCM_CDDR(top);
731 if (SCM_NULLP(v)) { /* we've done with this list */
732 Scm_PutcUnsafe(')', port);
733 POP();
734 } else if (!SCM_PAIRP(v)) {
735 /* Improper list. We treat aggregate types specially,
736 since such object at this position shouldn't increment
737 "level" - its content is regarded as the same level of
738 the current list.
739 */
740 Scm_PutzUnsafe(" . ", -1, port);
741 if (Scm_ClassOf(v)->flags & SCM_CLASS_AGGREGATE) {
742 if (st) st->currentLevel--;
743 write_rec(v, port, ctx);
744 if (st) st->currentLevel++;
745 Scm_PutcUnsafe(')', port);
746 POP();
747 } else {
748 obj = v;
749 SCM_SET_CAR_UNCHECKED(SCM_CDR(top),
750 SCM_MAKE_INT(count+1));
751 SCM_SET_CDR_UNCHECKED(SCM_CDR(top), SCM_NIL);
752 goto write1;
753 }
754 } else if (wp->printLength >= 0 && wp->printLength <= count) {
755 /* print-length limit reached */
756 Scm_PutzUnsafe(" ...)", -1, port);
757 POP();
758 } else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1))) {
759 /* cdr part is shared */
760 Scm_PutzUnsafe(" . ", -1, port);
761 obj = v;
762 SCM_SET_CAR_UNCHECKED(SCM_CDR(top), SCM_MAKE_INT(count+1));
763 SCM_SET_CDR_UNCHECKED(SCM_CDR(top), SCM_NIL);
764 goto write1;
765 } else {
766 Scm_PutcUnsafe(' ', port);
767 obj = SCM_CAR(v);
768 SCM_SET_CAR_UNCHECKED(SCM_CDR(top), SCM_MAKE_INT(count+1));
769 SCM_SET_CDR_UNCHECKED(SCM_CDR(top), SCM_CDR(v));
770 goto write1;
771 }
772 }
773 if (st) st->currentLevel--;
774 }
775 break;
776 }
777
778 #undef PUSH
779 #undef POP
780 #undef CHECK_DEPTH
781 }
782
783 /* Write/ss main driver
784 This should never be called recursively.
785 We modify port->flags and port->writeState; they are cleaned up
786 by the caller even if we throw an error during write. */
write_ss(ScmObj obj,ScmPort * port,ScmWriteContext * ctx)787 static void write_ss(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
788 {
789 SCM_ASSERT(Scm_PortWriteState(port) == NULL);
790
791 /* pass 1 */
792 port->flags |= SCM_PORT_WALKING;
793 if (SCM_WRITE_MODE(ctx)==SCM_WRITE_SHARED) port->flags |= SCM_PORT_WRITESS;
794 ScmWriteState *s = Scm_MakeWriteState(NULL);
795 s->sharedTable = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_EQ, 0));
796 s->controls = ctx->controls;
797 Scm_PortWriteStateSet(port, s);
798
799 write_walk(obj, port);
800 port->flags &= ~(SCM_PORT_WALKING|SCM_PORT_WRITESS);
801
802 /* pass 2 */
803 if (ctx->controls && ctx->controls->printPretty) {
804 static ScmObj proc = SCM_UNDEFINED;
805 SCM_BIND_PROC(proc, "%pretty-print", Scm_GaucheInternalModule());
806 Scm_ApplyRec4(proc, obj, SCM_OBJ(port),
807 SCM_OBJ(s->sharedTable), SCM_OBJ(ctx->controls));
808 } else {
809 write_rec(obj, port, ctx);
810 }
811 cleanup_port_write_state(port);
812 }
813
814 /*OBSOLETED*/
815 /*format is now in Scheme (libfmt.scm).*/
Scm_Format(ScmPort * out SCM_UNUSED,ScmString * fmt SCM_UNUSED,ScmObj args SCM_UNUSED,int sharedp SCM_UNUSED)816 void Scm_Format(ScmPort *out SCM_UNUSED,
817 ScmString *fmt SCM_UNUSED,
818 ScmObj args SCM_UNUSED,
819 int sharedp SCM_UNUSED)
820 {
821 Scm_Error("Scm_Format is obsoleted");
822 }
823
824 /*
825 * Printf()-like formatters
826 *
827 * These functions are familiar to C-programmers. The differences
828 * from C's printf() family are:
829 *
830 * - The first argument must be Scheme output port.
831 * - In the format string, the following conversion directives can
832 * be used, as well as the standard printf() directives:
833 *
834 * %[width][.prec]S - The corresponding argument must be
835 * ScmObj, which is written out by WRITE
836 * mode. If width is specified and no
837 * prec is given, the output is padded
838 * if it is shorter than width. If both
839 * width and prec are given, the output
840 * is truncated if it is wider than width.
841 *
842 * %[width][.prec]A - Same as %S, but use DISPLAY mode.
843 *
844 * %C - Take ScmChar argument and outputs it.
845 *
846 * Both functions return a number of characters written.
847 *
848 * A pound flag '#' for the S directive causes circular-safe output.
849 *
850 * NB: %A is taken by C99 for hexadecimal output of double numbers.
851 * We'll introduce a flag for S directive to use DISPLAY mode, and will
852 * move away from %A in future.
853 */
854
855 /* NB: Scm_Vprintf scans format string twice. In the first pass, arguments
856 * are retrieved from va_list variable and pushed to a list. In the second
857 * pass, they are printed according to the format string.
858 * It is necessary because we need to do the printing part within a closure
859 * called by Scm_WithPortLocking. On some architecture, we can't pass
860 * va_list type of argument in a closure packet easily.
861 */
862
863 /* Pass 1. Pop vararg and make a list of arguments.
864 * NB: If we're "walking" pass, and the argument is a Lisp object,
865 * we recurse to it in this pass.
866 * NB: Without NOINLINE, gcc inlines this in Scm_Vprintf which causes warning
867 * of register variable clobbering by longjmp.
868 */
vprintf_pass1(ScmPort * out,const char * fmt,va_list ap)869 static ScmObj SCM_NOINLINE vprintf_pass1(ScmPort *out,
870 const char *fmt,
871 va_list ap)
872 {
873 ScmObj h = SCM_NIL, t = SCM_NIL;
874 const char *fmtp = fmt;
875 int c, longp;
876
877 while ((c = *fmtp++) != 0) {
878 if (c != '%') continue;
879 longp = FALSE;
880 while ((c = *fmtp++) != 0) {
881 switch (c) {
882 case 'd': case 'i': case 'c':
883 if (longp) {
884 signed long val = va_arg(ap, signed long);
885 SCM_APPEND1(h, t, Scm_MakeInteger(val));
886 } else {
887 signed int val = va_arg(ap, signed int);
888 SCM_APPEND1(h, t, Scm_MakeInteger(val));
889 }
890 break;
891 case 'o': case 'u': case 'x': case 'X':
892 if (longp) {
893 unsigned long val = va_arg(ap, unsigned long);
894 SCM_APPEND1(h, t, Scm_MakeIntegerU(val));
895 } else {
896 unsigned int val = va_arg(ap, unsigned int);
897 SCM_APPEND1(h, t, Scm_MakeIntegerU(val));
898 }
899 break;
900 case 'e': case 'E': case 'f': case 'g': case 'G':
901 {
902 double val = va_arg(ap, double);
903 SCM_APPEND1(h, t, Scm_MakeFlonum(val));
904 break;
905 }
906 case 's':
907 {
908 char *val = va_arg(ap, char *);
909 /* for safety */
910 if (val != NULL) SCM_APPEND1(h, t, SCM_MAKE_STR(val));
911 else SCM_APPEND1(h, t, SCM_MAKE_STR("(null)"));
912 break;
913 }
914 case '%': break;
915 case 'p':
916 {
917 void *val = va_arg(ap, void *);
918 SCM_APPEND1(h, t, Scm_MakeIntegerU((u_long)(intptr_t)val));
919 break;
920 }
921 case 'S': case 'A':
922 {
923 ScmObj o = va_arg(ap, ScmObj);
924 SCM_APPEND1(h, t, o);
925 if (PORT_WALKER_P(out)) write_walk(o, out);
926 break;
927 }
928 case 'C':
929 {
930 ScmChar c = va_arg(ap, ScmChar);
931 SCM_APPEND1(h, t, Scm_MakeInteger(c));
932 break;
933 }
934 case '*':
935 {
936 int c = va_arg(ap, int);
937 SCM_APPEND1(h, t, Scm_MakeInteger(c));
938 continue;
939 }
940 case 'l':
941 longp = TRUE;
942 continue;
943 default:
944 continue;
945 }
946 break;
947 }
948 if (c == 0) {
949 Scm_Error("incomplete %%-directive in format string: %s", fmt);
950 }
951 }
952 return h;
953 }
954
955 /* Pass 2. */
vprintf_pass2(ScmPort * out,const char * fmt,ScmObj args)956 static void vprintf_pass2(ScmPort *out, const char *fmt, ScmObj args)
957 {
958 const char *fmtp = fmt;
959 ScmDString argbuf;
960 char buf[SPBUFSIZ];
961 int c;
962
963 while ((c = *fmtp++) != 0) {
964 int width, prec, dot_appeared, pound_appeared;
965
966 if (c != '%') {
967 Scm_PutcUnsafe(c, out);
968 continue;
969 }
970
971 Scm_DStringInit(&argbuf);
972 SCM_DSTRING_PUTB(&argbuf, c);
973 width = 0, prec = 0, dot_appeared = 0, pound_appeared = 0;
974 while ((c = *fmtp++) != 0) {
975 switch (c) {
976 case 'l':
977 SCM_DSTRING_PUTB(&argbuf, c);
978 continue;
979 case 'd': case 'i': case 'c':
980 {
981 SCM_ASSERT(SCM_PAIRP(args));
982 ScmObj val = SCM_CAR(args);
983 args = SCM_CDR(args);
984 SCM_ASSERT(SCM_EXACTP(val));
985 SCM_DSTRING_PUTB(&argbuf, c);
986 SCM_DSTRING_PUTB(&argbuf, 0);
987 snprintf(buf, SPBUFSIZ, Scm_DStringGetz(&argbuf),
988 Scm_GetInteger(val));
989 Scm_PutzUnsafe(buf, -1, out);
990 break;
991 }
992 case 'o': case 'u': case 'x': case 'X':
993 {
994 SCM_ASSERT(SCM_PAIRP(args));
995 ScmObj val = SCM_CAR(args);
996 args = SCM_CDR(args);
997 SCM_ASSERT(SCM_EXACTP(val));
998 SCM_DSTRING_PUTB(&argbuf, c);
999 SCM_DSTRING_PUTB(&argbuf, 0);
1000 snprintf(buf, SPBUFSIZ, Scm_DStringGetz(&argbuf),
1001 Scm_GetUInteger(val));
1002 Scm_PutzUnsafe(buf, -1, out);
1003 break;
1004 }
1005 case 'e': case 'E': case 'f': case 'g': case 'G':
1006 {
1007 SCM_ASSERT(SCM_PAIRP(args));
1008 ScmObj val = SCM_CAR(args);
1009 args = SCM_CDR(args);
1010 SCM_ASSERT(SCM_FLONUMP(val));
1011 SCM_DSTRING_PUTB(&argbuf, c);
1012 SCM_DSTRING_PUTB(&argbuf, 0);
1013 snprintf(buf, SPBUFSIZ, Scm_DStringGetz(&argbuf),
1014 Scm_GetDouble(val));
1015 Scm_PutzUnsafe(buf, -1, out);
1016 break;
1017 }
1018 case 's':
1019 {
1020 SCM_ASSERT(SCM_PAIRP(args));
1021 ScmObj val = SCM_CAR(args);
1022 args = SCM_CDR(args);
1023 SCM_ASSERT(SCM_STRINGP(val));
1024 Scm_PutsUnsafe(SCM_STRING(val), out);
1025
1026 /* TODO: support right adjustment such as %-10s.
1027 Currently we ignore minus sign and pad chars
1028 on the right. */
1029 for (int len = SCM_STRING_BODY_LENGTH(SCM_STRING_BODY(val));
1030 len < width;
1031 len++) {
1032 Scm_PutcUnsafe(' ', out);
1033 }
1034 break;
1035 }
1036 case '%':
1037 {
1038 Scm_PutcUnsafe('%', out);
1039 break;
1040 }
1041 case 'p':
1042 {
1043 SCM_ASSERT(SCM_PAIRP(args));
1044 ScmObj val = SCM_CAR(args);
1045 args = SCM_CDR(args);
1046 SCM_ASSERT(SCM_EXACTP(val));
1047 SCM_DSTRING_PUTB(&argbuf, c);
1048 SCM_DSTRING_PUTB(&argbuf, 0);
1049 snprintf(buf, SPBUFSIZ, Scm_DStringGetz(&argbuf),
1050 (void*)(intptr_t)Scm_GetUInteger(val));
1051 Scm_PutzUnsafe(buf, -1, out);
1052 break;
1053 }
1054 case 'S': case 'A':
1055 {
1056 SCM_ASSERT(SCM_PAIRP(args));
1057 ScmObj val = SCM_CAR(args);
1058 args = SCM_CDR(args);
1059
1060 int mode = (pound_appeared
1061 ? SCM_WRITE_SHARED
1062 : ((c == 'A')
1063 ? SCM_WRITE_DISPLAY
1064 : SCM_WRITE_WRITE));
1065 int n = 0;
1066 if (width <= 0) {
1067 Scm_Write(val, SCM_OBJ(out), mode);
1068 } else {
1069 Scm_WriteLimited(val, SCM_OBJ(out), mode, width);
1070 }
1071 if (n < 0 && prec > 0) {
1072 Scm_PutzUnsafe(" ...", -1, out);
1073 }
1074 if (n > 0) {
1075 for (; n < prec; n++) Scm_PutcUnsafe(' ', out);
1076 }
1077 break;
1078 }
1079 case 'C':
1080 {
1081 SCM_ASSERT(SCM_PAIRP(args));
1082 ScmObj val = SCM_CAR(args);
1083 args = SCM_CDR(args);
1084 SCM_ASSERT(SCM_EXACTP(val));
1085 Scm_PutcUnsafe(Scm_GetInteger(val), out);
1086 break;
1087 }
1088 case '0': case '1': case '2': case '3': case '4':
1089 case '5': case '6': case '7': case '8': case '9':
1090 if (dot_appeared) {
1091 prec = prec*10 + (c - '0');
1092 } else {
1093 width = width*10 + (c - '0');
1094 }
1095 goto fallback;
1096 case '.':
1097 dot_appeared++;
1098 goto fallback;
1099 case '#':
1100 pound_appeared++;
1101 goto fallback;
1102 case '*':
1103 SCM_ASSERT(SCM_PAIRP(args));
1104 if (dot_appeared) {
1105 prec = Scm_GetInteger(SCM_CAR(args));
1106 } else {
1107 width = Scm_GetInteger(SCM_CAR(args));
1108 }
1109 args = SCM_CDR(args);
1110 goto fallback;
1111 fallback:
1112 default:
1113 SCM_DSTRING_PUTB(&argbuf, c);
1114 continue;
1115 }
1116 break;
1117 }
1118 if (c == 0) {
1119 Scm_Error("incomplete %%-directive in format string: %s", fmt);
1120 }
1121 }
1122 }
1123
1124 /* Public APIs */
1125
Scm_Vprintf(ScmPort * out,const char * fmt,va_list ap,int sharedp SCM_UNUSED)1126 void Scm_Vprintf(ScmPort *out, const char *fmt, va_list ap,
1127 int sharedp SCM_UNUSED)
1128 {
1129 if (!SCM_OPORTP(out)) Scm_Error("output port required, but got %S", out);
1130
1131 /* TODO: handle sharedp */
1132 ScmObj args = vprintf_pass1(out, fmt, ap);
1133
1134 ScmVM *vm = Scm_VM();
1135 PORT_LOCK(out, vm);
1136 PORT_SAFE_CALL(out, vprintf_pass2(out, fmt, args), /*no cleanup*/);
1137 PORT_UNLOCK(out);
1138 }
1139
Scm_Printf(ScmPort * out,const char * fmt,...)1140 void Scm_Printf(ScmPort *out, const char *fmt, ...)
1141 {
1142 va_list ap;
1143 va_start(ap, fmt);
1144 Scm_Vprintf(out, fmt, ap, FALSE);
1145 va_end(ap);
1146 }
1147
Scm_PrintfShared(ScmPort * out,const char * fmt,...)1148 void Scm_PrintfShared(ScmPort *out, const char *fmt, ...)
1149 {
1150 va_list ap;
1151 va_start(ap, fmt);
1152 Scm_Vprintf(out, fmt, ap, TRUE);
1153 va_end(ap);
1154 }
1155
Scm_Sprintf(const char * fmt,...)1156 ScmObj Scm_Sprintf(const char *fmt, ...)
1157 {
1158 ScmObj r;
1159 va_list args;
1160 va_start(args, fmt);
1161 r = Scm_Vsprintf(fmt, args, FALSE);
1162 va_end(args);
1163 return r;
1164 }
1165
Scm_SprintfShared(const char * fmt,...)1166 ScmObj Scm_SprintfShared(const char *fmt, ...)
1167 {
1168 va_list args;
1169 va_start(args, fmt);
1170 ScmObj r = Scm_Vsprintf(fmt, args, TRUE);
1171 va_end(args);
1172 return r;
1173 }
1174
Scm_Vsprintf(const char * fmt,va_list ap,int sharedp)1175 ScmObj Scm_Vsprintf(const char *fmt, va_list ap, int sharedp)
1176 {
1177 ScmObj ostr = Scm_MakeOutputStringPort(TRUE);
1178 Scm_Vprintf(SCM_PORT(ostr), fmt, ap, sharedp);
1179 return Scm_GetOutputString(SCM_PORT(ostr), 0);
1180 }
1181
1182 /*
1183 * Initialization
1184 */
Scm__InitWrite(void)1185 void Scm__InitWrite(void)
1186 {
1187 Scm_InitBuiltinGeneric(&Scm_GenericWriteObject, "write-object",
1188 Scm_GaucheModule());
1189 defaultWriteControls = Scm_MakeWriteControls(NULL);
1190 }
1191