home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / utils / pp.el < prev    next >
Encoding:
Text File  |  1995-05-26  |  6.2 KB  |  182 lines
  1. ;;;; pp.el --- pretty printer for Emacs Lisp
  2.  
  3. ;; keywords: lisp, tools, language, extensions
  4.  
  5. ;; Copyright (C) 1989, 1993 Free Software Foundation, Inc.
  6.  
  7. ;; Author: Randal Schwartz <merlyn@ora.com>
  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, 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.
  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 the Free
  23. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Code:
  26.  
  27. (defvar pp-escape-newlines t 
  28.   "*Value of `print-escape-newlines' used by pp-* functions.")
  29. (defvar pp-print-readably t
  30.   "*Value of `print-readably' used by pp-* functions.")
  31.  
  32. ;;;###autoload
  33. (defun pp (object &optional stream)
  34.   "Output the pretty-printed representation of OBJECT, any Lisp object.
  35. Quoting characters are printed when needed to make output that `read'
  36. can handle, whenever this is possible.
  37. Output stream is STREAM, or value of `standard-output' (which see)."
  38.   (princ (pp-to-string object) (or stream standard-output)))
  39.  
  40. ;;;###autoload
  41. (defalias 'pprint 'pp)
  42.  
  43. (defun pp-to-string (object)
  44.   "Return a string containing the pretty-printed representation of OBJECT,
  45. any Lisp object.  Quoting characters are used when needed to make output
  46. that `read' can handle, whenever this is possible."
  47.   (save-excursion
  48.     (set-buffer (generate-new-buffer " pp-to-string"))
  49.     (unwind-protect
  50.     (progn
  51.       (emacs-lisp-mode)
  52.       (let ((print-escape-newlines pp-escape-newlines)
  53.         (print-readably pp-print-readably))
  54.         (prin1 object (current-buffer)))
  55.       (goto-char (point-min))
  56.       (while (not (eobp))
  57.         ;; (message "%06d" (- (point-max) (point)))
  58.         (cond
  59.          ((looking-at "\\s\(")
  60.           (while (looking-at "\\s(")
  61.         (forward-char 1)))
  62.          ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)")
  63.            (> (match-beginning 1) 1)
  64.            (= ?\( (char-after (1- (match-beginning 1))))
  65.            ;; Make sure this is a two-element list.
  66.            (save-excursion
  67.              (goto-char (match-beginning 2))
  68.              (forward-sexp)
  69.              ;; (looking-at "[ \t]*\)")
  70.              ;; Avoid mucking with match-data; does this test work?
  71.              (char-equal ?\) (char-after (point)))))
  72.           ;; -1 gets the paren preceding the quote as well.
  73.           (delete-region (1- (match-beginning 1)) (match-end 1))
  74.           (insert "'")
  75.           (forward-sexp 1)
  76.           (if (looking-at "[ \t]*\)")
  77.           (delete-region (match-beginning 0) (match-end 0))
  78.         (error "Malformed quote"))
  79.           (backward-sexp 1))          
  80.          ((condition-case err-var
  81.           (prog1 t (down-list 1))
  82.         (error nil))
  83.           (backward-char 1)
  84.           (skip-chars-backward " \t")
  85.           (delete-region
  86.            (point)
  87.            (progn (skip-chars-forward " \t") (point)))
  88.           (if (not (char-equal ?' (char-after (1- (point)))))
  89.           (insert ?\n)))
  90.          ((condition-case err-var
  91.           (prog1 t (up-list 1))
  92.         (error nil))
  93.           (while (looking-at "\\s)")
  94.         (forward-char 1))
  95.           (skip-chars-backward " \t")
  96.           (delete-region
  97.            (point)
  98.            (progn (skip-chars-forward " \t") (point)))
  99.           (if (not (char-equal ?' (char-after (1- (point)))))
  100.           (insert ?\n)))
  101.          (t (goto-char (point-max)))))
  102.       (goto-char (point-min))
  103.       (indent-sexp)
  104.       (buffer-string))
  105.       (kill-buffer (current-buffer)))))
  106.  
  107. (defun pp-eval-expression (expression)
  108.   "Evaluate EXPRESSION and pretty-print value into a new display buffer.
  109. If the pretty-printed value fits on one line, the message line is used
  110. instead.  Value is also consed on to front of variable  values 's
  111. value."
  112.   (interactive "xPp-eval: ")
  113.   (setq values (cons (eval expression) values))
  114.   (let* ((old-show-hook
  115.       (or (let ((sym (if (> (string-to-int emacs-version) 18)
  116.                  'temp-buffer-show-function
  117.                'temp-buffer-show-hook)))
  118.         (and (boundp 'sym) (symbol-value sym)))
  119.           'display-buffer))
  120.      (temp-buffer-show-hook
  121.       (function
  122.        (lambda (buf)
  123.          (save-excursion
  124.            (set-buffer buf)
  125.            (goto-char (point-min))
  126.            (end-of-line 1)
  127.            (if (or (< (1+ (point)) (point-max))
  128.                (>= (- (point) (point-min)) (screen-width)))
  129.            (progn
  130.              (goto-char (point-min)) ; expected by some hooks ...
  131.              (funcall old-show-hook buf))
  132.          (message "%s" (buffer-substring (point-min) (point)))
  133.          (delete-windows-on buf) ; no need to kill it
  134.          )))))
  135.      (temp-buffer-show-function temp-buffer-show-hook)) ; emacs19 name
  136.     (with-output-to-temp-buffer "*Pp Eval Output*"
  137.       (pp (car values)))
  138.     (save-excursion
  139.       (set-buffer "*Pp Eval Output*")
  140.       (emacs-lisp-mode))))
  141.  
  142. (defun pp-eval-last-sexp (arg)
  143.   "Run `pp-eval-expression' on sexp before point (which see).
  144. With argument, pretty-print output into current buffer.
  145. Ignores leading comment characters."
  146.   (interactive "P")
  147.   (let ((stab (syntax-table)) (pt (point)) start exp)
  148.     (set-syntax-table emacs-lisp-mode-syntax-table)
  149.     (save-excursion
  150.       (forward-sexp -1)
  151.       ;; If first line is commented, ignore all leading comments:
  152.       (if (save-excursion (beginning-of-line) (looking-at "[ \t]*;"))
  153.       (progn
  154.         (setq exp (buffer-substring (point) pt))
  155.         (while (string-match "\n[ \t]*;+" exp start)
  156.           (setq start (1+ (match-beginning 0))
  157.             exp (concat (substring exp 0 start)
  158.                 (substring exp (match-end 0)))))
  159.         (setq exp (read exp)))
  160.     (setq exp (read (current-buffer)))))
  161.     (set-syntax-table stab)
  162.     (if arg
  163.     (insert (pp-to-string (eval exp)))
  164.       (pp-eval-expression exp))))
  165.  
  166. ;;; Test cases for quote
  167. ;; (pp-eval-expression ''(quote quote))
  168. ;; (pp-eval-expression ''((quote a) (quote b)))
  169. ;; (pp-eval-expression ''('a 'b))    ; same as above
  170. ;; (pp-eval-expression ''((quote (quote quote)) (quote quote)))
  171. ;; These do not satisfy the quote test.
  172. ;; (pp-eval-expression ''quote)
  173. ;; (pp-eval-expression ''(quote))
  174. ;; (pp-eval-expression ''(quote . quote))
  175. ;; (pp-eval-expression ''(quote a b))
  176. ;; (pp-eval-expression ''(quotefoo))
  177. ;; (pp-eval-expression ''(a b))
  178.  
  179. (provide 'pp)                ; so (require 'pp) works
  180.  
  181. ;;; pp.el ends here.
  182.