libguile/print.c

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