Lines Matching defs:print
1 ;;; cust-print.el --- handles print-level and print-circle
11 ;; cust-print|Daniel LaLiberte|liberte@holonexus.org
12 ;; |Handle print-level, print-circle and more.
33 ;; This package provides a general print handler for prin1 and princ
34 ;; that supports print-level and print-circle, and by the way,
35 ;; print-length since the standard routines are being replaced. Also,
36 ;; to print custom types constructed from lists and vectors, use
37 ;; custom-print-list and custom-print-vector. See the documentation
41 ;; other parts of the same structure, the standard Emacs print
42 ;; subroutines may fail to print with an untrappable error,
46 ;; print-length. But car circular lists and circular vectors generate
48 ;; 19 supports print-level, but it is often useful to get a better
49 ;; print representation of circular and shared structures; the print-circle
50 ;; option may be used to print more concise representations.
54 ;; install-custom-print so that any use of these functions in
56 ;; uninstall-custom-print. Second, you may temporarily install
57 ;; these functions with the macro with-custom-print. Third, you
61 ;; Note that subroutines which call print subroutines directly will
62 ;; not use the custom print functions. In particular, the evaluation
63 ;; functions like eval-region call the print subroutines directly.
68 ;; Uninterned symbols are recognized when print-circle is non-nil,
70 ;; to print according to print-gensym.
72 ;; Obviously the right way to implement this custom-print facility is
79 ;; the processing is done depends on print-length, print-level, and
80 ;; print-circle. For circle printing, a preprocessing step is
88 (defgroup cust-print nil
89 "Handles print-level and print-circle."
90 :prefix "print-"
96 '(defpackage "cust-print"
97 (:nicknames "CP" "custom-print")
100 print-level
101 print-circle
103 custom-print-install
104 custom-print-uninstall
105 custom-print-installed-p
106 with-custom-print
111 custom-print
120 '(in-package cust-print)
132 ;;(defvar print-length nil
136 (defcustom print-level nil
137 "*Controls how many levels deep a nested data object will print.
142 Also see `print-length' and `print-circle'.
144 If non-nil, components at levels equal to or greater than `print-level'
149 :group 'cust-print)
152 (defcustom print-circle nil
158 `print-length' and `print-level'.
161 with `#N=' before the first occurrence (in the order of the print
168 :group 'cust-print)
171 (defcustom custom-print-vectors nil
172 "*Non-nil if printing of vectors should obey print-level and print-length.
174 For Emacs 18, setting print-level, or adding custom print list or
176 print-level, but not for vectors."
178 :group 'cust-print)
186 ;; e.g. '((symbolp . pkg::print-symbol))
190 PRINTER should print to `standard-output' using cust-print-original-princ
191 if the standard printer is sufficient, or cust-print-prin for complex things.
196 ;; Should cust-print-original-princ and cust-print-prin be exported symbols?
206 ;; Rather than updating here, we could wait until cust-print-top-level is called.
207 (cust-print-update-custom-printers))
213 (cust-print-update-custom-printers))
216 (defun cust-print-use-custom-printer (object)
220 (defun cust-print-update-custom-printers ()
221 ;; Modify the definition of cust-print-use-custom-printer
222 (defalias 'cust-print-use-custom-printer
243 (defun cust-print-set-function-cell (symbol-pair)
247 (defun cust-print-original-princ (object &optional stream)) ; dummy def
250 (if (not (fboundp 'cust-print-original-prin1))
251 (mapcar 'cust-print-set-function-cell
252 '((cust-print-original-prin1 prin1)
253 (cust-print-original-princ princ)
254 (cust-print-original-print print)
255 (cust-print-original-prin1-to-string prin1-to-string)
256 (cust-print-original-format format)
257 (cust-print-original-message message)
258 (cust-print-original-error error))))
261 (defun custom-print-install ()
262 "Replace print functions with general, customizable, Lisp versions.
264 by running `custom-print-uninstall'."
266 (mapcar 'cust-print-set-function-cell
269 (print custom-print)
277 (defun custom-print-uninstall ()
278 "Reset print functions to their Emacs subroutines."
280 (mapcar 'cust-print-set-function-cell
281 '((prin1 cust-print-original-prin1)
282 (princ cust-print-original-princ)
283 (print cust-print-original-print)
284 (prin1-to-string cust-print-original-prin1-to-string)
285 (format cust-print-original-format)
286 (message cust-print-original-message)
287 (error cust-print-original-error)
291 (defalias 'custom-print-funcs-installed-p 'custom-print-installed-p)
292 (defun custom-print-installed-p ()
293 "Return t if custom-print is currently installed, nil otherwise."
296 (put 'with-custom-print-funcs 'edebug-form-spec '(body))
297 (put 'with-custom-print 'edebug-form-spec '(body))
299 (defalias 'with-custom-print-funcs 'with-custom-print)
300 (defmacro with-custom-print (&rest body)
301 "Temporarily install the custom print package while executing BODY."
304 (custom-print-install)
306 (custom-print-uninstall)))
320 This is the custom-print replacement for the standard `prin1'. It
321 uses the appropriate printer depending on the values of `print-level'
322 and `print-circle' (which see)."
323 (cust-print-top-level object stream 'cust-print-original-prin1))
332 This is the custom-print replacement for the standard `princ'."
333 (cust-print-top-level object stream 'cust-print-original-princ))
342 This is the custom-print replacement for the standard `prin1-to-string'."
343 (let ((buf (get-buffer-create " *custom-print-temp*")))
349 ;; We must be in the current-buffer when the print occurs.
360 (defun custom-print (object &optional stream)
366 This is the custom-print replacement for the standard `print'."
367 (cust-print-original-princ "\n" stream)
369 (cust-print-original-princ "\n" stream))
377 %s means print an argument as a string, %d means print as number in decimal,
378 %c means print a number as a single character.
382 This is the custom-print replacement for the standard `format'. It
388 (apply 'cust-print-original-format fmt
399 It may contain %s or %d or %c to print successive following arguments.
400 %s means print an argument as a string, %d means print as number in decimal,
401 %c means print a number as a single character.
405 This is the custom-print replacement for the standard `message'.
408 ;; (cust-print-original-princ (apply 'custom-format fmt args))
411 ;; cust-print-original-message does it right.
412 (apply 'cust-print-original-message fmt
423 This is the custom-print replacement for the standard `error'.
435 (defvar cust-print-current-level)
437 (defun cust-print-original-printer (object)) ; One of the standard printers.
438 (defun cust-print-low-level-prin (object)) ; Used internally.
439 (defun cust-print-prin (object)) ; Call this to print recursively.
441 (defun cust-print-top-level (object stream emacs-printer)
445 (circle-table (and print-circle
446 (cust-print-preprocess-circle-tree object)))
447 (cust-print-current-level (or print-level -1)))
449 (defalias 'cust-print-original-printer emacs-printer)
450 (defalias 'cust-print-low-level-prin
454 print-level ; comment out for version 19
455 ;; Emacs doesn't use print-level or print-length
456 ;; for vectors, but custom-print can.
457 (if custom-print-vectors
458 (or print-level print-length)))
459 'cust-print-print-object)
460 (t 'cust-print-original-printer)))
461 (defalias 'cust-print-prin
462 (if circle-table 'cust-print-print-circular 'cust-print-low-level-prin))
464 (cust-print-prin object)
468 (defun cust-print-print-object (object)
469 ;; Test object type and print accordingly.
470 ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
472 ((null object) (cust-print-original-printer object))
473 ((cust-print-use-custom-printer object) object)
474 ((consp object) (cust-print-list object))
475 ((vectorp object) (cust-print-vector object))
476 ;; All other types, just print.
477 (t (cust-print-original-printer object))))
480 (defun cust-print-print-circular (object)
484 ;; Otherwise, print normally.
490 ;; Already printed, so just print id.
491 (cust-print-original-princ "#")
492 (cust-print-original-princ id)
493 (cust-print-original-princ "#"))
494 ;; Not printed yet, so label with id and print object.
496 (cust-print-original-princ "#")
497 (cust-print-original-princ (- id))
498 (cust-print-original-princ "=")
499 (cust-print-low-level-prin object)
502 (cust-print-low-level-prin object))))
506 ;; List and vector processing for print functions.
508 (defun cust-print-list (list)
509 ;; Print a list using print-length, print-level, and print-circle.
510 (if (= cust-print-current-level 0)
511 (cust-print-original-princ "#")
512 (let ((cust-print-current-level (1- cust-print-current-level)))
513 (cust-print-original-princ "(")
514 (let ((length (or print-length 0)))
517 (cust-print-prin (car list))
519 (if list (cust-print-original-princ " "))
527 (cust-print-prin (car list))
531 (cust-print-original-princ ". ")
532 (cust-print-prin list)
536 (if list (cust-print-original-princ " ")))
538 (if (and list (= length 0)) (cust-print-original-princ "..."))
539 (cust-print-original-princ ")"))))
543 (defun cust-print-vector (vector)
544 ;; Print a vector according to print-length, print-level, and print-circle.
545 (if (= cust-print-current-level 0)
546 (cust-print-original-princ "#")
547 (let ((cust-print-current-level (1- cust-print-current-level))
550 (cust-print-original-princ "[")
552 (if print-length
553 (setq len (min print-length len)))
556 (cust-print-prin (aref vector i))
558 (if (< i (length vector)) (cust-print-original-princ " ")))
560 (if (< i (length vector)) (cust-print-original-princ "..."))
561 (cust-print-original-princ "]")
571 (defun cust-print-preprocess-circle-tree (object)
581 (cust-print-walk-circle-tree object)
608 (defun cust-print-walk-circle-tree (object)
634 (cust-print-walk-circle-tree (car object))
645 (cust-print-walk-circle-tree (aref object j))
667 (install-custom-print)
668 ;; (setq print-circle t)
670 (let ((print-circle t))
674 (let ((print-circle t))
678 (let* ((print-circle t)
686 (let ((print-circle nil))
687 ;; cl-packages.el is required to print uninterned symbols like #:FOO.
691 (let ((print-circle t))
695 (uninstall-custom-print)
698 (provide 'cust-print)
701 ;;; cust-print.el ends here