master aa95b2a47d: Add OVERRIDES argument to prin1/prin1-to-string

[Lars Ingebrigtsen]

branch: master
commit aa95b2a47dce8cf74f70f43f72e35349782d1c74
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Add OVERRIDES argument to prin1/prin1-to-string
    
    * doc/lispref/streams.texi (Output Functions): Document it.
    (Output Overrides): New node.
    
    * src/process.c (Faccept_process_output):
    * src/print.c (debug_print, print_error_message):
    * src/pdumper.c (print_paths_to_root_1, decode_emacs_reloc):
    * src/lread.c (readevalloop):
    * src/eval.c (internal_lisp_condition_case):
    * src/editfns.c (styled_format): Adjust prin1/prin1-to-string
    callers.
    
    * src/print.c (Fprin1): Take an OVERRIDES parameter.
    (print_bind_overrides, print_bind_all_defaults): New functions.
    (Fprin1_to_string): Take an OVERRIDES parameter.
---
 doc/lispref/elisp.texi   |   1 +
 doc/lispref/streams.texi | 103 ++++++++++++++++++++++++++++++++++++++++-
 etc/NEWS                 |   4 ++
 src/editfns.c            |   2 +-
 src/eval.c               |   2 +-
 src/lread.c              |   2 +-
 src/pdumper.c            |   4 +-
 src/print.c              | 118 +++++++++++++++++++++++++++++++++++++++++++----
 src/process.c            |   2 +-
 test/src/print-tests.el  |  43 +++++++++++++++++
 10 files changed, 265 insertions(+), 16 deletions(-)

diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 968a2790e2..a3d1d80408 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -739,6 +739,7 @@ Reading and Printing Lisp Objects
 * Output Functions::        Functions to print Lisp objects as text.
 * Output Variables::        Variables that control what the printing
                               functions do.
+* Output Overrides::        Overriding output variables.
 
 Minibuffers
 
diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi
index 781a50f5c4..d805d08744 100644
--- a/doc/lispref/streams.texi
+++ b/doc/lispref/streams.texi
@@ -21,6 +21,7 @@ reading) or where to put it (if printing).
 * Output Streams::    Various data types that can be used as output streams.
 * Output Functions::  Functions to print Lisp objects as text.
 * Output Variables::  Variables that control what the printing functions do.
+* Output Overrides::  Overriding output variables.
 @end menu
 
 @node Streams Intro
@@ -634,7 +635,7 @@ characters are used.  @code{print} returns @var{object}.  
For example:
 @end example
 @end defun
 
-@defun prin1 object &optional stream
+@defun prin1 object &optional stream overrides
 This function outputs the printed representation of @var{object} to
 @var{stream}.  It does not print newlines to separate output as
 @code{print} does, but it does use quoting characters just like
@@ -649,6 +650,10 @@ This function outputs the printed representation of 
@var{object} to
      @result{} " came back"
 @end group
 @end example
+
+If @var{overrides} is non-@code{nil}, it should either be @code{t}
+(which tells @code{prin1} to use the defaults for all printer related
+variables), or a list of settings.  @xref{Output Overrides} for details.
 @end defun
 
 @defun princ object &optional stream
@@ -694,7 +699,7 @@ newline character first, which enables you to display 
incomplete
 lines.
 @end defun
 
-@defun prin1-to-string object &optional noescape
+@defun prin1-to-string object &optional noescape overrides
 @cindex object to string
 This function returns a string containing the text that @code{prin1}
 would have printed for the same argument.
@@ -708,6 +713,10 @@ would have printed for the same argument.
 (prin1-to-string (mark-marker))
      @result{} "#<marker at 2773 in strings.texi>"
 @end group
+
+If @var{overrides} is non-@code{nil}, it should either be @code{t}
+(which tells @code{prin1} to use the defaults for all printer related
+variables), or a list of settings.  @xref{Output Overrides} for details.
 @end example
 
 If @var{noescape} is non-@code{nil}, that inhibits use of quoting
