Merge remote-tracking branch 'origin/stable-2.0'
[bpt/guile.git] / libguile / print.c
index 8846cd3..6524091 100644 (file)
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
- *   2009, 2010, 2011 Free Software Foundation, Inc.
+ *   2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -44,6 +44,7 @@
 #include "libguile/alist.h"
 #include "libguile/struct.h"
 #include "libguile/ports.h"
+#include "libguile/ports-internal.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
 #include "libguile/strports.h"
@@ -60,6 +61,9 @@
 
 /* Character printers.  */
 
+#define PORT_CONVERSION_HANDLER(port)          \
+  SCM_PTAB_ENTRY (port)->ilseq_handler
+
 static size_t display_string (const void *, int, size_t, SCM,
                              scm_t_string_failed_conversion_handler);
 
@@ -106,8 +110,9 @@ scm_t_option scm_print_opts[] = {
   { SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F_BITS,
     "How to print symbols that have a colon as their first or last character. "
     "The value '#f' does not quote the colons; '#t' quotes them; "
-    "'reader' quotes them when the reader option 'keywords' is not '#f'." 
-  },
+    "'reader' quotes them when the reader option 'keywords' is not '#f'." },
+  { SCM_OPTION_BOOLEAN, "escape-newlines", 1,
+    "Render newlines as \\n when printing using `write'." },
   { 0 },
 };
 
@@ -156,7 +161,7 @@ do                                                          \
     {                                                          \
       if (pstate->top - pstate->list_offset >= pstate->level)  \
        {                                                       \
-         scm_putc ('#', port);                                 \
+         scm_putc_unlocked ('#', port);                                        \
          return;                                               \
        }                                                       \
     }                                                          \
@@ -300,9 +305,9 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref)
   for (i = pstate->top - 1; 1; --i)
     if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
       break;
-  scm_putc ('#', port);
+  scm_putc_unlocked ('#', port);
   scm_intprint (i - self, 10, port);
-  scm_putc ('#', port);
+  scm_putc_unlocked ('#', port);
 }
 
 /* Print the name of a symbol. */
@@ -331,6 +336,7 @@ quote_keywordish_symbols (void)
   (INITIAL_IDENTIFIER_MASK                                              \
    | UC_CATEGORY_MASK_Nd | UC_CATEGORY_MASK_Mc | UC_CATEGORY_MASK_Me)
 
+/* FIXME: Cache this information on the symbol, somehow.  */
 static int
 symbol_has_extended_read_syntax (SCM sym)
 {
@@ -343,26 +349,56 @@ symbol_has_extended_read_syntax (SCM sym)
 
   c = scm_i_symbol_ref (sym, 0);
 
-  /* Single dot; conflicts with dotted-pair notation.  */
-  if (len == 1 && c == '.')
-    return 1;
-
-  /* Other initial-character constraints.  */
-  if (c == '\'' || c == '`' || c == ',' || c == '"' || c == ';' || c == '#')
-    return 1;
+  switch (c) 
+    {
+    case '\'':
+    case '`':
+    case ',':
+    case '"':
+    case ';':
+    case '#':
+      /* Some initial-character constraints.  */
+      return 1;
   
-  /* Keywords can be identified by trailing colons too.  */
-  if (c == ':' || scm_i_symbol_ref (sym, len - 1) == ':')
-    return quote_keywordish_symbols ();
+    case ':':
+      /* Symbols that look like keywords.  */
+      return quote_keywordish_symbols ();
   
-  /* Number-ish symbols.  */
-  if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10)))
-    return 1;
+    case '.':
+      /* Single dot conflicts with dotted-pair notation.  */
+      if (len == 1)
+        return 1;
+      /* Fall through to check numbers.  */
+    case '+':
+    case '-':
+    case '0':
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6': 
+    case '7':
+    case '8':
+    case '9':
+     /* Number-ish symbols.  Numbers with radixes already caught be #
+        above.  */
+      if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10)))
+        return 1;
+      break;
+
+    default:
+      break;
+    }
   
   /* Other disallowed first characters.  */
   if (!uc_is_general_category_withtable (c, INITIAL_IDENTIFIER_MASK))
     return 1;
 
