libguile/print.c

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