xemacs-beta: lisp/utils/pretty-print.el comparison

comparison lisp/utils/pretty-print.el @ 12:bcdc7deadc19 r19-15b7

Import from CVS: tag r19-15b7

author	cvs
date	Mon, 13 Aug 2007 08:48:16 +0200
parents
children	ec9a17fef872

comparison

equal deleted inserted replaced

-:91ffe8bd52e4
+:bcdc7deadc19
+;;   -*- Syntax: Emacs-Lisp; Mode: emacs-lisp -*-
+;;
+;; Emacs Lisp pretty printer and macro expander
+;;
+;; Copyright (C) 1992,1993 Guido Bosch <Guido.Bosch@loria.fr>
+;; This file is written in GNU Emacs Lisp, but is not part of GNU Emacs.
+;; This file is part of XEmacs.
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; XEmacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+;; Synched up with:  Not in FSF.
+;; Please send bugs and comments to the author.
+;;
+;; <DISCLAIMER>
+;; This program is still under development.  Neither the author nor
+;; CRIN-INRIA accepts responsibility to anyone for the consequences of
+;; using it or for whether it serves any particular purpose or works
+;; at all.
+;;
+;; The package has been developed under Lucid Emacs 19, but also runs
+;; on Emacs 18, if it is compiled with the version 19 byte compiler
+;; (function `compiled-function-p' lacking).
+;;
+;; Installation and Usage
+;; ----------------------
+;;
+;; This package provides an Emacs Lisp sexpression pretty printer and
+;; macroexpander.  To install it, put the following line in your .emacs,
+;; default.el or site-init.el/site-run.el (for Lucid Emacs):
+;; (require 'pp)
+;;
+;; The package can also be made autoloadable, with the following entry
+;; points:
+;; (autoload 'pp-function "pp" nil t)
+;; (autoload 'pp-variable "pp" nil t)
+;; (autoload 'pp-plist     "pp" nil t)
+;; (autoload 'macroexpand-sexp "pp" nil t)
+;; (autoload 'macroexpand-all-sexp "pp" nil t)
+;; (autoload 'prettyexpand-sexp "pp" nil t)
+;; (autoload 'prettyexpand-all-sexp "pp" nil t)
+;;
+;;(define-key emacs-lisp-mode-map '(control meta m) 'macroexpand-sexp)
+;;(define-key emacs-lisp-mode-map '(control meta M) 'macroexpand-all-sexp)
+;;(define-key emacs-lisp-mode-map '(control symbol m) 'prettyexpand-sexp)
+;;(define-key emacs-lisp-mode-map '(control symbol M) 'prettyexpand-all-sexp)
+;;
+;;(define-key lisp-interaction-mode-map '(control meta m) 'macroexpand-sexp)
+;;(define-key lisp-interaction-mode-map '(control meta M) 'macroexpand-all-sexp)
+;;(define-key lisp-interaction-mode-map '(control symbol m) 'prettyexpand-sexp)
+;;(define-key lisp-interaction-mode-map '(control symbol M) 'prettyexpand-all-sexp)
+;;
+;; Pretty printing of the different cells of a symbol is done with the
+;; commands:
+;;
+;; 		M-x pp-function
+;; 		M-x pp-variable
+;;		M-x pp-plist
+;;
+;; They print a symbol's function definition, variable value and
+;; property list, respectively.  These commands pop up a separate
+;; window in which the pretty printed lisp object is displayed.
+;; Completion for function and variable symbols is provided. If a
+;; function is byte compiled, `pp-function' proposes to call the Emacs
+;; Lisp disassembler (this feature only works for Emacs 19, as it
+;; needs the `compiled-function-p' predicate).
+;;
+;; To use the macro expander, put the cursor at the beginning of the
+;; form to be expanded, then type
+;;
+;; 	        C-M-m 		(macroexpand-sexp)
+;; or		C-M-Sh-M  	(macroexpand-all-sexp)
+;;
+;; Both commands will pop up a temporary window containing the
+;; macroexpanded code. The only difference is that the second command
+;; expands recursively all containing macro calls, while the first one
+;; does it only for the uppermost sexpression.
+;; 	With a prefix argument, the macro expansion isn't displayed in a
+;; separate buffer but replaces the original code in the current
+;; buffer. Be aware: Comments will be lost.
+;; 	You can get back the original sexpression using the `undo'
+;; 	command on `C-x u'.
+;;
+;; There is also a prettyfied version of the macroexpander:
+;;
+;;		C-Sym-m		(prettyexpand-sexp)
+;; or		C-Sym-M		(prettyexpand-all-sexp)
+;;
+;; The only difference with the corresponding macroexpand commands is
+;; that calls to macros specified in the variable
+;; `pp-shadow-expansion-list' are not expanded, in order to make the
+;; code look nicer. This is only useful for Lucid Emacs or code that
+;; uses Dave Gillespies cl package, as it inhibits expansion of the
+;; following macros: block, eval-when, defun*, defmacro*, function*,
+;; setf.
+; Change History
+;
+; $Log: pretty-print.el,v $
+; Revision 1.2  1997/01/04 21:20:13  steve
+; beta6 to beta7 patches
+;
+; Revision 1.1  1997/01/01 21:45:30  steve
+; *** empty log message ***
+;
+; Revision 1.4  1993/03/25  14:09:52  bosch
+; Commands `prettyexpand-sexp' and `prettyexpand-all-sexp' and
+; corresponding key bindings added.  Commands pp-{function, variable}
+; rewritten. `pp-plist' added. Function `pp-internal-loop' (for Dave
+; Gillespies CL loop macro) added.
+;
+; Revision 1.3  1993/03/03  12:24:13  bosch
+; Macroexpander rewritten. Function `pp-macroexpand-all' added (snarfed
+; from Dave Gillespies cl-extra.el). Pretty printing for top level
+; defining forms added (`pp-internal-def'). Key bindings for
+; `emacs-lisp-mode-map' and `lisp-interaction-mode-map' added.  Built-in
+; variable `print-gensym' set for printinng uninterned symbols. Started
+; adding support for cl-dg (defun*, defmacro*, ...).  Minor bug fixes.
+;
+; Revision 1.2  1993/02/25  17:35:02  bosch
+; Comments about Emacs 18 compatibility added.
+;
+; Revision 1.1  1993/02/25  16:55:01  bosch
+; Initial revision
+;
+;
+;; TO DO LIST
+;; ----------
+;; Provide full Emacs 18 compatibility.
+;; Popper support
+(defvar pp-buffer-name "*Pretty Print*")
+(defvar pp-macroexpand-buffer-name "*Macro Expansion*")
+(if (featurep 'popper)
+(or (eq popper-pop-buffers 't)
+	(setq popper-pop-buffers
+	      (cons pp-buffer-name
+		    (cons pp-macroexpand-buffer-name
+			  popper-pop-buffers)))))
+;; User level functions
+;;;###autoload
+(defun pp-function (symbol)
+"Pretty print the function definition of SYMBOL in a seperate buffer"
+(interactive
+(list (pp-read-symbol 'fboundp "Pretty print function definition of: ")))
+(if (compiled-function-p (symbol-function symbol))
+(if (y-or-n-p
+	   (format "Function %s is byte compiled. Disassemble? " symbol))
+	  (disassemble (symbol-function symbol))
+	(pp-symbol-cell symbol 'symbol-function))
+(pp-symbol-cell symbol 'symbol-function)))
+;;;###autoload
+(defun pp-variable (symbol)
+"Pretty print the variable value of SYMBOL in a seperate buffer"
+(interactive
+(list (pp-read-symbol 'boundp "Pretty print variable value of: ")))
+(pp-symbol-cell symbol 'symbol-value))
+;;;###autoload
+(defun pp-plist (symbol)
+"Pretty print the property list of SYMBOL in a seperate buffer"
+(interactive
+(list (pp-read-symbol 'symbol-plist "Pretty print property list of: ")))
+(pp-symbol-cell symbol 'symbol-plist))
+(defun pp-read-symbol (predicate prompt)
+"Read a symbol for which  PREDICATE is true, promptiong with PROMPT."
+(let (symbol)
+(while (or (not symbol) (not (funcall predicate symbol)))
+(setq symbol
+	    (intern-soft
+	     (completing-read
+	      prompt
+	      obarray
+	      predicate
+	      t
+	      (and symbol (symbol-name symbol))))))
+symbol))
+(defun pp-symbol-cell (symbol accessor)
+"Pretty print the contents of the cell of SYMBOL that can be reached
+with the function ACCESSOR."
+(with-output-to-temp-buffer pp-buffer-name
+(set-buffer pp-buffer-name)
+(emacs-lisp-mode)
+(erase-buffer)
+(pp-internal
+(funcall accessor symbol)
+(format "%s's %s is:\n" symbol accessor))
+(terpri)))
+;; Macro expansion (user level)
+;;;###autoload
+(defun macroexpand-sexp (&optional replace)
+"Macro expand the sexpression following point. Pretty print expansion in a
+temporary buffer. With prefix argument, replace the original
+sexpression by its expansion in the current buffer."
+(interactive "P")
+(pp-macroexpand-internal 'macroexpand replace t))
+;;;###autoload
+(defun macroexpand-all-sexp (&optional replace)
+"Macro expand recursively the sexpression following point. Pretty print
+expansion in a temporary buffer. With prefix argument, replace the
+original sexpression by its expansion in the current buffer."
+(interactive "P")
+(pp-macroexpand-internal 'pp-macroexpand-all replace t))
+;;;###autoload
+(defun prettyexpand-sexp (&optional replace)
+"Macro expand the sexpression following point. Pretty print expansion
+in a temporary buffer. With prefix argument, replace the original
+sexpression by its expansion in the current buffer.
+	However, calls to macros specified in the variable
+`pp-shadow-expansion-list' are not expanded, in order to make the code
+look nicer."
+(interactive "P")
+(pp-macroexpand-internal 'macroexpand replace))
+;;;###autoload
+(defun prettyexpand-all-sexp (&optional replace)
+"Macro expand recursively the sexpression following point. Pretty print
+expansion in a temporary buffer. With prefix argument, replace the
+original sexpression by its expansion in the current buffer.
+	However, calls to macros specified in the variable
+`pp-shadow-expansion-list' are not expanded, in order to make the code
+look nicer."
+(interactive "P")
+(pp-macroexpand-internal 'pp-macroexpand-all replace))
+(define-key emacs-lisp-mode-map '(control meta m) 'macroexpand-sexp)
+(define-key emacs-lisp-mode-map '(control meta M) 'macroexpand-all-sexp)
+(define-key emacs-lisp-mode-map '(control symbol m) 'prettyexpand-sexp)
+(define-key emacs-lisp-mode-map '(control symbol M) 'prettyexpand-all-sexp)
+(define-key lisp-interaction-mode-map '(control meta m) 'macroexpand-sexp)
+(define-key lisp-interaction-mode-map '(control meta M) 'macroexpand-all-sexp)
+(define-key lisp-interaction-mode-map '(control symbol m) 'prettyexpand-sexp)
+(define-key lisp-interaction-mode-map '(control symbol M) 'prettyexpand-all-sexp)
+;; Macro expansion (internals)
+(defvar pp-shadow-expansion-list
+(mapcar 'list '(block eval-when defun* defmacro* function* setf))
+"The value of this variable is given as the optional environment
+argument of the macroexpand functions. Forms specified in this list are
+not expanded.")
+(defun pp-macroexpand-internal
+(macroexpand-function replace &optional dont-shadow)
+"Macro expand the sexp that starts at point, using
+MACROEXPAND-FUNCTION.  If REPLACE is non-nil, replace the original
+text by its expansion, otherwise pretty print the expansion in a
+temporary buffer. With optional argument DONT-SHADOW non-nil, do not
+use the `pp-shadow-expansion-list' to inhibit expansion of some
+forms."
+(interactive)
+(let ((expansion
+	 (funcall
+	  macroexpand-function
+	  (let ((stab (syntax-table)))
+	    (unwind-protect
+		(save-excursion
+		  (set-syntax-table emacs-lisp-mode-syntax-table)
+		  ;; (forward-sexp 1)
+		  (read (current-buffer)))
+	      (set-syntax-table stab)))
+	  (if dont-shadow
+	      nil
+	    pp-shadow-expansion-list))))
+(save-excursion
+(if replace
+	  (let ((start (point))
+		(end (progn (forward-sexp 1) (point))))
+	    (delete-region start end)
+	    (pp-internal expansion))
+	(with-output-to-temp-buffer pp-macroexpand-buffer-name
+	  (set-buffer pp-macroexpand-buffer-name)
+	  (erase-buffer)
+	  (emacs-lisp-mode)
+	  (pp-internal expansion))))))
+;; Internal pretty print functions
+(defun pp-internal (form &optional title)
+"Pretty print FORM in in the current buffer.
+Optional string TITEL is inserted before the pretty  print."
+(let (start)
+(if title (princ title))
+(setq start (point))
+;; print-escape-newlines must be t, otherwise we cannot use
+;; (current-column) to detect good line breaks
+(let ((print-escape-newlines t)
+	  (print-gensym t)
+	  )
+(prin1 form (current-buffer))
+(goto-char start)
+(pp-internal-sexp))))
+(defun pp-internal-sexp ()
+"Pretty print the following sexp.
+Point must be on or before the first character."
+(skip-chars-forward " \n\t")
+(let* ((char (following-char))
+	 (ch-class (char-syntax char))
+	 (start (point)))
+(cond
+;; open paren
+((eq char ?\()
+(down-list 1)
+(if (memq  (char-syntax (following-char)) '(?_ ?w))
+	  (let ((symbol (read (current-buffer))))
+	    (cond ((fboundp symbol)
+		   (goto-char start)
+		   (pp-internal-function symbol))
+		  ((memq symbol '(lambda macro))
+		   (pp-internal-lambda))
+		  (t
+		   (goto-char start)
+		   (pp-internal-list))))
+	(up-list -1)
+	(pp-internal-list)))
+;;symbols & strings
+((memq  ch-class '(?_		; symbol
+			?w		; word
+			?\"		; string
+			?\\		; escape
+			?\'		; quote (for uninterned symbols)
+			)) (forward-sexp 1))
+;; vector
+((eq char ?\[) (pp-internal-list))
+;; error otherwise
+(t (error "pp-internal-sexp: character class not treated yet: `%c'"
+	       ch-class)))))
+(defun pp-internal-function (func)
+"Pretty print a functuion call.
+Point must be on the open paren. the function symbol may be passed as an
+optional argument."
+(let ((start (point))
+	(too-large (>= (save-excursion
+			 (forward-sexp 1)
+			 (current-column))
+		       fill-column))
+	(indent-info (get func lisp-indent-function)))
+(down-list 1)
+;; skip over function name
+(forward-sexp 1)
+(cond
+((memq func '(let let*)) (pp-internal-let))
+((eq func 'cond) (pp-internal-cond))
+((memq func '(if while with-output-to-temp-buffer catch block))
+(pp-internal-sexp)
+(pp-internal-body 't))
+((eq func 'quote) (pp-internal-quote))
+((memq func '(progn
+		    prog1 prog2
+		    save-window-excursion
+		    save-excursion
+		    save-restriction))
+(pp-internal-body 't))
+((memq func '(defun defmacro defsubst defun* defmacro*))
+(pp-internal-def))
+((eq func 'loop) (pp-internal-loop))
+('t (pp-internal-body too-large)))))
+(defun pp-internal-def ()
+(forward-sexp 1)			; skip name
+(if (looking-at " nil")		; replace nil by ()
+(replace-match " ()")
+(forward-sexp 1))
+(if (looking-at " \"")
+;; comment string. Replace all escaped linefeeds by real ones
+(let ((limit (save-excursion (forward-sexp 1) (point-marker))))
+	(newline-and-indent)
+	(while (re-search-forward "\\\\n" limit t)
+	  (replace-match "\n" nil nil))
+	(goto-char limit)))
+(pp-internal-body 't))
+(defun pp-internal-list ()
+"Pretty print a list  or a vector.
+Point must be on the open paren."
+(let ((too-large (>= (save-excursion
+			(forward-sexp 1)
+			(current-column))
+		      fill-column)))
+(down-list 1)
+(pp-internal-sexp)
+(pp-internal-body too-large)))
+(defun pp-internal-body (&optional force-indent)
+"Prety print a body of sexp. Stop after reaching a `)'.  If argument
+FORCE-INDENT is non-nil, break line after each sexpression of the
+body."
+(skip-chars-forward " \n\t")
+(let (ch-class)
+;; while not closing paren
+(while (/= (setq ch-class (char-syntax (following-char))) ?\))
+(if  force-indent (newline-and-indent))
+(pp-internal-sexp))
+(up-list 1)))
+(defun pp-internal-loop ()
+"Prety print a loop body. Stop after reaching a `)'.
+Line breaks are done before the following keywords: "
+(forward-sexp 1)
+(skip-chars-forward " \n\t")
+(let (ch-class)
+;; while not closing paren
+(while (/= (setq ch-class (char-syntax (following-char))) ?\))
+(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"))
+	  (pp-internal-sexp)
+	(newline-and-indent)
+	(forward-sexp 1))
+(skip-chars-forward " \n\t"))
+(up-list 1)))
+(defun pp-internal-body-list ()
+(let ((too-large (>= (save-excursion
+			(forward-sexp 1)
+			(current-column))
+		      fill-column))
+	ch-class)
+(down-list 1)
+(pp-internal-sexp)
+(while (/= (setq ch-class (char-syntax (following-char))) ?\))
+(if  too-large (newline-and-indent))
+(pp-internal-sexp))
+(up-list 1)))
+(defun pp-internal-lambda ()
+(forward-sexp 1) ; arguments
+(pp-internal-body 't))
+(defun pp-internal-let ()
+"Pretty print a let-like  form.
+Cursor is behind funtion symbol."
+(down-list 1)
+(while (not (= (following-char) ?\)))
+(if (= (following-char) ?\()
+	(pp-internal-body-list)
+(forward-sexp 1))
+(if (not (= (following-char) ?\)))
+(newline-and-indent)))
+(up-list 1)
+(pp-internal-body 't))
+(defun pp-internal-cond ()
+"Pretty print a cond-like  form.
+Cursor is behind funtion symbol."
+(skip-chars-forward " \n\t")
+(while (not (= (following-char) ?\)))
+(pp-internal-body-list)
+(if (not (= (following-char) ?\)))
+	(newline-and-indent)))
+(up-list 1))
+(defun pp-internal-quote ()
+"Pretty print a quoted list.
+Cursor is behind the symbol quote."
+(skip-chars-forward " \n\t")
+(let ((end (point)))
+(backward-sexp 1)
+(delete-region (point) end)
+(up-list -1)
+(setq end (point))
+(forward-sexp 1)
+(delete-char -1)
+(goto-char end)
+(delete-char 1)
+(insert "'")
+(if (= (char-syntax (following-char)) ?\()
+	;; don't print it as sexp, because it could be (let ... ) or
+	;; (cond ... ) or whatever.
+	(pp-internal-list)
+(pp-internal-sexp))))
+;; Stolen form Dave Gillespies cl-extra.el
+(defun pp-macroexpand-all (form &optional env)
+"Expand all macro calls through a Lisp FORM.
+This also does some trivial optimizations to make the form prettier."
+(setq form (macroexpand form env))
+(cond
+((not (consp form)) form)
+((memq (car form) '(let let*))
+(if (null (nth 1 form))
+	(pp-macroexpand-all (cons 'progn (cdr (cdr form))) env)
+(cons (car form)
+	    (cons (pp-macroexpand-lets (nth 1 form) env)
+		  (pp-macroexpand-body (cdr (cdr form)) env)))))
+((eq (car form) 'cond)
+(cons (car form)
+	  (mapcar (function (lambda (x) (pp-macroexpand-body x env)))
+		  (cdr form))))
+((eq (car form) 'condition-case)
+(cons (car form)
+	  (cons (nth 1 form)
+		(cons (pp-macroexpand-all (nth 2 form) env)
+		      (pp-macroexpand-lets
+		       (cdr (cdr (cdr form))) env)))))
+((memq (car form) '(quote function))
+(if (eq (car-safe (nth 1 form)) 'lambda)
+	(list (car form)
+	      (cons 'lambda
+		    (cons (car (cdr (car (cdr form))))
+			  (pp-macroexpand-body
+			   (cdr (cdr (car (cdr form)))) env))))
+form))
+((memq (car form) '(defun defmacro))
+(cons (car form)
+	  (cons (nth 1 form)
+		(pp-macroexpand-body (cdr (cdr form)) env))))
+((and (eq (car form) 'progn) (not (cdr (cdr form))))
+(pp-macroexpand-all (nth 1 form) env))
+(t
+(cons (car form) (pp-macroexpand-body (cdr form) env)))))
+(defun pp-macroexpand-body (body &optional env)
+(mapcar (function (lambda (x) (pp-macroexpand-all x env))) body))
+(defun pp-macroexpand-lets (list &optional env)
+(mapcar (function
+	   (lambda (x)
+	     (if (consp x) (cons (car x) (pp-macroexpand-body (cdr x) env))
+	       x))) list))
+(run-hooks 'pp-load-hook)
+(provide 'pp)
+;; end pp.el

Mercurial > hg > xemacs-beta

comparison lisp/utils/pretty-print.el @ 12:bcdc7deadc19 r19-15b7