1
/*===========================================================================
3
* About : Object writer
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 SigScheme Project <uim AT freedesktop.org>
10
* All rights reserved.
12
* Redistribution and use in source and binary forms, with or without
13
* modification, are permitted provided that the following conditions
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.
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
===========================================================================*/
38
/* TODO: make format.c independent */
47
#include "sigscheme.h"
48
#include "sigschemeinternal.h"
50
/*=======================================
51
File Local Macro Definitions
52
=======================================*/
56
#define SCM_STRING_LEN(o) 0
62
#define INTERESTINGP(obj) \
64
|| (STRINGP(obj) && SCM_STRING_LEN(obj)) \
67
|| VALUEPACKETP(obj) \
69
#define OCCUPIED(ent) (!EQ((ent)->key, SCM_INVALID))
70
#define HASH_EMPTY(table) (!(table).used)
72
#define DEFINING_DATUM (-1)
73
#define NONDEFINING_DATUM 0
75
#define HASH_INSERT 1 /* insert key if it's not registered yet */
77
#endif /* SCM_USE_SRFI38 */
79
/*=======================================
80
File Local Type Definitions
81
=======================================*/
84
AS_WRITE, /* string is enclosed by ", char is written using #\ notation */
85
AS_DISPLAY /* string and char is written as-is */
89
typedef size_t hashval_t;
97
size_t size; /* capacity; MUST be a power of 2 */
98
size_t used; /* population */
103
hash_table seen; /* a table of seen objects */
104
scm_intobj_t next_index; /* the next index to use for #N# */
106
#endif /* SCM_USE_SRFI38 */
108
/*=======================================
110
=======================================*/
111
#include "functable-r5rs-write.c"
113
SCM_DEFINE_EXPORTED_VARS(write);
116
SCM_GLOBAL_VARS_BEGIN(static_write);
118
/* misc info in priting shared structures */
119
static write_ss_context *l_write_ss_ctx;
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 */
126
/*=======================================
127
File Local Function Declarations
128
=======================================*/
129
static void write_internal (ScmObj port, ScmObj obj, enum OutputType otype);
130
static void write_obj (ScmObj port, ScmObj obj, enum OutputType otype);
132
static void write_char (ScmObj port, ScmObj obj, enum OutputType otype);
135
static void write_string (ScmObj port, ScmObj obj, enum OutputType otype);
137
static void write_list (ScmObj port, ScmObj lst, enum OutputType otype);
139
static void write_vector (ScmObj port, ScmObj vec, enum OutputType otype);
141
static void write_port (ScmObj port, ScmObj obj, enum OutputType otype);
142
static void write_constant (ScmObj port, ScmObj obj, enum OutputType otype);
143
static void write_errobj (ScmObj port, ScmObj obj, enum OutputType otype);
145
#if SCM_USE_HYGIENIC_MACRO
146
static void write_farsymbol(ScmObj port, ScmObj obj, enum OutputType otype);
150
static void hash_grow(hash_table *tab);
151
static hash_entry *hash_lookup(hash_table *tab,
152
ScmObj key, scm_intobj_t datum, int flag);
153
static void write_ss_scan(ScmObj obj, 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 OutputType otype);
156
#endif /* SCM_USE_SRFI38 */
158
/*=======================================
160
=======================================*/
162
scm_init_writer(void)
164
SCM_GLOBAL_VARS_INIT(write);
166
SCM_GLOBAL_VARS_INIT(static_write);
169
scm_register_funcs(scm_functable_r5rs_write);
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;
178
scm_write(ScmObj port, ScmObj obj)
180
write_internal(port, obj, AS_WRITE);
184
scm_display(ScmObj port, ScmObj obj)
186
write_internal(port, obj, AS_DISPLAY);
190
write_internal(ScmObj port, ScmObj obj, enum OutputType otype)
192
DECLARE_INTERNAL_FUNCTION("write");
195
SCM_ENSURE_LIVE_PORT(port);
196
if (!(SCM_PORT_FLAG(port) & SCM_PORTFLAG_OUTPUT))
197
ERR_OBJ("output port required but got", port);
199
write_obj(port, obj, otype);
200
scm_port_flush(port);
204
write_obj(ScmObj port, ScmObj obj, enum OutputType otype)
209
if (INTERESTINGP(obj)) {
210
scm_intobj_t index = get_shared_index(obj);
213
scm_format(port, SCM_FMT_RAW_C, "#~ZU#", (size_t)index);
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. */
223
switch (SCM_TYPE(obj)) {
226
scm_format(port, SCM_FMT_RAW_C, "~MD", SCM_INT_VALUE(obj));
231
write_errobj(port, obj, otype);
233
write_list(port, obj, otype);
236
scm_port_puts(port, SCM_SYMBOL_NAME(obj));
240
write_char(port, obj, otype);
245
write_string(port, obj, otype);
249
scm_port_puts(port, (SCM_SYNTAXP(obj)) ? "#<syntax " : "#<subr ");
250
sym = scm_symbol_bound_to(obj);
252
scm_display(port, sym);
254
scm_format(port, SCM_FMT_RAW_C, "~P", (void *)obj);
255
scm_port_put_char(port, '>');
257
#if SCM_USE_HYGIENIC_MACRO
259
scm_port_puts(port, "#<macro ");
260
write_obj(port, SCM_HMACRO_RULES(obj), otype);
261
scm_port_puts(port, ">");
264
write_farsymbol(port, obj, otype);
267
if (SCM_SUBPAT_PVARP(obj)) {
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 */
277
SCM_ASSERT(SCM_SUBPAT_REPPATP(obj));
278
write_obj(port, SCM_SUBPAT_REPPAT_PAT(obj), otype);
280
scm_format(port, SCM_FMT_RAW_C, " ..[~MD]..",
281
SCM_SUBPAT_REPPAT_PVCOUNT(obj));
283
scm_port_puts(port, " ...");
287
#endif /* SCM_USE_HYGIENIC_MACRO */
289
scm_port_puts(port, "#<closure ");
290
write_obj(port, SCM_CLOSURE_EXP(obj), otype);
291
scm_port_put_char(port, '>');
295
write_vector(port, obj, otype);
299
write_port(port, obj, otype);
301
#if SCM_USE_CONTINUATION
302
case ScmContinuation:
303
scm_format(port, SCM_FMT_RAW_C, "#<continuation ~P>", (void *)obj);
307
scm_port_puts(port, "#<values ");
308
write_obj(port, SCM_VALUEPACKET_VALUES(obj), otype);
309
#if SCM_USE_VALUECONS
310
#if SCM_USE_STORAGE_FATTY
311
/* SCM_VALUEPACKET_VALUES() changes the type destructively */
312
SCM_ENTYPE(obj, ScmValuePacket);
313
#else /* SCM_USE_STORAGE_FATTY */
314
#error "valuecons is not supported on this storage implementation"
315
#endif /* SCM_USE_STORAGE_FATTY */
316
#endif /* SCM_USE_VALUECONS */
317
scm_port_put_char(port, '>');
320
write_constant(port, obj, otype);
322
#if SCM_USE_SSCM_EXTENSIONS
324
scm_format(port, SCM_FMT_RAW_C,
325
"#<c_pointer ~P>", SCM_C_POINTER_VALUE(obj));
327
case ScmCFuncPointer:
328
scm_format(port, SCM_FMT_RAW_C,
329
"#<c_func_pointer ~P>",
330
(void *)(uintptr_t)SCM_C_FUNCPOINTER_VALUE(obj));
344
write_char(ScmObj port, ScmObj obj, enum OutputType otype)
346
const ScmSpecialCharInfo *info;
349
c = SCM_CHAR_VALUE(obj);
352
scm_port_puts(port, "#\\");
354
for (info = scm_special_char_table; info->esc_seq; info++) {
355
if (c == info->code) {
356
scm_port_puts(port, info->lex_rep);
361
/* other control chars are printed in hexadecimal form */
362
if (ICHAR_CONTROLP(c)) {
363
scm_format(port, SCM_FMT_RAW_C, "x~02MX", (scm_int_t)c);
368
scm_port_put_char(port, c);
375
#endif /* SCM_USE_CHAR */
379
write_string(ScmObj port, ScmObj obj, enum OutputType otype)
381
#if SCM_USE_MULTIBYTE_CHAR
383
ScmMultibyteString mbs;
388
const ScmSpecialCharInfo *info;
391
DECLARE_INTERNAL_FUNCTION("write");
393
str = SCM_STRING_STR(obj);
397
scm_port_put_char(port, '\"'); /* opening doublequote */
398
#if SCM_USE_MULTIBYTE_CHAR
399
if (scm_current_char_codec != scm_port_codec(port)) {
400
/* Since the str does not have its encoding information, here
401
* assumes that scm_current_char_codec is that. And then SigScheme
402
* does not have an encoding conversion mechanism, puts it
404
scm_port_puts(port, str);
407
codec = scm_port_codec(port);
408
SCM_MBS_INIT2(mbs, str, len);
409
while (SCM_MBS_GET_SIZE(mbs)) {
410
c = SCM_CHARCODEC_READ_CHAR(codec, mbs);
411
#else /* SCM_USE_MULTIBYTE_CHAR */
412
len = SCM_STRING_LEN(obj);
413
for (i = 0; i < len; i++) {
415
#endif /* SCM_USE_MULTIBYTE_CHAR */
416
for (info = scm_special_char_table; info->esc_seq; info++) {
417
if (c == info->code) {
418
scm_port_puts(port, info->esc_seq);
422
scm_port_put_char(port, c);
426
#if SCM_USE_MULTIBYTE_CHAR
429
scm_port_put_char(port, '\"'); /* closing doublequote */
433
scm_port_puts(port, str);
440
#endif /* SCM_USE_STRING */
443
write_list(ScmObj port, ScmObj lst, enum OutputType otype)
447
size_t necessary_close_parens;
450
DECLARE_INTERNAL_FUNCTION("write");
453
necessary_close_parens = 1;
457
SCM_ASSERT(CONSP(lst));
459
scm_port_put_char(port, '(');
461
FOR_EACH (car, lst) {
462
write_obj(port, car, otype);
465
scm_port_put_char(port, ' ');
468
/* See if the next pair is shared. Note that the case
469
* where the first pair is shared is handled in
471
index = get_shared_index(lst);
474
scm_format(port, SCM_FMT_RAW_C, ". #~ZU#", (size_t)index);
475
goto close_parens_and_return;
478
/* defining datum, with the new index negated */
479
scm_format(port, SCM_FMT_RAW_C, ". #~ZU=", (size_t)-index);
480
necessary_close_parens++;
481
goto cheap_recursion;
488
scm_port_puts(port, " . ");
489
/* Callee takes care of shared data. */
490
write_obj(port, lst, otype);
494
close_parens_and_return:
495
while (necessary_close_parens--)
497
scm_port_put_char(port, ')');
502
write_vector(ScmObj port, ScmObj vec, enum OutputType otype)
507
scm_port_puts(port, "#(");
509
v = SCM_VECTOR_VEC(vec);
510
len = SCM_VECTOR_LEN(vec);
511
for (i = 0; i < len; i++) {
513
scm_port_put_char(port, ' ');
514
write_obj(port, v[i], otype);
517
scm_port_put_char(port, ')');
519
#endif /* SCM_USE_VECTOR */
522
write_port(ScmObj port, ScmObj obj, enum OutputType otype)
526
scm_port_puts(port, "#<");
528
/* input or output */
529
/* print "iport", "oport" or "ioport" if bidirectional port */
530
if (SCM_PORT_FLAG(obj) & SCM_PORTFLAG_INPUT)
531
scm_port_put_char(port, 'i');
532
if (SCM_PORT_FLAG(obj) & SCM_PORTFLAG_OUTPUT)
533
scm_port_put_char(port, 'o');
534
scm_port_puts(port, "port");
537
info = scm_port_inspect(obj);
539
scm_port_put_char(port, ' ');
540
scm_port_puts(port, info);
544
scm_port_put_char(port, '>');
548
write_constant(ScmObj port, ScmObj obj, enum OutputType otype)
552
if (EQ(obj, SCM_NULL))
554
else if (EQ(obj, SCM_TRUE))
556
else if (EQ(obj, SCM_FALSE))
558
else if (EQ(obj, SCM_EOF))
560
else if (EQ(obj, SCM_UNBOUND))
562
else if (EQ(obj, SCM_UNDEF))
567
scm_port_puts(port, str);
571
write_errobj(ScmObj port, ScmObj obj, enum OutputType otype)
573
ScmObj err_obj_tag, reason, objs, trace_stack, elm;
574
DECLARE_INTERNAL_FUNCTION("write");
576
err_obj_tag = MUST_POP_ARG(obj);
577
reason = MUST_POP_ARG(obj);
578
objs = MUST_POP_ARG(obj);
579
trace_stack = MUST_POP_ARG(obj);
580
ASSERT_NO_MORE_ARG(obj);
584
scm_port_puts(port, "#<error ");
585
scm_write(port, reason);
589
scm_display(port, reason);
596
FOR_EACH (elm, objs) {
597
scm_port_put_char(port, ' ');
598
scm_write(port, elm);
601
if (otype == AS_WRITE)
602
scm_port_put_char(port, '>');
605
#if SCM_USE_HYGIENIC_MACRO
607
write_farsymbol(ScmObj port, ScmObj obj, enum OutputType otype)
609
/* Assumes that ScmPackedEnv is an integer. */
610
scm_port_puts(port, "#<farsym");
611
for (; SCM_FARSYMBOLP(obj); obj = SCM_FARSYMBOL_SYM(obj))
612
scm_format(port, SCM_FMT_RAW_C, " ~MD ", SCM_FARSYMBOL_ENV(obj));
613
scm_display(port, obj); /* Name. */
614
scm_port_puts(port, ">");
616
#endif /* SCM_USE_HYGIENIC_MACRO */
620
hash_grow(hash_table *tab)
622
size_t old_size, new_size, i;
623
hash_entry *old_ents;
625
old_size = tab->size;
626
new_size = old_size * 2;
627
old_ents = tab->ents;
629
tab->ents = scm_calloc(new_size, sizeof(hash_entry));
630
tab->size = new_size;
633
for (i = 0; i < old_size; i++)
634
hash_lookup(tab, old_ents[i].key, old_ents[i].datum, HASH_INSERT);
640
* @return A pointer to the entry, or NULL if not found.
643
hash_lookup(hash_table *tab, ScmObj key, scm_intobj_t datum, int flag)
649
/* If we have > 32 bits, we'll discard some of them. The lower
650
* bits are zeroed for alignment or used for tag bits, and in the
651
* latter case, the tag can only take 3 values: pair, string, or
652
* vector. We'll drop these bits. KEYs are expected to be
653
* pointers into the heap, so their higher bis are probably
654
* uniform. I haven't confirmed either's validity, though. */
655
hashval = (hashval_t)key;
656
if (sizeof(hashval) > 4) {
657
hashval /= sizeof(ScmCell);
658
hashval &= 0xffffffff;
661
hashval *= 2654435761UL; /* golden ratio hash */
663
/* We probe linearly, since a) speed isn't a primary concern for
664
* SigScheme, and b) having a table of primes only for this
665
* purpose is probably just a waste. */
666
for (i = 0; i < tab->size; i++) {
667
ent = &(tab->ents)[(hashval + i) & (tab->size - 1)];
668
if (!OCCUPIED(ent)) {
669
if (flag & HASH_INSERT) {
674
/* used > size * 2/3 --> overpopulated */
675
if (tab->used * 3 > tab->size * 2)
680
if (EQ(ent->key, key))
684
/* A linear probe should always find a slot. */
689
* Find out what non-atomic objects a structure shares within itself.
690
* @param obj The object in question, or a part of it.
691
* @param ctx Where to put the scan results.
694
write_ss_scan(ScmObj obj, write_ss_context *ctx)
700
ScmObj err_obj_tag, reason, objs, trace_stack;
701
DECLARE_INTERNAL_FUNCTION("write-with-shared-structure");
704
err_obj_tag = MUST_POP_ARG(obj);
705
reason = MUST_POP_ARG(obj);
706
objs = MUST_POP_ARG(obj);
707
trace_stack = MUST_POP_ARG(obj);
708
ASSERT_NO_MORE_ARG(obj);
710
write_ss_scan(reason, ctx);
711
write_ss_scan(objs, ctx);
715
/* (for-each mark-as-seen-or-return-if-familiar obj) */
716
for (; CONSP(obj); obj = CDR(obj)) {
717
ent = hash_lookup(&ctx->seen, obj, NONDEFINING_DATUM, HASH_INSERT);
719
ent->datum = DEFINING_DATUM;
722
write_ss_scan(CAR(obj), ctx);
725
if (INTERESTINGP(obj)) {
726
ent = hash_lookup(&ctx->seen, obj, NONDEFINING_DATUM, HASH_INSERT);
728
ent->datum = DEFINING_DATUM;
731
switch (SCM_TYPE(obj)) {
733
/* We don't need to track env because it's not printed anyway. */
734
write_ss_scan(SCM_CLOSURE_EXP(obj), ctx);
738
#if SCM_USE_VALUECONS
739
#if SCM_USE_STORAGE_FATTY
740
if (!SCM_NULLVALUESP(obj)) {
741
/* EQ(obj, SCM_VALUEPACKET_VALUES(obj)) */
742
write_ss_scan(CDR(SCM_VALUEPACKET_VALUES(obj)), ctx);
743
/* SCM_VALUEPACKET_VALUES() changes the type destructively */
744
SCM_ENTYPE(obj, ScmValuePacket);
746
#else /* SCM_USE_STORAGE_FATTY */
747
#error "valuecons is not supported on this storage implementation"
748
#endif /* SCM_USE_STORAGE_FATTY */
749
#else /* SCM_USE_VALUECONS */
750
write_ss_scan(SCM_VALUEPACKET_VALUES(obj), ctx);
751
#endif /* SCM_USE_VALUECONS */
756
for (i = 0, len = SCM_VECTOR_LEN(obj); i < len; i++)
757
write_ss_scan(SCM_VECTOR_VEC(obj)[i], ctx);
759
#endif /* SCM_USE_VECTOR */
768
* @return The index for obj, if it's a defined datum. If it's a
769
* defining datum, allocate an index for it and return the
770
* *additive inverse* of the index. If obj is nondefining,
774
get_shared_index(ScmObj obj)
778
if (l_write_ss_ctx) {
779
ent = hash_lookup(&l_write_ss_ctx->seen, obj, 0, HASH_FIND);
782
if (ent->datum == DEFINING_DATUM) {
783
ent->datum = l_write_ss_ctx->next_index++;
784
return -(ent->datum);
793
write_ss_internal(ScmObj port, ScmObj obj, enum OutputType otype)
795
write_ss_context ctx = {{0}};
799
ctx.seen.size = 1 << 8; /* arbitrary initial size */
800
ctx.seen.ents = scm_calloc(ctx.seen.size, sizeof(hash_entry));
801
for (i = 0; i < ctx.seen.size; i++) {
802
ctx.seen.ents[i].key = SCM_INVALID;
805
write_ss_scan(obj, &ctx);
807
/* If no structure is shared, we do a normal write. */
808
if (!HASH_EMPTY(ctx.seen))
809
l_write_ss_ctx = &ctx;
811
write_internal(port, obj, otype);
813
l_write_ss_ctx = NULL;
817
/* write with shared structure */
819
scm_write_ss(ScmObj port, ScmObj obj)
821
write_ss_internal(port, obj, AS_WRITE);
825
scm_display_errobj_ss(ScmObj port, ScmObj errobj)
827
write_ss_internal(port, errobj, AS_DISPLAY);
829
#endif /* SCM_USE_SRFI38 */
831
/*===========================================================================
832
R5RS : 6.6 Input and Output : 6.6.3 Output
833
===========================================================================*/
835
scm_p_write(ScmObj obj, ScmObj args)
838
DECLARE_FUNCTION("write", procedure_variadic_1);
840
port = scm_prepare_port(args, scm_out);
841
scm_write(port, obj);
846
scm_p_display(ScmObj obj, ScmObj args)
849
DECLARE_FUNCTION("display", procedure_variadic_1);
851
port = scm_prepare_port(args, scm_out);
852
scm_display(port, obj);
added
removed
sigscheme/src/write.c
