From aa95b2a47dce8cf74f70f43f72e35349782d1c74 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 15 May 2022 15:29:28 +0200 Subject: [PATCH] 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 968a2790e21..a3d1d804086 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 781a50f5c49..d805d087447 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{} "#" @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 b89771cdbda..715827e76fe 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 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 diff --git a/test/src/print-tests.el b/test/src/print-tests.el index 0bae1959d1b..b9b282e5809 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 -- 2.39.2