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.

6 files changed, 116 insertions, 14 deletions

diff --git a/src/editfns.c b/src/editfns.c
index 6cb684d4d85..17f0252969e 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 29c122e2fb2..25ac8e45296 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 409e97cdfa6..5f3d83a846b 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 5923d9b1d82..88e7b311a89 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 d7583282b69..c9a9b868f9f 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 2f8863aef25..fe3e12343f2 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