655
|
1 ;; cus-print.el -- handles print-level and print-circle.
|
|
2
|
|
3 ;; LCD Archive Entry:
|
|
4 ;; custom-print|Daniel LaLiberte|liberte@cs.uiuc.edu
|
|
5 ;; |Handle print-level, print-circle and more.
|
|
6 ;; |$Date: Tue Mar 17, 1992$|$Revision: 1.0$|
|
|
7
|
|
8 ;; Copyright (C) 1992 Free Software Foundation, Inc.
|
|
9
|
|
10 ;; This file is part of GNU Emacs.
|
|
11
|
|
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
13 ;; it under the terms of the GNU General Public License as published by
|
|
14 ;; the Free Software Foundation; either version 1, or (at your option)
|
|
15 ;; any later version.
|
|
16
|
|
17 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
20 ;; GNU General Public License for more details.
|
|
21
|
|
22 ;; You should have received a copy of the GNU General Public License
|
|
23 ;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
24 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
25
|
|
26 ;; This package provides a general print handler for prin1 and princ
|
|
27 ;; that supports print-level and print-circle, and by the way,
|
|
28 ;; print-length since the standard routines are being replaced. Also,
|
|
29 ;; to print custom types constructed from lists and vectors, use
|
|
30 ;; custom-print-list and custom-print-vector. See the documentation
|
|
31 ;; strings of these variables for more details.
|
|
32
|
|
33 ;; If the results of your expressions contain circular references to
|
|
34 ;; other parts of the same structure, the standard Emacs print
|
|
35 ;; subroutines may fail to print with an untrappable error,
|
|
36 ;; "Apparently circular structure being printed". If you only use cdr
|
|
37 ;; circular lists (where cdrs of lists point back; what is the right
|
|
38 ;; term here?), you can limit the length of printing with
|
|
39 ;; print-length. But car circular lists and circular vectors generate
|
|
40 ;; the above mentioned untrappable error in Emacs version 18. Version
|
|
41 ;; 19 will support print-level, but it is often useful to get a better
|
|
42 ;; print representation of circular structures; the print-circle
|
|
43 ;; option may be used to print more concise representations.
|
|
44
|
|
45 ;; There are two main ways to use this package. First, you may
|
|
46 ;; replace prin1, princ, and some subroutines that use them by calling
|
|
47 ;; install-custom-print-funcs so that any use of these functions in
|
|
48 ;; lisp code will be affected. Second, you could call the custom
|
|
49 ;; routines directly, thus only affecting the printing that requires
|
|
50 ;; them.
|
|
51
|
|
52 ;; Note that subroutines which call print subroutines directly will not
|
|
53 ;; use the custom print functions. In particular, the evaluation
|
|
54 ;; functions like eval-region call the print subroutines directly.
|
|
55 ;; Therefore, evaluating (aref circ-list 0), which calls error
|
|
56 ;; directly (because circ-list is not an array), will jump to the top
|
|
57 ;; level instead of printing the circular list.
|
|
58
|
|
59 ;; Obviously the right way to implement this custom-print facility
|
|
60 ;; is in C. Please volunteer since I don't have the time or need.
|
|
61
|
|
62 ;; Implementation design: we want to use the same list and vector
|
|
63 ;; processing algorithm for all versions of prin1 and princ, since how
|
|
64 ;; the processing is done depends on print-length, print-level, and
|
|
65 ;; print-circle. For circle printing, a preprocessing step is
|
|
66 ;; required before the final printing. Thanks to Jamie Zawinski
|
|
67 ;; for motivation and algorithms.
|
|
68
|
|
69 ;;=========================================================
|
|
70 ;; export list:
|
|
71
|
|
72 ;; print-level
|
|
73 ;; print-circle
|
|
74
|
|
75 ;; custom-print-list
|
|
76 ;; custom-print-vector
|
|
77 ;; add-custom-print-list
|
|
78 ;; add-custom-print-vector
|
|
79
|
|
80 ;; install-custom-print-funcs
|
|
81 ;; uninstall-custom-print-funcs
|
|
82
|
|
83 ;; custom-prin1
|
|
84 ;; custom-princ
|
|
85 ;; custom-prin1-to-string
|
|
86 ;; custom-print
|
|
87 ;; custom-format
|
|
88 ;; custom-message
|
|
89 ;; custom-error
|
|
90
|
|
91
|
|
92 (provide 'custom-print)
|
|
93 ;; Abbreviated package name: "CP"
|
|
94
|
|
95 ;;(defvar print-length nil
|
|
96 ;; "*Controls how many elements of a list, at each level, are printed.
|
|
97 ;;This is defined by emacs.")
|
|
98
|
|
99 (defvar print-level nil
|
|
100 "*Controls how many levels deep a nested data object will print.
|
|
101
|
|
102 If nil, printing proceeds recursively and may lead to
|
|
103 max-lisp-eval-depth being exceeded or an untrappable error may occur:
|
|
104 \"Apparently circular structure being printed.\" Also see
|
|
105 print-length and print-circle.
|
|
106
|
|
107 If non-nil, components at levels equal to or greater than print-level
|
|
108 are printed simply as \"#\". The object to be printed is at level 0,
|
|
109 and if the object is a list or vector, its top-level components are at
|
|
110 level 1.")
|
|
111
|
|
112
|
|
113 (defvar print-circle nil
|
|
114 "*Controls the printing of recursive structures.
|
|
115
|
|
116 If nil, printing proceeds recursively and may lead to
|
|
117 max-lisp-eval-depth being exceeded or an untrappable error may occur:
|
|
118 \"Apparently circular structure being printed.\" Also see
|
|
119 print-length and print-level.
|
|
120
|
|
121 If non-nil, shared substructures anywhere in the structure are printed
|
|
122 with \"#n=\" before the first occurance (in the order of the print
|
|
123 representation) and \"#n#\" in place of each subsequent occurance,
|
|
124 where n is a positive decimal integer.
|
|
125
|
|
126 Currently, there is no way to read this representation in Emacs.")
|
|
127
|
|
128
|
|
129 (defconst custom-print-list
|
|
130 nil
|
|
131 ;; e.g. '((floatp . float-to-string))
|
|
132 "If non-nil, an alist for printing of custom list objects.
|
|
133 Pairs are of the form (pred . converter). If the predicate is true
|
|
134 for an object, the converter is called with the object and should
|
|
135 return a string which will be printed with princ.
|
|
136 Also see custom-print-vector.")
|
|
137
|
|
138 (defconst custom-print-vector
|
|
139 nil
|
|
140 "If non-nil, an alist for printing of custom vector objects.
|
|
141 Pairs are of the form (pred . converter). If the predicate is true
|
|
142 for an object, the converter is called with the object and should
|
|
143 return a string which will be printed with princ.
|
|
144 Also see custom-print-list.")
|
|
145
|
|
146
|
|
147 (defun add-custom-print-list (pred converter)
|
|
148 "Add the pair, a PREDICATE and a CONVERTER, to custom-print-list.
|
|
149 Any pair that has the same PREDICATE is first removed."
|
|
150 (setq custom-print-list (cons (cons pred converter)
|
|
151 (delq (assq pred custom-print-list)
|
|
152 custom-print-list))))
|
|
153 ;; e.g. (add-custom-print-list 'floatp 'float-to-string)
|
|
154
|
|
155
|
|
156 (defun add-custom-print-vector (pred converter)
|
|
157 "Add the pair, a PREDICATE and a CONVERTER, to custom-print-vector.
|
|
158 Any pair that has the same PREDICATE is first removed."
|
|
159 (setq custom-print-vector (cons (cons pred converter)
|
|
160 (delq (assq pred custom-print-vector)
|
|
161 custom-print-vector))))
|
|
162
|
|
163
|
|
164 ;;====================================================
|
|
165 ;; Saving and restoring internal printing routines.
|
|
166
|
|
167 (defun CP::set-function-cell (symbol-pair)
|
|
168 (fset (car symbol-pair)
|
|
169 (symbol-function (car (cdr symbol-pair)))))
|
|
170
|
|
171
|
|
172 (if (not (fboundp 'CP::internal-prin1))
|
|
173 (mapcar 'CP::set-function-cell
|
|
174 '((CP::internal-prin1 prin1)
|
|
175 (CP::internal-princ princ)
|
|
176 (CP::internal-print print)
|
|
177 (CP::internal-prin1-to-string prin1-to-string)
|
|
178 (CP::internal-format format)
|
|
179 (CP::internal-message message)
|
|
180 (CP::internal-error error))))
|
|
181
|
|
182
|
|
183 (defun install-custom-print-funcs ()
|
|
184 "Replace print functions with general, customizable, lisp versions.
|
|
185 The internal subroutines are saved away and may be recovered with
|
|
186 uninstall-custom-print-funcs."
|
|
187 (interactive)
|
|
188 (mapcar 'CP::set-function-cell
|
|
189 '((prin1 custom-prin1)
|
|
190 (princ custom-princ)
|
|
191 (print custom-print)
|
|
192 (prin1-to-string custom-prin1-to-string)
|
|
193 (format custom-format)
|
|
194 (message custom-message)
|
|
195 (error custom-error)
|
|
196 )))
|
|
197
|
|
198 (defun uninstall-custom-print-funcs ()
|
|
199 "Reset print functions to their internal subroutines."
|
|
200 (interactive)
|
|
201 (mapcar 'CP::set-function-cell
|
|
202 '((prin1 CP::internal-prin1)
|
|
203 (princ CP::internal-princ)
|
|
204 (print CP::internal-print)
|
|
205 (prin1-to-string CP::internal-prin1-to-string)
|
|
206 (format CP::internal-format)
|
|
207 (message CP::internal-message)
|
|
208 (error CP::internal-error)
|
|
209 )))
|
|
210
|
|
211
|
|
212 ;;===============================================================
|
|
213 ;; Lisp replacements for prin1 and princ and for subrs that use prin1
|
|
214 ;; (or princ) -- so far only the printing and formatting subrs.
|
|
215
|
|
216 (defun custom-prin1 (object &optional stream)
|
|
217 "Replacement for standard prin1 that uses the appropriate
|
|
218 printer depending on the values of print-level and print-circle (which see).
|
|
219
|
|
220 Output the printed representation of OBJECT, any Lisp object.
|
|
221 Quoting characters are printed when needed to make output that `read'
|
|
222 can handle, whenever this is possible.
|
|
223 Output stream is STREAM, or value of `standard-output' (which see)."
|
|
224 (CP::top-level object stream 'CP::internal-prin1))
|
|
225
|
|
226
|
|
227 (defun custom-princ (object &optional stream)
|
|
228 "Same as custom-prin1 except no quoting."
|
|
229 (CP::top-level object stream 'CP::internal-princ))
|
|
230
|
|
231 (defun custom-prin1-to-string-func (c)
|
|
232 "Stream function for custom-prin1-to-string."
|
|
233 (setq prin1-chars (cons c prin1-chars)))
|
|
234
|
|
235 (defun custom-prin1-to-string (object)
|
|
236 "Replacement for standard prin1-to-string."
|
|
237 (let ((prin1-chars nil))
|
|
238 (custom-prin1 object 'custom-prin1-to-string-func)
|
|
239 (concat (nreverse prin1-chars))))
|
|
240
|
|
241
|
|
242 (defun custom-print (object &optional stream)
|
|
243 "Replacement for standard print."
|
|
244 (CP::internal-princ "\n")
|
|
245 (custom-prin1 object stream)
|
|
246 (CP::internal-princ "\n"))
|
|
247
|
|
248
|
|
249 (defun custom-format (fmt &rest args)
|
|
250 "Replacement for standard format.
|
|
251
|
|
252 Calls format after first making strings for list or vector args.
|
|
253 The format specification for such args should be %s in any case, so a
|
|
254 string argument will also work. The string is generated with
|
|
255 custom-prin1-to-string, which quotes quotable characters."
|
|
256 (apply 'CP::internal-format fmt
|
|
257 (mapcar (function (lambda (arg)
|
|
258 (if (or (listp arg) (vectorp arg))
|
|
259 (custom-prin1-to-string arg)
|
|
260 arg)))
|
|
261 args)))
|
|
262
|
|
263
|
|
264
|
|
265 (defun custom-message (fmt &rest args)
|
|
266 "Replacement for standard message that works like custom-format."
|
|
267 ;; It doesnt work to princ the result of custom-format
|
|
268 ;; because the echo area requires special handling
|
|
269 ;; to avoid duplicating the output. CP::internal-message does it right.
|
|
270 ;; (CP::internal-princ (apply 'custom-format fmt args))
|
|
271 (apply 'CP::internal-message fmt
|
|
272 (mapcar (function (lambda (arg)
|
|
273 (if (or (listp arg) (vectorp arg))
|
|
274 (custom-prin1-to-string arg)
|
|
275 arg)))
|
|
276 args)))
|
|
277
|
|
278
|
|
279 (defun custom-error (fmt &rest args)
|
|
280 "Replacement for standard error that uses custom-format"
|
|
281 (signal 'error (list (apply 'custom-format fmt args))))
|
|
282
|
|
283
|
|
284 ;;=========================================
|
|
285 ;; Support for custom prin1 and princ
|
|
286
|
|
287 (defun CP::top-level (object stream internal-printer)
|
|
288 "Set up for printing."
|
|
289 (let ((standard-output (or stream standard-output))
|
|
290 (circle-table (and print-circle (CP::preprocess-circle-tree object)))
|
|
291 (level (or print-level -1))
|
|
292 )
|
|
293
|
|
294 (fset 'CP::internal-printer internal-printer)
|
|
295 (fset 'CP::low-level-prin
|
|
296 (cond
|
|
297 ((or custom-print-list
|
|
298 custom-print-vector
|
|
299 print-level ; comment out for version 19
|
|
300 )
|
|
301 'CP::custom-object)
|
|
302 (circle-table
|
|
303 'CP::object)
|
|
304 (t 'CP::internal-printer)))
|
|
305 (fset 'CP::prin (if circle-table 'CP::circular 'CP::low-level-prin))
|
|
306
|
|
307 (CP::prin object)
|
|
308 object))
|
|
309
|
|
310
|
|
311 (defun CP::object (object)
|
|
312 "Test object type and print accordingly."
|
|
313 ;; Could be called as either CP::low-level-prin or CP::prin.
|
|
314 (cond
|
|
315 ((null object) (CP::internal-printer object))
|
|
316 ((consp object) (CP::list object))
|
|
317 ((vectorp object) (CP::vector object))
|
|
318 ;; All other types, just print.
|
|
319 (t (CP::internal-printer object))))
|
|
320
|
|
321
|
|
322 (defun CP::custom-object (object)
|
|
323 "Test object type and print accordingly."
|
|
324 ;; Could be called as either CP::low-level-prin or CP::prin.
|
|
325 (cond
|
|
326 ((null object) (CP::internal-printer object))
|
|
327
|
|
328 ((consp object)
|
|
329 (or (and custom-print-list
|
|
330 (CP::custom-object1 object custom-print-list))
|
|
331 (CP::list object)))
|
|
332
|
|
333 ((vectorp object)
|
|
334 (or (and custom-print-vector
|
|
335 (CP::custom-object1 object custom-print-vector))
|
|
336 (CP::vector object)))
|
|
337
|
|
338 ;; All other types, just print.
|
|
339 (t (CP::internal-printer object))))
|
|
340
|
|
341
|
|
342 (defun CP::custom-object1 (object alist)
|
|
343 "Helper for CP::custom-object.
|
|
344 Print the custom OBJECT using the custom type ALIST.
|
|
345 For the first predicate that matches the object, the corresponding
|
|
346 converter is evaluated with the object and the string that results is
|
|
347 printed with princ. Return nil if no predicte matches the object."
|
|
348 (while (and alist (not (funcall (car (car alist)) object)))
|
|
349 (setq alist (cdr alist)))
|
|
350 ;; If alist is not null, then something matched.
|
|
351 (if alist
|
|
352 (CP::internal-princ
|
|
353 (funcall (cdr (car alist)) object) ; returns string
|
|
354 )))
|
|
355
|
|
356
|
|
357 (defun CP::circular (object)
|
|
358 "Printer for prin1 and princ that handles circular structures.
|
|
359 If OBJECT appears multiply, and has not yet been printed,
|
|
360 prefix with label; if it has been printed, use #n# instead.
|
|
361 Otherwise, print normally."
|
|
362 (let ((tag (assq object circle-table)))
|
|
363 (if tag
|
|
364 (let ((id (cdr tag)))
|
|
365 (if (> id 0)
|
|
366 (progn
|
|
367 ;; Already printed, so just print id.
|
|
368 (CP::internal-princ "#")
|
|
369 (CP::internal-princ id)
|
|
370 (CP::internal-princ "#"))
|
|
371 ;; Not printed yet, so label with id and print object.
|
|
372 (setcdr tag (- id)) ; mark it as printed
|
|
373 (CP::internal-princ "#")
|
|
374 (CP::internal-princ (- id))
|
|
375 (CP::internal-princ "=")
|
|
376 (CP::low-level-prin object)
|
|
377 ))
|
|
378 ;; Not repeated in structure.
|
|
379 (CP::low-level-prin object))))
|
|
380
|
|
381
|
|
382 ;;================================================
|
|
383 ;; List and vector processing for print functions.
|
|
384
|
|
385 (defun CP::list (list)
|
|
386 "Print a list using print-length, print-level, and print-circle."
|
|
387 (if (= level 0)
|
|
388 (CP::internal-princ "#")
|
|
389 (let ((level (1- level)))
|
|
390 (CP::internal-princ "(")
|
|
391 (let ((length (or print-length 0)))
|
|
392
|
|
393 ;; Print the first element always (even if length = 0).
|
|
394 (CP::prin (car list))
|
|
395 (setq list (cdr list))
|
|
396 (if list (CP::internal-princ " "))
|
|
397 (setq length (1- length))
|
|
398
|
|
399 ;; Print the rest of the elements.
|
|
400 (while (and list (/= 0 length))
|
|
401 (if (and (listp list)
|
|
402 (not (assq list circle-table)))
|
|
403 (progn
|
|
404 (CP::prin (car list))
|
|
405 (setq list (cdr list)))
|
|
406
|
|
407 ;; cdr is not a list, or it is in circle-table.
|
|
408 (CP::internal-princ ". ")
|
|
409 (CP::prin list)
|
|
410 (setq list nil))
|
|
411
|
|
412 (setq length (1- length))
|
|
413 (if list (CP::internal-princ " ")))
|
|
414
|
|
415 (if (and list (= length 0)) (CP::internal-princ "..."))
|
|
416 (CP::internal-princ ")"))))
|
|
417 list)
|
|
418
|
|
419
|
|
420 (defun CP::vector (vector)
|
|
421 "Print a vector using print-length, print-level, and print-circle."
|
|
422 (if (= level 0)
|
|
423 (CP::internal-princ "#")
|
|
424 (let ((level (1- level))
|
|
425 (i 0)
|
|
426 (len (length vector)))
|
|
427 (CP::internal-princ "[")
|
|
428
|
|
429 (if print-length
|
|
430 (setq len (min print-length len)))
|
|
431 ;; Print the elements
|
|
432 (while (< i len)
|
|
433 (CP::prin (aref vector i))
|
|
434 (setq i (1+ i))
|
|
435 (if (< i (length vector)) (CP::internal-princ " ")))
|
|
436
|
|
437 (if (< i (length vector)) (CP::internal-princ "..."))
|
|
438 (CP::internal-princ "]")
|
|
439 ))
|
|
440 vector)
|
|
441
|
|
442
|
|
443 ;;==================================
|
|
444 ;; Circular structure preprocessing
|
|
445
|
|
446 (defun CP::preprocess-circle-tree (object)
|
|
447 ;; Fill up the table.
|
|
448 (let (;; Table of tags for each object in an object to be printed.
|
|
449 ;; A tag is of the form:
|
|
450 ;; ( <object> <nil-t-or-id-number> )
|
|
451 ;; The id-number is generated after the entire table has been computed.
|
|
452 ;; During walk through, the real circle-table lives in the cdr so we
|
|
453 ;; can use setcdr to add new elements instead of having to setq the
|
|
454 ;; variable sometimes (poor man's locf).
|
|
455 (circle-table (list nil)))
|
|
456 (CP::walk-circle-tree object)
|
|
457
|
|
458 ;; Reverse table so it is in the order that the objects will be printed.
|
|
459 ;; This pass could be avoided if we always added to the end of the
|
|
460 ;; table with setcdr in walk-circle-tree.
|
|
461 (setcdr circle-table (nreverse (cdr circle-table)))
|
|
462
|
|
463 ;; Walk through the table, assigning id-numbers to those
|
|
464 ;; objects which will be printed using #N= syntax. Delete those
|
|
465 ;; objects which will be printed only once (to speed up assq later).
|
|
466 (let ((rest circle-table)
|
|
467 (id -1))
|
|
468 (while (cdr rest)
|
|
469 (let ((tag (car (cdr rest))))
|
|
470 (cond ((cdr tag)
|
|
471 (setcdr tag id)
|
|
472 (setq id (1- id))
|
|
473 (setq rest (cdr rest)))
|
|
474 ;; Else delete this object.
|
|
475 (t (setcdr rest (cdr (cdr rest))))))
|
|
476 ))
|
|
477 ;; Drop the car.
|
|
478 (cdr circle-table)
|
|
479 ))
|
|
480
|
|
481
|
|
482
|
|
483 (defun CP::walk-circle-tree (object)
|
|
484 (let (read-equivalent-p tag)
|
|
485 (while object
|
|
486 (setq read-equivalent-p (or (numberp object) (symbolp object))
|
|
487 tag (and (not read-equivalent-p)
|
|
488 (assq object (cdr circle-table))))
|
|
489 (cond (tag
|
|
490 ;; Seen this object already, so note that.
|
|
491 (setcdr tag t))
|
|
492
|
|
493 ((not read-equivalent-p)
|
|
494 ;; Add a tag for this object.
|
|
495 (setcdr circle-table
|
|
496 (cons (list object)
|
|
497 (cdr circle-table)))))
|
|
498 (setq object
|
|
499 (cond
|
|
500 (tag ;; No need to descend since we have already.
|
|
501 nil)
|
|
502
|
|
503 ((consp object)
|
|
504 ;; Walk the car of the list recursively.
|
|
505 (CP::walk-circle-tree (car object))
|
|
506 ;; But walk the cdr with the above while loop
|
|
507 ;; to avoid problems with max-lisp-eval-depth.
|
|
508 ;; And it should be faster than recursion.
|
|
509 (cdr object))
|
|
510
|
|
511 ((vectorp object)
|
|
512 ;; Walk the vector.
|
|
513 (let ((i (length object))
|
|
514 (j 0))
|
|
515 (while (< j i)
|
|
516 (CP::walk-circle-tree (aref object j))
|
|
517 (setq j (1+ j))))))))))
|
|
518
|
|
519
|
|
520
|
|
521 ;;=======================================
|
|
522
|
|
523 (quote
|
|
524 examples
|
|
525
|
|
526 (progn
|
|
527 ;; Create some circular structures.
|
|
528 (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
|
|
529 (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
|
|
530 (setcar (nthcdr 3 circ-list) circ-list)
|
|
531 (aset (nth 2 circ-list) 2 circ-list)
|
|
532 (setq dotted-circ-list (list 'a 'b 'c))
|
|
533 (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
|
|
534 (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
|
|
535 (aset circ-vector 5 (make-symbol "-gensym-"))
|
|
536 (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
|
|
537 nil)
|
|
538
|
|
539 (install-custom-print-funcs)
|
|
540 ;; (setq print-circle t)
|
|
541
|
|
542 (let ((print-circle t))
|
|
543 (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
|
|
544 (error "circular object with array printing")))
|
|
545
|
|
546 (let ((print-circle t))
|
|
547 (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
|
|
548 (error "circular object with array printing")))
|
|
549
|
|
550 (let* ((print-circle t)
|
|
551 (x (list 'p 'q))
|
|
552 (y (list (list 'a 'b) x 'foo x)))
|
|
553 (setcdr (cdr (cdr (cdr y))) (cdr y))
|
|
554 (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
|
|
555 )
|
|
556 (error "circular list example from CL manual")))
|
|
557
|
|
558 ;; There's no special handling of uninterned symbols in custom-print.
|
|
559 (let ((print-circle nil))
|
|
560 (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
|
|
561 (error "uninterned symbols in list")))
|
|
562 (let ((print-circle t))
|
|
563 (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
|
|
564 (error "circular uninterned symbols in list")))
|
|
565
|
|
566 (uninstall-custom-print-funcs)
|
|
567 )
|
|
568
|
|
569 ;;; cus-print.el ends here
|