@@ -971,3 +980,93 @@ Letter, Number, Punctuation, Symbol and Private-use
 (@pxref{Character Properties}), as well as the control characters
 having their own escape syntax such as newline.
 @end defvar
+
+@node Output Overrides
+@section Overriding Output Variables
+
+@xref{Output Functions} lists the numerous variables that controls how
+the Emacs Lisp printer outputs data.  These are generally available
+for users to change, but sometimes you want to output data in the
+default format.  For instance, if you're storing Emacs Lisp data in a
+file, you don't want that data to be shortened by a
+@code{print-length} setting.
+
+The @code{prin1} and @code{prin1-to-string} functions therefore have
+an optional @var{overrides} argument.  This variable can either be
+@code{t} (which means that all printing variables should be the
+default values), or a list of settings.  Each element in the list can
+either be @code{t} (which means ``reset to defaults'') or a pair where
+the @code{car} is a symbol, and the @code{cdr} is the value.
+
+For instance, this prints using nothing but defaults:
+
+@lisp
+(prin1 object nil t)
+@end lisp
+
+This prints @var{object} using the current printing settings, but
+overrides @code{print-length} to 5:
+
+@lisp
+(prin1 object nil '((length . 5)))
+@end lisp
+
+And finally, this prints @var{object} using only default settings, but
+overrides @code{print-length} to 5:
+
+@lisp
+(prin1 object nil '(t (length . 5)))
+@end lisp
+
+Below is a list of symbols that can be used, and which variables they
+map to:
+
+@table @code
+@item length
+This overrides @code{print-length}.
+
+@item level
+This overrides @code{print-level}.
+
+@item circle
+This overrides @code{print-circle}.
+
+@item quoted
+This overrides @code{print-quoted}.
+
+@item escape-newlines
+This overrides @code{print-escape-newlines}.
+
+@item escape-control-characters
+This overrides @code{print-escape-control-characters}.
+
+@item escape-nonascii
+This overrides @code{print-escape-nonascii}.
+
+@item escape-multibyte
+This overrides @code{print-escape-multibyte}.
+
+@item charset-text-property
+This overrides @code{print-charset-text-property}.
+
+@item unreadeable-function
+This overrides @code{print-unreadable-function}.
+
+@item gensym
+This overrides @code{print-gensym}.
+
+@item continuous-numbering
+This overrides @code{print-continuous-numbering}.
+
+@item number-table
+This overrides @code{print-number-table}.
+
+@item float-format
+This overrides @code{float-output-format}.
+
+@item integers-as-characters
+This overrides @code{print-integers-as-characters}.
+@end table
+
+In the future, more overrides may be offered that do not map directly
+to a variable, but can only be used via this parameter.
diff --git a/etc/NEWS b/etc/NEWS
index b89771cdbd..715827e76f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1817,6 +1817,10 @@ functions.
 
 * Lisp Changes in Emacs 29.1
 
++++
+** 'prin1' and 'prin1-to-string' now takes an OVERRIDES parameter.
+This parameter can be used to override printer settings.
+
 +++
 ** New minor mode 'header-line-indent-mode'.
 This is meant to be used in modes that have a header line that should
diff --git a/src/editfns.c b/src/editfns.c
index 6cb684d4d8..17f0252969 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -3327,7 +3327,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool 
message)
              if (EQ (arg, args[n]))
                {
                  Lisp_Object noescape = conversion == 'S' ? Qnil : Qt;
-                 spec->argument = arg = Fprin1_to_string (arg, noescape);
+                 spec->argument = arg = Fprin1_to_string (arg, noescape, Qnil);
                  if (STRING_MULTIBYTE (arg) && ! multibyte)
                    {
                      multibyte = true;
diff --git a/src/eval.c b/src/eval.c
index 29c122e2fb..25ac8e4529 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1341,7 +1341,7 @@ internal_lisp_condition_case (Lisp_Object var, 
Lisp_Object bodyform,
                 && (SYMBOLP (XCAR (tem))
                     || CONSP (XCAR (tem))))))
        error ("Invalid condition handler: %s",
-              SDATA (Fprin1_to_string (tem, Qt)));
+              SDATA (Fprin1_to_string (tem, Qt, Qnil)));
       if (CONSP (tem) && EQ (XCAR (tem), QCsuccess))
        success_handler = XCDR (tem);
       else