+  /* Keywords can be identified by trailing colons too.  */
+  if (scm_i_symbol_ref (sym, len - 1) == ':')
+    return quote_keywordish_symbols ();
+
   /* Otherwise, any character that's in the identifier category mask is
      fine to pass through as-is, provided it's not one of the ASCII
      delimiters like `;'.  */
@@ -381,7 +417,16 @@ symbol_has_extended_read_syntax (SCM sym)
 static void
 print_normal_symbol (SCM sym, SCM port)
 {
-  scm_display (scm_symbol_to_string (sym), port);
+  size_t len;
+  scm_t_string_failed_conversion_handler strategy;
+
+  len = scm_i_symbol_length (sym);
+  strategy = SCM_PTAB_ENTRY (port)->ilseq_handler;
+
+  if (scm_i_is_narrow_symbol (sym))
+    display_string (scm_i_symbol_chars (sym), 1, len, port, strategy);
+  else
+    display_string (scm_i_symbol_wide_chars (sym), 0, len, port, strategy);
 }
 
 static void
@@ -391,9 +436,9 @@ print_extended_symbol (SCM sym, SCM port)
   scm_t_string_failed_conversion_handler strategy;
 
   len = scm_i_symbol_length (sym);
-  strategy = scm_i_get_conversion_strategy (port);
+  strategy = PORT_CONVERSION_HANDLER (port);
 
-  scm_lfwrite ("#{", 2, port);
+  scm_lfwrite_unlocked ("#{", 2, port);
 
   for (pos = 0; pos < len; pos++)
     {
@@ -416,12 +461,12 @@ print_extended_symbol (SCM sym, SCM port)
         }
     }
 
-  scm_lfwrite ("}#", 2, port);
+  scm_lfwrite_unlocked ("}#", 2, port);
 }
 
 /* FIXME: allow R6RS hex escapes instead of #{...}#.  */
-void
-scm_i_print_symbol_name (SCM sym, SCM port)
+static void
+print_symbol (SCM sym, SCM port)
 {
   if (symbol_has_extended_read_syntax (sym))
     print_extended_symbol (sym, port);
@@ -433,7 +478,7 @@ void
 scm_print_symbol_name (const char *str, size_t len, SCM port)
 {
   SCM symbol = scm_from_utf8_symboln (str, len);
-  scm_i_print_symbol_name (symbol, port);
+  print_symbol (symbol, port);
 }
 
 /* Print generally.  Handles both write and display according to PSTATE.
@@ -452,7 +497,7 @@ static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);
         scm_intprint (i, 8, port);              \
       else                                      \
         {                                       \
-          scm_puts ("x", port);                 \
+          scm_puts_unlocked ("x", port);                 \
           scm_intprint (i, 16, port);           \
         }                                       \
     }                                           \
@@ -498,7 +543,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
          else
            {
              if (!display_character (SCM_CHAR (exp), port,
-                                     scm_i_get_conversion_strategy (port)))
+                                     PORT_CONVERSION_HANDLER (port)))
                scm_encoding_error (__func__, errno,
                                    "cannot convert to output locale",
                                    port, exp);
@@ -507,7 +552,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
       else if (SCM_IFLAGP (exp)
               && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
         {
-          scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
+          scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port);
         }
       else
        {
@@ -584,7 +629,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
              printed = display_string (scm_i_string_data (exp),
                                        scm_i_is_narrow_string (exp),
                                        len, port,
-                                       scm_i_get_conversion_strategy (port));
+                                       PORT_CONVERSION_HANDLER (port));
              if (SCM_UNLIKELY (printed < len))
                scm_encoding_error (__func__, errno,
                                    "cannot convert to output locale",
@@ -596,16 +641,16 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
        case scm_tc7_symbol:
          if (scm_i_symbol_is_interned (exp))
            {
-             scm_i_print_symbol_name (exp, port);
+             print_symbol (exp, port);
              scm_remember_upto_here_1 (exp);
            }
          else
            {
-             scm_puts ("#<uninterned-symbol ", port);
-             scm_i_print_symbol_name (exp, port);
-             scm_putc (' ', port);
+             scm_puts_unlocked ("#<uninterned-symbol ", port);
+             print_symbol (exp, port);
+             scm_putc_unlocked (' ', port);
              scm_uintprint (SCM_UNPACK (exp), 16, port);
-             scm_putc ('>', port);
+             scm_putc_unlocked ('>', port);
            }
          break;
        case scm_tc7_variable:
@@ -644,23 +689,24 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
        case scm_tc7_vm_cont:
          scm_i_vm_cont_print (exp, port, pstate);
          break;
-       case scm_tc7_prompt:
-         scm_i_prompt_print (exp, port, pstate);
+       case scm_tc7_array:
+         ENTER_NESTED_DATA (pstate, exp, circref);
+          scm_i_print_array (exp, port, pstate);
+          EXIT_NESTED_DATA (pstate);
+          break;
+       case scm_tc7_bytevector:
+         scm_i_print_bytevector (exp, port, pstate);
          break;
-       case scm_tc7_with_fluids:
-         scm_i_with_fluids_print (exp, port, pstate);
+       case scm_tc7_bitvector:
+         scm_i_print_bitvector (exp, port, pstate);
          break;
        case scm_tc7_wvect:
          ENTER_NESTED_DATA (pstate, exp, circref);
-          scm_puts ("#w(", port);
+          scm_puts_unlocked ("#w(", port);
          goto common_vector_printer;
-
-       case scm_tc7_bytevector:
-         scm_i_print_bytevector (exp, port, pstate);
-         break;
        case scm_tc7_vector:
          ENTER_NESTED_DATA (pstate, exp, circref);
-         scm_puts ("#(", port);
+         scm_puts_unlocked ("#(", port);
        common_vector_printer:
          {
            register long i;
@@ -675,7 +721,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
             for (i = 0; i < last; ++i)
               {
                 scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
-                scm_putc (' ', port);
+                scm_putc_unlocked (' ', port);
               }
            if (i == last)
              {
@@ -683,17 +729,15 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
                scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
              }
            if (cutp)
-             scm_puts (" ...", port);
-           scm_putc (')', port);
+             scm_puts_unlocked (" ...", port);
+           scm_putc_unlocked (')', port);
          }
          EXIT_NESTED_DATA (pstate);
          break;
        case scm_tc7_port:
          {
-           register long i = SCM_PTOBNUM (exp);
-           if (i < scm_numptob
-               && scm_ptobs[i].print
-               && (scm_ptobs[i].print) (exp, port, pstate))
+           scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (exp);
+           if (ptob->print && ptob->print (exp, port, pstate))
              break;
            goto punk;
          }
@@ -838,7 +882,7 @@ display_string_as_utf8 (const void *str, int narrow_p, size_t len,
 
       /* INPUT was successfully converted, entirely; print the
         result.  */
-      scm_lfwrite (utf8_buf, utf8_len, port);
+      scm_lfwrite_unlocked (utf8_buf, utf8_len, port);
       printed += i - printed;
     }
 
@@ -847,6 +891,54 @@ display_string_as_utf8 (const void *str, int narrow_p, size_t len,
   return len;
 }
 
+/* Write STR to PORT as ISO-8859-1.  STR is a LEN-codepoint string; it
+   is narrow if NARROW_P is true, wide otherwise.  Return LEN.  */
+static size_t
+display_string_as_latin1 (const void *str, int narrow_p, size_t len,
+                          SCM port,
+                          scm_t_string_failed_conversion_handler strategy)
+{
+  size_t printed = 0;
+
+  if (narrow_p)
+    {
+      scm_lfwrite_unlocked (str, len, port);
+      return len;
+    }
+
+  while (printed < len)
+    {
+      char buf[256];
+      size_t i;
+
+      for (i = 0; i < sizeof(buf) && printed < len; i++, printed++)
+        {
+          scm_t_wchar c = STR_REF (str, printed);
+
+          if (c < 256)
+            buf[i] = c;
+          else
+            break;
+        }
+
+      scm_lfwrite_unlocked (buf, i, port);
+
+      if (i < sizeof(buf) && printed < len)
+        {
+          if (strategy == SCM_FAILED_CONVERSION_ERROR)
+            break;
+          else if (strategy == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+            write_character_escaped (STR_REF (str, printed), 1, port);
+          else
+            /* STRATEGY is `SCM_FAILED_CONVERSION_QUESTION_MARK'.  */
+            display_string ("?", 1, 1, port, strategy);
+          printed++;
+        }
+    }
+
+  return printed;
+}
+
 /* Convert STR through PORT's output conversion descriptor and write the
    output to PORT.  Return the number of codepoints written.  */
 static size_t
@@ -855,9 +947,25 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len,
                            scm_t_string_failed_conversion_handler strategy)
 {
   size_t printed;
-  scm_t_port *pt;
+  scm_t_iconv_descriptors *id;
+  scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
 
-  pt = SCM_PTAB_ENTRY (port);
+  id = scm_i_port_iconv_descriptors (port, SCM_PORT_WRITE);
+
+  if (SCM_UNLIKELY (pti->at_stream_start_for_bom_write && len > 0))
+    {
+      scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+      /* Record that we're no longer at stream start.  */
+      pti->at_stream_start_for_bom_write = 0;
+      if (pt->rw_random)
+        pti->at_stream_start_for_bom_read = 0;
+
+      /* Write a BOM if appropriate.  */
+      if (SCM_UNLIKELY (strcmp(pt->encoding, "UTF-16") == 0
+                        || strcmp(pt->encoding, "UTF-32") == 0))
+        display_character (SCM_UNICODE_BOM, port, iconveh_error);
+    }
 
   printed = 0;
 
@@ -886,7 +994,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len,
       output = encoded_output;
       output_left = sizeof (encoded_output);
 
-      done = iconv (pt->output_cd, &input, &input_left,
+      done = iconv (id->output_cd, &input, &input_left,
                    &output, &output_left);
 
       output_len = sizeof (encoded_output) - output_left;
@@ -896,10 +1004,10 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len,
           int errno_save = errno;
 
          /* Reset the `iconv' state.  */
-         iconv (pt->output_cd, NULL, NULL, NULL, NULL);
+         iconv (id->output_cd, NULL, NULL, NULL, NULL);
 
          /* Print the OUTPUT_LEN bytes successfully converted.  */
-         scm_lfwrite (encoded_output, output_len, port);
+         scm_lfwrite_unlocked (encoded_output, output_len, port);
 
          /* See how many input codepoints these OUTPUT_LEN bytes
             corresponds to.  */
@@ -934,7 +1042,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len,
        {
          /* INPUT was successfully converted, entirely; print the
             result.  */
-         scm_lfwrite (encoded_output, output_len, port);
+         scm_lfwrite_unlocked (encoded_output, output_len, port);
          codepoints_read = i - printed;
          printed += codepoints_read;
        }
@@ -954,22 +1062,17 @@ static size_t
 display_string (const void *str, int narrow_p,
                size_t len, SCM port,
                scm_t_string_failed_conversion_handler strategy)
-
 {
-  scm_t_port *pt;
-
-  pt = SCM_PTAB_ENTRY (port);
+  scm_t_port_internal *pti;
 
-  if (pt->output_cd == (iconv_t) -1)
-    /* Initialize the conversion descriptors, if needed.  */
-    scm_i_set_port_encoding_x (port, pt->encoding);
+  pti = SCM_PORT_GET_INTERNAL (port);
 
-  /* FIXME: In 2.1, add a flag to determine whether a port is UTF-8.  */
-  if (pt->output_cd == (iconv_t) -1)
+  if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
     return display_string_as_utf8 (str, narrow_p, len, port);
+  else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+    return display_string_as_latin1 (str, narrow_p, len, port, strategy);
   else
-    return display_string_using_iconv (str, narrow_p, len,
-                                      port, strategy);
+    return display_string_using_iconv (str, narrow_p, len, port, strategy);
 }
 
 /* Attempt to display CH to PORT according to STRATEGY.  Return non-zero
@@ -1014,7 +1117,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port)
          /* Use special escapes for some C0 controls.  */
          buf[0] = '\\';
          buf[1] = escapes[ch - 0x07];
-         scm_lfwrite (buf, 2, port);
+         scm_lfwrite_unlocked (buf, 2, port);
        }
       else if (!SCM_R6RS_ESCAPES_P)
        {
@@ -1024,7 +1127,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port)
              buf[1] = 'x';
              buf[2] = hex[ch / 16];
              buf[3] = hex[ch % 16];
-             scm_lfwrite (buf, 4, port);
+             scm_lfwrite_unlocked (buf, 4, port);
            }
          else if (ch <= 0xFFFF)
            {
@@ -1034,7 +1137,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port)
              buf[3] = hex[(ch & 0xF00) >> 8];
              buf[4] = hex[(ch & 0xF0) >> 4];
              buf[5] = hex[(ch & 0xF)];
-             scm_lfwrite (buf, 6, port);
+             scm_lfwrite_unlocked (buf, 6, port);
            }
          else if (ch > 0xFFFF)
            {
@@ -1046,7 +1149,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port)
              buf[5] = hex[(ch & 0xF00) >> 8];
              buf[6] = hex[(ch & 0xF0) >> 4];
              buf[7] = hex[(ch & 0xF)];
-             scm_lfwrite (buf, 8, port);
+             scm_lfwrite_unlocked (buf, 8, port);
            }
        }
       else
@@ -1069,7 +1172,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port)
          buf[i] = 'x';
          i --;
          buf[i] = '\\';
-         scm_lfwrite (buf + i, 9 - i, port);
+         scm_lfwrite_unlocked (buf + i, 9 - i, port);
        }
     }
   else
@@ -1079,7 +1182,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port)
 
       name = scm_i_charname (SCM_MAKE_CHAR (ch));
       if (name != NULL)
-       scm_puts (name, port);
+       scm_puts_unlocked (name, port);
       else
        PRINT_CHAR_ESCAPE (ch, port);
     }
@@ -1095,7 +1198,7 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
   int printed = 0;
   scm_t_string_failed_conversion_handler strategy;
 
-  strategy = scm_i_get_conversion_strategy (port);
+  strategy = PORT_CONVERSION_HANDLER (port);
 
   if (string_escapes_p)
     {
@@ -1106,6 +1209,12 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
          display_character (ch, port, strategy);
          printed = 1;
        }
+      else if (ch == '\n' && SCM_PRINT_ESCAPE_NEWLINES_P)
+        {
+         display_character ('\\', port, iconveh_question_mark);
+         display_character ('n', port, strategy);
+         printed = 1;
+        }
       else if (ch == ' ' || ch == '\n')
        {
          display_character (ch, port, strategy);
@@ -1137,6 +1246,29 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
     write_character_escaped (ch, string_escapes_p, port);
 }
 
+/* Display STR to PORT from START inclusive to END exclusive.  */
+void
+scm_i_display_substring (SCM str, size_t start, size_t end, SCM port)
+{
+  int narrow_p;
+  const char *buf;
+  size_t len, printed;
+
+  buf = scm_i_string_data (str);
+  len = end - start;
+  narrow_p = scm_i_is_narrow_string (str);
+  buf += start * (narrow_p ? sizeof (char) : sizeof (scm_t_wchar));
+
+  printed = display_string (buf, narrow_p, end - start, port,
+                           PORT_CONVERSION_HANDLER (port));
+
+  if (SCM_UNLIKELY (printed < len))
+    scm_encoding_error (__func__, errno,
+                       "cannot convert to output locale",
+                       port, scm_c_string_ref (str, printed + start));
+}
+
+\f
 /* Print an integer.
  */
 
@@ -1144,14 +1276,14 @@ void
 scm_intprint (scm_t_intmax n, int radix, SCM port)
 {
   char num_buf[SCM_INTBUFLEN];
-  scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
+  scm_lfwrite_unlocked (num_buf, scm_iint2str (n, radix, num_buf), port);
 }
 
 void 
 scm_uintprint (scm_t_uintmax n, int radix, SCM port)
 {
   char num_buf[SCM_INTBUFLEN];
-  scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
+  scm_lfwrite_unlocked (num_buf, scm_iuint2str (n, radix, num_buf), port);
 }
 
 /* Print an object of unrecognized type.
@@ -1160,19 +1292,19 @@ scm_uintprint (scm_t_uintmax n, int radix, SCM port)
 void 
 scm_ipruk (char *hdr, SCM ptr, SCM port)
 {
-  scm_puts ("#<unknown-", port);
-  scm_puts (hdr, port);
+  scm_puts_unlocked ("#<unknown-", port);
+  scm_puts_unlocked (hdr, port);
   if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
     {
-      scm_puts (" (0x", port);
+      scm_puts_unlocked (" (0x", port);
       scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
-      scm_puts (" . 0x", port);
+      scm_puts_unlocked (" . 0x", port);
       scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
-      scm_puts (") @", port);
+      scm_puts_unlocked (") @", port);
     }
-  scm_puts (" 0x", port);
+  scm_puts_unlocked (" 0x", port);
   scm_uintprint (SCM_UNPACK (ptr), 16, port);
-  scm_putc ('>', port);
+  scm_putc_unlocked ('>', port);
 }
 
 
@@ -1183,7 +1315,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate)
 {
   register SCM hare, tortoise;
   long floor = pstate->top - 2;
-  scm_puts (hdr, port);
+  scm_puts_unlocked (hdr, port);
   /* CHECK_INTS; */
   if (pstate->fancyp)
     goto fancy_printing;
@@ -1213,18 +1345,18 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate)
        if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
          goto circref;
       PUSH_REF (pstate, exp);
-      scm_putc (' ', port);
+      scm_putc_unlocked (' ', port);
       /* CHECK_INTS; */
       scm_iprin1 (SCM_CAR (exp), port, pstate);
     }
   if (!SCM_NULL_OR_NIL_P (exp))
     {
-      scm_puts (" . ", port);
+      scm_puts_unlocked (" . ", port);
       scm_iprin1 (exp, port, pstate);
     }
 
 end:
-  scm_putc (tlr, port);
+  scm_putc_unlocked (tlr, port);
   pstate->top = floor + 2;
   return;
   
@@ -1245,7 +1377,7 @@ fancy_printing:
          {
            if (n == 0)
              {
-               scm_puts (" ...", port);
+               scm_puts_unlocked (" ...", port);
                goto skip_tail;
              }
            else
@@ -1253,14 +1385,14 @@ fancy_printing:
          }
        PUSH_REF(pstate, exp);
        ++pstate->list_offset;
-       scm_putc (' ', port);
+       scm_putc_unlocked (' ', port);
        /* CHECK_INTS; */
        scm_iprin1 (SCM_CAR (exp), port, pstate);
       }
   }
   if (!SCM_NULL_OR_NIL_P (exp))
     {
-      scm_puts (" . ", port);
+      scm_puts_unlocked (" . ", port);
       scm_iprin1 (exp, port, pstate);
     }
 skip_tail:
@@ -1271,7 +1403,7 @@ fancy_circref:
   pstate->list_offset -= pstate->top - floor - 2;
   
 circref:
-  scm_puts (" . ", port);
+  scm_puts_unlocked (" . ", port);
   print_circref (port, pstate, exp);
   goto end;
 }
@@ -1296,7 +1428,11 @@ scm_write (SCM obj, SCM port)
 
   SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
 
+  scm_dynwind_begin (0);
+  scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
   scm_prin1 (obj, port, 1);
+  scm_dynwind_end ();
+
   return SCM_UNSPECIFIED;
 }
 
@@ -1311,7 +1447,11 @@ scm_display (SCM obj, SCM port)
 
   SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
 
+  scm_dynwind_begin (0);
+  scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
   scm_prin1 (obj, port, 0);
+  scm_dynwind_end ();
+
   return SCM_UNSPECIFIED;
 }
 
@@ -1323,7 +1463,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
            "@var{message} can contain @code{~A} (was @code{%s}) and\n"
            "@code{~S} (was @code{%S}) escapes.  When printed,\n"
            "the escapes are replaced with corresponding members of\n"
-           "@var{ARGS}:\n"
+           "@var{args}:\n"
            "@code{~A} formats using @code{display} and @code{~S} formats\n"
            "using @code{write}.\n"
            "If @var{destination} is @code{#t}, then use the current output\n"
@@ -1424,7 +1564,7 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
 
   SCM_VALIDATE_OPORT_VALUE (1, port);
 
-  scm_putc ('\n', SCM_COERCE_OUTPORT (port));
+  scm_putc_unlocked ('\n', SCM_COERCE_OUTPORT (port));
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -1442,7 +1582,7 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
 
   port = SCM_COERCE_OUTPORT (port);
   if (!display_character (SCM_CHAR (chr), port,
-                         scm_i_get_conversion_strategy (port)))
+                         PORT_CONVERSION_HANDLER (port)))
     scm_encoding_error (__func__, errno,
                        "cannot convert to output locale",
                        port, chr);
@@ -1469,7 +1609,7 @@ static int
 port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
 {
   obj = SCM_PORT_WITH_PS_PORT (obj);
-  return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
+  return SCM_PORT_DESCRIPTOR (obj)->print (obj, port, pstate);
 }
 
 SCM
@@ -1514,21 +1654,10 @@ SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
 void
 scm_init_print ()
 {
-  SCM vtable, layout, type;
+  SCM type;
 
-  scm_init_opts (scm_print_options, scm_print_opts);
-
-  scm_print_options (scm_list_4 (scm_from_latin1_symbol ("highlight-prefix"),
-                                scm_from_locale_string ("{"),
-                                scm_from_latin1_symbol ("highlight-suffix"),
-                                scm_from_locale_string ("}")));
-
-  scm_gc_register_root (&print_state_pool);
-  scm_gc_register_root (&scm_print_state_vtable);
-  vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
-  layout =
-    scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
-  type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
+  type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
+                          SCM_BOOL_F);
   scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
   scm_print_state_vtable = type;
 
@@ -1538,6 +1667,11 @@ scm_init_print ()
 
 #include "libguile/print.x"
 
+  scm_init_opts (scm_print_options, scm_print_opts);
+  scm_print_opts[SCM_PRINT_HIGHLIGHT_PREFIX_I].val =
+    SCM_UNPACK (scm_from_locale_string ("{"));
+  scm_print_opts[SCM_PRINT_HIGHLIGHT_SUFFIX_I].val =
+    SCM_UNPACK (scm_from_locale_string ("}"));
   scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
 }