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