libguile/print.c

   1 /*      Copyright (C) 1995,1996,1997 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, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  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_print_struct (exp, port, pstate);
 324               break;
 325             }
 326
 327         case scm_tcs_cons_imcar:
 328         case scm_tcs_cons_nimcar:
 329           ENTER_NESTED_DATA (pstate, exp, circref);
 330           scm_iprlist ("(", exp, ')', port, pstate);
 331           EXIT_NESTED_DATA (pstate);
 332           break;
 333         circref:
 334           print_circref (port, pstate, exp);
 335           break;
 336         case scm_tcs_closures:
 337           if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
 338             {
 339               SCM ans = scm_cons2 (exp, port,
 340                                    scm_cons (SCM_WRITINGP (pstate)
 341                                              ? SCM_BOOL_T
 342                                              : SCM_BOOL_F,
 343                                              SCM_EOL));
 344               ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
 345             }
 346           else
 347             {
 348               SCM name, code;
 349               name = scm_procedure_property (exp, scm_i_name);
 350               code = SCM_CODE (exp);
 351               scm_gen_puts (scm_regular_string, "#<procedure ", port);
 352               if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 353                 {
 354                   scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
 355                   scm_gen_putc (' ', port);
 356                 }
 357               scm_iprin1 (SCM_CAR (code), port, pstate);
 358               if (SCM_PRINT_SOURCE_P)
 359                 {
 360                   code = scm_unmemocopy (SCM_CDR (code),
 361                                          SCM_EXTEND_ENV (SCM_CAR (code),
 362                                                          SCM_EOL,
 363                                                          SCM_ENV (exp)));
 364                   ENTER_NESTED_DATA (pstate, exp, circref);
 365                   scm_iprlist (" ", code, '>', port, pstate);
 366                   EXIT_NESTED_DATA (pstate);
 367                 }
 368               else
 369                 scm_gen_putc ('>', port);
 370             }
 371           break;
 372         case scm_tc7_mb_string:
 373         case scm_tc7_mb_substring:
 374           scm_print_mb_string (exp, port, SCM_WRITINGP (pstate));
 375           break;
 376         case scm_tc7_substring:
 377         case scm_tc7_string:
 378           if (SCM_WRITINGP (pstate))
 379             {
 380               scm_gen_putc ('"', port);
 381               for (i = 0; i < SCM_ROLENGTH (exp); ++i)
 382                 switch (SCM_ROCHARS (exp)[i])
 383                   {
 384                   case '"':
 385                   case '\\':
 386                     scm_gen_putc ('\\', port);
 387                   default:
 388                     scm_gen_putc (SCM_ROCHARS (exp)[i], port);
 389                   }
 390               scm_gen_putc ('"', port);
 391               break;
 392             }
 393           else
 394             scm_gen_write (scm_regular_string, SCM_ROCHARS (exp),
 395                            (scm_sizet) SCM_ROLENGTH (exp),
 396                            port);
 397           break;
 398         case scm_tcs_symbols:
 399           if (SCM_MB_STRINGP (exp))
 400             {
 401               scm_print_mb_symbol (exp, port);
 402               break;
 403             }
 404           else
 405             {
 406               int pos;
 407               int end;
 408               int len;
 409               char * str;
 410               int weird;
 411               int maybe_weird;
 412               int mw_pos = 0;
 413
 414               len = SCM_LENGTH (exp);
 415               str = SCM_CHARS (exp);
 416               scm_remember (&exp);
 417               pos = 0;
 418               weird = 0;
 419               maybe_weird = 0;
 420
 421               if (len == 0)
 422                 scm_gen_write (scm_regular_string, "#{}#", 4, port);
 423
 424               for (end = pos; end < len; ++end)
 425                 switch (str[end])
 426                   {
 427 #ifdef BRACKETS_AS_PARENS
 428                   case '[':
 429                   case ']':
 430 #endif
 431                   case '(':
 432                   case ')':
 433                   case '"':
 434                   case ';':
 435                   case SCM_WHITE_SPACES:
 436                   case SCM_LINE_INCREMENTORS:
 437                   weird_handler:
 438                     if (maybe_weird)
 439                       {
 440                         end = mw_pos;
 441                         maybe_weird = 0;
 442                       }
 443                     if (!weird)
 444                       {
 445                         scm_gen_write (scm_regular_string, "#{", 2, port);
 446                         weird = 1;
 447                       }
 448                     if (pos < end)
 449                       {
 450                         scm_gen_write (scm_regular_string, str + pos, end - pos, port);
 451                       }
 452                     {
 453                       char buf[2];
 454                       buf[0] = '\\';
 455                       buf[1] = str[end];
 456                       scm_gen_write (scm_regular_string, buf, 2, port);
 457                     }
 458                     pos = end + 1;
 459                     break;
 460                   case '\\':
 461                     if (weird)
 462                       goto weird_handler;
 463                     if (!maybe_weird)
 464                       {
 465                         maybe_weird = 1;
 466                         mw_pos = pos;
 467                       }
 468                     break;
 469                   case '}':
 470                   case '#':
 471                     if (weird)
 472                       goto weird_handler;
 473                     break;
 474                   default:
 475                     break;
 476                   }
 477               if (pos < end)
 478                 scm_gen_write (scm_regular_string, str + pos, end - pos, port);
 479               if (weird)
 480                 scm_gen_write (scm_regular_string, "}#", 2, port);
 481               break;
 482             }
 483         case scm_tc7_wvect:
 484           ENTER_NESTED_DATA (pstate, exp, circref);
 485           if (SCM_IS_WHVEC (exp))
 486             scm_gen_puts (scm_regular_string, "#wh(", port);
 487           else
 488             scm_gen_puts (scm_regular_string, "#w(", port);
 489           goto common_vector_printer;
 490
 491         case scm_tc7_vector:
 492           ENTER_NESTED_DATA (pstate, exp, circref);
 493           scm_gen_puts (scm_regular_string, "#(", port);
 494         common_vector_printer:
 495           {
 496             int last = SCM_LENGTH (exp) - 1;
 497             int cutp = 0;
 498             if (pstate->fancyp && SCM_LENGTH (exp) > pstate->length)
 499               {
 500                 last = pstate->length - 1;
 501                 cutp = 1;
 502               }
 503             for (i = 0; i < last; ++i)
 504               {
 505                 /* CHECK_INTS; */
 506                 scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 507                 scm_gen_putc (' ', port);
 508               }
 509             if (i == last)
 510               {
 511                 /* CHECK_INTS; */
 512                 scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 513               }
 514             if (cutp)
 515               scm_gen_puts (scm_regular_string, " ...", port);
 516             scm_gen_putc (')', port);
 517           }
 518           EXIT_NESTED_DATA (pstate);
 519           break;
 520         case scm_tc7_bvect:
 521         case scm_tc7_byvect:
 522         case scm_tc7_svect:
 523         case scm_tc7_ivect:
 524         case scm_tc7_uvect:
 525         case scm_tc7_fvect:
 526         case scm_tc7_dvect:
 527         case scm_tc7_cvect:
 528 #ifdef LONGLONGS
 529         case scm_tc7_llvect:
 530 #endif
 531           scm_raprin1 (exp, port, pstate);
 532           break;
 533         case scm_tcs_subrs:
 534           scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
 535           scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
 536                          ? scm_mb_string
 537                          : scm_regular_string),
 538                         SCM_CHARS (SCM_SNAME (exp)), port);
 539           scm_gen_putc ('>', port);
 540           break;
 541 #ifdef CCLO
 542         case scm_tc7_cclo:
 543           scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
 544           scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
 545           scm_gen_putc ('>', port);
 546           break;
 547 #endif
 548         case scm_tc7_contin:
 549           scm_gen_puts (scm_regular_string, "#<continuation ", port);
 550           scm_intprint (SCM_LENGTH (exp), 10, port);
 551           scm_gen_puts (scm_regular_string, " @ ", port);
 552           scm_intprint ((long) SCM_CHARS (exp), 16, port);
 553           scm_gen_putc ('>', port);
 554           break;
 555         case scm_tc7_port:
 556           i = SCM_PTOBNUM (exp);
 557           if (i < scm_numptob
 558               && scm_ptobs[i].print
 559               && (scm_ptobs[i].print) (exp, port, pstate))
 560             break;
 561           goto punk;
 562         case scm_tc7_smob:
 563           ENTER_NESTED_DATA (pstate, exp, circref);
 564           i = SCM_SMOBNUM (exp);
 565           if (i < scm_numsmob && scm_smobs[i].print
 566               && (scm_smobs[i].print) (exp, port, pstate))
 567             {
 568               EXIT_NESTED_DATA (pstate);
 569               break;
 570             }
 571           EXIT_NESTED_DATA (pstate);
 572         default:
 573         punk:
 574           scm_ipruk ("type", exp, port);
 575         }
 576     }
 577 }
 578
 579 /* Print states are necessary for circular reference safe printing.
 580  * They are also expensive to allocate.  Therefore print states are
 581  * kept in a pool so that they can be reused.
 582  */
 583
 584 void
 585 scm_prin1 (exp, port, writingp)
 586      SCM exp;
 587      SCM port;
 588      int writingp;
 589 {
 590   SCM handle = 0; /* Will GC protect the handle whilst unlinked */
 591   scm_print_state *pstate;
 592
 593   /* First try to allocate a print state from the pool */
 594   SCM_DEFER_INTS;
 595   if (SCM_NNULLP (SCM_CDR (print_state_pool)))
 596     {
 597       handle = SCM_CDR (print_state_pool);
 598       SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
 599     }
 600   SCM_ALLOW_INTS;
 601
 602   if (!handle)
 603     handle = scm_cons (make_print_state (), SCM_EOL);
 604
 605   pstate = SCM_PRINT_STATE (SCM_CAR (handle));
 606   pstate->writingp = writingp;
 607   scm_iprin1 (exp, port, pstate);
 608
 609   /* Return print state to pool */
 610   SCM_DEFER_INTS;
 611   SCM_SETCDR (handle, SCM_CDR (print_state_pool));
 612   SCM_SETCDR (print_state_pool, handle);
 613   SCM_ALLOW_INTS;
 614 }
 615
 616
 617 /* Print an integer.
 618  */
 619
 620 void
 621 scm_intprint (n, radix, port)
 622      long n;
 623      int radix;
 624      SCM port;
 625 {
 626   char num_buf[SCM_INTBUFLEN];
 627   scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
 628 }
 629
 630 /* Print an object of unrecognized type.
 631  */
 632
 633 void
 634 scm_ipruk (hdr, ptr, port)
 635      char *hdr;
 636      SCM ptr;
 637      SCM port;
 638 {
 639   scm_gen_puts (scm_regular_string, "#<unknown-", port);
 640   scm_gen_puts (scm_regular_string, hdr, port);
 641   if (SCM_CELLP (ptr))
 642     {
 643       scm_gen_puts (scm_regular_string, " (0x", port);
 644       scm_intprint (SCM_CAR (ptr), 16, port);
 645       scm_gen_puts (scm_regular_string, " . 0x", port);
 646       scm_intprint (SCM_CDR (ptr), 16, port);
 647       scm_gen_puts (scm_regular_string, ") @", port);
 648     }
 649   scm_gen_puts (scm_regular_string, " 0x", port);
 650   scm_intprint (ptr, 16, port);
 651   scm_gen_putc ('>', port);
 652 }
 653
 654 /* Print a list.
 655  */
 656
 657
 658 void
 659 scm_iprlist (hdr, exp, tlr, port, pstate)
 660      char *hdr;
 661      SCM exp;
 662      int tlr;
 663      SCM port;
 664      scm_print_state *pstate;
 665 {
 666   register int i;
 667   register SCM hare, tortoise;
 668   int floor = pstate->top - 2;
 669   scm_gen_puts (scm_regular_string, hdr, port);
 670   /* CHECK_INTS; */
 671   if (pstate->fancyp)
 672     goto fancy_printing;
 673
 674   /* Run a hare and tortoise so that total time complexity will be
 675      O(depth * N) instead of O(N^2). */
 676   hare = SCM_CDR (exp);
 677   tortoise = exp;
 678   while (SCM_NIMP (hare) && SCM_ECONSP (hare))
 679     {
 680       if (hare == tortoise)
 681         goto fancy_printing;
 682       hare = SCM_CDR (hare);
 683       if (SCM_IMP (hare) || SCM_NECONSP (hare))
 684         break;
 685       hare = SCM_CDR (hare);
 686       tortoise = SCM_CDR (tortoise);
 687     }
 688
 689   /* No cdr cycles intrinsic to this list */
 690   scm_iprin1 (SCM_CAR (exp), port, pstate);
 691   exp = SCM_CDR (exp);
 692   for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 693     {
 694       if (SCM_NECONSP (exp))
 695         break;
 696       for (i = floor; i >= 0; --i)
 697         if (pstate->ref_stack[i] == exp)
 698           goto circref;
 699       PUSH_REF (pstate, exp);
 700       scm_gen_putc (' ', port);
 701       /* CHECK_INTS; */
 702       scm_iprin1 (SCM_CAR (exp), port, pstate);
 703     }
 704   if (SCM_NNULLP (exp))
 705     {
 706       scm_gen_puts (scm_regular_string, " . ", port);
 707       scm_iprin1 (exp, port, pstate);
 708     }
 709
 710 end:
 711   scm_gen_putc (tlr, port);
 712   pstate->top = floor + 2;
 713   return;
 714
 715 fancy_printing:
 716   {
 717     int n = pstate->length;
 718
 719     scm_iprin1 (SCM_CAR (exp), port, pstate);
 720     exp = SCM_CDR (exp); --n;
 721     for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 722       {
 723         if (SCM_NECONSP (exp))
 724           break;
 725         for (i = 0; i < pstate->top; ++i)
 726           if (pstate->ref_stack[i] == exp)
 727             goto fancy_circref;
 728         if (pstate->fancyp)
 729           {
 730             if (n == 0)
 731               {
 732                 scm_gen_puts (scm_regular_string, " ...", port);
 733                 goto skip_tail;
 734               }
 735             else
 736               --n;
 737           }
 738         PUSH_REF(pstate, exp);
 739         ++pstate->list_offset;
 740         scm_gen_putc (' ', port);
 741         /* CHECK_INTS; */
 742         scm_iprin1 (SCM_CAR (exp), port, pstate);
 743       }
 744   }
 745   if (SCM_NNULLP (exp))
 746     {
 747       scm_gen_puts (scm_regular_string, " . ", port);
 748       scm_iprin1 (exp, port, pstate);
 749     }
 750 skip_tail:
 751   pstate->list_offset -= pstate->top - floor - 2;
 752   goto end;
 753
 754 fancy_circref:
 755   pstate->list_offset -= pstate->top - floor - 2;
 756
 757 circref:
 758   scm_gen_puts (scm_regular_string, " . ", port);
 759   print_circref (port, pstate, exp);
 760   goto end;
 761 }
 762
 763 \f
 764
 765 SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
 766
 767 SCM
 768 scm_write (obj, port)
 769      SCM obj;
 770      SCM port;
 771 {
 772   if (SCM_UNBNDP (port))
 773     port = scm_cur_outp;
 774   else
 775     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
 776   scm_prin1 (obj, port, 1);
 777 #ifdef HAVE_PIPE
 778 # ifdef EPIPE
 779   if (EPIPE == errno)
 780     scm_close_port (port);
 781 # endif
 782 #endif
 783   return SCM_UNSPECIFIED;
 784 }
 785
 786
 787 SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
 788
 789 SCM
 790 scm_display (obj, port)
 791      SCM obj;
 792      SCM port;
 793 {
 794   if (SCM_UNBNDP (port))
 795     port = scm_cur_outp;
 796   else
 797     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
 798   scm_prin1 (obj, port, 0);
 799 #ifdef HAVE_PIPE
 800 # ifdef EPIPE
 801   if (EPIPE == errno)
 802     scm_close_port (port);
 803 # endif
 804 #endif
 805   return SCM_UNSPECIFIED;
 806 }
 807
 808 SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
 809
 810 SCM
 811 scm_newline (port)
 812      SCM port;
 813 {
 814   if (SCM_UNBNDP (port))
 815  port = scm_cur_outp;
 816   else
 817     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
 818   scm_gen_putc ('\n', port);
 819 #ifdef HAVE_PIPE
 820 # ifdef EPIPE
 821   if (EPIPE == errno)
 822     scm_close_port (port);
 823   else
 824 # endif
 825 #endif
 826   if (port == scm_cur_outp)
 827     scm_fflush (port);
 828   return SCM_UNSPECIFIED;
 829 }
 830
 831 SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
 832
 833 SCM
 834 scm_write_char (chr, port)
 835      SCM chr;
 836      SCM port;
 837 {
 838   if (SCM_UNBNDP (port))
 839  port = scm_cur_outp;
 840   else
 841     SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
 842   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
 843   scm_gen_putc ((int) SCM_ICHR (chr), port);
 844 #ifdef HAVE_PIPE
 845 # ifdef EPIPE
 846   if (EPIPE == errno)
 847     scm_close_port (port);
 848 # endif
 849 #endif
 850   return SCM_UNSPECIFIED;
 851 }
 852
 853
 854 \f
 855
 856
 857 void
 858 scm_init_print ()
 859 {
 860   SCM vtable, type;
 861   scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
 862   vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL);
 863   type = scm_make_struct (vtable,
 864                           SCM_INUM0,
 865                           scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)),
 866                                     SCM_EOL));
 867   print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
 868 #include "print.x"
 869 }