libguile/print.c

   1 /*      Copyright (C) 1995,1996,1997,1998 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 "smob.h"
  48 #include "eval.h"
  49 #include "macros.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 unsigned long 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_putc ('#', port); \
 150           return; \
 151         } \
 152     } \
 153   PUSH_REF(pstate, obj); \
 154 } \
 155
 156 #define EXIT_NESTED_DATA(pstate) { --pstate->top; }
 157
 158 SCM scm_print_state_vtable;
 159
 160 static SCM print_state_pool;
 161
 162 #ifdef GUILE_DEBUG /* Used for debugging purposes */
 163 SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
 164
 165 SCM
 166 scm_current_pstate ()
 167 {
 168   return SCM_CADR (print_state_pool);
 169 }
 170 #endif
 171
 172 #define PSTATE_SIZE 50L
 173
 174 static SCM make_print_state SCM_P ((void));
 175
 176 static SCM
 177 make_print_state ()
 178 {
 179   SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */
 180                                      SCM_INUM0,
 181                                      SCM_EOL);
 182   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 183   pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE),
 184                                       SCM_UNDEFINED);
 185   pstate->ref_stack = SCM_VELTS (pstate->ref_vect);
 186   pstate->ceiling = SCM_LENGTH (pstate->ref_vect);
 187   return print_state;
 188 }
 189
 190 SCM
 191 scm_make_print_state ()
 192 {
 193   SCM answer = 0;
 194
 195   /* First try to allocate a print state from the pool */
 196   SCM_DEFER_INTS;
 197   if (SCM_NNULLP (SCM_CDR (print_state_pool)))
 198     {
 199       answer = SCM_CADR (print_state_pool);
 200       SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
 201     }
 202   SCM_ALLOW_INTS;
 203
 204   return answer ? answer : make_print_state ();
 205 }
 206
 207 static char s_print_state_printer[] = "print-state-printer";
 208 static SCM
 209 print_state_printer (obj, port)
 210      SCM obj;
 211      SCM port;
 212 {
 213   /* This function can be made visible by means of struct-ref, so
 214      we need to make sure that it gets what it wants. */
 215   SCM_ASSERT (SCM_NIMP (obj) && SCM_PRINT_STATE_P (obj),
 216               obj,
 217               SCM_ARG1,
 218               s_print_state_printer);
 219   SCM_ASSERT (scm_valid_oport_value_p (port),
 220               port,
 221               SCM_ARG2,
 222               s_print_state_printer);
 223   port = SCM_COERCE_OUTPORT (port);
 224   scm_puts ("#<print-state ", port);
 225   scm_intprint (obj, 16, port);
 226   scm_putc ('>', port);
 227   return SCM_UNSPECIFIED;
 228 }
 229
 230 void
 231 scm_free_print_state (print_state)
 232      SCM print_state;
 233 {
 234   SCM handle;
 235   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 236   /* Cleanup before returning print state to pool.
 237    * It is better to do it here.  Doing it in scm_prin1
 238    * would cost more since that function is called much more
 239    * often.
 240    */
 241   pstate->fancyp = 0;
 242   pstate->revealed = 0;
 243   SCM_NEWCELL (handle);
 244   SCM_DEFER_INTS;
 245   SCM_SETCAR (handle, print_state);
 246   SCM_SETCDR (handle, SCM_CDR (print_state_pool));
 247   SCM_SETCDR (print_state_pool, handle);
 248   SCM_ALLOW_INTS;
 249 }
 250
 251 static void grow_ref_stack SCM_P ((scm_print_state *pstate));
 252
 253 static void
 254 grow_ref_stack (pstate)
 255      scm_print_state *pstate;
 256 {
 257   int new_size = 2 * pstate->ceiling;
 258   scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size));
 259   pstate->ref_stack = SCM_VELTS (pstate->ref_vect);
 260   pstate->ceiling = new_size;
 261 }
 262
 263
 264 static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref));
 265
 266 static void
 267 print_circref (port, pstate, ref)
 268      SCM port;
 269      scm_print_state *pstate;
 270      SCM ref;
 271 {
 272   register int i;
 273   int self = pstate->top - 1;
 274   i = pstate->top - 1;
 275   if (SCM_CONSP (pstate->ref_stack[i]))
 276     {
 277       while (i > 0)
 278         {
 279           if (SCM_NCONSP (pstate->ref_stack[i - 1])
 280               || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i])
 281             break;
 282           --i;
 283         }
 284       self = i;
 285     }
 286   for (i = pstate->top - 1; 1; --i)
 287     if (pstate->ref_stack[i] == ref)
 288       break;
 289   scm_putc ('#', port);
 290   scm_intprint (i - self, 10, port);
 291   scm_putc ('#', port);
 292 }
 293
 294 /* Print generally.  Handles both write and display according to PSTATE.
 295  */
 296
 297
 298 void
 299 scm_iprin1 (exp, port, pstate)
 300      SCM exp;
 301      SCM port;
 302      scm_print_state *pstate;
 303 {
 304 taloop:
 305   switch (7 & (int) exp)
 306     {
 307     case 2:
 308     case 6:
 309       scm_intprint (SCM_INUM (exp), 10, port);
 310       break;
 311     case 4:
 312       if (SCM_ICHRP (exp))
 313         {
 314           register long i;
 315
 316           i = SCM_ICHR (exp);
 317           if (SCM_WRITINGP (pstate))
 318             {
 319               scm_puts ("#\\", port);
 320               if ((i >= 0) && (i <= ' ') && scm_charnames[i])
 321                 scm_puts (scm_charnames[i], port);
 322               else if (i < 0 || i > '\177')
 323                 scm_intprint (i, 8, port);
 324               else
 325                 scm_putc (i, port);
 326             }
 327           else
 328             scm_putc (i, port);
 329         }
 330       else if (SCM_IFLAGP (exp)
 331                && ((size_t) SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
 332           scm_puts (SCM_ISYMCHARS (exp), port);
 333       else if (SCM_ILOCP (exp))
 334         {
 335           scm_puts ("#@", port);
 336           scm_intprint ((long) SCM_IFRAME (exp), 10, port);
 337           scm_putc (SCM_ICDRP (exp) ? '-' : '+', port);
 338           scm_intprint ((long) SCM_IDIST (exp), 10, port);
 339         }
 340       else
 341         goto idef;
 342       break;
 343     case 1:
 344       /* gloc */
 345       scm_puts ("#@", port);
 346       exp = SCM_CAR (exp - 1);
 347       goto taloop;
 348     default:
 349     idef:
 350       scm_ipruk ("immediate", exp, port);
 351       break;
 352     case 0:
 353       switch (SCM_TYP7 (exp))
 354         {
 355         case scm_tcs_cons_gloc:
 356
 357           if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
 358             {
 359               ENTER_NESTED_DATA (pstate, exp, circref);
 360               scm_print_struct (exp, port, pstate);
 361               EXIT_NESTED_DATA (pstate);
 362               break;
 363             }
 364
 365         case scm_tcs_cons_imcar:
 366         case scm_tcs_cons_nimcar:
 367           ENTER_NESTED_DATA (pstate, exp, circref);
 368           scm_iprlist ("(", exp, ')', port, pstate);
 369           EXIT_NESTED_DATA (pstate);
 370           break;
 371         circref:
 372           print_circref (port, pstate, exp);
 373           break;
 374         macros:
 375           if (!SCM_CLOSUREP (SCM_CDR (exp)))
 376             goto prinmacro;
 377         case scm_tcs_closures:
 378           /* The user supplied print closure procedure must handle
 379              macro closures as well. */
 380           if (SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))
 381               || SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE,
 382                                                 exp, port, pstate)))
 383           {
 384             SCM name, code, env;
 385             if (SCM_TYP16 (exp) == scm_tc16_macro)
 386               {
 387                 /* Printing a macro. */
 388               prinmacro:
 389                 name = scm_macro_name (exp);
 390                 if (!SCM_CLOSUREP (SCM_CDR (exp)))
 391                   {
 392                     code = env = 0;
 393                     scm_puts ("#<primitive-", port);
 394                   }
 395                 else
 396                   {
 397                     code = SCM_CODE (SCM_CDR (exp));
 398                     env = SCM_ENV (SCM_CDR (exp));
 399                     scm_puts ("#<", port);
 400                   }
 401                 if (SCM_CAR (exp) & (3L << 16))
 402                   scm_puts ("macro", port);
 403                 else
 404                   scm_puts ("syntax", port);
 405                 if (SCM_CAR (exp) & (2L << 16))
 406                   scm_putc ('!', port);
 407               }
 408             else
 409               {
 410                 /* Printing a closure. */
 411                 name = scm_procedure_name (exp);
 412                 code = SCM_CODE (exp);
 413                 env = SCM_ENV (exp);
 414                 scm_puts ("#<procedure", port);
 415               }
 416             if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
 417               {
 418                 scm_putc (' ', port);
 419                 scm_puts (SCM_ROCHARS (name), port);
 420               }
 421             if (code)
 422               {
 423                 if (SCM_PRINT_SOURCE_P)
 424                   {
 425                     code = scm_unmemocopy (code,
 426                                            SCM_EXTEND_ENV (SCM_CAR (code),
 427                                                            SCM_EOL,
 428                                                            env));
 429                     ENTER_NESTED_DATA (pstate, exp, circref);
 430                     scm_iprlist (" ", code, '>', port, pstate);
 431                     EXIT_NESTED_DATA (pstate);
 432                   }
 433                 else
 434                   {
 435                     if (SCM_TYP16 (exp) != scm_tc16_macro)
 436                       {
 437                         scm_putc (' ', port);
 438                         scm_iprin1 (SCM_CAR (code), port, pstate);
 439                       }
 440                     scm_putc ('>', port);
 441                   }
 442               }
 443             else
 444               scm_putc ('>', port);
 445           }
 446           break;
 447         case scm_tc7_substring:
 448         case scm_tc7_string:
 449           if (SCM_WRITINGP (pstate))
 450             {
 451               scm_sizet i;
 452
 453               scm_putc ('"', port);
 454               for (i = 0; i < SCM_ROLENGTH (exp); ++i)
 455                 switch (SCM_ROCHARS (exp)[i])
 456                   {
 457                   case '"':
 458                   case '\\':
 459                     scm_putc ('\\', port);
 460                   default:
 461                     scm_putc (SCM_ROCHARS (exp)[i], port);
 462                   }
 463               scm_putc ('"', port);
 464               break;
 465             }
 466           else
 467             scm_lfwrite (SCM_ROCHARS (exp), (scm_sizet) SCM_ROLENGTH (exp),
 468                          port);
 469           break;
 470         case scm_tcs_symbols:
 471             {
 472               int pos;
 473               int end;
 474               int len;
 475               char * str;
 476               int weird;
 477               int maybe_weird;
 478               int mw_pos = 0;
 479
 480               len = SCM_LENGTH (exp);
 481               str = SCM_CHARS (exp);
 482               scm_remember (&exp);
 483               pos = 0;
 484               weird = 0;
 485               maybe_weird = 0;
 486
 487               if (len == 0)
 488                 scm_lfwrite ("#{}#", 4, port);
 489
 490               for (end = pos; end < len; ++end)
 491                 switch (str[end])
 492                   {
 493 #ifdef BRACKETS_AS_PARENS
 494                   case '[':
 495                   case ']':
 496 #endif
 497                   case '(':
 498                   case ')':
 499                   case '"':
 500                   case ';':
 501                   case SCM_WHITE_SPACES:
 502                   case SCM_LINE_INCREMENTORS:
 503                   weird_handler:
 504                     if (maybe_weird)
 505                       {
 506                         end = mw_pos;
 507                         maybe_weird = 0;
 508                       }
 509                     if (!weird)
 510                       {
 511                         scm_lfwrite ("#{", 2, port);
 512                         weird = 1;
 513                       }
 514                     if (pos < end)
 515                       {
 516                         scm_lfwrite (str + pos, end - pos, port);
 517                       }
 518                     {
 519                       char buf[2];
 520                       buf[0] = '\\';
 521                       buf[1] = str[end];
 522                       scm_lfwrite (buf, 2, port);
 523                     }
 524                     pos = end + 1;
 525                     break;
 526                   case '\\':
 527                     if (weird)
 528                       goto weird_handler;
 529                     if (!maybe_weird)
 530                       {
 531                         maybe_weird = 1;
 532                         mw_pos = pos;
 533                       }
 534                     break;
 535                   case '}':
 536                   case '#':
 537                     if (weird)
 538                       goto weird_handler;
 539                     break;
 540                   default:
 541                     break;
 542                   }
 543               if (pos < end)
 544                 scm_lfwrite (str + pos, end - pos, port);
 545               if (weird)
 546                 scm_lfwrite ("}#", 2, port);
 547               break;
 548             }
 549         case scm_tc7_wvect:
 550           ENTER_NESTED_DATA (pstate, exp, circref);
 551           if (SCM_IS_WHVEC (exp))
 552             scm_puts ("#wh(", port);
 553           else
 554             scm_puts ("#w(", port);
 555           goto common_vector_printer;
 556
 557         case scm_tc7_vector:
 558           ENTER_NESTED_DATA (pstate, exp, circref);
 559           scm_puts ("#(", port);
 560         common_vector_printer:
 561           {
 562             register long i;
 563             int last = SCM_LENGTH (exp) - 1;
 564             int cutp = 0;
 565             if (pstate->fancyp && SCM_LENGTH (exp) > pstate->length)
 566               {
 567                 last = pstate->length - 1;
 568                 cutp = 1;
 569               }
 570             for (i = 0; i < last; ++i)
 571               {
 572                 /* CHECK_INTS; */
 573                 scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 574                 scm_putc (' ', port);
 575               }
 576             if (i == last)
 577               {
 578                 /* CHECK_INTS; */
 579                 scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
 580               }
 581             if (cutp)
 582               scm_puts (" ...", port);
 583             scm_putc (')', port);
 584           }
 585           EXIT_NESTED_DATA (pstate);
 586           break;
 587         case scm_tc7_bvect:
 588         case scm_tc7_byvect:
 589         case scm_tc7_svect:
 590         case scm_tc7_ivect:
 591         case scm_tc7_uvect:
 592         case scm_tc7_fvect:
 593         case scm_tc7_dvect:
 594         case scm_tc7_cvect:
 595 #ifdef LONGLONGS
 596         case scm_tc7_llvect:
 597 #endif
 598           scm_raprin1 (exp, port, pstate);
 599           break;
 600         case scm_tcs_subrs:
 601           scm_puts ("#<primitive-procedure ", port);
 602           scm_puts (SCM_CHARS (SCM_SNAME (exp)), port);
 603           scm_putc ('>', port);
 604           break;
 605 #ifdef CCLO
 606         case scm_tc7_cclo:
 607           {
 608             SCM proc = SCM_CCLO_SUBR (exp);
 609             if (proc == scm_f_gsubr_apply)
 610               {
 611                 /* Print gsubrs as primitives */
 612                 SCM name = scm_procedure_name (exp);
 613                 scm_puts ("#<primitive-procedure", port);
 614                 if (SCM_NFALSEP (name))
 615                   {
 616                     scm_putc (' ', port);
 617                     scm_puts (SCM_CHARS (name), port);
 618                   }
 619               }
 620             else
 621               {
 622                 scm_puts ("#<compiled-closure ", port);
 623                 scm_iprin1 (proc, port, pstate);
 624               }
 625             scm_putc ('>', port);
 626           }
 627           break;
 628 #endif
 629         case scm_tc7_pws:
 630           scm_puts ("#<procedure-with-setter", port);
 631           {
 632             SCM name = scm_procedure_name (exp);
 633             if (SCM_NFALSEP (name))
 634               {
 635                 scm_putc (' ', port);
 636                 scm_puts (SCM_ROCHARS (name), port);
 637               }
 638           }
 639           scm_putc ('>', port);
 640           break;
 641         case scm_tc7_contin:
 642           scm_puts ("#<continuation ", port);
 643           scm_intprint (SCM_LENGTH (exp), 10, port);
 644           scm_puts (" @ ", port);
 645           scm_intprint ((long) SCM_CHARS (exp), 16, port);
 646           scm_putc ('>', port);
 647           break;
 648         case scm_tc7_port:
 649           {
 650             register long i = SCM_PTOBNUM (exp);
 651             if (i < scm_numptob
 652                 && scm_ptobs[i].print
 653                 && (scm_ptobs[i].print) (exp, port, pstate))
 654               break;
 655             goto punk;
 656           }
 657         case scm_tc7_smob:
 658           {
 659             register long i;
 660             ENTER_NESTED_DATA (pstate, exp, circref);
 661             i = SCM_SMOBNUM (exp);
 662             if (i < scm_numsmob && scm_smobs[i].print
 663                 && (scm_smobs[i].print) (exp, port, pstate))
 664               {
 665                 EXIT_NESTED_DATA (pstate);
 666                 break;
 667               }
 668             EXIT_NESTED_DATA (pstate);
 669             /* Macros have their print field set to NULL.  They are
 670                handled at the same place as closures in order to achieve
 671                non-redundancy.  Placing the condition here won't slow
 672                down printing of other smobs. */
 673             if (SCM_TYP16 (exp) == scm_tc16_macro)
 674               goto macros;
 675           }
 676         default:
 677         punk:
 678           scm_ipruk ("type", exp, port);
 679         }
 680     }
 681 }
 682
 683 /* Print states are necessary for circular reference safe printing.
 684  * They are also expensive to allocate.  Therefore print states are
 685  * kept in a pool so that they can be reused.
 686  */
 687
 688 /* The PORT argument can also be a print-state/port pair, which will
 689  * then be used instead of allocating a new print state.  This is
 690  * useful for continuing a chain of print calls from Scheme.  */
 691
 692 void
 693 scm_prin1 (exp, port, writingp)
 694      SCM exp;
 695      SCM port;
 696      int writingp;
 697 {
 698   SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */
 699   SCM pstate_scm;
 700   scm_print_state *pstate;
 701
 702   /* If PORT is a print-state/port pair, use that.  Else create a new
 703      print-state. */
 704
 705   if (SCM_NIMP (port) && SCM_CONSP (port))
 706     {
 707       pstate_scm = SCM_CDR (port);
 708       port = SCM_CAR (port);
 709     }
 710   else
 711     {
 712       /* First try to allocate a print state from the pool */
 713       SCM_DEFER_INTS;
 714       if (SCM_NNULLP (SCM_CDR (print_state_pool)))
 715         {
 716           handle = SCM_CDR (print_state_pool);
 717           SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
 718         }
 719       SCM_ALLOW_INTS;
 720       if (handle == SCM_BOOL_F)
 721         handle = scm_cons (make_print_state (), SCM_EOL);
 722       pstate_scm = SCM_CAR (handle);
 723     }
 724
 725   pstate = SCM_PRINT_STATE (pstate_scm);
 726   pstate->writingp = writingp;
 727   scm_iprin1 (exp, port, pstate);
 728
 729   /* Return print state to pool if it has been created above and
 730      hasn't escaped to Scheme. */
 731
 732   if (handle != SCM_BOOL_F && !pstate->revealed)
 733     {
 734       SCM_DEFER_INTS;
 735       SCM_SETCDR (handle, SCM_CDR (print_state_pool));
 736       SCM_SETCDR (print_state_pool, handle);
 737       SCM_ALLOW_INTS;
 738     }
 739 }
 740
 741
 742 /* Print an integer.
 743  */
 744
 745 void
 746 scm_intprint (n, radix, port)
 747      long n;
 748      int radix;
 749      SCM port;
 750 {
 751   char num_buf[SCM_INTBUFLEN];
 752   scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
 753 }
 754
 755 /* Print an object of unrecognized type.
 756  */
 757
 758 void
 759 scm_ipruk (hdr, ptr, port)
 760      char *hdr;
 761      SCM ptr;
 762      SCM port;
 763 {
 764   scm_puts ("#<unknown-", port);
 765   scm_puts (hdr, port);
 766   if (SCM_CELLP (ptr))
 767     {
 768       scm_puts (" (0x", port);
 769       scm_intprint (SCM_CAR (ptr), 16, port);
 770       scm_puts (" . 0x", port);
 771       scm_intprint (SCM_CDR (ptr), 16, port);
 772       scm_puts (") @", port);
 773     }
 774   scm_puts (" 0x", port);
 775   scm_intprint (ptr, 16, port);
 776   scm_putc ('>', port);
 777 }
 778
 779 /* Print a list.
 780  */
 781
 782
 783 void
 784 scm_iprlist (hdr, exp, tlr, port, pstate)
 785      char *hdr;
 786      SCM exp;
 787      int tlr;
 788      SCM port;
 789      scm_print_state *pstate;
 790 {
 791   register SCM hare, tortoise;
 792   int floor = pstate->top - 2;
 793   scm_puts (hdr, port);
 794   /* CHECK_INTS; */
 795   if (pstate->fancyp)
 796     goto fancy_printing;
 797
 798   /* Run a hare and tortoise so that total time complexity will be
 799      O(depth * N) instead of O(N^2). */
 800   hare = SCM_CDR (exp);
 801   tortoise = exp;
 802   while (SCM_NIMP (hare) && SCM_ECONSP (hare))
 803     {
 804       if (hare == tortoise)
 805         goto fancy_printing;
 806       hare = SCM_CDR (hare);
 807       if (SCM_IMP (hare) || SCM_NECONSP (hare))
 808         break;
 809       hare = SCM_CDR (hare);
 810       tortoise = SCM_CDR (tortoise);
 811     }
 812
 813   /* No cdr cycles intrinsic to this list */
 814   scm_iprin1 (SCM_CAR (exp), port, pstate);
 815   exp = SCM_CDR (exp);
 816   for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 817     {
 818       register int i;
 819
 820       if (SCM_NECONSP (exp))
 821         break;
 822       for (i = floor; i >= 0; --i)
 823         if (pstate->ref_stack[i] == exp)
 824           goto circref;
 825       PUSH_REF (pstate, exp);
 826       scm_putc (' ', port);
 827       /* CHECK_INTS; */
 828       scm_iprin1 (SCM_CAR (exp), port, pstate);
 829     }
 830   if (SCM_NNULLP (exp))
 831     {
 832       scm_puts (" . ", port);
 833       scm_iprin1 (exp, port, pstate);
 834     }
 835
 836 end:
 837   scm_putc (tlr, port);
 838   pstate->top = floor + 2;
 839   return;
 840
 841 fancy_printing:
 842   {
 843     int n = pstate->length;
 844
 845     scm_iprin1 (SCM_CAR (exp), port, pstate);
 846     exp = SCM_CDR (exp); --n;
 847     for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
 848       {
 849         register unsigned long i;
 850
 851         if (SCM_NECONSP (exp))
 852           break;
 853         for (i = 0; i < pstate->top; ++i)
 854           if (pstate->ref_stack[i] == exp)
 855             goto fancy_circref;
 856         if (pstate->fancyp)
 857           {
 858             if (n == 0)
 859               {
 860                 scm_puts (" ...", port);
 861                 goto skip_tail;
 862               }
 863             else
 864               --n;
 865           }
 866         PUSH_REF(pstate, exp);
 867         ++pstate->list_offset;
 868         scm_putc (' ', port);
 869         /* CHECK_INTS; */
 870         scm_iprin1 (SCM_CAR (exp), port, pstate);
 871       }
 872   }
 873   if (SCM_NNULLP (exp))
 874     {
 875       scm_puts (" . ", port);
 876       scm_iprin1 (exp, port, pstate);
 877     }
 878 skip_tail:
 879   pstate->list_offset -= pstate->top - floor - 2;
 880   goto end;
 881
 882 fancy_circref:
 883   pstate->list_offset -= pstate->top - floor - 2;
 884
 885 circref:
 886   scm_puts (" . ", port);
 887   print_circref (port, pstate, exp);
 888   goto end;
 889 }
 890
 891 \f
 892
 893 int
 894 scm_valid_oport_value_p (SCM val)
 895 {
 896   return (SCM_NIMP (val)
 897           && (SCM_OPOUTPORTP (val)
 898               || (SCM_CONSP (val)
 899                   && SCM_NIMP (SCM_CAR (val))
 900                   && SCM_OPOUTPORTP (SCM_CAR (val))
 901                   && SCM_NIMP (SCM_CDR (val))
 902                   && SCM_PRINT_STATE_P (SCM_CDR (val)))));
 903 }
 904
 905 SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
 906
 907 SCM
 908 scm_write (obj, port)
 909      SCM obj;
 910      SCM port;
 911 {
 912   if (SCM_UNBNDP (port))
 913     port = scm_cur_outp;
 914   else
 915     SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
 916
 917   scm_prin1 (obj, port, 1);
 918 #ifdef HAVE_PIPE
 919 # ifdef EPIPE
 920   if (EPIPE == errno)
 921     scm_close_port (port);
 922 # endif
 923 #endif
 924   return SCM_UNSPECIFIED;
 925 }
 926
 927
 928 SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
 929
 930 SCM
 931 scm_display (obj, port)
 932      SCM obj;
 933      SCM port;
 934 {
 935   if (SCM_UNBNDP (port))
 936     port = scm_cur_outp;
 937   else
 938     SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
 939
 940   scm_prin1 (obj, port, 0);
 941 #ifdef HAVE_PIPE
 942 # ifdef EPIPE
 943   if (EPIPE == errno)
 944     scm_close_port (port);
 945 # endif
 946 #endif
 947   return SCM_UNSPECIFIED;
 948 }
 949
 950 SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
 951
 952 SCM
 953 scm_newline (port)
 954      SCM port;
 955 {
 956   if (SCM_UNBNDP (port))
 957     port = scm_cur_outp;
 958   else
 959     SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG1, s_newline);
 960
 961   scm_putc ('\n', SCM_COERCE_OUTPORT (port));
 962 #ifdef HAVE_PIPE
 963 # ifdef EPIPE
 964   if (EPIPE == errno)
 965     scm_close_port (port);
 966   else
 967 # endif
 968 #endif
 969   if (port == scm_cur_outp)
 970     scm_fflush (port);
 971   return SCM_UNSPECIFIED;
 972 }
 973
 974 SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
 975
 976 SCM
 977 scm_write_char (chr, port)
 978      SCM chr;
 979      SCM port;
 980 {
 981   if (SCM_UNBNDP (port))
 982     port = scm_cur_outp;
 983   else
 984     SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write_char);
 985
 986   SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
 987   scm_putc ((int) SCM_ICHR (chr), SCM_COERCE_OUTPORT (port));
 988 #ifdef HAVE_PIPE
 989 # ifdef EPIPE
 990   if (EPIPE == errno)
 991     scm_close_port (port);
 992 # endif
 993 #endif
 994   return SCM_UNSPECIFIED;
 995 }
 996
 997 \f
 998
 999 /* Call back to Scheme code to do the printing of special objects
1000 (like structs).  SCM_PRINTER_APPLY applies PROC to EXP and a pair
1001 containing PORT and PSTATE.  This pair can be used as the port for
1002 display/write etc to continue the current print chain.  The REVEALED
1003 field of PSTATE is set to true to indicate that the print state has
1004 escaped to Scheme and thus has to be freed by the GC. */
1005
1006 SCM
1007 scm_printer_apply (proc, exp, port, pstate)
1008      SCM proc, exp, port;
1009      scm_print_state *pstate;
1010 {
1011   SCM pair = scm_cons (port, pstate->handle);
1012   pstate->revealed = 1;
1013   return scm_apply (proc, exp, scm_cons (pair, scm_listofnull));
1014 }
1015
1016 \f
1017
1018 void
1019 scm_init_print ()
1020 {
1021   SCM vtable, layout, printer, type;
1022
1023   scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
1024   vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr),
1025                                    SCM_INUM0,
1026                                    SCM_EOL);
1027   layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT));
1028   printer = scm_make_subr_opt (s_print_state_printer,
1029                                scm_tc7_subr_2,
1030                                (SCM (*) ()) print_state_printer,
1031                                0 /* Don't bind the name. */);
1032   type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST2 (layout, printer));
1033   print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
1034
1035   scm_print_state_vtable = type;
1036
1037 #include "print.x"
1038 }