1: /*
    2:  * write.c - writer
    3:  *
    4:  *   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
    5:  * 
    6:  *   Redistribution and use in source and binary forms, with or without
    7:  *   modification, are permitted provided that the following conditions
    8:  *   are met:
    9:  * 
   10:  *   1. Redistributions of source code must retain the above copyright
   11:  *      notice, this list of conditions and the following disclaimer.
   12:  *
   13:  *   2. Redistributions in binary form must reproduce the above copyright
   14:  *      notice, this list of conditions and the following disclaimer in the
   15:  *      documentation and/or other materials provided with the distribution.
   16:  *
   17:  *   3. Neither the name of the authors nor the names of its contributors
   18:  *      may be used to endorse or promote products derived from this
   19:  *      software without specific prior written permission.
   20:  *
   21:  *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22:  *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23:  *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24:  *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25:  *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26:  *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27:  *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28:  *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29:  *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30:  *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31:  *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32:  *
   33:  *  $Id: write.c,v 1.69 2007/08/24 23:55:44 shirok Exp $
   34:  */
   35: 
   36: #define LIBGAUCHE_BODY
   37: #include "gauche.h"
   38: #include "gauche/port.h"
   39: #include "gauche/builtin-syms.h"
   40: 
   41: #include <ctype.h>
   42: 
   43: static void write_walk(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
   44: static void write_ss(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
   45: static void write_ss_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
   46: static void write_object(ScmObj obj, ScmPort *out, ScmWriteContext *ctx);
   47: static ScmObj write_object_fallback(ScmObj *args, int nargs, ScmGeneric *gf);
   48: static void format_write(ScmObj obj, ScmPort *port, ScmWriteContext *ctx,
   49:                          int sharedp);
   50: SCM_DEFINE_GENERIC(Scm_GenericWriteObject, write_object_fallback, NULL);
   51: 
   52: /*============================================================
   53:  * Writers
   54:  */
   55: 
   56: /* Note: all internal routine (static functions) assumes the output
   57:    port is properly locked. */
   58: 
   59: /* Note: the current internal structure is in the transient state.
   60:    handling of writer mode and context should be much better.
   61:    Do not count on these APIs! */
   62: 
   63: /* Note: in order to support write/ss, we need to pass down the context
   64:    along the call tree.  We can think of a few strategies:
   65:    
   66:   (a) Use separate context argument : this is logically the most natural way.
   67:       The problem is that the legacy code didn't take the context into
   68:       account (especially in the printer of user-defined objects).
   69:     
   70:   (b) Attach context information to the port : this isn't "right", because
   71:       theoretically a user program may want to mix output of write/ss and
   72:       other writes into a single port.  However, it isn't likely a problem,
   73:       since (1) the outmost write() call locks the port, hence only one
   74:       thread can write to the port during a single write/ss call, and
   75:       (2) the purpose of write/ss is to produce an output which can be
   76:       read back, so you don't want to mix up other output.
   77: 
   78:       Another possible drawback is the overhead of dynamic wind in the
   79:       toplevel write() call (since we need to remove the context information
   80:       from the port when write() exits non-locally).  If the port hasn't
   81:       been locked, we need a C-level unwind-protect anyway, so it's not
   82:       a problem.   If the port is already locked, extra dynamic wind may
   83:       impact performance.
   84: 
   85:       Furthermore, I feel it isn't "right" to modify longer-living data
   86:       (port) for the sake of local, dynamically-scoped information (context).
   87:       
   88:       The advantage of this method is that legacy code will work unchanged.
   89: 
   90:   (c) A variation of (b) is to "wrap" the port by a transient procedural
   91:       port, which passes through output data to the original port, _and_
   92:       keeps the context info.  This is clean in the sense that it doesn't
   93:       contaminate the longer-living data (original port) by the transient
   94:       info.  We don't need to worry about dynamic winding as well (we can
   95:       leave the transient port to be GCed).
   96: 
   97:       The concern is the overhead of forwarding output via procedural
   98:       port interface.
   99: 
  100:    I'm not sure which is the best way in long run; so, as a temporary
  101:    solution, I use the strategy (b), since it is compatible to the current
  102:    version.  Let's see how it works.
  103:  */
  104: 
  105: #define SPBUFSIZ   50
  106: 
  107: /* Two bitmask used internally to indicate extra write mode */
  108: #define WRITE_LIMITED   0x10    /* we're limiting the length of output. */
  109: #define WRITE_CIRCULAR  0x20    /* circular-safe write.  info->table
  110:                                    is set up to look up for circular
  111:                                    objects. */
  112: 
  113: /* VM-default case mode */
  114: #define DEFAULT_CASE \
  115:    (SCM_VM_RUNTIME_FLAG_IS_SET(Scm_VM(), SCM_CASE_FOLD)? \
  116:     SCM_WRITE_CASE_FOLD:SCM_WRITE_CASE_NOFOLD)
  117: 
  118: /*
  119:  * Scm_Write - Standard Write.
  120:  */
  121: void Scm_Write(ScmObj obj, ScmObj p, int mode)
  122: {
  123:     ScmWriteContext ctx;
  124:     ScmVM *vm;
  125:     ScmPort *port;
  126:     
  127:     if (!SCM_OPORTP(p)) {
  128:         Scm_Error("output port required, but got %S", p);
  129:     }
  130:     port = SCM_PORT(p);
  131:     ctx.mode = mode;
  132:     ctx.flags = 0;
  133: 
  134:     /* if this is a "walk" pass of write/ss, dispatch to the walker */
  135:     if (port->flags & SCM_PORT_WALKING) {
  136:         SCM_ASSERT(SCM_PAIRP(port->data)&&SCM_HASH_TABLE_P(SCM_CDR(port->data)));
  137:         write_walk(obj, port, &ctx);
  138:         return;
  139:     }
  140:     /* if this is a "output" pass of write/ss, call the recursive routine */
  141:     if (port->flags & SCM_PORT_WRITESS) {
  142:         SCM_ASSERT(SCM_PAIRP(port->data)&&SCM_HASH_TABLE_P(SCM_CDR(port->data)));
  143:         write_ss_rec(obj, port, &ctx);
  144:         return;
  145:     }
  146:     
  147:     /* if case mode is not specified, use default taken from VM default */
  148:     if (SCM_WRITE_CASE(&ctx) == 0) ctx.mode |= DEFAULT_CASE;
  149: 
  150:     vm = Scm_VM();
  151:     PORT_LOCK(port, vm);
  152:     if (SCM_WRITE_MODE(&ctx) == SCM_WRITE_SHARED) {
  153:         PORT_SAFE_CALL(port, write_ss(obj, port, &ctx));
  154:     } else {
  155:         PORT_SAFE_CALL(port, write_ss_rec(obj, port, &ctx));
  156:     }
  157:     PORT_UNLOCK(port);
  158: }
  159: 
  160: /* 
  161:  * Scm_WriteLimited - Write to limited length.
  162:  *
  163:  *  Characters exceeding WIDTH are truncated.
  164:  *  If the output fits within WIDTH, # of characters actually written
  165:  *  is returned.  Othewise, -1 is returned.
  166:  * 
  167:  *  Current implementation is sloppy, potentially wasting time to write
  168:  *  objects which will be just discarded.
  169:  */
  170: int Scm_WriteLimited(ScmObj obj, ScmObj port, int mode, int width)
  171: {
  172:     ScmWriteContext ctx;
  173:     ScmString *str;
  174:     ScmObj out;
  175:     int nc, sharedp = FALSE;
  176:     
  177:     if (!SCM_OPORTP(port))
  178:         Scm_Error("output port required, but got %S", port);
  179:     out = Scm_MakeOutputStringPort(TRUE);
  180:     SCM_PORT(out)->data = SCM_PORT(port)->data;
  181:     ctx.mode = mode;
  182:     ctx.flags = WRITE_LIMITED;
  183:     ctx.limit = width;
  184:     /* if case mode is not specified, use default taken from VM default */
  185:     if (SCM_WRITE_CASE(&ctx) == 0) ctx.mode |= DEFAULT_CASE;
  186:     /* the walk pass does not produce any output, so we return immediately. */
  187:     if (SCM_PORT(port)->flags & SCM_PORT_WALKING) {
  188:         SCM_ASSERT(SCM_PAIRP(SCM_PORT(port)->data)&&SCM_HASH_TABLE_P(SCM_CDR(SCM_PORT(port)->data)));
  189:         write_walk(obj, SCM_PORT(port), &ctx);
  190:         return 0;               /* doesn't really matter */
  191:     }
  192:     /* we don't need to lock out, for it is private. */
  193:     sharedp = SCM_WRITE_MODE(&ctx) == SCM_WRITE_SHARED;
  194:     format_write(obj, SCM_PORT(out), &ctx, sharedp);
  195:     str = SCM_STRING(Scm_GetOutputString(SCM_PORT(out), 0));
  196:     nc = SCM_STRING_BODY_LENGTH(SCM_STRING_BODY(str));
  197:     if (nc > width) {
  198:         ScmObj sub = Scm_Substring(str, 0, width, FALSE);
  199:         SCM_PUTS(sub, port);    /* this locks port */
  200:         return -1;
  201:     } else {
  202:         SCM_PUTS(str, 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:     ScmObj out;
  214:     ScmString *str;
  215:     ScmWriteContext ctx;
  216:     int nc;
  217: 
  218:     if (!SCM_OPORTP(port)) {
  219:         Scm_Error("output port required, but got %S", port);
  220:     }
  221:     ctx.mode = mode;
  222:     ctx.flags = WRITE_CIRCULAR;
  223:     if (SCM_WRITE_CASE(&ctx) == 0) ctx.mode |= DEFAULT_CASE;
  224:     if (width > 0) {
  225:         ctx.flags |= WRITE_LIMITED;
  226:         ctx.limit = width;
  227:     }
  228:     ctx.ncirc = 0;
  229:     ctx.table = SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_EQ, 8));
  230: 
  231:     if (width <= 0) {
  232:         ScmVM *vm = Scm_VM();
  233:         PORT_LOCK(SCM_PORT(port), vm);
  234:         PORT_SAFE_CALL(SCM_PORT(port),
  235:                        format_write(obj, SCM_PORT(port), &ctx, TRUE));
  236:         PORT_UNLOCK(SCM_PORT(port));
  237:         return 0;
  238:     }
  239: 
  240:     if (SCM_PORT(port)->flags & SCM_PORT_WALKING) {
  241:         SCM_ASSERT(SCM_PAIRP(SCM_PORT(port)->data)&&SCM_HASH_TABLE_P(SCM_CDR(SCM_PORT(port)->data)));
  242:         write_walk(obj, SCM_PORT(port), &ctx);
  243:         return 0;               /* doesn't really matter */
  244:     }
  245: 
  246:     out = Scm_MakeOutputStringPort(TRUE);
  247:     SCM_PORT(out)->data = SCM_PORT(port)->data;
  248:     /* no need to lock out, for it is private */
  249:     format_write(obj, SCM_PORT(out), &ctx, TRUE);
  250:     str = SCM_STRING(Scm_GetOutputString(SCM_PORT(out),0));
  251:     nc = SCM_STRING_BODY_LENGTH(SCM_STRING_BODY(str));
  252:     if (nc > width) {
  253:         ScmObj sub = Scm_Substring(str, 0, width, FALSE);
  254:         SCM_PUTS(sub, port);    /* this locks port */
  255:         return -1;
  256:     } else {
  257:         SCM_PUTS(str, port);    /* this locks port */
  258:         return nc;
  259:     }
  260: }
  261: 
  262: /*===================================================================
  263:  * Internal writer
  264:  */
  265: 
  266: /* character name table (first 33 chars of ASCII)*/
  267: static const char *char_names[] = {
  268:     "null",   "x01",   "x02",    "x03",   "x04",   "x05",   "x06",   "x07",
  269:     "x08",    "tab",   "newline","x0b",   "x0c",   "return","x0e",   "x0f",
  270:     "x10",    "x11",   "x12",    "x13",   "x14",   "x15",   "x16",   "x17",
  271:     "x18",    "x19",   "x1a",    "escape","x1c",   "x1d",   "x1e",   "x1f",
  272:     "space"
  273: };
  274: 
  275: #define CASE_ITAG(obj, str) \
  276:     case SCM_ITAG(obj): Scm_PutzUnsafe(str, -1, port); break;
  277: 
  278: /* Obj is PTR, except pair and vector */
  279: static void write_general(ScmObj obj, ScmPort *out, ScmWriteContext *ctx)
  280: {
  281:     ScmClass *c = Scm_ClassOf(obj);
  282:     if (c->print) c->print(obj, out, ctx); 
  283:     else          write_object(obj, out, ctx);
  284: }
  285: 
  286: /* Default object printer delegates print action to generic function
  287:    write-object.   We can't use VMApply here since this function can be
  288:    called deep in the recursive stack of Scm_Write, so the control
  289:    may not return to VM immediately. */
  290: static void write_object(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
  291: {
  292:     Scm_ApplyRec(SCM_OBJ(&Scm_GenericWriteObject),
  293:                  SCM_LIST2(obj, SCM_OBJ(port)));
  294: }
  295: 
  296: /* Default method for write-object */
  297: static ScmObj write_object_fallback(ScmObj *args, int nargs, ScmGeneric *gf)
  298: {
  299:     ScmClass *klass;
  300:     if (nargs != 2 || (nargs == 2 && !SCM_OPORTP(args[1]))) {
  301:         Scm_Error("No applicable method for write-object with %S",
  302:                   Scm_ArrayToList(args, nargs));
  303:     }
  304:     klass = Scm_ClassOf(args[0]);
  305:     Scm_Printf(SCM_PORT(args[1]), "#<%A%s%p>",
  306:                klass->name,
  307:                (SCM_FALSEP(klass->redefined)? " " : ":redefined "),
  308:                args[0]);
  309:     return SCM_TRUE;
  310: }
  311: 
  312: /* We need two passes to realize write/ss.
  313: 
  314:    The first pass ("walk" pass) traverses the data and finds out
  315:    all shared substructures and/or cyclic references.  It builds a
  316:    hash table of objects that need special treatment.
  317: 
  318:    The second pass ("output" pass) writes out the data.
  319:    
  320:    For the walk pass, we can't use generic traversal algorithm
  321:    if the data contains user-defined structures.  In which case,
  322:    we delegate the walk task to the user-defined print routine.
  323:    In the walk pass, a special dummy port is created.  It is a
  324:    procedural port to which all output is discarded.  If the
  325:    user-defined routine needs to traverse substructure, it calls
  326:    back system's writer routine such as Scm_Write, Scm_Printf, 
  327:    so we can effectively traverse entire data to be printed.
  328: 
  329: */
  330: 
  331: /* Dummy port for the walk pass */
  332: static ScmPortVTable walker_port_vtable = {
  333:     NULL, NULL, NULL, NULL, NULL,
  334:     NULL, NULL, NULL, NULL, NULL,
  335:     NULL, NULL
  336: };
  337: 
  338: static ScmPort *make_walker_port(void)
  339: {
  340:     ScmPort *port;
  341:     ScmObj ht;
  342:                                           
  343:     port = SCM_PORT(Scm_MakeVirtualPort(SCM_CLASS_PORT, SCM_PORT_OUTPUT,
  344:                                         &walker_port_vtable));
  345:     ht = Scm_MakeHashTableSimple(SCM_HASH_EQ, 0);
  346:     port->data = Scm_Cons(SCM_MAKE_INT(0), ht);
  347:     port->flags = SCM_PORT_WALKING;
  348:     return port;
  349: }
  350: 
  351: /* pass 1 */
  352: static void write_walk(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
  353: {
  354:     ScmHashEntry *e;
  355:     ScmHashTable *ht;
  356:     ScmObj elt;
  357:     
  358:     ht = SCM_HASH_TABLE(SCM_CDR(port->data));
  359: 
  360:     for (;;) {
  361:         if (!SCM_PTRP(obj) || SCM_SYMBOLP(obj) || SCM_KEYWORDP(obj)
  362:             || SCM_NUMBERP(obj)) {
  363:             return;
  364:         }
  365:             
  366:         if (SCM_PAIRP(obj)) {
  367:             e = Scm_HashTableGet(ht, obj);
  368:             if (e) { e->value = SCM_TRUE; return; }
  369:             Scm_HashTablePut(ht, obj, SCM_FALSE);
  370: 
  371:             elt = SCM_CAR(obj);
  372:             if (SCM_PTRP(elt)) write_walk(SCM_CAR(obj), port, ctx);
  373:             obj = SCM_CDR(obj);
  374:             continue;
  375:         }
  376:         if (SCM_STRINGP(obj) && !SCM_STRING_NULL_P(obj)) {
  377:             e = Scm_HashTableGet(ht, obj);
  378:             if (e) { e->value = SCM_TRUE; return; }
  379:             Scm_HashTablePut(ht, obj, SCM_FALSE);
  380:             return;
  381:         }
  382:         if (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) > 0) {
  383:             int i, len = SCM_VECTOR_SIZE(obj);
  384: 
  385:             e = Scm_HashTableGet(ht, obj);
  386:             if (e) { e->value = SCM_TRUE; return; }
  387:             Scm_HashTablePut(ht, obj, SCM_FALSE);
  388: 
  389:             for (i=0; i<len; i++) {
  390:                 elt = SCM_VECTOR_ELEMENT(obj, i);
  391:                 if (SCM_PTRP(elt)) write_walk(elt, port, ctx);
  392:             }
  393:             return;
  394:         }
  395:         else {
  396:             /* Now we have user-defined object.
  397:                Call the user's print routine. */
  398:             e = Scm_HashTableGet(ht, obj);
  399:             if (e) { e->value = SCM_TRUE; return; }
  400:             Scm_HashTablePut(ht, obj, SCM_FALSE);
  401: 
  402:             write_general(obj, port, ctx);
  403:             return;
  404:         }
  405:     }
  406: }
  407: 
  408: /* pass 2 */
  409: static void write_ss_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
  410: {
  411:     ScmHashEntry *e;
  412:     char numbuf[50];  /* enough to contain long number */
  413:     ScmHashTable *ht = NULL;
  414: 
  415:     if (ctx->flags & WRITE_LIMITED) {
  416:         if (port->src.ostr.length >= ctx->limit) return;
  417:     }
  418: 
  419:     if (SCM_PAIRP(port->data) && SCM_HASH_TABLE_P(SCM_CDR(port->data))) {
  420:         ht = SCM_HASH_TABLE(SCM_CDR(port->data));
  421:     }
  422: 
  423:     if (!SCM_PTRP(obj)) {
  424:         if (SCM_IMMEDIATEP(obj)) {
  425:             switch (SCM_ITAG(obj)) {
  426:                 CASE_ITAG(SCM_FALSE,     "#f");
  427:                 CASE_ITAG(SCM_TRUE,      "#t");
  428:                 CASE_ITAG(SCM_NIL,       "()");
  429:                 CASE_ITAG(SCM_EOF,       "#<eof>");
  430:                 CASE_ITAG(SCM_UNDEFINED, "#<undef>");
  431:                 CASE_ITAG(SCM_UNBOUND,   "#<unbound>");
  432:             default:
  433:                 Scm_Panic("write: unknown itag object: %08x", SCM_WORD(obj));
  434:             }
  435:         }
  436:         else if (SCM_INTP(obj)) {
  437:             char buf[SPBUFSIZ];
  438:             snprintf(buf, SPBUFSIZ, "%ld", SCM_INT_VALUE(obj));
  439:             Scm_PutzUnsafe(buf, -1, port);
  440:         }
  441:         else if (SCM_CHARP(obj)) {
  442:             ScmChar ch = SCM_CHAR_VALUE(obj);
  443:             if (SCM_WRITE_MODE(ctx) == SCM_WRITE_DISPLAY) {
  444:                 Scm_PutcUnsafe(ch, port);
  445:             } else {
  446:                 Scm_PutzUnsafe("#\\", -1, port);
  447:                 if (ch <= 0x20)       Scm_PutzUnsafe(char_names[ch], -1, port);
  448:                 else if (ch == 0x7f)  Scm_PutzUnsafe("del", -1, port);
  449:                 else                  Scm_PutcUnsafe(ch, port);
  450:             }
  451:         }
  452:         else Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
  453:         return;
  454:     }
  455:     if (SCM_NUMBERP(obj)) {
  456:         /* number may be heap allocated, but we don't use srfi-38 notation. */
  457:         write_general(obj, port, ctx);
  458:         return;
  459:     }
  460:     
  461:     if ((SCM_STRINGP(obj) && SCM_STRING_NULL_P(obj))
  462:         || (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
  463:         /* special case where we don't put a reference tag. */
  464:         write_general(obj, port, ctx);
  465:         return;
  466:     }
  467: 
  468:     if (ht) {
  469:         e = Scm_HashTableGet(ht, obj);
  470:         if (e && e->value != SCM_FALSE) {
  471:             if (SCM_INTP(e->value)) {
  472:                 /* This object is already printed. */
  473:                 snprintf(numbuf, 50, "#%ld#", SCM_INT_VALUE(e->value));
  474:                 Scm_PutzUnsafe(numbuf, -1, port);
  475:                 return;
  476:             } else {
  477:                 /* This object will be seen again. Put a reference tag. */
  478:                 int count = SCM_INT_VALUE(SCM_CAR(port->data));
  479:                 snprintf(numbuf, 50, "#%d=", count);
  480:                 e->value = SCM_MAKE_INT(count);
  481:                 SCM_SET_CAR(port->data, SCM_MAKE_INT(count+1));
  482:                 Scm_PutzUnsafe(numbuf, -1, port);
  483:             }
  484:         }
  485:     }
  486: 
  487:     /* Writes aggregates */
  488:     if (SCM_PAIRP(obj)) {
  489:         /* special case for quote etc.*/
  490:         if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))) {
  491:             int special = TRUE;
  492:             if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
  493:                 Scm_PutcUnsafe('\'', port);
  494:             } else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
  495:                 Scm_PutcUnsafe('`', port);
  496:             } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
  497:                 Scm_PutcUnsafe(',', port);
  498:             } else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
  499:                 Scm_PutzUnsafe(",@", -1, port);
  500:             } else {
  501:                 special = FALSE;
  502:             }
  503:             if (special) {
  504:                 write_ss_rec(SCM_CADR(obj), port, ctx);
  505:                 return;
  506:             }
  507:         }
  508:         
  509:         /* normal case */
  510:         Scm_PutcUnsafe('(', port);
  511:         for (;;) {
  512: 
  513:             write_ss_rec(SCM_CAR(obj), port, ctx);
  514:         
  515:             obj = SCM_CDR(obj);
  516:             if (SCM_NULLP(obj)) { Scm_PutcUnsafe(')', port); return; }
  517:             if (!SCM_PAIRP(obj)) {
  518:                 Scm_PutzUnsafe(" . ", -1, port);
  519:                 write_ss_rec(obj, port, ctx);
  520:                 Scm_PutcUnsafe(')', port);
  521:                 return;
  522:             }
  523:             if (ht) {
  524:                 e = Scm_HashTableGet(ht, obj); /* check for shared cdr */
  525:                 if (e && e->value != SCM_FALSE) {
  526:                     Scm_PutzUnsafe(" . ", -1, port);
  527:                     write_ss_rec(obj, port, ctx);
  528:                     Scm_PutcUnsafe(')', port);
  529:                     return;
  530:                 }
  531:             }
  532:             Scm_PutcUnsafe(' ', port);
  533:         }
  534:     } else if (SCM_VECTORP(obj)) {
  535:         int len, i;
  536:         ScmObj *elts;
  537:         
  538:         Scm_PutzUnsafe("#(", -1, port);
  539:         len = SCM_VECTOR_SIZE(obj);
  540:         elts = SCM_VECTOR_ELEMENTS(obj);
  541:         for (i=0; i<len-1; i++) {
  542:             write_ss_rec(elts[i], port, ctx);
  543:             Scm_PutcUnsafe(' ', port);
  544:         }
  545:         write_ss_rec(elts[i], port, ctx);
  546:         Scm_PutcUnsafe(')', port);
  547:     } else {
  548:         /* string or user-defined object */
  549:         write_general(obj, port, ctx);
  550:     }
  551: }
  552: