2230
|
1 ;;; cust-print.el --- handles print-level and print-circle.
|
655
|
2
|
845
|
3 ;; Copyright (C) 1992 Free Software Foundation, Inc.
|
|
4
|
30805
|
5 ;; Author: Daniel LaLiberte <liberte@holonexus.org>
|
807
|
6 ;; Adapted-By: ESR
|
2247
|
7 ;; Keywords: extensions
|
655
|
8
|
6511
|
9 ;; LCD Archive Entry:
|
30805
|
10 ;; cust-print|Daniel LaLiberte|liberte@holonexus.org
|
6511
|
11 ;; |Handle print-level, print-circle and more.
|
|
12
|
655
|
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
|
807
|
17 ;; the Free Software Foundation; either version 2, or (at your option)
|
655
|
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
|
26519
|
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.
|
655
|
29
|
807
|
30 ;;; Commentary:
|
|
31
|
655
|
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
|
6511
|
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
|
655
|
49 ;; option may be used to print more concise representations.
|
|
50
|
6511
|
51 ;; There are three main ways to use this package. First, you may
|
655
|
52 ;; replace prin1, princ, and some subroutines that use them by calling
|
6511
|
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.
|
655
|
59
|
6511
|
60 ;; Note that subroutines which call print subroutines directly will
|
|
61 ;; not use the custom print functions. In particular, the evaluation
|
655
|
62 ;; functions like eval-region call the print subroutines directly.
|
6511
|
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.
|
655
|
66
|
6511
|
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.
|
|
70
|
|
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.
|
655
|
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
|
6511
|
83
|
|
84 ;;; Code:
|
26519
|
85
|
|
86 (defgroup cust-print nil
|
|
87 "Handles print-level and print-circle."
|
|
88 :prefix "print-"
|
|
89 :group 'lisp
|
|
90 :group 'extensions)
|
6511
|
91
|
|
92 ;; If using cl-packages:
|
655
|
93
|
6511
|
94 '(defpackage "cust-print"
|
|
95 (:nicknames "CP" "custom-print")
|
|
96 (:use "el")
|
|
97 (:export
|
|
98 print-level
|
|
99 print-circle
|
655
|
100
|
6687
|
101 custom-print-install
|
|
102 custom-print-uninstall
|
6511
|
103 custom-print-installed-p
|
|
104 with-custom-print
|
655
|
105
|
6511
|
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 ))
|
655
|
117
|
6511
|
118 '(in-package cust-print)
|
|
119
|
26519
|
120 ;; Emacs 18 doesn't have defalias.
|
6511
|
121 ;; Provide def for byte compiler.
|
6779
|
122 (eval-and-compile
|
|
123 (or (fboundp 'defalias) (fset 'defalias 'fset)))
|
655
|
124
|
6511
|
125
|
|
126 ;; Variables:
|
|
127 ;;=========================================================
|
655
|
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
|
26519
|
133 (defcustom print-level nil
|
655
|
134 "*Controls how many levels deep a nested data object will print.
|
|
135
|
|
136 If nil, printing proceeds recursively and may lead to
|
6511
|
137 max-lisp-eval-depth being exceeded or an error may occur:
|
1359
|
138 `Apparently circular structure being printed.'
|
|
139 Also see `print-length' and `print-circle'.
|
655
|
140
|
1359
|
141 If non-nil, components at levels equal to or greater than `print-level'
|
1366
ebf903dc2d70
(custom-prin1-chars): Var defined, and renamed from prin1-chars.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
142 are printed simply as `#'. The object to be printed is at level 0,
|
655
|
143 and if the object is a list or vector, its top-level components are at
|
26519
|
144 level 1."
|
|
145 :type '(choice (const nil) integer)
|
|
146 :group 'cust-print)
|
655
|
147
|
|
148
|
26519
|
149 (defcustom print-circle nil
|
655
|
150 "*Controls the printing of recursive structures.
|
|
151
|
|
152 If nil, printing proceeds recursively and may lead to
|
6511
|
153 `max-lisp-eval-depth' being exceeded or an error may occur:
|
655
|
154 \"Apparently circular structure being printed.\" Also see
|
1359
|
155 `print-length' and `print-level'.
|
655
|
156
|
|
157 If non-nil, shared substructures anywhere in the structure are printed
|
3591
|
158 with `#N=' before the first occurrence (in the order of the print
|
|
159 representation) and `#N#' in place of each subsequent occurrence,
|
1359
|
160 where N is a positive decimal integer.
|
655
|
161
|
6511
|
162 There is no way to read this representation in standard Emacs,
|
26519
|
163 but if you need to do so, try the cl-read.el package."
|
|
164 :type 'boolean
|
|
165 :group 'cust-print)
|
655
|
166
|
|
167
|
26519
|
168 (defcustom custom-print-vectors nil
|
6511
|
169 "*Non-nil if printing of vectors should obey print-level and print-length.
|
|
170
|
|
171 For Emacs 18, setting print-level, or adding custom print list or
|
|
172 vector handling will make this happen anyway. Emacs 19 obeys
|
26519
|
173 print-level, but not for vectors."
|
|
174 :type 'boolean
|
|
175 :group 'cust-print)
|
6511
|
176
|
|
177
|
|
178 ;; Custom printers
|
|
179 ;;==========================================================
|
|
180
|
|
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.
|
655
|
189
|
6511
|
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
|
26519
|
194 ;; CP ones in Emacs Lisp so that CP internal functions need not be called?
|
6511
|
195
|
|
196 (defun add-custom-printer (pred printer)
|
|
197 "Add a pair of PREDICATE and PRINTER to `custom-printers'.
|
|
198 Any pair that has the same PREDICATE is first removed."
|
|
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))
|
655
|
210
|
|
211
|
6511
|
212 (defun cust-print-use-custom-printer (object)
|
|
213 ;; Default function returns nil.
|
|
214 nil)
|
655
|
215
|
6511
|
216 (defun cust-print-update-custom-printers ()
|
|
217 ;; Modify the definition of cust-print-use-custom-printer
|
|
218 (defalias 'cust-print-use-custom-printer
|
26519
|
219 ;; We don't really want to require the byte-compiler.
|
6511
|
220 ;; (byte-compile
|
26519
|
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 ))
|
655
|
233
|
6511
|
234
|
|
235 ;; Saving and restoring emacs printing routines.
|
655
|
236 ;;====================================================
|
|
237
|
1359
|
238 (defun cust-print-set-function-cell (symbol-pair)
|
2571
|
239 (defalias (car symbol-pair)
|
6511
|
240 (symbol-function (car (cdr symbol-pair)))))
|
|
241
|
|
242 (defun cust-print-original-princ (object &optional stream)) ; dummy def
|
|
243
|
|
244 ;; Save emacs routines.
|
|
245 (if (not (fboundp 'cust-print-original-prin1))
|
|
246 (mapcar 'cust-print-set-function-cell
|
|
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))))
|
655
|
254
|
|
255
|
6687
|
256 (defun custom-print-install ()
|
1359
|
257 "Replace print functions with general, customizable, Lisp versions.
|
6511
|
258 The emacs subroutines are saved away, and you can reinstall them
|
6687
|
259 by running `custom-print-uninstall'."
|
655
|
260 (interactive)
|
1359
|
261 (mapcar 'cust-print-set-function-cell
|
655
|
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)
|
6511
|
269 ))
|
|
270 t)
|
655
|
271
|
6687
|
272 (defun custom-print-uninstall ()
|
6511
|
273 "Reset print functions to their emacs subroutines."
|
655
|
274 (interactive)
|
1359
|
275 (mapcar 'cust-print-set-function-cell
|
6511
|
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)))
|
655
|
290
|
6511
|
291 (put 'with-custom-print-funcs 'edebug-form-spec '(body))
|
|
292 (put 'with-custom-print 'edebug-form-spec '(body))
|
655
|
293
|
6511
|
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."
|
26519
|
297 `(unwind-protect
|
|
298 (progn
|
|
299 (custom-print-install)
|
|
300 ,@body)
|
|
301 (custom-print-uninstall)))
|
6511
|
302
|
|
303
|
|
304 ;; Lisp replacements for prin1 and princ, and for some subrs that use them
|
655
|
305 ;;===============================================================
|
6511
|
306 ;; - so far only the printing and formatting subrs.
|
655
|
307
|
|
308 (defun custom-prin1 (object &optional stream)
|
6511
|
309 "Output the printed representation of OBJECT, any Lisp object.
|
655
|
310 Quoting characters are printed when needed to make output that `read'
|
|
311 can handle, whenever this is possible.
|
6511
|
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))
|
655
|
318
|
|
319
|
|
320 (defun custom-princ (object &optional stream)
|
6511
|
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).
|
655
|
325
|
6511
|
326 This is the custom-print replacement for the standard `princ'."
|
|
327 (cust-print-top-level object stream 'cust-print-original-princ))
|
1366
ebf903dc2d70
(custom-prin1-chars): Var defined, and renamed from prin1-chars.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
328
|
655
|
329
|
26519
|
330 (defun custom-prin1-to-string (object &optional noescape)
|
6511
|
331 "Return a string containing the printed representation of OBJECT,
|
|
332 any Lisp object. Quoting characters are used when needed to make output
|
26519
|
333 that `read' can handle, whenever this is possible, unless the optional
|
|
334 second argument NOESCAPE is non-nil.
|
6511
|
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
|
26519
|
339 ;; occurred during the last prin1-to-string and we are in debugger.
|
6511
|
340 (save-excursion
|
|
341 (set-buffer buf)
|
|
342 (erase-buffer))
|
|
343 ;; We must be in the current-buffer when the print occurs.
|
26519
|
344 (if noescape
|
|
345 (custom-princ object buf)
|
|
346 (custom-prin1 object buf))
|
6511
|
347 (save-excursion
|
|
348 (set-buffer buf)
|
|
349 (buffer-string)
|
|
350 ;; We could erase the buffer again, but why bother?
|
|
351 )))
|
655
|
352
|
|
353
|
|
354 (defun custom-print (object &optional stream)
|
6511
|
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)
|
655
|
362 (custom-prin1 object stream)
|
6511
|
363 (cust-print-original-princ "\n" stream))
|
655
|
364
|
|
365
|
|
366 (defun custom-format (fmt &rest args)
|
6511
|
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.
|
655
|
375
|
6511
|
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
|
655
|
383 (mapcar (function (lambda (arg)
|
6511
|
384 (if (or (listp arg) (vectorp arg) (symbolp arg))
|
655
|
385 (custom-prin1-to-string arg)
|
|
386 arg)))
|
|
387 args)))
|
|
388
|
|
389
|
6511
|
390 (defun custom-message (fmt &rest args)
|
|
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.
|
655
|
398
|
6511
|
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))
|
655
|
403 ;; because the echo area requires special handling
|
6511
|
404 ;; to avoid duplicating the output.
|
|
405 ;; cust-print-original-message does it right.
|
|
406 (apply 'cust-print-original-message fmt
|
655
|
407 (mapcar (function (lambda (arg)
|
6511
|
408 (if (or (listp arg) (vectorp arg) (symbolp arg))
|
655
|
409 (custom-prin1-to-string arg)
|
|
410 arg)))
|
|
411 args)))
|
|
412
|
|
413
|
|
414 (defun custom-error (fmt &rest args)
|
6511
|
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."
|
655
|
419 (signal 'error (list (apply 'custom-format fmt args))))
|
|
420
|
|
421
|
6511
|
422
|
655
|
423 ;; Support for custom prin1 and princ
|
6511
|
424 ;;=========================================
|
655
|
425
|
6511
|
426 ;; Defs to quiet byte-compiler.
|
1366
ebf903dc2d70
(custom-prin1-chars): Var defined, and renamed from prin1-chars.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
427 (defvar circle-table)
|
6511
|
428 (defvar cust-print-current-level)
|
1366
ebf903dc2d70
(custom-prin1-chars): Var defined, and renamed from prin1-chars.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
429
|
6511
|
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.
|
|
433
|
|
434 (defun cust-print-top-level (object stream emacs-printer)
|
|
435 ;; Set up for printing.
|
655
|
436 (let ((standard-output (or stream standard-output))
|
6511
|
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)))
|
655
|
441
|
6511
|
442 (defalias 'cust-print-original-printer emacs-printer)
|
2571
|
443 (defalias 'cust-print-low-level-prin
|
6511
|
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))
|
655
|
456
|
1359
|
457 (cust-print-prin object)
|
655
|
458 object))
|
|
459
|
|
460
|
6511
|
461 (defun cust-print-print-object (object)
|
|
462 ;; Test object type and print accordingly.
|
1359
|
463 ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
|
655
|
464 (cond
|
6511
|
465 ((null object) (cust-print-original-printer object))
|
|
466 ((cust-print-use-custom-printer object) object)
|
1359
|
467 ((consp object) (cust-print-list object))
|
|
468 ((vectorp object) (cust-print-vector object))
|
655
|
469 ;; All other types, just print.
|
6511
|
470 (t (cust-print-original-printer object))))
|
655
|
471
|
|
472
|
6511
|
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.
|
655
|
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.
|
6511
|
484 (cust-print-original-princ "#")
|
|
485 (cust-print-original-princ id)
|
|
486 (cust-print-original-princ "#"))
|
655
|
487 ;; Not printed yet, so label with id and print object.
|
|
488 (setcdr tag (- id)) ; mark it as printed
|
6511
|
489 (cust-print-original-princ "#")
|
|
490 (cust-print-original-princ (- id))
|
|
491 (cust-print-original-princ "=")
|
1359
|
492 (cust-print-low-level-prin object)
|
655
|
493 ))
|
|
494 ;; Not repeated in structure.
|
1359
|
495 (cust-print-low-level-prin object))))
|
655
|
496
|
|
497
|
|
498 ;;================================================
|
|
499 ;; List and vector processing for print functions.
|
|
500
|
1359
|
501 (defun cust-print-list (list)
|
6511
|
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 "(")
|
655
|
507 (let ((length (or print-length 0)))
|
|
508
|
|
509 ;; Print the first element always (even if length = 0).
|
1359
|
510 (cust-print-prin (car list))
|
655
|
511 (setq list (cdr list))
|
6511
|
512 (if list (cust-print-original-princ " "))
|
655
|
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
|
1359
|
520 (cust-print-prin (car list))
|
655
|
521 (setq list (cdr list)))
|
|
522
|
|
523 ;; cdr is not a list, or it is in circle-table.
|
6511
|
524 (cust-print-original-princ ". ")
|
1359
|
525 (cust-print-prin list)
|
655
|
526 (setq list nil))
|
|
527
|
|
528 (setq length (1- length))
|
6511
|
529 (if list (cust-print-original-princ " ")))
|
655
|
530
|
6511
|
531 (if (and list (= length 0)) (cust-print-original-princ "..."))
|
|
532 (cust-print-original-princ ")"))))
|
655
|
533 list)
|
|
534
|
|
535
|
1359
|
536 (defun cust-print-vector (vector)
|
6511
|
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))
|
655
|
541 (i 0)
|
|
542 (len (length vector)))
|
6511
|
543 (cust-print-original-princ "[")
|
655
|
544
|
|
545 (if print-length
|
|
546 (setq len (min print-length len)))
|
|
547 ;; Print the elements
|
|
548 (while (< i len)
|
1359
|
549 (cust-print-prin (aref vector i))
|
655
|
550 (setq i (1+ i))
|
6511
|
551 (if (< i (length vector)) (cust-print-original-princ " ")))
|
655
|
552
|
6511
|
553 (if (< i (length vector)) (cust-print-original-princ "..."))
|
|
554 (cust-print-original-princ "]")
|
655
|
555 ))
|
|
556 vector)
|
|
557
|
|
558
|
6511
|
559
|
|
560 ;; Circular structure preprocessing
|
655
|
561 ;;==================================
|
|
562
|
1359
|
563 (defun cust-print-preprocess-circle-tree (object)
|
655
|
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)))
|
1359
|
573 (cust-print-walk-circle-tree object)
|
655
|
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
|
1359
|
600 (defun cust-print-walk-circle-tree (object)
|
655
|
601 (let (read-equivalent-p tag)
|
|
602 (while object
|
6511
|
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)))))
|
655
|
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.
|
1359
|
626 (cust-print-walk-circle-tree (car object))
|
655
|
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)
|
1359
|
637 (cust-print-walk-circle-tree (aref object j))
|
655
|
638 (setq j (1+ j))))))))))
|
|
639
|
6511
|
640
|
|
641 ;; Example.
|
655
|
642 ;;=======================================
|
|
643
|
6511
|
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)
|
655
|
657
|
6511
|
658 (install-custom-print)
|
|
659 ;; (setq print-circle t)
|
655
|
660
|
6511
|
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")))
|
655
|
664
|
6511
|
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")))
|
655
|
676
|
6511
|
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")))
|
655
|
685
|
6511
|
686 (uninstall-custom-print)
|
|
687 )
|
|
688
|
|
689 (provide 'cust-print)
|
655
|
690
|
811
|
691 ;;; cust-print.el ends here
|
6779
|
692
|