[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master e4d2a7894b 1/3: Add new variable print-unreadable-function
|
From: |
Lars Ingebrigtsen |
|
Subject: |
master e4d2a7894b 1/3: Add new variable print-unreadable-function |
|
Date: |
Sat, 22 Jan 2022 09:13:36 -0500 (EST) |
branch: master
commit e4d2a7894b4294a31a4311fa81a3644ea06028e5
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>
Add new variable print-unreadable-function
* doc/lispref/streams.texi (Output Variables): Document it.
* src/print.c (print_vectorlike): Use the variable.
(syms_of_print): New variable print-unreadable-function
(bug#52566).
---
doc/lispref/streams.texi | 26 +++
etc/NEWS | 8 +-
src/print.c | 449 ++++++++++++++++++++++++++---------------------
test/src/print-tests.el | 11 ++
4 files changed, 291 insertions(+), 203 deletions(-)
diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi
index c6b3397ae1..5ab6cf5777 100644
--- a/doc/lispref/streams.texi
+++ b/doc/lispref/streams.texi
@@ -872,6 +872,32 @@ If non-@code{nil}, this variable enables detection of
circular and
shared structure in printing. @xref{Circular Objects}.
@end defvar
+@defvar print-unreadable-function
+By default, Emacs prints unreadable objects as @samp{#<...>"}. For
+instance:
+
+@example
+(prin1-to-string (make-marker))
+ @result{} "#<marker in no buffer>"
+@end example
+
+If this variable is non-@code{nil}, it should be a function that will
+be called to handle printing of these objects. The first argument is
+the object, and the second argument is the @var{noescape} flag used by
+the printing functions (@pxref{Output Functions}).
+
+The function should return either @code{nil} (print nothing), or a
+string (which will be printed), or any other object (which means that
+the object should be printed normally). For instance:
+
+@example
+(let ((print-unreadable-function
+ (lambda (object escape) "hello")))
+ (prin1-to-string (make-marker)))
+ @result{} "hello"
+@end example
+@end defvar
+
@defvar print-gensym
If non-@code{nil}, this variable enables detection of uninterned symbols
(@pxref{Creating Symbols}) in printing. When this is enabled,
diff --git a/etc/NEWS b/etc/NEWS
index 87b009d5e2..02e7a462a1 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -977,12 +977,16 @@ functions.
* Lisp Changes in Emacs 29.1
---
++++
+** New variable 'print-unreadable-function'.
+This variable allows changing how Emacs prints unreadable objects.
+
+---
** The variable 'polling-period' now accepts floating point values.
This means Emacs can now poll for input during Lisp execution more
frequently than once in a second.
---
+---
** New function 'bidi-string-strip-control-characters'.
This utility function is meant for displaying strings when it's
essential that there's no bidirectional context.
diff --git a/src/print.c b/src/print.c
index a3c9011215..4d9feb55ac 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1387,6 +1387,7 @@ static bool
print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
char *buf)
{
+ /* First do all the vectorlike types that have a readable syntax. */
switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
{
case PVEC_BIGNUM:
@@ -1398,8 +1399,240 @@ print_vectorlike (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag,
strout (str, len, len, printcharfun);
SAFE_FREE ();
}
+ return true;
+
+ case PVEC_BOOL_VECTOR:
+ {
+ EMACS_INT size = bool_vector_size (obj);
+ ptrdiff_t size_in_bytes = bool_vector_bytes (size);
+ ptrdiff_t real_size_in_bytes = size_in_bytes;
+ unsigned char *data = bool_vector_uchar_data (obj);
+
+ int len = sprintf (buf, "#&%"pI"d\"", size);
+ strout (buf, len, len, printcharfun);
+
+ /* Don't print more bytes than the specified maximum.
+ Negative values of print-length are invalid. Treat them
+ like a print-length of nil. */
+ if (FIXNATP (Vprint_length)
+ && XFIXNAT (Vprint_length) < size_in_bytes)
+ size_in_bytes = XFIXNAT (Vprint_length);
+
+ for (ptrdiff_t i = 0; i < size_in_bytes; i++)
+ {
+ maybe_quit ();
+ unsigned char c = data[i];
+ if (c == '\n' && print_escape_newlines)
+ print_c_string ("\\n", printcharfun);
+ else if (c == '\f' && print_escape_newlines)
+ print_c_string ("\\f", printcharfun);
+ else if (c > '\177'
+ || (print_escape_control_characters && c_iscntrl (c)))
+ {
+ /* Use octal escapes to avoid encoding issues. */
+ octalout (c, data, i + 1, size_in_bytes, printcharfun);
+ }
+ else
+ {
+ if (c == '\"' || c == '\\')
+ printchar ('\\', printcharfun);
+ printchar (c, printcharfun);
+ }
+ }
+
+ if (size_in_bytes < real_size_in_bytes)
+ print_c_string (" ...", printcharfun);
+ printchar ('\"', printcharfun);
+ }
+ return true;
+
+ case PVEC_HASH_TABLE:
+ {
+ struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
+ /* Implement a readable output, e.g.:
+ #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
+ /* Always print the size. */
+ int len = sprintf (buf, "#s(hash-table size %"pD"d",
+ HASH_TABLE_SIZE (h));
+ strout (buf, len, len, printcharfun);
+
+ if (!NILP (h->test.name))
+ {
+ print_c_string (" test ", printcharfun);
+ print_object (h->test.name, printcharfun, escapeflag);
+ }
+
+ if (!NILP (h->weak))
+ {
+ print_c_string (" weakness ", printcharfun);
+ print_object (h->weak, printcharfun, escapeflag);
+ }
+
+ print_c_string (" rehash-size ", printcharfun);
+ print_object (Fhash_table_rehash_size (obj),
+ printcharfun, escapeflag);
+
+ print_c_string (" rehash-threshold ", printcharfun);
+ print_object (Fhash_table_rehash_threshold (obj),
+ printcharfun, escapeflag);
+
+ if (h->purecopy)
+ {
+ print_c_string (" purecopy ", printcharfun);
+ print_object (h->purecopy ? Qt : Qnil, printcharfun, escapeflag);
+ }
+
+ print_c_string (" data ", printcharfun);
+
+ /* Print the data here as a plist. */
+ ptrdiff_t real_size = HASH_TABLE_SIZE (h);
+ ptrdiff_t size = h->count;
+
+ /* Don't print more elements than the specified maximum. */
+ if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size)
+ size = XFIXNAT (Vprint_length);
+
+ printchar ('(', printcharfun);
+ ptrdiff_t j = 0;
+ for (ptrdiff_t i = 0; i < real_size; i++)
+ {
+ Lisp_Object key = HASH_KEY (h, i);
+ if (!EQ (key, Qunbound))
+ {
+ if (j++) printchar (' ', printcharfun);
+ print_object (key, printcharfun, escapeflag);
+ printchar (' ', printcharfun);
+ print_object (HASH_VALUE (h, i), printcharfun, escapeflag);
+ if (j == size)
+ break;
+ }
+ }
+
+ if (j < h->count)
+ {
+ if (j)
+ printchar (' ', printcharfun);
+ print_c_string ("...", printcharfun);
+ }
+
+ print_c_string ("))", printcharfun);
+ }
+ return true;
+
+ case PVEC_RECORD:
+ {
+ ptrdiff_t size = PVSIZE (obj);
+
+ /* Don't print more elements than the specified maximum. */
+ ptrdiff_t n
+ = (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size
+ ? XFIXNAT (Vprint_length) : size);
+
+ print_c_string ("#s(", printcharfun);
+ for (ptrdiff_t i = 0; i < n; i ++)
+ {
+ if (i) printchar (' ', printcharfun);
+ print_object (AREF (obj, i), printcharfun, escapeflag);
+ }
+ if (n < size)
+ print_c_string (" ...", printcharfun);
+ printchar (')', printcharfun);
+ }
+ return true;
+
+ case PVEC_SUB_CHAR_TABLE:
+ case PVEC_COMPILED:
+ case PVEC_CHAR_TABLE:
+ case PVEC_NORMAL_VECTOR:
+ {
+ ptrdiff_t size = ASIZE (obj);
+ if (COMPILEDP (obj))
+ {
+ printchar ('#', printcharfun);
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ }
+ if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj))
+ {
+ /* Print a char-table as if it were a vector,
+ lumping the parent and default slots in with the
+ character slots. But add #^ as a prefix. */
+
+ /* Make each lowest sub_char_table start a new line.
+ Otherwise we'll make a line extremely long, which
+ results in slow redisplay. */
+ if (SUB_CHAR_TABLE_P (obj)
+ && XSUB_CHAR_TABLE (obj)->depth == 3)
+ printchar ('\n', printcharfun);
+ print_c_string ("#^", printcharfun);
+ if (SUB_CHAR_TABLE_P (obj))
+ printchar ('^', printcharfun);
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ }
+ if (size & PSEUDOVECTOR_FLAG)
+ return false;
+
+ printchar ('[', printcharfun);
+
+ int idx = SUB_CHAR_TABLE_P (obj) ? SUB_CHAR_TABLE_OFFSET : 0;
+ Lisp_Object tem;
+ ptrdiff_t real_size = size;
+
+ /* For a sub char-table, print heading non-Lisp data first. */
+ if (SUB_CHAR_TABLE_P (obj))
+ {
+ int i = sprintf (buf, "%d %d", XSUB_CHAR_TABLE (obj)->depth,
+ XSUB_CHAR_TABLE (obj)->min_char);
+ strout (buf, i, i, printcharfun);
+ }
+
+ /* Don't print more elements than the specified maximum. */
+ if (FIXNATP (Vprint_length)
+ && XFIXNAT (Vprint_length) < size)
+ size = XFIXNAT (Vprint_length);
+
+ for (int i = idx; i < size; i++)
+ {
+ if (i) printchar (' ', printcharfun);
+ tem = AREF (obj, i);
+ print_object (tem, printcharfun, escapeflag);
+ }
+ if (size < real_size)
+ print_c_string (" ...", printcharfun);
+ printchar (']', printcharfun);
+ }
+ return true;
+
+ default:
break;
+ }
+
+ /* Then do all the pseudovector types that don't have a readable
+ syntax. First check whether this is handled by
+ `print-unreadable-function'. */
+ if (!NILP (Vprint_unreadable_function)
+ && FUNCTIONP (Vprint_unreadable_function))
+ {
+ ptrdiff_t count = SPECPDL_INDEX ();
+ /* Bind `print-unreadable-function' to nil to avoid accidental
+ infinite recursion in the function called. */
+ Lisp_Object func = Vprint_unreadable_function;
+ specbind (Qprint_unreadable_function, Qnil);
+ Lisp_Object result = CALLN (Ffuncall, func, obj,
+ escapeflag? Qt: Qnil);
+ unbind_to (count, Qnil);
+
+ if (!NILP (result))
+ {
+ if (STRINGP (result))
+ print_string (result, printcharfun);
+ /* It's handled, so stop processing here. */
+ return true;
+ }
+ }
+ /* Not handled; print unreadable object. */
+ switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
+ {
case PVEC_MARKER:
print_c_string ("#<marker ", printcharfun);
/* Do you think this is necessary? */
@@ -1470,51 +1703,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag,
print_string (XPROCESS (obj)->name, printcharfun);
break;
- case PVEC_BOOL_VECTOR:
- {
- EMACS_INT size = bool_vector_size (obj);
- ptrdiff_t size_in_bytes = bool_vector_bytes (size);
- ptrdiff_t real_size_in_bytes = size_in_bytes;
- unsigned char *data = bool_vector_uchar_data (obj);
-
- int len = sprintf (buf, "#&%"pI"d\"", size);
- strout (buf, len, len, printcharfun);
-
- /* Don't print more bytes than the specified maximum.
- Negative values of print-length are invalid. Treat them
- like a print-length of nil. */
- if (FIXNATP (Vprint_length)
- && XFIXNAT (Vprint_length) < size_in_bytes)
- size_in_bytes = XFIXNAT (Vprint_length);
-
- for (ptrdiff_t i = 0; i < size_in_bytes; i++)
- {
- maybe_quit ();
- unsigned char c = data[i];
- if (c == '\n' && print_escape_newlines)
- print_c_string ("\\n", printcharfun);
- else if (c == '\f' && print_escape_newlines)
- print_c_string ("\\f", printcharfun);
- else if (c > '\177'
- || (print_escape_control_characters && c_iscntrl (c)))
- {
- /* Use octal escapes to avoid encoding issues. */
- octalout (c, data, i + 1, size_in_bytes, printcharfun);
- }
- else
- {
- if (c == '\"' || c == '\\')
- printchar ('\\', printcharfun);
- printchar (c, printcharfun);
- }
- }
-
- if (size_in_bytes < real_size_in_bytes)
- print_c_string (" ...", printcharfun);
- printchar ('\"', printcharfun);
- }
- break;
-
case PVEC_SUBR:
print_c_string ("#<subr ", printcharfun);
print_c_string (XSUBR (obj)->symbol_name, printcharfun);
@@ -1578,79 +1766,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag,
}
break;
- case PVEC_HASH_TABLE:
- {
- struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
- /* Implement a readable output, e.g.:
- #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */
- /* Always print the size. */
- int len = sprintf (buf, "#s(hash-table size %"pD"d",
- HASH_TABLE_SIZE (h));
- strout (buf, len, len, printcharfun);
-
- if (!NILP (h->test.name))
- {
- print_c_string (" test ", printcharfun);
- print_object (h->test.name, printcharfun, escapeflag);
- }
-
- if (!NILP (h->weak))
- {
- print_c_string (" weakness ", printcharfun);
- print_object (h->weak, printcharfun, escapeflag);
- }
-
- print_c_string (" rehash-size ", printcharfun);
- print_object (Fhash_table_rehash_size (obj),
- printcharfun, escapeflag);
-
- print_c_string (" rehash-threshold ", printcharfun);
- print_object (Fhash_table_rehash_threshold (obj),
- printcharfun, escapeflag);
-
- if (h->purecopy)
- {
- print_c_string (" purecopy ", printcharfun);
- print_object (h->purecopy ? Qt : Qnil, printcharfun, escapeflag);
- }
-
- print_c_string (" data ", printcharfun);
-
- /* Print the data here as a plist. */
- ptrdiff_t real_size = HASH_TABLE_SIZE (h);
- ptrdiff_t size = h->count;
-
- /* Don't print more elements than the specified maximum. */
- if (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size)
- size = XFIXNAT (Vprint_length);
-
- printchar ('(', printcharfun);
- ptrdiff_t j = 0;
- for (ptrdiff_t i = 0; i < real_size; i++)
- {
- Lisp_Object key = HASH_KEY (h, i);
- if (!EQ (key, Qunbound))
- {
- if (j++) printchar (' ', printcharfun);
- print_object (key, printcharfun, escapeflag);
- printchar (' ', printcharfun);
- print_object (HASH_VALUE (h, i), printcharfun, escapeflag);
- if (j == size)
- break;
- }
- }
-
- if (j < h->count)
- {
- if (j)
- printchar (' ', printcharfun);
- print_c_string ("...", printcharfun);
- }
-
- print_c_string ("))", printcharfun);
- }
- break;
-
case PVEC_BUFFER:
if (!BUFFER_LIVE_P (XBUFFER (obj)))
print_c_string ("#<killed buffer>", printcharfun);
@@ -1756,89 +1871,6 @@ print_vectorlike (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag,
printchar ('>', printcharfun);
break;
- case PVEC_RECORD:
- {
- ptrdiff_t size = PVSIZE (obj);
-
- /* Don't print more elements than the specified maximum. */
- ptrdiff_t n
- = (FIXNATP (Vprint_length) && XFIXNAT (Vprint_length) < size
- ? XFIXNAT (Vprint_length) : size);
-
- print_c_string ("#s(", printcharfun);
- for (ptrdiff_t i = 0; i < n; i ++)
- {
- if (i) printchar (' ', printcharfun);
- print_object (AREF (obj, i), printcharfun, escapeflag);
- }
- if (n < size)
- print_c_string (" ...", printcharfun);
- printchar (')', printcharfun);
- }
- break;
-
- case PVEC_SUB_CHAR_TABLE:
- case PVEC_COMPILED:
- case PVEC_CHAR_TABLE:
- case PVEC_NORMAL_VECTOR:
- {
- ptrdiff_t size = ASIZE (obj);
- if (COMPILEDP (obj))
- {
- printchar ('#', printcharfun);
- size &= PSEUDOVECTOR_SIZE_MASK;
- }
- if (CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj))
- {
- /* Print a char-table as if it were a vector,
- lumping the parent and default slots in with the
- character slots. But add #^ as a prefix. */
-
- /* Make each lowest sub_char_table start a new line.
- Otherwise we'll make a line extremely long, which
- results in slow redisplay. */
- if (SUB_CHAR_TABLE_P (obj)
- && XSUB_CHAR_TABLE (obj)->depth == 3)
- printchar ('\n', printcharfun);
- print_c_string ("#^", printcharfun);
- if (SUB_CHAR_TABLE_P (obj))
- printchar ('^', printcharfun);
- size &= PSEUDOVECTOR_SIZE_MASK;
- }
- if (size & PSEUDOVECTOR_FLAG)
- return false;
-
- printchar ('[', printcharfun);
-
- int idx = SUB_CHAR_TABLE_P (obj) ? SUB_CHAR_TABLE_OFFSET : 0;
- Lisp_Object tem;
- ptrdiff_t real_size = size;
-
- /* For a sub char-table, print heading non-Lisp data first. */
- if (SUB_CHAR_TABLE_P (obj))
- {
- int i = sprintf (buf, "%d %d", XSUB_CHAR_TABLE (obj)->depth,
- XSUB_CHAR_TABLE (obj)->min_char);
- strout (buf, i, i, printcharfun);
- }
-
- /* Don't print more elements than the specified maximum. */
- if (FIXNATP (Vprint_length)
- && XFIXNAT (Vprint_length) < size)
- size = XFIXNAT (Vprint_length);
-
- for (int i = idx; i < size; i++)
- {
- if (i) printchar (' ', printcharfun);
- tem = AREF (obj, i);
- print_object (tem, printcharfun, escapeflag);
- }
- if (size < real_size)
- print_c_string (" ...", printcharfun);
- printchar (']', printcharfun);
- }
- break;
-
#ifdef HAVE_MODULES
case PVEC_MODULE_FUNCTION:
{
@@ -2464,4 +2496,19 @@ priorities. Values other than nil or t are also treated
as
print_prune_charset_plist = Qnil;
staticpro (&print_prune_charset_plist);
+
+ DEFVAR_LISP ("print-unreadable-function", Vprint_unreadable_function,
+ doc: /* Function called when printing unreadable objects.
+By default, Emacs printing functions (like `prin1') print unreadable
+objects like \"#<...>\", where \"...\" describes the object (for
+instance, \"#<marker in no buffer>\"). If this variable is non-nil,
+it should be a function which will be called to print the object instead.
+
+It will be called with two arguments: The object to be printed, and
+noescape (see `prin1-to-string'). If this function returns nil, the
+object will be printed as normal. If it returns a string, that string
+will then be printed. If the function returns anything else, the
+object will not be printed. */);
+ Vprint_unreadable_function = Qnil;
+ DEFSYM (Qprint_unreadable_function, "print-unreadable-function");
}
diff --git a/test/src/print-tests.el b/test/src/print-tests.el
index 4c7b339e0c..1ef0caf1a4 100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@ -406,5 +406,16 @@ otherwise, use a different charset."
(should (equal printed-nonprints
"(55296 57343 778 65535 8194 8204)"))))
+(ert-deftest test-unreadable ()
+ (should (equal (prin1-to-string (make-marker)) "#<marker in no buffer>"))
+ (let ((print-unreadable-function
+ (lambda (_object _escape)
+ "hello")))
+ (should (equal (prin1-to-string (make-marker)) "hello")))
+ (let ((print-unreadable-function
+ (lambda (_object _escape)
+ t)))
+ (should (equal (prin1-to-string (make-marker)) ""))))
+
(provide 'print-tests)
;;; print-tests.el ends here