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