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, 2006, 2007, 2008,
   4 ;;   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   :type 'boolean
 170   :group 'cust-print)
 171
 172 \f
 173 ;; Custom printers
 174 ;;==========================================================
 175
 176 (defvar custom-printers nil
 177   ;; e.g. '((symbolp . pkg::print-symbol))
 178   "An alist for custom printing of any type.
 179 Pairs are of the form (PREDICATE . PRINTER).  If PREDICATE is true
 180 for an object, then PRINTER is called with the object.
 181 PRINTER should print to `standard-output' using cust-print-original-princ
 182 if the standard printer is sufficient, or cust-print-prin for complex things.
 183 The PRINTER should return the object being printed.
 184
 185 Don't modify this variable directly.  Use `add-custom-printer' and
 186 `delete-custom-printer'")
 187 ;; Should cust-print-original-princ and cust-print-prin be exported symbols?
 188 ;; Or should the standard printers functions be replaced by
 189 ;; CP ones in Emacs Lisp so that CP internal functions need not be called?
 190
 191 (defun add-custom-printer (pred printer)
 192   "Add a pair of PREDICATE and PRINTER to `custom-printers'.
 193 Any pair that has the same PREDICATE is first removed."
 194   (setq custom-printers (cons (cons pred printer)
 195                               (delq (assq pred custom-printers)
 196                                     custom-printers)))
 197   ;; Rather than updating here, we could wait until cust-print-top-level is called.
 198   (cust-print-update-custom-printers))
 199
 200 (defun delete-custom-printer (pred)
 201   "Delete the custom printer associated with PREDICATE."
 202   (setq custom-printers (delq (assq pred custom-printers)
 203                               custom-printers))
 204   (cust-print-update-custom-printers))
 205
 206
 207 (defun cust-print-use-custom-printer (object)
 208   ;; Default function returns nil.
 209   nil)
 210
 211 (defun cust-print-update-custom-printers ()
 212   ;; Modify the definition of cust-print-use-custom-printer
 213   (defalias 'cust-print-use-custom-printer
 214     ;; We don't really want to require the byte-compiler.
 215     ;; (byte-compile
 216     `(lambda (object)
 217        (cond
 218         ,@(mapcar (function
 219                    (lambda (pair)
 220                      `((,(car pair) object)
 221                        (,(cdr pair) object))))
 222                   custom-printers)
 223         ;; Otherwise return nil.
 224         (t nil)
 225         ))
 226     ;; )
 227     ))
 228
 229 \f
 230 ;; Saving and restoring emacs printing routines.
 231 ;;====================================================
 232
 233 (defun cust-print-set-function-cell (symbol-pair)
 234   (defalias (car symbol-pair)
 235     (symbol-function (car (cdr symbol-pair)))))
 236
 237 (defun cust-print-original-princ (object &optional stream)) ; dummy def
 238
 239 ;; Save emacs routines.
 240 (if (not (fboundp 'cust-print-original-prin1))
 241     (mapc 'cust-print-set-function-cell
 242           '((cust-print-original-prin1 prin1)
 243             (cust-print-original-princ princ)
 244             (cust-print-original-print print)
 245             (cust-print-original-prin1-to-string prin1-to-string)
 246             (cust-print-original-format format)
 247             (cust-print-original-message message)
 248             (cust-print-original-error error))))
 249
 250
 251 (defun custom-print-install ()
 252   "Replace print functions with general, customizable, Lisp versions.
 253 The Emacs subroutines are saved away, and you can reinstall them
 254 by running `custom-print-uninstall'."
 255   (interactive)
 256   (mapc 'cust-print-set-function-cell
 257         '((prin1 custom-prin1)
 258           (princ custom-princ)
 259           (print custom-print)
 260           (prin1-to-string custom-prin1-to-string)
 261           (format custom-format)
 262           (message custom-message)
 263           (error custom-error)
 264           ))
 265   t)
 266
 267 (defun custom-print-uninstall ()
 268   "Reset print functions to their Emacs subroutines."
 269   (interactive)
 270   (mapc 'cust-print-set-function-cell
 271         '((prin1 cust-print-original-prin1)
 272           (princ cust-print-original-princ)
 273           (print cust-print-original-print)
 274           (prin1-to-string cust-print-original-prin1-to-string)
 275           (format cust-print-original-format)
 276           (message cust-print-original-message)
 277           (error cust-print-original-error)
 278           ))
 279   t)
 280
 281 (defalias 'custom-print-funcs-installed-p 'custom-print-installed-p)
 282 (defun custom-print-installed-p ()
 283   "Return t if custom-print is currently installed, nil otherwise."
 284   (eq (symbol-function 'custom-prin1) (symbol-function 'prin1)))
 285
 286 (put 'with-custom-print-funcs 'edebug-form-spec '(body))
 287 (put 'with-custom-print 'edebug-form-spec '(body))
 288
 289 (defalias 'with-custom-print-funcs 'with-custom-print)
 290 (defmacro with-custom-print (&rest body)
 291   "Temporarily install the custom print package while executing BODY."
 292   `(unwind-protect
 293        (progn
 294          (custom-print-install)
 295          ,@body)
 296      (custom-print-uninstall)))
 297
 298 \f
 299 ;; Lisp replacements for prin1 and princ, and for some subrs that use them
 300 ;;===============================================================
 301 ;; - so far only the printing and formatting subrs.
 302
 303 (defun custom-prin1 (object &optional stream)
 304   "Output the printed representation of OBJECT, any Lisp object.
 305 Quoting characters are printed when needed to make output that `read'
 306 can handle, whenever this is possible.
 307 Output stream is STREAM, or value of `standard-output' (which see).
 308
 309 This is the custom-print replacement for the standard `prin1'.  It
 310 uses the appropriate printer depending on the values of `print-level'
 311 and `print-circle' (which see)."
 312   (cust-print-top-level object stream 'cust-print-original-prin1))
 313
 314
 315 (defun custom-princ (object &optional stream)
 316   "Output the printed representation of OBJECT, any Lisp object.
 317 No quoting characters are used; no delimiters are printed around
 318 the contents of strings.
 319 Output stream is STREAM, or value of `standard-output' (which see).
 320
 321 This is the custom-print replacement for the standard `princ'."
 322   (cust-print-top-level object stream 'cust-print-original-princ))
 323
 324
 325 (defun custom-prin1-to-string (object &optional noescape)
 326   "Return a string containing the printed representation of OBJECT,
 327 any Lisp object.  Quoting characters are used when needed to make output
 328 that `read' can handle, whenever this is possible, unless the optional
 329 second argument NOESCAPE is non-nil.
 330
 331 This is the custom-print replacement for the standard `prin1-to-string'."
 332   (let ((buf (get-buffer-create " *custom-print-temp*")))
 333     ;; We must erase the buffer before printing in case an error
 334     ;; occurred during the last prin1-to-string and we are in debugger.
 335     (save-excursion
 336       (set-buffer buf)
 337       (erase-buffer))
 338     ;; We must be in the current-buffer when the print occurs.
 339     (if noescape
 340         (custom-princ object buf)
 341       (custom-prin1 object buf))
 342     (save-excursion
 343       (set-buffer buf)
 344       (buffer-string)
 345       ;; We could erase the buffer again, but why bother?
 346       )))
 347
 348
 349 (defun custom-print (object &optional stream)
 350   "Output the printed representation of OBJECT, with newlines around it.
 351 Quoting characters are printed when needed to make output that `read'
 352 can handle, whenever this is possible.
 353 Output stream is STREAM, or value of `standard-output' (which see).
 354
 355 This is the custom-print replacement for the standard `print'."
 356   (cust-print-original-princ "\n" stream)
 357   (custom-prin1 object stream)
 358   (cust-print-original-princ "\n" stream))
 359
 360
 361 (defun custom-format (fmt &rest args)
 362   "Format a string out of a control-string and arguments.
 363 The first argument is a control string.  It, and subsequent arguments
 364 substituted into it, become the value, which is a string.
 365 It may contain %s or %d or %c to substitute successive following arguments.
 366 %s means print an argument as a string, %d means print as number in decimal,
 367 %c means print a number as a single character.
 368 The argument used by %s must be a string or a symbol;
 369 the argument used by %d, %b, %o, %x or %c must be a number.
 370
 371 This is the custom-print replacement for the standard `format'.  It
 372 calls the Emacs `format' after first making strings for list,
 373 vector, or symbol args.  The format specification for such args should
 374 be `%s' in any case, so a string argument will also work.  The string
 375 is generated with `custom-prin1-to-string', which quotes quotable
 376 characters."
 377   (apply 'cust-print-original-format fmt
 378          (mapcar (function (lambda (arg)
 379                              (if (or (listp arg) (vectorp arg) (symbolp arg))
 380                                  (custom-prin1-to-string arg)
 381                                arg)))
 382                  args)))
 383
 384
 385 (defun custom-message (fmt &rest args)
 386   "Print a one-line message at the bottom of the screen.
 387 The first argument is a control string.
 388 It may contain %s or %d or %c to print successive following arguments.
 389 %s means print an argument as a string, %d means print as number in decimal,
 390 %c means print a number as a single character.
 391 The argument used by %s must be a string or a symbol;
 392 the argument used by %d or %c must be a number.
 393
 394 This is the custom-print replacement for the standard `message'.
 395 See `custom-format' for the details."
 396   ;; It doesn't work to princ the result of custom-format as in:
 397   ;; (cust-print-original-princ (apply 'custom-format fmt args))
 398   ;; because the echo area requires special handling
 399   ;; to avoid duplicating the output.
 400   ;; cust-print-original-message does it right.
 401   (apply 'cust-print-original-message  fmt
 402          (mapcar (function (lambda (arg)
 403                              (if (or (listp arg) (vectorp arg) (symbolp arg))
 404                                  (custom-prin1-to-string arg)
 405                                arg)))
 406                  args)))
 407
 408
 409 (defun custom-error (fmt &rest args)
 410   "Signal an error, making error message by passing all args to `format'.
 411
 412 This is the custom-print replacement for the standard `error'.
 413 See `custom-format' for the details."
 414   (signal 'error (list (apply 'custom-format fmt args))))
 415
 416
 417 \f
 418 ;; Support for custom prin1 and princ
 419 ;;=========================================
 420
 421 ;; Defs to quiet byte-compiler.
 422 (defvar circle-table)
 423 (defvar cust-print-current-level)
 424
 425 (defun cust-print-original-printer (object))  ; One of the standard printers.
 426 (defun cust-print-low-level-prin (object))    ; Used internally.
 427 (defun cust-print-prin (object))              ; Call this to print recursively.
 428
 429 (defun cust-print-top-level (object stream emacs-printer)
 430   ;; Set up for printing.
 431   (let ((standard-output (or stream standard-output))
 432         ;; circle-table will be non-nil if anything is circular.
 433         (circle-table (and print-circle
 434                            (cust-print-preprocess-circle-tree object)))
 435         (cust-print-current-level (or print-level -1)))
 436
 437     (defalias 'cust-print-original-printer emacs-printer)
 438     (defalias 'cust-print-low-level-prin
 439       (cond
 440        ((or custom-printers
 441             circle-table
 442             print-level                 ; comment out for version 19
 443             ;; Emacs doesn't use print-level or print-length
 444             ;; for vectors, but custom-print can.
 445             (if custom-print-vectors
 446                 (or print-level print-length)))
 447         'cust-print-print-object)
 448        (t 'cust-print-original-printer)))
 449     (defalias 'cust-print-prin
 450       (if circle-table 'cust-print-print-circular 'cust-print-low-level-prin))
 451
 452     (cust-print-prin object)
 453     object))
 454
 455
 456 (defun cust-print-print-object (object)
 457   ;; Test object type and print accordingly.
 458   ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
 459   (cond
 460    ((null object) (cust-print-original-printer object))
 461    ((cust-print-use-custom-printer object) object)
 462    ((consp object) (cust-print-list object))
 463    ((vectorp object) (cust-print-vector object))
 464    ;; All other types, just print.
 465    (t (cust-print-original-printer object))))
 466
 467
 468 (defun cust-print-print-circular (object)
 469   ;; Printer for `prin1' and `princ' that handles circular structures.
 470   ;; If OBJECT appears multiply, and has not yet been printed,
 471   ;; prefix with label; if it has been printed, use `#N#' instead.
 472   ;; Otherwise, print normally.
 473   (let ((tag (assq object circle-table)))
 474     (if tag
 475         (let ((id (cdr tag)))
 476           (if (> id 0)
 477               (progn
 478                 ;; Already printed, so just print id.
 479                 (cust-print-original-princ "#")
 480                 (cust-print-original-princ id)
 481                 (cust-print-original-princ "#"))
 482             ;; Not printed yet, so label with id and print object.
 483             (setcdr tag (- id)) ; mark it as printed
 484             (cust-print-original-princ "#")
 485             (cust-print-original-princ (- id))
 486             (cust-print-original-princ "=")
 487             (cust-print-low-level-prin object)
 488             ))
 489       ;; Not repeated in structure.
 490       (cust-print-low-level-prin object))))
 491
 492
 493 ;;================================================
 494 ;; List and vector processing for print functions.
 495
 496 (defun cust-print-list (list)
 497   ;; Print a list using print-length, print-level, and print-circle.
 498   (if (= cust-print-current-level 0)
 499       (cust-print-original-princ "#")
 500     (let ((cust-print-current-level (1- cust-print-current-level)))
 501       (cust-print-original-princ "(")
 502       (let ((length (or print-length 0)))
 503
 504         ;; Print the first element always (even if length = 0).
 505         (cust-print-prin (car list))
 506         (setq list (cdr list))
 507         (if list (cust-print-original-princ " "))
 508         (setq length (1- length))
 509
 510         ;; Print the rest of the elements.
 511         (while (and list (/= 0 length))
 512           (if (and (listp list)
 513                    (not (assq list circle-table)))
 514               (progn
 515                 (cust-print-prin (car list))
 516                 (setq list (cdr list)))
 517
 518             ;; cdr is not a list, or it is in circle-table.
 519             (cust-print-original-princ ". ")
 520             (cust-print-prin list)
 521             (setq list nil))
 522
 523           (setq length (1- length))
 524           (if list (cust-print-original-princ " ")))
 525
 526         (if (and list (= length 0)) (cust-print-original-princ "..."))
 527         (cust-print-original-princ ")"))))
 528   list)
 529
 530
 531 (defun cust-print-vector (vector)
 532   ;; Print a vector according to print-length, print-level, and print-circle.
 533   (if (= cust-print-current-level 0)
 534       (cust-print-original-princ "#")
 535     (let ((cust-print-current-level (1- cust-print-current-level))
 536           (i 0)
 537           (len (length vector)))
 538       (cust-print-original-princ "[")
 539
 540       (if print-length
 541           (setq len (min print-length len)))
 542       ;; Print the elements
 543       (while (< i len)
 544         (cust-print-prin (aref vector i))
 545         (setq i (1+ i))
 546         (if (< i (length vector)) (cust-print-original-princ " ")))
 547
 548       (if (< i (length vector)) (cust-print-original-princ "..."))
 549       (cust-print-original-princ "]")
 550       ))
 551   vector)
 552
 553
 554 \f
 555 ;; Circular structure preprocessing
 556 ;;==================================
 557
 558 (defun cust-print-preprocess-circle-tree (object)
 559   ;; Fill up the table.
 560   (let (;; Table of tags for each object in an object to be printed.
 561         ;; A tag is of the form:
 562         ;; ( <object> <nil-t-or-id-number> )
 563         ;; The id-number is generated after the entire table has been computed.
 564         ;; During walk through, the real circle-table lives in the cdr so we
 565         ;; can use setcdr to add new elements instead of having to setq the
 566         ;; variable sometimes (poor man's locf).
 567         (circle-table (list nil)))
 568     (cust-print-walk-circle-tree object)
 569
 570     ;; Reverse table so it is in the order that the objects will be printed.
 571     ;; This pass could be avoided if we always added to the end of the
 572     ;; table with setcdr in walk-circle-tree.
 573     (setcdr circle-table (nreverse (cdr circle-table)))
 574
 575     ;; Walk through the table, assigning id-numbers to those
 576     ;; objects which will be printed using #N= syntax.  Delete those
 577     ;; objects which will be printed only once (to speed up assq later).
 578     (let ((rest circle-table)
 579           (id -1))
 580       (while (cdr rest)
 581         (let ((tag (car (cdr rest))))
 582           (cond ((cdr tag)
 583                  (setcdr tag id)
 584                  (setq id (1- id))
 585                  (setq rest (cdr rest)))
 586                 ;; Else delete this object.
 587                 (t (setcdr rest (cdr (cdr rest))))))
 588         ))
 589     ;; Drop the car.
 590     (cdr circle-table)
 591     ))
 592
 593
 594
 595 (defun cust-print-walk-circle-tree (object)
 596   (let (read-equivalent-p tag)
 597     (while object
 598       (setq read-equivalent-p
 599             (or (numberp object)
 600                 (and (symbolp object)
 601                      ;; Check if it is uninterned.
 602                      (eq object (intern-soft (symbol-name object)))))
 603             tag (and (not read-equivalent-p)
 604                      (assq object (cdr circle-table))))
 605       (cond (tag
 606              ;; Seen this object already, so note that.
 607              (setcdr tag t))
 608
 609             ((not read-equivalent-p)
 610              ;; Add a tag for this object.
 611              (setcdr circle-table
 612                      (cons (list object)
 613                            (cdr circle-table)))))
 614       (setq object
 615             (cond
 616              (tag ;; No need to descend since we have already.
 617               nil)
 618
 619              ((consp object)
 620               ;; Walk the car of the list recursively.
 621               (cust-print-walk-circle-tree (car object))
 622               ;; But walk the cdr with the above while loop
 623               ;; to avoid problems with max-lisp-eval-depth.
 624               ;; And it should be faster than recursion.
 625               (cdr object))
 626
 627              ((vectorp object)
 628               ;; Walk the vector.
 629               (let ((i (length object))
 630                     (j 0))
 631                 (while (< j i)
 632                   (cust-print-walk-circle-tree (aref object j))
 633                   (setq j (1+ j))))))))))
 634
 635 \f
 636 ;; Example.
 637 ;;=======================================
 638
 639 '(progn
 640    (progn
 641      ;; Create some circular structures.
 642      (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
 643      (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
 644      (setcar (nthcdr 3 circ-list) circ-list)
 645      (aset (nth 2 circ-list) 2 circ-list)
 646      (setq dotted-circ-list (list 'a 'b 'c))
 647      (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
 648      (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
 649      (aset circ-vector 5 (make-symbol "-gensym-"))
 650      (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
 651      nil)
 652
 653    (install-custom-print)
 654    ;; (setq print-circle t)
 655
 656    (let ((print-circle t))
 657      (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
 658          (error "circular object with array printing")))
 659
 660    (let ((print-circle t))
 661      (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
 662          (error "circular object with array printing")))
 663
 664    (let* ((print-circle t)
 665           (x (list 'p 'q))
 666           (y (list (list 'a 'b) x 'foo x)))
 667      (setcdr (cdr (cdr (cdr y))) (cdr y))
 668      (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
 669                 )
 670          (error "circular list example from CL manual")))
 671
 672    (let ((print-circle nil))
 673      ;; cl-packages.el is required to print uninterned symbols like #:FOO.
 674      ;; (require 'cl-packages)
 675      (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
 676          (error "uninterned symbols in list")))
 677    (let ((print-circle t))
 678      (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
 679          (error "circular uninterned symbols in list")))
 680
 681    (uninstall-custom-print)
 682    )
 683
 684 (provide 'cust-print)
 685
 686 ;; arch-tag: 3a5a8650-622c-48c4-87d8-e01bf72ec580
 687 ;;; cust-print.el ends here