1 /* writer.c -*- mode:c; coding:utf-8; -*-
2 *
3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com>
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 *
12 * 2. Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditions and the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 *
16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 *
28 * $Id: $
29 */
30 #include <string.h>
31 #include <stdarg.h>
32 #include <ctype.h>
33 #define LIBSAGITTARIUS_BODY
34 #include "sagittarius/private/writer.h"
35 #include "sagittarius/private/port.h"
36 #include "sagittarius/private/generic.h"
37 #include "sagittarius/private/transcoder.h"
38 #include "sagittarius/private/bytevector.h"
39 #include "sagittarius/private/core.h"
40 #include "sagittarius/private/clos.h"
41 #include "sagittarius/private/file.h"
42 #include "sagittarius/private/pair.h"
43 #include "sagittarius/private/keyword.h"
44 #include "sagittarius/private/string.h"
45 #include "sagittarius/private/number.h"
46 #include "sagittarius/private/error.h"
47 #include "sagittarius/private/hashtable.h"
48 #include "sagittarius/private/identifier.h"
49 #include "sagittarius/private/library.h"
50 #include "sagittarius/private/vector.h"
51 #include "sagittarius/private/symbol.h"
52 #include "sagittarius/private/record.h"
53 #include "sagittarius/private/vm.h"
54 #include "sagittarius/private/unicode.h"
55 #include "sagittarius/private/builtin-symbols.h"
56
57 #include "shortnames.incl"
58
59 #define WRITE_LIMITED 0x10
60 #define WRITE_CIRCULAR 0x20
61
62 /* for convenient */
63 static void format_write(SgObject obj, SgPort *port, SgWriteContext *ctx,
64 int sharedp);
65 static void write_ss_rec(SgObject obj, SgPort *port, SgWriteContext *ctx);
66 static void write_ss(SgObject obj, SgPort *port, SgWriteContext *ctx);
67 static void write_object(SgObject obj, SgPort *port, SgWriteContext *ctx);
68 static SgObject write_object_fallback(SgObject *args, int nargs, SgGeneric *gf);
69
70
71 SG_DEFINE_GENERIC(Sg_GenericWriteObject, write_object_fallback, NULL);
72
73 #define MAIN_THREAD_STACK_SIZE_LIMIT SG_MAIN_THREAD_STACK_SIZE_LIMIT
74 #define CHILD_THREAD_STACK_SIZE_LIMIT SG_CHILD_THREAD_STACK_SIZE_LIMIT
75
76
77 #define SET_STACK_SIZE(ctx) \
78 do { \
79 if (Sg_MainThreadP()) \
80 (ctx)->stackSize = MAIN_THREAD_STACK_SIZE_LIMIT; \
81 else \
82 (ctx)->stackSize = CHILD_THREAD_STACK_SIZE_LIMIT; \
83 } while (0)
84
85
Sg_Write(SgObject obj,SgObject p,int mode)86 void Sg_Write(SgObject obj, SgObject p, int mode)
87 {
88 SgWriteContext ctx;
89 SgPort *port;
90
91 if (!SG_OUTPUT_PORTP(p)) {
92 Sg_Error(UC("output port required, but got %S"), p);
93 }
94 if (SG_BINARY_PORTP(p)) {
95 /* for now I asuume it's a binary port. */
96 SgTranscoder *trans = Sg_UTF16ConsolePortP(p)
97 ? SG_TRANSCODER(Sg_MakeNativeConsoleTranscoder())
98 : SG_TRANSCODER(Sg_MakeNativeTranscoder());
99 port = SG_PORT(Sg_MakeTranscodedPort(SG_PORT(p), trans));
100 } else {
101 /* for now I assume it's a textual port */
102 port = SG_PORT(p);
103 }
104 ctx.mode = mode;
105 ctx.table= NULL;
106 ctx.flags = 0;
107 ctx.sharedId = 0;
108 SET_STACK_SIZE(&ctx);
109
110 SG_PORT_LOCK_WRITE(port);
111 format_write(obj, port, &ctx, SG_WRITE_MODE(&ctx) == SG_WRITE_SHARED);
112 SG_PORT_UNLOCK_WRITE(port);
113 }
114
Sg_WriteCircular(SgObject obj,SgObject port,int mode,long width)115 long Sg_WriteCircular(SgObject obj, SgObject port, int mode, long width)
116 {
117 SgWriteContext ctx;
118 SgString *str;
119 SgPort *out;
120 SgStringPort tp;
121 SgHashTable seen;
122 long nc;
123 int sharedp = FALSE;
124
125 if (!SG_OUTPUT_PORTP(port)) {
126 Sg_Error(UC("output port required, but got %S"), port);
127 }
128 Sg_InitHashTableSimple(&seen, SG_HASH_EQ, 8);
129 ctx.mode = mode;
130 ctx.flags = WRITE_CIRCULAR;
131 if (width > 0) {
132 ctx.flags |= WRITE_LIMITED;
133 ctx.limit = width;
134 }
135 ctx.ncirc = 0;
136 ctx.table = &seen;
137 ctx.sharedId = 0;
138 SET_STACK_SIZE(&ctx);
139
140 if (width <= 0) {
141 SG_PORT_LOCK_WRITE(SG_PORT(port));
142 format_write(obj, SG_PORT(port), &ctx, TRUE);
143 SG_PORT_UNLOCK_WRITE(SG_PORT(port));
144 return 0;
145 }
146
147 out = Sg_InitStringOutputPort(&tp, 0);
148 sharedp = SG_WRITE_MODE(&ctx) == SG_WRITE_SHARED;
149 format_write(obj, out, &ctx, sharedp);
150 str = SG_STRING(Sg_GetStringFromStringPort(&tp));
151 SG_CLEAN_STRING_PORT(&tp);
152 nc = str->size;
153 if (nc > width) {
154 SgObject sub = Sg_Substring(str, 0, width);
155 Sg_Puts(port, sub);
156 return -1;
157 } else {
158 Sg_Puts(port, str);
159 return nc;
160 }
161 }
162
Sg_WriteLimited(SgObject obj,SgObject port,int mode,long width)163 long Sg_WriteLimited(SgObject obj, SgObject port, int mode, long width)
164 {
165 SgWriteContext ctx;
166 SgString *str;
167 SgPort *out;
168 SgStringPort tp;
169 long nc;
170 int sharedp = FALSE;
171
172 if (!SG_OUTPUT_PORTP(port)) {
173 Sg_Error(UC("output port required, but got %S"), port);
174 }
175 out = Sg_InitStringOutputPort(&tp, 0);
176 ctx.mode = mode;
177 ctx.flags = WRITE_LIMITED;
178 ctx.limit = width;
179 ctx.sharedId = 0;
180 ctx.table = NULL;
181 SET_STACK_SIZE(&ctx);
182
183 sharedp = SG_WRITE_MODE(&ctx) == SG_WRITE_SHARED;
184 format_write(obj, out, &ctx, sharedp);
185 str = SG_STRING(Sg_GetStringFromStringPort(&tp));
186 SG_CLEAN_STRING_PORT(&tp);
187 nc = str->size;
188 if (nc > width) {
189 SgObject sub = Sg_Substring(str, 0, width);
190 Sg_Puts(port, sub);
191 return -1;
192 } else {
193 Sg_Puts(port, str);
194 return nc;
195 }
196 }
197
198 #define NEXT_ARG(arg, args) \
199 do { \
200 if (!SG_PAIRP(args)) { \
201 Sg_Error(UC("too few arguments for format string: %S"), fmt); \
202 } \
203 arg = SG_CAR(args); \
204 args = SG_CDR(args); \
205 argcount++; \
206 } while(0)
207
208 #define MAX_PARAMS 5
209
format_pad(SgPort * out,SgString * str,long mincol,long colinc,SgChar padchar,int rightalign)210 static void format_pad(SgPort *out, SgString *str,
211 long mincol, long colinc, SgChar padchar,
212 int rightalign)
213 {
214 long padcount = mincol - SG_STRING_SIZE(str);
215 long i;
216
217 if (padcount > 0) {
218 if (colinc > 1) {
219 padcount = ((padcount + colinc - 1) / colinc) * colinc;
220 }
221 if (rightalign) {
222 for (i = 0; i < padcount; i++) Sg_PutcUnsafe(out, padchar);
223 }
224 Sg_PutsUnsafe(out, str);
225 if (!rightalign) {
226 for (i = 0; i < padcount; i++) Sg_PutcUnsafe(out, padchar);
227 }
228 } else {
229 Sg_PutsUnsafe(out, str);
230 }
231 }
232
233 /* ~s and ~a writer */
format_sexp(SgPort * out,SgObject arg,SgObject * params,int nparams,int rightalign,int dots,int mode)234 static void format_sexp(SgPort *out, SgObject arg,
235 SgObject *params, int nparams,
236 int rightalign, int dots, int mode)
237 {
238 long mincol = 0, colinc = 1, minpad = 0, maxcol = -1, nwritten = 0, i;
239 SgChar padchar = ' ';
240 SgPort *tmpout;
241 SgStringPort tp;
242 SgString *tmpstr;
243
244 if (nparams > 0 && SG_INTP(params[0])) mincol = SG_INT_VALUE(params[0]);
245 if (nparams > 1 && SG_INTP(params[1])) colinc = SG_INT_VALUE(params[1]);
246 if (nparams > 2 && SG_INTP(params[2])) minpad = SG_INT_VALUE(params[2]);
247 if (nparams > 3 && SG_CHARP(params[3])) padchar = SG_CHAR_VALUE(params[3]);
248 if (nparams > 4 && SG_INTP(params[4])) maxcol = SG_INT_VALUE(params[4]);
249
250 tmpout = Sg_InitStringOutputPort(&tp,
251 (maxcol > 0) ? maxcol : (minpad > 0) ? minpad : 0);
252 if (minpad > 0 && rightalign) {
253 for (i = 0; i < minpad; i++) Sg_PutcUnsafe(tmpout, padchar);
254 }
255 if (maxcol > 0) {
256 nwritten = Sg_WriteLimited(arg, tmpout, mode, maxcol);
257 } else {
258 Sg_Write(arg, tmpout, mode);
259 }
260 if (minpad > 0 && !rightalign) {
261 for (i = 0; i < minpad; i++) Sg_PutcUnsafe(tmpout, padchar);
262 }
263 tmpstr = SG_STRING(Sg_GetStringFromStringPort(&tp));
264 SG_CLEAN_STRING_PORT(&tp);
265
266 if (maxcol > 0 && nwritten < 0) {
267 const SgChar *s = SG_STRING_VALUE(tmpstr);
268 long size = SG_STRING_SIZE(tmpstr);
269 if (dots && maxcol > 4) {
270 for (i = 0; i < size - 4; i++) {
271 Sg_PutcUnsafe(out, *s++);
272 }
273 Sg_PutuzUnsafe(out, UC(" ..."));
274 } else {
275 for (i = 0; i < size; i++) {
276 Sg_PutcUnsafe(out, *s++);
277 }
278 }
279 } else {
280 format_pad(out, tmpstr, mincol, colinc, padchar, rightalign);
281 }
282 }
283
284 /* ~d, ~b, ~o and ~x */
format_integer(SgPort * out,SgObject arg,SgObject * params,int nparams,int radix,int delimited,int alwayssign,int use_upper)285 static void format_integer(SgPort *out, SgObject arg, SgObject *params,
286 int nparams, int radix, int delimited,
287 int alwayssign, int use_upper)
288 {
289 long mincol = 0, commainterval = 3;
290 SgChar padchar = ' ', commachar = ',';
291 SgObject str;
292 if (!Sg_IntegerP(arg)) {
293 SgWriteContext ictx;
294 ictx.mode = SG_WRITE_DISPLAY;
295 ictx.flags = 0;
296 ictx.table = NULL;
297 ictx.sharedId = 0;
298 format_write(arg, out, &ictx, FALSE);
299 return;
300 }
301 if (SG_FLONUMP(arg)) arg = Sg_Exact(arg);
302 if (nparams > 0 && SG_INTP(params[0])) mincol = SG_INT_VALUE(params[0]);
303 if (nparams > 1 && SG_CHARP(params[1])) padchar = SG_CHAR_VALUE(params[1]);
304 if (nparams > 2 && SG_CHARP(params[2])) commachar = SG_CHAR_VALUE(params[2]);
305 if (nparams > 3 && SG_INTP(params[3])) commainterval = SG_INT_VALUE(params[3]);
306 str = Sg_NumberToString(arg, radix, use_upper);
307 if (alwayssign && SG_STRING_VALUE_AT(str, 0) != '-') {
308 str = Sg_StringAppend2(SG_MAKE_STRING("+"), str);
309 }
310 if (delimited && commainterval) {
311 const SgChar *ptr = SG_STRING_VALUE(str);
312 unsigned long num_digits = SG_STRING_SIZE(str), colcnt, i;
313 SgPort *strout;
314 SgStringPort tp;
315
316 strout = Sg_InitStringOutputPort(&tp,
317 num_digits + (num_digits % commainterval));
318 if (*ptr == '-' || *ptr == '+') {
319 Sg_PutcUnsafe(strout, *ptr);
320 ptr++;
321 num_digits--;
322 }
323 colcnt = num_digits % commainterval;
324 if (colcnt != 0) {
325 for (i = 0; i < colcnt; i++) {
326 Sg_Putc(strout, *(ptr + i));
327 }
328 }
329 while (colcnt < num_digits) {
330 if (colcnt != 0) Sg_PutcUnsafe(strout, commachar);
331 for (i = 0; i < commainterval; i++) {
332 Sg_Putc(strout, *(ptr + colcnt + i));
333 }
334 colcnt += commainterval;
335 }
336 str = Sg_GetStringFromStringPort(&tp);
337 SG_CLEAN_STRING_PORT(&tp);
338 }
339 format_pad(out, SG_STRING(str), mincol, 1, padchar, TRUE);
340 }
341
format_bin_bv(SgPort * port,SgObject bv)342 static void format_bin_bv(SgPort *port, SgObject bv)
343 {
344 #define BYTETOBINARYPATTERN "#b%d%d%d%d%d%d%d%d"
345 #define BYTETOBINARY(byte) \
346 (byte & 0x80 ? 1 : 0), \
347 (byte & 0x40 ? 1 : 0), \
348 (byte & 0x20 ? 1 : 0), \
349 (byte & 0x10 ? 1 : 0), \
350 (byte & 0x08 ? 1 : 0), \
351 (byte & 0x04 ? 1 : 0), \
352 (byte & 0x02 ? 1 : 0), \
353 (byte & 0x01 ? 1 : 0)
354
355 int i;
356 char buf[16], *p;
357 uint8_t byte;
358 Sg_PutuzUnsafe(port, UC("#vu8("));
359 for (i = 0; i < SG_BVECTOR_SIZE(bv); i++) {
360 if (i) Sg_PutcUnsafe(port, ' ');
361 byte = SG_BVECTOR_ELEMENT(bv, i);
362 snprintf(buf, sizeof(buf), BYTETOBINARYPATTERN, BYTETOBINARY(byte));
363 p = buf;
364 for (;*p; p++) {
365 Sg_PutcUnsafe(port, *p);
366 }
367 }
368 Sg_PutcUnsafe(port, ')');
369 #undef BYTETOBINARYPATTERN
370 #undef BYTETOBINARY
371
372 }
373
374
format_bv(SgPort * port,SgObject bv,int radix,int upperP)375 static void format_bv(SgPort *port, SgObject bv, int radix, int upperP)
376 {
377 int i;
378 char buf[10], *p;
379 const char *fmt;
380 switch (radix) {
381 case 2: format_bin_bv(port, bv); return;
382 case 8: fmt = "#o%o"; break;
383 case 16: if (upperP) fmt = "#x%X"; else fmt = "#x%x"; break;
384 /* default case, this isn't needed since format_bv is only used
385 internally and the radix is always one of listed values.
386 but to make compiler shut. */
387 case 10:
388 default:
389 fmt = "%u"; break;
390 }
391
392 Sg_PutuzUnsafe(port, UC("#vu8("));
393 for (i = 0; i < SG_BVECTOR_SIZE(bv); i++) {
394 if (i) Sg_PutcUnsafe(port, ' ');
395
396 snprintf(buf, sizeof(buf), fmt, SG_BVECTOR_ELEMENT(bv, i));
397 p = buf;
398 for (;*p; p++) {
399 Sg_PutcUnsafe(port, *p);
400 }
401 }
402 Sg_PutcUnsafe(port, ')');
403 }
404
405
format_proc(SgPort * port,SgString * fmt,SgObject args,int sharedp)406 static void format_proc(SgPort *port, SgString *fmt, SgObject args, int sharedp)
407 {
408 SgChar ch = 0;
409 SgObject arg;
410 SgPort *fmtstr = SG_PORT(Sg_MakeStringInputPort(fmt, 0, -1));
411 int backtracked = FALSE;
412 int /* arglen, */ argcount;
413 SgWriteContext sctx, actx; /* context for ~s and ~a */
414
415 /* arglen = Sg_Length(args); */
416 argcount = 0;
417
418 sctx.mode = SG_WRITE_WRITE;
419 sctx.table = NULL;
420 sctx.flags = 0;
421 sctx.sharedId = 0;
422 SET_STACK_SIZE(&sctx);
423
424 actx.mode = SG_WRITE_DISPLAY;
425 actx.table = NULL;
426 actx.flags = 0;
427 actx.sharedId = 0;
428 SET_STACK_SIZE(&actx);
429
430 for (;;) {
431 int atflag, colonflag;
432 SgObject params[MAX_PARAMS];
433 int numParams;
434 ch = Sg_GetcUnsafe(fmtstr);
435 if (ch == EOF) {
436 if (!backtracked && !SG_NULLP(args)) {
437 Sg_Error(UC("too many arguments for format string: %S"), fmt);
438 }
439 return;
440 }
441 if (ch != '~') {
442 Sg_PutcUnsafe(port, ch);
443 continue;
444 }
445 numParams = 0;
446 atflag = colonflag = FALSE;
447 for (;;) {
448 ch = Sg_GetcUnsafe(fmtstr);
449 switch (ch) {
450 case EOF:
451 Sg_Error(UC("imcomplete format string: %S"), fmt);
452 break;
453 case '%':
454 /* TODO get eol from port */
455 Sg_PutcUnsafe(port, '\n');
456 break;
457 case '!':
458 /* flush */
459 Sg_FlushPort(port);
460 break;
461 case 's': case 'S':
462 NEXT_ARG(arg, args);
463 if (numParams == 0) {
464 format_write(arg, port, &sctx, sharedp);
465 } else {
466 format_sexp(port, arg, params, numParams, atflag, colonflag,
467 sharedp ? SG_WRITE_SHARED : SG_WRITE_WRITE);
468 }
469 break;
470 case 'a': case 'A':
471 NEXT_ARG(arg, args);
472 if (numParams == 0) {
473 format_write(arg, port, &actx, sharedp);
474 } else {
475 format_sexp(port, arg, params, numParams, atflag, colonflag,
476 SG_WRITE_DISPLAY);
477 }
478 break;
479 case 'd': case 'D':
480 NEXT_ARG(arg, args);
481 if (numParams == 0 && !atflag && !colonflag) {
482 if (SG_BVECTORP(arg)) {
483 format_bv(port, arg, 10, FALSE);
484 } else {
485 format_write(arg, port, &actx, FALSE);
486 }
487 } else {
488 format_integer(port, arg, params, numParams, 10,
489 colonflag, atflag, FALSE);
490 }
491 break;
492 case 'b': case 'B':
493 NEXT_ARG(arg, args);
494 if (numParams == 0 && !atflag && !colonflag) {
495 if (Sg_IntegerP(arg)) {
496 format_write(Sg_NumberToString(arg, 2, FALSE), port, &actx, FALSE);
497 } else if (SG_BVECTORP(arg)) {
498 format_bv(port, arg, 2, FALSE);
499 } else {
500 format_write(arg, port, &actx, FALSE);
501 }
502 } else {
503 format_integer(port, arg, params, numParams, 2,
504 colonflag, atflag, FALSE);
505 }
506 break;
507 case 'o': case 'O':
508 NEXT_ARG(arg, args);
509 if (numParams == 0 && !atflag && !colonflag) {
510 if (Sg_IntegerP(arg)) {
511 format_write(Sg_NumberToString(arg, 8, FALSE), port, &actx, FALSE);
512 } else if (SG_BVECTORP(arg)) {
513 format_bv(port, arg, 8, FALSE);
514 } else {
515 format_write(arg, port, &actx, FALSE);
516 }
517 } else {
518 format_integer(port, arg, params, numParams, 8,
519 colonflag, atflag, FALSE);
520 }
521 break;
522 case 'x': case 'X':
523 NEXT_ARG(arg, args);
524 if (numParams == 0 && !atflag && !colonflag) {
525 if (Sg_IntegerP(arg)) {
526 format_write(Sg_NumberToString(arg, 16, ch == 'X'), port,
527 &actx, FALSE);
528 } else if (SG_BVECTORP(arg)) {
529 format_bv(port, arg, 16, ch == 'X');
530 } else {
531 format_write(arg, port, &actx, FALSE);
532 }
533 } else {
534 format_integer(port, arg, params, numParams, 16,
535 colonflag, atflag, ch == 'X');
536 }
537 break;
538 case '@':
539 if (atflag) {
540 Sg_Error(UC("too many @-flag for formatting directive: %S"), fmt);
541 }
542 atflag = TRUE;
543 continue;
544 case ':':
545 if (colonflag) {
546 Sg_Error(UC("too many :-flag for formatting directive: %S"), fmt);
547 }
548 colonflag = TRUE;
549 continue;
550 case '\'':
551 if (atflag || colonflag) goto badfmt;
552 if (numParams >= MAX_PARAMS) goto badfmt;
553 ch = Sg_GetcUnsafe(fmtstr);
554 if (ch == EOF) goto badfmt;
555 params[numParams++] = SG_MAKE_CHAR(ch);
556 ch = Sg_GetcUnsafe(fmtstr);
557 if (ch != ',') Sg_UngetcUnsafe(fmtstr, ch);
558 continue;
559 case '0': case '1': case '2': case '3': case '4':
560 case '5': case '6': case '7': case '8': case '9':
561 case '-': case '+':
562 if (atflag || colonflag || numParams >= MAX_PARAMS) {
563 goto badfmt;
564 } else {
565 int sign = (ch == '-') ? -1 : 1;
566 unsigned long value = isdigit(ch) ? (ch - '0') : 0;
567 for (;;) {
568 ch = Sg_GetcUnsafe(fmtstr);
569 /* TODO check valid character */
570 if (!isdigit(ch)) {
571 if (ch != ',') Sg_UngetcUnsafe(fmtstr, ch);
572 params[numParams++] = Sg_MakeInteger(sign * value);
573 break;
574 }
575 /* TODO check over flow */
576 value = value * 10 + (ch - '0');
577 }
578 }
579 continue;
580 case ',':
581 if (atflag || colonflag || numParams >= MAX_PARAMS) {
582 goto badfmt;
583 } else {
584 params[numParams++] = SG_FALSE;
585 continue;
586 }
587 default:
588 Sg_PutcUnsafe(port, ch);
589 break;
590 }
591 break;
592 }
593 }
594 badfmt:
595 Sg_Error(UC("illegal format string: %S"), fmt);
596 return;
597 }
598
Sg_Format(SgPort * port,SgString * fmt,SgObject args,int ss)599 void Sg_Format(SgPort *port, SgString *fmt, SgObject args, int ss)
600 {
601 SgPort *out;
602
603 if (!SG_OUTPUT_PORTP(port)) {
604 Sg_Error(UC("output port required, but got %S"), port);
605 }
606 if (SG_BINARY_PORTP(port)) {
607 /* for now I asuume it's a binary port. */
608 SgTranscoder *trans = Sg_UTF16ConsolePortP(port)
609 ? SG_TRANSCODER(Sg_MakeNativeConsoleTranscoder())
610 : SG_TRANSCODER(Sg_MakeNativeTranscoder());
611 out = SG_PORT(Sg_MakeTranscodedPort(port, trans));
612 } else {
613 /* for now I assume it's a textual port */
614 out = SG_PORT(port);
615 }
616 SG_PORT_LOCK_WRITE(out);
617 format_proc(out, fmt, args, ss);
618 SG_PORT_UNLOCK_WRITE(out);
619 }
620
Sg_Printf(SgPort * port,const SgChar * fmt,...)621 void Sg_Printf(SgPort *port, const SgChar *fmt, ...)
622 {
623 va_list ap;
624 va_start(ap, fmt);
625 Sg_Vprintf(port, fmt, ap, FALSE);
626 va_end(ap);
627 }
628
Sg_PrintfShared(SgPort * port,const SgChar * fmt,...)629 void Sg_PrintfShared(SgPort *port, const SgChar *fmt, ...)
630 {
631 va_list ap;
632 va_start(ap, fmt);
633 Sg_Vprintf(port, fmt, ap, TRUE);
634 va_end(ap);
635 }
636
637 static char special[] = {
638 /* NUL .... */
639 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
640 /* .... */
641 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
642 /* ! " # $ % & ' ( ) * + , - . / */
643 3, 0, 3, 3, 0, 0, 0, 3, 3, 3, 0, 1, 3, 1, 1, 0,
644 /* 0 1 2 3 4 5 6 7 8 9 : ; < = > ? */
645 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ,3, 0, 0, 0, 0,
646 /* @ A B C D E F G H I J K L M N O */
647 1, 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,
648 /* P Q R S T U V W X Y Z [ \ ] ^ _ */
649 16,16,16,16,16,16,16,16,16,16,16,3, 11,3, 0, 0,
650 /* ` a b c d e f g h i j k l m n o */
651 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
652 /* p q r s t u v w x y z { | } ~ ^? */
653 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 11,3, 0, 7
654 };
655
656 /*
657 Check if the symbol needs bar escaped.
658 The bar needs only for symbols start with number or
659 contains control characters or white space.
660 */
symbol_need_bar(const SgChar * s,long n)661 static int symbol_need_bar(const SgChar *s, long n)
662 {
663 /* R7RS allows these without escape. */
664 #if 0
665 switch (s[0]) {
666 case '@': return TRUE;
667 case '+':
668 if (s[1] == 0) return FALSE;
669 return TRUE;
670 case '-':
671 if (s[1] == 0) return FALSE;
672 if (s[1] != '>') return TRUE;
673 break;
674 case '.':
675 if (s[1] != '.') return TRUE;
676 if (s[2] != '.') return TRUE;
677 if (s[3] == 0) return FALSE;
678 return TRUE;
679 }
680 #endif
681
682 if (s[0] <= 0x7F && isdigit(s[0])) {
683 return TRUE;
684 } else {
685 SgChar c;
686 while (n--) {
687 c = *s++;
688 if (c >= 0x80) {
689 switch (Sg_CharGeneralCategory(c)) {
690 case Cc: case Cf: case Cs: case Co: case Cn:
691 return TRUE;
692 default:
693 return Sg_Ucs4WhiteSpaceP(c);
694 }
695 }
696 if (isalnum(c)) continue;
697 if (strchr("!$%&/:*<=>?^_~+-.@", (char)c)) continue;
698 return TRUE;
699 }
700 return FALSE;
701 }
702 }
703
704 #define SPBUFSIZ 50
705 #define CASE_ITAG(obj, str) \
706 case SG_ITAG(obj): Sg_PutuzUnsafe(port, str); break;
707
708 /* character name table (first 33 chars of ASCII) */
709 static const char *char_names[] = {
710 "nul", "x01", "x02", "x03", "x04", "x05", "x06", "alarm",
711 "backspace","tab", "newline","vtab", "page", "return","x0e", "x0f",
712 "x10", "x11", "x12", "x13", "x14", "x15", "x16", "x17",
713 "x18", "x19", "x1a", "esc", "x1c", "x1d", "x1e", "x1f",
714 "space"
715 };
716 /* R7RS defines slightly different name (e.g. nul vs null) */
717 static const char *r7rs_char_names[] = {
718 "null", "x01", "x02", "x03", "x04", "x05", "x06", "alarm",
719 "backspace","tab", "newline","x0b", "x0c", "return","x0e", "x0f",
720 "x10", "x11", "x12", "x13", "x14", "x15", "x16", "x17",
721 "x18", "x19", "x1a", "escape","x1c", "x1d", "x1e", "x1f",
722 "space"
723 };
724
write_object(SgObject obj,SgPort * port,SgWriteContext * ctx)725 static void write_object(SgObject obj, SgPort *port, SgWriteContext *ctx)
726 {
727 Sg_Apply2(SG_OBJ(&Sg_GenericWriteObject), obj, port);
728 }
729
write_object_fallback(SgObject * args,int argc,SgGeneric * gf)730 static SgObject write_object_fallback(SgObject *args, int argc, SgGeneric *gf)
731 {
732 SgClass *klass;
733 if (argc != 2 || (argc == 2 && !SG_OUTPUT_PORTP(args[1]))) {
734 Sg_Error(UC("no applicable method for write-object with %S"),
735 Sg_ArrayToList(args, argc));
736 }
737 klass = Sg_ClassOf(args[0]);
738 Sg_Printf(SG_PORT(args[1]), UC("#<%A %p>"),
739 klass->name, args[0]);
740 return SG_TRUE;
741 }
742
write_general(SgObject obj,SgPort * port,SgWriteContext * ctx)743 static void write_general(SgObject obj, SgPort *port, SgWriteContext *ctx)
744 {
745 SgClass *c = Sg_ClassOf(obj);
746 if (c->printer) c->printer(obj, port, ctx);
747 else write_object(obj, port, ctx);
748 }
749
write_noptr(SgObject obj,SgPort * port,SgWriteContext * ctx)750 static void write_noptr(SgObject obj, SgPort *port, SgWriteContext *ctx)
751 {
752 if (SG_IMMEDIATEP(obj)) {
753 switch (SG_ITAG(obj)) {
754 CASE_ITAG(SG_FALSE, UC("#f"));
755 CASE_ITAG(SG_TRUE, UC("#t"));
756 CASE_ITAG(SG_NIL, UC("()"));
757 CASE_ITAG(SG_EOF, UC("#<eof>"));
758 CASE_ITAG(SG_UNDEF, UC("#<unspecified>"));
759 CASE_ITAG(SG_UNBOUND, UC("#<unbound variable>"));
760 default:
761 Sg_Panic("write: unknown itag object: %08x", SG_WORD(obj));
762 }
763 } else if (SG_INTP(obj)) {
764 char buf[SPBUFSIZ];
765 snprintf(buf, sizeof(buf), "%ld", SG_INT_VALUE(obj));
766 Sg_PutzUnsafe(port, buf);
767 } else if (SG_CHARP(obj)) {
768 SgChar ch = SG_CHAR_VALUE(obj);
769 if (SG_WRITE_MODE(ctx) == SG_WRITE_DISPLAY) {
770 Sg_PutcUnsafe(port, ch);
771 } else {
772 Sg_PutuzUnsafe(port, UC("#\\"));
773 /* FIXME this is ugly */
774 if (ch <= 0x20) {
775 if (SG_VM_IS_SET_FLAG(Sg_VM(), SG_R7RS_MODE)) {
776 Sg_PutzUnsafe(port, r7rs_char_names[ch]);
777 } else {
778 Sg_PutzUnsafe(port, char_names[ch]);
779 }
780 }
781 else if (ch == 0x7f) Sg_PutuzUnsafe(port, UC("delete"));
782 else switch (Sg_CharGeneralCategory(ch)) {
783 case Mn: case Mc: case Me: /* Marks */
784 case Zs: case Zl: case Zp: /* Separator */
785 case Cc: case Cf: case Cs: case Co: case Cn: /* control */
786 Sg_Printf(port, UC("x%x"), ch);
787 break;
788 default:
789 Sg_PutcUnsafe(port, ch);
790 break;
791 }
792 }
793 }
794 #ifdef USE_IMMEDIATE_FLONUM
795 else if (SG_IFLONUMP(obj)) {
796 write_general(obj, port, ctx);
797 }
798 #endif /* USE_IMMEDIATE_FLONUM */
799 else {
800 Sg_Panic("write: got a bogus object: %08x", SG_WORD(obj));
801 }
802 return;
803 }
804
805 /* check stack.
806 write context holds stack info.
807
808 FIXME: this assumes stack grows downward;
809 */
810 #define CHECK_BOUNDARY(s, p, c) \
811 do { \
812 if ((char *)&(s) < (char *)&((c)->mode) - (c)->stackSize) { \
813 Sg_IOWriteError((SG_WRITE_MODE(c) == SG_WRITE_DISPLAY) \
814 ? SG_INTERN("display") \
815 : SG_INTERN("write"), \
816 SG_MAKE_STRING("stack overflow"), (p), SG_NIL); \
817 return; \
818 } \
819 } while(0)
820
write_ss_rec(SgObject obj,SgPort * port,SgWriteContext * ctx)821 void write_ss_rec(SgObject obj, SgPort *port, SgWriteContext *ctx)
822 {
823 SgObject e;
824 SgHashTable *ht = ctx->table;
825
826 CHECK_BOUNDARY(e, port, ctx);
827
828 if (ctx->flags & WRITE_LIMITED) {
829 /*
830 if the flag has WRITE_LIMITED, then output port must be
831 string output port
832 TODO: move this to port.c
833 */
834 char_buffer *start = SG_STRING_PORT(port)->buffer.start;
835 char_buffer *current = SG_STRING_PORT(port)->buffer.current;
836 size_t count = 0;
837 for (; start != current; start = start->next) count++;
838 if (count >= ctx->limit) return;
839 }
840
841 if (!obj) {
842 Sg_PutuzUnsafe(port, UC("#<null>"));
843 return;
844 }
845
846 if (!SG_PTRP(obj)) {
847 write_noptr(obj, port, ctx);
848 return;
849 }
850
851 if (SG_NUMBERP(obj)) {
852 write_general(obj, port, ctx);
853 return;
854 }
855
856 if (ht) {
857 char numbuf[SPBUFSIZ];
858 e = Sg_HashTableRef(ht, obj, SG_FALSE);
859 if (!SG_FALSEP(e)) {
860 if (SG_INTP(e)) {
861 /* This object is already printed. */
862 snprintf(numbuf, sizeof(numbuf), "#%ld#", SG_INT_VALUE(e));
863 Sg_PutzUnsafe(port, numbuf);
864 return;
865 } else {
866 /* This object will be seen again. Put a reference tag. */
867 Sg_HashTableSet(ht, obj, SG_MAKE_INT(ctx->sharedId), 0);
868 snprintf(numbuf, sizeof(numbuf), "#%d=", ctx->sharedId);
869 Sg_PutzUnsafe(port, numbuf);
870 ctx->sharedId++;
871 }
872 }
873 }
874
875 if (SG_PAIRP(obj)) {
876 /* special case for quote etc */
877 /* check if the cdr part is shared, otherwise get infinite recursion
878 like this case (cdr '#1='#1#) */
879 if (SG_PAIRP(SG_CDR(obj)) && SG_NULLP(SG_CDDR(obj))
880 && (!ht || SG_FALSEP(Sg_HashTableRef(ht, SG_CDR(obj), SG_FALSE)))) {
881 int special = TRUE;
882 if (SG_CAR(obj) == SG_SYMBOL_QUOTE) {
883 Sg_PutcUnsafe(port, '\'');
884 } else if (SG_CAR(obj) == SG_SYMBOL_QUASIQUOTE) {
885 Sg_PutcUnsafe(port, '`');
886 } else if (SG_CAR(obj) == SG_SYMBOL_UNQUOTE) {
887 Sg_PutcUnsafe(port, ',');
888 } else if (SG_CAR(obj) == SG_SYMBOL_UNQUOTE_SPLICING) {
889 Sg_PutuzUnsafe(port, UC(",@"));
890 } else if (SG_CAR(obj) == SG_SYMBOL_SYNTAX) {
891 Sg_PutuzUnsafe(port, UC("#'"));
892 } else if (SG_CAR(obj) == SG_SYMBOL_QUASISYNTAX) {
893 Sg_PutuzUnsafe(port, UC("#`"));
894 } else if (SG_CAR(obj) == SG_SYMBOL_UNSYNTAX) {
895 Sg_PutuzUnsafe(port, UC("#,"));
896 } else if (SG_CAR(obj) == SG_SYMBOL_UNSYNTAX_SPLICING) {
897 Sg_PutuzUnsafe(port, UC("#,@"));
898 } else {
899 special = FALSE;
900 }
901 if (special) {
902 write_ss_rec(SG_CADR(obj), port, ctx);
903 return;
904 }
905 }
906 /* normal case */
907 Sg_PutcUnsafe(port, '(');
908 for (;;) {
909 write_ss_rec(SG_CAR(obj), port, ctx);
910 obj = SG_CDR(obj);
911 if (SG_NULLP(obj)) {
912 Sg_PutcUnsafe(port, ')');
913 return;
914 }
915 if (!SG_PAIRP(obj)) {
916 Sg_PutuzUnsafe(port, UC(" . "));
917 write_ss_rec(obj, port, ctx);
918 Sg_PutcUnsafe(port, ')');
919 return;
920 }
921 if (ht) {
922 e = Sg_HashTableRef(ht, obj, SG_FALSE);
923 if (!SG_FALSEP(e)) {
924 Sg_PutuzUnsafe(port, UC(" . "));
925 write_ss_rec(obj, port, ctx);
926 Sg_PutcUnsafe(port, ')');
927 return;
928 }
929 }
930 Sg_PutcUnsafe(port, ' ');
931 }
932 } else if (SG_VECTORP(obj)) {
933 long len, i;
934 SgObject *elts;
935 Sg_PutuzUnsafe(port, UC("#("));
936 len = SG_VECTOR(obj)->size;
937 elts = SG_VECTOR(obj)->elements;
938 for (i = 0; i < len; i++) {
939 if (i != 0) Sg_PutcUnsafe(port, ' ');
940 write_ss_rec(elts[i], port, ctx);
941 }
942 Sg_PutcUnsafe(port, ')');
943 } else {
944 write_general(obj, port, ctx);
945 }
946 return;
947 }
948
949 /* FIXME, merge it */
write_walk_circular(SgObject obj,SgWriteContext * ctx,int cycleonlyp)950 static void write_walk_circular(SgObject obj, SgWriteContext *ctx,
951 int cycleonlyp)
952 {
953 SgHashTable *ht;
954 SgObject elt;
955
956 CHECK_BOUNDARY(elt, SG_FALSE, ctx);
957 #define REGISTER(obj) \
958 do { \
959 SgObject e = Sg_HashTableRef(ht, (obj), SG_UNBOUND); \
960 if (SG_INTP(e)) { \
961 long v = SG_INT_VALUE(e); \
962 Sg_HashTableSet(ht, (obj), SG_MAKE_INT(v + 1), 0); \
963 if (v > 0) return; \
964 } else { \
965 Sg_HashTableSet(ht, (obj), SG_MAKE_INT(0), 0); \
966 } \
967 } while(0)
968
969 #define UNREGISTER(obj) \
970 do { \
971 if (cycleonlyp) { \
972 SgObject e = Sg_HashTableRef(ht, (obj), SG_MAKE_INT(0)); \
973 long v = SG_INT_VALUE(e); \
974 if (v <= 1) { \
975 Sg_HashTableDelete(ht, (obj)); \
976 } \
977 } \
978 } while(0)
979
980 ht = ctx->table;
981 if (SG_PAIRP(obj) || SG_VECTORP(obj)) {
982 REGISTER(obj);
983 if (SG_PAIRP(obj)) {
984 elt = SG_CAR(obj);
985 if (SG_PTRP(elt)) write_walk_circular(elt, ctx, cycleonlyp);
986 write_walk_circular(SG_CDR(obj), ctx, cycleonlyp);
987 } else if (SG_VECTORP(obj) && SG_VECTOR_SIZE(obj) > 0) {
988 long i, len = SG_VECTOR_SIZE(obj);
989 for (i = 0; i < len; i++) {
990 elt = SG_VECTOR_ELEMENT(obj, i);
991 if (SG_PTRP(elt)) write_walk_circular(elt, ctx, cycleonlyp);
992 }
993 }
994 UNREGISTER(obj);
995 }
996 #undef REGISTER
997 #undef UNREGISTER
998 }
999
write_walk(SgObject obj,SgWriteContext * ctx)1000 static void write_walk(SgObject obj, SgWriteContext *ctx)
1001 {
1002 SgHashTable *ht;
1003 SgObject elt;
1004
1005 CHECK_BOUNDARY(elt, SG_FALSE, ctx);
1006
1007 #define REGISTER(obj) \
1008 do { \
1009 SgObject e = Sg_HashTableRef(ht, (obj), SG_UNBOUND); \
1010 if (!SG_UNBOUNDP(e)) { \
1011 Sg_HashTableSet(ht, (obj), SG_TRUE, 0); \
1012 return; \
1013 } \
1014 Sg_HashTableSet(ht, (obj), SG_FALSE, 0); \
1015 } while(0)
1016
1017 ht = ctx->table;
1018 for (;;) {
1019 if (!SG_PTRP(obj) || SG_KEYWORDP(obj) || SG_NUMBERP(obj)
1020 || (SG_SYMBOLP(obj) && SG_INTERNED_SYMBOL(obj))) {
1021 return;
1022 }
1023 if (SG_PAIRP(obj)) {
1024 REGISTER(obj);
1025 elt = SG_CAR(obj);
1026 if (SG_PTRP(elt)) write_walk(elt, ctx);
1027 obj = SG_CDR(obj);
1028 continue;
1029 }
1030 if (SG_STRINGP(obj) && SG_STRING(obj)->size != 0) {
1031 REGISTER(obj);
1032 return;
1033 }
1034 if (SG_VECTORP(obj) && SG_VECTOR_SIZE(obj) > 0) {
1035 long i, len = SG_VECTOR_SIZE(obj);
1036 REGISTER(obj);
1037 for (i = 0; i < len; i++) {
1038 elt = SG_VECTOR_ELEMENT(obj, i);
1039 if (SG_PTRP(elt)) write_walk(elt, ctx);
1040 }
1041 return;
1042 }
1043 if (SG_SYMBOLP(obj)) {
1044 ASSERT(!SG_INTERNED_SYMBOL(obj));
1045 REGISTER(obj);
1046 return;
1047 }
1048 return;
1049 }
1050 }
1051
write_ss(SgObject obj,SgPort * port,SgWriteContext * ctx)1052 void write_ss(SgObject obj, SgPort *port, SgWriteContext *ctx)
1053 {
1054 if (ctx->flags & WRITE_CIRCULAR) {
1055 SgObject seen = Sg_MakeHashTableSimple(SG_HASH_EQ, 64);
1056 SgHashTable *save = ctx->table;
1057 SgHashIter iter;
1058 SgObject k, v;
1059 ctx->table = SG_HASHTABLE(seen);
1060 write_walk_circular(obj, ctx, TRUE);
1061 /* extract */
1062 ctx->table = save;
1063 Sg_HashIterInit(seen, &iter);
1064 while (Sg_HashIterNext(&iter, &k, &v)) {
1065 if (SG_INT_VALUE(v) > 1) {
1066 Sg_HashTableSet(ctx->table, k, SG_TRUE, 0);
1067 }
1068 }
1069 } else {
1070 ctx->table = Sg_MakeHashTableSimple(SG_HASH_EQ, 0);
1071 write_walk(obj, ctx);
1072 }
1073
1074 write_ss_rec(obj, port, ctx);
1075 }
1076
format_write(SgObject obj,SgPort * port,SgWriteContext * ctx,int sharedp)1077 void format_write(SgObject obj, SgPort *port, SgWriteContext *ctx, int sharedp)
1078 {
1079 /* From https://support.microsoft.com/en-us/kb/315937
1080 The stack area of the Windows environment might be restricted
1081 to less then our expected size. In this case, it raises 0xc00000fd
1082 error. so trap it here.
1083 */
1084 /* only for MSVC. */
1085 #ifdef _MSC_VER
1086 volatile __int64 frame = 0;
1087 __try {
1088 #endif
1089 if (sharedp) {
1090 write_ss(obj, port, ctx);
1091 } else {
1092 write_ss_rec(obj, port, ctx);
1093 }
1094 #ifdef _MSC_VER
1095 } __except(GetExceptionCode() == EXCEPTION_STACK_OVERFLOW ?
1096 EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH) {
1097 Sg_SanitiseStack(&frame);
1098 Sg_IOWriteError((SG_WRITE_MODE(ctx) == SG_WRITE_DISPLAY)
1099 ? SG_INTERN("display")
1100 : SG_INTERN("write"),
1101 SG_MAKE_STRING("stack overflow"), port, SG_NIL);
1102 }
1103 #endif
1104 }
1105
1106
1107
vprintf_proc(SgPort * port,const SgChar * fmt,SgObject args,int sharedp)1108 static void vprintf_proc(SgPort *port, const SgChar *fmt,
1109 SgObject args, int sharedp)
1110 {
1111 const SgChar *fmtp = fmt;
1112 SgObject value;
1113 SgChar c;
1114 char buf[SPBUFSIZ], tmp[SPBUFSIZ];
1115 int longp = 0, mode;
1116 long len;
1117
1118 while ((c = *fmtp++) != 0) {
1119 long width, prec, dot_appeared, pound_appeared, index;
1120 int minus_appeared;
1121
1122 if (c != '%') {
1123 Sg_PutcUnsafe(port, c);
1124 continue;
1125 }
1126 #define get_value() \
1127 do { \
1128 ASSERT(SG_PAIRP(args)); \
1129 value = SG_CAR(args); \
1130 args = SG_CDR(args); \
1131 } while (0)
1132 #define put_tmp_to_buf(c, getter) \
1133 tmp[index++] = (char)(c); \
1134 tmp[index++] = 0; \
1135 snprintf(buf, sizeof(buf), tmp, (getter))
1136
1137 width = 0, prec = 0, dot_appeared = 0, pound_appeared = 0;
1138 index = 0; minus_appeared = 0;
1139 tmp[index++] = c; /* store % to tmp */
1140 while ((c = *fmtp++) != 0) {
1141 switch (c) {
1142 case 'l':
1143 longp++;
1144 tmp[index++] = (char)c;
1145 continue;
1146 case 'd': case 'i': case 'c':
1147 {
1148 get_value();
1149 ASSERT(Sg_ExactP(value));
1150 put_tmp_to_buf(c, Sg_GetInteger(value));
1151 Sg_PutzUnsafe(port, buf);
1152 break;
1153 }
1154 case 'U':
1155 {
1156 SgChar ucs4;
1157 SgWriteContext wctx;
1158 wctx.mode = SG_WRITE_WRITE;
1159 wctx.table = NULL;
1160 wctx.flags = 0;
1161 wctx.sharedId = 0;
1162 SET_STACK_SIZE(&wctx);
1163
1164 get_value();
1165 ASSERT(SG_CHARP(value));
1166 ucs4 = SG_CHAR_VALUE(value);
1167 if (ucs4 < 128) {
1168 /* put char in '~' or \tab or U+10 */
1169 switch (ucs4) {
1170 case 0: Sg_PutuzUnsafe(port, UC("nul(U+0000)")); break;
1171 case 7: Sg_PutuzUnsafe(port, UC("alarm(U+0007)")); break;
1172 case 8: Sg_PutuzUnsafe(port, UC("backspace(U+0008)")); break;
1173 case 9: Sg_PutuzUnsafe(port, UC("tab(U+0009)")); break;
1174 case 10: Sg_PutuzUnsafe(port, UC("linefeed(U+000A)")); break;
1175 case 11: Sg_PutuzUnsafe(port, UC("vtab(U+000B)")); break;
1176 case 12: Sg_PutuzUnsafe(port, UC("page(U+000C)")); break;
1177 case 13: Sg_PutuzUnsafe(port, UC("return(U+000D)")); break;
1178 case 27: Sg_PutuzUnsafe(port, UC("esc(U+001B)")); break;
1179 case 32: Sg_PutuzUnsafe(port, UC("space(U+0020)")); break;
1180 case 127: Sg_PutuzUnsafe(port, UC("delete(U+007F)")); break;
1181 default:
1182 if (ucs4 < 32) {
1183 snprintf(buf, sizeof(buf), "U+%04X", ucs4);
1184 Sg_PutzUnsafe(port, buf);
1185 } else {
1186 Sg_PutcUnsafe(port, '\'');
1187 format_write(value, port, &wctx, sharedp);
1188 Sg_PutcUnsafe(port, '\'');
1189 }
1190 break;
1191 }
1192 } else {
1193 Sg_PutcUnsafe(port, '\'');
1194 format_write(value, port, &wctx, sharedp);
1195 Sg_PutcUnsafe(port, '\'');
1196 snprintf(buf, sizeof(buf), "(U+%04X)", ucs4);
1197 Sg_PutzUnsafe(port, buf);
1198 }
1199 break;
1200 }
1201 case 'o': case 'u': case 'x': case 'X':
1202 {
1203 get_value();
1204 ASSERT(Sg_ExactP(value));
1205 put_tmp_to_buf(c, Sg_GetUInteger(value));
1206 Sg_PutzUnsafe(port, buf);
1207 break;
1208 }
1209 case 'e': case 'E': case 'f': case 'g': case 'G':
1210 {
1211 get_value();
1212 ASSERT(SG_FLONUMP(value));
1213 put_tmp_to_buf(c, Sg_GetDouble(value));
1214 Sg_PutzUnsafe(port, buf);
1215 break;
1216 }
1217 case 's':
1218 {
1219 get_value();
1220 if (width < 0) {
1221 for (len = SG_STRING(value)->size; len < -width; len++) {
1222 Sg_PutcUnsafe(port, ' ');
1223 }
1224 }
1225 Sg_PutsUnsafe(port, SG_STRING(value));
1226 if (width > 0) {
1227 for (len = SG_STRING(value)->size; len < width; len++) {
1228 Sg_PutcUnsafe(port, ' ');
1229 }
1230 }
1231 break;
1232 }
1233 case '%':
1234 Sg_PutcUnsafe(port, '%');
1235 break;
1236 case 'p':
1237 {
1238 get_value();
1239 ASSERT(Sg_ExactP(value));
1240 put_tmp_to_buf(c, (void*)(intptr_t)Sg_GetUInteger(value));
1241 Sg_PutzUnsafe(port, buf);
1242 break;
1243 }
1244 case 'S': case 'A': case 'L':
1245 {
1246 SgWriteContext wctx;
1247 get_value();
1248 mode = (c == 'A') ? SG_WRITE_DISPLAY
1249 : (c == 'L') ? SG_WRITE_LIBPATH
1250 : (sharedp) ? SG_WRITE_SHARED
1251 : SG_WRITE_WRITE;
1252 wctx.mode = mode;
1253 wctx.table = NULL;
1254 wctx.flags = 0;
1255 wctx.sharedId = 0;
1256 SET_STACK_SIZE(&wctx);
1257 if (pound_appeared) {
1258 long n = Sg_WriteCircular(value, SG_OBJ(port), mode, width);
1259 if (n < 0 && prec > 0) {
1260 Sg_PutuzUnsafe(port, UC(" ..."));
1261 }
1262 if (n > 0) {
1263 for (; n < prec; n++) Sg_PutcUnsafe(port, ' ');
1264 }
1265 } else if (width == 0) {
1266 format_write(value, port, &wctx, sharedp);
1267 } else if (dot_appeared) {
1268 long n = Sg_WriteLimited(value, SG_OBJ(port), mode, width);
1269 if (n < 0 && prec > 0) {
1270 Sg_PutuzUnsafe(port, UC(" ..."));
1271 }
1272 if (n > 0) {
1273 for (; n < prec; n++) Sg_PutcUnsafe(port, ' ');
1274 }
1275 } else {
1276 format_write(value, port, &wctx, sharedp);
1277 }
1278 break;
1279 }
1280 case 'C':
1281 {
1282 get_value();
1283 ASSERT(Sg_ExactP(value));
1284 Sg_PutcUnsafe(port, (SgChar)Sg_GetInteger(value));
1285 }
1286 case '0': case '1': case '2': case '3': case '4':
1287 case '5': case '6': case '7': case '8': case '9':
1288 {
1289 if (dot_appeared) {
1290 prec = prec * 10 + (c - '0');
1291 } else {
1292 width = width * 10 + (c - '0');
1293 if (minus_appeared) {
1294 /* not so smart... */
1295 width = 0 - labs(width);
1296 }
1297 }
1298 goto fallback;
1299 }
1300 case '-':
1301 minus_appeared++;
1302 goto fallback;
1303 case '.':
1304 dot_appeared++;
1305 goto fallback;
1306 case '#':
1307 pound_appeared++;
1308 goto fallback;
1309 case '*':
1310 {
1311 get_value();
1312 if (dot_appeared) {
1313 prec = Sg_GetInteger(value);
1314 } else {
1315 width = Sg_GetInteger(value);
1316 }
1317 goto fallback;
1318 }
1319 fallback:
1320 default:
1321 tmp[index++] = c;
1322 continue;
1323 }
1324 break;
1325 }
1326 if (c == 0) {
1327 Sg_Error(UC("incomplete %%-directive in format string: %s"), fmt);
1328 }
1329 }
1330 }
1331
1332 /*
1333 I think it's better to convert binary port to textual port implicitly,
1334 especially for this method. I need to think about 'format' and 'display'.
1335 */
Sg_Vprintf(SgPort * port,const SgChar * fmt,va_list sp,int sharedp)1336 void Sg_Vprintf(SgPort *port, const SgChar *fmt, va_list sp, int sharedp)
1337 {
1338 SgObject h = SG_NIL, t = SG_NIL;
1339 SgPort *out;
1340 const SgChar *fmtp = fmt;
1341 int c;
1342 if (!SG_OUTPUT_PORTP(port)) {
1343 Sg_Error(UC("output port required, but got %S"), port);
1344 }
1345 if (SG_BINARY_PORTP(port)) {
1346 /* for now I asuume it's a binary port. */
1347 SgTranscoder *trans = Sg_UTF16ConsolePortP(port)
1348 ? SG_TRANSCODER(Sg_MakeNativeConsoleTranscoder())
1349 : SG_TRANSCODER(Sg_MakeNativeTranscoder());
1350 out = Sg_MakeTranscodedPort(port, trans);
1351 } else {
1352 /* for now I assume it's a textual port */
1353 out = port;
1354 }
1355
1356 while ((c = *fmtp++) != 0) {
1357 if (c != '%') continue;
1358 while ((c = *fmtp++) != 0) {
1359 switch (c) {
1360 case 'd': case 'i': case 'c': case 'C': case '*':
1361 {
1362 int value = va_arg(sp, int);
1363 SG_APPEND1(h, t, Sg_MakeInteger(value));
1364 break;
1365 }
1366 case 'U':
1367 {
1368 SgChar value = va_arg(sp, SgChar);
1369 SG_APPEND1(h, t, SG_MAKE_CHAR(value));
1370 break;
1371 }
1372 case 'o': case 'u': case 'x': case 'X':
1373 {
1374 unsigned long value = va_arg(sp, unsigned long);
1375 SG_APPEND1(h, t, Sg_MakeIntegerU(value));
1376 break;
1377 }
1378 case 'e': case 'E': case 'f': case 'g': case 'G':
1379 {
1380 double value = va_arg(sp, double);
1381 SG_APPEND1(h, t, Sg_MakeFlonum(value));
1382 break;
1383 }
1384 case 's':
1385 {
1386 SgChar *value = va_arg(sp, SgChar*);
1387 /* for safety */
1388 if (value != NULL) {
1389 SG_APPEND1(h, t, Sg_HeapString(value));
1390 } else {
1391 SG_APPEND1(h, t, SG_MAKE_STRING("(null)"));
1392 }
1393 break;
1394 }
1395 case '%':
1396 break;
1397 case 'p':
1398 {
1399 void *value = va_arg(sp, void *);
1400 SG_APPEND1(h, t, Sg_MakeIntegerU((unsigned long)value));
1401 break;
1402 }
1403 case 'S': case 'A': case 'L':
1404 {
1405 SgObject value = va_arg(sp, SgObject);
1406 SG_APPEND1(h, t, value);
1407 break;
1408 }
1409 default:
1410 continue;
1411 }
1412 break;
1413 }
1414 }
1415 SG_PORT_LOCK_WRITE(out);
1416 vprintf_proc(out, fmt, h, sharedp);
1417 SG_PORT_UNLOCK_WRITE(out);
1418 }
1419
Sg_Sprintf(const SgChar * fmt,...)1420 SgObject Sg_Sprintf(const SgChar *fmt, ...)
1421 {
1422 SgObject r;
1423 va_list ap;
1424 va_start(ap, fmt);
1425 r = Sg_Vsprintf(fmt, ap, FALSE);
1426 va_end(ap);
1427 return r;
1428 }
1429
Sg_SprintfShared(const SgChar * fmt,...)1430 SgObject Sg_SprintfShared(const SgChar *fmt, ...)
1431 {
1432 SgObject r;
1433 va_list ap;
1434 va_start(ap, fmt);
1435 r = Sg_Vsprintf(fmt, ap, TRUE);
1436 va_end(ap);
1437 return r;
1438 }
1439
Sg_Vsprintf(const SgChar * fmt,va_list args,int sharedp)1440 SgObject Sg_Vsprintf(const SgChar *fmt, va_list args, int sharedp)
1441 {
1442 /* use default size */
1443 SgPort *port;
1444 SgStringPort tp;
1445 SgObject r;
1446
1447 port = Sg_InitStringOutputPort(&tp, 0);
1448 Sg_Vprintf(port, fmt, args, sharedp);
1449 r = Sg_GetStringFromStringPort(&tp);
1450 SG_CLEAN_STRING_PORT(&tp);
1451 return r;
1452 }
1453
Sg_WriteSymbolName(SgString * snam,SgPort * port,SgWriteContext * ctx,int flags)1454 void Sg_WriteSymbolName(SgString *snam, SgPort *port,
1455 SgWriteContext *ctx, int flags)
1456 {
1457 const SgChar *p = snam->value, *q;
1458 long size = snam->size;
1459 int escape = FALSE;
1460 int r6rsMode = SG_VM_IS_SET_FLAG(Sg_VM(), SG_R6RS_MODE);
1461 int mode = SG_WRITE_MODE(ctx);
1462
1463 SG_PORT_LOCK_WRITE(port);
1464 if (size == 0) {
1465 /* if the mode is R6RS then (string->symbol "") should not
1466 print anything. however, some of the R6RS implementations
1467 does print '|| or equivalent. (Chez and guile).
1468 */
1469 if (!(flags & SG_SYMBOL_WRITER_NOESCAPE_EMPTY)) {
1470 Sg_PutuzUnsafe(port, UC("||"));
1471 }
1472 goto end;
1473 }
1474 if (size == 1 && (*p == '+' || *p == '-')) {
1475 Sg_PutcUnsafe(port, *p);
1476 goto end;
1477 }
1478 /* R6RS does not have '|' */
1479 /* NOTE: this makes library name convertion ignore the difference
1480 between (srfi 1) and (srfi |1|). it seems there is no problem
1481 if it remove the check for SG_WRITE_LIBPATH here however then
1482 question would be who wants to make such a file named like
1483 %7c1%7c.scm. at least I don't. so for now, we ignore the
1484 difference. if there are a lot of request to distinguish such
1485 library names, then we just need to simply remove the check. */
1486 if (mode != SG_WRITE_LIBPATH &&
1487 (!(flags & SG_SYMBOL_WRITER_NOESCAPE_INITIAL))) {
1488 escape = symbol_need_bar(p, size);
1489 }
1490 /* FIXME symbol_need_bar and following piece of code does almost
1491 the same checking... */
1492 if (escape && !r6rsMode) {
1493 Sg_PutcUnsafe(port, '|');
1494 for (q = p; q < p + size; q++) {
1495 SgChar ch = *q;
1496 if (ch < 128) {
1497 if (special[ch] & 8) {
1498 Sg_PutcUnsafe(port, '\\');
1499 Sg_PutcUnsafe(port, ch);
1500 } else if (special[ch] & 4) {
1501 Sg_Printf(port, UC("\\x%02x;"), ch);
1502 } else {
1503 Sg_PutcUnsafe(port, ch);
1504 }
1505 } else {
1506 /* the same as R6RS except -> and ... */
1507 if ((q == p && Sg_Ucs4ConstituentP(ch)) ||
1508 (q != p && Sg_Ucs4SubsequentP(ch))) {
1509 Sg_PutcUnsafe(port, ch);
1510 } else {
1511 Sg_Printf(port, UC("\\x%02x;"), ch);
1512 }
1513 }
1514 }
1515 Sg_PutcUnsafe(port, '|');
1516 goto end;
1517 } else if (r6rsMode && (mode != SG_WRITE_LIBPATH)) {
1518 for (q = p; q < p + size; q++) {
1519 SgChar ch = *q;
1520 if ((q == p && Sg_Ucs4ConstituentP(ch)) ||
1521 (q != p && Sg_Ucs4SubsequentP(ch))) {
1522 Sg_PutcUnsafe(port, ch);
1523 } else {
1524 char buf[16];
1525 /* ... */
1526 if (q == p) {
1527 if (size == 3) {
1528 if (q[0] == '.' && q[1] == '.' && q[2] == '.') {
1529 Sg_PutuzUnsafe(port, UC("..."));
1530 goto end;
1531 }
1532 }
1533 if (size > 2) {
1534 if (q[0] == '-' && q[1] == '>') {
1535 Sg_PutuzUnsafe(port, UC("->"));
1536 q += 2;
1537 continue;
1538 }
1539 }
1540 }
1541 snprintf(buf, sizeof(buf), "\\x%X;", ch);
1542 Sg_PutzUnsafe(port, buf);
1543 }
1544 }
1545 } else {
1546 Sg_PutsUnsafe(port, snam);
1547 }
1548 end:
1549 SG_PORT_UNLOCK_WRITE(port);
1550 }
1551
Sg__InitWrite()1552 void Sg__InitWrite()
1553 {
1554 SgLibrary *lib = Sg_FindLibrary(SG_INTERN("(sagittarius clos)"), TRUE);
1555 Sg_InitBuiltinGeneric(&Sg_GenericWriteObject, UC("write-object"), lib);
1556
1557 }
1558
1559 /*
1560 end of file
1561 Local Variables:
1562 coding: utf-8-unix
1563 End:
1564 */
1565