* lisp/emacs-lisp/macroexp.el (macroexpand-all-1): Tolerate errors during
[emacs.git] / lisp / emacs-lisp / cust-print.el
blobb456d59e8dacf3752d29c6c517f1125309d9d783
1 ;;; cust-print.el --- handles print-level and print-circle
3 ;; Copyright (C) 1992, 2001-2012 Free Software Foundation, Inc.
5 ;; Author: Daniel LaLiberte <liberte@holonexus.org>
6 ;; Adapted-By: ESR
7 ;; Keywords: extensions
9 ;; LCD Archive Entry:
10 ;; cust-print|Daniel LaLiberte|liberte@holonexus.org
11 ;; |Handle print-level, print-circle and more.
13 ;; This file is part of GNU Emacs.
15 ;; GNU Emacs is free software: you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation, either version 3 of the License, or
18 ;; (at your option) any later version.
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 ;; GNU General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 ;;; Commentary:
30 ;; This package provides a general print handler for prin1 and princ
31 ;; that supports print-level and print-circle, and by the way,
32 ;; print-length since the standard routines are being replaced. Also,
33 ;; to print custom types constructed from lists and vectors, use
34 ;; custom-print-list and custom-print-vector. See the documentation
35 ;; strings of these variables for more details.
37 ;; If the results of your expressions contain circular references to
38 ;; other parts of the same structure, the standard Emacs print
39 ;; subroutines may fail to print with an untrappable error,
40 ;; "Apparently circular structure being printed". If you only use cdr
41 ;; circular lists (where cdrs of lists point back; what is the right
42 ;; term here?), you can limit the length of printing with
43 ;; print-length. But car circular lists and circular vectors generate
44 ;; the above mentioned error in Emacs version 18. Version
45 ;; 19 supports print-level, but it is often useful to get a better
46 ;; print representation of circular and shared structures; the print-circle
47 ;; option may be used to print more concise representations.
49 ;; There are three main ways to use this package. First, you may
50 ;; replace prin1, princ, and some subroutines that use them by calling
51 ;; install-custom-print so that any use of these functions in
52 ;; Lisp code will be affected; you can later reset with
53 ;; uninstall-custom-print. Second, you may temporarily install
54 ;; these functions with the macro with-custom-print. Third, you
55 ;; could call the custom routines directly, thus only affecting the
56 ;; printing that requires them.
58 ;; Note that subroutines which call print subroutines directly will
59 ;; not use the custom print functions. In particular, the evaluation
60 ;; functions like eval-region call the print subroutines directly.
61 ;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a
62 ;; circular list rather than an array, aref calls error directly which
63 ;; will jump to the top level instead of printing the circular list.
65 ;; Uninterned symbols are recognized when print-circle is non-nil,
66 ;; but they are not printed specially here. Use the cl-packages package
67 ;; to print according to print-gensym.
69 ;; Obviously the right way to implement this custom-print facility is
70 ;; in C or with hooks into the standard printer. Please volunteer
71 ;; since I don't have the time or need. More CL-like printing
72 ;; capabilities could be added in the future.
74 ;; Implementation design: we want to use the same list and vector
75 ;; processing algorithm for all versions of prin1 and princ, since how
76 ;; the processing is done depends on print-length, print-level, and
77 ;; print-circle. For circle printing, a preprocessing step is
78 ;; required before the final printing. Thanks to Jamie Zawinski
79 ;; for motivation and algorithms.
82 ;;; Code:
84 (defgroup cust-print nil
85 "Handles print-level and print-circle."
86 :prefix "print-"
87 :group 'lisp
88 :group 'extensions)
90 ;; If using cl-packages:
92 '(defpackage "cust-print"
93 (:nicknames "CP" "custom-print")
94 (:use "el")
95 (:export
96 print-level
97 print-circle
99 custom-print-install
100 custom-print-uninstall
101 custom-print-installed-p
102 with-custom-print
104 custom-prin1
105 custom-princ
106 custom-prin1-to-string
107 custom-print
108 custom-format
109 custom-message
110 custom-error
112 custom-printers
113 add-custom-printer
116 '(in-package cust-print)
118 ;; Emacs 18 doesn't have defalias.
119 ;; Provide def for byte compiler.
120 (eval-and-compile
121 (or (fboundp 'defalias) (fset 'defalias 'fset)))
124 ;; Variables:
125 ;;=========================================================
127 ;;(defvar print-length nil
128 ;; "*Controls how many elements of a list, at each level, are printed.
129 ;;This is defined by emacs.")
131 (defcustom print-level nil
132 "Controls how many levels deep a nested data object will print.
134 If nil, printing proceeds recursively and may lead to
135 max-lisp-eval-depth being exceeded or an error may occur:
136 `Apparently circular structure being printed.'
137 Also see `print-length' and `print-circle'.
139 If non-nil, components at levels equal to or greater than `print-level'
140 are printed simply as `#'. The object to be printed is at level 0,
141 and if the object is a list or vector, its top-level components are at
142 level 1."
143 :type '(choice (const nil) integer)
144 :group 'cust-print)
147 (defcustom print-circle nil
148 "Controls the printing of recursive structures.
150 If nil, printing proceeds recursively and may lead to
151 `max-lisp-eval-depth' being exceeded or an error may occur:
152 \"Apparently circular structure being printed.\" Also see
153 `print-length' and `print-level'.
155 If non-nil, shared substructures anywhere in the structure are printed
156 with `#N=' before the first occurrence (in the order of the print
157 representation) and `#N#' in place of each subsequent occurrence,
158 where N is a positive decimal integer.
160 There is no way to read this representation in standard Emacs,
161 but if you need to do so, try the cl-read.el package."
162 :type 'boolean
163 :group 'cust-print)
166 (defcustom custom-print-vectors nil
167 "Non-nil if printing of vectors should obey `print-level' and `print-length'."
168 :type 'boolean
169 :group 'cust-print)
172 ;; Custom printers
173 ;;==========================================================
175 (defvar custom-printers nil
176 ;; e.g. '((symbolp . pkg::print-symbol))
177 "An alist for custom printing of any type.
178 Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true
179 for an object, then PRINTER is called with the object.
180 PRINTER should print to `standard-output' using cust-print-original-princ
181 if the standard printer is sufficient, or cust-print-prin for complex things.
182 The PRINTER should return the object being printed.
184 Don't modify this variable directly. Use `add-custom-printer' and
185 `delete-custom-printer'")
186 ;; Should cust-print-original-princ and cust-print-prin be exported symbols?
187 ;; Or should the standard printers functions be replaced by
188 ;; CP ones in Emacs Lisp so that CP internal functions need not be called?
190 (defun add-custom-printer (pred printer)
191 "Add a pair of PREDICATE and PRINTER to `custom-printers'.
192 Any pair that has the same PREDICATE is first removed."
193 (setq custom-printers (cons (cons pred printer)
194 (delq (assq pred custom-printers)
195 custom-printers)))
196 ;; Rather than updating here, we could wait until cust-print-top-level is called.
197 (cust-print-update-custom-printers))
199 (defun delete-custom-printer (pred)
200 "Delete the custom printer associated with PREDICATE."
201 (setq custom-printers (delq (assq pred custom-printers)
202 custom-printers))
203 (cust-print-update-custom-printers))
206 (defun cust-print-use-custom-printer (object)
207 ;; Default function returns nil.
208 nil)
210 (defun cust-print-update-custom-printers ()
211 ;; Modify the definition of cust-print-use-custom-printer
212 (defalias 'cust-print-use-custom-printer
213 ;; We don't really want to require the byte-compiler.
214 ;; (byte-compile
215 `(lambda (object)
216 (cond
217 ,@(mapcar (function
218 (lambda (pair)
219 `((,(car pair) object)
220 (,(cdr pair) object))))
221 custom-printers)
222 ;; Otherwise return nil.
223 (t nil)
225 ;; )
229 ;; Saving and restoring emacs printing routines.
230 ;;====================================================
232 (defun cust-print-set-function-cell (symbol-pair)
233 (defalias (car symbol-pair)
234 (symbol-function (car (cdr symbol-pair)))))
236 (defun cust-print-original-princ (object &optional stream)) ; dummy def
238 ;; Save emacs routines.
239 (if (not (fboundp 'cust-print-original-prin1))
240 (mapc 'cust-print-set-function-cell
241 '((cust-print-original-prin1 prin1)
242 (cust-print-original-princ princ)
243 (cust-print-original-print print)
244 (cust-print-original-prin1-to-string prin1-to-string)
245 (cust-print-original-format format)
246 (cust-print-original-message message)
247 (cust-print-original-error error))))
250 (defun custom-print-install ()
251 "Replace print functions with general, customizable, Lisp versions.
252 The Emacs subroutines are saved away, and you can reinstall them
253 by running `custom-print-uninstall'."
254 (interactive)
255 (mapc 'cust-print-set-function-cell
256 '((prin1 custom-prin1)
257 (princ custom-princ)
258 (print custom-print)
259 (prin1-to-string custom-prin1-to-string)
260 (format custom-format)
261 (message custom-message)
262 (error custom-error)
266 (defun custom-print-uninstall ()
267 "Reset print functions to their Emacs subroutines."
268 (interactive)
269 (mapc 'cust-print-set-function-cell
270 '((prin1 cust-print-original-prin1)
271 (princ cust-print-original-princ)
272 (print cust-print-original-print)
273 (prin1-to-string cust-print-original-prin1-to-string)
274 (format cust-print-original-format)
275 (message cust-print-original-message)
276 (error cust-print-original-error)
280 (defalias 'custom-print-funcs-installed-p 'custom-print-installed-p)
281 (defun custom-print-installed-p ()
282 "Return t if custom-print is currently installed, nil otherwise."
283 (eq (symbol-function 'custom-prin1) (symbol-function 'prin1)))
285 (put 'with-custom-print-funcs 'edebug-form-spec '(body))
286 (put 'with-custom-print 'edebug-form-spec '(body))
288 (defalias 'with-custom-print-funcs 'with-custom-print)
289 (defmacro with-custom-print (&rest body)
290 "Temporarily install the custom print package while executing BODY."
291 `(unwind-protect
292 (progn
293 (custom-print-install)
294 ,@body)
295 (custom-print-uninstall)))
298 ;; Lisp replacements for prin1 and princ, and for some subrs that use them
299 ;;===============================================================
300 ;; - so far only the printing and formatting subrs.
302 (defun custom-prin1 (object &optional stream)
303 "Output the printed representation of OBJECT, any Lisp object.
304 Quoting characters are printed when needed to make output that `read'
305 can handle, whenever this is possible.
306 Output stream is STREAM, or value of `standard-output' (which see).
308 This is the custom-print replacement for the standard `prin1'. It
309 uses the appropriate printer depending on the values of `print-level'
310 and `print-circle' (which see)."
311 (cust-print-top-level object stream 'cust-print-original-prin1))
314 (defun custom-princ (object &optional stream)
315 "Output the printed representation of OBJECT, any Lisp object.
316 No quoting characters are used; no delimiters are printed around
317 the contents of strings.
318 Output stream is STREAM, or value of `standard-output' (which see).
320 This is the custom-print replacement for the standard `princ'."
321 (cust-print-top-level object stream 'cust-print-original-princ))
324 (defun custom-prin1-to-string (object &optional noescape)
325 "Return a string containing the printed representation of OBJECT,
326 any Lisp object. Quoting characters are used when needed to make output
327 that `read' can handle, whenever this is possible, unless the optional
328 second argument NOESCAPE is non-nil.
330 This is the custom-print replacement for the standard `prin1-to-string'."
331 (let ((buf (get-buffer-create " *custom-print-temp*")))
332 ;; We must erase the buffer before printing in case an error
333 ;; occurred during the last prin1-to-string and we are in debugger.
334 (with-current-buffer buf
335 (erase-buffer))
336 ;; We must be in the current-buffer when the print occurs.
337 (if noescape
338 (custom-princ object buf)
339 (custom-prin1 object buf))
340 (with-current-buffer buf
341 (buffer-string)
342 ;; We could erase the buffer again, but why bother?
346 (defun custom-print (object &optional stream)
347 "Output the printed representation of OBJECT, with newlines around it.
348 Quoting characters are printed when needed to make output that `read'
349 can handle, whenever this is possible.
350 Output stream is STREAM, or value of `standard-output' (which see).
352 This is the custom-print replacement for the standard `print'."
353 (cust-print-original-princ "\n" stream)
354 (custom-prin1 object stream)
355 (cust-print-original-princ "\n" stream))
358 (defun custom-format (fmt &rest args)
359 "Format a string out of a control-string and arguments.
360 The first argument is a control string. It, and subsequent arguments
361 substituted into it, become the value, which is a string.
362 It may contain %s or %d or %c to substitute successive following arguments.
363 %s means print an argument as a string, %d means print as number in decimal,
364 %c means print a number as a single character.
365 The argument used by %s must be a string or a symbol;
366 the argument used by %d, %b, %o, %x or %c must be a number.
368 This is the custom-print replacement for the standard `format'. It
369 calls the Emacs `format' after first making strings for list,
370 vector, or symbol args. The format specification for such args should
371 be `%s' in any case, so a string argument will also work. The string
372 is generated with `custom-prin1-to-string', which quotes quotable
373 characters."
374 (apply 'cust-print-original-format fmt
375 (mapcar (function (lambda (arg)
376 (if (or (listp arg) (vectorp arg) (symbolp arg))
377 (custom-prin1-to-string arg)
378 arg)))
379 args)))
382 (defun custom-message (fmt &rest args)
383 "Print a one-line message at the bottom of the screen.
384 The first argument is a control string.
385 It may contain %s or %d or %c to print successive following arguments.
386 %s means print an argument as a string, %d means print as number in decimal,
387 %c means print a number as a single character.
388 The argument used by %s must be a string or a symbol;
389 the argument used by %d or %c must be a number.
391 This is the custom-print replacement for the standard `message'.
392 See `custom-format' for the details."
393 ;; It doesn't work to princ the result of custom-format as in:
394 ;; (cust-print-original-princ (apply 'custom-format fmt args))
395 ;; because the echo area requires special handling
396 ;; to avoid duplicating the output.
397 ;; cust-print-original-message does it right.
398 (apply 'cust-print-original-message fmt
399 (mapcar (function (lambda (arg)
400 (if (or (listp arg) (vectorp arg) (symbolp arg))
401 (custom-prin1-to-string arg)
402 arg)))
403 args)))
406 (defun custom-error (fmt &rest args)
407 "Signal an error, making error message by passing all args to `format'.
409 This is the custom-print replacement for the standard `error'.
410 See `custom-format' for the details."
411 (signal 'error (list (apply 'custom-format fmt args))))
415 ;; Support for custom prin1 and princ
416 ;;=========================================
418 ;; Defs to quiet byte-compiler.
419 (defvar circle-table)
420 (defvar cust-print-current-level)
422 (defun cust-print-original-printer (object)) ; One of the standard printers.
423 (defun cust-print-low-level-prin (object)) ; Used internally.
424 (defun cust-print-prin (object)) ; Call this to print recursively.
426 (defun cust-print-top-level (object stream emacs-printer)
427 ;; Set up for printing.
428 (let ((standard-output (or stream standard-output))
429 ;; circle-table will be non-nil if anything is circular.
430 (circle-table (and print-circle
431 (cust-print-preprocess-circle-tree object)))
432 (cust-print-current-level (or print-level -1)))
434 (defalias 'cust-print-original-printer emacs-printer)
435 (defalias 'cust-print-low-level-prin
436 (cond
437 ((or custom-printers
438 circle-table
439 print-level ; comment out for version 19
440 ;; Emacs doesn't use print-level or print-length
441 ;; for vectors, but custom-print can.
442 (if custom-print-vectors
443 (or print-level print-length)))
444 'cust-print-print-object)
445 (t 'cust-print-original-printer)))
446 (defalias 'cust-print-prin
447 (if circle-table 'cust-print-print-circular 'cust-print-low-level-prin))
449 (cust-print-prin object)
450 object))
453 (defun cust-print-print-object (object)
454 ;; Test object type and print accordingly.
455 ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
456 (cond
457 ((null object) (cust-print-original-printer object))
458 ((cust-print-use-custom-printer object) object)
459 ((consp object) (cust-print-list object))
460 ((vectorp object) (cust-print-vector object))
461 ;; All other types, just print.
462 (t (cust-print-original-printer object))))
465 (defun cust-print-print-circular (object)
466 ;; Printer for `prin1' and `princ' that handles circular structures.
467 ;; If OBJECT appears multiply, and has not yet been printed,
468 ;; prefix with label; if it has been printed, use `#N#' instead.
469 ;; Otherwise, print normally.
470 (let ((tag (assq object circle-table)))
471 (if tag
472 (let ((id (cdr tag)))
473 (if (> id 0)
474 (progn
475 ;; Already printed, so just print id.
476 (cust-print-original-princ "#")
477 (cust-print-original-princ id)
478 (cust-print-original-princ "#"))
479 ;; Not printed yet, so label with id and print object.
480 (setcdr tag (- id)) ; mark it as printed
481 (cust-print-original-princ "#")
482 (cust-print-original-princ (- id))
483 (cust-print-original-princ "=")
484 (cust-print-low-level-prin object)
486 ;; Not repeated in structure.
487 (cust-print-low-level-prin object))))
490 ;;================================================
491 ;; List and vector processing for print functions.
493 (defun cust-print-list (list)
494 ;; Print a list using print-length, print-level, and print-circle.
495 (if (= cust-print-current-level 0)
496 (cust-print-original-princ "#")
497 (let ((cust-print-current-level (1- cust-print-current-level)))
498 (cust-print-original-princ "(")
499 (let ((length (or print-length 0)))
501 ;; Print the first element always (even if length = 0).
502 (cust-print-prin (car list))
503 (setq list (cdr list))
504 (if list (cust-print-original-princ " "))
505 (setq length (1- length))
507 ;; Print the rest of the elements.
508 (while (and list (/= 0 length))
509 (if (and (listp list)
510 (not (assq list circle-table)))
511 (progn
512 (cust-print-prin (car list))
513 (setq list (cdr list)))
515 ;; cdr is not a list, or it is in circle-table.
516 (cust-print-original-princ ". ")
517 (cust-print-prin list)
518 (setq list nil))
520 (setq length (1- length))
521 (if list (cust-print-original-princ " ")))
523 (if (and list (= length 0)) (cust-print-original-princ "..."))
524 (cust-print-original-princ ")"))))
525 list)
528 (defun cust-print-vector (vector)
529 ;; Print a vector according to print-length, print-level, and print-circle.
530 (if (= cust-print-current-level 0)
531 (cust-print-original-princ "#")
532 (let ((cust-print-current-level (1- cust-print-current-level))
533 (i 0)
534 (len (length vector)))
535 (cust-print-original-princ "[")
537 (if print-length
538 (setq len (min print-length len)))
539 ;; Print the elements
540 (while (< i len)
541 (cust-print-prin (aref vector i))
542 (setq i (1+ i))
543 (if (< i (length vector)) (cust-print-original-princ " ")))
545 (if (< i (length vector)) (cust-print-original-princ "..."))
546 (cust-print-original-princ "]")
548 vector)
552 ;; Circular structure preprocessing
553 ;;==================================
555 (defun cust-print-preprocess-circle-tree (object)
556 ;; Fill up the table.
557 (let (;; Table of tags for each object in an object to be printed.
558 ;; A tag is of the form:
559 ;; ( <object> <nil-t-or-id-number> )
560 ;; The id-number is generated after the entire table has been computed.
561 ;; During walk through, the real circle-table lives in the cdr so we
562 ;; can use setcdr to add new elements instead of having to setq the
563 ;; variable sometimes (poor man's locf).
564 (circle-table (list nil)))
565 (cust-print-walk-circle-tree object)
567 ;; Reverse table so it is in the order that the objects will be printed.
568 ;; This pass could be avoided if we always added to the end of the
569 ;; table with setcdr in walk-circle-tree.
570 (setcdr circle-table (nreverse (cdr circle-table)))
572 ;; Walk through the table, assigning id-numbers to those
573 ;; objects which will be printed using #N= syntax. Delete those
574 ;; objects which will be printed only once (to speed up assq later).
575 (let ((rest circle-table)
576 (id -1))
577 (while (cdr rest)
578 (let ((tag (car (cdr rest))))
579 (cond ((cdr tag)
580 (setcdr tag id)
581 (setq id (1- id))
582 (setq rest (cdr rest)))
583 ;; Else delete this object.
584 (t (setcdr rest (cdr (cdr rest))))))
586 ;; Drop the car.
587 (cdr circle-table)
592 (defun cust-print-walk-circle-tree (object)
593 (let (read-equivalent-p tag)
594 (while object
595 (setq read-equivalent-p
596 (or (numberp object)
597 (and (symbolp object)
598 ;; Check if it is uninterned.
599 (eq object (intern-soft (symbol-name object)))))
600 tag (and (not read-equivalent-p)
601 (assq object (cdr circle-table))))
602 (cond (tag
603 ;; Seen this object already, so note that.
604 (setcdr tag t))
606 ((not read-equivalent-p)
607 ;; Add a tag for this object.
608 (setcdr circle-table
609 (cons (list object)
610 (cdr circle-table)))))
611 (setq object
612 (cond
613 (tag ;; No need to descend since we have already.
614 nil)
616 ((consp object)
617 ;; Walk the car of the list recursively.
618 (cust-print-walk-circle-tree (car object))
619 ;; But walk the cdr with the above while loop
620 ;; to avoid problems with max-lisp-eval-depth.
621 ;; And it should be faster than recursion.
622 (cdr object))
624 ((vectorp object)
625 ;; Walk the vector.
626 (let ((i (length object))
627 (j 0))
628 (while (< j i)
629 (cust-print-walk-circle-tree (aref object j))
630 (setq j (1+ j))))))))))
633 ;; Example.
634 ;;=======================================
636 '(progn
637 (progn
638 ;; Create some circular structures.
639 (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
640 (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
641 (setcar (nthcdr 3 circ-list) circ-list)
642 (aset (nth 2 circ-list) 2 circ-list)
643 (setq dotted-circ-list (list 'a 'b 'c))
644 (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
645 (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
646 (aset circ-vector 5 (make-symbol "-gensym-"))
647 (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
648 nil)
650 (install-custom-print)
651 ;; (setq print-circle t)
653 (let ((print-circle t))
654 (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
655 (error "circular object with array printing")))
657 (let ((print-circle t))
658 (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
659 (error "circular object with array printing")))
661 (let* ((print-circle t)
662 (x (list 'p 'q))
663 (y (list (list 'a 'b) x 'foo x)))
664 (setcdr (cdr (cdr (cdr y))) (cdr y))
665 (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
667 (error "circular list example from CL manual")))
669 (let ((print-circle nil))
670 ;; cl-packages.el is required to print uninterned symbols like #:FOO.
671 ;; (require 'cl-packages)
672 (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
673 (error "uninterned symbols in list")))
674 (let ((print-circle t))
675 (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
676 (error "circular uninterned symbols in list")))
678 (uninstall-custom-print)
681 (provide 'cust-print)
683 ;;; cust-print.el ends here