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