1 /*===========================================================================
2 * Filename : write.c
3 * About : Object writer
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 /* TODO: make format.c independent */
39
40 #include <config.h>
41
42 #include <stdlib.h>
43 #include <stdio.h>
44 #include <stdarg.h>
45 #include <string.h>
46
47 #include "sigscheme.h"
48 #include "sigschemeinternal.h"
49
50 /*=======================================
51 File Local Macro Definitions
52 =======================================*/
53 #if SCM_USE_SRFI38
54 #if !SCM_USE_STRING
55 #define STRINGP(o) 0
56 #define SCM_STRING_LEN(o) 0
57 #endif
58 #if !SCM_USE_VECTOR
59 #undef VECTORP
60 #define VECTORP(o) 0
61 #endif
62 #define INTERESTINGP(obj) \
63 (CONSP(obj) \
64 || (STRINGP(obj) && SCM_STRING_LEN(obj)) \
65 || CLOSUREP(obj) \
66 || VECTORP(obj) \
67 || VALUEPACKETP(obj) \
68 || ERROBJP(obj))
69 #define OCCUPIED(ent) (!EQ((ent)->key, SCM_INVALID))
70 #define HASH_EMPTY(table) (!(table).used)
71 /* datum index */
72 #define DEFINING_DATUM (-1)
73 #define NONDEFINING_DATUM 0
74 /* flags */
75 #define HASH_INSERT 1 /* insert key if it's not registered yet */
76 #define HASH_FIND 0
77 #endif /* SCM_USE_SRFI38 */
78
79 /*=======================================
80 File Local Type Definitions
81 =======================================*/
82 enum ScmOutputType {
83 UNKNOWN,
84 AS_WRITE, /* string is enclosed by ", char is written using #\ notation */
85 AS_DISPLAY /* string and char is written as-is */
86 };
87
88 #if SCM_USE_SRFI38
89 typedef size_t hashval_t;
90
91 typedef struct {
92 ScmObj key;
93 scm_intobj_t datum;
94 } scm_hash_entry;
95
96 typedef struct {
97 size_t size; /* capacity; MUST be a power of 2 */
98 size_t used; /* population */
99 scm_hash_entry *ents;
100 } scm_hash_table;
101
102 typedef struct {
103 scm_hash_table seen; /* a table of seen objects */
104 scm_intobj_t next_index; /* the next index to use for #N# */
105 } scm_write_ss_context;
106 #endif /* SCM_USE_SRFI38 */
107
108 /*=======================================
109 Variable Definitions
110 =======================================*/
111 #include "functable-r5rs-write.c"
112
113 SCM_DEFINE_EXPORTED_VARS(write);
114
115 #if SCM_USE_SRFI38
116 SCM_GLOBAL_VARS_BEGIN(static_write);
117 #define static
118 /* misc info in priting shared structures */
119 static scm_write_ss_context *l_write_ss_ctx;
120 #undef static
121 SCM_GLOBAL_VARS_END(static_write);
122 #define l_write_ss_ctx SCM_GLOBAL_VAR(static_write, l_write_ss_ctx)
123 SCM_DEFINE_STATIC_VARS(static_write);
124 #endif /* SCM_USE_SRFI38 */
125
126 /*=======================================
127 File Local Function Declarations
128 =======================================*/
129 static void write_internal (ScmObj port, ScmObj obj, enum ScmOutputType otype);
130 static void write_obj (ScmObj port, ScmObj obj, enum ScmOutputType otype);
131 #if SCM_USE_CHAR
132 static void write_char (ScmObj port, ScmObj obj, enum ScmOutputType otype);
133 #endif
134 #if SCM_USE_STRING
135 static void write_string (ScmObj port, ScmObj obj, enum ScmOutputType otype);
136 #endif
137 static void write_list (ScmObj port, ScmObj lst, enum ScmOutputType otype);
138 #if SCM_USE_VECTOR
139 static void write_vector (ScmObj port, ScmObj vec, enum ScmOutputType otype);
140 #endif
141 static void write_port (ScmObj port, ScmObj obj, enum ScmOutputType otype);
142 static void write_constant (ScmObj port, ScmObj obj, enum ScmOutputType otype);
143 static void write_errobj (ScmObj port, ScmObj obj, enum ScmOutputType otype);
144
145 #if SCM_USE_HYGIENIC_MACRO
146 static void write_farsymbol(ScmObj port, ScmObj obj, enum ScmOutputType otype);
147 #endif
148
149 #if SCM_USE_SRFI38
150 static void hash_grow(scm_hash_table *tab);
151 static scm_hash_entry *hash_lookup(scm_hash_table *tab,
152 ScmObj key, scm_intobj_t datum, int flag);
153 static void write_ss_scan(ScmObj obj, scm_write_ss_context *ctx);
154 static scm_intobj_t get_shared_index(ScmObj obj);
155 static void write_ss_internal(ScmObj port, ScmObj obj, enum ScmOutputType otype);
156 #endif /* SCM_USE_SRFI38 */
157
158 /*=======================================
159 Function Definitions
160 =======================================*/
161 SCM_EXPORT void
scm_init_writer(void)162 scm_init_writer(void)
163 {
164 SCM_GLOBAL_VARS_INIT(write);
165 #if SCM_USE_SRFI38
166 SCM_GLOBAL_VARS_INIT(static_write);
167 #endif
168
169 scm_register_funcs(scm_functable_r5rs_write);
170
171 /* To allow re-initialization of the interpreter, this variable must be
172 * re-initialized by assignment. Initialized .data section does not work
173 * for such situation. -- YamaKen 2006-03-31 */
174 scm_write_ss_func = scm_write;
175 }
176
177 SCM_EXPORT void
scm_write(ScmObj port,ScmObj obj)178 scm_write(ScmObj port, ScmObj obj)
179 {
180 write_internal(port, obj, AS_WRITE);
181 }
182
183 SCM_EXPORT void
scm_display(ScmObj port,ScmObj obj)184 scm_display(ScmObj port, ScmObj obj)
185 {
186 write_internal(port, obj, AS_DISPLAY);
187 }
188
189 static void
write_internal(ScmObj port,ScmObj obj,enum ScmOutputType otype)190 write_internal(ScmObj port, ScmObj obj, enum ScmOutputType otype)
191 {
192 DECLARE_INTERNAL_FUNCTION("write");
193
194 ENSURE_PORT(port);
195 SCM_ENSURE_LIVE_PORT(port);
196 if (!(SCM_PORT_FLAG(port) & SCM_PORTFLAG_OUTPUT))
197 ERR_OBJ("output port required but got", port);
198
199 write_obj(port, obj, otype);
200 scm_port_flush(port);
201 }
202
203 static void
write_obj(ScmObj port,ScmObj obj,enum ScmOutputType otype)204 write_obj(ScmObj port, ScmObj obj, enum ScmOutputType otype)
205 {
206 ScmObj sym;
207
208 #if SCM_USE_SRFI38
209 if (INTERESTINGP(obj)) {
210 scm_intobj_t index = get_shared_index(obj);
211 if (index > 0) {
212 /* defined datum */
213 scm_format(port, SCM_FMT_RAW_C, "#~ZU#", (size_t)index);
214 return;
215 }
216 if (index < 0) {
217 /* defining datum, with the new index negated */
218 scm_format(port, SCM_FMT_RAW_C, "#~ZU=", (size_t)-index);
219 /* Print it; the next time it'll be defined. */
220 }
221 }
222 #endif
223 switch (SCM_TYPE(obj)) {
224 #if SCM_USE_INT
225 case ScmInt:
226 scm_format(port, SCM_FMT_RAW_C, "~MD", SCM_INT_VALUE(obj));
227 break;
228 #endif
229 case ScmCons:
230 if (ERROBJP(obj))
231 write_errobj(port, obj, otype);
232 else
233 write_list(port, obj, otype);
234 break;
235 case ScmSymbol:
236 scm_port_puts(port, SCM_SYMBOL_NAME(obj));
237 break;
238 #if SCM_USE_CHAR
239 case ScmChar:
240 write_char(port, obj, otype);
241 break;
242 #endif
243 #if SCM_USE_STRING
244 case ScmString:
245 write_string(port, obj, otype);
246 break;
247 #endif
248 case ScmFunc:
249 scm_port_puts(port, (SCM_SYNTAXP(obj)) ? "#<syntax " : "#<subr ");
250 sym = scm_symbol_bound_to(obj);
251 if (TRUEP(sym))
252 scm_display(port, sym);
253 else
254 scm_format(port, SCM_FMT_RAW_C, "~P", (void *)obj);
255 scm_port_put_char(port, '>');
256 break;
257 #if SCM_USE_HYGIENIC_MACRO
258 case ScmMacro:
259 scm_port_puts(port, "#<macro ");
260 write_obj(port, SCM_HMACRO_RULES(obj), otype);
261 scm_port_puts(port, ">");
262 break;
263 case ScmFarsymbol:
264 write_farsymbol(port, obj, otype);
265 break;
266 case ScmSubpat:
267 if (SCM_SUBPAT_PVARP(obj)) {
268 #if SCM_DEBUG_MACRO
269 scm_port_puts(port, "#<pvar ");
270 write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
271 scm_format(port, SCM_FMT_RAW_C, " ~MD>",
272 SCM_SUBPAT_PVAR_INDEX(obj));
273 #else /* not SCM_DEBUG_MACRO */
274 write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
275 #endif /* not SCM_DEBUG_MACRO */
276 } else {
277 SCM_ASSERT(SCM_SUBPAT_REPPATP(obj));
278 write_obj(port, SCM_SUBPAT_REPPAT_PAT(obj), otype);
279 #if SCM_DEBUG_MACRO
280 scm_format(port, SCM_FMT_RAW_C, " ..[~MD]..",
281 SCM_SUBPAT_REPPAT_PVCOUNT(obj));
282 #else
283 scm_port_puts(port, " ...");
284 #endif
285 }
286 break;
287 #endif /* SCM_USE_HYGIENIC_MACRO */
288 case ScmClosure:
289 #if SCM_USE_LEGACY_MACRO
290 if (SYNTACTIC_CLOSUREP(obj))
291 scm_port_puts(port, "#<syntactic closure ");
292 else
293 #endif
294 scm_port_puts(port, "#<closure ");
295 write_obj(port, SCM_CLOSURE_EXP(obj), otype);
296 scm_port_put_char(port, '>');
297 break;
298 #if SCM_USE_VECTOR
299 case ScmVector:
300 write_vector(port, obj, otype);
301 break;
302 #endif
303 case ScmPort:
304 write_port(port, obj, otype);
305 break;
306 #if SCM_USE_CONTINUATION
307 case ScmContinuation:
308 scm_format(port, SCM_FMT_RAW_C, "#<continuation ~P>", (void *)obj);
309 break;
310 #endif
311 case ScmValuePacket:
312 scm_port_puts(port, "#<values ");
313 write_obj(port, SCM_VALUEPACKET_VALUES(obj), otype);
314 #if SCM_USE_VALUECONS
315 #if SCM_USE_STORAGE_FATTY
316 /* SCM_VALUEPACKET_VALUES() changes the type destructively */
317 SCM_ENTYPE(obj, ScmValuePacket);
318 #else /* SCM_USE_STORAGE_FATTY */
319 #error "valuecons is not supported on this storage implementation"
320 #endif /* SCM_USE_STORAGE_FATTY */
321 #endif /* SCM_USE_VALUECONS */
322 scm_port_put_char(port, '>');
323 break;
324 case ScmConstant:
325 write_constant(port, obj, otype);
326 break;
327 #if SCM_USE_SSCM_EXTENSIONS
328 case ScmCPointer:
329 scm_format(port, SCM_FMT_RAW_C,
330 "#<c_pointer ~P>", SCM_C_POINTER_VALUE(obj));
331 break;
332 case ScmCFuncPointer:
333 scm_format(port, SCM_FMT_RAW_C,
334 "#<c_func_pointer ~P>",
335 (void *)(uintptr_t)SCM_C_FUNCPOINTER_VALUE(obj));
336 break;
337 #endif
338
339 case ScmRational:
340 case ScmReal:
341 case ScmComplex:
342 default:
343 SCM_NOTREACHED;
344 }
345 }
346
347 #if SCM_USE_CHAR
348 static void
write_char(ScmObj port,ScmObj obj,enum ScmOutputType otype)349 write_char(ScmObj port, ScmObj obj, enum ScmOutputType otype)
350 {
351 const ScmSpecialCharInfo *info;
352 scm_ichar_t c;
353
354 c = SCM_CHAR_VALUE(obj);
355 switch (otype) {
356 case AS_WRITE:
357 scm_port_puts(port, "#\\");
358 /* special chars */
359 for (info = scm_special_char_table; info->esc_seq; info++) {
360 if (c == info->code) {
361 scm_port_puts(port, info->lex_rep);
362 return;
363 }
364 }
365
366 /* other control chars are printed in hexadecimal form */
367 if (ICHAR_CONTROLP(c)) {
368 scm_format(port, SCM_FMT_RAW_C, "x~02MX", (scm_int_t)c);
369 return;
370 }
371 /* FALLTHROUGH */
372 case AS_DISPLAY:
373 scm_port_put_char(port, c);
374 break;
375
376 default:
377 SCM_NOTREACHED;
378 }
379 }
380 #endif /* SCM_USE_CHAR */
381
382 #if SCM_USE_STRING
383 static void
write_string(ScmObj port,ScmObj obj,enum ScmOutputType otype)384 write_string(ScmObj port, ScmObj obj, enum ScmOutputType otype)
385 {
386 #if SCM_USE_MULTIBYTE_CHAR
387 ScmCharCodec *codec;
388 ScmMultibyteString mbs;
389 size_t len;
390 #else
391 scm_int_t i, len;
392 #endif
393 const ScmSpecialCharInfo *info;
394 const char *str;
395 scm_ichar_t c;
396 DECLARE_INTERNAL_FUNCTION("write");
397
398 str = SCM_STRING_STR(obj);
399
400 switch (otype) {
401 case AS_WRITE:
402 scm_port_put_char(port, '\"'); /* opening doublequote */
403 #if SCM_USE_MULTIBYTE_CHAR
404 if (scm_current_char_codec != scm_port_codec(port)) {
405 /* Since the str does not have its encoding information, here
406 * assumes that scm_current_char_codec is that. And then SigScheme
407 * does not have an encoding conversion mechanism, puts it
408 * as-is. */
409 scm_port_puts(port, str);
410 } else {
411 len = strlen(str);
412 codec = scm_port_codec(port);
413 SCM_MBS_INIT2(mbs, str, len);
414 while (SCM_MBS_GET_SIZE(mbs)) {
415 c = SCM_CHARCODEC_READ_CHAR(codec, mbs);
416 #else /* SCM_USE_MULTIBYTE_CHAR */
417 len = SCM_STRING_LEN(obj);
418 for (i = 0; i < len; i++) {
419 c = str[i];
420 #endif /* SCM_USE_MULTIBYTE_CHAR */
421 for (info = scm_special_char_table; info->esc_seq; info++) {
422 if (c == info->code) {
423 scm_port_puts(port, info->esc_seq);
424 goto continue2;
425 }
426 }
427 scm_port_put_char(port, c);
428 continue2:
429 ;
430 }
431 #if SCM_USE_MULTIBYTE_CHAR
432 }
433 #endif
434 scm_port_put_char(port, '\"'); /* closing doublequote */
435 break;
436
437 case AS_DISPLAY:
438 scm_port_puts(port, str);
439 break;
440
441 default:
442 SCM_NOTREACHED;
443 }
444 }
445 #endif /* SCM_USE_STRING */
446
447 static void
448 write_list(ScmObj port, ScmObj lst, enum ScmOutputType otype)
449 {
450 ScmObj car;
451 #if SCM_USE_SRFI38
452 size_t necessary_close_parens;
453 scm_intobj_t index;
454 #endif
455 DECLARE_INTERNAL_FUNCTION("write");
456
457 #if SCM_USE_SRFI38
458 necessary_close_parens = 1;
459 cheap_recursion:
460 #endif
461
462 SCM_ASSERT(CONSP(lst));
463
464 scm_port_put_char(port, '(');
465
466 FOR_EACH (car, lst) {
467 write_obj(port, car, otype);
468 if (!CONSP(lst))
469 break;
470 scm_port_put_char(port, ' ');
471
472 #if SCM_USE_SRFI38
473 /* See if the next pair is shared. Note that the case
474 * where the first pair is shared is handled in
475 * write_obj(). */
476 index = get_shared_index(lst);
477 if (index > 0) {
478 /* defined datum */
479 scm_format(port, SCM_FMT_RAW_C, ". #~ZU#", (size_t)index);
480 goto close_parens_and_return;
481 }
482 if (index < 0) {
483 /* defining datum, with the new index negated */
484 scm_format(port, SCM_FMT_RAW_C, ". #~ZU=", (size_t)-index);
485 necessary_close_parens++;
486 goto cheap_recursion;
487 }
488 #endif
489 }
490
491 /* last item */
492 if (!NULLP(lst)) {
493 scm_port_puts(port, " . ");
494 /* Callee takes care of shared data. */
495 write_obj(port, lst, otype);
496 }
497
498 #if SCM_USE_SRFI38
499 close_parens_and_return:
500 while (necessary_close_parens--)
501 #endif
502 scm_port_put_char(port, ')');
503 }
504
505 #if SCM_USE_VECTOR
506 static void
507 write_vector(ScmObj port, ScmObj vec, enum ScmOutputType otype)
508 {
509 ScmObj *v;
510 scm_int_t len, i;
511
512 scm_port_puts(port, "#(");
513
514 v = SCM_VECTOR_VEC(vec);
515 len = SCM_VECTOR_LEN(vec);
516 for (i = 0; i < len; i++) {
517 if (i)
518 scm_port_put_char(port, ' ');
519 write_obj(port, v[i], otype);
520 }
521
522 scm_port_put_char(port, ')');
523 }
524 #endif /* SCM_USE_VECTOR */
525
526 static void
527 write_port(ScmObj port, ScmObj obj, enum ScmOutputType otype)
528 {
529 char *info;
530
531 scm_port_puts(port, "#<");
532
533 /* input or output */
534 /* print "iport", "oport" or "ioport" if bidirectional port */
535 if (SCM_PORT_FLAG(obj) & SCM_PORTFLAG_INPUT)
536 scm_port_put_char(port, 'i');
537 if (SCM_PORT_FLAG(obj) & SCM_PORTFLAG_OUTPUT)
538 scm_port_put_char(port, 'o');
539 scm_port_puts(port, "port");
540
541 /* file or string */
542 info = scm_port_inspect(obj);
543 if (*info) {
544 scm_port_put_char(port, ' ');
545 scm_port_puts(port, info);
546 }
547 free(info);
548
549 scm_port_put_char(port, '>');
550 }
551
552 static void
553 write_constant(ScmObj port, ScmObj obj, enum ScmOutputType otype)
554 {
555 const char *str;
556
557 if (EQ(obj, SCM_NULL))
558 str = "()";
559 else if (EQ(obj, SCM_TRUE))
560 str = "#t";
561 else if (EQ(obj, SCM_FALSE))
562 str = "#f";
563 else if (EQ(obj, SCM_EOF))
564 str = "#<eof>";
565 else if (EQ(obj, SCM_UNBOUND))
566 str = "#<unbound>";
567 else if (EQ(obj, SCM_UNDEF))
568 str = "#<undef>";
569 else
570 SCM_NOTREACHED;
571
572 scm_port_puts(port, str);
573 }
574
575 static void
576 write_errobj(ScmObj port, ScmObj obj, enum ScmOutputType otype)
577 {
578 ScmObj reason, objs, elm;
579 DECLARE_INTERNAL_FUNCTION("write");
580
581 MUST_POP_ARG(obj);
582 reason = MUST_POP_ARG(obj);
583 objs = MUST_POP_ARG(obj);
584 MUST_POP_ARG(obj);
585 ASSERT_NO_MORE_ARG(obj);
586
587 switch (otype) {
588 case AS_WRITE:
589 scm_port_puts(port, "#<error ");
590 scm_write(port, reason);
591 break;
592
593 case AS_DISPLAY:
594 scm_display(port, reason);
595 break;
596
597 default:
598 SCM_NOTREACHED;
599 }
600
601 FOR_EACH (elm, objs) {
602 scm_port_put_char(port, ' ');
603 scm_write(port, elm);
604 }
605
606 if (otype == AS_WRITE)
607 scm_port_put_char(port, '>');
608 }
609
610 #if SCM_USE_HYGIENIC_MACRO
611 static void
612 write_farsymbol(ScmObj port, ScmObj obj, enum ScmOutputType otype)
613 {
614 /* Assumes that ScmPackedEnv is an integer. */
615 scm_port_puts(port, "#<farsym");
616 for (; SCM_FARSYMBOLP(obj); obj = SCM_FARSYMBOL_SYM(obj))
617 scm_format(port, SCM_FMT_RAW_C, " ~MD ", SCM_FARSYMBOL_ENV(obj));
618 scm_display(port, obj); /* Name. */
619 scm_port_puts(port, ">");
620 }
621 #endif /* SCM_USE_HYGIENIC_MACRO */
622
623 #if SCM_USE_SRFI38
624 static void
625 hash_grow(scm_hash_table *tab)
626 {
627 size_t old_size, new_size, i;
628 scm_hash_entry *old_ents;
629
630 old_size = tab->size;
631 new_size = old_size * 2;
632 old_ents = tab->ents;
633
634 tab->ents = scm_malloc(new_size * sizeof(scm_hash_entry));
635 tab->size = new_size;
636 tab->used = 0;
637 for (i = 0; i < new_size; i++)
638 tab->ents[i].key = SCM_INVALID;
639
640 for (i = 0; i < old_size; i++)
641 hash_lookup(tab, old_ents[i].key, old_ents[i].datum, HASH_INSERT);
642
643 free(old_ents);
644 }
645
646 /**
647 * @return A pointer to the entry, or NULL if not found.
648 */
649 static scm_hash_entry *
650 hash_lookup(scm_hash_table *tab, ScmObj key, scm_intobj_t datum, int flag)
651 {
652 size_t i;
653 hashval_t hashval;
654 scm_hash_entry *ent;
655
656 /* If we have > 32 bits, we'll discard some of them. The lower
657 * bits are zeroed for alignment or used for tag bits, and in the
658 * latter case, the tag can only take 3 values: pair, string, or
659 * vector. We'll drop these bits. KEYs are expected to be
660 * pointers into the heap, so their higher bis are probably
661 * uniform. I haven't confirmed either's validity, though. */
662 hashval = (hashval_t)key;
663 if (sizeof(hashval) > 4) {
664 hashval /= sizeof(ScmCell);
665 hashval &= 0xffffffff;
666 }
667
668 hashval *= 2654435761UL; /* golden ratio hash */
669
670 /* We probe linearly, since a) speed isn't a primary concern for
671 * SigScheme, and b) having a table of primes only for this
672 * purpose is probably just a waste. */
673 for (i = 0; i < tab->size; i++) {
674 ent = &(tab->ents)[(hashval + i) & (tab->size - 1)];
675 if (!OCCUPIED(ent)) {
676 if (flag & HASH_INSERT) {
677 ent->key = key;
678 ent->datum = datum;
679 tab->used++;
680
681 /* used > size * 2/3 --> overpopulated */
682 if (tab->used * 3 > tab->size * 2)
683 hash_grow(tab);
684 }
685 return NULL;
686 }
687 if (EQ(ent->key, key))
688 return ent;
689 }
690
691 /* A linear probe should always find a slot. */
692 SCM_NOTREACHED;
693 }
694
695 /**
696 * Find out what non-atomic objects a structure shares within itself.
697 * @param obj The object in question, or a part of it.
698 * @param ctx Where to put the scan results.
699 */
700 static void
701 write_ss_scan(ScmObj obj, scm_write_ss_context *ctx)
702 {
703 #if SCM_USE_VECTOR
704 scm_int_t i, len;
705 #endif
706 scm_hash_entry *ent;
707 ScmObj reason, objs;
708 DECLARE_INTERNAL_FUNCTION("write-with-shared-structure");
709
710 if (ERROBJP(obj)) {
711 MUST_POP_ARG(obj);
712 reason = MUST_POP_ARG(obj);
713 objs = MUST_POP_ARG(obj);
714 MUST_POP_ARG(obj);
715 ASSERT_NO_MORE_ARG(obj);
716
717 write_ss_scan(reason, ctx);
718 write_ss_scan(objs, ctx);
719 return;
720 }
721
722 /* (for-each mark-as-seen-or-return-if-familiar obj) */
723 for (; CONSP(obj); obj = CDR(obj)) {
724 ent = hash_lookup(&ctx->seen, obj, NONDEFINING_DATUM, HASH_INSERT);
725 if (ent) {
726 ent->datum = DEFINING_DATUM;
727 return;
728 }
729 write_ss_scan(CAR(obj), ctx);
730 }
731
732 if (INTERESTINGP(obj)) {
733 ent = hash_lookup(&ctx->seen, obj, NONDEFINING_DATUM, HASH_INSERT);
734 if (ent) {
735 ent->datum = DEFINING_DATUM;
736 return;
737 }
738 switch (SCM_TYPE(obj)) {
739 case ScmClosure:
740 /* We don't need to track env because it's not printed anyway. */
741 write_ss_scan(SCM_CLOSURE_EXP(obj), ctx);
742 break;
743
744 case ScmValuePacket:
745 #if SCM_USE_VALUECONS
746 #if SCM_USE_STORAGE_FATTY
747 if (!SCM_NULLVALUESP(obj)) {
748 /* EQ(obj, SCM_VALUEPACKET_VALUES(obj)) */
749 write_ss_scan(CDR(SCM_VALUEPACKET_VALUES(obj)), ctx);
750 /* SCM_VALUEPACKET_VALUES() changes the type destructively */
751 SCM_ENTYPE(obj, ScmValuePacket);
752 }
753 #else /* SCM_USE_STORAGE_FATTY */
754 #error "valuecons is not supported on this storage implementation"
755 #endif /* SCM_USE_STORAGE_FATTY */
756 #else /* SCM_USE_VALUECONS */
757 write_ss_scan(SCM_VALUEPACKET_VALUES(obj), ctx);
758 #endif /* SCM_USE_VALUECONS */
759 break;
760
761 #if SCM_USE_VECTOR
762 case ScmVector:
763 for (i = 0, len = SCM_VECTOR_LEN(obj); i < len; i++)
764 write_ss_scan(SCM_VECTOR_VEC(obj)[i], ctx);
765 break;
766 #endif /* SCM_USE_VECTOR */
767
768 default:
769 break;
770 }
771 }
772 }
773
774 /**
775 * @return The index for obj, if it's a defined datum. If it's a
776 * defining datum, allocate an index for it and return the
777 * *additive inverse* of the index. If obj is nondefining,
778 * return zero.
779 */
780 static scm_intobj_t
781 get_shared_index(ScmObj obj)
782 {
783 scm_hash_entry *ent;
784
785 if (l_write_ss_ctx) {
786 ent = hash_lookup(&l_write_ss_ctx->seen, obj, 0, HASH_FIND);
787
788 if (ent) {
789 if (ent->datum == DEFINING_DATUM) {
790 ent->datum = l_write_ss_ctx->next_index++;
791 return -(ent->datum);
792 }
793 return ent->datum;
794 }
795 }
796 return 0;
797 }
798
799 static void
800 write_ss_internal(ScmObj port, ScmObj obj, enum ScmOutputType otype)
801 {
802 scm_write_ss_context ctx = {{0}};
803 size_t i;
804
805 ctx.next_index = 1;
806 ctx.seen.size = 1 << 8; /* arbitrary initial size */
807 ctx.seen.ents = scm_malloc(ctx.seen.size * sizeof(scm_hash_entry));
808 for (i = 0; i < ctx.seen.size; i++)
809 ctx.seen.ents[i].key = SCM_INVALID;
810
811 write_ss_scan(obj, &ctx);
812
813 /* If no structure is shared, we do a normal write. */
814 if (!HASH_EMPTY(ctx.seen))
815 l_write_ss_ctx = &ctx;
816
817 write_internal(port, obj, otype);
818
819 l_write_ss_ctx = NULL;
820 free(ctx.seen.ents);
821 }
822
823 /* write with shared structure */
824 SCM_EXPORT void
825 scm_write_ss(ScmObj port, ScmObj obj)
826 {
827 write_ss_internal(port, obj, AS_WRITE);
828 }
829
830 SCM_EXPORT void
831 scm_display_errobj_ss(ScmObj port, ScmObj errobj)
832 {
833 write_ss_internal(port, errobj, AS_DISPLAY);
834 }
835 #endif /* SCM_USE_SRFI38 */
836
837 /*===========================================================================
838 R5RS : 6.6 Input and Output : 6.6.3 Output
839 ===========================================================================*/
840 SCM_EXPORT ScmObj
841 scm_p_write(ScmObj obj, ScmObj args)
842 {
843 ScmObj port;
844 DECLARE_FUNCTION("write", procedure_variadic_1);
845
846 port = scm_prepare_port(args, scm_out);
847 scm_write(port, obj);
848 return SCM_UNDEF;
849 }
850
851 SCM_EXPORT ScmObj
852 scm_p_display(ScmObj obj, ScmObj args)
853 {
854 ScmObj port;
855 DECLARE_FUNCTION("display", procedure_variadic_1);
856
857 port = scm_prepare_port(args, scm_out);
858 scm_display(port, obj);
859 return SCM_UNDEF;
860 }
861