lisp/emacs-lisp/cust-print.el

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