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