diff --git a/src/lread.c b/src/lread.c
index 409e97cdfa..5f3d83a846 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2349,7 +2349,7 @@ readevalloop (Lisp_Object readcharfun,
        {
          Vvalues = Fcons (val, Vvalues);
          if (EQ (Vstandard_output, Qt))
-           Fprin1 (val, Qnil);
+           Fprin1 (val, Qnil, Qnil);
          else
            Fprint (val, Qnil);
        }
diff --git a/src/pdumper.c b/src/pdumper.c
index 5923d9b1d8..88e7b311a8 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -1383,7 +1383,7 @@ print_paths_to_root_1 (struct dump_context *ctx,
     {
       Lisp_Object referrer = XCAR (referrers);
       referrers = XCDR (referrers);
-      Lisp_Object repr = Fprin1_to_string (referrer, Qnil);
+      Lisp_Object repr = Fprin1_to_string (referrer, Qnil, Qnil);
       for (int i = 0; i < level; ++i)
        putc (' ', stderr);
       fwrite (SDATA (repr), 1, SBYTES (repr), stderr);
@@ -3758,7 +3758,7 @@ decode_emacs_reloc (struct dump_context *ctx, Lisp_Object 
lreloc)
             reloc.u.dump_offset = dump_recall_object (ctx, target_value);
             if (reloc.u.dump_offset <= 0)
               {
-                Lisp_Object repr = Fprin1_to_string (target_value, Qnil);
+                Lisp_Object repr = Fprin1_to_string (target_value, Qnil, Qnil);
                 error ("relocation target was not dumped: %s", SDATA (repr));
               }
             dump_check_dump_off (ctx, reloc.u.dump_offset);
diff --git a/src/print.c b/src/print.c
index d7583282b6..c9a9b868f9 100644
--- a/src/print.c
+++ b/src/print.c
@@ -620,7 +620,51 @@ If PRINTCHARFUN is omitted or nil, the value of 
`standard-output' is used.  */)
   return val;
 }
 
-DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
+static void
+print_bind_all_defaults (void)
+{
+  for (Lisp_Object vars = Vprint__variable_mapping; !NILP (vars);
+       vars = XCDR (vars))
+    {
+      Lisp_Object elem = XCDR (XCAR (vars));
+      specbind (XCAR (elem), XCAR (XCDR (elem)));
+    }
+}
+
+static void
+print_bind_overrides (Lisp_Object overrides)
+{
+  if (EQ (overrides, Qt))
+    print_bind_all_defaults ();
+  else if (!CONSP (overrides))
+    xsignal (Qwrong_type_argument, Qconsp);
+  else
+    {
+      while (!NILP (overrides))
+       {
+         Lisp_Object setting = XCAR (overrides);
+         if (EQ (setting, Qt))
+           print_bind_all_defaults ();
+         else if (!CONSP (setting))
+           xsignal (Qwrong_type_argument, Qconsp);
+         else
+           {
+             Lisp_Object key = XCAR (setting),
+               value = XCDR (setting);
+             Lisp_Object map = Fassq (key, Vprint__variable_mapping);
+             if (NILP (map))
+               xsignal2 (Qwrong_type_argument, Qsymbolp, map);
+             specbind (XCAR (XCDR (map)), value);
+           }
+
+         if (!NILP (XCDR (overrides)) && !CONSP (XCDR (overrides)))
+           xsignal (Qwrong_type_argument, Qconsp);
+         overrides = XCDR (overrides);
+       }
+    }
+}
+
+DEFUN ("prin1", Fprin1, Sprin1, 1, 3, 0,
        doc: /* Output the printed representation of OBJECT, any Lisp object.
 Quoting characters are printed when needed to make output that `read'
 can handle, whenever this is possible.  For complex objects, the behavior
@@ -642,21 +686,43 @@ of these:
    - t, in which case the output is displayed in the echo area.
 
 If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
-is used instead.  */)
-  (Lisp_Object object, Lisp_Object printcharfun)
+is used instead.
+
+OVERRIDES should be a list of settings.  An element in this list be
+the symbol t, which means "use all the defaults".  If not, an element
+should be a pair, where the `car' or the pair is the setting, and the
+`cdr' of the pair is the value of printer-related settings to use for
+this `prin1' call.
+
+For instance:
+
+  (prin1 object nil \\='((length . 100) (circle . t))).
+
+See the manual entry `(elisp)Output Overrides' for a list of possible
+values.
+
+As a special case, OVERRIDES can also simply be the symbol t, which
+means "use all the defaults".  */)
+  (Lisp_Object object, Lisp_Object printcharfun, Lisp_Object overrides)
 {
+  specpdl_ref count = SPECPDL_INDEX ();
+
   if (NILP (printcharfun))
     printcharfun = Vstandard_output;
+  if (!NILP (overrides))
+    print_bind_overrides (overrides);
+
   PRINTPREPARE;
   print (object, printcharfun, 1);
   PRINTFINISH;
-  return object;
+
+  return unbind_to (count, object);
 }
 
 /* A buffer which is used to hold output being built by prin1-to-string.  */
 Lisp_Object Vprin1_to_string_buffer;
 
-DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
+DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 3, 0,
        doc: /* Return a string containing the printed representation of OBJECT.
 OBJECT can be any Lisp object.  This function outputs quoting characters
 when necessary to make output that `read' can handle, whenever possible,
@@ -666,13 +732,18 @@ the behavior is controlled by `print-level' and 
`print-length', which see.
 OBJECT is any of the Lisp data types: a number, a string, a symbol,
 a list, a buffer, a window, a frame, etc.
 
+See `prin1' for the meaning of OVERRIDES.
+
 A printed representation of an object is text which describes that object.  */)
