X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/92ad69b62e62455ca7dfd42d141fce3f15ff3fcc..654359e2e3cbae9727b2bf6a298054bee9e10d41:/lisp/emacs-lisp/cust-print.el

diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el
index 965b52e4b8..b7cc52a983 100644
--- a/lisp/emacs-lisp/cust-print.el
+++ b/lisp/emacs-lisp/cust-print.el
@@ -1,11 +1,14 @@
-;; 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.
 
-;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
-;; Version: 1.0
+;; Author: Daniel LaLiberte <liberte@holonexus.org>
 ;; Adapted-By: ESR
-;; Keyword: extensions
+;; 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.
 
@@ -20,8 +23,9 @@
 ;; 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.
+;; 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:
 
@@ -30,7 +34,7 @@
 ;; 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
@@ -39,27 +43,35 @@
 ;; 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 untrappable error in Emacs version 18.  Version
-;; 19 will support print-level, but it is often useful to get a better
-;; print representation of circular structures; the print-circle
+;; 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 two main ways to use this package.  First, you may
+;; 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-funcs so that any use of these functions in
-;; lisp code will be affected.  Second, 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
+;; 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, evaluating (aref circ-list 0), which calls error
-;; directly (because circ-list is not an array), will jump to the top
-;; level instead of printing the circular list.
+;; 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.
 
-;; Obviously the right way to implement this custom-print facility
-;; is in C.  Please volunteer since I don't have the time or need.
+;; 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
@@ -68,124 +80,183 @@
 ;; required before the final printing.  Thanks to Jamie Zawinski
 ;; for motivation and algorithms.
 
-;;=========================================================
-;; export list:
-
-;; print-level
-;; print-circle
-
-;; custom-print-list
-;; custom-print-vector
-;; add-custom-print-list
-;; add-custom-print-vector
+
+;;; Code:
 
-;; install-custom-print-funcs
-;; uninstall-custom-print-funcs
+(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
+    ))
 
-;; custom-prin1
-;; custom-princ
-;; custom-prin1-to-string
-;; custom-print
-;; custom-format
-;; custom-message
-;; custom-error
+'(in-package cust-print)
 
