|
72
|
1 ;; -*- Syntax: Emacs-Lisp; Mode: emacs-lisp -*-
|
|
|
2 ;;
|
|
|
3 ;; Emacs Lisp pretty printer and macro expander
|
|
|
4 ;;
|
|
|
5 ;; Copyright (C) 1992,1993 Guido Bosch <Guido.Bosch@loria.fr>
|
|
|
6
|
|
|
7 ;; This file is written in GNU Emacs Lisp, but is not part of GNU Emacs.
|
|
|
8
|
|
|
9 ;; The software contained in this file is free software; you can
|
|
|
10 ;; redistribute it and/or modify it under the terms of the GNU General
|
|
|
11 ;; Public License as published by the Free Software Foundation; either
|
|
|
12 ;; version 2, or (at your option) any later version.
|
|
|
13
|
|
|
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
|
|
|
19 ;; You should have received a copy of the GNU General Public License
|
|
|
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
|
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
22 ;;
|
|
|
23 ;; Please send bugs and comments to the author.
|
|
|
24 ;;
|
|
|
25 ;; <DISCLAIMER>
|
|
|
26 ;; This program is still under development. Neither the author nor
|
|
|
27 ;; CRIN-INRIA accepts responsibility to anyone for the consequences of
|
|
|
28 ;; using it or for whether it serves any particular purpose or works
|
|
|
29 ;; at all.
|
|
|
30 ;;
|
|
|
31 ;; The package has been developed under Lucid Emacs 19, but also runs
|
|
|
32 ;; on Emacs 18, if it is compiled with the version 19 byte compiler
|
|
|
33 ;; (function `compiled-function-p' lacking).
|
|
|
34 ;;
|
|
|
35
|
|
|
36 ;; Installation and Usage
|
|
|
37 ;; ----------------------
|
|
|
38 ;;
|
|
|
39 ;; This package provides an Emacs Lisp sexpression pretty printer and
|
|
|
40 ;; macroexpander. To install it, put the following line in your .emacs,
|
|
|
41 ;; default.el or site-init.el/site-run.el (for Lucid Emacs):
|
|
|
42 ;; (require 'pp)
|
|
|
43 ;;
|
|
|
44 ;; The package can also be made autoloadable, with the following entry
|
|
|
45 ;; points:
|
|
|
46 ;; (autoload 'pp-function "pp" nil t)
|
|
|
47 ;; (autoload 'pp-variable "pp" nil t)
|
|
|
48 ;; (autoload 'pp-plist "pp" nil t)
|
|
|
49 ;; (autoload 'macroexpand-sexp "pp" nil t)
|
|
|
50 ;; (autoload 'macroexpand-all-sexp "pp" nil t)
|
|
|
51 ;; (autoload 'prettyexpand-sexp "pp" nil t)
|
|
|
52 ;; (autoload 'prettyexpand-all-sexp "pp" nil t)
|
|
|
53 ;;
|
|
|
54 ;;(define-key emacs-lisp-mode-map '(control meta m) 'macroexpand-sexp)
|
|
|
55 ;;(define-key emacs-lisp-mode-map '(control meta M) 'macroexpand-all-sexp)
|
|
|
56 ;;(define-key emacs-lisp-mode-map '(control symbol m) 'prettyexpand-sexp)
|
|
|
57 ;;(define-key emacs-lisp-mode-map '(control symbol M) 'prettyexpand-all-sexp)
|
|
|
58 ;;
|
|
|
59 ;;(define-key lisp-interaction-mode-map '(control meta m) 'macroexpand-sexp)
|
|
|
60 ;;(define-key lisp-interaction-mode-map '(control meta M) 'macroexpand-all-sexp)
|
|
|
61 ;;(define-key lisp-interaction-mode-map '(control symbol m) 'prettyexpand-sexp)
|
|
|
62 ;;(define-key lisp-interaction-mode-map '(control symbol M) 'prettyexpand-all-sexp)
|
|
|
63 ;;
|
|
|
64
|
|
|
65 ;; Pretty printing of the different cells of a symbol is done with the
|
|
|
66 ;; commands:
|
|
|
67 ;;
|
|
|
68 ;; M-x pp-function
|
|
|
69 ;; M-x pp-variable
|
|
|
70 ;; M-x pp-plist
|
|
|
71 ;;
|
|
|
72 ;; They print a symbol's function definition, variable value and
|
|
|
73 ;; property list, respectively. These commands pop up a separate
|
|
|
74 ;; window in which the pretty printed lisp object is displayed.
|
|
|
75 ;; Completion for function and variable symbols is provided. If a
|
|
|
76 ;; function is byte compiled, `pp-function' proposes to call the Emacs
|
|
|
77 ;; Lisp disassembler (this feature only works for Emacs 19, as it
|
|
|
78 ;; needs the `compiled-function-p' predicate).
|
|
|
79 ;;
|
|
|
80 ;; To use the macro expander, put the cursor at the beginning of the
|
|
|
81 ;; form to be expanded, then type
|
|
|
82 ;;
|
|
|
83 ;; C-M-m (macroexpand-sexp)
|
|
|
84 ;; or C-M-Sh-M (macroexpand-all-sexp)
|
|
|
85 ;;
|
|
|
86 ;; Both commands will pop up a temporary window containing the
|
|
|
87 ;; macroexpanded code. The only difference is that the second command
|
|
|
88 ;; expands recursively all containing macro calls, while the first one
|
|
|
89 ;; does it only for the uppermost sexpression.
|
|
|
90 ;; With a prefix argument, the macro expansion isn't displayed in a
|
|
|
91 ;; separate buffer but replaces the original code in the current
|
|
|
92 ;; buffer. Be aware: Comments will be lost.
|
|
|
93 ;; You can get back the original sexpression using the `undo'
|
|
|
94 ;; command on `C-x u'.
|
|
|
95 ;;
|
|
|
96 ;; There is also a prettyfied version of the macroexpander:
|
|
|
97 ;;
|
|
|
98 ;; C-Sym-m (prettyexpand-sexp)
|
|
|
99 ;; or C-Sym-M (prettyexpand-all-sexp)
|
|
|
100 ;;
|
|
|
101 ;; The only difference with the corresponding macroexpand commands is
|
|
|
102 ;; that calls to macros specified in the variable
|
|
|
103 ;; `pp-shadow-expansion-list' are not expanded, in order to make the
|
|
|
104 ;; code look nicer. This is only useful for Lucid Emacs or code that
|
|
|
105 ;; uses Dave Gillespies cl package, as it inhibits expansion of the
|
|
|
106 ;; following macros: block, eval-when, defun*, defmacro*, function*,
|
|
|
107 ;; setf.
|
|
|
108
|
|
|
109 ; Change History
|
|
|
110 ;
|
|
|
111 ; $Log: pretty-print.el,v $
|
|
|
112 ; Revision 1.1.1.1 1996/12/18 22:51:29 steve
|
|
|
113 ; XEmacs 20.0 -- Beta 31
|
|
|
114 ;
|
|
|
115 ; Revision 1.4 1993/03/25 14:09:52 bosch
|
|
|
116 ; Commands `prettyexpand-sexp' and `prettyexpand-all-sexp' and
|
|
|
117 ; corresponding key bindings added. Commands pp-{function, variable}
|
|
|
118 ; rewritten. `pp-plist' added. Function `pp-internal-loop' (for Dave
|
|
|
119 ; Gillespies CL loop macro) added.
|
|
|
120 ;
|
|
|
121 ; Revision 1.3 1993/03/03 12:24:13 bosch
|
|
|
122 ; Macroexpander rewritten. Function `pp-macroexpand-all' added (snarfed
|
|
|
123 ; from Dave Gillespies cl-extra.el). Pretty printing for top level
|
|
|
124 ; defining forms added (`pp-internal-def'). Key bindings for
|
|
|
125 ; `emacs-lisp-mode-map' and `lisp-interaction-mode-map' added. Built-in
|
|
|
126 ; variable `print-gensym' set for printinng uninterned symbols. Started
|
|
|
127 ; adding support for cl-dg (defun*, defmacro*, ...). Minor bug fixes.
|
|
|
128 ;
|
|
|
129 ; Revision 1.2 1993/02/25 17:35:02 bosch
|
|
|
130 ; Comments about Emacs 18 compatibility added.
|
|
|
131 ;
|
|
|
132 ; Revision 1.1 1993/02/25 16:55:01 bosch
|
|
|
133 ; Initial revision
|
|
|
134 ;
|
|
|
135 ;
|
|
|
136
|
|
|
137
|
|
|
138 ;; TO DO LIST
|
|
|
139 ;; ----------
|
|
|
140 ;; Provide full Emacs 18 compatibility.
|
|
|
141
|
|
|
142 ;; Popper support
|
|
|
143 (defvar pp-buffer-name "*Pretty Print*")
|
|
|
144 (defvar pp-macroexpand-buffer-name "*Macro Expansion*")
|
|
|
145 (if (featurep 'popper)
|
|
|
146 (or (eq popper-pop-buffers 't)
|
|
|
147 (setq popper-pop-buffers
|
|
|
148 (cons pp-buffer-name
|
|
|
149 (cons pp-macroexpand-buffer-name
|
|
|
150 popper-pop-buffers)))))
|
|
|
151
|
|
|
152 ;; User level functions
|
|
|
153 ;;;###autoload
|
|
|
154 (defun pp-function (symbol)
|
|
|
155 "Pretty print the function definition of SYMBOL in a seperate buffer"
|
|
|
156 (interactive
|
|
|
157 (list (pp-read-symbol 'fboundp "Pretty print function definition of: ")))
|
|
|
158 (if (compiled-function-p (symbol-function symbol))
|
|
|
159 (if (y-or-n-p
|
|
|
160 (format "Function %s is byte compiled. Disassemble? " symbol))
|
|
|
161 (disassemble (symbol-function symbol))
|
|
|
162 (pp-symbol-cell symbol 'symbol-function))
|
|
|
163 (pp-symbol-cell symbol 'symbol-function)))
|
|
|
164
|
|
|
165 ;;;###autoload
|
|
|
166 (defun pp-variable (symbol)
|
|
|
167 "Pretty print the variable value of SYMBOL in a seperate buffer"
|
|
|
168 (interactive
|
|
|
169 (list (pp-read-symbol 'boundp "Pretty print variable value of: ")))
|
|
|
170 (pp-symbol-cell symbol 'symbol-value))
|
|
|
171
|
|
|
172 ;;;###autoload
|
|
|
173 (defun pp-plist (symbol)
|
|
|
174 "Pretty print the property list of SYMBOL in a seperate buffer"
|
|
|
175 (interactive
|
|
|
176 (list (pp-read-symbol 'symbol-plist "Pretty print property list of: ")))
|
|
|
177 (pp-symbol-cell symbol 'symbol-plist))
|
|
|
178
|
|
|
179 (defun pp-read-symbol (predicate prompt)
|
|
|
180 "Read a symbol for which PREDICATE is true, promptiong with PROMPT."
|
|
|
181 (let (symbol)
|
|
|
182 (while (or (not symbol) (not (funcall predicate symbol)))
|
|
|
183 (setq symbol
|
|
|
184 (intern-soft
|
|
|
185 (completing-read
|
|
|
186 prompt
|
|
|
187 obarray
|
|
|
188 predicate
|
|
|
189 t
|
|
|
190 (and symbol (symbol-name symbol))))))
|
|
|
191 symbol))
|
|
|
192
|
|
|
193 (defun pp-symbol-cell (symbol accessor)
|
|
|
194 "Pretty print the contents of the cell of SYMBOL that can be reached
|
|
|
195 with the function ACCESSOR."
|
|
|
196 (with-output-to-temp-buffer pp-buffer-name
|
|
|
197 (set-buffer pp-buffer-name)
|
|
|
198 (emacs-lisp-mode)
|
|
|
199 (erase-buffer)
|
|
|
200 (pp-internal
|
|
|
201 (funcall accessor symbol)
|
|
|
202 (format "%s's %s is:\n" symbol accessor))
|
|
|
203 (terpri)))
|
|
|
204
|
|
|
205
|
|
|
206
|
|
|
207 ;; Macro expansion (user level)
|
|
|
208
|
|
|
209 ;;;###autoload
|
|
|
210 (defun macroexpand-sexp (&optional replace)
|
|
|
211 "Macro expand the sexpression following point. Pretty print expansion in a
|
|
|
212 temporary buffer. With prefix argument, replace the original
|
|
|
213 sexpression by its expansion in the current buffer."
|
|
|
214 (interactive "P")
|
|
|
215 (pp-macroexpand-internal 'macroexpand replace t))
|
|
|
216
|
|
|
217 ;;;###autoload
|
|
|
218 (defun macroexpand-all-sexp (&optional replace)
|
|
|
219 "Macro expand recursively the sexpression following point. Pretty print
|
|
|
220 expansion in a temporary buffer. With prefix argument, replace the
|
|
|
221 original sexpression by its expansion in the current buffer."
|
|
|
222 (interactive "P")
|
|
|
223 (pp-macroexpand-internal 'pp-macroexpand-all replace t))
|
|
|
224
|
|
|
225 ;;;###autoload
|
|
|
226 (defun prettyexpand-sexp (&optional replace)
|
|
|
227 "Macro expand the sexpression following point. Pretty print expansion
|
|
|
228 in a temporary buffer. With prefix argument, replace the original
|
|
|
229 sexpression by its expansion in the current buffer.
|
|
|
230 However, calls to macros specified in the variable
|
|
|
231 `pp-shadow-expansion-list' are not expanded, in order to make the code
|
|
|
232 look nicer."
|
|
|
233
|
|
|
234 (interactive "P")
|
|
|
235 (pp-macroexpand-internal 'macroexpand replace))
|
|
|
236
|
|
|
237 ;;;###autoload
|
|
|
238 (defun prettyexpand-all-sexp (&optional replace)
|
|
|
239 "Macro expand recursively the sexpression following point. Pretty print
|
|
|
240 expansion in a temporary buffer. With prefix argument, replace the
|
|
|
241 original sexpression by its expansion in the current buffer.
|
|
|
242 However, calls to macros specified in the variable
|
|
|
243 `pp-shadow-expansion-list' are not expanded, in order to make the code
|
|
|
244 look nicer."
|
|
|
245 (interactive "P")
|
|
|
246 (pp-macroexpand-internal 'pp-macroexpand-all replace))
|
|
|
247
|
|
|
248 (define-key emacs-lisp-mode-map '(control meta m) 'macroexpand-sexp)
|
|
|
249 (define-key emacs-lisp-mode-map '(control meta M) 'macroexpand-all-sexp)
|
|
|
250 (define-key emacs-lisp-mode-map '(control symbol m) 'prettyexpand-sexp)
|
|
|
251 (define-key emacs-lisp-mode-map '(control symbol M) 'prettyexpand-all-sexp)
|
|
|
252
|
|
|
253 (define-key lisp-interaction-mode-map '(control meta m) 'macroexpand-sexp)
|
|
|
254 (define-key lisp-interaction-mode-map '(control meta M) 'macroexpand-all-sexp)
|
|
|
255 (define-key lisp-interaction-mode-map '(control symbol m) 'prettyexpand-sexp)
|
|
|
256 (define-key lisp-interaction-mode-map '(control symbol M) 'prettyexpand-all-sexp)
|
|
|
257
|
|
|
258
|
|
|
259 ;; Macro expansion (internals)
|
|
|
260
|
|
|
261 (defvar pp-shadow-expansion-list
|
|
|
262 (mapcar 'list '(block eval-when defun* defmacro* function* setf))
|
|
|
263 "The value of this variable is given as the optional environment
|
|
|
264 argument of the macroexpand functions. Forms specified in this list are
|
|
|
265 not expanded.")
|
|
|
266
|
|
|
267 (defun pp-macroexpand-internal
|
|
|
268 (macroexpand-function replace &optional dont-shadow)
|
|
|
269 "Macro expand the sexp that starts at point, using
|
|
|
270 MACROEXPAND-FUNCTION. If REPLACE is non-nil, replace the original
|
|
|
271 text by its expansion, otherwise pretty print the expansion in a
|
|
|
272 temporary buffer. With optional argument DONT-SHADOW non-nil, do not
|
|
|
273 use the `pp-shadow-expansion-list' to inhibit expansion of some
|
|
|
274 forms."
|
|
|
275
|
|
|
276 (interactive)
|
|
|
277 (let ((expansion
|
|
|
278 (funcall
|
|
|
279 macroexpand-function
|
|
|
280 (let ((stab (syntax-table)))
|
|
|
281 (unwind-protect
|
|
|
282 (save-excursion
|
|
|
283 (set-syntax-table emacs-lisp-mode-syntax-table)
|
|
|
284 ;; (forward-sexp 1)
|
|
|
285 (read (current-buffer)))
|
|
|
286 (set-syntax-table stab)))
|
|
|
287 (if dont-shadow
|
|
|
288 nil
|
|
|
289 pp-shadow-expansion-list))))
|
|
|
290 (save-excursion
|
|
|
291 (if replace
|
|
|
292 (let ((start (point))
|
|
|
293 (end (progn (forward-sexp 1) (point))))
|
|
|
294 (delete-region start end)
|
|
|
295 (pp-internal expansion))
|
|
|
296 (with-output-to-temp-buffer pp-macroexpand-buffer-name
|
|
|
297 (set-buffer pp-macroexpand-buffer-name)
|
|
|
298 (erase-buffer)
|
|
|
299 (emacs-lisp-mode)
|
|
|
300 (pp-internal expansion))))))
|
|
|
301
|
|
|
302 ;; Internal pretty print functions
|
|
|
303
|
|
|
304 (defun pp-internal (form &optional title)
|
|
|
305 "Pretty print FORM in in the current buffer.
|
|
|
306 Optional string TITEL is inserted before the pretty print."
|
|
|
307 (let (start)
|
|
|
308 (if title (princ title))
|
|
|
309 (setq start (point))
|
|
|
310 ;; print-escape-newlines must be t, otherwise we cannot use
|
|
|
311 ;; (current-column) to detect good line breaks
|
|
|
312 (let ((print-escape-newlines t)
|
|
|
313 (print-gensym t)
|
|
|
314 )
|
|
|
315 (prin1 form (current-buffer))
|
|
|
316 (goto-char start)
|
|
|
317 (pp-internal-sexp))))
|
|
|
318
|
|
|
319 (defun pp-internal-sexp ()
|
|
|
320 "Pretty print the following sexp.
|
|
|
321 Point must be on or before the first character."
|
|
|
322
|
|
|
323 (skip-chars-forward " \n\t")
|
|
|
324 (let* ((char (following-char))
|
|
|
325 (ch-class (char-syntax char))
|
|
|
326 (start (point)))
|
|
|
327
|
|
|
328 (cond
|
|
|
329 ;; open paren
|
|
|
330 ((eq char ?\()
|
|
|
331 (down-list 1)
|
|
|
332 (if (memq (char-syntax (following-char)) '(?_ ?w))
|
|
|
333 (let ((symbol (read (current-buffer))))
|
|
|
334 (cond ((fboundp symbol)
|
|
|
335 (goto-char start)
|
|
|
336 (pp-internal-function symbol))
|
|
|
337 ((memq symbol '(lambda macro))
|
|
|
338 (pp-internal-lambda))
|
|
|
339 (t
|
|
|
340 (goto-char start)
|
|
|
341 (pp-internal-list))))
|
|
|
342 (up-list -1)
|
|
|
343 (pp-internal-list)))
|
|
|
344
|
|
|
345 ;;symbols & strings
|
|
|
346 ((memq ch-class '(?_ ; symbol
|
|
|
347 ?w ; word
|
|
|
348 ?\" ; string
|
|
|
349 ?\\ ; escape
|
|
|
350 ?\' ; quote (for uninterned symbols)
|
|
|
351 )) (forward-sexp 1))
|
|
|
352
|
|
|
353 ;; vector
|
|
|
354 ((eq char ?\[) (pp-internal-list))
|
|
|
355
|
|
|
356 ;; error otherwise
|
|
|
357 (t (error "pp-internal-sexp: character class not treated yet: `%c'"
|
|
|
358 ch-class)))))
|
|
|
359
|
|
|
360 (defun pp-internal-function (func)
|
|
|
361 "Pretty print a functuion call.
|
|
|
362 Point must be on the open paren. the function symbol may be passed as an
|
|
|
363 optional argument."
|
|
|
364 (let ((start (point))
|
|
|
365 (too-large (>= (save-excursion
|
|
|
366 (forward-sexp 1)
|
|
|
367 (current-column))
|
|
|
368 fill-column))
|
|
|
369 (indent-info (get func lisp-indent-function)))
|
|
|
370 (down-list 1)
|
|
|
371 ;; skip over function name
|
|
|
372 (forward-sexp 1)
|
|
|
373 (cond
|
|
|
374 ((memq func '(let let*)) (pp-internal-let))
|
|
|
375
|
|
|
376 ((eq func 'cond) (pp-internal-cond))
|
|
|
377
|
|
|
378 ((memq func '(if while with-output-to-temp-buffer catch block))
|
|
|
379 (pp-internal-sexp)
|
|
|
380 (pp-internal-body 't))
|
|
|
381
|
|
|
382 ((eq func 'quote) (pp-internal-quote))
|
|
|
383
|
|
|
384 ((memq func '(progn
|
|
|
385 prog1 prog2
|
|
|
386 save-window-excursion
|
|
|
387 save-excursion
|
|
|
388 save-restriction))
|
|
|
389 (pp-internal-body 't))
|
|
|
390
|
|
|
391 ((memq func '(defun defmacro defsubst defun* defmacro*))
|
|
|
392 (pp-internal-def))
|
|
|
393
|
|
|
394 ((eq func 'loop) (pp-internal-loop))
|
|
|
395
|
|
|
396 ('t (pp-internal-body too-large)))))
|
|
|
397
|
|
|
398 (defun pp-internal-def ()
|
|
|
399 (forward-sexp 1) ; skip name
|
|
|
400 (if (looking-at " nil") ; replace nil by ()
|
|
|
401 (replace-match " ()")
|
|
|
402 (forward-sexp 1))
|
|
|
403 (if (looking-at " \"")
|
|
|
404 ;; comment string. Replace all escaped linefeeds by real ones
|
|
|
405 (let ((limit (save-excursion (forward-sexp 1) (point-marker))))
|
|
|
406 (newline-and-indent)
|
|
|
407 (while (re-search-forward "\\\\n" limit t)
|
|
|
408 (replace-match "\n" nil nil))
|
|
|
409 (goto-char limit)))
|
|
|
410 (pp-internal-body 't))
|
|
|
411
|
|
|
412 (defun pp-internal-list ()
|
|
|
413 "Pretty print a list or a vector.
|
|
|
414 Point must be on the open paren."
|
|
|
415 (let ((too-large (>= (save-excursion
|
|
|
416 (forward-sexp 1)
|
|
|
417 (current-column))
|
|
|
418 fill-column)))
|
|
|
419 (down-list 1)
|
|
|
420 (pp-internal-sexp)
|
|
|
421 (pp-internal-body too-large)))
|
|
|
422
|
|
|
423 (defun pp-internal-body (&optional force-indent)
|
|
|
424 "Prety print a body of sexp. Stop after reaching a `)'. If argument
|
|
|
425 FORCE-INDENT is non-nil, break line after each sexpression of the
|
|
|
426 body."
|
|
|
427 (skip-chars-forward " \n\t")
|
|
|
428 (let (ch-class)
|
|
|
429 ;; while not closing paren
|
|
|
430 (while (/= (setq ch-class (char-syntax (following-char))) ?\))
|
|
|
431 (if force-indent (newline-and-indent))
|
|
|
432 (pp-internal-sexp))
|
|
|
433 (up-list 1)))
|
|
|
434
|
|
|
435 (defun pp-internal-loop ()
|
|
|
436 "Prety print a loop body. Stop after reaching a `)'.
|
|
|
437 Line breaks are done before the following keywords: "
|
|
|
438 (forward-sexp 1)
|
|
|
439 (skip-chars-forward " \n\t")
|
|
|
440 (let (ch-class)
|
|
|
441 ;; while not closing paren
|
|
|
442 (while (/= (setq ch-class (char-syntax (following-char))) ?\))
|
|
|
443 (if (not (looking-at "for\\|repeat\\|with\\|while\\|until\\|always\\|never\\|thereis\\|collect\\|append\\|nconc\\|sum\\|count\\|maximize\\|minimize\\|if\\|when\\|else\\|unless\\|do\\W\\|initially\\|finally\\|return\\|named"))
|
|
|
444 (pp-internal-sexp)
|
|
|
445 (newline-and-indent)
|
|
|
446 (forward-sexp 1))
|
|
|
447 (skip-chars-forward " \n\t"))
|
|
|
448 (up-list 1)))
|
|
|
449
|
|
|
450 (defun pp-internal-body-list ()
|
|
|
451 (let ((too-large (>= (save-excursion
|
|
|
452 (forward-sexp 1)
|
|
|
453 (current-column))
|
|
|
454 fill-column))
|
|
|
455 ch-class)
|
|
|
456 (down-list 1)
|
|
|
457 (pp-internal-sexp)
|
|
|
458 (while (/= (setq ch-class (char-syntax (following-char))) ?\))
|
|
|
459 (if too-large (newline-and-indent))
|
|
|
460 (pp-internal-sexp))
|
|
|
461 (up-list 1)))
|
|
|
462
|
|
|
463 (defun pp-internal-lambda ()
|
|
|
464 (forward-sexp 1) ; arguments
|
|
|
465 (pp-internal-body 't))
|
|
|
466
|
|
|
467 (defun pp-internal-let ()
|
|
|
468 "Pretty print a let-like form.
|
|
|
469 Cursor is behind funtion symbol."
|
|
|
470 (down-list 1)
|
|
|
471 (while (not (= (following-char) ?\)))
|
|
|
472 (if (= (following-char) ?\()
|
|
|
473 (pp-internal-body-list)
|
|
|
474 (forward-sexp 1))
|
|
|
475 (if (not (= (following-char) ?\)))
|
|
|
476 (newline-and-indent)))
|
|
|
477 (up-list 1)
|
|
|
478 (pp-internal-body 't))
|
|
|
479
|
|
|
480 (defun pp-internal-cond ()
|
|
|
481 "Pretty print a cond-like form.
|
|
|
482 Cursor is behind funtion symbol."
|
|
|
483 (skip-chars-forward " \n\t")
|
|
|
484 (while (not (= (following-char) ?\)))
|
|
|
485 (pp-internal-body-list)
|
|
|
486 (if (not (= (following-char) ?\)))
|
|
|
487 (newline-and-indent)))
|
|
|
488 (up-list 1))
|
|
|
489
|
|
|
490
|
|
|
491 (defun pp-internal-quote ()
|
|
|
492 "Pretty print a quoted list.
|
|
|
493 Cursor is behind the symbol quote."
|
|
|
494 (skip-chars-forward " \n\t")
|
|
|
495 (let ((end (point)))
|
|
|
496 (backward-sexp 1)
|
|
|
497 (delete-region (point) end)
|
|
|
498 (up-list -1)
|
|
|
499 (setq end (point))
|
|
|
500 (forward-sexp 1)
|
|
|
501 (delete-char -1)
|
|
|
502 (goto-char end)
|
|
|
503 (delete-char 1)
|
|
|
504 (insert "'")
|
|
|
505 (if (= (char-syntax (following-char)) ?\()
|
|
|
506 ;; don't print it as sexp, because it could be (let ... ) or
|
|
|
507 ;; (cond ... ) or whatever.
|
|
|
508 (pp-internal-list)
|
|
|
509 (pp-internal-sexp))))
|
|
|
510
|
|
|
511
|
|
|
512 ;; Stolen form Dave Gillespies cl-extra.el
|
|
|
513 (defun pp-macroexpand-all (form &optional env)
|
|
|
514 "Expand all macro calls through a Lisp FORM.
|
|
|
515 This also does some trivial optimizations to make the form prettier."
|
|
|
516 (setq form (macroexpand form env))
|
|
|
517 (cond
|
|
|
518 ((not (consp form)) form)
|
|
|
519 ((memq (car form) '(let let*))
|
|
|
520 (if (null (nth 1 form))
|
|
|
521 (pp-macroexpand-all (cons 'progn (cdr (cdr form))) env)
|
|
|
522 (cons (car form)
|
|
|
523 (cons (pp-macroexpand-lets (nth 1 form) env)
|
|
|
524 (pp-macroexpand-body (cdr (cdr form)) env)))))
|
|
|
525 ((eq (car form) 'cond)
|
|
|
526 (cons (car form)
|
|
|
527 (mapcar (function (lambda (x) (pp-macroexpand-body x env)))
|
|
|
528 (cdr form))))
|
|
|
529 ((eq (car form) 'condition-case)
|
|
|
530 (cons (car form)
|
|
|
531 (cons (nth 1 form)
|
|
|
532 (cons (pp-macroexpand-all (nth 2 form) env)
|
|
|
533 (pp-macroexpand-lets
|
|
|
534 (cdr (cdr (cdr form))) env)))))
|
|
|
535 ((memq (car form) '(quote function))
|
|
|
536 (if (eq (car-safe (nth 1 form)) 'lambda)
|
|
|
537 (list (car form)
|
|
|
538 (cons 'lambda
|
|
|
539 (cons (car (cdr (car (cdr form))))
|
|
|
540 (pp-macroexpand-body
|
|
|
541 (cdr (cdr (car (cdr form)))) env))))
|
|
|
542 form))
|
|
|
543 ((memq (car form) '(defun defmacro))
|
|
|
544 (cons (car form)
|
|
|
545 (cons (nth 1 form)
|
|
|
546 (pp-macroexpand-body (cdr (cdr form)) env))))
|
|
|
547 ((and (eq (car form) 'progn) (not (cdr (cdr form))))
|
|
|
548 (pp-macroexpand-all (nth 1 form) env))
|
|
|
549 (t
|
|
|
550 (cons (car form) (pp-macroexpand-body (cdr form) env)))))
|
|
|
551
|
|
|
552 (defun pp-macroexpand-body (body &optional env)
|
|
|
553 (mapcar (function (lambda (x) (pp-macroexpand-all x env))) body))
|
|
|
554
|
|
|
555 (defun pp-macroexpand-lets (list &optional env)
|
|
|
556 (mapcar (function
|
|
|
557 (lambda (x)
|
|
|
558 (if (consp x) (cons (car x) (pp-macroexpand-body (cdr x) env))
|
|
|
559 x))) list))
|
|
|
560
|
|
|
561 (run-hooks 'pp-load-hook)
|
|
|
562 (provide 'pp)
|
|
|
563
|
|
|
564 ;; end pp.el
|
