Re: with-standard-io-syntax

[Davis Herring]

> This is orthogonal (we can also introduce an all-encompassing
> print-readably, but the issue will remain).

I have a very old patch meant to provide support akin to
`print-readably' (which savehist.el tries to use, but Emacs doesn't
have).  It could obviously be extended to suppress print-length etc.
when it's set.

Davis

--- emacs-cvs/src/print.c.~2007-08-13~  2012-08-22 13:15:06.329475983 -0600
+++ emacs-cvs/src/.#print.c.1.237       2007-09-05 12:03:21.000000000 -0600
@@ -163,6 +163,12 @@
 int print_number_index;
 Lisp_Object Vprint_number_table;

+/* Function to call to print objects with no read syntax. */
+Lisp_Object Qprint_unreadable_function, Vprint_unreadable_function;
+/* We can't use do-while(0) here, so use a dangling else. */
+#define PRINT_UNREADABLE \
+  if (escapeflag && !NILP (Vprint_unreadable_function)) {unreadable =
1; break;} else
+
 /* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table
TABLE.
    PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE.
    See the comment of the variable Vprint_number_table.  */
@@ -1475,6 +1481,9 @@
      int escapeflag;
 {
   char buf[40];
+  /* If we're asked to make readable output, and we can't, and there's a
+     handler for that, set this. */
+  int unreadable = 0;

   QUIT;

@@ -1883,9 +1892,13 @@
        {
          if (escapeflag)
            {
-             strout ("#<process ", -1, -1, printcharfun, 0);
-             print_string (XPROCESS (obj)->name, printcharfun);
-             PRINTCHAR ('>');
+             if (NILP (Vprint_unreadable_function))
+               {
+                 strout ("#<process ", -1, -1, printcharfun, 0);
+                 print_string (XPROCESS (obj)->name, printcharfun);
+                 PRINTCHAR ('>');
+               }
+             else unreadable = 1;
            }
          else
            print_string (XPROCESS (obj)->name, printcharfun);
@@ -1949,12 +1962,14 @@
        }
       else if (SUBRP (obj))
        {
+         PRINT_UNREADABLE;
          strout ("#<subr ", -1, -1, printcharfun, 0);
          strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun, 0);
          PRINTCHAR ('>');
        }
       else if (WINDOWP (obj))
        {
+         PRINT_UNREADABLE;
          strout ("#<window ", -1, -1, printcharfun, 0);
          sprintf (buf, "%ld", (long) XFASTINT (XWINDOW 
(obj)->sequence_number));
          strout (buf, -1, -1, printcharfun, 0);
@@ -1967,6 +1982,7 @@
        }
       else if (HASH_TABLE_P (obj))
        {
+         PRINT_UNREADABLE;
          struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
          strout ("#<hash-table", -1, -1, printcharfun, 0);
          if (SYMBOLP (h->test))
@@ -1987,6 +2003,7 @@
        }
       else if (BUFFERP (obj))
        {
+         PRINT_UNREADABLE;
          if (NILP (XBUFFER (obj)->name))
            strout ("#<killed buffer>", -1, -1, printcharfun, 0);
          else if (escapeflag)
@@ -2000,10 +2017,12 @@
        }
       else if (WINDOW_CONFIGURATIONP (obj))
        {
+         PRINT_UNREADABLE;
          strout ("#<window-configuration>", -1, -1, printcharfun, 0);
        }
       else if (FRAMEP (obj))
        {
+         PRINT_UNREADABLE;
          strout ((FRAME_LIVE_P (XFRAME (obj))
                   ? "#<frame " : "#<dead frame "),
                  -1, -1, printcharfun, 0);
@@ -2062,6 +2081,7 @@
       switch (XMISCTYPE (obj))
        {
        case Lisp_Misc_Marker:
+         PRINT_UNREADABLE;
          strout ("#<marker ", -1, -1, printcharfun, 0);
          /* Do you think this is necessary?  */
          if (XMARKER (obj)->insertion_type != 0)
@@ -2079,6 +2099,7 @@
          break;

        case Lisp_Misc_Overlay:
+         PRINT_UNREADABLE;
          strout ("#<overlay ", -1, -1, printcharfun, 0);
          if (! XMARKER (OVERLAY_START (obj))->buffer)
            strout ("in no buffer", -1, -1, printcharfun, 0);
@@ -2097,27 +2118,32 @@
       /* Remaining cases shouldn't happen in normal usage, but let's print
         them anyway for the benefit of the debugger.  */
        case Lisp_Misc_Free:
+         PRINT_UNREADABLE;
          strout ("#<misc free cell>", -1, -1, printcharfun, 0);
          break;

        case Lisp_Misc_Intfwd:
+         PRINT_UNREADABLE;
          sprintf (buf, "#<intfwd to %ld>", (long) *XINTFWD (obj)->intvar);
          strout (buf, -1, -1, printcharfun, 0);
          break;

        case Lisp_Misc_Boolfwd:
+         PRINT_UNREADABLE;
          sprintf (buf, "#<boolfwd to %s>",
                   (*XBOOLFWD (obj)->boolvar ? "t" : "nil"));
          strout (buf, -1, -1, printcharfun, 0);
          break;

        case Lisp_Misc_Objfwd:
+         PRINT_UNREADABLE;
          strout ("#<objfwd to ", -1, -1, printcharfun, 0);
          print_object (*XOBJFWD (obj)->objvar, printcharfun, escapeflag);
          PRINTCHAR ('>');
          break;

        case Lisp_Misc_Buffer_Objfwd:
+         PRINT_UNREADABLE;
          strout ("#<buffer_objfwd to ", -1, -1, printcharfun, 0);
          print_object (PER_BUFFER_VALUE (current_buffer,
                                          XBUFFER_OBJFWD (obj)->offset),
@@ -2126,6 +2152,7 @@
          break;

        case Lisp_Misc_Kboard_Objfwd:
+         PRINT_UNREADABLE;
          strout ("#<kboard_objfwd to ", -1, -1, printcharfun, 0);
          print_object (*(Lisp_Object *) ((char *) current_kboard
                                          + XKBOARD_OBJFWD (obj)->offset),
@@ -2134,9 +2161,11 @@
          break;

        case Lisp_Misc_Buffer_Local_Value:
+         PRINT_UNREADABLE;
          strout ("#<buffer_local_value ", -1, -1, printcharfun, 0);
          goto do_buffer_local;
        case Lisp_Misc_Some_Buffer_Local_Value:
+         PRINT_UNREADABLE;
          strout ("#<some_buffer_local_value ", -1, -1, printcharfun, 0);
        do_buffer_local:
          strout ("[realvalue] ", -1, -1, printcharfun, 0);
@@ -2167,6 +2196,7 @@
          break;

        case Lisp_Misc_Save_Value:
+         PRINT_UNREADABLE;
          strout ("#<save_value ", -1, -1, printcharfun, 0);
          sprintf(buf, "ptr=0x%08lx int=%d",
                  (unsigned long) XSAVE_VALUE (obj)->pointer,
@@ -2198,6 +2228,20 @@
       }
     }

+  if (unreadable)
+    {
+      /* Suppress print-unreadable-function.  If we have a real handler, it
+        has no need to call itself; if we're signaling, a debugger may need
+        to print what's not printable with the signal enabled!  */
+      int count = SPECPDL_INDEX ();
+      Lisp_Object handler = Vprint_unreadable_function;
+      specbind (Qprint_unreadable_function, Qnil);
+      if (EQ (handler, Qt))
+       xsignal1 (Qinvalid_read_syntax, obj);
+      call2 (handler, obj, printcharfun);
+      unbind_to (count, Qnil);
+    }
+
   print_depth--;
 }
 
@@ -2332,6 +2376,15 @@
 that need to be recorded in the table.  */);
   Vprint_number_table = Qnil;

+  DEFVAR_LISP ("print-unreadable-function", &Vprint_unreadable_function,
+              doc: /* A function to call to print objects having no read 
syntax.
+It is called with two arguments: the object to print and the output stream.
+If t, an error is signaled to prevent producing unreadable output.
+If nil, hash notation is used.  */);
+  Vprint_unreadable_function = Qnil;
+  Qprint_unreadable_function = intern ("print-unreadable-function");
+  staticpro (&Qprint_unreadable_function);
+
   /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
   staticpro (&Vprin1_to_string_buffer);