Merge branch 'stable-2.0'

[bpt/guile.git] / libguile / print.c

diff --git a/libguile/print.c b/libguile/print.c
index dbc6e96..4ad2a95 100644 (file)
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
- *   2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *   2009, 2010, 2011, 2012, 2013, 2014 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
@@ -113,6 +113,8 @@ scm_t_option scm_print_opts[] = {
     "'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'." },
+  { SCM_OPTION_BOOLEAN, "r7rs-symbols", 0,
+    "Escape symbols using R7RS |...| symbol notation." },
   { 0 },
 };
 
@@ -359,6 +361,13 @@ symbol_has_extended_read_syntax (SCM sym)
     case '#':
       /* Some initial-character constraints.  */
       return 1;
+
+    case '|':
+    case '\\':
+      /* R7RS allows neither '|' nor '\' in bare symbols.  */
+      if (SCM_PRINT_R7RS_SYMBOLS_P)
+        return 1;
+      break;
   
     case ':':
       /* Symbols that look like keywords.  */
@@ -409,6 +418,9 @@ symbol_has_extended_read_syntax (SCM sym)
         return 1;
       else if (c == '"' || c == ';' || c == '#')
         return 1;
+      else if ((c == '|' || c == '\\') && SCM_PRINT_R7RS_SYMBOLS_P)
+        /* R7RS allows neither '|' nor '\' in bare symbols.  */
+        return 1;
     }
 
   return 0;
@@ -456,23 +468,76 @@ print_extended_symbol (SCM sym, SCM port)
         }
       else
         {
-          display_string ("\\x", 1, 2, port, iconveh_question_mark);
+          scm_lfwrite_unlocked ("\\x", 2, port);
           scm_intprint (c, 16, port);
-          display_character (';', port, iconveh_question_mark);
+          scm_putc_unlocked (';', port);
         }
     }
 
   scm_lfwrite_unlocked ("}#", 2, port);
 }
 
-/* FIXME: allow R6RS hex escapes instead of #{...}#.  */
+static void
+print_r7rs_extended_symbol (SCM sym, SCM port)
+{
+  size_t pos, len;
+  scm_t_string_failed_conversion_handler strategy;
+
+  len = scm_i_symbol_length (sym);
+  strategy = PORT_CONVERSION_HANDLER (port);
+
+  scm_putc_unlocked ('|', port);
+
+  for (pos = 0; pos < len; pos++)
+    {
+      scm_t_wchar c = scm_i_symbol_ref (sym, pos);
+
+      switch (c)
+        {
+        case '\a': scm_lfwrite_unlocked ("\\a", 2, port); break;
+        case '\b': scm_lfwrite_unlocked ("\\b", 2, port); break;
+        case '\t': scm_lfwrite_unlocked ("\\t", 2, port); break;
+        case '\n': scm_lfwrite_unlocked ("\\n", 2, port); break;
+        case '\r': scm_lfwrite_unlocked ("\\r", 2, port); break;
+        case '|':  scm_lfwrite_unlocked ("\\|", 2, port); break;
+        case '\\': scm_lfwrite_unlocked ("\\x5c;", 5, port); break;
+        default:
+          if (uc_is_general_category_withtable (c,
+                                                UC_CATEGORY_MASK_L
+                                                | UC_CATEGORY_MASK_M
+                                                | UC_CATEGORY_MASK_N
+                                                | UC_CATEGORY_MASK_P
+                                                | UC_CATEGORY_MASK_S)
+              || (c == ' '))
+            {
+              if (!display_character (c, port, strategy))
+                scm_encoding_error ("print_r7rs_extended_symbol", errno,
+                                    "cannot convert to output locale",
+                                    port, SCM_MAKE_CHAR (c));
+            }
+          else
+            {
+              scm_lfwrite_unlocked ("\\x", 2, port);
+              scm_intprint (c, 16, port);
+              scm_putc_unlocked (';', port);
+            }
+          break;
+        }
+    }
+
+  scm_putc_unlocked ('|', port);
+}
+
+/* FIXME: allow R6RS hex escapes instead of #{...}# or |...|.  */
 static void
 print_symbol (SCM sym, SCM port)
 {
-  if (symbol_has_extended_read_syntax (sym))
-    print_extended_symbol (sym, port);
-  else
+  if (!symbol_has_extended_read_syntax (sym))
     print_normal_symbol (sym, port);
+  else if (SCM_PRINT_R7RS_SYMBOLS_P)
+    print_r7rs_extended_symbol (sym, port);
+  else
+    print_extended_symbol (sym, port);
 }
 
 void
@@ -609,6 +674,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
             break;
           }
          break;
+        case scm_tc7_stringbuf:
+          scm_i_print_stringbuf (exp, port, pstate);
+          break;
         case scm_tc7_string:
           if (SCM_WRITINGP (pstate))
             {
@@ -657,7 +725,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
        case scm_tc7_variable:
          scm_i_variable_print (exp, port, pstate);
          break;
-       case scm_tc7_rtl_program:
        case scm_tc7_program:
          scm_i_program_print (exp, port, pstate);
          break;
@@ -682,12 +749,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
        case scm_tc7_frame:
          scm_i_frame_print (exp, port, pstate);
          break;
-       case scm_tc7_objcode:
-         scm_i_objcode_print (exp, port, pstate);
-         break;
-       case scm_tc7_vm:
-         scm_i_vm_print (exp, port, pstate);
-         break;
        case scm_tc7_vm_cont:
          scm_i_vm_cont_print (exp, port, pstate);
          break;