all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: Davis Herring <herring@lanl.gov>
To: sds@gnu.org
Cc: emacs-devel@gnu.org
Subject: Re: with-standard-io-syntax
Date: Wed, 22 Aug 2012 13:31:02 -0600	[thread overview]
Message-ID: <50353376.5070801@lanl.gov> (raw)
In-Reply-To: <87y5l6ixts.fsf@gnu.org>

> 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);



      reply	other threads:[~2012-08-22 19:31 UTC|newest]

Thread overview: 4+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2012-08-21 14:36 with-standard-io-syntax Sam Steingold
2012-08-22 17:48 ` with-standard-io-syntax Stefan Monnier
2012-08-22 18:30   ` with-standard-io-syntax Sam Steingold
2012-08-22 19:31     ` Davis Herring [this message]

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=50353376.5070801@lanl.gov \
    --to=herring@lanl.gov \
    --cc=emacs-devel@gnu.org \
    --cc=sds@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.