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