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