cust-print.el 23 KB

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