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