summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorLars Ingebrigtsen <larsi@gnus.org>2022-05-15 15:29:28 +0200
committerLars Ingebrigtsen <larsi@gnus.org>2022-05-15 15:29:38 +0200
commitaa95b2a47dce8cf74f70f43f72e35349782d1c74 (patch)
tree169ef433c0b42ae69f09abf71e0d04c7c79ac925 /src
parent22873b5415fbcc81f2d1e0e69cccd5dbeaac51ee (diff)
downloademacs-aa95b2a47dce8cf74f70f43f72e35349782d1c74.tar.gz
emacs-aa95b2a47dce8cf74f70f43f72e35349782d1c74.tar.bz2
emacs-aa95b2a47dce8cf74f70f43f72e35349782d1c74.zip
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.
Diffstat (limited to 'src')
-rw-r--r--src/editfns.c2
-rw-r--r--src/eval.c2
-rw-r--r--src/lread.c2
-rw-r--r--src/pdumper.c4
-rw-r--r--src/print.c118
-rw-r--r--src/process.c2
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
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-06 02:43:32 +0000