/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- outlen
- Scm_Write
- Scm_WriteLimited
- Scm_WriteCircular
- write_general
- write_object
- write_object_fallback
- make_walker_port
- write_walk
- write_ss_rec
- write_ss
- format_write
- format_pad
- format_sexp
- format_integer
- format_proc
- Scm_Format
- vprintf_proc
- Scm_Vprintf
- Scm_Printf
- Scm_PrintfShared
- Scm__InitWrite
1 /*
2 * write.c - writer
3 *
4 * Copyright (c) 2000-2004 Shiro Kawai, All rights reserved.
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 * $Id: write.c,v 1.57 2005/10/13 08:14:13 shirok Exp $
34 */
35
36 #include <stdio.h>
37 #include <ctype.h>
38 #define LIBGAUCHE_BODY
39 #include "gauche.h"
40 #include "gauche/port.h"
41 #include "gauche/builtin-syms.h"
42 #include "gauche/code.h" /* NB: for SCM_VM_INSNP -- remove this later */
43
44 static void write_walk(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
45 static void write_ss(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
46 static void write_ss_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
47 static void write_object(ScmObj obj, ScmPort *out, ScmWriteContext *ctx);
48 static ScmObj write_object_fallback(ScmObj *args, int nargs, ScmGeneric *gf);
49 SCM_DEFINE_GENERIC(Scm_GenericWriteObject, write_object_fallback, NULL);
50
51 /*============================================================
52 * Writers
53 */
54
55 /* Note: all internal routine (static functions) assumes the output
56 port is properly locked. */
57
58 /* Note: the current internal structure is in the transient state.
59 handling of writer mode and context should be much better.
60 Do not count on these APIs! */
61
62 /* Note: in order to support write/ss, we need to pass down the context
63 along the call tree. We can think of a few strategies:
64
65 (a) Use separate context argument : this is logically the most natural way.
66 The problem is that the legacy code didn't take the context into
67 account (especially in the printer of user-defined objects).
68
69 (b) Attach context information to the port : this isn't "right", because
70 theoretically a user program may want to mix output of write/ss and
71 other writes into a single port. However, it isn't likely a problem,
72 since (1) the outmost write() call locks the port, hence only one
73 thread can write to the port during a single write/ss call, and
74 (2) the purpose of write/ss is to produce an output which can be
75 read back, so you don't want to mix up other output.
76
77 Another possible drawback is the overhead of dynamic wind in the
78 toplevel write() call (since we need to remove the context information
79 from the port when write() exits non-locally). If the port hasn't
80 been locked, we need a C-level unwind-protect anyway, so it's not
81 a problem. If the port is already locked, extra dynamic wind may
82 impact performance.
83
84 Furthermore, I feel it isn't "right" to modify longer-living data
85 (port) for the sake of local, dynamically-scoped information (context).
86
87 The advantage of this method is that legacy code will work unchanged.
88
89 (c) A variation of (b) is to "wrap" the port by a transient procedural
90 port, which passes through output data to the original port, _and_
91 keeps the context info. This is clean in the sense that it doesn't
92 contaminate the longer-living data (original port) by the transient
93 info. We don't need to worry about dynamic winding as well (we can
94 leave the transient port to be GCed).
95
96 The concern is the overhead of forwarding output via procedural
97 port interface.
98
99 I'm not sure which is the best way in long run; so, as a temporary
100 solution, I use the strategy (b), since it is compatible to the current
101 version. Let's see how it works.
102 */
103
104 #define SPBUFSIZ 50
105
106 /* Two bitmask used internally to indicate extra write mode */
107 #define WRITE_LIMITED 0x10 /* we're limiting the length of output. */
108 #define WRITE_CIRCULAR 0x20 /* circular-safe write. info->table
109 is set up to look up for circular
110 objects. */
111
112 /* VM-default case mode */
113 #define DEFAULT_CASE \
114 (SCM_VM_RUNTIME_FLAG_IS_SET(Scm_VM(), SCM_CASE_FOLD)? \
115 SCM_WRITE_CASE_FOLD:SCM_WRITE_CASE_NOFOLD)
116
117 static inline int outlen(ScmPort *out)
118 {
119 SCM_ASSERT(SCM_PORT_TYPE(out) == SCM_PORT_OSTR);
120 if (out->src.ostr.length < 0) {
121 return Scm_DStringSize(&out->src.ostr);
122 } else {
123 return out->src.ostr.length;
124 }
125 }
126
127 /*
128 * Scm_Write - Standard Write.
129 */
130 void Scm_Write(ScmObj obj, ScmObj p, int mode)
131 {
132 ScmWriteContext ctx;
133 ScmVM *vm;
134 ScmPort *port;
135
136 if (!SCM_OPORTP(p)) {
137 Scm_Error("output port required, but got %S", p);
138 }
139 port = SCM_PORT(p);
140 ctx.mode = mode;
141 ctx.flags = 0;
142
143 /* if this is a "walk" pass of write/ss, dispatch to the walker */
144 if (port->flags & SCM_PORT_WALKING) {
145 SCM_ASSERT(SCM_PAIRP(port->data)&&SCM_HASH_TABLE_P(SCM_CDR(port->data)));
146 write_walk(obj, port, &ctx);
147 return;
148 }
149 /* if this is a "output" pass of write/ss, call the recursive routine */
150 if (port->flags & SCM_PORT_WRITESS) {
151 SCM_ASSERT(SCM_PAIRP(port->data)&&SCM_HASH_TABLE_P(SCM_CDR(port->data)));
152 write_ss_rec(obj, port, &ctx);
153 return;
154 }
155
156 /* if case mode is not specified, use default taken from VM default */
157 if (SCM_WRITE_CASE(&ctx) == 0) ctx.mode |= DEFAULT_CASE;
158
159 vm = Scm_VM();
160 PORT_LOCK(port, vm);
161 if (SCM_WRITE_MODE(&ctx) == SCM_WRITE_SHARED) {
162 PORT_SAFE_CALL(port, write_ss(obj, port, &ctx));
163 } else {
164 PORT_SAFE_CALL(port, write_ss_rec(obj, port, &ctx));
165 }
166 PORT_UNLOCK(port);
167 }
168
169 /*
170 * Scm_WriteLimited - Write to limited length.
171 *
172 * Characters exceeding WIDTH are truncated.
173 * If the output fits within WIDTH, # of characters actually written
174 * is returned. Othewise, -1 is returned.
175 *
176 * Current implementation is sloppy, potentially wasting time to write
177 * objects which will be just discarded.
178 */
179 int Scm_WriteLimited(ScmObj obj, ScmObj port, int mode, int width)
180 {
181 ScmWriteContext ctx;
182 ScmObj out;
183 int nc;
184
185 if (!SCM_OPORTP(port))
186 Scm_Error("output port required, but got %S", port);
187 out = Scm_MakeOutputStringPort(TRUE);
188 ctx.mode = mode;
189 ctx.flags = WRITE_LIMITED;
190 ctx.limit = width;
191 /* if case mode is not specified, use default taken from VM default */
192 if (SCM_WRITE_CASE(&ctx) == 0) ctx.mode |= DEFAULT_CASE;
193 /* we don't need to lock out, for it is private. */
194 write_ss_rec(obj, SCM_PORT(out), &ctx);
195 nc = outlen(SCM_PORT(out));
196 if (nc > width) {
197 ScmObj sub = Scm_Substring(SCM_STRING(Scm_GetOutputString(SCM_PORT(out))),
198 0, width);
199 SCM_PUTS(sub, port); /* this locks port */
200 return -1;
201 } else {
202 SCM_PUTS(Scm_GetOutputString(SCM_PORT(out)), port); /* this locks port */
203 return nc;
204 }
205 }
206
207 /*
208 * Scm_WriteCircular - circular-safe writer
209 */
210
211 int Scm_WriteCircular(ScmObj obj, ScmObj port, int mode, int width)
212 {
213 ScmWriteContext ctx;
214 int nc;
215
216 if (!SCM_OPORTP(port)) {
217 Scm_Error("output port required, but got %S", port);
218 }
219 ctx.mode = mode;
220 ctx.flags = WRITE_CIRCULAR;
221 if (SCM_WRITE_CASE(&ctx) == 0) ctx.mode |= DEFAULT_CASE;
222 if (width > 0) {
223 ctx.flags |= WRITE_LIMITED;
224 ctx.limit = width;
225 }
226 ctx.ncirc = 0;
227 ctx.table = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_EQ, 8));
228
229 if (width > 0) {
230 ScmObj out = Scm_MakeOutputStringPort(TRUE);
231 /* no need to lock out, for it is private */
232 write_ss(obj, SCM_PORT(out), &ctx);
233 nc = outlen(SCM_PORT(out));
234 if (nc > width) {
235 ScmObj sub = Scm_Substring(SCM_STRING(Scm_GetOutputString(SCM_PORT(out))),
236 0, width);
237 SCM_PUTS(sub, port); /* this locks port */
238 return -1;
239 } else {
240 SCM_PUTS(Scm_GetOutputString(SCM_PORT(out)), port); /* this locks port */
241 return nc;
242 }
243 } else {
244 ScmVM *vm = Scm_VM();
245 PORT_LOCK(SCM_PORT(port), vm);
246 PORT_SAFE_CALL(SCM_PORT(port),
247 write_ss(obj, SCM_PORT(port), &ctx));
248 PORT_UNLOCK(SCM_PORT(port));
249 }
250 return 0;
251 }
252
253 /*===================================================================
254 * Internal writer
255 */
256
257 /* character name table (first 33 chars of ASCII)*/
258 static const char *char_names[] = {
259 "null", "x01", "x02", "x03", "x04", "x05", "x06", "x07",
260 "x08", "tab", "newline","x0b", "x0c", "return","x0e", "x0f",
261 "x10", "x11", "x12", "x13", "x14", "x15", "x16", "x17",
262 "x18", "x19", "x1a", "escape","x1c", "x1d", "x1e", "x1f",
263 "space"
264 };
265
266 #define CASE_ITAG(obj, str) \
267 case SCM_ITAG(obj): Scm_PutzUnsafe(str, -1, port); break;
268
269 /* Obj is PTR, except pair and vector */
270 static void write_general(ScmObj obj, ScmPort *out, ScmWriteContext *ctx)
271 {
272 ScmClass *c = Scm_ClassOf(obj);
273 if (c->print) c->print(obj, out, ctx);
274 else write_object(obj, out, ctx);
275 }
276
277 /* Default object printer delegates print action to generic function
278 write-object. We can't use VMApply here since this function can be
279 called deep in the recursive stack of Scm_Write, so the control
280 may not return to VM immediately. */
281 static void write_object(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
282 {
283 Scm_Apply(SCM_OBJ(&Scm_GenericWriteObject), SCM_LIST2(obj, SCM_OBJ(port)));
284 }
285
286 /* Default method for write-object */
287 static ScmObj write_object_fallback(ScmObj *args, int nargs, ScmGeneric *gf)
288 {
289 ScmClass *klass;
290 if (nargs != 2 || (nargs == 2 && !SCM_OPORTP(args[1]))) {
291 Scm_Error("No applicable method for write-object with %S",
292 Scm_ArrayToList(args, nargs));
293 }
294 klass = Scm_ClassOf(args[0]);
295 Scm_Printf(SCM_PORT(args[1]), "#<%A %p>", klass->name, args[0]);
296 return SCM_TRUE;
297 }
298
299 /* We need two passes to realize write/ss.
300
301 The first pass ("walk" pass) traverses the data and finds out
302 all shared substructures and/or cyclic references. It builds a
303 hash table of objects that need special treatment.
304
305 The second pass ("output" pass) writes out the data.
306
307 For the walk pass, we can't use generic traversal algorithm
308 if the data contains user-defined structures. In which case,
309 we delegate the walk task to the user-defined print routine.
310 In the walk pass, a special dummy port is created. It is a
311 procedural port to which all output is discarded. If the
312 user-defined routine needs to traverse substructure, it calls
313 back system's writer routine such as Scm_Write, Scm_Printf,
314 so we can effectively traverse entire data to be printed.
315
316 */
317
318 /* Dummy port for the walk pass */
319 static ScmPortVTable walker_port_vtable = {
320 NULL, NULL, NULL, NULL, NULL,
321 NULL, NULL, NULL, NULL, NULL,
322 NULL, NULL
323 };
324
325 static ScmPort *make_walker_port(void)
326 {
327 ScmPort *port;
328 ScmObj ht;
329
330 port = SCM_PORT(Scm_MakeVirtualPort(SCM_CLASS_PORT, SCM_PORT_OUTPUT,
331 &walker_port_vtable));
332 ht = Scm_MakeHashTableSimple(SCM_HASH_EQ, 0);
333 port->data = Scm_Cons(SCM_MAKE_INT(0), ht);
334 port->flags = SCM_PORT_WALKING;
335 return port;
336 }
337
338 /* pass 1 */
339 static void write_walk(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
340 {
341 ScmHashEntry *e;
342 ScmHashTable *ht;
343 ScmObj elt;
344
345 ht = SCM_HASH_TABLE(SCM_CDR(port->data));
346
347 for (;;) {
348 if (!SCM_PTRP(obj) || SCM_SYMBOLP(obj) || SCM_KEYWORDP(obj)
349 || SCM_NUMBERP(obj)) {
350 return;
351 }
352
353 if (SCM_PAIRP(obj)) {
354 e = Scm_HashTableGet(ht, obj);
355 if (e) { e->value = SCM_TRUE; return; }
356 Scm_HashTablePut(ht, obj, SCM_FALSE);
357
358 elt = SCM_CAR(obj);
359 if (SCM_PTRP(elt)) write_walk(SCM_CAR(obj), port, ctx);
360 obj = SCM_CDR(obj);
361 continue;
362 }
363 if (SCM_STRINGP(obj) && !SCM_STRING_NULL_P(obj)) {
364 e = Scm_HashTableGet(ht, obj);
365 if (e) { e->value = SCM_TRUE; return; }
366 Scm_HashTablePut(ht, obj, SCM_FALSE);
367 return;
368 }
369 if (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) > 0) {
370 int i, len = SCM_VECTOR_SIZE(obj);
371
372 e = Scm_HashTableGet(ht, obj);
373 if (e) { e->value = SCM_TRUE; return; }
374 Scm_HashTablePut(ht, obj, SCM_FALSE);
375
376 for (i=0; i<len; i++) {
377 elt = SCM_VECTOR_ELEMENT(obj, i);
378 if (SCM_PTRP(elt)) write_walk(elt, port, ctx);
379 }
380 return;
381 }
382 else {
383 /* Now we have user-defined object.
384 Call the user's print routine. */
385 e = Scm_HashTableGet(ht, obj);
386 if (e) { e->value = SCM_TRUE; return; }
387 Scm_HashTablePut(ht, obj, SCM_FALSE);
388
389 write_general(obj, port, ctx);
390 return;
391 }
392 }
393 }
394
395 /* pass 2 */
396 static void write_ss_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
397 {
398 ScmHashEntry *e;
399 char numbuf[50]; /* enough to contain long number */
400 ScmHashTable *ht = NULL;
401
402 if (ctx->flags & WRITE_LIMITED) {
403 if (outlen(port) >= ctx->limit) return;
404 }
405
406 if (SCM_PAIRP(port->data) && SCM_HASH_TABLE_P(SCM_CDR(port->data))) {
407 ht = SCM_HASH_TABLE(SCM_CDR(port->data));
408 }
409
410 if (!SCM_PTRP(obj)) {
411 if (SCM_IMMEDIATEP(obj)) {
412 switch (SCM_ITAG(obj)) {
413 CASE_ITAG(SCM_FALSE, "#f");
414 CASE_ITAG(SCM_TRUE, "#t");
415 CASE_ITAG(SCM_NIL, "()");
416 CASE_ITAG(SCM_EOF, "#<eof>");
417 CASE_ITAG(SCM_UNDEFINED, "#<undef>");
418 CASE_ITAG(SCM_UNBOUND, "#<unbound>");
419 default:
420 Scm_Panic("write: unknown itag object: %08x", SCM_WORD(obj));
421 }
422 }
423 else if (SCM_INTP(obj)) {
424 char buf[SPBUFSIZ];
425 snprintf(buf, SPBUFSIZ, "%ld", SCM_INT_VALUE(obj));
426 Scm_PutzUnsafe(buf, -1, port);
427 }
428 else if (SCM_CHARP(obj)) {
429 ScmChar ch = SCM_CHAR_VALUE(obj);
430 if (SCM_WRITE_MODE(ctx) == SCM_WRITE_DISPLAY) {
431 Scm_PutcUnsafe(ch, port);
432 } else {
433 Scm_PutzUnsafe("#\\", -1, port);
434 if (ch <= 0x20) Scm_PutzUnsafe(char_names[ch], -1, port);
435 else if (ch == 0x7f) Scm_PutzUnsafe("del", -1, port);
436 else Scm_PutcUnsafe(ch, port);
437 }
438 }
439 else Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
440 return;
441 }
442 if (SCM_NUMBERP(obj)) {
443 /* number may be heap allocated, but we don't use srfi-38 notation. */
444 write_general(obj, port, ctx);
445 return;
446 }
447
448 if ((SCM_STRINGP(obj) && SCM_STRING_NULL_P(obj))
449 || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
450 /* special case where we don't put a reference tag. */
451 write_general(obj, port, ctx);
452 return;
453 }
454
455 if (ht) {
456 e = Scm_HashTableGet(ht, obj);
457 if (e && e->value != SCM_FALSE) {
458 if (SCM_INTP(e->value)) {
459 /* This object is already printed. */
460 snprintf(numbuf, 50, "#%ld#", SCM_INT_VALUE(e->value));
461 Scm_PutzUnsafe(numbuf, -1, port);
462 return;
463 } else {
464 /* This object will be seen again. Put a reference tag. */
465 int count = SCM_INT_VALUE(SCM_CAR(port->data));
466 snprintf(numbuf, 50, "#%d=", count);
467 e->value = SCM_MAKE_INT(count);
468 SCM_SET_CAR(port->data, SCM_MAKE_INT(count+1));
469 Scm_PutzUnsafe(numbuf, -1, port);
470 }
471 }
472 }
473
474 /* Writes aggregates */
475 if (SCM_PAIRP(obj)) {
476 /* special case for quote etc.*/
477 if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))) {
478 int special = TRUE;
479 if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
480 Scm_PutcUnsafe('\'', port);
481 } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
482 Scm_PutcUnsafe('`', port);
483 } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
484 Scm_PutcUnsafe(',', port);
485 } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
486 Scm_PutzUnsafe(",@", -1, port);
487 } else {
488 special = FALSE;
489 }
490 if (special) {
491 write_ss_rec(SCM_CADR(obj), port, ctx);
492 return;
493 }
494 }
495
496 /* normal case */
497 Scm_PutcUnsafe('(', port);
498 for (;;) {
499
500 write_ss_rec(SCM_CAR(obj), port, ctx);
501
502 obj = SCM_CDR(obj);
503 if (SCM_NULLP(obj)) { Scm_PutcUnsafe(')', port); return; }
504 if (!SCM_PAIRP(obj)) {
505 Scm_PutzUnsafe(" . ", -1, port);
506 write_ss_rec(obj, port, ctx);
507 Scm_PutcUnsafe(')', port);
508 return;
509 }
510 if (ht) {
511 e = Scm_HashTableGet(ht, obj); /* check for shared cdr */
512 if (e && e->value != SCM_FALSE) {
513 Scm_PutzUnsafe(" . ", -1, port);
514 write_ss_rec(obj, port, ctx);
515 Scm_PutcUnsafe(')', port);
516 return;
517 }
518 }
519 Scm_PutcUnsafe(' ', port);
520 }
521 } else if (SCM_VECTORP(obj)) {
522 int len, i;
523 ScmObj *elts;
524
525 Scm_PutzUnsafe("#(", -1, port);
526 len = SCM_VECTOR_SIZE(obj);
527 elts = SCM_VECTOR_ELEMENTS(obj);
528 for (i=0; i<len-1; i++) {
529 write_ss_rec(elts[i], port, ctx);
530 Scm_PutcUnsafe(' ', port);
531 }
532 write_ss_rec(elts[i], port, ctx);
533 Scm_PutcUnsafe(')', port);
534 } else {
535 /* string or user-defined object */
536 write_general(obj, port, ctx);
537 }
538 }
539
540 /* Write/ss main driver
541 NB: this should never be called recursively. */
542 static void write_ss(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
543 {
544 ScmPort *walker_port = make_walker_port();
545
546 /* pass 1 */
547 write_walk(obj, walker_port, ctx);
548 Scm_ClosePort(walker_port);
549
550 /* pass 2 */
551 /* TODO: we need to rewind port mode */
552 port->data = walker_port->data;
553 port->flags |= SCM_PORT_WRITESS;
554 write_ss_rec(obj, port, ctx);
555 port->data = SCM_FALSE;
556 port->flags &= ~SCM_PORT_WRITESS;
557 }
558
559 /*===================================================================
560 * Formatters
561 */
562
563 /* TODO: provide option to compile format string. */
564
565 #define NEXT_ARG(arg, args) \
566 do { \
567 if (!SCM_PAIRP(args)) \
568 Scm_Error("too few arguments for format string: %S", fmt); \
569 arg = SCM_CAR(args); \
570 args = SCM_CDR(args); \
571 argcnt++; \
572 } while (0)
573
574 /* max # of parameters for a format directive */
575 #define MAX_PARAMS 5
576
577 /* dispatch to proper writer */
578 static void format_write(ScmObj obj, ScmPort *port, ScmWriteContext *ctx,
579 int sharedp)
580 {
581 if (port->flags & SCM_PORT_WALKING) {
582 SCM_ASSERT(SCM_PAIRP(port->data)&&SCM_HASH_TABLE_P(SCM_CDR(port->data)));
583 write_walk(obj, port, ctx);
584 return;
585 }
586 if (port->flags & SCM_PORT_WRITESS) {
587 SCM_ASSERT(SCM_PAIRP(port->data)&&SCM_HASH_TABLE_P(SCM_CDR(port->data)));
588 write_ss_rec(obj, port, ctx);
589 return;
590 }
591 if (sharedp) {
592 write_ss(obj, port, ctx);
593 } else {
594 write_ss_rec(obj, port, ctx);
595 }
596 }
597
598 /* output string with padding */
599 static void format_pad(ScmPort *out, ScmString *str,
600 int mincol, int colinc, ScmChar padchar,
601 int rightalign)
602 {
603 int padcount = mincol- SCM_STRING_BODY_LENGTH(SCM_STRING_BODY(str));
604 int i;
605
606 if (padcount > 0) {
607 if (colinc > 1) {
608 padcount = ((padcount+colinc-1)/colinc)*colinc;
609 }
610 if (rightalign) {
611 for (i=0; i<padcount; i++) Scm_PutcUnsafe(padchar, out);
612 }
613 Scm_PutsUnsafe(str, SCM_PORT(out));
614 if (!rightalign) {
615 for (i=0; i<padcount; i++) Scm_PutcUnsafe(padchar, out);
616 }
617 } else {
618 Scm_PutsUnsafe(str, out);
619 }
620 }
621
622 /* ~s and ~a writer */
623 static void format_sexp(ScmPort *out, ScmObj arg,
624 ScmObj *params, int nparams,
625 int rightalign, int dots, int mode)
626 {
627 int mincol = 0, colinc = 1, minpad = 0, maxcol = -1, nwritten = 0, i;
628 ScmChar padchar = ' ';
629 ScmObj tmpout = Scm_MakeOutputStringPort(TRUE);
630 ScmString *tmpstr;
631
632 if (nparams>0 && SCM_INTP(params[0])) mincol = SCM_INT_VALUE(params[0]);
633 if (nparams>1 && SCM_INTP(params[1])) colinc = SCM_INT_VALUE(params[1]);
634 if (nparams>2 && SCM_INTP(params[2])) minpad = SCM_INT_VALUE(params[2]);
635 if (nparams>3 && SCM_CHARP(params[3])) padchar = SCM_CHAR_VALUE(params[3]);
636 if (nparams>4 && SCM_INTP(params[4])) maxcol = SCM_INT_VALUE(params[4]);
637
638 if (minpad > 0 && rightalign) {
639 for (i=0; i<minpad; i++) Scm_PutcUnsafe(padchar, SCM_PORT(tmpout));
640 }
641 if (maxcol > 0) {
642 nwritten = Scm_WriteLimited(arg, tmpout, mode, maxcol);
643 } else {
644 Scm_Write(arg, tmpout, mode);
645 }
646 if (minpad > 0 && !rightalign) {
647 for (i=0; i<minpad; i++) Scm_PutcUnsafe(padchar, SCM_PORT(tmpout));
648 }
649 tmpstr = SCM_STRING(Scm_GetOutputString(SCM_PORT(tmpout)));
650
651 if (maxcol > 0 && nwritten < 0) {
652 const char *s = Scm_GetStringContent(tmpstr, NULL, NULL, NULL), *e;
653 if (dots && maxcol > 4) {
654 e = Scm_StringPosition(tmpstr, maxcol-4);
655 Scm_PutzUnsafe(s, e-s, out);
656 Scm_PutzUnsafe(" ...", 4, out);
657 } else {
658 e = Scm_StringPosition(tmpstr, maxcol);
659 Scm_PutzUnsafe(s, e-s, out);
660 }
661 } else {
662 format_pad(out, tmpstr, mincol, colinc, padchar, rightalign);
663 }
664 }
665
666 /* ~d, ~b, ~o, and ~x */
667 static void format_integer(ScmPort *out, ScmObj arg,
668 ScmObj *params, int nparams, int radix,
669 int delimited, int alwayssign, int use_upper)
670 {
671 int mincol = 0, commainterval = 3;
672 ScmChar padchar = ' ', commachar = ',';
673 ScmObj str;
674 if (!Scm_IntegerP(arg)) {
675 /* if arg is not an integer, use ~a */
676 ScmWriteContext ictx;
677 ictx.mode = SCM_WRITE_DISPLAY;
678 ictx.flags = 0;
679 format_write(arg, out, &ictx, FALSE);
680 return;
681 }
682 if (SCM_FLONUMP(arg)) arg = Scm_InexactToExact(arg);
683 if (nparams>0 && SCM_INTP(params[0])) mincol = SCM_INT_VALUE(params[0]);
684 if (nparams>1 && SCM_CHARP(params[1])) padchar = SCM_CHAR_VALUE(params[1]);
685 if (nparams>2 && SCM_CHARP(params[2])) commachar = SCM_CHAR_VALUE(params[2]);
686 if (nparams>3 && SCM_INTP(params[3])) commainterval = SCM_INT_VALUE(params[3]);
687 str = Scm_NumberToString(arg, radix, use_upper);
688 if (alwayssign && SCM_STRING_BODY_START(SCM_STRING_BODY(str))[0] != '-') {
689 str = Scm_StringAppend2(SCM_STRING(SCM_MAKE_STR("+")),
690 SCM_STRING(str));
691 }
692 if (delimited && commainterval) {
693 /* Delimited output. We use char*, for str never contains
694 mbchar. */
695 /* NB: I think the specification of delimited behavior in CLtL2
696 contradicts its examples; it is ambiguous about what happens
697 if the number is padded. */
698 ScmDString tmpout;
699 u_int num_digits, colcnt;
700 const char *ptr = Scm_GetStringContent(SCM_STRING(str), &num_digits,
701 NULL, NULL);
702
703 Scm_DStringInit(&tmpout);
704 if (*ptr == '-' || *ptr == '+') {
705 Scm_DStringPutc(&tmpout, *ptr);
706 ptr++;
707 num_digits--;
708 }
709 colcnt = num_digits % commainterval;
710 if (colcnt != 0) Scm_DStringPutz(&tmpout, ptr, colcnt);
711 while (colcnt < num_digits) {
712 if (colcnt != 0) Scm_DStringPutc(&tmpout, commachar);
713 Scm_DStringPutz(&tmpout, ptr+colcnt, commainterval);
714 colcnt += commainterval;
715 }
716 str = Scm_DStringGet(&tmpout, 0);
717 }
718 format_pad(out, SCM_STRING(str), mincol, 1, padchar, TRUE);
719 }
720
721 static void format_proc(ScmPort *out, ScmString *fmt, ScmObj args, int sharedp)
722 {
723 ScmChar ch = 0;
724 ScmObj arg, oargs = args;
725 ScmPort *fmtstr = SCM_PORT(Scm_MakeInputStringPort(fmt, FALSE));
726 int backtracked = FALSE; /* true if ~:* is used */
727 int arglen, argcnt;
728 ScmWriteContext sctx, actx; /* context for ~s and ~a */
729
730 arglen = Scm_Length(args);
731 argcnt = 0;
732
733 sctx.mode = SCM_WRITE_WRITE;
734 sctx.flags = 0;
735 actx.mode = SCM_WRITE_DISPLAY;
736 actx.flags = 0;
737
738 for (;;) {
739 int atflag, colonflag;
740 ScmObj params[MAX_PARAMS];
741 int numParams;
742
743 ch = Scm_GetcUnsafe(fmtstr);
744 if (ch == EOF) {
745 if (!backtracked && !SCM_NULLP(args)) {
746 Scm_Error("too many arguments for format string: %S", fmt);
747 }
748 return;
749 }
750
751 if (ch != '~') {
752 Scm_PutcUnsafe(ch, out);
753 continue;
754 }
755
756 numParams = 0;
757 atflag = colonflag = FALSE;
758
759 for (;;) {
760 ch = Scm_GetcUnsafe(fmtstr);
761 switch (ch) {
762 case '%':
763 Scm_PutcUnsafe('\n', out);
764 break;
765 case 's':; case 'S':;
766 NEXT_ARG(arg, args);
767 if (numParams == 0) {
768 format_write(arg, out, &sctx, sharedp);
769 } else {
770 format_sexp(out, arg, params, numParams, atflag,
771 colonflag, SCM_WRITE_WRITE);
772 }
773 break;
774 case 'a':; case 'A':;
775 NEXT_ARG(arg, args);
776 if (numParams == 0) {
777 /* short path */
778 format_write(arg, out, &actx, sharedp);
779 } else {
780 format_sexp(out, arg, params, numParams, atflag,
781 colonflag, SCM_WRITE_DISPLAY);
782 }
783 break;
784 case 'd':; case 'D':;
785 NEXT_ARG(arg, args);
786 if (numParams == 0 && !atflag && !colonflag) {
787 format_write(arg, out, &actx, FALSE);
788 } else {
789 format_integer(out, arg, params, numParams, 10,
790 colonflag, atflag, FALSE);
791 }
792 break;
793 case 'b':; case 'B':;
794 NEXT_ARG(arg, args);
795 if (numParams == 0 && !atflag && !colonflag) {
796 if (Scm_IntegerP(arg)) {
797 format_write(Scm_NumberToString(arg, 2, FALSE), out,
798 &actx, FALSE);
799 } else {
800 format_write(arg, out, &actx, FALSE);
801 }
802 } else {
803 format_integer(out, arg, params, numParams, 2,
804 colonflag, atflag, FALSE);
805 }
806 break;
807 case 'o':; case 'O':;
808 NEXT_ARG(arg, args);
809 if (numParams == 0 && !atflag && !colonflag) {
810 if (Scm_IntegerP(arg)) {
811 format_write(Scm_NumberToString(arg, 8, FALSE), out,
812 &actx, FALSE);
813 } else {
814 format_write(arg, out, &actx, FALSE);
815 }
816 } else {
817 format_integer(out, arg, params, numParams, 8,
818 colonflag, atflag, FALSE);
819 }
820 break;
821 case 'x':; case 'X':;
822 NEXT_ARG(arg, args);
823 if (numParams == 0 && !atflag && !colonflag) {
824 if (Scm_IntegerP(arg)) {
825 format_write(Scm_NumberToString(arg, 16, ch == 'X'),
826 out, &actx, FALSE);
827 } else {
828 format_write(arg, out, &actx, FALSE);
829 }
830 } else {
831 format_integer(out, arg, params, numParams, 16,
832 colonflag, atflag, ch == 'X');
833 }
834 break;
835 case '*':
836 {
837 int argindex;
838 if (numParams) {
839 if (!SCM_INTP(params[0])) goto badfmt;
840 argindex = SCM_INT_VALUE(params[0]);
841 } else {
842 argindex = 1;
843 }
844 if (colonflag) {
845 if (atflag) goto badfmt;
846 argindex = argcnt - argindex;
847 backtracked = TRUE;
848 } else if (!atflag) {
849 argindex = argcnt + argindex;
850 } else {
851 backtracked = TRUE;
852 }
853 if (argindex < 0 || argindex >= arglen) {
854 Scm_Error("'~*' format directive refers outside of argument list in %S", fmt);
855 }
856 argcnt = argindex;
857 args = Scm_ListTail(oargs, argcnt, SCM_UNBOUND);
858 break;
859 }
860 case 'v':; case 'V':;
861 if (atflag || colonflag || numParams >= MAX_PARAMS)
862 goto badfmt;
863 NEXT_ARG(arg, args);
864 if (!SCM_FALSEP(arg) && !SCM_INTP(arg) && !SCM_CHARP(arg)) {
865 Scm_Error("argument for 'v' format parameter in %S should be either an integer, a character or #f, but got %S",
866 fmt, arg);
867 }
868 params[numParams++] = arg;
869 ch = Scm_GetcUnsafe(fmtstr);
870 if (ch != ',') Scm_UngetcUnsafe(ch, fmtstr);
871 continue;
872 case '@':
873 if (atflag) {
874 Scm_Error("too many @-flag for formatting directive: %S",
875 fmt);
876 }
877 atflag = TRUE;
878 continue;
879 case ':':
880 if (colonflag) {
881 Scm_Error("too many :-flag for formatting directive: %S",
882 fmt);
883 }
884 colonflag = TRUE;
885 continue;
886 case '\'':
887 if (atflag || colonflag) goto badfmt;
888 if (numParams >= MAX_PARAMS) goto badfmt;
889 ch = Scm_GetcUnsafe(fmtstr);
890 if (ch == EOF) goto badfmt;
891 params[numParams++] = SCM_MAKE_CHAR(ch);
892 ch = Scm_GetcUnsafe(fmtstr);
893 if (ch != ',') Scm_UngetcUnsafe(ch, fmtstr);
894 continue;
895 case '0':; case '1':; case '2':; case '3':; case '4':;
896 case '5':; case '6':; case '7':; case '8':; case '9':;
897 case '-':; case '+':;
898 if (atflag || colonflag || numParams >= MAX_PARAMS) {
899 goto badfmt;
900 } else {
901 int sign = (ch == '-')? -1 : 1;
902 unsigned long value = isdigit(ch)? (ch - '0') : 0;
903 for (;;) {
904 ch = Scm_GetcUnsafe(fmtstr);
905 /* TODO: check valid character */
906 if (!isdigit(ch)) {
907 if (ch != ',') Scm_UngetcUnsafe(ch, fmtstr);
908 params[numParams++] = Scm_MakeInteger(sign*value);
909 break;
910 }
911 /* TODO: check overflow */
912 value = value * 10 + (ch - '0');
913 }
914 }
915 continue;
916 case ',':
917 if (atflag || colonflag || numParams >= MAX_PARAMS) {
918 goto badfmt;
919 } else {
920 params[numParams++] = SCM_FALSE;
921 continue;
922 }
923 default:
924 Scm_PutcUnsafe(ch, out);
925 break;
926 }
927 break;
928 }
929 }
930 badfmt:
931 Scm_Error("illegal format string: %S", fmt);
932 return; /* dummy */
933 }
934
935 void Scm_Format(ScmPort *out, ScmString *fmt, ScmObj args, int sharedp)
936 {
937 ScmVM *vm;
938
939 if (!SCM_OPORTP(out)) {
940 Scm_Error("output port required, but got %S", out);
941 }
942
943 vm = Scm_VM();
944 PORT_LOCK(out, vm);
945 PORT_SAFE_CALL(out, format_proc(SCM_PORT(out), fmt, args, sharedp));
946 PORT_UNLOCK(out);
947 }
948
949 /*
950 * Printf()-like formatters
951 *
952 * These functions are familiar to C-programmers. The differences
953 * from C's printf() family are:
954 *
955 * - The first argument must be Scheme output port.
956 * - In the format string, the following conversion directives can
957 * be used, as well as the standard printf() directives:
958 *
959 * %[width][.prec]S - The corresponding argument must be
960 * ScmObj, which is written out by WRITE
961 * mode. If width is specified and no
962 * prec is given, the output is padded
963 * if it is shorter than width. If both
964 * width and prec are given, the output
965 * is truncated if it is wider than width.
966 *
967 * %[width][.prec]A - Same as %S, but use DISPLAY mode.
968 *
969 * %C - Take ScmChar argument and outputs it.
970 *
971 * Both functions return a number of characters written.
972 */
973
974 struct vprintf_ctx {
975 const char *fmt;
976 ScmObj args;
977 };
978
979 /* NB: Scm_Vprintf scans format string twice. In the first pass, arguments
980 * are retrieved from va_list variable and pushed to a list. In the second
981 * pass, they are printed according to the format string.
982 * It is necessary because we need to do the printing part within a closure
983 * called by Scm_WithPortLocking. On some architecture, we can't pass
984 * va_list type of argument in a closure packet easily.
985 */
986
987 static void vprintf_proc(ScmPort *out, const char *fmt, ScmObj args,
988 int sharedp)
989 {
990 const char *fmtp = fmt;
991 ScmObj val;
992 ScmDString argbuf;
993 char buf[SPBUFSIZ];
994 int c, longp = 0, len, mode;
995
996 while ((c = *fmtp++) != 0) {
997 int width, prec, dot_appeared, pound_appeared;
998
999 if (c != '%') {
1000 Scm_PutcUnsafe(c, out);
1001 continue;
1002 }
1003
1004 Scm_DStringInit(&argbuf);
1005 SCM_DSTRING_PUTB(&argbuf, c);
1006 width = 0, prec = 0, dot_appeared = 0, pound_appeared = 0;
1007 while ((c = *fmtp++) != 0) {
1008 switch (c) {
1009 case 'l':
1010 longp++;
1011 SCM_DSTRING_PUTB(&argbuf, c);
1012 continue;
1013 case 'd':; case 'i':; case 'c':
1014 {
1015 SCM_ASSERT(SCM_PAIRP(args));
1016 val = SCM_CAR(args);
1017 args = SCM_CDR(args);
1018 SCM_ASSERT(SCM_EXACTP(val));
1019 SCM_DSTRING_PUTB(&argbuf, c);
1020 SCM_DSTRING_PUTB(&argbuf, 0);
1021 snprintf(buf, SPBUFSIZ, Scm_DStringGetz(&argbuf),
1022 Scm_GetInteger(val));
1023 Scm_PutzUnsafe(buf, -1, out);
1024 break;
1025 }
1026 case 'o':; case 'u':; case 'x':; case 'X':
1027 {
1028 SCM_ASSERT(SCM_PAIRP(args));
1029 val = SCM_CAR(args);
1030 args = SCM_CDR(args);
1031 SCM_ASSERT(SCM_EXACTP(val));
1032 SCM_DSTRING_PUTB(&argbuf, c);
1033 SCM_DSTRING_PUTB(&argbuf, 0);
1034 snprintf(buf, SPBUFSIZ, Scm_DStringGetz(&argbuf),
1035 Scm_GetUInteger(val));
1036 Scm_PutzUnsafe(buf, -1, out);
1037 break;
1038 }
1039 case 'e':; case 'E':; case 'f':; case 'g':; case 'G':
1040 {
1041 SCM_ASSERT(SCM_PAIRP(args));
1042 val = SCM_CAR(args);
1043 args = SCM_CDR(args);
1044 SCM_ASSERT(SCM_FLONUMP(val));
1045 SCM_DSTRING_PUTB(&argbuf, c);
1046 SCM_DSTRING_PUTB(&argbuf, 0);
1047 snprintf(buf, SPBUFSIZ, Scm_DStringGetz(&argbuf),
1048 Scm_GetDouble(val));
1049 Scm_PutzUnsafe(buf, -1, out);
1050 break;
1051 }
1052 case 's':;
1053 {
1054 SCM_ASSERT(SCM_PAIRP(args));
1055 val = SCM_CAR(args);
1056 args = SCM_CDR(args);
1057 SCM_ASSERT(SCM_STRINGP(val));
1058 Scm_PutsUnsafe(SCM_STRING(val), out);
1059
1060 /* TODO: support right adjustment such as %-10s.
1061 Currently we ignore minus sign and pad chars
1062 on the right. */
1063 for (len = SCM_STRING_BODY_LENGTH(SCM_STRING_BODY(val));
1064 len < width;
1065 len++) {
1066 Scm_PutcUnsafe(' ', out);
1067 }
1068 break;
1069 }
1070 case '%':;
1071 {
1072 Scm_PutcUnsafe('%', out);
1073 break;
1074 }
1075 case 'p':
1076 {
1077 SCM_ASSERT(SCM_PAIRP(args));
1078 val = SCM_CAR(args);
1079 args = SCM_CDR(args);
1080 SCM_ASSERT(SCM_EXACTP(val));
1081 SCM_DSTRING_PUTB(&argbuf, c);
1082 SCM_DSTRING_PUTB(&argbuf, 0);
1083 snprintf(buf, SPBUFSIZ, Scm_DStringGetz(&argbuf),
1084 (void*)Scm_GetUInteger(val));
1085 Scm_PutzUnsafe(buf, -1, out);
1086 break;
1087 }
1088 case 'S':; case 'A':
1089 {
1090 ScmWriteContext wctx;
1091
1092 SCM_ASSERT(SCM_PAIRP(args));
1093 val = SCM_CAR(args);
1094 args = SCM_CDR(args);
1095
1096 mode = (c == 'A')? SCM_WRITE_DISPLAY : SCM_WRITE_WRITE;
1097 wctx.mode = mode | DEFAULT_CASE;
1098 wctx.flags = 0;
1099
1100 if (pound_appeared) {
1101 int n = Scm_WriteCircular(val, SCM_OBJ(out), mode, width);
1102 if (n < 0 && prec > 0) {
1103 Scm_PutzUnsafe(" ...", -1, out);
1104 }
1105 if (n > 0) {
1106 for (; n < prec; n++) Scm_PutcUnsafe(' ', out);
1107 }
1108 } else if (width == 0) {
1109 format_write(val, out, &wctx, sharedp);
1110 } else if (dot_appeared) {
1111 int n = Scm_WriteLimited(val, SCM_OBJ(out), mode, width);
1112 if (n < 0 && prec > 0) {
1113 Scm_PutzUnsafe(" ...", -1, out);
1114 }
1115 if (n > 0) {
1116 for (; n < prec; n++) Scm_PutcUnsafe(' ', out);
1117 }
1118 } else {
1119 format_write(val, out, &wctx, sharedp);
1120 }
1121 break;
1122 }
1123 case 'C':
1124 {
1125 SCM_ASSERT(SCM_PAIRP(args));
1126 val = SCM_CAR(args);
1127 args = SCM_CDR(args);
1128 SCM_ASSERT(SCM_EXACTP(val));
1129 Scm_PutcUnsafe(Scm_GetInteger(val), out);
1130 break;
1131 }
1132 case '0':; case '1':; case '2':; case '3':; case '4':;
1133 case '5':; case '6':; case '7':; case '8':; case '9':
1134 if (dot_appeared) {
1135 prec = prec*10 + (c - '0');
1136 } else {
1137 width = width*10 + (c - '0');
1138 }
1139 goto fallback;
1140 case '.':
1141 dot_appeared++;
1142 goto fallback;
1143 case '#':
1144 pound_appeared++;
1145 goto fallback;
1146 fallback:
1147 default:
1148 SCM_DSTRING_PUTB(&argbuf, c);
1149 continue;
1150 }
1151 break;
1152 }
1153 if (c == 0) {
1154 Scm_Error("incomplete %-directive in format string: %s", fmt);
1155 }
1156 }
1157 }
1158
1159 void Scm_Vprintf(ScmPort *out, const char *fmt, va_list ap, int sharedp)
1160 {
1161 ScmObj h = SCM_NIL, t = SCM_NIL;
1162 const char *fmtp = fmt;
1163 ScmVM *vm;
1164 int c;
1165
1166 if (!SCM_OPORTP(out)) {
1167 Scm_Error("output port required, but got %S", out);
1168 }
1169 /*
1170 * First pass : pop vararg and make a list of arguments.
1171 */
1172 while ((c = *fmtp++) != 0) {
1173 if (c != '%') continue;
1174 while ((c = *fmtp++) != 0) {
1175 switch (c) {
1176 case 'd':; case 'i':; case 'c':
1177 {
1178 signed int val = va_arg(ap, signed int);
1179 SCM_APPEND1(h, t, Scm_MakeInteger(val));
1180 break;
1181 }
1182 case 'o':; case 'u':; case 'x':; case 'X':
1183 {
1184 unsigned long val = va_arg(ap, unsigned long);
1185 SCM_APPEND1(h, t, Scm_MakeIntegerU(val));
1186 break;
1187 }
1188 case 'e':; case 'E':; case 'f':; case 'g':; case 'G':
1189 {
1190 double val = va_arg(ap, double);
1191 SCM_APPEND1(h, t, Scm_MakeFlonum(val));
1192 break;
1193 }
1194 case 's':;
1195 {
1196 char *val = va_arg(ap, char *);
1197 /* for safety */
1198 if (val != NULL) SCM_APPEND1(h, t, SCM_MAKE_STR(val));
1199 else SCM_APPEND1(h, t, SCM_MAKE_STR("(null)"));
1200 break;
1201 }
1202 case '%':;
1203 {
1204 break;
1205 }
1206 case 'p':
1207 {
1208 void *val = va_arg(ap, void *);
1209 SCM_APPEND1(h, t, Scm_MakeIntegerU((unsigned long)val));
1210 break;
1211 }
1212 case 'S':; case 'A':
1213 {
1214 ScmObj o = va_arg(ap, ScmObj);
1215 SCM_APPEND1(h, t, o);
1216 break;
1217 }
1218 case 'C':
1219 {
1220 int c = va_arg(ap, int);
1221 SCM_APPEND1(h, t, Scm_MakeInteger(c));
1222 break;
1223 }
1224 default:
1225 continue;
1226 }
1227 break;
1228 }
1229 if (c == 0) {
1230 Scm_Error("incomplete %-directive in format string: %s", fmt);
1231 }
1232 }
1233 /*
1234 * Second pass is called while locking the port.
1235 */
1236 vm = Scm_VM();
1237 PORT_LOCK(out, vm);
1238 PORT_SAFE_CALL(out, vprintf_proc(out, fmt, h, sharedp));
1239 PORT_UNLOCK(out);
1240 }
1241
1242 void Scm_Printf(ScmPort *out, const char *fmt, ...)
1243 {
1244 va_list ap;
1245
1246 va_start(ap, fmt);
1247 Scm_Vprintf(out, fmt, ap, FALSE);
1248 va_end(ap);
1249 }
1250
1251 void Scm_PrintfShared(ScmPort *out, const char *fmt, ...)
1252 {
1253 va_list ap;
1254 va_start(ap, fmt);
1255 Scm_Vprintf(out, fmt, ap, TRUE);
1256 va_end(ap);
1257 }
1258
1259 /*
1260 * Initialization
1261 */
1262 void Scm__InitWrite(void)
1263 {
1264 Scm_InitBuiltinGeneric(&Scm_GenericWriteObject, "write-object",
1265 Scm_GaucheModule());
1266 }