-  (Lisp_Object object, Lisp_Object noescape)
+  (Lisp_Object object, Lisp_Object noescape, Lisp_Object overrides)
 {
   specpdl_ref count = SPECPDL_INDEX ();
 
   specbind (Qinhibit_modification_hooks, Qt);
 
+  if (!NILP (overrides))
+    print_bind_overrides (overrides);
+
   /* Save and restore this: we are altering a buffer
      but we don't want to deactivate the mark just for that.
      No need for specbind, since errors deactivate the mark.  */
@@ -847,7 +918,7 @@ append to existing target file.  */)
 void
 debug_print (Lisp_Object arg)
 {
-  Fprin1 (arg, Qexternal_debugging_output);
+  Fprin1 (arg, Qexternal_debugging_output, Qnil);
   fputs ("\r\n", stderr);
 }
 
@@ -995,7 +1066,7 @@ print_error_message (Lisp_Object data, Lisp_Object stream, 
const char *context,
            || EQ (errname, Qend_of_file) || EQ (errname, Quser_error))
          Fprinc (obj, stream);
        else
-         Fprin1 (obj, stream);
+         Fprin1 (obj, stream, Qnil);
       }
   }
 }
@@ -2571,4 +2642,35 @@ be printed.  */);
   DEFSYM (Qprint_unreadable_function, "print-unreadable-function");
 
   defsubr (&Sflush_standard_output);
