Line data Source code
1 : ;;; cl-print.el --- CL-style generic printing -*- lexical-binding: t; -*-
2 :
3 : ;; Copyright (C) 2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6 : ;; Keywords:
7 : ;; Version: 1.0
8 : ;; Package-Requires: ((emacs "25"))
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 3 of the License, or
15 : ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
24 :
25 : ;;; Commentary:
26 :
27 : ;; Customizable print facility.
28 : ;;
29 : ;; The heart of it is the generic function `cl-print-object' to which you
30 : ;; can add any method you like.
31 : ;;
32 : ;; The main entry point is `cl-prin1'.
33 :
34 : ;;; Code:
35 :
36 : (require 'button)
37 :
38 : (defvar cl-print-readably nil
39 : "If non-nil, try and make sure the result can be `read'.")
40 :
41 : (defvar cl-print--number-table nil)
42 : (defvar cl-print--currently-printing nil)
43 :
44 : ;;;###autoload
45 : (cl-defgeneric cl-print-object (object stream)
46 : "Dispatcher to print OBJECT on STREAM according to its type.
47 : You can add methods to it to customize the output.
48 : But if you just want to print something, don't call this directly:
49 : call other entry points instead, such as `cl-prin1'."
50 : ;; This delegates to the C printer. The C printer will not call us back, so
51 : ;; we should only use it for objects which don't have nesting.
52 : (prin1 object stream))
53 :
54 : (cl-defmethod cl-print-object ((object cons) stream)
55 1762 : (let ((car (pop object)))
56 881 : (if (and (memq car '(\, quote \` \,@ \,.))
57 15 : (consp object)
58 881 : (null (cdr object)))
59 15 : (progn
60 15 : (princ (if (eq car 'quote) '\' car) stream)
61 15 : (cl-print-object (car object) stream))
62 866 : (princ "(" stream)
63 866 : (cl-print-object car stream)
64 2587 : (while (and (consp object)
65 1721 : (not (if cl-print--number-table
66 0 : (numberp (gethash object cl-print--number-table))
67 2587 : (memq object cl-print--currently-printing))))
68 1721 : (princ " " stream)
69 3442 : (cl-print-object (pop object) stream))
70 866 : (when object
71 866 : (princ " . " stream) (cl-print-object object stream))
72 881 : (princ ")" stream))))
73 :
74 : (cl-defmethod cl-print-object ((object vector) stream)
75 0 : (princ "[" stream)
76 0 : (dotimes (i (length object))
77 0 : (unless (zerop i) (princ " " stream))
78 0 : (cl-print-object (aref object i) stream))
79 0 : (princ "]" stream))
80 :
81 : (define-button-type 'help-byte-code
82 : 'follow-link t
83 : 'action (lambda (button)
84 : (disassemble (button-get button 'byte-code-function)))
85 : 'help-echo (purecopy "mouse-2, RET: disassemble this function"))
86 :
87 : (defvar cl-print-compiled nil
88 : "Control how to print byte-compiled functions. Can be:
89 : - `static' to print the vector of constants.
90 : - `disassemble' to print the disassembly of the code.
91 : - nil to skip printing any details about the code.")
92 :
93 : (defvar cl-print-compiled-button t
94 : "Control how to print byte-compiled functions into buffers.
95 : When the stream is a buffer, make the bytecode part of the output
96 : into a button whose action shows the function's disassembly.")
97 :
98 : (autoload 'disassemble-1 "disass")
99 :
100 : (cl-defmethod cl-print-object ((object compiled-function) stream)
101 : (unless stream (setq stream standard-output))
102 : ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results.
103 : (princ "#f(compiled-function " stream)
104 : (let ((args (help-function-arglist object 'preserve-names)))
105 : (if args
106 : (prin1 args stream)
107 : (princ "()" stream)))
108 : (pcase (help-split-fundoc (documentation object 'raw) object)
109 : ;; Drop args which `help-function-arglist' already printed.
110 : (`(,_usage . ,(and doc (guard (stringp doc))))
111 : (princ " " stream)
112 : (prin1 doc stream)))
113 : (let ((inter (interactive-form object)))
114 : (when inter
115 : (princ " " stream)
116 : (cl-print-object
117 : (if (eq 'byte-code (car-safe (cadr inter)))
118 : `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
119 : (nth 2 (cadr inter))
120 : (nth 3 (cadr inter))))
121 : inter)
122 : stream)))
123 : (if (eq cl-print-compiled 'disassemble)
124 : (princ
125 : (with-temp-buffer
126 : (insert "\n")
127 : (disassemble-1 object 0)
128 : (buffer-string))
129 : stream)
130 : (princ " " stream)
131 : (let ((button-start (and cl-print-compiled-button
132 : (bufferp stream)
133 : (with-current-buffer stream (point)))))
134 : (princ "#<bytecode>" stream)
135 : (when (eq cl-print-compiled 'static)
136 : (princ " " stream)
137 : (cl-print-object (aref object 2) stream))
138 : (when button-start
139 : (with-current-buffer stream
140 : (make-text-button button-start (point)
141 : :type 'help-byte-code
142 : 'byte-code-function object)))))
143 : (princ ")" stream))
144 :
145 : ;; This belongs in nadvice.el, of course, but some load-ordering issues make it
146 : ;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add
147 : ;; from nadvice, so nadvice needs to be loaded before cl-generic and hence
148 : ;; can't use cl-defmethod.
149 : (cl-defmethod cl-print-object :extra "nadvice"
150 : ((object compiled-function) stream)
151 4 : (if (not (advice--p object))
152 4 : (cl-call-next-method)
153 2 : (princ "#f(advice-wrapper " stream)
154 2 : (when (fboundp 'advice--where)
155 2 : (princ (advice--where object) stream)
156 2 : (princ " " stream))
157 2 : (cl-print-object (advice--cdr object) stream)
158 2 : (princ " " stream)
159 0 : (cl-print-object (advice--car object) stream)
160 2 : (let ((props (advice--props object)))
161 2 : (when props
162 2 : (princ " " stream)
163 0 : (cl-print-object props stream)))
164 0 : (princ ")" stream)))
165 :
166 : (cl-defmethod cl-print-object ((object cl-structure-object) stream)
167 0 : (princ "#s(" stream)
168 0 : (let* ((class (cl-find-class (type-of object)))
169 0 : (slots (cl--struct-class-slots class)))
170 0 : (princ (cl--struct-class-name class) stream)
171 0 : (dotimes (i (length slots))
172 0 : (let ((slot (aref slots i)))
173 0 : (princ " :" stream)
174 0 : (princ (cl--slot-descriptor-name slot) stream)
175 0 : (princ " " stream)
176 0 : (cl-print-object (aref object (1+ i)) stream))))
177 0 : (princ ")" stream))
178 :
179 : ;;; Circularity and sharing.
180 :
181 : ;; I don't try to support the `print-continuous-numbering', because
182 : ;; I think it's ill defined anyway: if an object appears only once in each call
183 : ;; its sharing can't be properly preserved!
184 :
185 : (cl-defmethod cl-print-object :around (object stream)
186 : ;; FIXME: Only put such an :around method on types where it's relevant.
187 2617 : (cond
188 2617 : (print-circle
189 0 : (let ((n (gethash object cl-print--number-table)))
190 0 : (if (not (numberp n))
191 0 : (cl-call-next-method)
192 0 : (if (> n 0)
193 : ;; Already printed. Just print a reference.
194 0 : (progn (princ "#" stream) (princ n stream) (princ "#" stream))
195 0 : (puthash object (- n) cl-print--number-table)
196 0 : (princ "#" stream) (princ (- n) stream) (princ "=" stream)
197 0 : (cl-call-next-method)))))
198 2617 : ((let ((already-printing (memq object cl-print--currently-printing)))
199 2617 : (when already-printing
200 : ;; Currently printing, just print reference to avoid endless
201 : ;; recursion.
202 0 : (princ "#" stream)
203 2617 : (princ (length (cdr already-printing)) stream))))
204 2617 : (t (let ((cl-print--currently-printing
205 2617 : (cons object cl-print--currently-printing)))
206 2617 : (cl-call-next-method)))))
207 :
208 : (defvar cl-print--number-index nil)
209 :
210 : (defun cl-print--find-sharing (object table)
211 : ;; Avoid recursion: not only because it's too easy to bump into
212 : ;; `max-lisp-eval-depth', but also because function calls are fairly slow.
213 : ;; At first, I thought using a list for our stack would cause too much
214 : ;; garbage to generated, but I didn't notice any such problem in practice.
215 : ;; I experimented with using an array instead, but the result was slightly
216 : ;; slower and the reduction in GC activity was less than 1% on my test.
217 0 : (let ((stack (list object)))
218 0 : (while stack
219 0 : (let ((object (pop stack)))
220 0 : (unless
221 : ;; Skip objects which don't have identity!
222 0 : (or (floatp object) (numberp object)
223 0 : (null object) (if (symbolp object) (intern-soft object)))
224 0 : (let ((n (gethash object table)))
225 0 : (cond
226 0 : ((numberp n)) ;All done.
227 0 : (n ;Already seen, but only once.
228 0 : (let ((n (1+ cl-print--number-index)))
229 0 : (setq cl-print--number-index n)
230 0 : (puthash object (- n) table)))
231 : (t
232 0 : (puthash object t table)
233 0 : (pcase object
234 : (`(,car . ,cdr)
235 0 : (push cdr stack)
236 0 : (push car stack))
237 : ((pred stringp)
238 : ;; We presumably won't print its text-properties.
239 : nil)
240 : ((or (pred arrayp) (pred byte-code-function-p))
241 : ;; FIXME: Inefficient for char-tables!
242 0 : (dotimes (i (length object))
243 0 : (push (aref object i) stack))))))))))))
244 :
245 : (defun cl-print--preprocess (object)
246 0 : (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0)))
247 0 : (if (fboundp 'print--preprocess)
248 : ;; Use the predefined C version if available.
249 0 : (print--preprocess object) ;Fill print-number-table!
250 0 : (let ((cl-print--number-index 0))
251 0 : (cl-print--find-sharing object print-number-table)))
252 0 : print-number-table))
253 :
254 : ;;;###autoload
255 : (defun cl-prin1 (object &optional stream)
256 15 : (cond
257 15 : (cl-print-readably (prin1 object stream))
258 15 : ((not print-circle) (cl-print-object object stream))
259 : (t
260 0 : (let ((cl-print--number-table (cl-print--preprocess object)))
261 14 : (cl-print-object object stream)))))
262 :
263 : ;;;###autoload
264 : (defun cl-prin1-to-string (object)
265 0 : (with-temp-buffer
266 0 : (cl-prin1 object (current-buffer))
267 0 : (buffer-string)))
268 :
269 : (provide 'cl-print)
270 : ;;; cl-print.el ends here
|