code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/cust-print.el

   1 ;;; cust-print.el --- handles print-level and print-circle
   2
   3 ;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005,
   4 ;;   2006, 2007, 2008, 2009 Free Software Foundation, Inc.
   5
   6 ;; Author: Daniel LaLiberte <liberte@holonexus.org>
   7 ;; Adapted-By: ESR
   8 ;; Keywords: extensions
   9
  10 ;; LCD Archive Entry:
  11 ;; cust-print|Daniel LaLiberte|liberte@holonexus.org
  12 ;; |Handle print-level, print-circle and more.
  13
  14 ;; This file is part of GNU Emacs.
  15
  16 ;; GNU Emacs is free software: you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation, either version 3 of the License, or
  19 ;; (at your option) any later version.
  20
  21 ;; GNU Emacs is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  28
  29 ;;; Commentary:
  30
  31 ;; This package provides a general print handler for prin1 and princ
  32 ;; that supports print-level and print-circle, and by the way,
  33 ;; print-length since the standard routines are being replaced.  Also,
  34 ;; to print custom types constructed from lists and vectors, use
  35 ;; custom-print-list and custom-print-vector.  See the documentation
  36 ;; strings of these variables for more details.
  37
  38 ;; If the results of your expressions contain circular references to
  39 ;; other parts of the same structure, the standard Emacs print
  40 ;; subroutines may fail to print with an untrappable error,
  41 ;; "Apparently circular structure being printed".  If you only use cdr
  42 ;; circular lists (where cdrs of lists point back; what is the right
  43 ;; term here?), you can limit the length of printing with
  44 ;; print-length.  But car circular lists and circular vectors generate
  45 ;; the above mentioned error in Emacs version 18.  Version
  46 ;; 19 supports print-level, but it is often useful to get a better
  47 ;; print representation of circular and shared structures; the print-circle
  48 ;; option may be used to print more concise representations.
  49
  50 ;; There are three main ways to use this package.  First, you may
  51 ;; replace prin1, princ, and some subroutines that use them by calling
  52 ;; install-custom-print so that any use of these functions in
  53 ;; Lisp code will be affected; you can later reset with
  54 ;; uninstall-custom-print.  Second, you may temporarily install
  55 ;; these functions with the macro with-custom-print.  Third, you
  56 ;; could call the custom routines directly, thus only affecting the
  57 ;; printing that requires them.
  58
  59 ;; Note that subroutines which call print subroutines directly will
  60 ;; not use the custom print functions.  In particular, the evaluation
  61 ;; functions like eval-region call the print subroutines directly.
  62 ;; Therefore, if you evaluate (aref circ-list 0), where circ-list is a
  63 ;; circular list rather than an array, aref calls error directly which
  64 ;; will jump to the top level instead of printing the circular list.
  65
  66 ;; Uninterned symbols are recognized when print-circle is non-nil,
  67 ;; but they are not printed specially here.  Use the cl-packages package
  68 ;; to print according to print-gensym.
  69
  70 ;; Obviously the right way to implement this custom-print facility is
  71 ;; in C or with hooks into the standard printer.  Please volunteer
  72 ;; since I don't have the time or need.  More CL-like printing
  73 ;; capabilities could be added in the future.
  74
  75 ;; Implementation design: we want to use the same list and vector
  76 ;; processing algorithm for all versions of prin1 and princ, since how
  77 ;; the processing is done depends on print-length, print-level, and
  78 ;; print-circle.  For circle printing, a preprocessing step is
  79 ;; required before the final printing.  Thanks to Jamie Zawinski
  80 ;; for motivation and algorithms.
  81
  82 \f
  83 ;;; Code:
  84
  85 (defgroup cust-print nil
  86   "Handles print-level and print-circle."
  87   :prefix "print-"
  88   :group 'lisp
  89   :group 'extensions)
  90
  91 ;; If using cl-packages:
  92
  93 '(defpackage "cust-print"
  94    (:nicknames "CP" "custom-print")
  95    (:use "el")
  96    (:export
  97     print-level
  98     print-circle
  99
 100     custom-print-install
 101     custom-print-uninstall
 102     custom-print-installed-p
 103     with-custom-print
 104
 105     custom-prin1
 106     custom-princ
 107     custom-prin1-to-string
 108     custom-print
 109     custom-format
 110     custom-message
 111     custom-error
 112
 113     custom-printers
 114     add-custom-printer
 115     ))
 116
 117 '(in-package cust-print)
 118
 119 ;; Emacs 18 doesn't have defalias.
 120 ;; Provide def for byte compiler.
 121 (eval-and-compile
 122   (or (fboundp 'defalias) (fset 'defalias 'fset)))
 123
 124 \f
 125 ;; Variables:
 126 ;;=========================================================
 127
 128 ;;(defvar print-length nil
 129 ;;  "*Controls how many elements of a list, at each level, are printed.
 130 ;;This is defined by emacs.")
 131
 132 (defcustom print-level nil
 133   "*Controls how many levels deep a nested data object will print.
 134
 135 If nil, printing proceeds recursively and may lead to
 136 max-lisp-eval-depth being exceeded or an error may occur:
 137 `Apparently circular structure being printed.'
 138 Also see `print-length' and `print-circle'.
 139
 140 If non-nil, components at levels equal to or greater than `print-level'
 141 are printed simply as `#'.  The object to be printed is at level 0,
 142 and if the object is a list or vector, its top-level components are at
 143 level 1."
 144   :type '(choice (const nil) integer)
 145   :group 'cust-print)
 146
 147
 148 (defcustom print-circle nil
 149   "*Controls the printing of recursive structures.
 150
 151 If nil, printing proceeds recursively and may lead to
 152 `max-lisp-eval-depth' being exceeded or an error may occur:
 153 \"Apparently circular structure being printed.\"  Also see
 154 `print-length' and `print-level'.
 155
 156 If non-nil, shared substructures anywhere in the structure are printed
 157 with `#N=' before the first occurrence (in the order of the print
 158 representation) and `#N#' in place of each subsequent occurrence,
 159 where N is a positive decimal integer.
 160
 161 There is no way to read this representation in standard Emacs,
 162 but if you need to do so, try the cl-read.el package."
 163   :type 'boolean
 164   :group 'cust-print)
 165
 166
 167 (defcustom custom-print-vectors nil
 168   "*Non-nil if printing of vectors should obey print-level and print-length.
 169
 170 For Emacs 18, setting print-level, or adding custom print list or
 171 vector handling will make this happen anyway.  Emacs 19 obeys
 172 print-level, but not for vectors."
 173   :type 'boolean
 174   :group 'cust-print)
 175
 176 \f
 177 ;; Custom printers
 178 ;;==========================================================
 179
 180 (defvar custom-printers nil
 181   ;; e.g. '((symbolp . pkg::print-symbol))
 182   "An alist for custom printing of any type.
 183 Pairs are of the form (PREDICATE . PRINTER).  If PREDICATE is true
 184 for an object, then PRINTER is called with the object.
 185 PRINTER should print to `standard-output' using cust-print-original-princ
 186 if the standard printer is sufficient, or cust-print-prin for complex things.
 187 The PRINTER should return the object being printed.
 188
 189 Don't modify this variable directly.  Use `add-custom-printer' and
 190 `delete-custom-printer'")
 191 ;; Should cust-print-original-princ and cust-print-prin be exported symbols?
 192 ;; Or should the standard printers functions be replaced by
 193 ;; CP ones in Emacs Lisp so that CP internal functions need not be called?
 194
 195 (defun add-custom-printer (pred printer)
 196   "Add a pair of PREDICATE and PRINTER to `custom-printers'.
 197 Any pair that has the same PREDICATE is first removed."
 198   (setq custom-printers (cons (cons pred printer)
 199                               (delq (assq pred custom-printers)
 200                                     custom-printers)))
 201   ;; Rather than updating here, we could wait until cust-print-top-level is called.
 202   (cust-print-update-custom-printers))
 203
 204 (defun delete-custom-printer (pred)
 205   "Delete the custom printer associated with PREDICATE."
 206   (setq custom-printers (delq (assq pred custom-printers)
 207                               custom-printers))
 208   (cust-print-update-custom-printers))
 209
 210
 211 (defun cust-print-use-custom-printer (object)
 212   ;; Default function returns nil.
 213   nil)
 214
 215 (defun cust-print-update-custom-printers ()
 216   ;; Modify the definition of cust-print-use-custom-printer
 217   (defalias 'cust-print-use-custom-printer
 218     ;; We don't really want to require the byte-compiler.
 219     ;; (byte-compile
 220     `(lambda (object)
 221        (cond
 222         ,@(mapcar (function
 223                    (lambda (pair)
 224                      `((,(car pair) object)
 225                        (,(cdr pair) object))))
 226                   custom-printers)
 227         ;; Otherwise return nil.
 228         (t nil)
 229         ))
 230     ;; )
 231     ))
 232
 233 \f
 234 ;; Saving and restoring emacs printing routines.
 235 ;;====================================================
 236
 237 (defun cust-print-set-function-cell (symbol-pair)
 238   (defalias (car symbol-pair)
 239     (symbol-function (car (cdr symbol-pair)))))
 240
 241 (defun cust-print-original-princ (object &optional stream)) ; dummy def
 242
 243 ;; Save emacs routines.
 244 (if (not (fboundp 'cust-print-original-prin1))
 245     (mapc 'cust-print-set-function-cell
 246           '((cust-print-original-prin1 prin1)
 247             (cust-print-original-princ princ)
 248             (cust-print-original-print print)
 249             (cust-print-original-prin1-to-string prin1-to-string)
 250             (cust-print-original-format format)
 251             (cust-print-original-message message)
 252             (cust-print-original-error error))))
 253
 254
 255 (defun custom-print-install ()
 256   "Replace print functions with general, customizable, Lisp versions.
 257 The Emacs subroutines are saved away, and you can reinstall them
 258 by running `custom-print-uninstall'."
 259   (interactive)
 260   (mapc 'cust-print-set-function-cell
 261         '((prin1 custom-prin1)
 262           (princ custom-princ)
 263           (print custom-print)
 264           (prin1-to-string custom-prin1-to-string)
 265           (format custom-format)
 266           (message custom-message)
 267           (error custom-error)
 268           ))
 269   t)
 270
 271 (defun custom-print-uninstall ()
 272   "Reset print functions to their Emacs subroutines."
 273   (interactive)
 274   (mapc 'cust-print-set-function-cell
 275         '((prin1 cust-print-original-prin1)
 276           (princ cust-print-original-princ)
 277           (print cust-print-original-print)
 278           (prin1-to-string cust-print-original-prin1-to-string)
 279           (format cust-print-original-format)
 280           (message cust-print-original-message)
 281           (error cust-print-original-error)
 282           ))
 283   t)
 284
 285 (defalias 'custom-print-funcs-installed-p 'custom-print-installed-p)
 286 (defun custom-print-installed-p ()
 287   "Return t if custom-print is currently installed, nil otherwise."
 288   (eq (symbol-function 'custom-prin1) (symbol-function 'prin1)))
 289
 290 (put 'with-custom-print-funcs 'edebug-form-spec '(body))
 291 (put 'with-custom-print 'edebug-form-spec '(body))
 292
 293 (defalias 'with-custom-print-funcs 'with-custom-print)
 294 (defmacro with-custom-print (&rest body)
 295   "Temporarily install the custom print package while executing BODY."
 296   `(unwind-protect
 297        (progn
 298          (custom-print-install)
 299          ,@body)
 300      (custom-print-uninstall)))
 301
 302 \f
 303 ;; Lisp replacements for prin1 and princ, and for some subrs that use them
 304 ;;===============================================================
 305 ;; - so far only the printing and formatting subrs.
 306
 307 (defun custom-prin1 (object &optional stream)
 308   "Output the printed representation of OBJECT, any Lisp object.
 309 Quoting characters are printed when needed to make output that `read'
 310 can handle, whenever this is possible.
 311 Output stream is STREAM, or value of `standard-output' (which see).
 312
 313 This is the custom-print replacement for the standard `prin1'.  It
 314 uses the appropriate printer depending on the values of `print-level'
 315 and `print-circle' (which see)."
 316   (cust-print-top-level object stream 'cust-print-original-prin1))
 317
 318
 319 (defun custom-princ (object &optional stream)
 320   "Output the printed representation of OBJECT, any Lisp object.
 321 No quoting characters are used; no delimiters are printed around
 322 the contents of strings.
 323 Output stream is STREAM, or value of `standard-output' (which see).
 324
 325 This is the custom-print replacement for the standard `princ'."
 326   (cust-print-top-level object stream 'cust-print-original-princ))
 327
 328
 329 (defun custom-prin1-to-string (object &optional noescape)
 330   "Return a string containing the printed representation of OBJECT,
 331 any Lisp object.  Quoting characters are used when needed to make output
 332 that `read' can handle, whenever this is possible, unless the optional
 333 second argument NOESCAPE is non-nil.
 334
 335 This is the custom-print replacement for the standard `prin1-to-string'."
 336   (let ((buf (get-buffer-create " *custom-print-temp*")))
 337     ;; We must erase the buffer before printing in case an error
 338     ;; occurred during the last prin1-to-string and we are in debugger.
 339     (save-excursion
 340       (set-buffer buf)
 341       (erase-buffer))
 342     ;; We must be in the current-buffer when the print occurs.
 343     (if noescape
 344         (custom-princ object buf)
 345       (custom-prin1 object buf))
 346     (save-excursion
 347       (set-buffer buf)
 348       (buffer-string)
 349       ;; We could erase the buffer again, but why bother?
 350       )))
 351
 352
 353 (defun custom-print (object &optional stream)
 354   "Output the printed representation of OBJECT, with newlines around it.
 355 Quoting characters are printed when needed to make output that `read'
 356 can handle, whenever this is possible.
 357 Output stream is STREAM, or value of `standard-output' (which see).
 358
 359 This is the custom-print replacement for the standard `print'."
 360   (cust-print-original-princ "\n" stream)
 361   (custom-prin1 object stream)
 362   (cust-print-original-princ "\n" stream))
 363
 364
 365 (defun custom-format (fmt &rest args)
 366   "Format a string out of a control-string and arguments.
 367 The first argument is a control string.  It, and subsequent arguments
 368 substituted into it, become the value, which is a string.
 369 It may contain %s or %d or %c to substitute successive following arguments.
 370 %s means print an argument as a string, %d means print as number in decimal,
 371 %c means print a number as a single character.
 372 The argument used by %s must be a string or a symbol;
 373 the argument used by %d, %b, %o, %x or %c must be a number.
 374
 375 This is the custom-print replacement for the standard `format'.  It
 376 calls the Emacs `format' after first making strings for list,
 377 vector, or symbol args.  The format specification for such args should
 378 be `%s' in any case, so a string argument will also work.  The string
 379 is generated with `custom-prin1-to-string', which quotes quotable
 380 characters."
 381   (apply 'cust-print-original-format fmt
 382          (mapcar (function (lambda (arg)
 383                              (if (or (listp arg) (vectorp arg) (symbolp arg))
 384                                  (custom-prin1-to-string arg)
 385                                arg)))
 386                  args)))
 387
 388
 389 (defun custom-message (fmt &rest args)
 390   "Print a one-line message at the bottom of the screen.
 391 The first argument is a control string.
 392 It may contain %s or %d or %c to print successive following arguments.
 393 %s means print an argument as a string, %d means print as number in decimal,
 394 %c means print a number as a single character.
 395 The argument used by %s must be a string or a symbol;
 396 the argument used by %d or %c must be a number.
 397
 398 This is the custom-print replacement for the standard `message'.
 399 See `custom-format' for the details."
 400   ;; It doesn't work to princ the result of custom-format as in:
 401   ;; (cust-print-original-princ (apply 'custom-format fmt args))
 402   ;; because the echo area requires special handling
 403   ;; to avoid duplicating the output.
 404   ;; cust-print-original-message does it right.
 405   (apply 'cust-print-original-message  fmt
 406          (mapcar (function (lambda (arg)
 407                              (if (or (listp arg) (vectorp arg) (symbolp arg))
 408                                  (custom-prin1-to-string arg)
 409                                arg)))
 410                  args)))
 411
 412
 413 (defun custom-error (fmt &rest args)
 414   "Signal an error, making error message by passing all args to `format'.
 415
 416 This is the custom-print replacement for the standard `error'.
 417 See `custom-format' for the details."
 418   (signal 'error (list (apply 'custom-format fmt args))))
 419
 420
 421 \f
 422 ;; Support for custom prin1 and princ
 423 ;;=========================================
 424
 425 ;; Defs to quiet byte-compiler.
 426 (defvar circle-table)
 427 (defvar cust-print-current-level)
 428
 429 (defun cust-print-original-printer (object))  ; One of the standard printers.
 430 (defun cust-print-low-level-prin (object))    ; Used internally.
 431 (defun cust-print-prin (object))              ; Call this to print recursively.
 432
 433 (defun cust-print-top-level (object stream emacs-printer)
 434   ;; Set up for printing.
 435   (let ((standard-output (or stream standard-output))
 436         ;; circle-table will be non-nil if anything is circular.
 437         (circle-table (and print-circle
 438                            (cust-print-preprocess-circle-tree object)))
 439         (cust-print-current-level (or print-level -1)))
 440
 441     (defalias 'cust-print-original-printer emacs-printer)
 442     (defalias 'cust-print-low-level-prin
 443       (cond
 444        ((or custom-printers
 445             circle-table
 446             print-level                 ; comment out for version 19
 447             ;; Emacs doesn't use print-level or print-length
 448             ;; for vectors, but custom-print can.
 449             (if custom-print-vectors
 450                 (or print-level print-length)))
 451         'cust-print-print-object)
 452        (t 'cust-print-original-printer)))
 453     (defalias 'cust-print-prin
 454       (if circle-table 'cust-print-print-circular 'cust-print-low-level-prin))
 455
 456     (cust-print-prin object)
 457     object))
 458
 459
 460 (defun cust-print-print-object (object)
 461   ;; Test object type and print accordingly.
 462   ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
 463   (cond
 464    ((null object) (cust-print-original-printer object))
 465    ((cust-print-use-custom-printer object) object)
 466    ((consp object) (cust-print-list object))
 467    ((vectorp object) (cust-print-vector object))
 468    ;; All other types, just print.
 469    (t (cust-print-original-printer object))))
 470
 471
 472 (defun cust-print-print-circular (object)
 473   ;; Printer for `prin1' and `princ' that handles circular structures.
 474   ;; If OBJECT appears multiply, and has not yet been printed,
 475   ;; prefix with label; if it has been printed, use `#N#' instead.
 476   ;; Otherwise, print normally.
 477   (let ((tag (assq object circle-table)))
 478     (if tag
 479         (let ((id (cdr tag)))
 480           (if (> id 0)
 481               (progn
 482                 ;; Already printed, so just print id.
 483                 (cust-print-original-princ "#")
 484                 (cust-print-original-princ id)
 485                 (cust-print-original-princ "#"))
 486             ;; Not printed yet, so label with id and print object.
 487             (setcdr tag (- id)) ; mark it as printed
 488             (cust-print-original-princ "#")
 489             (cust-print-original-princ (- id))
 490             (cust-print-original-princ "=")
 491             (cust-print-low-level-prin object)
 492             ))
 493       ;; Not repeated in structure.
 494       (cust-print-low-level-prin object))))
 495
 496
 497 ;;================================================
 498 ;; List and vector processing for print functions.
 499
 500 (defun cust-print-list (list)
 501   ;; Print a list using print-length, print-level, and print-circle.
 502   (if (= cust-print-current-level 0)
 503       (cust-print-original-princ "#")
 504     (let ((cust-print-current-level (1- cust-print-current-level)))
 505       (cust-print-original-princ "(")
 506       (let ((length (or print-length 0)))
 507
 508         ;; Print the first element always (even if length = 0).
 509         (cust-print-prin (car list))
 510         (setq list (cdr list))
 511         (if list (cust-print-original-princ " "))
 512         (setq length (1- length))
 513
 514         ;; Print the rest of the elements.
 515         (while (and list (/= 0 length))
 516           (if (and (listp list)
 517                    (not (assq list circle-table)))
 518               (progn
 519                 (cust-print-prin (car list))
 520                 (setq list (cdr list)))
 521
 522             ;; cdr is not a list, or it is in circle-table.
 523             (cust-print-original-princ ". ")
 524             (cust-print-prin list)
 525             (setq list nil))
 526
 527           (setq length (1- length))
 528           (if list (cust-print-original-princ " ")))
 529
 530         (if (and list (= length 0)) (cust-print-original-princ "..."))
 531         (cust-print-original-princ ")"))))
 532   list)
 533
 534
 535 (defun cust-print-vector (vector)
 536   ;; Print a vector according to print-length, print-level, and print-circle.
 537   (if (= cust-print-current-level 0)
 538       (cust-print-original-princ "#")
 539     (let ((cust-print-current-level (1- cust-print-current-level))
 540           (i 0)
 541           (len (length vector)))
 542       (cust-print-original-princ "[")
 543
 544       (if print-length
 545           (setq len (min print-length len)))
 546       ;; Print the elements
 547       (while (< i len)
 548         (cust-print-prin (aref vector i))
 549         (setq i (1+ i))
 550         (if (< i (length vector)) (cust-print-original-princ " ")))
 551
 552       (if (< i (length vector)) (cust-print-original-princ "..."))
 553       (cust-print-original-princ "]")
 554       ))
 555   vector)
 556
 557
 558 \f
 559 ;; Circular structure preprocessing
 560 ;;==================================
 561
 562 (defun cust-print-preprocess-circle-tree (object)
 563   ;; Fill up the table.
 564   (let (;; Table of tags for each object in an object to be printed.
 565         ;; A tag is of the form:
 566         ;; ( <object> <nil-t-or-id-number> )
 567         ;; The id-number is generated after the entire table has been computed.
 568         ;; During walk through, the real circle-table lives in the cdr so we
 569         ;; can use setcdr to add new elements instead of having to setq the
 570         ;; variable sometimes (poor man's locf).
 571         (circle-table (list nil)))
 572     (cust-print-walk-circle-tree object)
 573
 574     ;; Reverse table so it is in the order that the objects will be printed.
 575     ;; This pass could be avoided if we always added to the end of the
 576     ;; table with setcdr in walk-circle-tree.
 577     (setcdr circle-table (nreverse (cdr circle-table)))
 578
 579     ;; Walk through the table, assigning id-numbers to those
 580     ;; objects which will be printed using #N= syntax.  Delete those
 581     ;; objects which will be printed only once (to speed up assq later).
 582     (let ((rest circle-table)
 583           (id -1))
 584       (while (cdr rest)
 585         (let ((tag (car (cdr rest))))
 586           (cond ((cdr tag)
 587                  (setcdr tag id)
 588                  (setq id (1- id))
 589                  (setq rest (cdr rest)))
 590                 ;; Else delete this object.
 591                 (t (setcdr rest (cdr (cdr rest))))))
 592         ))
 593     ;; Drop the car.
 594     (cdr circle-table)
 595     ))
 596
 597
 598
 599 (defun cust-print-walk-circle-tree (object)
 600   (let (read-equivalent-p tag)
 601     (while object
 602       (setq read-equivalent-p
 603             (or (numberp object)
 604                 (and (symbolp object)
 605                      ;; Check if it is uninterned.
 606                      (eq object (intern-soft (symbol-name object)))))
 607             tag (and (not read-equivalent-p)
 608                      (assq object (cdr circle-table))))
 609       (cond (tag
 610              ;; Seen this object already, so note that.
 611              (setcdr tag t))
 612
 613             ((not read-equivalent-p)
 614              ;; Add a tag for this object.
 615              (setcdr circle-table
 616                      (cons (list object)
 617                            (cdr circle-table)))))
 618       (setq object
 619             (cond
 620              (tag ;; No need to descend since we have already.
 621               nil)
 622
 623              ((consp object)
 624               ;; Walk the car of the list recursively.
 625               (cust-print-walk-circle-tree (car object))
 626               ;; But walk the cdr with the above while loop
 627               ;; to avoid problems with max-lisp-eval-depth.
 628               ;; And it should be faster than recursion.
 629               (cdr object))
 630
 631              ((vectorp object)
 632               ;; Walk the vector.
 633               (let ((i (length object))
 634                     (j 0))
 635                 (while (< j i)
 636                   (cust-print-walk-circle-tree (aref object j))
 637                   (setq j (1+ j))))))))))
 638
 639 \f
 640 ;; Example.
 641 ;;=======================================
 642
 643 '(progn
 644    (progn
 645      ;; Create some circular structures.
 646      (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
 647      (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
 648      (setcar (nthcdr 3 circ-list) circ-list)
 649      (aset (nth 2 circ-list) 2 circ-list)
 650      (setq dotted-circ-list (list 'a 'b 'c))
 651      (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
 652      (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
 653      (aset circ-vector 5 (make-symbol "-gensym-"))
 654      (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
 655      nil)
 656
 657    (install-custom-print)
 658    ;; (setq print-circle t)
 659
 660    (let ((print-circle t))
 661      (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
 662          (error "circular object with array printing")))
 663
 664    (let ((print-circle t))
 665      (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
 666          (error "circular object with array printing")))
 667
 668    (let* ((print-circle t)
 669           (x (list 'p 'q))
 670           (y (list (list 'a 'b) x 'foo x)))
 671      (setcdr (cdr (cdr (cdr y))) (cdr y))
 672      (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
 673                 )
 674          (error "circular list example from CL manual")))
 675
 676    (let ((print-circle nil))
 677      ;; cl-packages.el is required to print uninterned symbols like #:FOO.
 678      ;; (require 'cl-packages)
 679      (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
 680          (error "uninterned symbols in list")))
 681    (let ((print-circle t))
 682      (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
 683          (error "circular uninterned symbols in list")))
 684
 685    (uninstall-custom-print)
 686    )
 687
 688 (provide 'cust-print)
 689
 690 ;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580
 691 ;;; cust-print.el ends here