+
+  DEFVAR_LISP ("print--variable-mapping", Vprint__variable_mapping,
+              doc: /* Mapping for print variables in `prin1'.
+Do not modify this list.  */);
+  Vprint__variable_mapping = Qnil;
+  Lisp_Object total[] = {
+    list3 (intern ("length"), intern ("print-length"), Qnil),
+    list3 (intern ("level"), intern ("print-level"), Qnil),
+    list3 (intern ("circle"), intern ("print-circle"), Qnil),
+    list3 (intern ("quoted"), intern ("print-quoted"), Qt),
+    list3 (intern ("escape-newlines"), intern ("print-escape-newlines"), Qnil),
+    list3 (intern ("escape-control-characters"),
+          intern ("print-escape-control-characters"), Qnil),
+    list3 (intern ("escape-nonascii"), intern ("print-escape-nonascii"), Qnil),
+    list3 (intern ("escape-multibyte"),
+          intern ("print-escape-multibyte"), Qnil),
+    list3 (intern ("charset-text-property"),
+          intern ("print-charset-text-property"), Qnil),
+    list3 (intern ("unreadeable-function"),
+          intern ("print-unreadable-function"), Qnil),
+    list3 (intern ("gensym"), intern ("print-gensym"), Qnil),
+    list3 (intern ("continuous-numbering"),
+          intern ("print-continuous-numbering"), Qnil),
+    list3 (intern ("number-table"), intern ("print-number-table"), Qnil),
+    list3 (intern ("float-format"), intern ("float-output-format"), Qnil),
+    list3 (intern ("integers-as-characters"),
+          intern ("print-integers-as-characters"), Qnil),
+  };
+
+  Vprint__variable_mapping = CALLMANY (Flist, total);
+  make_symbol_constant (intern_c_string ("print--variable-mapping"));
 }
diff --git a/src/process.c b/src/process.c
index 2f8863aef2..fe3e12343f 100644
--- a/src/process.c
+++ b/src/process.c
@@ -4779,7 +4779,7 @@ corresponding connection was closed.  */)
                 SDATA (proc->name),
                 STRINGP (proc_thread_name)
                 ? SDATA (proc_thread_name)
-                : SDATA (Fprin1_to_string (proc->thread, Qt)));
+                : SDATA (Fprin1_to_string (proc->thread, Qt, Qnil)));
        }
     }
   else
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index 0bae1959d1..b9b282e580 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -425,5 +425,48 @@ otherwise, use a different charset."
   (should (equal (prin1-to-string '\?bar) "\\?bar"))
   (should (equal (prin1-to-string '\?bar?) "\\?bar?")))
 
+(ert-deftest test-prin1-overrides ()
+  (with-temp-buffer
+    (let ((print-length 10))
+      (prin1 (make-list 20 t) (current-buffer) t)
+      (should (= print-length 10)))
+    (goto-char (point-min))
+    (should (= (length (read (current-buffer))) 20)))
+
+  (with-temp-buffer
+    (let ((print-length 10))
+      (prin1 (make-list 20 t) (current-buffer) '((length . 5)))
+      (should (= print-length 10)))
+    (goto-char (point-min))
+    (should (= (length (read (current-buffer))) 6)))
+
+  (with-temp-buffer
+    (let ((print-length 10))
+      (prin1 (make-list 20 t) (current-buffer) '(t (length . 5)))
+      (should (= print-length 10)))
+    (goto-char (point-min))
+    (should (= (length (read (current-buffer))) 6))))
+
+(ert-deftest test-prin1-to-string-overrides ()
+  (let ((print-length 10))
+    (should
+     (= (length (car (read-from-string
+                      (prin1-to-string (make-list 20 t) nil t))))
+        20)))
+
+  (let ((print-length 10))
+    (should
+     (= (length (car (read-from-string
+                      (prin1-to-string (make-list 20 t) nil
+                                       '((length . 5))))))
+        6)))
+
+  (should-error (prin1-to-string 'foo nil 'a))
+  (should-error (prin1-to-string 'foo nil '(a)))
+  (should-error (prin1-to-string 'foo nil '(t . b)))
+  (should-error (prin1-to-string 'foo nil '(t b)))
+  (should-error (prin1-to-string 'foo nil '((a . b) b)))
+  (should-error (prin1-to-string 'foo nil '((length . 10) . b))))
+
 (provide 'print-tests)
 ;;; print-tests.el ends here