-;;; Code:
+;; Emacs 18 doesn't have defalias.
+;; Provide def for byte compiler.
+(eval-and-compile
+  (or (fboundp 'defalias) (fset 'defalias 'fset)))
 
-(provide 'custom-print)
+
+;; Variables:
+;;=========================================================
 
 ;;(defvar print-length nil
 ;;  "*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 untrappable error may occur:
+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.")
+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 untrappable error may occur:
+`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 occurance (in the order of the print
-representation) and `#N#' in place of each subsequent occurance,
+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.
 
-Currently, there is no way to read this representation in Emacs.")
-
-
-(defconst custom-print-list
-  nil
-  ;; e.g.  '((floatp . float-to-string))
-  "An alist for custom printing of lists.  
-Pairs are of the form (PRED . CONVERTER).  If PREDICATE is true
-for an object, then CONVERTER is called with the object and should
-return a string to be printed with `princ'.  
-Also see `custom-print-vector'.")
-
-(defconst custom-print-vector
-  nil
-  "An alist for custom printing of vectors.  
-Pairs are of the form (PRED . CONVERTER).  If PREDICATE is true
-for an object, then CONVERTER is called with the object and should
-return a string to be printed with `princ'.  
-Also see `custom-print-list'.")
-
-
-(defun add-custom-print-list (pred converter)
-  "Add a pair of PREDICATE and CONVERTER to `custom-print-list'.
-Any pair that has the same PREDICATE is first removed."
-  (setq custom-print-list (cons (cons pred converter) 
-				(delq (assq pred custom-print-list)
-				      custom-print-list))))
-;; e.g. (add-custom-print-list 'floatp 'float-to-string)
-
-
-(defun add-custom-print-vector (pred converter)
-  "Add a pair of PREDICATE and CONVERTER to `custom-print-vector'.
+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-print-vector (cons (cons pred converter) 
-				  (delq (assq pred custom-print-vector)
-					custom-print-vector))))
-
+  (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.
 ;;====================================================
-;; Saving and restoring internal printing routines.
 
 (defun cust-print-set-function-cell (symbol-pair)
-  (fset (car symbol-pair) 
-	(symbol-function (car (cdr symbol-pair)))))
+  (defalias (car symbol-pair)
+    (symbol-function (car (cdr symbol-pair)))))
 
+(defun cust-print-original-princ (object &optional stream)) ; dummy def
 
-(if (not (fboundp 'cust-print-internal-prin1))
+;; Save emacs routines.
+(if (not (fboundp 'cust-print-original-prin1))
     (mapcar 'cust-print-set-function-cell
-	    '((cust-print-internal-prin1 prin1)
-	      (cust-print-internal-princ princ)
-	      (cust-print-internal-print print)
-	      (cust-print-internal-prin1-to-string prin1-to-string)
-	      (cust-print-internal-format format)
-	      (cust-print-internal-message message)
-	      (cust-print-internal-error error))))
+	    '((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 install-custom-print-funcs ()
+(defun custom-print-install ()
   "Replace print functions with general, customizable, Lisp versions.
-The internal subroutines are saved away, and you can reinstall them
-by running `uninstall-custom-print-funcs'."
+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)
@@ -195,193 +266,229 @@ by running `uninstall-custom-print-funcs'."
 	    (format custom-format)
 	    (message custom-message)
 	    (error custom-error)
-	    )))
-  
-(defun uninstall-custom-print-funcs ()
-  "Reset print functions to their internal subroutines."
+	    ))
+  t)
+
+(defun custom-print-uninstall ()
+  "Reset print functions to their emacs subroutines."
   (interactive)
   (mapcar 'cust-print-set-function-cell
-	  '((prin1 cust-print-internal-prin1)
-	    (princ cust-print-internal-princ)
-	    (print cust-print-internal-print)
-	    (prin1-to-string cust-print-internal-prin1-to-string)
-	    (format cust-print-internal-format)
-	    (message cust-print-internal-message)
-	    (error cust-print-internal-error)
-	    )))
-
-
+	  '((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
 ;;===============================================================
-;; Lisp replacements for prin1 and princ and for subrs that use prin1 
-;; (or princ) -- so far only the printing and formatting subrs.
+;; - so far only the printing and formatting subrs.
 
 (defun custom-prin1 (object &optional stream)
-  "Replacement for standard `prin1'.
-Uses the appropriate printer depending on the values of `print-level'
-and `print-circle' (which see).
-
-Output the printed representation of OBJECT, any Lisp object.
+  "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)."
-  (cust-print-top-level object stream 'cust-print-internal-prin1))
+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)
-  "Same as `custom-prin1' except no quoting."
-  (cust-print-top-level object stream 'cust-print-internal-princ))
-
-(defvar custom-prin1-chars)
 
-(defun custom-prin1-to-string-func (c)
-  "Stream function for `custom-prin1-to-string'."
-  (setq custom-prin1-chars (cons c custom-prin1-chars)))
-
-(defun custom-prin1-to-string (object)
-  "Replacement for standard `prin1-to-string'."
-  (let ((custom-prin1-chars nil))
-    (custom-prin1 object 'custom-prin1-to-string-func)
-    (concat (nreverse custom-prin1-chars))))
+(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)
-  "Replacement for standard `print'."
-  (cust-print-internal-princ "\n")
+  "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-internal-princ "\n"))
+  (cust-print-original-princ "\n" stream))
 
 
 (defun custom-format (fmt &rest args)
-  "Replacement for standard `format'.
-
-Calls format after first making strings for list or vector 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-internal-format fmt
+  "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))
+			     (if (or (listp arg) (vectorp arg) (symbolp arg))
 				 (custom-prin1-to-string arg)
 			       arg)))
 		 args)))
-	    
-  
+
 
 (defun custom-message (fmt &rest args)
-  "Replacement for standard `message' that works like `custom-format'."
-  ;; It doesnt work to princ the result of custom-format
+  "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-internal-message does it right.
-  ;; (cust-print-internal-princ (apply 'custom-format fmt args))
-  (apply 'cust-print-internal-message  fmt
+  ;; 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))
+			     (if (or (listp arg) (vectorp arg) (symbolp arg))
 				 (custom-prin1-to-string arg)
 			       arg)))
 		 args)))
