|
0
|
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
|
