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