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