Index: print.c
===================================================================
RCS file: /sources/emacs/emacs/src/print.c,v
retrieving revision 1.237
diff -c -r1.237 print.c
*** print.c	29 Aug 2007 05:27:56 -0000	1.237
--- print.c	5 Sep 2007 18:03:24 -0000
***************
*** 163,168 ****
--- 163,174 ----
  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,1480 ****
--- 1481,1489 ----
       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,1891 ****
  	{
  	  if (escapeflag)
  	    {
! 	      strout ("#<process ", -1, -1, printcharfun, 0);
! 	      print_string (XPROCESS (obj)->name, printcharfun);
! 	      PRINTCHAR ('>');
  	    }
  	  else
  	    print_string (XPROCESS (obj)->name, printcharfun);
--- 1892,1904 ----
  	{
  	  if (escapeflag)
  	    {
! 	      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,1960 ****
--- 1962,1975 ----
  	}
        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,1972 ****
--- 1982,1988 ----
  	}
        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,1992 ****
--- 2003,2009 ----
  	}
        else if (BUFFERP (obj))
  	{
+ 	  PRINT_UNREADABLE;
  	  if (NILP (XBUFFER (obj)->name))
  	    strout ("#<killed buffer>", -1, -1, printcharfun, 0);
  	  else if (escapeflag)
***************
*** 2000,2009 ****
--- 2017,2028 ----
  	}
        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,2067 ****
--- 2081,2087 ----
        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,2084 ****
--- 2099,2105 ----
  	  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,2123 ****
--- 2118,2149 ----
        /* 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,2131 ****
--- 2152,2158 ----
  	  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,2142 ****
--- 2161,2171 ----
  	  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,2172 ****
--- 2196,2202 ----
  	  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,2203 ****
--- 2228,2247 ----
        }
      }
  
+   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,2337 ****
--- 2376,2390 ----
  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);
  
