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