Commit | Line | Data |
---|---|---|
3b1e4dd1 | 1 | ;;; cust-print.el --- handles print-level and print-circle. |
ecb4184d | 2 | |
9750e079 ER |
3 | ;; Copyright (C) 1992 Free Software Foundation, Inc. |
4 | ||
e5167999 | 5 | ;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu> |
e5167999 | 6 | ;; Adapted-By: ESR |
e9571d2a | 7 | ;; Keywords: extensions |
ecb4184d | 8 | |
65c3c4ed DL |
9 | ;; LCD Archive Entry: |
10 | ;; cust-print|Daniel LaLiberte|liberte@cs.uiuc.edu | |
11 | ;; |Handle print-level, print-circle and more. | |
4633707b | 12 | ;; |$Date: 1994/04/05 21:05:09 $|$Revision: 1.14 $| |
65c3c4ed | 13 | |
ecb4184d ER |
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 | |
e5167999 | 18 | ;; the Free Software Foundation; either version 2, or (at your option) |
ecb4184d ER |
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 | ||
65c3c4ed | 30 | ;;; =============================== |
4633707b | 31 | ;;; $Header: $ |
65c3c4ed | 32 | ;;; $Log: cust-print.el,v $ |
4633707b DL |
33 | ;;; Revision 1.14 1994/04/05 21:05:09 liberte |
34 | ;;; Change install- and uninstall- to -install and -uninstall. | |
35 | ;;; | |
11b57bf9 DL |
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 | ;;; | |
65c3c4ed DL |
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 | |
e5167999 ER |
75 | ;;; Commentary: |
76 | ||
ecb4184d ER |
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 | |
65c3c4ed DL |
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 | |
ecb4184d ER |
94 | ;; option may be used to print more concise representations. |
95 | ||
65c3c4ed | 96 | ;; There are three main ways to use this package. First, you may |
ecb4184d | 97 | ;; replace prin1, princ, and some subroutines that use them by calling |
65c3c4ed DL |
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 | |
ecb4184d | 107 | ;; functions like eval-region call the print subroutines directly. |
65c3c4ed DL |
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. | |
ecb4184d | 115 | |
65c3c4ed DL |
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. | |
ecb4184d ER |
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 | ||
65c3c4ed DL |
128 | \f |
129 | ;;; Code: | |
ecb4184d | 130 | ;;========================================================= |
ecb4184d | 131 | |
65c3c4ed DL |
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 | ||
11b57bf9 DL |
141 | custom-print-install |
142 | custom-print-uninstall | |
65c3c4ed DL |
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 | )) | |
ecb4184d | 157 | |
65c3c4ed | 158 | '(in-package cust-print) |
ecb4184d | 159 | |
65c3c4ed | 160 | (require 'backquote) |
ecb4184d | 161 | |
65c3c4ed DL |
162 | ;; Emacs 18 doesnt have defalias. |
163 | ;; Provide def for byte compiler. | |
4633707b DL |
164 | (eval-and-compile |
165 | (or (fboundp 'defalias) (fset 'defalias 'fset))) | |
ecb4184d | 166 | |
65c3c4ed DL |
167 | \f |
168 | ;; Variables: | |
169 | ;;========================================================= | |
ecb4184d ER |
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 | |
65c3c4ed | 179 | max-lisp-eval-depth being exceeded or an error may occur: |
fb252f97 RS |
180 | `Apparently circular structure being printed.' |
181 | Also see `print-length' and `print-circle'. | |
ecb4184d | 182 | |
fb252f97 | 183 | If non-nil, components at levels equal to or greater than `print-level' |
92ad69b6 | 184 | are printed simply as `#'. The object to be printed is at level 0, |
ecb4184d ER |
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 | |
65c3c4ed | 193 | `max-lisp-eval-depth' being exceeded or an error may occur: |
ecb4184d | 194 | \"Apparently circular structure being printed.\" Also see |
fb252f97 | 195 | `print-length' and `print-level'. |
ecb4184d ER |
196 | |
197 | If non-nil, shared substructures anywhere in the structure are printed | |
eb8c3be9 JB |
198 | with `#N=' before the first occurrence (in the order of the print |
199 | representation) and `#N#' in place of each subsequent occurrence, | |
fb252f97 | 200 | where N is a positive decimal integer. |
ecb4184d | 201 | |
65c3c4ed DL |
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.") | |
ecb4184d ER |
204 | |
205 | ||
65c3c4ed DL |
206 | (defvar custom-print-vectors nil |
207 | "*Non-nil if printing of vectors should obey print-level and print-length. | |
ecb4184d | 208 | |
65c3c4ed DL |
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.") | |
ecb4184d | 212 | |
65c3c4ed DL |
213 | \f |
214 | ;; Custom printers | |
215 | ;;========================================================== | |
ecb4184d | 216 | |
65c3c4ed DL |
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. | |
ecb4184d | 225 | |
65c3c4ed DL |
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? | |
ecb4184d | 231 | |
65c3c4ed DL |
232 | (defun add-custom-printer (pred printer) |
233 | "Add a pair of PREDICATE and PRINTER to `custom-printers'. | |
ecb4184d | 234 | Any pair that has the same PREDICATE is first removed." |
65c3c4ed DL |
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. | |
ecb4184d | 272 | ;;==================================================== |
ecb4184d | 273 | |
fb252f97 | 274 | (defun cust-print-set-function-cell (symbol-pair) |
31e1d920 | 275 | (defalias (car symbol-pair) |
65c3c4ed | 276 | (symbol-function (car (cdr symbol-pair))))) |
ecb4184d | 277 | |
65c3c4ed | 278 | (defun cust-print-original-princ (object &optional stream)) ; dummy def |
ecb4184d | 279 | |
65c3c4ed DL |
280 | ;; Save emacs routines. |
281 | (if (not (fboundp 'cust-print-original-prin1)) | |
fb252f97 | 282 | (mapcar 'cust-print-set-function-cell |
65c3c4ed DL |
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)))) | |
ecb4184d ER |
290 | |
291 | ||
11b57bf9 | 292 | (defun custom-print-install () |
fb252f97 | 293 | "Replace print functions with general, customizable, Lisp versions. |
65c3c4ed | 294 | The emacs subroutines are saved away, and you can reinstall them |
11b57bf9 | 295 | by running `custom-print-uninstall'." |
ecb4184d | 296 | (interactive) |
fb252f97 | 297 | (mapcar 'cust-print-set-function-cell |
ecb4184d ER |
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) | |
65c3c4ed DL |
305 | )) |
306 | t) | |
ecb4184d | 307 | |
11b57bf9 | 308 | (defun custom-print-uninstall () |
65c3c4ed | 309 | "Reset print functions to their emacs subroutines." |
ecb4184d | 310 | (interactive) |
fb252f97 | 311 | (mapcar 'cust-print-set-function-cell |
65c3c4ed DL |
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 | |
11b57bf9 | 335 | (custom-print-install) |
65c3c4ed | 336 | (,@ body)) |
11b57bf9 | 337 | (custom-print-uninstall)))) |
65c3c4ed DL |
338 | |
339 | \f | |
340 | ;; Lisp replacements for prin1 and princ, and for some subrs that use them | |
ecb4184d | 341 | ;;=============================================================== |
65c3c4ed | 342 | ;; - so far only the printing and formatting subrs. |
ecb4184d ER |
343 | |
344 | (defun custom-prin1 (object &optional stream) | |
65c3c4ed | 345 | "Output the printed representation of OBJECT, any Lisp object. |
ecb4184d ER |
346 | Quoting characters are printed when needed to make output that `read' |
347 | can handle, whenever this is possible. | |
65c3c4ed DL |
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)) | |
ecb4184d ER |
354 | |
355 | ||
356 | (defun custom-princ (object &optional stream) | |
65c3c4ed DL |
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). | |
ecb4184d | 361 | |
65c3c4ed DL |
362 | This is the custom-print replacement for the standard `princ'." |
363 | (cust-print-top-level object stream 'cust-print-original-princ)) | |
92ad69b6 | 364 | |
ecb4184d ER |
365 | |
366 | (defun custom-prin1-to-string (object) | |
65c3c4ed DL |
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 | ))) | |
ecb4184d ER |
385 | |
386 | ||
387 | (defun custom-print (object &optional stream) | |
65c3c4ed DL |
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) | |
ecb4184d | 395 | (custom-prin1 object stream) |
65c3c4ed | 396 | (cust-print-original-princ "\n" stream)) |
ecb4184d ER |
397 | |
398 | ||
399 | (defun custom-format (fmt &rest args) | |
65c3c4ed DL |
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 | |
ecb4184d | 416 | (mapcar (function (lambda (arg) |
65c3c4ed | 417 | (if (or (listp arg) (vectorp arg) (symbolp arg)) |
ecb4184d ER |
418 | (custom-prin1-to-string arg) |
419 | arg))) | |
420 | args))) | |
421 | ||
422 | ||
ecb4184d | 423 | (defun custom-message (fmt &rest args) |
65c3c4ed DL |
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)) | |
ecb4184d | 436 | ;; because the echo area requires special handling |
65c3c4ed DL |
437 | ;; to avoid duplicating the output. |
438 | ;; cust-print-original-message does it right. | |
439 | (apply 'cust-print-original-message fmt | |
ecb4184d | 440 | (mapcar (function (lambda (arg) |
65c3c4ed | 441 | (if (or (listp arg) (vectorp arg) (symbolp arg)) |
ecb4184d ER |
442 | (custom-prin1-to-string arg) |
443 | arg))) | |
444 | args))) | |
445 | ||
446 | ||
447 | (defun custom-error (fmt &rest args) | |
65c3c4ed DL |
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." | |
ecb4184d ER |
452 | (signal 'error (list (apply 'custom-format fmt args)))) |
453 | ||
454 | ||
65c3c4ed | 455 | \f |
ecb4184d | 456 | ;; Support for custom prin1 and princ |
65c3c4ed | 457 | ;;========================================= |
ecb4184d | 458 | |
65c3c4ed | 459 | ;; Defs to quiet byte-compiler. |
92ad69b6 | 460 | (defvar circle-table) |
65c3c4ed DL |
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. | |
92ad69b6 | 466 | |
65c3c4ed DL |
467 | (defun cust-print-top-level (object stream emacs-printer) |
468 | ;; Set up for printing. | |
ecb4184d | 469 | (let ((standard-output (or stream standard-output)) |
65c3c4ed DL |
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))) | |
ecb4184d | 474 | |
65c3c4ed | 475 | (defalias 'cust-print-original-printer emacs-printer) |
31e1d920 | 476 | (defalias 'cust-print-low-level-prin |
65c3c4ed DL |
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)) | |
ecb4184d | 489 | |
fb252f97 | 490 | (cust-print-prin object) |
ecb4184d ER |
491 | object)) |
492 | ||
493 | ||
65c3c4ed DL |
494 | (defun cust-print-print-object (object) |
495 | ;; Test object type and print accordingly. | |
fb252f97 | 496 | ;; Could be called as either cust-print-low-level-prin or cust-print-prin. |
ecb4184d | 497 | (cond |
65c3c4ed DL |
498 | ((null object) (cust-print-original-printer object)) |
499 | ((cust-print-use-custom-printer object) object) | |
fb252f97 RS |
500 | ((consp object) (cust-print-list object)) |
501 | ((vectorp object) (cust-print-vector object)) | |
ecb4184d | 502 | ;; All other types, just print. |
65c3c4ed | 503 | (t (cust-print-original-printer object)))) |
ecb4184d | 504 | |
ecb4184d | 505 | |
65c3c4ed DL |
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. | |
ecb4184d ER |
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. | |
65c3c4ed DL |
517 | (cust-print-original-princ "#") |
518 | (cust-print-original-princ id) | |
519 | (cust-print-original-princ "#")) | |
ecb4184d ER |
520 | ;; Not printed yet, so label with id and print object. |
521 | (setcdr tag (- id)) ; mark it as printed | |
65c3c4ed DL |
522 | (cust-print-original-princ "#") |
523 | (cust-print-original-princ (- id)) | |
524 | (cust-print-original-princ "=") | |
fb252f97 | 525 | (cust-print-low-level-prin object) |
ecb4184d ER |
526 | )) |
527 | ;; Not repeated in structure. | |
fb252f97 | 528 | (cust-print-low-level-prin object)))) |
ecb4184d ER |
529 | |
530 | ||
531 | ;;================================================ | |
532 | ;; List and vector processing for print functions. | |
533 | ||
fb252f97 | 534 | (defun cust-print-list (list) |
65c3c4ed DL |
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 "(") | |
ecb4184d ER |
540 | (let ((length (or print-length 0))) |
541 | ||
542 | ;; Print the first element always (even if length = 0). | |
fb252f97 | 543 | (cust-print-prin (car list)) |
ecb4184d | 544 | (setq list (cdr list)) |
65c3c4ed | 545 | (if list (cust-print-original-princ " ")) |
ecb4184d ER |
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 | |
fb252f97 | 553 | (cust-print-prin (car list)) |
ecb4184d ER |
554 | (setq list (cdr list))) |
555 | ||
556 | ;; cdr is not a list, or it is in circle-table. | |
65c3c4ed | 557 | (cust-print-original-princ ". ") |
fb252f97 | 558 | (cust-print-prin list) |
ecb4184d ER |
559 | (setq list nil)) |
560 | ||
561 | (setq length (1- length)) | |
65c3c4ed | 562 | (if list (cust-print-original-princ " "))) |
ecb4184d | 563 | |
65c3c4ed DL |
564 | (if (and list (= length 0)) (cust-print-original-princ "...")) |
565 | (cust-print-original-princ ")")))) | |
ecb4184d ER |
566 | list) |
567 | ||
568 | ||
fb252f97 | 569 | (defun cust-print-vector (vector) |
65c3c4ed DL |
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)) | |
ecb4184d ER |
574 | (i 0) |
575 | (len (length vector))) | |
65c3c4ed | 576 | (cust-print-original-princ "[") |
ecb4184d ER |
577 | |
578 | (if print-length | |
579 | (setq len (min print-length len))) | |
580 | ;; Print the elements | |
581 | (while (< i len) | |
fb252f97 | 582 | (cust-print-prin (aref vector i)) |
ecb4184d | 583 | (setq i (1+ i)) |
65c3c4ed | 584 | (if (< i (length vector)) (cust-print-original-princ " "))) |
ecb4184d | 585 | |
65c3c4ed DL |
586 | (if (< i (length vector)) (cust-print-original-princ "...")) |
587 | (cust-print-original-princ "]") | |
ecb4184d ER |
588 | )) |
589 | vector) | |
590 | ||
591 | ||
65c3c4ed | 592 | \f |
ecb4184d | 593 | ;; Circular structure preprocessing |
65c3c4ed | 594 | ;;================================== |
ecb4184d | 595 | |
fb252f97 | 596 | (defun cust-print-preprocess-circle-tree (object) |
ecb4184d ER |
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))) | |
fb252f97 | 606 | (cust-print-walk-circle-tree object) |
ecb4184d ER |
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 | ||
fb252f97 | 633 | (defun cust-print-walk-circle-tree (object) |
ecb4184d ER |
634 | (let (read-equivalent-p tag) |
635 | (while object | |
65c3c4ed DL |
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))))) | |
ecb4184d ER |
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. | |
fb252f97 | 659 | (cust-print-walk-circle-tree (car object)) |
ecb4184d ER |
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) | |
fb252f97 | 670 | (cust-print-walk-circle-tree (aref object j)) |
ecb4184d ER |
671 | (setq j (1+ j)))))))))) |
672 | ||
65c3c4ed DL |
673 | \f |
674 | ;; Example. | |
675 | ;;======================================= | |
ecb4184d | 676 | |
65c3c4ed DL |
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"))) | |
ecb4184d | 709 | |
65c3c4ed DL |
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"))) | |
ecb4184d | 718 | |
65c3c4ed DL |
719 | (uninstall-custom-print) |
720 | ) | |
92ad69b6 | 721 | |
65c3c4ed | 722 | (provide 'cust-print) |
ecb4184d | 723 | |
fd7fa35a | 724 | ;;; cust-print.el ends here |
4633707b | 725 |