-	    
+
 
 (defun custom-error (fmt &rest args)
-  "Replacement for standard `error' that uses `custom-format'"
+  "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 circle-tree)
-(defvar circle-level)
+(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 internal-printer)
-  "Set up for printing."
+(defun cust-print-top-level (object stream emacs-printer)
+  ;; Set up for printing.
   (let ((standard-output (or stream standard-output))
-	(circle-table (and print-circle (cust-print-preprocess-circle-tree object)))
-	(circle-level (or print-level -1))
-	)
-
-    (fset 'cust-print-internal-printer internal-printer)
-    (fset 'cust-print-low-level-prin 
-	  (cond
-	   ((or custom-print-list
-		custom-print-vector
-		print-level ; comment out for version 19
-		)
-	    'cust-print-custom-object)
-	   (circle-table
-	    'cust-print-object)
-	   (t 'cust-print-internal-printer)))
-    (fset 'cust-print-prin (if circle-table 'cust-print-circular 'cust-print-low-level-prin))
+	;; 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))
 
 
-;; Test object type and print accordingly.
-(defun cust-print-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-internal-printer 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))
    ;; All other types, just print.
-   (t (cust-print-internal-printer object))))
-
-
-;; Test object type and print accordingly.
-(defun cust-print-custom-object (object)
-  ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
-  (cond 
-   ((null object) (cust-print-internal-printer object))
+   (t (cust-print-original-printer object))))
 
-   ((consp object) 
-    (or (and custom-print-list
-	     (cust-print-custom-object1 object custom-print-list))
-	(cust-print-list object)))
 
-   ((vectorp object) 
-    (or (and custom-print-vector
-	     (cust-print-custom-object1 object custom-print-vector))
-	(cust-print-vector object)))
-
-   ;; All other types, just print.
-   (t (cust-print-internal-printer object))))
-
-
-;; Helper for cust-print-custom-object.
-;; Print the custom OBJECT using the custom type ALIST.
-;; For the first predicate that matches the object, the corresponding
-;; converter is evaluated with the object and the string that results is
-;; printed with princ.  Return nil if no predicte matches the object.
-(defun cust-print-custom-object1 (object alist)
-  (while (and alist (not (funcall (car (car alist)) object)))
-    (setq alist (cdr alist)))
-  ;; If alist is not null, then something matched.
-  (if alist
-      (cust-print-internal-princ
-       (funcall (cdr (car alist)) object) ; returns string
-       )))
-
-
-(defun cust-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."
+(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-internal-princ "#")
-		(cust-print-internal-princ id)
-		(cust-print-internal-princ "#"))
+		(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-internal-princ "#")
-	    (cust-print-internal-princ (- id))
-	    (cust-print-internal-princ "=")
+	    (cust-print-original-princ "#")
+	    (cust-print-original-princ (- id))
+	    (cust-print-original-princ "=")
 	    (cust-print-low-level-prin object)
 	    ))
       ;; Not repeated in structure.
@@ -391,18 +498,18 @@ Otherwise, print normally."
 ;;================================================
 ;; List and vector processing for print functions.
 
-;; Print a list using print-length, print-level, and print-circle.
 (defun cust-print-list (list)
-  (if (= circle-level 0)
-      (cust-print-internal-princ "#")
-    (let ((circle-level (1- circle-level)))
-      (cust-print-internal-princ "(")
+  ;; 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-internal-princ " "))
+	(if list (cust-print-original-princ " "))
 	(setq length (1- length))
 
 	;; Print the rest of the elements.
@@ -414,26 +521,26 @@ Otherwise, print normally."
 		(setq list (cdr list)))
 
 	    ;; cdr is not a list, or it is in circle-table.
-	    (cust-print-internal-princ ". ")
+	    (cust-print-original-princ ". ")
 	    (cust-print-prin list)
 	    (setq list nil))
 
 	  (setq length (1- length))
-	  (if list (cust-print-internal-princ " ")))
+	  (if list (cust-print-original-princ " ")))
 
-	(if (and list (= length 0)) (cust-print-internal-princ "..."))
-	(cust-print-internal-princ ")"))))
+	(if (and list (= length 0)) (cust-print-original-princ "..."))
+	(cust-print-original-princ ")"))))
   list)
 
 
-;; Print a vector according to print-length, print-level, and print-circle.
 (defun cust-print-vector (vector)
-  (if (= circle-level 0)
-      (cust-print-internal-princ "#")
-    (let ((circle-level (1- circle-level))
+  ;; 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-internal-princ "[")
+      (cust-print-original-princ "[")
 
       (if print-length
 	  (setq len (min print-length len)))
@@ -441,19 +548,20 @@ Otherwise, print normally."
       (while (< i len)
 	(cust-print-prin (aref vector i))
 	(setq i (1+ i))
-	(if (< i (length vector)) (cust-print-internal-princ " ")))
+	(if (< i (length vector)) (cust-print-original-princ " ")))
 
-      (if (< i (length vector)) (cust-print-internal-princ "..."))
-      (cust-print-internal-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.  
+  ;; 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> )
@@ -492,7 +600,11 @@ Otherwise, print normally."
 (defun cust-print-walk-circle-tree (object)
   (let (read-equivalent-p tag)
     (while object
-      (setq read-equivalent-p (or (numberp object) (symbolp 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
@@ -505,7 +617,7 @@ Otherwise, print normally."
 		     (cons (list object)
 			   (cdr circle-table)))))
       (setq object
-	    (cond 
+	    (cond
 	     (tag ;; No need to descend since we have already.
 	      nil)
 
@@ -525,49 +637,56 @@ Otherwise, print normally."
 		  (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")))
 
-;; Example.
+   (uninstall-custom-print)
+   )
 
-;;;; 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))
-
-;;(install-custom-print-funcs)
-;;;; (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")))
-
-;;;; There's no special handling of uninterned symbols in custom-print.
-;;(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-funcs)
+(provide 'cust-print)
 
+;;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580
 ;;; cust-print.el ends here