From e4d2a7894b4294a31a4311fa81a3644ea06028e5 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 22 Jan 2022 15:06:33 +0100 Subject: [PATCH] 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 c6b3397ae11..5ab6cf5777b 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{} "#" +@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 87b009d5e24..02e7a462a18 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 a3c9011215f..4d9feb55ac2 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 ("#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 ("#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 ("#", 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, \"#\"). 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 4c7b339e0c6..1ef0caf1a46 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)) "#")) + (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 -- 2.39.5