(defgroup cust-print nil
"Handles print-level and print-circle."
:prefix "print-"
:group 'lisp
:group 'extensions)
'(defpackage "cust-print"
(:nicknames "CP" "custom-print")
(:use "el")
(:export
print-level
print-circle
custom-print-install
custom-print-uninstall
custom-print-installed-p
with-custom-print
custom-prin1
custom-princ
custom-prin1-to-string
custom-print
custom-format
custom-message
custom-error
custom-printers
add-custom-printer
))
'(in-package cust-print)
(eval-and-compile
(or (fboundp 'defalias) (fset 'defalias 'fset)))
(defcustom print-level nil
"*Controls how many levels deep a nested data object will print.
If nil, printing proceeds recursively and may lead to
max-lisp-eval-depth being exceeded or an error may occur:
`Apparently circular structure being printed.'
Also see `print-length' and `print-circle'.
If non-nil, components at levels equal to or greater than `print-level'
are printed simply as `#'. The object to be printed is at level 0,
and if the object is a list or vector, its top-level components are at
level 1."
:type '(choice (const nil) integer)
:group 'cust-print)
(defcustom print-circle nil
"*Controls the printing of recursive structures.
If nil, printing proceeds recursively and may lead to
`max-lisp-eval-depth' being exceeded or an error may occur:
\"Apparently circular structure being printed.\" Also see
`print-length' and `print-level'.
If non-nil, shared substructures anywhere in the structure are printed
with `#N=' before the first occurrence (in the order of the print
representation) and `#N#' in place of each subsequent occurrence,
where N is a positive decimal integer.
There is no way to read this representation in standard Emacs,
but if you need to do so, try the cl-read.el package."
:type 'boolean
:group 'cust-print)
(defcustom custom-print-vectors nil
"*Non-nil if printing of vectors should obey print-level and print-length.
For Emacs 18, setting print-level, or adding custom print list or
vector handling will make this happen anyway. Emacs 19 obeys
print-level, but not for vectors."
:type 'boolean
:group 'cust-print)
(defvar custom-printers nil
"An alist for custom printing of any type.
Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true
for an object, then PRINTER is called with the object.
PRINTER should print to `standard-output' using cust-print-original-princ
if the standard printer is sufficient, or cust-print-prin for complex things.
The PRINTER should return the object being printed.
Don't modify this variable directly. Use `add-custom-printer' and
`delete-custom-printer'")
(defun add-custom-printer (pred printer)
"Add a pair of PREDICATE and PRINTER to `custom-printers'.
Any pair that has the same PREDICATE is first removed."
(setq custom-printers (cons (cons pred printer)
(delq (assq pred custom-printers)
custom-printers)))
(cust-print-update-custom-printers))
(defun delete-custom-printer (pred)
"Delete the custom printer associated with PREDICATE."
(setq custom-printers (delq (assq pred custom-printers)
custom-printers))
(cust-print-update-custom-printers))
(defun cust-print-use-custom-printer (object)
nil)
(defun cust-print-update-custom-printers ()
(defalias 'cust-print-use-custom-printer
`(lambda (object)
(cond
,@(mapcar (function
(lambda (pair)
`((,(car pair) object)
(,(cdr pair) object))))
custom-printers)
(t nil)
))
))
(defun cust-print-set-function-cell (symbol-pair)
(defalias (car symbol-pair)
(symbol-function (car (cdr symbol-pair)))))
(defun cust-print-original-princ (object &optional stream))
(if (not (fboundp 'cust-print-original-prin1))
(mapcar 'cust-print-set-function-cell
'((cust-print-original-prin1 prin1)
(cust-print-original-princ princ)
(cust-print-original-print print)
(cust-print-original-prin1-to-string prin1-to-string)
(cust-print-original-format format)
(cust-print-original-message message)
(cust-print-original-error error))))
(defun custom-print-install ()
"Replace print functions with general, customizable, Lisp versions.
The Emacs subroutines are saved away, and you can reinstall them
by running `custom-print-uninstall'."
(interactive)
(mapcar 'cust-print-set-function-cell
'((prin1 custom-prin1)
(princ custom-princ)
(print custom-print)
(prin1-to-string custom-prin1-to-string)
(format custom-format)
(message custom-message)
(error custom-error)
))
t)
(defun custom-print-uninstall ()
"Reset print functions to their Emacs subroutines."
(interactive)
(mapcar 'cust-print-set-function-cell
'((prin1 cust-print-original-prin1)
(princ cust-print-original-princ)
(print cust-print-original-print)
(prin1-to-string cust-print-original-prin1-to-string)
(format cust-print-original-format)
(message cust-print-original-message)
(error cust-print-original-error)
))
t)
(defalias 'custom-print-funcs-installed-p 'custom-print-installed-p)
(defun custom-print-installed-p ()
"Return t if custom-print is currently installed, nil otherwise."
(eq (symbol-function 'custom-prin1) (symbol-function 'prin1)))
(put 'with-custom-print-funcs 'edebug-form-spec '(body))
(put 'with-custom-print 'edebug-form-spec '(body))
(defalias 'with-custom-print-funcs 'with-custom-print)
(defmacro with-custom-print (&rest body)
"Temporarily install the custom print package while executing BODY."
`(unwind-protect
(progn
(custom-print-install)
,@body)
(custom-print-uninstall)))
(defun custom-prin1 (object &optional stream)
"Output the printed representation of OBJECT, any Lisp object.
Quoting characters are printed when needed to make output that `read'
can handle, whenever this is possible.
Output stream is STREAM, or value of `standard-output' (which see).
This is the custom-print replacement for the standard `prin1'. It
uses the appropriate printer depending on the values of `print-level'
and `print-circle' (which see)."
(cust-print-top-level object stream 'cust-print-original-prin1))
(defun custom-princ (object &optional stream)
"Output the printed representation of OBJECT, any Lisp object.
No quoting characters are used; no delimiters are printed around
the contents of strings.
Output stream is STREAM, or value of `standard-output' (which see).
This is the custom-print replacement for the standard `princ'."
(cust-print-top-level object stream 'cust-print-original-princ))
(defun custom-prin1-to-string (object &optional noescape)
"Return a string containing the printed representation of OBJECT,
any Lisp object. Quoting characters are used when needed to make output
that `read' can handle, whenever this is possible, unless the optional
second argument NOESCAPE is non-nil.
This is the custom-print replacement for the standard `prin1-to-string'."
(let ((buf (get-buffer-create " *custom-print-temp*")))
(save-excursion
(set-buffer buf)
(erase-buffer))
(if noescape
(custom-princ object buf)
(custom-prin1 object buf))
(save-excursion
(set-buffer buf)
(buffer-string)
)))
(defun custom-print (object &optional stream)
"Output the printed representation of OBJECT, with newlines around it.
Quoting characters are printed when needed to make output that `read'
can handle, whenever this is possible.
Output stream is STREAM, or value of `standard-output' (which see).
This is the custom-print replacement for the standard `print'."
(cust-print-original-princ "\n" stream)
(custom-prin1 object stream)
(cust-print-original-princ "\n" stream))
(defun custom-format (fmt &rest args)
"Format a string out of a control-string and arguments.
The first argument is a control string. It, and subsequent arguments
substituted into it, become the value, which is a string.
It may contain %s or %d or %c to substitute successive following arguments.
%s means print an argument as a string, %d means print as number in decimal,
%c means print a number as a single character.
The argument used by %s must be a string or a symbol;
the argument used by %d, %b, %o, %x or %c must be a number.
This is the custom-print replacement for the standard `format'. It
calls the Emacs `format' after first making strings for list,
vector, or symbol args. The format specification for such args should
be `%s' in any case, so a string argument will also work. The string
is generated with `custom-prin1-to-string', which quotes quotable
characters."
(apply 'cust-print-original-format fmt
(mapcar (function (lambda (arg)
(if (or (listp arg) (vectorp arg) (symbolp arg))
(custom-prin1-to-string arg)
arg)))
args)))
(defun custom-message (fmt &rest args)
"Print a one-line message at the bottom of the screen.
The first argument is a control string.
It may contain %s or %d or %c to print successive following arguments.
%s means print an argument as a string, %d means print as number in decimal,
%c means print a number as a single character.
The argument used by %s must be a string or a symbol;
the argument used by %d or %c must be a number.
This is the custom-print replacement for the standard `message'.
See `custom-format' for the details."
(apply 'cust-print-original-message fmt
(mapcar (function (lambda (arg)
(if (or (listp arg) (vectorp arg) (symbolp arg))
(custom-prin1-to-string arg)
arg)))
args)))
(defun custom-error (fmt &rest args)
"Signal an error, making error message by passing all args to `format'.
This is the custom-print replacement for the standard `error'.
See `custom-format' for the details."
(signal 'error (list (apply 'custom-format fmt args))))
(defvar circle-table)
(defvar cust-print-current-level)
(defun cust-print-original-printer (object)) (defun cust-print-low-level-prin (object)) (defun cust-print-prin (object))
(defun cust-print-top-level (object stream emacs-printer)
(let ((standard-output (or stream standard-output))
(circle-table (and print-circle
(cust-print-preprocess-circle-tree object)))
(cust-print-current-level (or print-level -1)))
(defalias 'cust-print-original-printer emacs-printer)
(defalias 'cust-print-low-level-prin
(cond
((or custom-printers
circle-table
print-level (if custom-print-vectors
(or print-level print-length)))
'cust-print-print-object)
(t 'cust-print-original-printer)))
(defalias 'cust-print-prin
(if circle-table 'cust-print-print-circular 'cust-print-low-level-prin))
(cust-print-prin object)
object))
(defun cust-print-print-object (object)
(cond
((null object) (cust-print-original-printer object))
((cust-print-use-custom-printer object) object)
((consp object) (cust-print-list object))
((vectorp object) (cust-print-vector object))
(t (cust-print-original-printer object))))
(defun cust-print-print-circular (object)
(let ((tag (assq object circle-table)))
(if tag
(let ((id (cdr tag)))
(if (> id 0)
(progn
(cust-print-original-princ "#")
(cust-print-original-princ id)
(cust-print-original-princ "#"))
(setcdr tag (- id)) (cust-print-original-princ "#")
(cust-print-original-princ (- id))
(cust-print-original-princ "=")
(cust-print-low-level-prin object)
))
(cust-print-low-level-prin object))))
(defun cust-print-list (list)
(if (= cust-print-current-level 0)
(cust-print-original-princ "#")
(let ((cust-print-current-level (1- cust-print-current-level)))
(cust-print-original-princ "(")
(let ((length (or print-length 0)))
(cust-print-prin (car list))
(setq list (cdr list))
(if list (cust-print-original-princ " "))
(setq length (1- length))
(while (and list (/= 0 length))
(if (and (listp list)
(not (assq list circle-table)))
(progn
(cust-print-prin (car list))
(setq list (cdr list)))
(cust-print-original-princ ". ")
(cust-print-prin list)
(setq list nil))
(setq length (1- length))
(if list (cust-print-original-princ " ")))
(if (and list (= length 0)) (cust-print-original-princ "..."))
(cust-print-original-princ ")"))))
list)
(defun cust-print-vector (vector)
(if (= cust-print-current-level 0)
(cust-print-original-princ "#")
(let ((cust-print-current-level (1- cust-print-current-level))
(i 0)
(len (length vector)))
(cust-print-original-princ "[")
(if print-length
(setq len (min print-length len)))
(while (< i len)
(cust-print-prin (aref vector i))
(setq i (1+ i))
(if (< i (length vector)) (cust-print-original-princ " ")))
(if (< i (length vector)) (cust-print-original-princ "..."))
(cust-print-original-princ "]")
))
vector)
(defun cust-print-preprocess-circle-tree (object)
(let ( (circle-table (list nil)))
(cust-print-walk-circle-tree object)
(setcdr circle-table (nreverse (cdr circle-table)))
(let ((rest circle-table)
(id -1))
(while (cdr rest)
(let ((tag (car (cdr rest))))
(cond ((cdr tag)
(setcdr tag id)
(setq id (1- id))
(setq rest (cdr rest)))
(t (setcdr rest (cdr (cdr rest))))))
))
(cdr circle-table)
))
(defun cust-print-walk-circle-tree (object)
(let (read-equivalent-p tag)
(while object
(setq read-equivalent-p
(or (numberp object)
(and (symbolp object)
(eq object (intern-soft (symbol-name object)))))
tag (and (not read-equivalent-p)
(assq object (cdr circle-table))))
(cond (tag
(setcdr tag t))
((not read-equivalent-p)
(setcdr circle-table
(cons (list object)
(cdr circle-table)))))
(setq object
(cond
(tag nil)
((consp object)
(cust-print-walk-circle-tree (car object))
(cdr object))
((vectorp object)
(let ((i (length object))
(j 0))
(while (< j i)
(cust-print-walk-circle-tree (aref object j))
(setq j (1+ j))))))))))
'(progn
(progn
(setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
(setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
(setcar (nthcdr 3 circ-list) circ-list)
(aset (nth 2 circ-list) 2 circ-list)
(setq dotted-circ-list (list 'a 'b 'c))
(setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
(setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
(aset circ-vector 5 (make-symbol "-gensym-"))
(setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
nil)
(install-custom-print)
(let ((print-circle t))
(or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
(error "circular object with array printing")))
(let ((print-circle t))
(or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
(error "circular object with array printing")))
(let* ((print-circle t)
(x (list 'p 'q))
(y (list (list 'a 'b) x 'foo x)))
(setcdr (cdr (cdr (cdr y))) (cdr y))
(or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
)
(error "circular list example from CL manual")))
(let ((print-circle nil))
(or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
(error "uninterned symbols in list")))
(let ((print-circle t))
(or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
(error "circular uninterned symbols in list")))
(uninstall-custom-print)
)
(provide 'cust-print)