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