1 ;;; cust-print.el --- handles print-level and print-circle
3 ;; Copyright (C) 1992 Free Software Foundation, Inc.
5 ;; Author: Daniel LaLiberte <liberte@holonexus.org>
7 ;; Keywords: extensions
10 ;; cust-print|Daniel LaLiberte|liberte@holonexus.org
11 ;; |Handle print-level, print-circle and more.
13 ;; This file is part of XEmacs.
15 ;; XEmacs is free software; you can redistribute it and/or modify it
16 ;; under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation; either version 2, or (at your option)
20 ;; XEmacs is distributed in the hope that it will be useful, but
21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23 ;; General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with XEmacs; see the file COPYING. If not, write to the Free
27 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
30 ;;; Synched up with: Emacs 21.3
34 ;; This package provides a general print handler for prin1 and princ
35 ;; that supports print-level and print-circle, and by the way,
36 ;; print-length since the standard routines are being replaced. Also,
37 ;; to print custom types constructed from lists and vectors, use
38 ;; custom-print-list and custom-print-vector. See the documentation
39 ;; strings of these variables for more details.
41 ;; If the results of your expressions contain circular references to
42 ;; other parts of the same structure, the standard Emacs print
43 ;; subroutines may fail to print with an untrappable error,
44 ;; "Apparently circular structure being printed". If you only use cdr
45 ;; circular lists (where cdrs of lists point back; what is the right
46 ;; term here?), you can limit the length of printing with
47 ;; print-length. But car circular lists and circular vectors generate
48 ;; the above mentioned error in Emacs version 18. Version
49 ;; 19 supports print-level, but it is often useful to get a better
50 ;; print representation of circular and shared structures; the print-circle
51 ;; option may be used to print more concise representations.
53 ;; There are three main ways to use this package. First, you may
54 ;; replace prin1, princ, and some subroutines that use them by calling
55 ;; install-custom-print so that any use of these functions in
56 ;; Lisp code will be affected; you can later reset with
57 ;; uninstall-custom-print. Second, you may temporarily install
58 ;; these functions with the macro with-custom-print. Third, you
59 ;; could call the custom routines directly, thus only affecting the
60 ;; printing that requires them.
62 ;; Note that subroutines which call print subroutines directly will
63 ;; not use the custom print functions. In particular, the evaluation
64 ;; functions like eval-region call the print subroutines directly.
65 ;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a
66 ;; circular list rather than an array, aref calls error directly which
67 ;; will jump to the top level instead of printing the circular list.
69 ;; Uninterned symbols are recognized when print-circle is non-nil,
70 ;; but they are not printed specially here. Use the cl-packages package
71 ;; to print according to print-gensym.
73 ;; Obviously the right way to implement this custom-print facility is
74 ;; in C or with hooks into the standard printer. Please volunteer
75 ;; since I don't have the time or need. More CL-like printing
76 ;; capabilities could be added in the future.
78 ;; Implementation design: we want to use the same list and vector
79 ;; processing algorithm for all versions of prin1 and princ, since how
80 ;; the processing is done depends on print-length, print-level, and
81 ;; print-circle. For circle printing, a preprocessing step is
82 ;; required before the final printing. Thanks to Jamie Zawinski
83 ;; for motivation and algorithms.
88 (defgroup cust-print nil
89 "Handles print-level and print-circle."
94 ;; If using cl-packages:
96 '(defpackage "cust-print"
97 (:nicknames "CP" "custom-print")
104 custom-print-uninstall
105 custom-print-installed-p
110 custom-prin1-to-string
120 '(in-package cust-print)
122 ;; Emacs 18 doesn't have defalias.
123 ;; Provide def for byte compiler.
125 (or (fboundp 'defalias) (fset 'defalias 'fset)))
129 ;;=========================================================
131 ;;(defvar print-length nil
132 ;; "*Controls how many elements of a list, at each level, are printed.
133 ;;This is defined by emacs.")
135 (defcustom print-level nil
136 "*Controls how many levels deep a nested data object will print.
138 If nil, printing proceeds recursively and may lead to
139 max-lisp-eval-depth being exceeded or an error may occur:
140 `Apparently circular structure being printed.'
141 Also see `print-length' and `print-circle'.
143 If non-nil, components at levels equal to or greater than `print-level'
144 are printed simply as `#'. The object to be printed is at level 0,
145 and if the object is a list or vector, its top-level components are at
147 :type '(choice (const nil) integer)
151 (defcustom print-circle nil
152 "*Controls the printing of recursive structures.
154 If nil, printing proceeds recursively and may lead to
155 `max-lisp-eval-depth' being exceeded or an error may occur:
156 \"Apparently circular structure being printed.\" Also see
157 `print-length' and `print-level'.
159 If non-nil, shared substructures anywhere in the structure are printed
160 with `#N=' before the first occurrence (in the order of the print
161 representation) and `#N#' in place of each subsequent occurrence,
162 where N is a positive decimal integer.
164 There is no way to read this representation in standard Emacs,
165 but if you need to do so, try the cl-read.el package."
170 (defcustom custom-print-vectors nil
171 "*Non-nil if printing of vectors should obey print-level and print-length.
173 For Emacs 18, setting print-level, or adding custom print list or
174 vector handling will make this happen anyway. Emacs 19 obeys
175 print-level, but not for vectors."
181 ;;==========================================================
183 (defconst custom-printers nil
184 ;; e.g. '((symbolp . pkg::print-symbol))
185 "An alist for custom printing of any type.
186 Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true
187 for an object, then PRINTER is called with the object.
188 PRINTER should print to `standard-output' using cust-print-original-princ
189 if the standard printer is sufficient, or cust-print-prin for complex things.
190 The PRINTER should return the object being printed.
192 Don't modify this variable directly. Use `add-custom-printer' and
193 `delete-custom-printer'")
194 ;; Should cust-print-original-princ and cust-print-prin be exported symbols?
195 ;; Or should the standard printers functions be replaced by
196 ;; CP ones in Emacs Lisp so that CP internal functions need not be called?
198 (defun add-custom-printer (pred printer)
199 "Add a pair of PREDICATE and PRINTER to `custom-printers'.
200 Any pair that has the same PREDICATE is first removed."
201 (setq custom-printers (cons (cons pred printer)
202 (delq (assq pred custom-printers)
204 ;; Rather than updating here, we could wait until cust-print-top-level is called.
205 (cust-print-update-custom-printers))
207 (defun delete-custom-printer (pred)
208 "Delete the custom printer associated with PREDICATE."
209 (setq custom-printers (delq (assq pred custom-printers)
211 (cust-print-update-custom-printers))
214 (defun cust-print-use-custom-printer (object)
215 ;; Default function returns nil.
218 (defun cust-print-update-custom-printers ()
219 ;; Modify the definition of cust-print-use-custom-printer
220 (defalias 'cust-print-use-custom-printer
221 ;; We don't really want to require the byte-compiler.
227 `((,(car pair) object)
228 (,(cdr pair) object))))
230 ;; Otherwise return nil.
237 ;; Saving and restoring emacs printing routines.
238 ;;====================================================
240 (defun cust-print-set-function-cell (symbol-pair)
241 (defalias (car symbol-pair)
242 (symbol-function (car (cdr symbol-pair)))))
244 (defun cust-print-original-princ (object &optional stream)) ; dummy def
246 ;; Save emacs routines.
247 (if (not (fboundp 'cust-print-original-prin1))
248 (mapcar 'cust-print-set-function-cell
249 '((cust-print-original-prin1 prin1)
250 (cust-print-original-princ princ)
251 (cust-print-original-print print)
252 (cust-print-original-prin1-to-string prin1-to-string)
253 (cust-print-original-format format)
254 (cust-print-original-message message)
255 (cust-print-original-error error))))
258 (defun custom-print-install ()
259 "Replace print functions with general, customizable, Lisp versions.
260 The emacs subroutines are saved away, and you can reinstall them
261 by running `custom-print-uninstall'."
263 (mapcar 'cust-print-set-function-cell
264 '((prin1 custom-prin1)
267 (prin1-to-string custom-prin1-to-string)
268 (format custom-format)
269 (message custom-message)
274 (defun custom-print-uninstall ()
275 "Reset print functions to their emacs subroutines."
277 (mapcar 'cust-print-set-function-cell
278 '((prin1 cust-print-original-prin1)
279 (princ cust-print-original-princ)
280 (print cust-print-original-print)
281 (prin1-to-string cust-print-original-prin1-to-string)
282 (format cust-print-original-format)
283 (message cust-print-original-message)
284 (error cust-print-original-error)
288 (defalias 'custom-print-funcs-installed-p 'custom-print-installed-p)
289 (defun custom-print-installed-p ()
290 "Return t if custom-print is currently installed, nil otherwise."
291 (eq (symbol-function 'custom-prin1) (symbol-function 'prin1)))
293 (put 'with-custom-print-funcs 'edebug-form-spec '(body))
294 (put 'with-custom-print 'edebug-form-spec '(body))
296 (defalias 'with-custom-print-funcs 'with-custom-print)
297 (defmacro with-custom-print (&rest body)
298 "Temporarily install the custom print package while executing BODY."
301 (custom-print-install)
303 (custom-print-uninstall)))
306 ;; Lisp replacements for prin1 and princ, and for some subrs that use them
307 ;;===============================================================
308 ;; - so far only the printing and formatting subrs.
310 (defun custom-prin1 (object &optional stream)
311 "Output the printed representation of OBJECT, any Lisp object.
312 Quoting characters are printed when needed to make output that `read'
313 can handle, whenever this is possible.
314 Output stream is STREAM, or value of `standard-output' (which see).
316 This is the custom-print replacement for the standard `prin1'. It
317 uses the appropriate printer depending on the values of `print-level'
318 and `print-circle' (which see)."
319 (cust-print-top-level object stream 'cust-print-original-prin1))
322 (defun custom-princ (object &optional stream)
323 "Output the printed representation of OBJECT, any Lisp object.
324 No quoting characters are used; no delimiters are printed around
325 the contents of strings.
326 Output stream is STREAM, or value of `standard-output' (which see).
328 This is the custom-print replacement for the standard `princ'."
329 (cust-print-top-level object stream 'cust-print-original-princ))
332 (defun custom-prin1-to-string (object &optional noescape)
333 "Return a string containing the printed representation of OBJECT,
334 any Lisp object. Quoting characters are used when needed to make output
335 that `read' can handle, whenever this is possible, unless the optional
336 second argument NOESCAPE is non-nil.
338 This is the custom-print replacement for the standard `prin1-to-string'."
339 (let ((buf (get-buffer-create " *custom-print-temp*")))
340 ;; We must erase the buffer before printing in case an error
341 ;; occurred during the last prin1-to-string and we are in debugger.
345 ;; We must be in the current-buffer when the print occurs.
347 (custom-princ object buf)
348 (custom-prin1 object buf))
352 ;; We could erase the buffer again, but why bother?
356 (defun custom-print (object &optional stream)
357 "Output the printed representation of OBJECT, with newlines around it.
358 Quoting characters are printed when needed to make output that `read'
359 can handle, whenever this is possible.
360 Output stream is STREAM, or value of `standard-output' (which see).
362 This is the custom-print replacement for the standard `print'."
363 (cust-print-original-princ "\n" stream)
364 (custom-prin1 object stream)
365 (cust-print-original-princ "\n" stream))
368 (defun custom-format (fmt &rest args)
369 "Format a string out of a control-string and arguments.
370 The first argument is a control string. It, and subsequent arguments
371 substituted into it, become the value, which is a string.
372 It may contain %s or %d or %c to substitute successive following arguments.
373 %s means print an argument as a string, %d means print as number in decimal,
374 %c means print a number as a single character.
375 The argument used by %s must be a string or a symbol;
376 the argument used by %d, %b, %o, %x or %c must be a number.
378 This is the custom-print replacement for the standard `format'. It
379 calls the emacs `format' after first making strings for list,
380 vector, or symbol args. The format specification for such args should
381 be `%s' in any case, so a string argument will also work. The string
382 is generated with `custom-prin1-to-string', which quotes quotable
384 (apply 'cust-print-original-format fmt
385 (mapcar (function (lambda (arg)
386 (if (or (listp arg) (vectorp arg) (symbolp arg))
387 (custom-prin1-to-string arg)
392 (defun custom-message (fmt &rest args)
393 "Print a one-line message at the bottom of the screen.
394 The first argument is a control string.
395 It may contain %s or %d or %c to print successive following arguments.
396 %s means print an argument as a string, %d means print as number in decimal,
397 %c means print a number as a single character.
398 The argument used by %s must be a string or a symbol;
399 the argument used by %d or %c must be a number.
401 This is the custom-print replacement for the standard `message'.
402 See `custom-format' for the details."
403 ;; It doesn't work to princ the result of custom-format as in:
404 ;; (cust-print-original-princ (apply 'custom-format fmt args))
405 ;; because the echo area requires special handling
406 ;; to avoid duplicating the output.
407 ;; cust-print-original-message does it right.
408 (apply 'cust-print-original-message fmt
409 (mapcar (function (lambda (arg)
410 (if (or (listp arg) (vectorp arg) (symbolp arg))
411 (custom-prin1-to-string arg)
416 (defun custom-error (fmt &rest args)
417 "Signal an error, making error message by passing all args to `format'.
419 This is the custom-print replacement for the standard `error'.
420 See `custom-format' for the details."
421 (signal 'error (list (apply 'custom-format fmt args))))
425 ;; Support for custom prin1 and princ
426 ;;=========================================
428 ;; Defs to quiet byte-compiler.
429 (defvar circle-table)
430 (defvar cust-print-current-level)
432 (defun cust-print-original-printer (object)) ; One of the standard printers.
433 (defun cust-print-low-level-prin (object)) ; Used internally.
434 (defun cust-print-prin (object)) ; Call this to print recursively.
436 (defun cust-print-top-level (object stream emacs-printer)
437 ;; Set up for printing.
438 (let ((standard-output (or stream standard-output))
439 ;; circle-table will be non-nil if anything is circular.
440 (circle-table (and print-circle
441 (cust-print-preprocess-circle-tree object)))
442 (cust-print-current-level (or print-level -1)))
444 (defalias 'cust-print-original-printer emacs-printer)
445 (defalias 'cust-print-low-level-prin
449 print-level ; comment out for version 19
450 ;; Emacs doesn't use print-level or print-length
451 ;; for vectors, but custom-print can.
452 (if custom-print-vectors
453 (or print-level print-length)))
454 'cust-print-print-object)
455 (t 'cust-print-original-printer)))
456 (defalias 'cust-print-prin
457 (if circle-table 'cust-print-print-circular 'cust-print-low-level-prin))
459 (cust-print-prin object)
463 (defun cust-print-print-object (object)
464 ;; Test object type and print accordingly.
465 ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
467 ((null object) (cust-print-original-printer object))
468 ((cust-print-use-custom-printer object) object)
469 ((consp object) (cust-print-list object))
470 ((vectorp object) (cust-print-vector object))
471 ;; All other types, just print.
472 (t (cust-print-original-printer object))))
475 (defun cust-print-print-circular (object)
476 ;; Printer for `prin1' and `princ' that handles circular structures.
477 ;; If OBJECT appears multiply, and has not yet been printed,
478 ;; prefix with label; if it has been printed, use `#N#' instead.
479 ;; Otherwise, print normally.
480 (let ((tag (assq object circle-table)))
482 (let ((id (cdr tag)))
485 ;; Already printed, so just print id.
486 (cust-print-original-princ "#")
487 (cust-print-original-princ id)
488 (cust-print-original-princ "#"))
489 ;; Not printed yet, so label with id and print object.
490 (setcdr tag (- id)) ; mark it as printed
491 (cust-print-original-princ "#")
492 (cust-print-original-princ (- id))
493 (cust-print-original-princ "=")
494 (cust-print-low-level-prin object)
496 ;; Not repeated in structure.
497 (cust-print-low-level-prin object))))
500 ;;================================================
501 ;; List and vector processing for print functions.
503 (defun cust-print-list (list)
504 ;; Print a list using print-length, print-level, and print-circle.
505 (if (= cust-print-current-level 0)
506 (cust-print-original-princ "#")
507 (let ((cust-print-current-level (1- cust-print-current-level)))
508 (cust-print-original-princ "(")
509 (let ((length (or print-length 0)))
511 ;; Print the first element always (even if length = 0).
512 (cust-print-prin (car list))
513 (setq list (cdr list))
514 (if list (cust-print-original-princ " "))
515 (setq length (1- length))
517 ;; Print the rest of the elements.
518 (while (and list (/= 0 length))
519 (if (and (listp list)
520 (not (assq list circle-table)))
522 (cust-print-prin (car list))
523 (setq list (cdr list)))
525 ;; cdr is not a list, or it is in circle-table.
526 (cust-print-original-princ ". ")
527 (cust-print-prin list)
530 (setq length (1- length))
531 (if list (cust-print-original-princ " ")))
533 (if (and list (= length 0)) (cust-print-original-princ "..."))
534 (cust-print-original-princ ")"))))
538 (defun cust-print-vector (vector)
539 ;; Print a vector according to print-length, print-level, and print-circle.
540 (if (= cust-print-current-level 0)
541 (cust-print-original-princ "#")
542 (let ((cust-print-current-level (1- cust-print-current-level))
544 (len (length vector)))
545 (cust-print-original-princ "[")
548 (setq len (min print-length len)))
549 ;; Print the elements
551 (cust-print-prin (aref vector i))
553 (if (< i (length vector)) (cust-print-original-princ " ")))
555 (if (< i (length vector)) (cust-print-original-princ "..."))
556 (cust-print-original-princ "]")
562 ;; Circular structure preprocessing
563 ;;==================================
565 (defun cust-print-preprocess-circle-tree (object)
566 ;; Fill up the table.
567 (let (;; Table of tags for each object in an object to be printed.
568 ;; A tag is of the form:
569 ;; ( <object> <nil-t-or-id-number> )
570 ;; The id-number is generated after the entire table has been computed.
571 ;; During walk through, the real circle-table lives in the cdr so we
572 ;; can use setcdr to add new elements instead of having to setq the
573 ;; variable sometimes (poor man's locf).
574 (circle-table (list nil)))
575 (cust-print-walk-circle-tree object)
577 ;; Reverse table so it is in the order that the objects will be printed.
578 ;; This pass could be avoided if we always added to the end of the
579 ;; table with setcdr in walk-circle-tree.
580 (setcdr circle-table (nreverse (cdr circle-table)))
582 ;; Walk through the table, assigning id-numbers to those
583 ;; objects which will be printed using #N= syntax. Delete those
584 ;; objects which will be printed only once (to speed up assq later).
585 (let ((rest circle-table)
588 (let ((tag (car (cdr rest))))
592 (setq rest (cdr rest)))
593 ;; Else delete this object.
594 (t (setcdr rest (cdr (cdr rest))))))
602 (defun cust-print-walk-circle-tree (object)
603 (let (read-equivalent-p tag)
605 (setq read-equivalent-p
607 (and (symbolp object)
608 ;; Check if it is uninterned.
609 (eq object (intern-soft (symbol-name object)))))
610 tag (and (not read-equivalent-p)
611 (assq object (cdr circle-table))))
613 ;; Seen this object already, so note that.
616 ((not read-equivalent-p)
617 ;; Add a tag for this object.
620 (cdr circle-table)))))
623 (tag ;; No need to descend since we have already.
627 ;; Walk the car of the list recursively.
628 (cust-print-walk-circle-tree (car object))
629 ;; But walk the cdr with the above while loop
630 ;; to avoid problems with max-lisp-eval-depth.
631 ;; And it should be faster than recursion.
636 (let ((i (length object))
639 (cust-print-walk-circle-tree (aref object j))
640 (setq j (1+ j))))))))))
644 ;;=======================================
648 ;; Create some circular structures.
649 (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
650 (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
651 (setcar (nthcdr 3 circ-list) circ-list)
652 (aset (nth 2 circ-list) 2 circ-list)
653 (setq dotted-circ-list (list 'a 'b 'c))
654 (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
655 (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
656 (aset circ-vector 5 (make-symbol "-gensym-"))
657 (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
660 (install-custom-print)
661 ;; (setq print-circle t)
663 (let ((print-circle t))
664 (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
665 (error "circular object with array printing")))
667 (let ((print-circle t))
668 (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
669 (error "circular object with array printing")))
671 (let* ((print-circle t)
673 (y (list (list 'a 'b) x 'foo x)))
674 (setcdr (cdr (cdr (cdr y))) (cdr y))
675 (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
677 (error "circular list example from CL manual")))
679 (let ((print-circle nil))
680 ;; cl-packages.el is required to print uninterned symbols like #:FOO.
681 ;; (require 'cl-packages)
682 (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
683 (error "uninterned symbols in list")))
684 (let ((print-circle t))
685 (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
686 (error "circular uninterned symbols in list")))
688 (uninstall-custom-print)
691 (provide 'cust-print)
693 ;;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580
694 ;;; cust-print.el ends here