mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-05 08:53:45 +00:00
693 lines
24 KiB
EmacsLisp
693 lines
24 KiB
EmacsLisp
;;; cust-print.el --- handles print-level and print-circle
|
||
|
||
;; Copyright (C) 1992 Free Software Foundation, Inc.
|
||
|
||
;; Author: Daniel LaLiberte <liberte@holonexus.org>
|
||
;; Adapted-By: ESR
|
||
;; Keywords: extensions
|
||
|
||
;; LCD Archive Entry:
|
||
;; cust-print|Daniel LaLiberte|liberte@holonexus.org
|
||
;; |Handle print-level, print-circle and more.
|
||
|
||
;; This file is part of GNU Emacs.
|
||
|
||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 2, or (at your option)
|
||
;; any later version.
|
||
|
||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; 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, Inc., 59 Temple Place - Suite 330,
|
||
;; Boston, MA 02111-1307, USA.
|
||
|
||
;;; Commentary:
|
||
|
||
;; This package provides a general print handler for prin1 and princ
|
||
;; that supports print-level and print-circle, and by the way,
|
||
;; 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.
|
||
|
||
;; If the results of your expressions contain circular references to
|
||
;; other parts of the same structure, the standard Emacs print
|
||
;; subroutines may fail to print with an untrappable error,
|
||
;; "Apparently circular structure being printed". If you only use cdr
|
||
;; circular lists (where cdrs of lists point back; what is the right
|
||
;; term here?), you can limit the length of printing with
|
||
;; print-length. But car circular lists and circular vectors generate
|
||
;; the above mentioned error in Emacs version 18. Version
|
||
;; 19 supports print-level, but it is often useful to get a better
|
||
;; print representation of circular and shared structures; the print-circle
|
||
;; option may be used to print more concise representations.
|
||
|
||
;; There are three main ways to use this package. First, you may
|
||
;; replace prin1, princ, and some subroutines that use them by calling
|
||
;; install-custom-print so that any use of these functions in
|
||
;; Lisp code will be affected; you can later reset with
|
||
;; uninstall-custom-print. Second, you may temporarily install
|
||
;; these functions with the macro with-custom-print. Third, you
|
||
;; could call the custom routines directly, thus only affecting the
|
||
;; printing that requires them.
|
||
|
||
;; Note that subroutines which call print subroutines directly will
|
||
;; not use the custom print functions. In particular, the evaluation
|
||
;; functions like eval-region call the print subroutines directly.
|
||
;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a
|
||
;; circular list rather than an array, aref calls error directly which
|
||
;; will jump to the top level instead of printing the circular list.
|
||
|
||
;; Uninterned symbols are recognized when print-circle is non-nil,
|
||
;; but they are not printed specially here. Use the cl-packages package
|
||
;; to print according to print-gensym.
|
||
|
||
;; Obviously the right way to implement this custom-print facility is
|
||
;; in C or with hooks into the standard printer. Please volunteer
|
||
;; since I don't have the time or need. More CL-like printing
|
||
;; capabilities could be added in the future.
|
||
|
||
;; Implementation design: we want to use the same list and vector
|
||
;; processing algorithm for all versions of prin1 and princ, since how
|
||
;; the processing is done depends on print-length, print-level, and
|
||
;; print-circle. For circle printing, a preprocessing step is
|
||
;; required before the final printing. Thanks to Jamie Zawinski
|
||
;; for motivation and algorithms.
|
||
|
||
|
||
;;; Code:
|
||
|
||
(defgroup cust-print nil
|
||
"Handles print-level and print-circle."
|
||
:prefix "print-"
|
||
:group 'lisp
|
||
:group 'extensions)
|
||
|
||
;; If using cl-packages:
|
||
|
||
'(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)
|
||
|
||
;; Emacs 18 doesn't have defalias.
|
||
;; Provide def for byte compiler.
|
||
(eval-and-compile
|
||
(or (fboundp 'defalias) (fset 'defalias 'fset)))
|
||
|
||
|
||
;; Variables:
|
||
;;=========================================================
|
||
|
||
;;(defvar print-length nil
|
||
;; "*Controls how many elements of a list, at each level, are printed.
|
||
;;This is defined by emacs.")
|
||
|
||
(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)
|
||
|
||
|
||
;; Custom printers
|
||
;;==========================================================
|
||
|
||
(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
|
||
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'")
|
||
;; Should cust-print-original-princ and cust-print-prin be exported symbols?
|
||
;; Or should the standard printers functions be replaced by
|
||
;; 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)
|
||
(delq (assq pred custom-printers)
|
||
custom-printers)))
|
||
;; Rather than updating here, we could wait until cust-print-top-level is called.
|
||
(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)
|
||
;; Default function returns nil.
|
||
nil)
|
||
|
||
(defun cust-print-update-custom-printers ()
|
||
;; Modify the definition of cust-print-use-custom-printer
|
||
(defalias 'cust-print-use-custom-printer
|
||
;; 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)
|
||
))
|
||
;; )
|
||
))
|
||
|
||
|
||
;; Saving and restoring emacs printing routines.
|
||
;;====================================================
|
||
|
||
(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)) ; dummy def
|
||
|
||
;; Save emacs routines.
|
||
(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)))
|
||
|
||
|
||
;; Lisp replacements for prin1 and princ, and for some subrs that use them
|
||
;;===============================================================
|
||
;; - so far only the printing and formatting subrs.
|
||
|
||
(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*")))
|
||
;; 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.
|
||
(if noescape
|
||
(custom-princ object buf)
|
||
(custom-prin1 object buf))
|
||
(save-excursion
|
||
(set-buffer buf)
|
||
(buffer-string)
|
||
;; We could erase the buffer again, but why bother?
|
||
)))
|
||
|
||
|
||
(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."
|
||
;; 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.
|
||
;; cust-print-original-message does it right.
|
||
(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))))
|
||
|
||
|
||
|
||
;; Support for custom prin1 and princ
|
||
;;=========================================
|
||
|
||
;; Defs to quiet byte-compiler.
|
||
(defvar circle-table)
|
||
(defvar cust-print-current-level)
|
||
|
||
(defun cust-print-original-printer (object)) ; One of the standard printers.
|
||
(defun cust-print-low-level-prin (object)) ; Used internally.
|
||
(defun cust-print-prin (object)) ; Call this to print recursively.
|
||
|
||
(defun cust-print-top-level (object stream emacs-printer)
|
||
;; 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
|
||
(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 ; comment out for version 19
|
||
;; Emacs doesn't use print-level or print-length
|
||
;; for vectors, but custom-print can.
|
||
(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)
|
||
;; Test object type and print accordingly.
|
||
;; Could be called as either cust-print-low-level-prin or cust-print-prin.
|
||
(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))
|
||
;; All other types, just print.
|
||
(t (cust-print-original-printer object))))
|
||
|
||
|
||
(defun cust-print-print-circular (object)
|
||
;; Printer for `prin1' and `princ' that handles circular structures.
|
||
;; If OBJECT appears multiply, and has not yet been printed,
|
||
;; prefix with label; if it has been printed, use `#N#' instead.
|
||
;; Otherwise, print normally.
|
||
(let ((tag (assq object circle-table)))
|
||
(if tag
|
||
(let ((id (cdr tag)))
|
||
(if (> id 0)
|
||
(progn
|
||
;; Already printed, so just print id.
|
||
(cust-print-original-princ "#")
|
||
(cust-print-original-princ id)
|
||
(cust-print-original-princ "#"))
|
||
;; Not printed yet, so label with id and print object.
|
||
(setcdr tag (- id)) ; mark it as printed
|
||
(cust-print-original-princ "#")
|
||
(cust-print-original-princ (- id))
|
||
(cust-print-original-princ "=")
|
||
(cust-print-low-level-prin object)
|
||
))
|
||
;; Not repeated in structure.
|
||
(cust-print-low-level-prin object))))
|
||
|
||
|
||
;;================================================
|
||
;; List and vector processing for print functions.
|
||
|
||
(defun cust-print-list (list)
|
||
;; Print a list using print-length, print-level, and print-circle.
|
||
(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)))
|
||
|
||
;; Print the first element always (even if length = 0).
|
||
(cust-print-prin (car list))
|
||
(setq list (cdr list))
|
||
(if list (cust-print-original-princ " "))
|
||
(setq length (1- length))
|
||
|
||
;; Print the rest of the elements.
|
||
(while (and list (/= 0 length))
|
||
(if (and (listp list)
|
||
(not (assq list circle-table)))
|
||
(progn
|
||
(cust-print-prin (car list))
|
||
(setq list (cdr list)))
|
||
|
||
;; cdr is not a list, or it is in circle-table.
|
||
(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)
|
||
;; Print a vector according to print-length, print-level, and print-circle.
|
||
(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)))
|
||
;; Print the elements
|
||
(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)
|
||
|
||
|
||
|
||
;; Circular structure preprocessing
|
||
;;==================================
|
||
|
||
(defun cust-print-preprocess-circle-tree (object)
|
||
;; 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> )
|
||
;; The id-number is generated after the entire table has been computed.
|
||
;; During walk through, the real circle-table lives in the cdr so we
|
||
;; can use setcdr to add new elements instead of having to setq the
|
||
;; variable sometimes (poor man's locf).
|
||
(circle-table (list nil)))
|
||
(cust-print-walk-circle-tree object)
|
||
|
||
;; Reverse table so it is in the order that the objects will be printed.
|
||
;; This pass could be avoided if we always added to the end of the
|
||
;; table with setcdr in walk-circle-tree.
|
||
(setcdr circle-table (nreverse (cdr circle-table)))
|
||
|
||
;; Walk through the table, assigning id-numbers to those
|
||
;; objects which will be printed using #N= syntax. Delete those
|
||
;; objects which will be printed only once (to speed up assq later).
|
||
(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)))
|
||
;; Else delete this object.
|
||
(t (setcdr rest (cdr (cdr rest))))))
|
||
))
|
||
;; Drop the car.
|
||
(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)
|
||
;; Check if it is uninterned.
|
||
(eq object (intern-soft (symbol-name object)))))
|
||
tag (and (not read-equivalent-p)
|
||
(assq object (cdr circle-table))))
|
||
(cond (tag
|
||
;; Seen this object already, so note that.
|
||
(setcdr tag t))
|
||
|
||
((not read-equivalent-p)
|
||
;; Add a tag for this object.
|
||
(setcdr circle-table
|
||
(cons (list object)
|
||
(cdr circle-table)))))
|
||
(setq object
|
||
(cond
|
||
(tag ;; No need to descend since we have already.
|
||
nil)
|
||
|
||
((consp object)
|
||
;; Walk the car of the list recursively.
|
||
(cust-print-walk-circle-tree (car object))
|
||
;; But walk the cdr with the above while loop
|
||
;; to avoid problems with max-lisp-eval-depth.
|
||
;; And it should be faster than recursion.
|
||
(cdr object))
|
||
|
||
((vectorp object)
|
||
;; Walk the vector.
|
||
(let ((i (length object))
|
||
(j 0))
|
||
(while (< j i)
|
||
(cust-print-walk-circle-tree (aref object j))
|
||
(setq j (1+ j))))))))))
|
||
|
||
|
||
;; Example.
|
||
;;=======================================
|
||
|
||
'(progn
|
||
(progn
|
||
;; Create some circular structures.
|
||
(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)
|
||
;; (setq print-circle t)
|
||
|
||
(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))
|
||
;; cl-packages.el is required to print uninterned symbols like #:FOO.
|
||
;; (require 'cl-packages)
|
||
(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)
|
||
|
||
;;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580
|
||
;;; cust-print.el ends here
|