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 #ifdef GUILE_DEBUG /* 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 = 0;
 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           {
 498             int last = SCM_LENGTH (exp) - 1;
 499             int cutp = 0;
 500             if (pstate->fancyp && SCM_LENGTH (exp) > pstate->length)
 501               {
 502                 last = pstate->length - 1;
 503                 cutp = 1;
 504               }
 505             for (i = 0; i < last; ++i)
 506               {
 507                 /* CHECK_INTS; */
 508                 scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 509                 scm_gen_putc (' ', port);
 510               }
 511             if (i == last)
 512               {
 513                 /* CHECK_INTS; */
 514                 scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 515               }
 516             if (cutp)
 517               scm_gen_puts (scm_regular_string, " ...", port);
 518             scm_gen_putc (')', port);
 519           }
 520           EXIT_NESTED_DATA (pstate);
 521           break;
 522         case scm_tc7_bvect:
 523         case scm_tc7_byvect:
 524         case scm_tc7_svect:
 525         case scm_tc7_ivect:
 526         case scm_tc7_uvect:
 527         case scm_tc7_fvect:
 528         case scm_tc7_dvect:
 529         case scm_tc7_cvect:
 530 #ifdef LONGLONGS
 531         case scm_tc7_llvect:
 532 #endif
 533           scm_raprin1 (exp, port, pstate);
 534           break;
 535         case scm_tcs_subrs:
 536           scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
 537           scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
 538                          ? scm_mb_string
 539                          : scm_regular_string),
 540                         SCM_CHARS (SCM_SNAME (exp)), port);
 541           scm_gen_putc ('>', port);
 542           break;
 543 #ifdef CCLO
 544         case scm_tc7_cclo:
 545           scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
 546           scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
 547           scm_gen_putc ('>', port);
 548           break;
 549 #endif
 550         case scm_tc7_contin:
 551           scm_gen_puts (scm_regular_string, "#<continuation ", port);
 552           scm_intprint (SCM_LENGTH (exp), 10, port);
 553           scm_gen_puts (scm_regular_string, " @ ", port);
 554           scm_intprint ((long) SCM_CHARS (exp), 16, port);
 555           scm_gen_putc ('>', port);
 556           break;
 557         case scm_tc7_port:
 558           i = SCM_PTOBNUM (exp);
 559           if (i < scm_numptob
 560               && scm_ptobs[i].print
 561               && (scm_ptobs[i].print) (exp, port, pstate))
 562             break;
 563           goto punk;
 564         case scm_tc7_smob:
 565           ENTER_NESTED_DATA (pstate, exp, circref);
 566           i = SCM_SMOBNUM (exp);
 567           if (i < scm_numsmob && scm_smobs[i].print
 568               && (scm_smobs[i].print) (exp, port, pstate))
 569             {
 570               EXIT_NESTED_DATA (pstate);
 571               break;
 572             }
 573           EXIT_NESTED_DATA (pstate);
 574         default:
 575         punk:
 576           scm_ipruk ("type", exp, port);
 577         }
 578     }
 579 }
 580
 581 /* Print states are necessary for circular reference safe printing.
 582  * They are also expensive to allocate.  Therefore print states are
 583  * kept in a pool so that they can be reused.
 584  */
 585
 586 void
 587 scm_prin1 (exp, port, writingp)
 588      SCM exp;
 589      SCM port;
 590      int writingp;
 591 {
 592   SCM handle = 0; /* Will GC protect the handle whilst unlinked */
 593   scm_print_state *pstate;
 594
 595   /* First try to allocate a print state from the pool */
 596   SCM_DEFER_INTS;
 597   if (SCM_NNULLP (SCM_CDR (print_state_pool)))
 598     {
 599       handle = SCM_CDR (print_state_pool);
 600       SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
 601     }
 602   SCM_ALLOW_INTS;
 603
 604   if (!handle)
 605     handle = scm_cons (make_print_state (), SCM_EOL);
 606
 607   pstate = SCM_PRINT_STATE (SCM_CAR (handle));
 608   pstate->writingp = writingp;
 609   scm_iprin1 (exp, port, pstate);
 610
 611   /* Return print state to pool */
 612   SCM_DEFER_INTS;
 613   SCM_SETCDR (handle, SCM_CDR (print_state_pool));
 614   SCM_SETCDR (print_state_pool, handle);
 615   SCM_ALLOW_INTS;
 616 }
 617
 618
 619 /* Print an integer.
 620  */
 621
 622 void
 623 scm_intprint (n, radix, port)
 624      long n;
 625      int radix;
 626      SCM port;
 627 {
 628   char num_buf[SCM_INTBUFLEN];
 629   scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
 630 }
 631
 632 /* Print an object of unrecognized type.
 633  */
 634
 635 void
 636 scm_ipruk (hdr, ptr, port)
 637      char *hdr;
 638      SCM ptr;
 639      SCM port;
 640 {
 641   scm_gen_puts (scm_regular_string, "#<unknown-", port);
 642   scm_gen_puts (scm_regular_string, hdr, port);
 643   if (SCM_CELLP (ptr))
 644     {
 645       scm_gen_puts (scm_regular_string, " (0x", port);
 646       scm_intprint (SCM_CAR (ptr), 16, port);
 647       scm_gen_puts (scm_regular_string, " . 0x", port);
 648       scm_intprint (SCM_CDR (ptr), 16, port);
 649       scm_gen_puts (scm_regular_string, ") @", port);
 650     }
 651   scm_gen_puts (scm_regular_string, " 0x", port);
 652   scm_intprint (ptr, 16, port);
 653   scm_gen_putc ('>', port);
 654 }
 655
 656 /* Print a list.
 657  */
 658
 659
 660 void
 661 scm_iprlist (hdr, exp, tlr, port, pstate)
 662      char *hdr;
 663      SCM exp;
 664      int tlr;
 665      SCM port;
 666      scm_print_state *pstate;
 667 {
 668   register int i;
 669   register SCM hare, tortoise;
 670   int floor = pstate->top - 2;
 671   scm_gen_puts (scm_regular_string, hdr, port);
 672   /* CHECK_INTS; */
 673   if (pstate->fancyp)
 674     goto fancy_printing;
 675
 676   /* Run a hare and tortoise so that total time complexity will be
 677      O(depth * N) instead of O(N^2). */
 678   hare = SCM_CDR (exp);
 679   tortoise = exp;
 680   while (SCM_NIMP (hare) && SCM_ECONSP (hare))
 681     {
 682       if (hare == tortoise)
 683         goto fancy_printing;
 684       hare = SCM_CDR (hare);
 685       if (SCM_IMP (hare) || SCM_NECONSP (hare))
 686         break;
 687       hare = SCM_CDR (hare);
 688       tortoise = SCM_CDR (tortoise);
 689     }
 690
 691   /* No cdr cycles intrinsic to this list */
 692   scm_iprin1 (SCM_CAR (exp), port, pstate);
 693   exp = SCM_CDR (exp);
 694   for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 695     {
 696       if (SCM_NECONSP (exp))
 697         break;
 698       for (i = floor; i >= 0; --i)
 699         if (pstate->ref_stack[i] == exp)
 700           goto circref;
 701       PUSH_REF (pstate, exp);
 702       scm_gen_putc (' ', port);
 703       /* CHECK_INTS; */
 704       scm_iprin1 (SCM_CAR (exp), port, pstate);
 705     }
 706   if (SCM_NNULLP (exp))
 707     {
 708       scm_gen_puts (scm_regular_string, " . ", port);
 709       scm_iprin1 (exp, port, pstate);
 710     }
 711
 712 end:
 713   scm_gen_putc (tlr, port);
 714   pstate->top = floor + 2;
 715   return;
 716
 717 fancy_printing:
 718   {
 719     int n = pstate->length;
 720
 721     scm_iprin1 (SCM_CAR (exp), port, pstate);
 722     exp = SCM_CDR (exp); --n;
 723     for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 724       {
 725         if (SCM_NECONSP (exp))
 726           break;
 727         for (i = 0; i < pstate->top; ++i)
 728           if (pstate->ref_stack[i] == exp)
 729             goto fancy_circref;
 730         if (pstate->fancyp)
 731           {
 732             if (n == 0)
 733               {
 734                 scm_gen_puts (scm_regular_string, " ...", port);
 735                 goto skip_tail;
 736               }
 737             else
 738               --n;
 739           }
 740         PUSH_REF(pstate, exp);
 741         ++pstate->list_offset;
 742         scm_gen_putc (' ', port);
 743         /* CHECK_INTS; */
 744         scm_iprin1 (SCM_CAR (exp), port, pstate);
 745       }
 746   }
 747   if (SCM_NNULLP (exp))
 748     {
 749       scm_gen_puts (scm_regular_string, " . ", port);
 750       scm_iprin1 (exp, port, pstate);
 751     }
 752 skip_tail:
 753   pstate->list_offset -= pstate->top - floor - 2;
 754   goto end;
 755
 756 fancy_circref:
 757   pstate->list_offset -= pstate->top - floor - 2;
 758
 759 circref:
 760   scm_gen_puts (scm_regular_string, " . ", port);
 761   print_circref (port, pstate, exp);
 762   goto end;
 763 }
 764
 765 \f
 766
 767 SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
 768
 769 SCM
 770 scm_write (obj, port)
 771      SCM obj;
 772      SCM port;
 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
 791 SCM
 792 scm_display (obj, port)
 793      SCM obj;
 794      SCM port;
 795 {
 796   if (SCM_UNBNDP (port))
 797     port = scm_cur_outp;
 798   else
 799     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
 800   scm_prin1 (obj, port, 0);
 801 #ifdef HAVE_PIPE
 802 # ifdef EPIPE
 803   if (EPIPE == errno)
 804     scm_close_port (port);
 805 # endif
 806 #endif
 807   return SCM_UNSPECIFIED;
 808 }
 809
 810 SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
 811
 812 SCM
 813 scm_newline (port)
 814      SCM port;
 815 {
 816   if (SCM_UNBNDP (port))
 817  port = scm_cur_outp;
 818   else
 819     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
 820   scm_gen_putc ('\n', port);
 821 #ifdef HAVE_PIPE
 822 # ifdef EPIPE
 823   if (EPIPE == errno)
 824     scm_close_port (port);
 825   else
 826 # endif
 827 #endif
 828   if (port == scm_cur_outp)
 829     scm_fflush (port);
 830   return SCM_UNSPECIFIED;
 831 }
 832
 833 SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
 834
 835 SCM
 836 scm_write_char (chr, port)
 837      SCM chr;
 838      SCM port;
 839 {
 840   if (SCM_UNBNDP (port))
 841  port = scm_cur_outp;
 842   else
 843     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
 844   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
 845   scm_gen_putc ((int) SCM_ICHR (chr), port);
 846 #ifdef HAVE_PIPE
 847 # ifdef EPIPE
 848   if (EPIPE == errno)
 849     scm_close_port (port);
 850 # endif
 851 #endif
 852   return SCM_UNSPECIFIED;
 853 }
 854
 855
 856 \f
 857
 858
 859 void
 860 scm_init_print ()
 861 {
 862   SCM vtable, type;
 863   scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
 864   vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL);
 865   type = scm_make_struct (vtable,
 866                           SCM_INUM0,
 867                           scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)),
 868                                     SCM_EOL));
 869   print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
 870 #include "print.x"
 871 }