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