Mercurial > hg > xemacs-beta

comparison lisp/edebug/cust-print.el @ 0:376386a54a3c r19-14

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