guile18/libguile/print.c

   1 /* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include <errno.h>
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/chars.h"
  28 #include "libguile/continuations.h"
  29 #include "libguile/smob.h"
  30 #include "libguile/eval.h"
  31 #include "libguile/macros.h"
  32 #include "libguile/procprop.h"
  33 #include "libguile/read.h"
  34 #include "libguile/weaks.h"
  35 #include "libguile/unif.h"
  36 #include "libguile/alist.h"
  37 #include "libguile/struct.h"
  38 #include "libguile/objects.h"
  39 #include "libguile/ports.h"
  40 #include "libguile/root.h"
  41 #include "libguile/strings.h"
  42 #include "libguile/strports.h"
  43 #include "libguile/vectors.h"
  44 #include "libguile/lang.h"
  45 #include "libguile/numbers.h"
  46
  47 #include "libguile/validate.h"
  48 #include "libguile/print.h"
  49 \f
  50
  51 /* {Names of immediate symbols}
  52  *
  53  * This table must agree with the declarations in scm.h: {Immediate Symbols}.
  54  */
  55
  56 /* This table must agree with the list of flags in tags.h.  */
  57 static const char *iflagnames[] =
  58 {
  59   "#f",
  60   "#t",
  61   "#<undefined>",
  62   "#<eof>",
  63   "()",
  64   "#<unspecified>",
  65
  66   /* Unbound slot marker for GOOPS.  For internal use in GOOPS only.  */
  67   "#<unbound>",
  68
  69   /* Elisp nil value.  This is its Scheme name; whenever it's printed in
  70    * Elisp, it should appear as the symbol `nil'.  */
  71   "#nil"
  72 };
  73
  74 SCM_SYMBOL (sym_reader, "reader");
  75
  76 scm_t_option scm_print_opts[] = {
  77   { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F),
  78     "Hook for printing closures (should handle macros as well)." },
  79   { SCM_OPTION_BOOLEAN, "source", 0,
  80     "Print closures with source." },
  81   { SCM_OPTION_SCM, "highlight-prefix", (unsigned long)SCM_BOOL_F,
  82     "The string to print before highlighted values." },
  83   { SCM_OPTION_SCM, "highlight-suffix", (unsigned long)SCM_BOOL_F,
  84     "The string to print after highlighted values." },
  85   { SCM_OPTION_SCM, "quote-keywordish-symbols", (unsigned long)SCM_BOOL_F,
  86     "How to print symbols that have a colon as their first or last character. "
  87     "The value '#f' does not quote the colons; '#t' quotes them; "
  88     "'reader' quotes them when the reader option 'keywords' is not '#f'."
  89   }
  90 };
  91
  92 SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
  93             (SCM setting),
  94             "Option interface for the print options. Instead of using\n"
  95             "this procedure directly, use the procedures\n"
  96             "@code{print-enable}, @code{print-disable}, @code{print-set!}\n"
  97             "and @code{print-options}.")
  98 #define FUNC_NAME s_scm_print_options
  99 {
 100   SCM ans = scm_options (setting,
 101                          scm_print_opts,
 102                          SCM_N_PRINT_OPTIONS,
 103                          FUNC_NAME);
 104   return ans;
 105 }
 106 #undef FUNC_NAME
 107
 108 \f
 109 /* {Printing of Scheme Objects}
 110  */
 111
 112 /* Detection of circular references.
 113  *
 114  * Due to other constraints in the implementation, this code has bad
 115  * time complexity (O (depth * N)), The printer code can be
 116  * rewritten to be O(N).
 117  */
 118 #define PUSH_REF(pstate, obj)                   \
 119 do                                              \
 120 {                                               \
 121   PSTATE_STACK_SET (pstate, pstate->top, obj);  \
 122   pstate->top++;                                \
 123   if (pstate->top == pstate->ceiling)           \
 124     grow_ref_stack (pstate);                    \
 125 } while(0)
 126
 127 #define ENTER_NESTED_DATA(pstate, obj, label)                   \
 128 do                                                              \
 129 {                                                               \
 130   register unsigned long i;                                     \
 131   for (i = 0; i < pstate->top; ++i)                             \
 132     if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj)))        \
 133       goto label;                                               \
 134   if (pstate->fancyp)                                           \
 135     {                                                           \
 136       if (pstate->top - pstate->list_offset >= pstate->level)   \
 137         {                                                       \
 138           scm_putc ('#', port);                                 \
 139           return;                                               \
 140         }                                                       \
 141     }                                                           \
 142   PUSH_REF(pstate, obj);                                        \
 143 } while(0)
 144
 145 #define EXIT_NESTED_DATA(pstate)                                \
 146 do                                                              \
 147 {                                                               \
 148   --pstate->top;                                                \
 149   PSTATE_STACK_SET (pstate, pstate->top, SCM_UNDEFINED);        \
 150 }                                                               \
 151 while (0)
 152
 153 SCM scm_print_state_vtable = SCM_BOOL_F;
 154 static SCM print_state_pool = SCM_EOL;
 155 scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 156
 157 #ifdef GUILE_DEBUG /* Used for debugging purposes */
 158
 159 SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0,
 160            (),
 161             "Return the current-pstate -- the car of the\n"
 162             "@code{print_state_pool}.  @code{current-pstate} is only\n"
 163             "included in @code{--enable-guile-debug} builds.")
 164 #define FUNC_NAME s_scm_current_pstate
 165 {
 166   if (!scm_is_null (print_state_pool))
 167     return SCM_CAR (print_state_pool);
 168   else
 169     return SCM_BOOL_F;
 170 }
 171 #undef FUNC_NAME
 172
 173 #endif
 174
 175 #define PSTATE_SIZE 50L
 176
 177 static SCM
 178 make_print_state (void)
 179 {
 180   SCM print_state
 181     = scm_make_struct (scm_print_state_vtable, SCM_INUM0, SCM_EOL);
 182   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 183   pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
 184   pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect);
 185   pstate->highlight_objects = SCM_EOL;
 186   return print_state;
 187 }
 188
 189 SCM
 190 scm_make_print_state ()
 191 {
 192   SCM answer = SCM_BOOL_F;
 193
 194   /* First try to allocate a print state from the pool */
 195   scm_i_pthread_mutex_lock (&print_state_mutex);
 196   if (!scm_is_null (print_state_pool))
 197     {
 198       answer = SCM_CAR (print_state_pool);
 199       print_state_pool = SCM_CDR (print_state_pool);
 200     }
 201   scm_i_pthread_mutex_unlock (&print_state_mutex);
 202
 203   return scm_is_false (answer) ? make_print_state () : answer;
 204 }
 205
 206 void
 207 scm_free_print_state (SCM print_state)
 208 {
 209   SCM handle;
 210   scm_print_state *pstate = SCM_PRINT_STATE (print_state);
 211   /* Cleanup before returning print state to pool.
 212    * It is better to do it here.  Doing it in scm_prin1
 213    * would cost more since that function is called much more
 214    * often.
 215    */
 216   pstate->fancyp = 0;
 217   pstate->revealed = 0;
 218   pstate->highlight_objects = SCM_EOL;
 219   scm_i_pthread_mutex_lock (&print_state_mutex);
 220   handle = scm_cons (print_state, print_state_pool);
 221   print_state_pool = handle;
 222   scm_i_pthread_mutex_unlock (&print_state_mutex);
 223 }
 224
 225 SCM
 226 scm_i_port_with_print_state (SCM port, SCM print_state)
 227 {
 228   if (SCM_UNBNDP (print_state))
 229     {
 230       if (SCM_PORT_WITH_PS_P (port))
 231         return port;
 232       else
 233         print_state = scm_make_print_state ();
 234       /* port does not need to be coerced since it doesn't have ps */
 235     }
 236   else
 237     port = SCM_COERCE_OUTPORT (port);
 238   SCM_RETURN_NEWSMOB (scm_tc16_port_with_ps,
 239                       SCM_UNPACK (scm_cons (port, print_state)));
 240 }
 241
 242 static void
 243 grow_ref_stack (scm_print_state *pstate)
 244 {
 245   SCM old_vect = pstate->ref_vect;
 246   size_t old_size = SCM_SIMPLE_VECTOR_LENGTH (old_vect);
 247   size_t new_size = 2 * pstate->ceiling;
 248   SCM new_vect = scm_c_make_vector (new_size, SCM_UNDEFINED);
 249   unsigned long int i;
 250
 251   for (i = 0; i != old_size; ++i)
 252     SCM_SIMPLE_VECTOR_SET (new_vect, i, SCM_SIMPLE_VECTOR_REF (old_vect, i));
 253
 254   pstate->ref_vect = new_vect;
 255   pstate->ceiling = new_size;
 256 }
 257
 258 #define PSTATE_STACK_REF(p,i)   SCM_SIMPLE_VECTOR_REF((p)->ref_vect, (i))
 259 #define PSTATE_STACK_SET(p,i,v) SCM_SIMPLE_VECTOR_SET((p)->ref_vect, (i), (v))
 260
 261 static void
 262 print_circref (SCM port, scm_print_state *pstate, SCM ref)
 263 {
 264   register long i;
 265   long self = pstate->top - 1;
 266   i = pstate->top - 1;
 267   if (scm_is_pair (PSTATE_STACK_REF (pstate, i)))
 268     {
 269       while (i > 0)
 270         {
 271           if (!scm_is_pair (PSTATE_STACK_REF (pstate, i-1))
 272               || !scm_is_eq (SCM_CDR (PSTATE_STACK_REF (pstate, i-1)),
 273                              SCM_CDR (PSTATE_STACK_REF (pstate, i))))
 274             break;
 275           --i;
 276         }
 277       self = i;
 278     }
 279   for (i = pstate->top - 1; 1; --i)
 280     if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
 281       break;
 282   scm_putc ('#', port);
 283   scm_intprint (i - self, 10, port);
 284   scm_putc ('#', port);
 285 }
 286
 287 /* Print the name of a symbol. */
 288
 289 static int
 290 quote_keywordish_symbol (const char *str, size_t len)
 291 {
 292   SCM option;
 293
 294   /* LEN is guaranteed to be > 0.
 295    */
 296   if (str[0] != ':' && str[len-1] != ':')
 297     return 0;
 298
 299   option = SCM_PRINT_KEYWORD_STYLE;
 300   if (scm_is_false (option))
 301     return 0;
 302   if (scm_is_eq (option, sym_reader))
 303     return scm_is_true (SCM_PACK (SCM_KEYWORD_STYLE));
 304   return 1;
 305 }
 306
 307 void
 308 scm_print_symbol_name (const char *str, size_t len, SCM port)
 309 {
 310   /* This points to the first character that has not yet been written to the
 311    * port. */
 312   size_t pos = 0;
 313   /* This points to the character we're currently looking at. */
 314   size_t end;
 315   /* If the name contains weird characters, we'll escape them with
 316    * backslashes and set this flag; it indicates that we should surround the
 317    * name with "#{" and "}#". */
 318   int weird = 0;
 319   /* Backslashes are not sufficient to make a name weird, but if a name is
 320    * weird because of other characters, backslahes need to be escaped too.
 321    * The first time we see a backslash, we set maybe_weird, and mw_pos points
 322    * to the backslash.  Then if the name turns out to be weird, we re-process
 323    * everything starting from mw_pos.
 324    * We could instead make backslashes always weird.  This is not necessary
 325    * to ensure that the output is (read)-able, but it would make this code
 326    * simpler and faster. */
 327   int maybe_weird = 0;
 328   size_t mw_pos = 0;
 329
 330   if (len == 0 || str[0] == '\'' || str[0] == '`' || str[0] == ','
 331       || quote_keywordish_symbol (str, len)
 332       || (str[0] == '.' && len == 1)
 333       || scm_is_true (scm_c_locale_stringn_to_number (str, len, 10)))
 334     {
 335       scm_lfwrite ("#{", 2, port);
 336       weird = 1;
 337     }
 338
 339   for (end = pos; end < len; ++end)
 340     switch (str[end])
 341       {
 342 #ifdef BRACKETS_AS_PARENS
 343       case '[':
 344       case ']':
 345 #endif
 346       case '(':
 347       case ')':
 348       case '"':
 349       case ';':
 350       case '#':
 351       case SCM_WHITE_SPACES:
 352       case SCM_LINE_INCREMENTORS:
 353       weird_handler:
 354         if (maybe_weird)
 355           {
 356             end = mw_pos;
 357             maybe_weird = 0;
 358           }
 359         if (!weird)
 360           {
 361             scm_lfwrite ("#{", 2, port);
 362             weird = 1;
 363           }
 364         if (pos < end)
 365           scm_lfwrite (str + pos, end - pos, port);
 366         {
 367           char buf[2];
 368           buf[0] = '\\';
 369           buf[1] = str[end];
 370           scm_lfwrite (buf, 2, port);
 371         }
 372         pos = end + 1;
 373         break;
 374       case '\\':
 375         if (weird)
 376           goto weird_handler;
 377         if (!maybe_weird)
 378           {
 379             maybe_weird = 1;
 380             mw_pos = pos;
 381           }
 382         break;
 383       default:
 384         break;
 385       }
 386   if (pos < end)
 387     scm_lfwrite (str + pos, end - pos, port);
 388   if (weird)
 389     scm_lfwrite ("}#", 2, port);
 390 }
 391
 392 /* Print generally.  Handles both write and display according to PSTATE.
 393  */
 394 SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
 395 SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
 396
 397 static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);
 398
 399 void
 400 scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 401 {
 402   if (pstate->fancyp
 403       && scm_is_true (scm_memq (exp, pstate->highlight_objects)))
 404     {
 405       scm_display (SCM_PRINT_HIGHLIGHT_PREFIX, port);
 406       iprin1 (exp, port, pstate);
 407       scm_display (SCM_PRINT_HIGHLIGHT_SUFFIX, port);
 408     }
 409   else
 410     iprin1 (exp, port, pstate);
 411 }
 412
 413 static void
 414 iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 415 {
 416   switch (SCM_ITAG3 (exp))
 417     {
 418     case scm_tc3_closure:
 419     case scm_tc3_tc7_1:
 420     case scm_tc3_tc7_2:
 421       /* These tc3 tags should never occur in an immediate value.  They are
 422        * only used in cell types of non-immediates, i. e. the value returned
 423        * by SCM_CELL_TYPE (exp) can use these tags.
 424        */
 425       scm_ipruk ("immediate", exp, port);
 426       break;
 427     case scm_tc3_int_1:
 428     case scm_tc3_int_2:
 429       scm_intprint (SCM_I_INUM (exp), 10, port);
 430       break;
 431     case scm_tc3_imm24:
 432       if (SCM_CHARP (exp))
 433         {
 434           long i = SCM_CHAR (exp);
 435
 436           if (SCM_WRITINGP (pstate))
 437             {
 438               scm_puts ("#\\", port);
 439               if ((i >= 0) && (i <= ' ') && scm_charnames[i])
 440                 scm_puts (scm_charnames[i], port);
 441 #ifndef EBCDIC
 442               else if (i == '\177')
 443                 scm_puts (scm_charnames[scm_n_charnames - 1], port);
 444 #endif
 445               else if (i < 0 || i > '\177')
 446                 scm_intprint (i, 8, port);
 447               else
 448                 scm_putc (i, port);
 449             }
 450           else
 451             scm_putc (i, port);
 452         }
 453       else if (SCM_IFLAGP (exp)
 454                && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
 455         {
 456           scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
 457         }
 458       else if (SCM_ISYMP (exp))
 459         {
 460           scm_i_print_isym (exp, port);
 461         }
 462       else if (SCM_ILOCP (exp))
 463         {
 464           scm_i_print_iloc (exp, port);
 465         }
 466       else
 467         {
 468           /* unknown immediate value */
 469           scm_ipruk ("immediate", exp, port);
 470         }
 471       break;
 472     case scm_tc3_cons:
 473       switch (SCM_TYP7 (exp))
 474         {
 475         case scm_tcs_struct:
 476           {
 477             ENTER_NESTED_DATA (pstate, exp, circref);
 478             if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
 479               {
 480                 SCM pwps, print = pstate->writingp ? g_write : g_display;
 481                 if (!print)
 482                   goto print_struct;
 483                 pwps = scm_i_port_with_print_state (port, pstate->handle);
 484                 pstate->revealed = 1;
 485                 scm_call_generic_2 (print, exp, pwps);
 486               }
 487             else
 488               {
 489               print_struct:
 490                 scm_print_struct (exp, port, pstate);
 491               }
 492             EXIT_NESTED_DATA (pstate);
 493           }
 494           break;
 495         case scm_tcs_cons_imcar:
 496         case scm_tcs_cons_nimcar:
 497           ENTER_NESTED_DATA (pstate, exp, circref);
 498           scm_iprlist ("(", exp, ')', port, pstate);
 499           EXIT_NESTED_DATA (pstate);
 500           break;
 501         circref:
 502           print_circref (port, pstate, exp);
 503           break;
 504         case scm_tcs_closures:
 505           if (scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
 506               || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
 507                                                 exp, port, pstate)))
 508             {
 509               SCM formals = SCM_CLOSURE_FORMALS (exp);
 510               scm_puts ("#<procedure", port);
 511               scm_putc (' ', port);
 512               scm_iprin1 (scm_procedure_name (exp), port, pstate);
 513               scm_putc (' ', port);
 514               if (SCM_PRINT_SOURCE_P)
 515                 {
 516                   SCM env = SCM_ENV (exp);
 517                   SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
 518                   SCM src = scm_i_unmemocopy_body (SCM_CODE (exp), xenv);
 519                   ENTER_NESTED_DATA (pstate, exp, circref);
 520                   scm_iprin1 (src, port, pstate);
 521                   EXIT_NESTED_DATA (pstate);
 522                 }
 523               else
 524                 scm_iprin1 (formals, port, pstate);
 525               scm_putc ('>', port);
 526             }
 527           break;
 528         case scm_tc7_number:
 529           switch SCM_TYP16 (exp) {
 530           case scm_tc16_big:
 531             scm_bigprint (exp, port, pstate);
 532             break;
 533           case scm_tc16_real:
 534             scm_print_real (exp, port, pstate);
 535             break;
 536           case scm_tc16_complex:
 537             scm_print_complex (exp, port, pstate);
 538             break;
 539           case scm_tc16_fraction:
 540             scm_i_print_fraction (exp, port, pstate);
 541             break;
 542           }
 543           break;
 544         case scm_tc7_string:
 545           if (SCM_WRITINGP (pstate))
 546             {
 547               size_t i, j, len;
 548               const char *data;
 549
 550               scm_putc ('"', port);
 551               len = scm_i_string_length (exp);
 552               data = scm_i_string_chars (exp);
 553               for (i = 0, j = 0; i < len; ++i)
 554                 {
 555                   unsigned char ch = data[i];
 556                   if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148))
 557                     {
 558                       static char const hex[]="0123456789abcdef";
 559                       char buf[4];
 560
 561                       scm_lfwrite (data+j, i-j, port);
 562                       buf[0] = '\\';
 563                       buf[1] = 'x';
 564                       buf[2] =  hex [ch / 16];
 565                       buf[3] = hex [ch % 16];
 566                       scm_lfwrite (buf, 4, port);
 567                       data = scm_i_string_chars (exp);
 568                       j = i+1;
 569                     }
 570                   else if (ch == '"' || ch == '\\')
 571                     {
 572                       scm_lfwrite (data+j, i-j, port);
 573                       scm_putc ('\\', port);
 574                       data = scm_i_string_chars (exp);
 575                       j = i;
 576                     }
 577                 }
 578               scm_lfwrite (data+j, i-j, port);
 579               scm_putc ('"', port);
 580               scm_remember_upto_here_1 (exp);
 581             }
 582           else
 583             scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp),
 584                          port);
 585           scm_remember_upto_here_1 (exp);
 586           break;
 587         case scm_tc7_symbol:
 588           if (scm_i_symbol_is_interned (exp))
 589             {
 590               scm_print_symbol_name (scm_i_symbol_chars (exp),
 591                                      scm_i_symbol_length (exp),
 592                                      port);
 593               scm_remember_upto_here_1 (exp);
 594             }
 595           else
 596             {
 597               scm_puts ("#<uninterned-symbol ", port);
 598               scm_print_symbol_name (scm_i_symbol_chars (exp),
 599                                      scm_i_symbol_length (exp),
 600                                      port);
 601               scm_putc (' ', port);
 602               scm_uintprint (SCM_UNPACK (exp), 16, port);
 603               scm_putc ('>', port);
 604             }
 605           break;
 606         case scm_tc7_variable:
 607           scm_i_variable_print (exp, port, pstate);
 608           break;
 609         case scm_tc7_wvect:
 610           ENTER_NESTED_DATA (pstate, exp, circref);
 611           if (SCM_IS_WHVEC (exp))
 612             scm_puts ("#wh(", port);
 613           else
 614             scm_puts ("#w(", port);
 615           goto common_vector_printer;
 616
 617         case scm_tc7_vector:
 618           ENTER_NESTED_DATA (pstate, exp, circref);
 619           scm_puts ("#(", port);
 620         common_vector_printer:
 621           {
 622             register long i;
 623             long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1;
 624             int cutp = 0;
 625             if (pstate->fancyp
 626                 && SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length)
 627               {
 628                 last = pstate->length - 1;
 629                 cutp = 1;
 630               }
 631             for (i = 0; i < last; ++i)
 632               {
 633                 /* CHECK_INTS; */
 634                 scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
 635                 scm_putc (' ', port);
 636               }
 637             if (i == last)
 638               {
 639                 /* CHECK_INTS; */
 640                 scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
 641               }
 642             if (cutp)
 643               scm_puts (" ...", port);
 644             scm_putc (')', port);
 645           }
 646           EXIT_NESTED_DATA (pstate);
 647           break;
 648         case scm_tcs_subrs:
 649           scm_puts (SCM_SUBR_GENERIC (exp)
 650                     ? "#<primitive-generic "
 651                     : "#<primitive-procedure ",
 652                     port);
 653           scm_puts (scm_i_symbol_chars (SCM_SNAME (exp)), port);
 654           scm_putc ('>', port);
 655           break;
 656 #ifdef CCLO
 657         case scm_tc7_cclo:
 658           {
 659             SCM proc = SCM_CCLO_SUBR (exp);
 660             if (scm_is_eq (proc, scm_f_gsubr_apply))
 661               {
 662                 /* Print gsubrs as primitives */
 663                 SCM name = scm_procedure_name (exp);
 664                 scm_puts ("#<primitive-procedure", port);
 665                 if (scm_is_true (name))
 666                   {
 667                     scm_putc (' ', port);
 668                     scm_puts (scm_i_symbol_chars (name), port);
 669                   }
 670               }
 671             else
 672               {
 673                 scm_puts ("#<compiled-closure ", port);
 674                 scm_iprin1 (proc, port, pstate);
 675               }
 676             scm_putc ('>', port);
 677           }
 678           break;
 679 #endif
 680         case scm_tc7_pws:
 681           scm_puts ("#<procedure-with-setter", port);
 682           {
 683             SCM name = scm_procedure_name (exp);
 684             if (scm_is_true (name))
 685               {
 686                 scm_putc (' ', port);
 687                 scm_display (name, port);
 688               }
 689           }
 690           scm_putc ('>', port);
 691           break;
 692         case scm_tc7_port:
 693           {
 694             register long i = SCM_PTOBNUM (exp);
 695             if (i < scm_numptob
 696                 && scm_ptobs[i].print
 697                 && (scm_ptobs[i].print) (exp, port, pstate))
 698               break;
 699             goto punk;
 700           }
 701         case scm_tc7_smob:
 702           ENTER_NESTED_DATA (pstate, exp, circref);
 703           SCM_SMOB_DESCRIPTOR (exp).print (exp, port, pstate);
 704           EXIT_NESTED_DATA (pstate);
 705           break;
 706         default:
 707         punk:
 708           scm_ipruk ("type", exp, port);
 709         }
 710     }
 711 }
 712
 713 /* Print states are necessary for circular reference safe printing.
 714  * They are also expensive to allocate.  Therefore print states are
 715  * kept in a pool so that they can be reused.
 716  */
 717
 718 /* The PORT argument can also be a print-state/port pair, which will
 719  * then be used instead of allocating a new print state.  This is
 720  * useful for continuing a chain of print calls from Scheme.  */
 721
 722 void
 723 scm_prin1 (SCM exp, SCM port, int writingp)
 724 {
 725   SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */
 726   SCM pstate_scm;
 727   scm_print_state *pstate;
 728   int old_writingp;
 729
 730   /* If PORT is a print-state/port pair, use that.  Else create a new
 731      print-state. */
 732
 733   if (SCM_PORT_WITH_PS_P (port))
 734     {
 735       pstate_scm = SCM_PORT_WITH_PS_PS (port);
 736       port = SCM_PORT_WITH_PS_PORT (port);
 737     }
 738   else
 739     {
 740       /* First try to allocate a print state from the pool */
 741       scm_i_pthread_mutex_lock (&print_state_mutex);
 742       if (!scm_is_null (print_state_pool))
 743         {
 744           handle = print_state_pool;
 745           print_state_pool = SCM_CDR (print_state_pool);
 746         }
 747       scm_i_pthread_mutex_unlock (&print_state_mutex);
 748       if (scm_is_false (handle))
 749         handle = scm_list_1 (make_print_state ());
 750       pstate_scm = SCM_CAR (handle);
 751     }
 752
 753   pstate = SCM_PRINT_STATE (pstate_scm);
 754   old_writingp = pstate->writingp;
 755   pstate->writingp = writingp;
 756   scm_iprin1 (exp, port, pstate);
 757   pstate->writingp = old_writingp;
 758
 759   /* Return print state to pool if it has been created above and
 760      hasn't escaped to Scheme. */
 761
 762   if (scm_is_true (handle) && !pstate->revealed)
 763     {
 764       scm_i_pthread_mutex_lock (&print_state_mutex);
 765       SCM_SETCDR (handle, print_state_pool);
 766       print_state_pool = handle;
 767       scm_i_pthread_mutex_unlock (&print_state_mutex);
 768     }
 769 }
 770
 771
 772 /* Print an integer.
 773  */
 774
 775 void
 776 scm_intprint (scm_t_intmax n, int radix, SCM port)
 777 {
 778   char num_buf[SCM_INTBUFLEN];
 779   scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
 780 }
 781
 782 void
 783 scm_uintprint (scm_t_uintmax n, int radix, SCM port)
 784 {
 785   char num_buf[SCM_INTBUFLEN];
 786   scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
 787 }
 788
 789 /* Print an object of unrecognized type.
 790  */
 791
 792 void
 793 scm_ipruk (char *hdr, SCM ptr, SCM port)
 794 {
 795   scm_puts ("#<unknown-", port);
 796   scm_puts (hdr, port);
 797   if (scm_in_heap_p (ptr))
 798     {
 799       scm_puts (" (0x", port);
 800       scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
 801       scm_puts (" . 0x", port);
 802       scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
 803       scm_puts (") @", port);
 804     }
 805   scm_puts (" 0x", port);
 806   scm_uintprint (SCM_UNPACK (ptr), 16, port);
 807   scm_putc ('>', port);
 808 }
 809
 810
 811 /* Print a list.
 812  */
 813 void
 814 scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate)
 815 {
 816   register SCM hare, tortoise;
 817   long floor = pstate->top - 2;
 818   scm_puts (hdr, port);
 819   /* CHECK_INTS; */
 820   if (pstate->fancyp)
 821     goto fancy_printing;
 822
 823   /* Run a hare and tortoise so that total time complexity will be
 824      O(depth * N) instead of O(N^2). */
 825   hare = SCM_CDR (exp);
 826   tortoise = exp;
 827   while (scm_is_pair (hare))
 828     {
 829       if (scm_is_eq (hare, tortoise))
 830         goto fancy_printing;
 831       hare = SCM_CDR (hare);
 832       if (!scm_is_pair (hare))
 833         break;
 834       hare = SCM_CDR (hare);
 835       tortoise = SCM_CDR (tortoise);
 836     }
 837
 838   /* No cdr cycles intrinsic to this list */
 839   scm_iprin1 (SCM_CAR (exp), port, pstate);
 840   for (exp = SCM_CDR (exp); scm_is_pair (exp); exp = SCM_CDR (exp))
 841     {
 842       register long i;
 843
 844       for (i = floor; i >= 0; --i)
 845         if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
 846           goto circref;
 847       PUSH_REF (pstate, exp);
 848       scm_putc (' ', port);
 849       /* CHECK_INTS; */
 850       scm_iprin1 (SCM_CAR (exp), port, pstate);
 851     }
 852   if (!SCM_NULL_OR_NIL_P (exp))
 853     {
 854       scm_puts (" . ", port);
 855       scm_iprin1 (exp, port, pstate);
 856     }
 857
 858 end:
 859   scm_putc (tlr, port);
 860   pstate->top = floor + 2;
 861   return;
 862
 863 fancy_printing:
 864   {
 865     long n = pstate->length;
 866
 867     scm_iprin1 (SCM_CAR (exp), port, pstate);
 868     exp = SCM_CDR (exp); --n;
 869     for (; scm_is_pair (exp); exp = SCM_CDR (exp))
 870       {
 871         register unsigned long i;
 872
 873         for (i = 0; i < pstate->top; ++i)
 874           if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
 875             goto fancy_circref;
 876         if (pstate->fancyp)
 877           {
 878             if (n == 0)
 879               {
 880                 scm_puts (" ...", port);
 881                 goto skip_tail;
 882               }
 883             else
 884               --n;
 885           }
 886         PUSH_REF(pstate, exp);
 887         ++pstate->list_offset;
 888         scm_putc (' ', port);
 889         /* CHECK_INTS; */
 890         scm_iprin1 (SCM_CAR (exp), port, pstate);
 891       }
 892   }
 893   if (!SCM_NULL_OR_NIL_P (exp))
 894     {
 895       scm_puts (" . ", port);
 896       scm_iprin1 (exp, port, pstate);
 897     }
 898 skip_tail:
 899   pstate->list_offset -= pstate->top - floor - 2;
 900   goto end;
 901
 902 fancy_circref:
 903   pstate->list_offset -= pstate->top - floor - 2;
 904
 905 circref:
 906   scm_puts (" . ", port);
 907   print_circref (port, pstate, exp);
 908   goto end;
 909 }
 910
 911 \f
 912
 913 int
 914 scm_valid_oport_value_p (SCM val)
 915 {
 916   return (SCM_OPOUTPORTP (val)
 917           || (SCM_PORT_WITH_PS_P (val)
 918               && SCM_OPOUTPORTP (SCM_PORT_WITH_PS_PORT (val))));
 919 }
 920
 921 /* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */
 922
 923 SCM
 924 scm_write (SCM obj, SCM port)
 925 {
 926   if (SCM_UNBNDP (port))
 927     port = scm_current_output_port ();
 928
 929   SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
 930
 931   scm_prin1 (obj, port, 1);
 932 #if 0
 933 #ifdef HAVE_PIPE
 934 # ifdef EPIPE
 935   if (EPIPE == errno)
 936     scm_close_port (port);
 937 # endif
 938 #endif
 939 #endif
 940   return SCM_UNSPECIFIED;
 941 }
 942
 943
 944 /* SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); */
 945
 946 SCM
 947 scm_display (SCM obj, SCM port)
 948 {
 949   if (SCM_UNBNDP (port))
 950     port = scm_current_output_port ();
 951
 952   SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
 953
 954   scm_prin1 (obj, port, 0);
 955 #if 0
 956 #ifdef HAVE_PIPE
 957 # ifdef EPIPE
 958   if (EPIPE == errno)
 959     scm_close_port (port);
 960 # endif
 961 #endif
 962 #endif
 963   return SCM_UNSPECIFIED;
 964 }
 965
 966
 967 SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
 968             (SCM destination, SCM message, SCM args),
 969             "Write @var{message} to @var{destination}, defaulting to\n"
 970             "the current output port.\n"
 971             "@var{message} can contain @code{~A} (was @code{%s}) and\n"
 972             "@code{~S} (was @code{%S}) escapes.  When printed,\n"
 973             "the escapes are replaced with corresponding members of\n"
 974             "@var{ARGS}:\n"
 975             "@code{~A} formats using @code{display} and @code{~S} formats\n"
 976             "using @code{write}.\n"
 977             "If @var{destination} is @code{#t}, then use the current output\n"
 978             "port, if @var{destination} is @code{#f}, then return a string\n"
 979             "containing the formatted text. Does not add a trailing newline.")
 980 #define FUNC_NAME s_scm_simple_format
 981 {
 982   SCM port, answer = SCM_UNSPECIFIED;
 983   int fReturnString = 0;
 984   int writingp;
 985   const char *start;
 986   const char *end;
 987   const char *p;
 988
 989   if (scm_is_eq (destination, SCM_BOOL_T))
 990     {
 991       destination = port = scm_current_output_port ();
 992     }
 993   else if (scm_is_false (destination))
 994     {
 995       fReturnString = 1;
 996       port = scm_mkstrport (SCM_INUM0,
 997                             scm_make_string (SCM_INUM0, SCM_UNDEFINED),
 998                             SCM_OPN | SCM_WRTNG,
 999                             FUNC_NAME);
1000       destination = port;
1001     }
1002   else
1003     {
1004       SCM_VALIDATE_OPORT_VALUE (1, destination);
1005       port = SCM_COERCE_OUTPORT (destination);
1006     }
1007   SCM_VALIDATE_STRING (2, message);
1008   SCM_VALIDATE_REST_ARGUMENT (args);
1009
1010   start = scm_i_string_chars (message);
1011   end = start + scm_i_string_length (message);
1012   for (p = start; p != end; ++p)
1013     if (*p == '~')
1014       {
1015         if (++p == end)
1016           break;
1017
1018         switch (*p)
1019           {
1020           case 'A': case 'a':
1021             writingp = 0;
1022             break;
1023           case 'S': case 's':
1024             writingp = 1;
1025             break;
1026           case '~':
1027             scm_lfwrite (start, p - start, port);
1028             start = p + 1;
1029             continue;
1030           case '%':
1031             scm_lfwrite (start, p - start - 1, port);
1032             scm_newline (port);
1033             start = p + 1;
1034             continue;
1035           default:
1036             SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead",
1037                             scm_list_1 (SCM_MAKE_CHAR (*p)));
1038
1039           }
1040
1041
1042         if (!scm_is_pair (args))
1043           SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A",
1044                           scm_list_1 (SCM_MAKE_CHAR (*p)));
1045
1046         scm_lfwrite (start, p - start - 1, port);
1047         /* we pass destination here */
1048         scm_prin1 (SCM_CAR (args), destination, writingp);
1049         args = SCM_CDR (args);
1050         start = p + 1;
1051       }
1052
1053   scm_lfwrite (start, p - start, port);
1054   if (!scm_is_eq (args, SCM_EOL))
1055     SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments",
1056                     scm_list_1 (scm_length (args)));
1057
1058   if (fReturnString)
1059     answer = scm_strport_to_string (destination);
1060
1061   return scm_return_first (answer, message);
1062 }
1063 #undef FUNC_NAME
1064
1065
1066 SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
1067             (SCM port),
1068             "Send a newline to @var{port}.\n"
1069             "If @var{port} is omitted, send to the current output port.")
1070 #define FUNC_NAME s_scm_newline
1071 {
1072   if (SCM_UNBNDP (port))
1073     port = scm_current_output_port ();
1074
1075   SCM_VALIDATE_OPORT_VALUE (1, port);
1076
1077   scm_putc ('\n', SCM_COERCE_OUTPORT (port));
1078   return SCM_UNSPECIFIED;
1079 }
1080 #undef FUNC_NAME
1081
1082 SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
1083             (SCM chr, SCM port),
1084             "Send character @var{chr} to @var{port}.")
1085 #define FUNC_NAME s_scm_write_char
1086 {
1087   if (SCM_UNBNDP (port))
1088     port = scm_current_output_port ();
1089
1090   SCM_VALIDATE_CHAR (1, chr);
1091   SCM_VALIDATE_OPORT_VALUE (2, port);
1092
1093   scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
1094 #if 0
1095 #ifdef HAVE_PIPE
1096 # ifdef EPIPE
1097   if (EPIPE == errno)
1098     scm_close_port (port);
1099 # endif
1100 #endif
1101 #endif
1102   return SCM_UNSPECIFIED;
1103 }
1104 #undef FUNC_NAME
1105
1106 \f
1107
1108 /* Call back to Scheme code to do the printing of special objects
1109  * (like structs).  SCM_PRINTER_APPLY applies PROC to EXP and a smob
1110  * containing PORT and PSTATE.  This object can be used as the port for
1111  * display/write etc to continue the current print chain.  The REVEALED
1112  * field of PSTATE is set to true to indicate that the print state has
1113  * escaped to Scheme and thus has to be freed by the GC.
1114  */
1115
1116 scm_t_bits scm_tc16_port_with_ps;
1117
1118 /* Print exactly as the port itself would */
1119
1120 static int
1121 port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
1122 {
1123   obj = SCM_PORT_WITH_PS_PORT (obj);
1124   return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
1125 }
1126
1127 SCM
1128 scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate)
1129 {
1130   pstate->revealed = 1;
1131   return scm_call_2 (proc, exp,
1132                      scm_i_port_with_print_state (port, pstate->handle));
1133 }
1134
1135 SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0,
1136             (SCM port, SCM pstate),
1137             "Create a new port which behaves like @var{port}, but with an\n"
1138             "included print state @var{pstate}.  @var{pstate} is optional.\n"
1139             "If @var{pstate} isn't supplied and @var{port} already has\n"
1140             "a print state, the old print state is reused.")
1141 #define FUNC_NAME s_scm_port_with_print_state
1142 {
1143   SCM_VALIDATE_OPORT_VALUE (1, port);
1144   if (!SCM_UNBNDP (pstate))
1145     SCM_VALIDATE_PRINTSTATE (2, pstate);
1146   return scm_i_port_with_print_state (port, pstate);
1147 }
1148 #undef FUNC_NAME
1149
1150 SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
1151             (SCM port),
1152             "Return the print state of the port @var{port}. If @var{port}\n"
1153             "has no associated print state, @code{#f} is returned.")
1154 #define FUNC_NAME s_scm_get_print_state
1155 {
1156   if (SCM_PORT_WITH_PS_P (port))
1157     return SCM_PORT_WITH_PS_PS (port);
1158   if (SCM_OUTPUT_PORT_P (port))
1159     return SCM_BOOL_F;
1160   SCM_WRONG_TYPE_ARG (1, port);
1161 }
1162 #undef FUNC_NAME
1163
1164 \f
1165
1166 void
1167 scm_init_print ()
1168 {
1169   SCM vtable, layout, type;
1170
1171   scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
1172
1173   scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"),
1174                                  scm_from_locale_string ("{"),
1175                                  scm_from_locale_symbol ("highlight-suffix"),
1176                                  scm_from_locale_string ("}")));
1177
1178   scm_gc_register_root (&print_state_pool);
1179   scm_gc_register_root (&scm_print_state_vtable);
1180   vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
1181   layout =
1182     scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
1183   type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
1184   scm_set_struct_vtable_name_x (type, scm_from_locale_symbol ("print-state"));
1185   scm_print_state_vtable = type;
1186
1187   /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */
1188   scm_tc16_port_with_ps = scm_make_smob_type (0, 0);
1189   scm_set_smob_mark (scm_tc16_port_with_ps, scm_markcdr);
1190   scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print);
1191
1192 #include "libguile/print.x"
1193
1194   scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
1195 }
1196
1197 /*
1198   Local Variables:
1199   c-file-style: "gnu"
1200   End:
1201 */