Re: 23.0.50; savehist save invalid syntax

["Davis Herring" <herring@lanl.gov>]

[-- Attachment #1: Type: text/plain, Size: 1712 bytes --]

>     With this much complexity, my temptation would be to provide a
>     print-readable function (or an optional argument to an existing
> printer)
>     that signalled if it  were asked to print something that has no read
>     syntax.
>
> I wouldn't mind adding that feature if someone wants to do it.
> It should be controlled by a variable.

I've implemented that feature.  I took Stefan's suggestion and made the
variable be a function that took over printing (or t for signaling as in
my original suggestion).  The patch is attached; please bear with me as I
think it's my most complex foray into Emacs' C thus far and introduces a
new macro and such.  It is, however, tested.

On a side note, I see that this is an extension of the variable
`print-readably' in XEmacs.  It doesn't follow naming convention, but
perhaps my new variable `print-unreadable-function' should be named or
aliased to `print-readably' for compatibility.

Meanwhile, savehist needs to use this.  It actually already has a hack in
it that uses `prin1' and `read' (or `print-readably' on XEmacs) to detect
unreadability; one could certainly use this instead of the new printing
feature.  But for cleanliness and completeness, I removed that trick and
replaced it with handlers for the unreadable signals that, now, both
varities of Emacs will generate.  (Of course, I also actually implemented
the code to skip unprintable history elements, instead of skipping the
entire history or so.)  This second patch is completely untested because
I'm unfamiliar with savehist.

Davis

-- 
This product is sold by volume, not by mass.  If it appears too dense or
too sparse, it is because mass-energy conversion has occurred during
shipping.

[-- Attachment #2: print-unreadable.patch --]
[-- Type: application/octet-stream, Size: 7233 bytes --]

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

[-- Attachment #3: savehist-unreadable.patch --]
[-- Type: application/octet-stream, Size: 3900 bytes --]

*** savehist.el	01 Aug 2007 11:08:24 -0600	1.21
--- savehist.el	05 Sep 2007 12:13:43 -0600	
***************
*** 299,325 ****
  	  (print-string-length nil)
  	  (print-level nil)
  	  (print-readably t)
! 	  (print-quoted t))
        ;; Save the minibuffer histories, along with the value of
        ;; savehist-minibuffer-history-variables itself.
        (when savehist-save-minibuffer-history
  	(prin1 `(setq savehist-minibuffer-history-variables
! 		      ',savehist-minibuffer-history-variables)
! 	       (current-buffer))
  	(insert ?\n)
  	(dolist (symbol savehist-minibuffer-history-variables)
  	  (when (boundp symbol)
  	    (let ((value (savehist-trim-history (symbol-value symbol))))
  	      (when value		; don't save empty histories
! 		(prin1 `(setq ,symbol ',value) (current-buffer))
! 		(insert ?\n))))))
        ;; Save the additional variables.
        (dolist (symbol savehist-additional-variables)
  	(when (boundp symbol)
! 	  (let ((value (symbol-value symbol)))
! 	    (when (savehist-printable value)
! 	      (prin1 `(setq ,symbol ',value) (current-buffer))
! 	      (insert ?\n))))))
      ;; If autosaving, avoid writing if nothing has changed since the
      ;; last write.
      (let ((checksum (md5 (current-buffer) nil nil savehist-no-conversion)))
--- 299,328 ----
  	  (print-string-length nil)
  	  (print-level nil)
  	  (print-readably t)
! 	  (print-quoted t)
! 	  (print-unreadable-function t)
! 	  (standard-output (current-buffer)))
        ;; Save the minibuffer histories, along with the value of
        ;; savehist-minibuffer-history-variables itself.
        (when savehist-save-minibuffer-history
  	(prin1 `(setq savehist-minibuffer-history-variables
! 		      ',savehist-minibuffer-history-variables))
  	(insert ?\n)
  	(dolist (symbol savehist-minibuffer-history-variables)
  	  (when (boundp symbol)
  	    (let ((value (savehist-trim-history (symbol-value symbol))))
  	      (when value		; don't save empty histories
! 		(insert "(setq ")
! 		(prin1 symbol)
! 		(insert ?\n)
! 		(while value
! 		  (and (savehist-prin1-readable (car value))
! 		       (setq value (cdr value)) (insert "  ")))
! 		(insert ?\)))))))
        ;; Save the additional variables.
        (dolist (symbol savehist-additional-variables)
  	(when (boundp symbol)
! 	  (savehist-prin1-readable `(setq ,symbol ',(symbol-value symbol)))))
      ;; If autosaving, avoid writing if nothing has changed since the
      ;; last write.
      (let ((checksum (md5 (current-buffer) nil nil savehist-no-conversion)))
***************
*** 355,380 ****
        (loop repeat history-length collect (pop value))
      value))
  
! (defun savehist-printable (value)
!   "Return non-nil if VALUE is printable."
!   (cond
!    ;; Quick response for oft-encountered types known to be printable.
!    ((stringp value))
!    ((numberp value))
!    ((symbolp value))
!    (t
!     ;; For others, check explicitly.
!     (with-temp-buffer
!       (condition-case nil
! 	  (let ((print-readably t) (print-level nil))
! 	  ;; Print the value into a buffer...
  	  (prin1 value (current-buffer))
! 	  ;; ...and attempt to read it.
! 	  (read (point-min-marker))
! 	  ;; The attempt worked: the object is printable.
! 	  t)
! 	;; The attempt failed: the object is not printable.
! 	(error nil))))))
  
  (defun savehist-minibuffer-hook ()
    (unless (or (eq minibuffer-history-variable t)
--- 358,372 ----
        (loop repeat history-length collect (pop value))
      value))
  
! (defun savehist-prin1-readable (value)
!   "Print VALUE in the current buffer, if it's readable.
! Return non-nil if it was printed."
!   (let ((opoint (point)))
!     (condition-case nil
! 	(progn
  	  (prin1 value (current-buffer))
! 	  (insert ?\n) t)
!       (invalid-read-syntax (delete-region opoint (point)) nil))))
  
  (defun savehist-minibuffer-hook ()
    (unless (or (eq minibuffer-history-variable t)

[-- Attachment #4: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel