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 #ifdef __STDC__
 110 SCM
 111 scm_print_options (SCM setting)
 112 #else
 113 SCM
 114 scm_print_options (setting)
 115      SCM setting;
 116 #endif
 117 {
 118   SCM ans = scm_options (setting,
 119                          scm_print_opts,
 120                          SCM_N_PRINT_OPTIONS,
 121                          s_print_options);
 122   return ans;
 123 }
 124
 125 \f
 126 /* {Printing of Scheme Objects}
 127  */
 128
 129 /* Detection of circular references.
 130  *
 131  * Due to other constraints in the implementation, this code has bad
 132  * time complexity (O (depth * N)), The printer code will be
 133  * completely rewritten before next release of Guile.  The new code
 134  * will be O(N).
 135  */
 136 #define PUSH_REF(pstate, obj) \
 137 { \
 138   pstate->ref_stack[pstate->top++] = (obj); \
 139   if (pstate->top == pstate->ceiling) \
 140     grow_ref_stack (pstate); \
 141 }
 142
 143 #define ENTER_NESTED_DATA(pstate, obj, label) \
 144 { \
 145   register int i; \
 146   for (i = 0; i < pstate->top; ++i) \
 147     if (pstate->ref_stack[i] == (obj)) \
 148       goto label; \
 149   if (pstate->fancyp) \
 150     { \
 151       if (pstate->top - pstate->list_offset >= pstate->level) \
 152         { \
 153           scm_gen_putc ('#', port); \
 154           return; \
 155         } \
 156     } \
 157   PUSH_REF(pstate, obj); \
 158 } \
 159
 160 #define EXIT_NESTED_DATA(pstate) { --pstate->top; }
 161
 162 static SCM print_state_pool;
 163
 164 #if 1 /* Used for debugging purposes */
 165 SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
 166 #ifdef __STDC__
 167 SCM
 168 scm_current_pstate (void)
 169 #else
 170 SCM
 171 scm_current_pstate ()
 172 #endif
 173 {
 174   return SCM_CADR (print_state_pool);
 175 }
 176 #endif
 177
 178 #define PSTATE_SIZE 50L
 179
 180 #ifdef __STDC__
 181 SCM
 182 scm_make_print_state (void)
 183 #else
 184 SCM
 185 scm_make_print_state ()
 186 #endif
 187 {
 188   return scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */
 189                           SCM_MAKINUM (PSTATE_SIZE),
 190                           SCM_EOL);
 191 }
 192
 193 #ifdef __STDC__
 194 static void
 195 grow_ref_stack (scm_print_state *pstate)
 196 #else
 197 static void
 198 grow_ref_stack (pstate)
 199      scm_print_state *pstate;
 200 #endif
 201 {
 202   int i, size = pstate->ceiling;
 203   int total_size;
 204   SCM handle;
 205   SCM *data;
 206   SCM_DEFER_INTS;
 207   handle = pstate->handle;
 208   data = (SCM *) pstate - scm_struct_n_extra_words;
 209   total_size = ((SCM *) pstate)[scm_struct_i_n_words];
 210   data = (SCM *) scm_must_realloc ((char *) data,
 211                                    total_size,
 212                                    total_size + size,
 213                                    "grow_ref_stack");
 214   pstate = (scm_print_state *) (data + scm_struct_n_extra_words);
 215   ((SCM *) pstate)[scm_struct_i_n_words] = total_size + size;
 216   pstate->ceiling += size;
 217   for (i = size; i < pstate->ceiling; ++i)
 218     pstate->ref_stack[i] = SCM_BOOL_F;
 219   SCM_SETCDR (handle, pstate);
 220   SCM_ALLOW_INTS;
 221 }
 222
 223 #ifdef __STDC__
 224 static void
 225 print_circref (SCM port, scm_print_state *pstate, SCM ref)
 226 #else
 227 static void
 228 print_circref (port, pstate, ref)
 229      SCM port;
 230      scm_print_state *pstate;
 231      SCM ref;
 232 #endif
 233 {
 234   register int i;
 235   int self = pstate->top - 1;
 236   i = pstate->top - 1;
 237   if (SCM_CONSP (pstate->ref_stack[i]))
 238     {
 239       while (i > 0)
 240         {
 241           if (SCM_NCONSP (pstate->ref_stack[i - 1])
 242               || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i])
 243             break;
 244           --i;
 245         }
 246       self = i;
 247     }
 248   for (i = pstate->top - 1; 1; --i)
 249     if (pstate->ref_stack[i] == ref)
 250       break;
 251   scm_gen_putc ('#', port);
 252   scm_intprint (i - self, 10, port);
 253   scm_gen_putc ('#', port);
 254 }
 255
 256 /* Print generally.  Handles both write and display according to PSTATE.
 257  */
 258
 259 #ifdef __STDC__
 260 void
 261 scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 262 #else
 263 void
 264 scm_iprin1 (exp, port, pstate)
 265      SCM exp;
 266      SCM port;
 267      scm_print_state *pstate;
 268 #endif
 269 {
 270   register long i;
 271 taloop:
 272   switch (7 & (int) exp)
 273     {
 274     case 2:
 275     case 6:
 276       scm_intprint (SCM_INUM (exp), 10, port);
 277       break;
 278     case 4:
 279       if (SCM_ICHRP (exp))
 280         {
 281           i = SCM_ICHR (exp);
 282           scm_put_wchar (i, port, SCM_WRITINGP (pstate));
 283
 284         }
 285       else if (SCM_IFLAGP (exp)
 286                && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
 287           scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port);
 288       else if (SCM_ILOCP (exp))
 289         {
 290           scm_gen_puts (scm_regular_string, "#@", port);
 291           scm_intprint ((long) SCM_IFRAME (exp), 10, port);
 292           scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port);
 293           scm_intprint ((long) SCM_IDIST (exp), 10, port);
 294         }
 295       else
 296         goto idef;
 297       break;
 298     case 1:
 299       /* gloc */
 300       scm_gen_puts (scm_regular_string, "#@", port);
 301       exp = SCM_CAR (exp - 1);
 302       goto taloop;
 303     default:
 304     idef:
 305       scm_ipruk ("immediate", exp, port);
 306       break;
 307     case 0:
 308       switch (SCM_TYP7 (exp))
 309         {
 310         case scm_tcs_cons_gloc:
 311
 312           if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
 313             {
 314               scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
 315               scm_intprint(exp, 16, port);
 316               scm_gen_putc ('>', port);
 317               break;
 318             }
 319
 320         case scm_tcs_cons_imcar:
 321         case scm_tcs_cons_nimcar:
 322           ENTER_NESTED_DATA (pstate, exp, circref);
 323           scm_iprlist ("(", exp, ')', port, pstate);
 324           EXIT_NESTED_DATA (pstate);
 325           break;
 326         circref:
 327           print_circref (port, pstate, exp);
 328           break;
 329         case scm_tcs_closures:
 330           if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
 331             {
 332               SCM ans = scm_cons2 (exp, port,
 333                                    scm_cons (SCM_WRITINGP (pstate)
 334                                              ? SCM_BOOL_T
 335                                              : SCM_BOOL_F,
 336                                              SCM_EOL));
 337               ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
 338             }
 339           else
 340             {
 341               SCM name, code;
 342               name = scm_procedure_property (exp, scm_i_name);
 343               code = SCM_CODE (exp);
 344               scm_gen_puts (scm_regular_string, "#<procedure ", port);
 345               if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 346                 {
 347                   scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
 348                   scm_gen_putc (' ', port);
 349                 }
 350               scm_iprin1 (SCM_CAR (code), port, pstate);
 351               if (SCM_PRINT_SOURCE_P)
 352                 {
 353                   code = scm_unmemocopy (SCM_CDR (code),
 354                                          SCM_EXTEND_ENV (SCM_CAR (code),
 355                                                          SCM_EOL,
 356                                                          SCM_ENV (exp)));
 357                   ENTER_NESTED_DATA (pstate, exp, circref);
 358                   scm_iprlist (" ", code, '>', port, pstate);
 359                   EXIT_NESTED_DATA (pstate);
 360                 }
 361               else
 362                 scm_gen_putc ('>', port);
 363             }
 364           break;
 365         case scm_tc7_mb_string:
 366         case scm_tc7_mb_substring:
 367           scm_print_mb_string (exp, port, SCM_WRITINGP (pstate));
 368           break;
 369         case scm_tc7_substring:
 370         case scm_tc7_string:
 371           if (SCM_WRITINGP (pstate))
 372             {
 373               scm_gen_putc ('"', port);
 374               for (i = 0; i < SCM_ROLENGTH (exp); ++i)
 375                 switch (SCM_ROCHARS (exp)[i])
 376                   {
 377                   case '"':
 378                   case '\\':
 379                     scm_gen_putc ('\\', port);
 380                   default:
 381                     scm_gen_putc (SCM_ROCHARS (exp)[i], port);
 382                   }
 383               scm_gen_putc ('"', port);
 384               break;
 385             }
 386           else
 387             scm_gen_write (scm_regular_string, SCM_ROCHARS (exp),
 388                            (scm_sizet) SCM_ROLENGTH (exp),
 389                            port);
 390           break;
 391         case scm_tcs_symbols:
 392           if (SCM_MB_STRINGP (exp))
 393             {
 394               scm_print_mb_symbol (exp, port);
 395               break;
 396             }
 397           else
 398             {
 399               int pos;
 400               int end;
 401               int len;
 402               char * str;
 403               int weird;
 404               int maybe_weird;
 405               int mw_pos;
 406
 407               len = SCM_LENGTH (exp);
 408               str = SCM_CHARS (exp);
 409               scm_remember (&exp);
 410               pos = 0;
 411               weird = 0;
 412               maybe_weird = 0;
 413
 414               if (len == 0)
 415                 scm_gen_write (scm_regular_string, "#{}#", 4, port);
 416
 417               for (end = pos; end < len; ++end)
 418                 switch (str[end])
 419                   {
 420 #ifdef BRACKETS_AS_PARENS
 421                   case '[':
 422                   case ']':
 423 #endif
 424                   case '(':
 425                   case ')':
 426                   case '"':
 427                   case ';':
 428                   case SCM_WHITE_SPACES:
 429                   case SCM_LINE_INCREMENTORS:
 430                   weird_handler:
 431                     if (maybe_weird)
 432                       {
 433                         end = mw_pos;
 434                         maybe_weird = 0;
 435                       }
 436                     if (!weird)
 437                       {
 438                         scm_gen_write (scm_regular_string, "#{", 2, port);
 439                         weird = 1;
 440                       }
 441                     if (pos < end)
 442                       {
 443                         scm_gen_write (scm_regular_string, str + pos, end - pos, port);
 444                       }
 445                     {
 446                       char buf[2];
 447                       buf[0] = '\\';
 448                       buf[1] = str[end];
 449                       scm_gen_write (scm_regular_string, buf, 2, port);
 450                     }
 451                     pos = end + 1;
 452                     break;
 453                   case '\\':
 454                     if (weird)
 455                       goto weird_handler;
 456                     if (!maybe_weird)
 457                       {
 458                         maybe_weird = 1;
 459                         mw_pos = pos;
 460                       }
 461                     break;
 462                   case '}':
 463                   case '#':
 464                     if (weird)
 465                       goto weird_handler;
 466                     break;
 467                   default:
 468                     break;
 469                   }
 470               if (pos < end)
 471                 scm_gen_write (scm_regular_string, str + pos, end - pos, port);
 472               if (weird)
 473                 scm_gen_write (scm_regular_string, "}#", 2, port);
 474               break;
 475             }
 476         case scm_tc7_wvect:
 477           ENTER_NESTED_DATA (pstate, exp, circref);
 478           if (SCM_IS_WHVEC (exp))
 479             scm_gen_puts (scm_regular_string, "#wh(", port);
 480           else
 481             scm_gen_puts (scm_regular_string, "#w(", port);
 482           goto common_vector_printer;
 483
 484         case scm_tc7_vector:
 485           ENTER_NESTED_DATA (pstate, exp, circref);
 486           scm_gen_puts (scm_regular_string, "#(", port);
 487         common_vector_printer:
 488           for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
 489             {
 490               /* CHECK_INTS; */
 491               scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 492               scm_gen_putc (' ', port);
 493             }
 494           if (i < SCM_LENGTH (exp))
 495             {
 496               /* CHECK_INTS; */
 497               scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 498             }
 499           scm_gen_putc (')', port);
 500           EXIT_NESTED_DATA (pstate);
 501           break;
 502         case scm_tc7_bvect:
 503         case scm_tc7_byvect:
 504         case scm_tc7_svect:
 505         case scm_tc7_ivect:
 506         case scm_tc7_uvect:
 507         case scm_tc7_fvect:
 508         case scm_tc7_dvect:
 509         case scm_tc7_cvect:
 510 #ifdef LONGLONGS
 511         case scm_tc7_llvect:
 512 #endif
 513           scm_raprin1 (exp, port, pstate);
 514           break;
 515         case scm_tcs_subrs:
 516           scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
 517           scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
 518                          ? scm_mb_string
 519                          : scm_regular_string),
 520                         SCM_CHARS (SCM_SNAME (exp)), port);
 521           scm_gen_putc ('>', port);
 522           break;
 523 #ifdef CCLO
 524         case scm_tc7_cclo:
 525           scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
 526           scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
 527           scm_gen_putc ('>', port);
 528           break;
 529 #endif
 530         case scm_tc7_contin:
 531           scm_gen_puts (scm_regular_string, "#<continuation ", port);
 532           scm_intprint (SCM_LENGTH (exp), 10, port);
 533           scm_gen_puts (scm_regular_string, " @ ", port);
 534           scm_intprint ((long) SCM_CHARS (exp), 16, port);
 535           scm_gen_putc ('>', port);
 536           break;
 537         case scm_tc7_port:
 538           i = SCM_PTOBNUM (exp);
 539           if (i < scm_numptob
 540               && scm_ptobs[i].print
 541               && (scm_ptobs[i].print) (exp, port, pstate))
 542             break;
 543           goto punk;
 544         case scm_tc7_smob:
 545           ENTER_NESTED_DATA (pstate, exp, circref);
 546           i = SCM_SMOBNUM (exp);
 547           if (i < scm_numsmob && scm_smobs[i].print
 548               && (scm_smobs[i].print) (exp, port, pstate))
 549             {
 550               EXIT_NESTED_DATA (pstate);
 551               break;
 552             }
 553           EXIT_NESTED_DATA (pstate);
 554         default:
 555         punk:
 556           scm_ipruk ("type", exp, port);
 557         }
 558     }
 559 }
 560
 561 /* Print states are necessary for circular reference safe printing.
 562  * They are also expensive to allocate.  Therefore print states are
 563  * kept in a pool so that they can be reused.
 564  */
 565 #ifdef __STDC__
 566 void
 567 scm_prin1 (SCM exp, SCM port, int writingp)
 568 #else
 569 void
 570 scm_prin1 (exp, port, writingp)
 571      SCM exp;
 572      SCM port;
 573      int writingp;
 574 #endif
 575 {
 576   SCM handle = 0; /* Will GC protect the handle whilst unlinked */
 577   scm_print_state *pstate;
 578
 579   /* First try to allocate a print state from the pool */
 580   SCM_DEFER_INTS;
 581   if (SCM_NNULLP (SCM_CDR (print_state_pool)))
 582     {
 583       handle = SCM_CDR (print_state_pool);
 584       SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
 585     }
 586   SCM_ALLOW_INTS;
 587
 588   if (!handle)
 589     handle = scm_cons (scm_make_print_state (), SCM_EOL);
 590
 591   pstate = (scm_print_state *) SCM_STRUCT_DATA (SCM_CAR (handle));
 592   pstate->writingp = writingp;
 593   scm_iprin1 (exp, port, pstate);
 594
 595   /* Return print state to pool */
 596   SCM_DEFER_INTS;
 597   SCM_SETCDR (handle, SCM_CDR (print_state_pool));
 598   SCM_SETCDR (print_state_pool, handle);
 599   SCM_ALLOW_INTS;
 600 }
 601
 602
 603 /* Print an integer.
 604  */
 605 #ifdef __STDC__
 606 void
 607 scm_intprint (long n, int radix, SCM port)
 608 #else
 609 void
 610 scm_intprint (n, radix, port)
 611      long n;
 612      int radix;
 613      SCM port;
 614 #endif
 615 {
 616   char num_buf[SCM_INTBUFLEN];
 617   scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
 618 }
 619
 620 /* Print an object of unrecognized type.
 621  */
 622 #ifdef __STDC__
 623 void
 624 scm_ipruk (char *hdr, SCM ptr, SCM port)
 625 #else
 626 void
 627 scm_ipruk (hdr, ptr, port)
 628      char *hdr;
 629      SCM ptr;
 630      SCM port;
 631 #endif
 632 {
 633   scm_gen_puts (scm_regular_string, "#<unknown-", port);
 634   scm_gen_puts (scm_regular_string, hdr, port);
 635   if (SCM_CELLP (ptr))
 636     {
 637       scm_gen_puts (scm_regular_string, " (0x", port);
 638       scm_intprint (SCM_CAR (ptr), 16, port);
 639       scm_gen_puts (scm_regular_string, " . 0x", port);
 640       scm_intprint (SCM_CDR (ptr), 16, port);
 641       scm_gen_puts (scm_regular_string, ") @", port);
 642     }
 643   scm_gen_puts (scm_regular_string, " 0x", port);
 644   scm_intprint (ptr, 16, port);
 645   scm_gen_putc ('>', port);
 646 }
 647
 648 /* Print a list.
 649  */
 650
 651 #ifdef __STDC__
 652 void
 653 scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, scm_print_state *pstate)
 654 #else
 655 void
 656 scm_iprlist (hdr, exp, tlr, port, pstate)
 657      char *hdr;
 658      SCM exp;
 659      char tlr;
 660      SCM port;
 661      scm_print_state *pstate;
 662 #endif
 663 {
 664   register int i;
 665   register SCM hare, tortoise;
 666   int floor = pstate->top - 2;
 667   scm_gen_puts (scm_regular_string, hdr, port);
 668   /* CHECK_INTS; */
 669   if (pstate->fancyp)
 670     goto fancy_printing;
 671
 672   /* Run a hare and tortoise so that total time complexity will be
 673      O(depth * N) instead of O(N^2). */
 674   hare = SCM_CDR (exp);
 675   tortoise = exp;
 676   while (SCM_NIMP (hare) && SCM_ECONSP (hare))
 677     {
 678       if (hare == tortoise)
 679         goto fancy_printing;
 680       hare = SCM_CDR (hare);
 681       if (SCM_IMP (hare) || SCM_NECONSP (hare))
 682         break;
 683       hare = SCM_CDR (hare);
 684       tortoise = SCM_CDR (tortoise);
 685     }
 686
 687   /* No cdr cycles intrinsic to this list */
 688   scm_iprin1 (SCM_CAR (exp), port, pstate);
 689   exp = SCM_CDR (exp);
 690   for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 691     {
 692       if (SCM_NECONSP (exp))
 693         break;
 694       for (i = floor; i >= 0; --i)
 695         if (pstate->ref_stack[i] == exp)
 696           goto circref;
 697       PUSH_REF (pstate, exp);
 698       scm_gen_putc (' ', port);
 699       /* CHECK_INTS; */
 700       scm_iprin1 (SCM_CAR (exp), port, pstate);
 701     }
 702   if (SCM_NNULLP (exp))
 703     {
 704       scm_gen_puts (scm_regular_string, " . ", port);
 705       scm_iprin1 (exp, port, pstate);
 706     }
 707
 708 end:
 709   scm_gen_putc (tlr, port);
 710   pstate->top = floor + 2;
 711   return;
 712
 713 fancy_printing:
 714   {
 715     int n = pstate->length;
 716
 717     scm_iprin1 (SCM_CAR (exp), port, pstate);
 718     exp = SCM_CDR (exp); --n;
 719     for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 720       {
 721         if (SCM_NECONSP (exp))
 722           break;
 723         for (i = 0; i < pstate->top; ++i)
 724           if (pstate->ref_stack[i] == exp)
 725             goto fancy_circref;
 726         if (pstate->fancyp)
 727           {
 728             if (n == 0)
 729               {
 730                 scm_gen_puts (scm_regular_string, " ...", port);
 731                 goto skip_tail;
 732               }
 733             else
 734               --n;
 735           }
 736         PUSH_REF(pstate, exp);
 737         ++pstate->list_offset;
 738         scm_gen_putc (' ', port);
 739         /* CHECK_INTS; */
 740         scm_iprin1 (SCM_CAR (exp), port, pstate);
 741       }
 742   }
 743   if (SCM_NNULLP (exp))
 744     {
 745       scm_gen_puts (scm_regular_string, " . ", port);
 746       scm_iprin1 (exp, port, pstate);
 747     }
 748 skip_tail:
 749   pstate->list_offset -= pstate->top - floor - 2;
 750   goto end;
 751
 752 fancy_circref:
 753   pstate->list_offset -= pstate->top - floor - 2;
 754
 755 circref:
 756   scm_gen_puts (scm_regular_string, " . ", port);
 757   print_circref (port, pstate, exp);
 758   goto end;
 759 }
 760
 761 \f
 762
 763 SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
 764 #ifdef __STDC__
 765 SCM
 766 scm_write (SCM obj, SCM port)
 767 #else
 768 SCM
 769 scm_write (obj, port)
 770      SCM obj;
 771      SCM port;
 772 #endif
 773 {
 774   if (SCM_UNBNDP (port))
 775     port = scm_cur_outp;
 776   else
 777     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
 778   scm_prin1 (obj, port, 1);
 779 #ifdef HAVE_PIPE
 780 # ifdef EPIPE
 781   if (EPIPE == errno)
 782     scm_close_port (port);
 783 # endif
 784 #endif
 785   return SCM_UNSPECIFIED;
 786 }
 787
 788
 789 SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
 790 #ifdef __STDC__
 791 SCM
 792 scm_display (SCM obj, SCM port)
 793 #else
 794 SCM
 795 scm_display (obj, port)
 796      SCM obj;
 797      SCM port;
 798 #endif
 799 {
 800   if (SCM_UNBNDP (port))
 801     port = scm_cur_outp;
 802   else
 803     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
 804   scm_prin1 (obj, port, 0);
 805 #ifdef HAVE_PIPE
 806 # ifdef EPIPE
 807   if (EPIPE == errno)
 808     scm_close_port (port);
 809 # endif
 810 #endif
 811   return SCM_UNSPECIFIED;
 812 }
 813
 814 SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
 815 #ifdef __STDC__
 816 SCM
 817 scm_newline(SCM port)
 818 #else
 819 SCM
 820 scm_newline (port)
 821      SCM port;
 822 #endif
 823 {
 824   if (SCM_UNBNDP (port))
 825  port = scm_cur_outp;
 826   else
 827     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
 828   scm_gen_putc ('\n', port);
 829 #ifdef HAVE_PIPE
 830 # ifdef EPIPE
 831   if (EPIPE == errno)
 832     scm_close_port (port);
 833   else
 834 # endif
 835 #endif
 836   if (port == scm_cur_outp)
 837     scm_fflush (port);
 838   return SCM_UNSPECIFIED;
 839 }
 840
 841 SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
 842 #ifdef __STDC__
 843 SCM
 844 scm_write_char (SCM chr, SCM port)
 845 #else
 846 SCM
 847 scm_write_char (chr, port)
 848      SCM chr;
 849      SCM port;
 850 #endif
 851 {
 852   if (SCM_UNBNDP (port))
 853  port = scm_cur_outp;
 854   else
 855     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
 856   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
 857   scm_gen_putc ((int) SCM_ICHR (chr), port);
 858 #ifdef HAVE_PIPE
 859 # ifdef EPIPE
 860   if (EPIPE == errno)
 861     scm_close_port (port);
 862 # endif
 863 #endif
 864   return SCM_UNSPECIFIED;
 865 }
 866
 867
 868 \f
 869
 870 #ifdef __STDC__
 871 void
 872 scm_init_print (void)
 873 #else
 874 void
 875 scm_init_print ()
 876 #endif
 877 {
 878   SCM vtable, type;
 879   scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
 880   vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_makfrom0str ("")), SCM_INUM0, SCM_EOL);
 881   type = scm_make_struct (vtable,
 882                           SCM_INUM0,
 883                           scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)),
 884                                     SCM_EOL));
 885   print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
 886 #include "print.x"
 887 }