Re: with-standard-io-syntax

[Davis Herring <herring@lanl.gov>]

> 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--;
 }
 \f
@@ -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);