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