-;;; cust-print.el --- handles print-level and print-circle.
+;;; cust-print.el --- handles print-level and print-circle
-;; Copyright (C) 1992 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005,
+;; 2006, 2007 Free Software Foundation, Inc.
-;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
+;; Author: Daniel LaLiberte <liberte@holonexus.org>
;; Adapted-By: ESR
;; Keywords: extensions
;; LCD Archive Entry:
-;; cust-print|Daniel LaLiberte|liberte@cs.uiuc.edu
+;; cust-print|Daniel LaLiberte|liberte@holonexus.org
;; |Handle print-level, print-circle and more.
-;; |$Date: 1994/04/05 21:05:09 $|$Revision: 1.14 $|
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; ===============================
-;;; $Header: $
-;;; $Log: cust-print.el,v $
-;;; Revision 1.14 1994/04/05 21:05:09 liberte
-;;; Change install- and uninstall- to -install and -uninstall.
-;;;
-;;; Revision 1.13 1994/03/24 20:26:05 liberte
-;;; Change "internal" to "original" throughout.
-;;; (add-custom-printer, delete-custom-printer) replace customizers.
-;;; (with-custom-print) new
-;;; (custom-prin1-to-string) Made it more robust.
-;;;
-;;; Revision 1.4 1994/03/23 20:34:29 liberte
-;;; * Change "emacs" to "original" - I just can't decide.
-;;;
-;;; Revision 1.3 1994/02/21 21:25:36 liberte
-;;; * Make custom-prin1-to-string more robust when errors occur.
-;;; * Change "internal" to "emacs".
-;;;
-;;; Revision 1.2 1993/11/22 22:36:36 liberte
-;;; * Simplified and generalized printer customization.
-;;; custom-printers is an alist of (PREDICATE . PRINTER) pairs
-;;; for any data types. The PRINTER function should print to
-;;; `standard-output' add-custom-printer and delete-custom-printer
-;;; change custom-printers.
-;;;
-;;; * Installation function now called install-custom-print. The
-;;; old name is still around for now.
-;;;
-;;; * New macro with-custom-print (added earlier) - executes like
-;;; progn but with custom-print activated temporarily.
-;;;
-;;; * Cleaned up comments for replacements of standardard printers.
-;;;
-;;; * Changed custom-prin1-to-string to use a temporary buffer.
-;;;
-;;; * Option custom-print-vectors (added earlier) - controls whether
-;;; vectors should be printed according to print-length and
-;;; print-length. Emacs doesnt do this, but cust-print would
-;;; otherwise do it only if custom printing is required.
-;;;
-;;; * Uninterned symbols are treated as non-read-equivalent.
-;;;
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
-\f
;;; Commentary:
;; This package provides a general print handler for prin1 and princ
;; print-length since the standard routines are being replaced. Also,
;; to print custom types constructed from lists and vectors, use
;; custom-print-list and custom-print-vector. See the documentation
-;; strings of these variables for more details.
+;; strings of these variables for more details.
;; If the results of your expressions contain circular references to
;; other parts of the same structure, the standard Emacs print
\f
;;; Code:
-;;=========================================================
+
+(defgroup cust-print nil
+ "Handles print-level and print-circle."
+ :prefix "print-"
+ :group 'lisp
+ :group 'extensions)
;; If using cl-packages:
'(in-package cust-print)
-(require 'backquote)
-
-;; Emacs 18 doesnt have defalias.
+;; Emacs 18 doesn't have defalias.
;; Provide def for byte compiler.
(eval-and-compile
(or (fboundp 'defalias) (fset 'defalias 'fset)))
;; "*Controls how many elements of a list, at each level, are printed.
;;This is defined by emacs.")
-(defvar print-level nil
- "*Controls how many levels deep a nested data object will print.
+(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:
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.")
+level 1."
+ :type '(choice (const nil) integer)
+ :group 'cust-print)
-(defvar print-circle nil
- "*Controls the printing of recursive structures.
+(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:
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.")
+but if you need to do so, try the cl-read.el package."
+ :type 'boolean
+ :group 'cust-print)
-(defvar custom-print-vectors nil
+(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.")
+print-level, but not for vectors."
+ :type 'boolean
+ :group 'cust-print)
\f
;; Custom printers
;;==========================================================
-(defconst custom-printers nil
+(defvar custom-printers nil
;; e.g. '((symbolp . pkg::print-symbol))
"An alist for custom printing of any type.
Pairs are of the form (PREDICATE . PRINTER). If PREDICATE is true
`delete-custom-printer'")
;; Should cust-print-original-princ and cust-print-prin be exported symbols?
;; Or should the standard printers functions be replaced by
-;; CP ones in elisp so that CP internal functions need not be called?
+;; CP ones in Emacs Lisp so that CP internal functions need not be called?
(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)
+ (setq custom-printers (cons (cons pred printer)
(delq (assq pred custom-printers)
custom-printers)))
;; Rather than updating here, we could wait until cust-print-top-level is called.
(defun cust-print-update-custom-printers ()
;; Modify the definition of cust-print-use-custom-printer
(defalias 'cust-print-use-custom-printer
- ;; We dont really want to require the byte-compiler.
+ ;; We don't really want to require the byte-compiler.
;; (byte-compile
- (` (lambda (object)
- (cond
- (,@ (mapcar (function
- (lambda (pair)
- (` (((, (car pair)) object)
- ((, (cdr pair)) object)))))
- custom-printers))
- ;; Otherwise return nil.
- (t nil)
- )))
- ;; )
- ))
+ `(lambda (object)
+ (cond
+ ,@(mapcar (function
+ (lambda (pair)
+ `((,(car pair) object)
+ (,(cdr pair) object))))
+ custom-printers)
+ ;; Otherwise return nil.
+ (t nil)
+ ))
+ ;; )
+ ))
\f
;; Saving and restoring emacs printing routines.
;;====================================================
(defun cust-print-set-function-cell (symbol-pair)
- (defalias (car symbol-pair)
+ (defalias (car symbol-pair)
(symbol-function (car (cdr symbol-pair)))))
(defun cust-print-original-princ (object &optional stream)) ; dummy def
(defun custom-print-install ()
"Replace print functions with general, customizable, Lisp versions.
-The emacs subroutines are saved away, and you can reinstall them
+The Emacs subroutines are saved away, and you can reinstall them
by running `custom-print-uninstall'."
(interactive)
(mapcar 'cust-print-set-function-cell
(error custom-error)
))
t)
-
+
(defun custom-print-uninstall ()
- "Reset print functions to their emacs subroutines."
+ "Reset print functions to their Emacs subroutines."
(interactive)
(mapcar 'cust-print-set-function-cell
'((prin1 cust-print-original-prin1)
(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))))
+ `(unwind-protect
+ (progn
+ (custom-print-install)
+ ,@body)
+ (custom-print-uninstall)))
\f
;; Lisp replacements for prin1 and princ, and for some subrs that use them
(cust-print-top-level object stream 'cust-print-original-princ))
-(defun custom-prin1-to-string (object)
+(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.
+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*")))
- ;; We must erase the buffer before printing in case an error
- ;; occured during the last prin1-to-string and we are in debugger.
+ ;; We must erase the buffer before printing in case an error
+ ;; occurred during the last prin1-to-string and we are in debugger.
(save-excursion
(set-buffer buf)
(erase-buffer))
;; We must be in the current-buffer when the print occurs.
- (custom-prin1 object buf)
+ (if noescape
+ (custom-princ object buf)
+ (custom-prin1 object buf))
(save-excursion
(set-buffer buf)
(buffer-string)
(defun custom-format (fmt &rest args)
- "Format a string out of a control-string and arguments.
+ "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.
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,
+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
(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 doesn't work to princ the result of custom-format as in:
;; (cust-print-original-princ (apply 'custom-format fmt args))
;; because the echo area requires special handling
- ;; to avoid duplicating the output.
+ ;; to avoid duplicating the output.
;; cust-print-original-message does it right.
(apply 'cust-print-original-message fmt
(mapcar (function (lambda (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'.
;; Set up for printing.
(let ((standard-output (or stream standard-output))
;; circle-table will be non-nil if anything is circular.
- (circle-table (and print-circle
+ (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
+ (defalias 'cust-print-low-level-prin
(cond
((or custom-printers
circle-table
(or print-level print-length)))
'cust-print-print-object)
(t 'cust-print-original-printer)))
- (defalias 'cust-print-prin
+ (defalias 'cust-print-prin
(if circle-table 'cust-print-print-circular 'cust-print-low-level-prin))
(cust-print-prin object)
(defun cust-print-print-object (object)
;; Test object type and print accordingly.
;; Could be called as either cust-print-low-level-prin or cust-print-prin.
- (cond
+ (cond
((null object) (cust-print-original-printer object))
((cust-print-use-custom-printer object) object)
((consp object) (cust-print-list object))
;;==================================
(defun cust-print-preprocess-circle-tree (object)
- ;; Fill up the table.
+ ;; Fill up the table.
(let (;; Table of tags for each object in an object to be printed.
;; A tag is of the form:
;; ( <object> <nil-t-or-id-number> )
(defun cust-print-walk-circle-tree (object)
(let (read-equivalent-p tag)
(while object
- (setq read-equivalent-p
- (or (numberp object)
+ (setq read-equivalent-p
+ (or (numberp object)
(and (symbolp object)
;; Check if it is uninterned.
(eq object (intern-soft (symbol-name object)))))
(cons (list object)
(cdr circle-table)))))
(setq object
- (cond
+ (cond
(tag ;; No need to descend since we have already.
nil)
(provide 'cust-print)
+;;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580
;;; cust-print.el ends here
-
HCoop / bpt / emacs.git / blobdiff