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