libguile/print.c

   1 /*      Copyright (C) 1995,1996 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "chars.h"
  46 #include "genio.h"
  47 #include "mbstrings.h"
  48 #include "smob.h"
  49 #include "eval.h"
  50 #include "procprop.h"
  51 #include "read.h"
  52 #include "weaks.h"
  53 #include "unif.h"
  54 #include "alist.h"
  55 #include "struct.h"
  56
  57 #include "print.h"
  58 \f
  59
  60 /* {Names of immediate symbols}
  61  *
  62  * This table must agree with the declarations in scm.h: {Immediate Symbols}.
  63  */
  64
  65 char *scm_isymnames[] =
  66 {
  67   /* This table must agree with the declarations */
  68   "#@and",
  69   "#@begin",
  70   "#@case",
  71   "#@cond",
  72   "#@do",
  73   "#@if",
  74   "#@lambda",
  75   "#@let",
  76   "#@let*",
  77   "#@letrec",
  78   "#@or",
  79   "#@quote",
  80   "#@set!",
  81   "#@define",
  82 #if 0
  83   "#@literal-variable-ref",
  84   "#@literal-variable-set!",
  85 #endif
  86   "#@apply",
  87   "#@call-with-current-continuation",
  88
  89  /* user visible ISYMS */
  90  /* other keywords */
  91  /* Flags */
  92
  93   "#f",
  94   "#t",
  95   "#<undefined>",
  96   "#<eof>",
  97   "()",
  98   "#<unspecified>"
  99 };
 100
 101 scm_option scm_print_opts[] = {
 102   { SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F,
 103     "Hook for printing closures." },
 104   { SCM_OPTION_BOOLEAN, "source", 0,
 105     "Print closures with source." }
 106 };
 107
 108 SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options);
 109
 110 SCM
 111 scm_print_options (setting)
 112      SCM setting;
 113 {
 114   SCM ans = scm_options (setting,
 115                          scm_print_opts,
 116                          SCM_N_PRINT_OPTIONS,
 117                          s_print_options);
 118   return ans;
 119 }
 120
 121 \f
 122 /* {Printing of Scheme Objects}
 123  */
 124
 125 /* Detection of circular references.
 126  *
 127  * Due to other constraints in the implementation, this code has bad
 128  * time complexity (O (depth * N)), The printer code will be
 129  * completely rewritten before next release of Guile.  The new code
 130  * will be O(N).
 131  */
 132 #define PUSH_REF(pstate, obj) \
 133 { \
 134   pstate->ref_stack[pstate->top++] = (obj); \
 135   if (pstate->top == pstate->ceiling) \
 136     grow_ref_stack (pstate); \
 137 }
 138
 139 #define ENTER_NESTED_DATA(pstate, obj, label) \
 140 { \
 141   register int i; \
 142   for (i = 0; i < pstate->top; ++i) \
 143     if (pstate->ref_stack[i] == (obj)) \
 144       goto label; \
 145   if (pstate->fancyp) \
 146     { \
 147       if (pstate->top - pstate->list_offset >= pstate->level) \
 148         { \
 149           scm_gen_putc ('#', port); \
 150           return; \
 151         } \
 152     } \
 153   PUSH_REF(pstate, obj); \
 154 } \
 155
 156 #define EXIT_NESTED_DATA(pstate) { --pstate->top; }
 157
 158 static SCM print_state_pool;
 159
 160 #if 1 /* Used for debugging purposes */
 161 SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
 162
 163 SCM
 164 scm_current_pstate ()
 165 {
 166   return SCM_CADR (print_state_pool);
 167 }
 168 #endif
 169
 170 #define PSTATE_SIZE 50L
 171
 172 static SCM make_print_state SCM_P ((void));
 173
 174 static SCM
 175 make_print_state ()
 176 {
 177   SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */
 178                                      SCM_MAKINUM (PSTATE_SIZE),
 179                                      SCM_EOL);
 180   SCM_PRINT_STATE (print_state)->ceiling = PSTATE_SIZE;
 181   return print_state;
 182 }
 183
 184 SCM
 185 scm_make_print_state ()
 186 {
 187   SCM answer = 0;
 188
 189   /* First try to allocate a print state from the pool */
 190   SCM_DEFER_INTS;
 191   if (SCM_NNULLP (SCM_CDR (print_state_pool)))
 192     {
 193       answer = SCM_CADR (print_state_pool);
 194       SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
 195     }
 196   SCM_ALLOW_INTS;
 197
 198   return answer ? answer : make_print_state ();
 199 }
 200
 201 void
 202 scm_free_print_state (print_state)
 203      SCM print_state;
 204 {
 205   SCM handle;
 206   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 207   /* Cleanup before returning print state to pool.
 208    * It is better to do it here.  Doing it in scm_prin1
 209    * would cost more since that function is called much more
 210    * often.
 211    */
 212   pstate->fancyp = 0;
 213   SCM_NEWCELL (handle);
 214   SCM_DEFER_INTS;
 215   SCM_SETCAR (handle, print_state);
 216   SCM_SETCDR (handle, SCM_CDR (print_state_pool));
 217   SCM_SETCDR (print_state_pool, handle);
 218   SCM_ALLOW_INTS;
 219 }
 220
 221 static void grow_ref_stack SCM_P ((scm_print_state *pstate));
 222
 223 static void
 224 grow_ref_stack (pstate)
 225      scm_print_state *pstate;
 226 {
 227   int i, size = pstate->ceiling;
 228   int total_size;
 229   SCM handle;
 230   SCM *data;
 231   SCM_DEFER_INTS;
 232   handle = pstate->handle;
 233   data = (SCM *) pstate - scm_struct_n_extra_words;
 234   total_size = ((SCM *) pstate)[scm_struct_i_n_words];
 235   data = (SCM *) scm_must_realloc ((char *) data,
 236                                    total_size,
 237                                    total_size + size,
 238                                    "grow_ref_stack");
 239   pstate = (scm_print_state *) (data + scm_struct_n_extra_words);
 240   ((SCM *) pstate)[scm_struct_i_n_words] = total_size + size;
 241   pstate->ceiling += size;
 242   for (i = size; i < pstate->ceiling; ++i)
 243     pstate->ref_stack[i] = SCM_BOOL_F;
 244   SCM_SETCDR (handle, pstate);
 245   SCM_ALLOW_INTS;
 246 }
 247
 248
 249 static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref));
 250
 251 static void
 252 print_circref (port, pstate, ref)
 253      SCM port;
 254      scm_print_state *pstate;
 255      SCM ref;
 256 {
 257   register int i;
 258   int self = pstate->top - 1;
 259   i = pstate->top - 1;
 260   if (SCM_CONSP (pstate->ref_stack[i]))
 261     {
 262       while (i > 0)
 263         {
 264           if (SCM_NCONSP (pstate->ref_stack[i - 1])
 265               || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i])
 266             break;
 267           --i;
 268         }
 269       self = i;
 270     }
 271   for (i = pstate->top - 1; 1; --i)
 272     if (pstate->ref_stack[i] == ref)
 273       break;
 274   scm_gen_putc ('#', port);
 275   scm_intprint (i - self, 10, port);
 276   scm_gen_putc ('#', port);
 277 }
 278
 279 /* Print generally.  Handles both write and display according to PSTATE.
 280  */
 281
 282
 283 void
 284 scm_iprin1 (exp, port, pstate)
 285      SCM exp;
 286      SCM port;
 287      scm_print_state *pstate;
 288 {
 289   register long i;
 290 taloop:
 291   switch (7 & (int) exp)
 292     {
 293     case 2:
 294     case 6:
 295       scm_intprint (SCM_INUM (exp), 10, port);
 296       break;
 297     case 4:
 298       if (SCM_ICHRP (exp))
 299         {
 300           i = SCM_ICHR (exp);
 301           scm_put_wchar (i, port, SCM_WRITINGP (pstate));
 302
 303         }
 304       else if (SCM_IFLAGP (exp)
 305                && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
 306           scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port);
 307       else if (SCM_ILOCP (exp))
 308         {
 309           scm_gen_puts (scm_regular_string, "#@", port);
 310           scm_intprint ((long) SCM_IFRAME (exp), 10, port);
 311           scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port);
 312           scm_intprint ((long) SCM_IDIST (exp), 10, port);
 313         }
 314       else
 315         goto idef;
 316       break;
 317     case 1:
 318       /* gloc */
 319       scm_gen_puts (scm_regular_string, "#@", port);
 320       exp = SCM_CAR (exp - 1);
 321       goto taloop;
 322     default:
 323     idef:
 324       scm_ipruk ("immediate", exp, port);
 325       break;
 326     case 0:
 327       switch (SCM_TYP7 (exp))
 328         {
 329         case scm_tcs_cons_gloc:
 330
 331           if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
 332             {
 333               scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
 334               scm_intprint(exp, 16, port);
 335               scm_gen_putc ('>', port);
 336               break;
 337             }
 338
 339         case scm_tcs_cons_imcar:
 340         case scm_tcs_cons_nimcar:
 341           ENTER_NESTED_DATA (pstate, exp, circref);
 342           scm_iprlist ("(", exp, ')', port, pstate);
 343           EXIT_NESTED_DATA (pstate);
 344           break;
 345         circref:
 346           print_circref (port, pstate, exp);
 347           break;
 348         case scm_tcs_closures:
 349           if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
 350             {
 351               SCM ans = scm_cons2 (exp, port,
 352                                    scm_cons (SCM_WRITINGP (pstate)
 353                                              ? SCM_BOOL_T
 354                                              : SCM_BOOL_F,
 355                                              SCM_EOL));
 356               ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
 357             }
 358           else
 359             {
 360               SCM name, code;
 361               name = scm_procedure_property (exp, scm_i_name);
 362               code = SCM_CODE (exp);
 363               scm_gen_puts (scm_regular_string, "#<procedure ", port);
 364               if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 365                 {
 366                   scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
 367                   scm_gen_putc (' ', port);
 368                 }
 369               scm_iprin1 (SCM_CAR (code), port, pstate);
 370               if (SCM_PRINT_SOURCE_P)
 371                 {
 372                   code = scm_unmemocopy (SCM_CDR (code),
 373                                          SCM_EXTEND_ENV (SCM_CAR (code),
 374                                                          SCM_EOL,
 375                                                          SCM_ENV (exp)));
 376                   ENTER_NESTED_DATA (pstate, exp, circref);
 377                   scm_iprlist (" ", code, '>', port, pstate);
 378                   EXIT_NESTED_DATA (pstate);
 379                 }
 380               else
 381                 scm_gen_putc ('>', port);
 382             }
 383           break;
 384         case scm_tc7_mb_string:
 385         case scm_tc7_mb_substring:
 386           scm_print_mb_string (exp, port, SCM_WRITINGP (pstate));
 387           break;
 388         case scm_tc7_substring:
 389         case scm_tc7_string:
 390           if (SCM_WRITINGP (pstate))
 391             {
 392               scm_gen_putc ('"', port);
 393               for (i = 0; i < SCM_ROLENGTH (exp); ++i)
 394                 switch (SCM_ROCHARS (exp)[i])
 395                   {
 396                   case '"':
 397                   case '\\':
 398                     scm_gen_putc ('\\', port);
 399                   default:
 400                     scm_gen_putc (SCM_ROCHARS (exp)[i], port);
 401                   }
 402               scm_gen_putc ('"', port);
 403               break;
 404             }
 405           else
 406             scm_gen_write (scm_regular_string, SCM_ROCHARS (exp),
 407                            (scm_sizet) SCM_ROLENGTH (exp),
 408                            port);
 409           break;
 410         case scm_tcs_symbols:
 411           if (SCM_MB_STRINGP (exp))
 412             {
 413               scm_print_mb_symbol (exp, port);
 414               break;
 415             }
 416           else
 417             {
 418               int pos;
 419               int end;
 420               int len;
 421               char * str;
 422               int weird;
 423               int maybe_weird;
 424               int mw_pos;
 425
 426               len = SCM_LENGTH (exp);
 427               str = SCM_CHARS (exp);
 428               scm_remember (&exp);
 429               pos = 0;
 430               weird = 0;
 431               maybe_weird = 0;
 432
 433               if (len == 0)
 434                 scm_gen_write (scm_regular_string, "#{}#", 4, port);
 435
 436               for (end = pos; end < len; ++end)
 437                 switch (str[end])
 438                   {
 439 #ifdef BRACKETS_AS_PARENS
 440                   case '[':
 441                   case ']':
 442 #endif
 443                   case '(':
 444                   case ')':
 445                   case '"':
 446                   case ';':
 447                   case SCM_WHITE_SPACES:
 448                   case SCM_LINE_INCREMENTORS:
 449                   weird_handler:
 450                     if (maybe_weird)
 451                       {
 452                         end = mw_pos;
 453                         maybe_weird = 0;
 454                       }
 455                     if (!weird)
 456                       {
 457                         scm_gen_write (scm_regular_string, "#{", 2, port);
 458                         weird = 1;
 459                       }
 460                     if (pos < end)
 461                       {
 462                         scm_gen_write (scm_regular_string, str + pos, end - pos, port);
 463                       }
 464                     {
 465                       char buf[2];
 466                       buf[0] = '\\';
 467                       buf[1] = str[end];
 468                       scm_gen_write (scm_regular_string, buf, 2, port);
 469                     }
 470                     pos = end + 1;
 471                     break;
 472                   case '\\':
 473                     if (weird)
 474                       goto weird_handler;
 475                     if (!maybe_weird)
 476                       {
 477                         maybe_weird = 1;
 478                         mw_pos = pos;
 479                       }
 480                     break;
 481                   case '}':
 482                   case '#':
 483                     if (weird)
 484                       goto weird_handler;
 485                     break;
 486                   default:
 487                     break;
 488                   }
 489               if (pos < end)
 490                 scm_gen_write (scm_regular_string, str + pos, end - pos, port);
 491               if (weird)
 492                 scm_gen_write (scm_regular_string, "}#", 2, port);
 493               break;
 494             }
 495         case scm_tc7_wvect:
 496           ENTER_NESTED_DATA (pstate, exp, circref);
 497           if (SCM_IS_WHVEC (exp))
 498             scm_gen_puts (scm_regular_string, "#wh(", port);
 499           else
 500             scm_gen_puts (scm_regular_string, "#w(", port);
 501           goto common_vector_printer;
 502
 503         case scm_tc7_vector:
 504           ENTER_NESTED_DATA (pstate, exp, circref);
 505           scm_gen_puts (scm_regular_string, "#(", port);
 506         common_vector_printer:
 507           for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
 508             {
 509               /* CHECK_INTS; */
 510               scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 511               scm_gen_putc (' ', port);
 512             }
 513           if (i < SCM_LENGTH (exp))
 514             {
 515               /* CHECK_INTS; */
 516               scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 517             }
 518           scm_gen_putc (')', port);
 519           EXIT_NESTED_DATA (pstate);
 520           break;
 521         case scm_tc7_bvect:
 522         case scm_tc7_byvect:
 523         case scm_tc7_svect:
 524         case scm_tc7_ivect:
 525         case scm_tc7_uvect:
 526         case scm_tc7_fvect:
 527         case scm_tc7_dvect:
 528         case scm_tc7_cvect:
 529 #ifdef LONGLONGS
 530         case scm_tc7_llvect:
 531 #endif
 532           scm_raprin1 (exp, port, pstate);
 533           break;
 534         case scm_tcs_subrs:
 535           scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
 536           scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
 537                          ? scm_mb_string
 538                          : scm_regular_string),
 539                         SCM_CHARS (SCM_SNAME (exp)), port);
 540           scm_gen_putc ('>', port);
 541           break;
 542 #ifdef CCLO
 543         case scm_tc7_cclo:
 544           scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
 545           scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
 546           scm_gen_putc ('>', port);
 547           break;
 548 #endif
 549         case scm_tc7_contin:
 550           scm_gen_puts (scm_regular_string, "#<continuation ", port);
 551           scm_intprint (SCM_LENGTH (exp), 10, port);
 552           scm_gen_puts (scm_regular_string, " @ ", port);
 553           scm_intprint ((long) SCM_CHARS (exp), 16, port);
 554           scm_gen_putc ('>', port);
 555           break;
 556         case scm_tc7_port:
 557           i = SCM_PTOBNUM (exp);
 558           if (i < scm_numptob
 559               && scm_ptobs[i].print
 560               && (scm_ptobs[i].print) (exp, port, pstate))
 561             break;
 562           goto punk;
 563         case scm_tc7_smob:
 564           ENTER_NESTED_DATA (pstate, exp, circref);
 565           i = SCM_SMOBNUM (exp);
 566           if (i < scm_numsmob && scm_smobs[i].print
 567               && (scm_smobs[i].print) (exp, port, pstate))
 568             {
 569               EXIT_NESTED_DATA (pstate);
 570               break;
 571             }
 572           EXIT_NESTED_DATA (pstate);
 573         default:
 574         punk:
 575           scm_ipruk ("type", exp, port);
 576         }
 577     }
 578 }
 579
 580 /* Print states are necessary for circular reference safe printing.
 581  * They are also expensive to allocate.  Therefore print states are
 582  * kept in a pool so that they can be reused.
 583  */
 584
 585 void
 586 scm_prin1 (exp, port, writingp)
 587      SCM exp;
 588      SCM port;
 589      int writingp;
 590 {
 591   SCM handle = 0; /* Will GC protect the handle whilst unlinked */
 592   scm_print_state *pstate;
 593
 594   /* First try to allocate a print state from the pool */
 595   SCM_DEFER_INTS;
 596   if (SCM_NNULLP (SCM_CDR (print_state_pool)))
 597     {
 598       handle = SCM_CDR (print_state_pool);
 599       SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
 600     }
 601   SCM_ALLOW_INTS;
 602
 603   if (!handle)
 604     handle = scm_cons (make_print_state (), SCM_EOL);
 605
 606   pstate = SCM_PRINT_STATE (SCM_CAR (handle));
 607   pstate->writingp = writingp;
 608   scm_iprin1 (exp, port, pstate);
 609
 610   /* Return print state to pool */
 611   SCM_DEFER_INTS;
 612   SCM_SETCDR (handle, SCM_CDR (print_state_pool));
 613   SCM_SETCDR (print_state_pool, handle);
 614   SCM_ALLOW_INTS;
 615 }
 616
 617
 618 /* Print an integer.
 619  */
 620
 621 void
 622 scm_intprint (n, radix, port)
 623      long n;
 624      int radix;
 625      SCM port;
 626 {
 627   char num_buf[SCM_INTBUFLEN];
 628   scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
 629 }
 630
 631 /* Print an object of unrecognized type.
 632  */
 633
 634 void
 635 scm_ipruk (hdr, ptr, port)
 636      char *hdr;
 637      SCM ptr;
 638      SCM port;
 639 {
 640   scm_gen_puts (scm_regular_string, "#<unknown-", port);
 641   scm_gen_puts (scm_regular_string, hdr, port);
 642   if (SCM_CELLP (ptr))
 643     {
 644       scm_gen_puts (scm_regular_string, " (0x", port);
 645       scm_intprint (SCM_CAR (ptr), 16, port);
 646       scm_gen_puts (scm_regular_string, " . 0x", port);
 647       scm_intprint (SCM_CDR (ptr), 16, port);
 648       scm_gen_puts (scm_regular_string, ") @", port);
 649     }
 650   scm_gen_puts (scm_regular_string, " 0x", port);
 651   scm_intprint (ptr, 16, port);
 652   scm_gen_putc ('>', port);
 653 }
 654
 655 /* Print a list.
 656  */
 657
 658
 659 void
 660 scm_iprlist (hdr, exp, tlr, port, pstate)
 661      char *hdr;
 662      SCM exp;
 663      char tlr;
 664      SCM port;
 665      scm_print_state *pstate;
 666 {
 667   register int i;
 668   register SCM hare, tortoise;
 669   int floor = pstate->top - 2;
 670   scm_gen_puts (scm_regular_string, hdr, port);
 671   /* CHECK_INTS; */
 672   if (pstate->fancyp)
 673     goto fancy_printing;
 674
 675   /* Run a hare and tortoise so that total time complexity will be
 676      O(depth * N) instead of O(N^2). */
 677   hare = SCM_CDR (exp);
 678   tortoise = exp;
 679   while (SCM_NIMP (hare) && SCM_ECONSP (hare))
 680     {
 681       if (hare == tortoise)
 682         goto fancy_printing;
 683       hare = SCM_CDR (hare);
 684       if (SCM_IMP (hare) || SCM_NECONSP (hare))
 685         break;
 686       hare = SCM_CDR (hare);
 687       tortoise = SCM_CDR (tortoise);
 688     }
 689
 690   /* No cdr cycles intrinsic to this list */
 691   scm_iprin1 (SCM_CAR (exp), port, pstate);
 692   exp = SCM_CDR (exp);
 693   for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 694     {
 695       if (SCM_NECONSP (exp))
 696         break;
 697       for (i = floor; i >= 0; --i)
 698         if (pstate->ref_stack[i] == exp)
 699           goto circref;
 700       PUSH_REF (pstate, exp);
 701       scm_gen_putc (' ', port);
 702       /* CHECK_INTS; */
 703       scm_iprin1 (SCM_CAR (exp), port, pstate);
 704     }
 705   if (SCM_NNULLP (exp))
 706     {
 707       scm_gen_puts (scm_regular_string, " . ", port);
 708       scm_iprin1 (exp, port, pstate);
 709     }
 710
 711 end:
 712   scm_gen_putc (tlr, port);
 713   pstate->top = floor + 2;
 714   return;
 715
 716 fancy_printing:
 717   {
 718     int n = pstate->length;
 719
 720     scm_iprin1 (SCM_CAR (exp), port, pstate);
 721     exp = SCM_CDR (exp); --n;
 722     for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 723       {
 724         if (SCM_NECONSP (exp))
 725           break;
 726         for (i = 0; i < pstate->top; ++i)
 727           if (pstate->ref_stack[i] == exp)
 728             goto fancy_circref;
 729         if (pstate->fancyp)
 730           {
 731             if (n == 0)
 732               {
 733                 scm_gen_puts (scm_regular_string, " ...", port);
 734                 goto skip_tail;
 735               }
 736             else
 737               --n;
 738           }
 739         PUSH_REF(pstate, exp);
 740         ++pstate->list_offset;
 741         scm_gen_putc (' ', port);
 742         /* CHECK_INTS; */
 743         scm_iprin1 (SCM_CAR (exp), port, pstate);
 744       }
 745   }
 746   if (SCM_NNULLP (exp))
 747     {
 748       scm_gen_puts (scm_regular_string, " . ", port);
 749       scm_iprin1 (exp, port, pstate);
 750     }
 751 skip_tail:
 752   pstate->list_offset -= pstate->top - floor - 2;
 753   goto end;
 754
 755 fancy_circref:
 756   pstate->list_offset -= pstate->top - floor - 2;
 757
 758 circref:
 759   scm_gen_puts (scm_regular_string, " . ", port);
 760   print_circref (port, pstate, exp);
 761   goto end;
 762 }
 763
 764 \f
 765
 766 SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
 767
 768 SCM
 769 scm_write (obj, port)
 770      SCM obj;
 771      SCM port;
 772 {
 773   if (SCM_UNBNDP (port))
 774     port = scm_cur_outp;
 775   else
 776     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
 777   scm_prin1 (obj, port, 1);
 778 #ifdef HAVE_PIPE
 779 # ifdef EPIPE
 780   if (EPIPE == errno)
 781     scm_close_port (port);
 782 # endif
 783 #endif
 784   return SCM_UNSPECIFIED;
 785 }
 786
 787
 788 SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
 789
 790 SCM
 791 scm_display (obj, port)
 792      SCM obj;
 793      SCM port;
 794 {
 795   if (SCM_UNBNDP (port))
 796     port = scm_cur_outp;
 797   else
 798     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
 799   scm_prin1 (obj, port, 0);
 800 #ifdef HAVE_PIPE
 801 # ifdef EPIPE
 802   if (EPIPE == errno)
 803     scm_close_port (port);
 804 # endif
 805 #endif
 806   return SCM_UNSPECIFIED;
 807 }
 808
 809 SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
 810
 811 SCM
 812 scm_newline (port)
 813      SCM port;
 814 {
 815   if (SCM_UNBNDP (port))
 816  port = scm_cur_outp;
 817   else
 818     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
 819   scm_gen_putc ('\n', port);
 820 #ifdef HAVE_PIPE
 821 # ifdef EPIPE
 822   if (EPIPE == errno)
 823     scm_close_port (port);
 824   else
 825 # endif
 826 #endif
 827   if (port == scm_cur_outp)
 828     scm_fflush (port);
 829   return SCM_UNSPECIFIED;
 830 }
 831
 832 SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
 833
 834 SCM
 835 scm_write_char (chr, port)
 836      SCM chr;
 837      SCM port;
 838 {
 839   if (SCM_UNBNDP (port))
 840  port = scm_cur_outp;
 841   else
 842     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
 843   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
 844   scm_gen_putc ((int) SCM_ICHR (chr), port);
 845 #ifdef HAVE_PIPE
 846 # ifdef EPIPE
 847   if (EPIPE == errno)
 848     scm_close_port (port);
 849 # endif
 850 #endif
 851   return SCM_UNSPECIFIED;
 852 }
 853
 854
 855 \f
 856
 857
 858 void
 859 scm_init_print ()
 860 {
 861   SCM vtable, type;
 862   scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
 863   vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_makfrom0str ("")), SCM_INUM0, SCM_EOL);
 864   type = scm_make_struct (vtable,
 865                           SCM_INUM0,
 866                           scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)),
 867                                     SCM_EOL));
 868   print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
 869 #include "print.x"
 870 }