From 57c4bc146b7e17b6f662604047cb5d10982f962c Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 23 Jul 2018 00:57:06 -0700 Subject: =?UTF-8?q?0x%x=20=E2=86=92=20%#x=20in=20elisp=20formats?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/emacs-lisp/cl-print.el (cl-print-object): * lisp/profiler.el (profiler-format-entry): * lisp/progmodes/hideif.el (hif-evaluate-macro): Prefer %#x to 0x%x in elisp formats when formatting arbitrary integers, as it’ll produce more-readable output with negative args should we change how negative values are printed with %x. --- lisp/emacs-lisp/cl-print.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp/cl-print.el') diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 1eae8faf236..bf5b1e878d5 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -109,7 +109,7 @@ call other entry points instead, such as `cl-prin1'." (princ (hash-table-count object) stream) (princ "/" stream) (princ (hash-table-size object) stream) - (princ (format " 0x%x" (sxhash object)) stream) + (princ (format " %#x" (sxhash object)) stream) (princ ">" stream)) (define-button-type 'help-byte-code @@ -166,7 +166,7 @@ into a button whose action shows the function's disassembly.") (let ((button-start (and cl-print-compiled-button (bufferp stream) (with-current-buffer stream (point))))) - (princ (format "#" (sxhash object)) stream) + (princ (format "#" (sxhash object)) stream) (when (eq cl-print-compiled 'static) (princ " " stream) (cl-print-object (aref object 2) stream)) -- cgit v1.2.1 From eba16e5e5829c244d313101a769d4988946387d9 Mon Sep 17 00:00:00 2001 From: Gemini Lasswell Date: Fri, 15 Jun 2018 10:23:58 -0700 Subject: Support ellipsis expansion in cl-print * lisp/emacs-lisp/cl-print.el (cl-print-object-contents): New generic method. (cl-print-object-contents) : New methods. (cl-print-object) : Use cl-print-insert-ellipsis. (cl-print-object) : Elide whole object if print-level exceeded. Use cl-print-insert-ellipsis. (cl-print-insert-ellipsis, cl-print-propertize-ellipsis) (cl-print-expand-ellipsis): New functions. * test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-4): Test printing of objects nested in other objects. (cl-print-tests-strings, cl-print-tests-ellipsis-cons) (cl-print-tests-ellipsis-vector, cl-print-tests-ellipsis-struct) (cl-print-tests-ellipsis-circular): New tests. (cl-print-tests-check-ellipsis-expansion) (cl-print-tests-check-ellipsis-expansion-rx): New functions. --- lisp/emacs-lisp/cl-print.el | 155 ++++++++++++++++++++++++++++++++++++++------ 1 file changed, 134 insertions(+), 21 deletions(-) (limited to 'lisp/emacs-lisp/cl-print.el') diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index bf5b1e878d5..e638e58275a 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -55,10 +55,19 @@ call other entry points instead, such as `cl-prin1'." ;; we should only use it for objects which don't have nesting. (prin1 object stream)) +(cl-defgeneric cl-print-object-contents (_object _start _stream) + "Dispatcher to print the contents of OBJECT on STREAM. +Print the contents starting with the item at START, without +delimiters." + ;; Every cl-print-object method which can print an ellipsis should + ;; have a matching cl-print-object-contents method to expand an + ;; ellipsis. + (error "Missing cl-print-object-contents method")) + (cl-defmethod cl-print-object ((object cons) stream) (if (and cl-print--depth (natnump print-level) (> cl-print--depth print-level)) - (princ "..." stream) + (cl-print-insert-ellipsis object 0 stream) (let ((car (pop object)) (count 1)) (if (and print-quoted @@ -84,23 +93,60 @@ call other entry points instead, such as `cl-prin1'." (princ " " stream) (if (or (not (natnump print-length)) (> print-length count)) (cl-print-object (pop object) stream) - (princ "..." stream) + (cl-print-insert-ellipsis object print-length stream) (setq object nil)) (cl-incf count)) (when object (princ " . " stream) (cl-print-object object stream)) (princ ")" stream))))) +(cl-defmethod cl-print-object-contents ((object cons) _start stream) + (let ((count 0)) + (while (and (consp object) + (not (cond + (cl-print--number-table + (numberp (gethash object cl-print--number-table))) + ((memq object cl-print--currently-printing)) + (t (push object cl-print--currently-printing) + nil)))) + (unless (zerop count) + (princ " " stream)) + (if (or (not (natnump print-length)) (> print-length count)) + (cl-print-object (pop object) stream) + (cl-print-insert-ellipsis object print-length stream) + (setq object nil)) + (cl-incf count)) + (when object + (princ " . " stream) (cl-print-object object stream)))) + (cl-defmethod cl-print-object ((object vector) stream) - (princ "[" stream) - (let ((count (length object))) - (dotimes (i (if (natnump print-length) - (min print-length count) count)) - (unless (zerop i) (princ " " stream)) - (cl-print-object (aref object i) stream)) - (when (and (natnump print-length) (< print-length count)) - (princ " ..." stream))) - (princ "]" stream)) + (if (and cl-print--depth (natnump print-level) + (> cl-print--depth print-level)) + (cl-print-insert-ellipsis object 0 stream) + (princ "[" stream) + (let* ((len (length object)) + (limit (if (natnump print-length) + (min print-length len) len))) + (dotimes (i limit) + (unless (zerop i) (princ " " stream)) + (cl-print-object (aref object i) stream)) + (when (< limit len) + (princ " " stream) + (cl-print-insert-ellipsis object limit stream))) + (princ "]" stream))) + +(cl-defmethod cl-print-object-contents ((object vector) start stream) + (let* ((len (length object)) + (limit (if (natnump print-length) + (min (+ start print-length) len) len)) + (i start)) + (while (< i limit) + (unless (= i start) (princ " " stream)) + (cl-print-object (aref object i) stream) + (cl-incf i)) + (when (< limit len) + (princ " " stream) + (cl-print-insert-ellipsis object limit stream)))) (cl-defmethod cl-print-object ((object hash-table) stream) (princ "# cl-print--depth print-level)) + (cl-print-insert-ellipsis object 0 stream) + (princ "#s(" stream) + (let* ((class (cl-find-class (type-of object))) + (slots (cl--struct-class-slots class)) + (len (length slots)) + (limit (if (natnump print-length) + (min print-length len) len))) + (princ (cl--struct-class-name class) stream) + (dotimes (i limit) + (let ((slot (aref slots i))) + (princ " :" stream) + (princ (cl--slot-descriptor-name slot) stream) + (princ " " stream) + (cl-print-object (aref object (1+ i)) stream))) + (when (< limit len) + (princ " " stream) + (cl-print-insert-ellipsis object limit stream))) + (princ ")" stream))) + +(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream) (let* ((class (cl-find-class (type-of object))) (slots (cl--struct-class-slots class)) - (count (length slots))) - (princ (cl--struct-class-name class) stream) - (dotimes (i (if (natnump print-length) - (min print-length count) count)) + (len (length slots)) + (limit (if (natnump print-length) + (min (+ start print-length) len) len)) + (i start)) + (while (< i limit) (let ((slot (aref slots i))) - (princ " :" stream) + (unless (= i start) (princ " " stream)) + (princ ":" stream) (princ (cl--slot-descriptor-name slot) stream) (princ " " stream) - (cl-print-object (aref object (1+ i)) stream))) - (when (and (natnump print-length) (< print-length count)) - (princ " ..." stream))) - (princ ")" stream)) + (cl-print-object (aref object (1+ i)) stream)) + (cl-incf i)) + (when (< limit len) + (princ " " stream) + (cl-print-insert-ellipsis object limit stream)))) + ;;; Circularity and sharing. @@ -291,6 +362,48 @@ into a button whose action shows the function's disassembly.") (cl-print--find-sharing object print-number-table))) print-number-table)) +(defun cl-print-insert-ellipsis (object start stream) + "Print \"...\" to STREAM with the `cl-print-ellipsis' text property. +Save state in the text property in order to print the elided part +of OBJECT later. START should be 0 if the whole OBJECT is being +elided, otherwise it should be an index or other pointer into the +internals of OBJECT which can be passed to +`cl-print-object-contents' at a future time." + (unless stream (setq stream standard-output)) + (let ((ellipsis-start (and (bufferp stream) + (with-current-buffer stream (point))))) + (princ "..." stream) + (when ellipsis-start + (with-current-buffer stream + (cl-print-propertize-ellipsis object start ellipsis-start (point) + stream))))) + +(defun cl-print-propertize-ellipsis (object start beg end stream) + "Add the `cl-print-ellipsis' property between BEG and END. +STREAM should be a buffer. OBJECT and START are as described in +`cl-print-insert-ellipsis'." + (let ((value (list object start cl-print--number-table + cl-print--currently-printing))) + (with-current-buffer stream + (put-text-property beg end 'cl-print-ellipsis value stream)))) + +;;;###autoload +(defun cl-print-expand-ellipsis (value stream) + "Print the expansion of an ellipsis to STREAM. +VALUE should be the value of the `cl-print-ellipsis' text property +which was attached to the ellipsis by `cl-prin1'." + (let ((cl-print--depth 1) + (object (nth 0 value)) + (start (nth 1 value)) + (cl-print--number-table (nth 2 value)) + (print-number-table (nth 2 value)) + (cl-print--currently-printing (nth 3 value))) + (when (eq object (car cl-print--currently-printing)) + (pop cl-print--currently-printing)) + (if (equal start 0) + (cl-print-object object stream) + (cl-print-object-contents object start stream)))) + ;;;###autoload (defun cl-prin1 (object &optional stream) "Print OBJECT on STREAM according to its type. -- cgit v1.2.1 From 8a7620955b4d859caecd9a5dc9f2a986baf994fd Mon Sep 17 00:00:00 2001 From: Gemini Lasswell Date: Fri, 15 Jun 2018 10:26:13 -0700 Subject: Add methods for strings to cl-print * lisp/emacs-lisp/cl-print.el (cl-print-object) : New method. (cl-print-object-contents) : New method. (cl-print--find-sharing): Look in string property lists. * test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-3): Test printing of long strings. (cl-print-tests-4): Test printing of strings nested in other objects. (cl-print-tests-strings, cl-print-tests-ellipsis-string): New tests. --- lisp/emacs-lisp/cl-print.el | 102 +++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 100 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp/cl-print.el') diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index e638e58275a..337efa465a0 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -285,6 +285,95 @@ into a button whose action shows the function's disassembly.") (princ " " stream) (cl-print-insert-ellipsis object limit stream)))) +(cl-defmethod cl-print-object ((object string) stream) + (unless stream (setq stream standard-output)) + (let* ((has-properties (or (text-properties-at 0 object) + (next-property-change 0 object))) + (len (length object)) + (limit (if (natnump print-length) (min print-length len) len))) + (if (and has-properties + cl-print--depth + (natnump print-level) + (> cl-print--depth print-level)) + (cl-print-insert-ellipsis object 0 stream) + ;; Print all or part of the string + (when has-properties + (princ "#(" stream)) + (if (= limit len) + (prin1 (if has-properties (substring-no-properties object) object) + stream) + (let ((part (concat (substring-no-properties object 0 limit) "..."))) + (prin1 part stream) + (when (bufferp stream) + (with-current-buffer stream + (cl-print-propertize-ellipsis object limit + (- (point) 4) + (- (point) 1) stream))))) + ;; Print the property list. + (when has-properties + (let* ((interval-limit (and (natnump print-length) + (max 1 (/ print-length 3)))) + (interval-count 0) + (start-pos (if (text-properties-at 0 object) + 0 (next-property-change 0 object))) + (end-pos (next-property-change start-pos object len))) + (while (and (or (null interval-limit) + (< interval-count interval-limit)) + (< start-pos len)) + (let ((props (text-properties-at start-pos object))) + (when props + (princ " " stream) (princ start-pos stream) + (princ " " stream) (princ end-pos stream) + (princ " " stream) (cl-print-object props stream) + (cl-incf interval-count)) + (setq start-pos end-pos + end-pos (next-property-change start-pos object len)))) + (when (< start-pos len) + (princ " " stream) + (cl-print-insert-ellipsis object (list start-pos) stream))) + (princ ")" stream))))) + +(cl-defmethod cl-print-object-contents ((object string) start stream) + ;; If START is an integer, it is an index into the string, and the + ;; ellipsis that needs to be expanded is part of the string. If + ;; START is a cons, its car is an index into the string, and the + ;; ellipsis that needs to be expanded is in the property list. + (let* ((len (length object))) + (if (atom start) + ;; Print part of the string. + (let* ((limit (if (natnump print-length) + (min (+ start print-length) len) len)) + (substr (substring-no-properties object start limit)) + (printed (prin1-to-string substr)) + (trimmed (substring printed 1 (1- (length printed))))) + (princ trimmed) + (when (< limit len) + (cl-print-insert-ellipsis object limit stream))) + + ;; Print part of the property list. + (let* ((first t) + (interval-limit (and (natnump print-length) + (max 1 (/ print-length 3)))) + (interval-count 0) + (start-pos (car start)) + (end-pos (next-property-change start-pos object len))) + (while (and (or (null interval-limit) + (< interval-count interval-limit)) + (< start-pos len)) + (let ((props (text-properties-at start-pos object))) + (when props + (if first + (setq first nil) + (princ " " stream)) + (princ start-pos stream) + (princ " " stream) (princ end-pos stream) + (princ " " stream) (cl-print-object props stream) + (cl-incf interval-count)) + (setq start-pos end-pos + end-pos (next-property-change start-pos object len)))) + (when (< start-pos len) + (princ " " stream) + (cl-print-insert-ellipsis object (list start-pos) stream)))))) ;;; Circularity and sharing. @@ -346,8 +435,17 @@ into a button whose action shows the function's disassembly.") (push cdr stack) (push car stack)) ((pred stringp) - ;; We presumably won't print its text-properties. - nil) + (let* ((len (length object)) + (start (if (text-properties-at 0 object) + 0 (next-property-change 0 object))) + (end (and start + (next-property-change start object len)))) + (while (and start (< start len)) + (let ((props (text-properties-at start object))) + (when props + (push props stack)) + (setq start end + end (next-property-change start object len)))))) ((or (pred arrayp) (pred byte-code-function-p)) ;; FIXME: Inefficient for char-tables! (dotimes (i (length object)) -- cgit v1.2.1 From a3ba34aeac1b41ca5d12bfe5644d3fdfa894ddda Mon Sep 17 00:00:00 2001 From: Gemini Lasswell Date: Sat, 14 Jul 2018 08:05:51 -0700 Subject: Add new command to expand all "..."s in a backtrace frame * doc/lispref/debugging.texi (Backtraces): Document new keybinding. * lisp/emacs-lisp/backtrace.el (backtrace-line-length): Add the option of unlimited line length. (backtrace--match-ellipsis-in-string): Add a comment to explain why this function is necessary. (backtrace-mode-map): Add keybinding for 'backtrace-expand-ellipses'. (backtrace-expand-ellipsis): Use 'cl-print-to-string-with-limit'. (backtrace-expand-ellipses): New command. (backtrace-print-to-string): Use 'cl-print-to-string-with-limit'. Tag the printed forms with a gensym instead of the values of print-length and print-level. (backtrace--print): Add 'stream' argument. * test/lisp/emacs-lisp/backtrace-tests.el (backtrace-tests--expand-ellipsis): Make the test less dependent on the implementation. (backtrace-tests--expand-ellipses): New test. Move the fitting of a printed representation into a limited number of characters using appropriate values of print-level and print-length from 'backtrace-print-to-string' to cl-print.el for future use by other parts of Emacs. * lisp/emacs-lisp/cl-print.el (cl-print-to-string-with-limit): New function. * test/lisp/emacs-lisp/cl-print-tests.el (cl-print-tests-print-to-string-with-limit): New test. --- lisp/emacs-lisp/cl-print.el | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) (limited to 'lisp/emacs-lisp/cl-print.el') diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 337efa465a0..c63f5ac005c 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -524,5 +524,45 @@ node `(elisp)Output Variables'." (cl-prin1 object (current-buffer)) (buffer-string))) +;;;###autoload +(defun cl-print-to-string-with-limit (print-function value limit) + "Return a string containing a printed representation of VALUE. +Attempt to get the length of the returned string under LIMIT +characters with appropriate settings of `print-level' and +`print-length.' Use PRINT-FUNCTION to print, which should take +the arguments VALUE and STREAM and which should respect +`print-length' and `print-level'. LIMIT may be nil or zero in +which case PRINT-FUNCTION will be called with `print-level' and +`print-length' bound to nil. + +Use this function with `cl-prin1' to print an object, +abbreviating it with ellipses to fit within a size limit. Use +this function with `cl-prin1-expand-ellipsis' to expand an +ellipsis, abbreviating the expansion to stay within a size +limit." + (setq limit (and (natnump limit) + (not (zerop limit)) + limit)) + ;; Since this is used by the debugger when stack space may be + ;; limited, if you increase print-level here, add more depth in + ;; call_debugger (bug#31919). + (let* ((print-length (when limit (min limit 50))) + (print-level (when limit (min 8 (truncate (log limit))))) + (delta (when limit + (max 1 (truncate (/ print-length print-level)))))) + (with-temp-buffer + (catch 'done + (while t + (erase-buffer) + (funcall print-function value (current-buffer)) + ;; Stop when either print-level is too low or the value is + ;; successfully printed in the space allowed. + (when (or (not limit) + (< (- (point-max) (point-min)) limit) + (= print-level 2)) + (throw 'done (buffer-string))) + (cl-decf print-level) + (cl-decf print-length delta)))))) + (provide 'cl-print) ;;; cl-print.el ends here -- cgit v1.2.1