mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-28 10:56:36 +00:00
Code Issues Releases Activity

Initial revision

Browse Source
This commit is contained in:
Richard M. Stallman 1994-09-14 09:03:27 +00:00
parent 7908d27ce0
commit 20f5d14570
2 changed files with 1266 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

493
lisp/emacs-lisp/elp.el Normal file
View File

@ -0,0 +1,493 @@
;;; elp.el --- Emacs Lisp Profiler
;; Author: 1994 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com>
;; Maintainer: bwarsaw@cen.com
;; Created: 26-Feb-1994
;; Version: 2.11
;; Last Modified: 1994/06/06 22:38:07
;; Keywords: Emacs Lisp Profile Timing
;; Copyright (C) 1994 Barry A. Warsaw
;; This file is not yet part of GNU Emacs.
;;
;; This program 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 of the License, or
;; (at your option) any later version.
;;
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;; LCD Archive Entry:
;; elp|Barry A. Warsaw|tools-help@anthem.nlm.nih.gov|
;; Emacs Lisp Profiler|
;; 1994/06/06 22:38:07|2.11|~/misc/elp.el.Z|
;;; Commentary:
;;
;; This program is based on the only two existing Emacs Lisp profilers
;; that I'm aware of, Boaz Ben-Zvi's profile.el, and Root Boy Jim's
;; profiler.el. Both were written for Emacs 18 and both were pretty
;; good first shots at profiling, but I found that they didn't provide
;; the functionality or interface that I wanted. So I wrote this.
;; I've tested elp in Lucid Emacs 19.9 and in Emacs 19.22. There's no
;; point in even trying to make this work with Emacs 18.
;; Unlike previous profilers, elp uses Emacs 19's built-in function
;; current-time to return interval times. This obviates the need for
;; both an external C program and Emacs processes to communicate with
;; such a program, and thus simplifies the package as a whole. One
;; small shortcut: I throw away the most significant 16 bits of
;; seconds returned by current-time since I doubt anyone will ever
;; want to profile stuff on the order of 18 hours. 2^16 == 65536
;; seconds == ~1092 minutes == ~18 hours.
;; Note that there are plenty of factors that could make the times
;; reported unreliable, including the accuracy and granularity of your
;; system clock, and the overhead spent in lisp calculating and
;; recording the intervals. The latter I figure is pretty constant
;; so, while the times may not be entirely accurate, I think they'll
;; give you a good feel for the relative amount of work spent in the
;; various lisp routines you are profiling. Note further that times
;; are calculated using wall-clock time, so other system load will
;; affect accuracy too.
;; There are only 3 variables you can change to customize behavior of
;; elp. See below for their description.
;;
;; Here is a list of the interactive commands you can use:
;; elp-instrument-function
;; elp-restore-function
;; elp-instrument-list
;; elp-restore-list
;; elp-restore-all
;; elp-reset-function
;; elp-reset-list
;; elp-reset-all
;; elp-results
;; elp-submit-bug-report
;;
;; Here are some brief usage notes. If you want to profile a bunch of
;; functions, set elp-function-list to the list of symbols, then call
;; elp-instrument-list. This hacks the functions so that profiling
;; information is recorded whenever they are called. To print out the
;; current results, use elp-results. With elp-reset-after-results set
;; to non-nil, profiling information will be reset whenever the
;; results are displayed, but you can reset all profiling info with
;; elp-reset-all.
;;
;; If you want to sort the results, set elp-sort-by-function to some
;; predicate function. The three most obvious choices are predefined:
;; elp-sort-by-call-count, elp-sort-by-average-time, and
;; elp-sort-by-total-time.
;;
;; Elp can instrument byte-compiled functions just as easily as
;; interpreted functions. However, when you redefine a function (e.g.
;; with eval-defun), you'll need to re-instrument it with
;; elp-instrument-function. Re-instrumenting resets profiling
;; information for that function. Elp can also handle interactive
;; functions (i.e. commands), but of course any time spent idling for
;; user prompts will show up in the timing results.
;;
;; You can also designate a `master' function. Profiling times will
;; be gathered for instrumented functions only during execution of
;; this master function. Thus, if you have some defuns like:
;;
;; (defun foo () (do-something-time-intensive))
;; (defun bar () (foo))
;; (defun baz () (bar) (foo))
;;
;; and you want to find out the amount of time spent in bar and foo,
;; but only during execution of bar, make bar the master and the call
;; of foo from baz will not add to foo's total timing sums. Use
;; elp-set-master and elp-unset-master to utilize this feature. Only
;; one master function can be used at a time.
;; You can restore any function's original function definition with
;; elp-restore-function. The other instrument, restore, and reset
;; functions are provided for symmetry.
;;; Code:
;; start user configuration variables
;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
(defvar elp-function-list nil
"*List of function to profile.")
(defvar elp-reset-after-results t
"*Non-nil means reset all profiling info after results are displayed.
Results are displayed with the `elp-results' command.")
(defvar elp-sort-by-function nil
"*Non-nil specifies elp results sorting function.
These functions are currently available:
elp-sort-by-call-count -- sort by the highest call count
elp-sort-by-total-time -- sort by the highest total time
elp-sort-by-average-time -- sort by the highest average times
You can write you're own sort function. It should adhere to the
interface specified by the PRED argument for the `sort' defun. Each
\"element of LIST\" is really a 4 element vector where element 0 is
the call count, element 1 is the total time spent in the function,
element 2 is the average time spent in the function, and element 3 is
the symbol's name string.")
;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
;; end user configuration variables
(defconst elp-version "2.11"
"ELP version number.")
(defconst elp-help-address "tools-help@anthem.nlm.nih.gov"
"Address accepting submissions of bug reports and questions.")
(defvar elp-results-buffer "*ELP Profiling Results*"
"Buffer name for outputting profiling results.")
(defconst elp-timer-info-property 'elp-info
"ELP information property name.")
(defvar elp-all-instrumented-list nil
"List of all functions currently being instrumented.")
(defvar elp-record-p t
"Controls whether functions should record times or not.
This variable is set by the master function.")
(defvar elp-master nil
"Master function symbol.")
(defun elp-instrument-function (funsym)
"Instrument FUNSYM for profiling.
FUNSYM must be a symbol of a defined function."
(interactive "aFunction to instrument: ")
;; TBD what should we do if the function is already instrumented???
(let* ((funguts (symbol-function funsym))
(infovec (vector 0 0 funguts))
(newguts '(lambda (&rest args))))
;; put rest of newguts together
(if (commandp funsym)
(setq newguts (append newguts '((interactive)))))
(setq newguts (append newguts (list
(list 'elp-wrapper
(list 'quote funsym)
(list 'and
'(interactive-p)
(not (not (commandp funsym))))
'args))))
;; to record profiling times, we set the symbol's function
;; definition so that it runs the elp-wrapper function with the
;; function symbol as an argument. We place the old function
;; definition on the info vector.
;;
;; The info vector data structure is a 3 element vector. The 0th
;; element is the call-count, i.e. the total number of times this
;; function has been entered. This value is bumped up on entry to
;; the function so that non-local exists are still recorded. TBD:
;; I haven't tested non-local exits at all, so no guarantees.
;;
;; The 1st element is the total amount of time in usecs that have
;; been spent inside this function. This number is added to on
;; function exit.
;;
;; The 2nd element is the old function definition list. This gets
;; funcall'd in between start/end time retrievals. I believe that
;; this lets us profile even byte-compiled functions.
;; put the info vector on the property list
(put funsym elp-timer-info-property infovec)
;; set the symbol's new profiling function definition to run
;; elp-wrapper
(fset funsym newguts)
;; add this function to the instrumentation list
(or (memq funsym elp-all-instrumented-list)
(setq elp-all-instrumented-list
(cons funsym elp-all-instrumented-list)))
))
(defun elp-restore-function (funsym)
"Restore an instrumented function to its original definition.
Argument FUNSYM is the symbol of a defined function."
(interactive "aFunction to restore: ")
(let ((info (get funsym elp-timer-info-property)))
;; delete the function from the all instrumented list
(setq elp-all-instrumented-list
(delq funsym elp-all-instrumented-list))
;; if the function was the master, reset the master
(if (eq funsym elp-master)
(setq elp-master nil
elp-record-p t))
;; zap the properties
(put funsym elp-timer-info-property nil)
;; restore the original function definition, but if the function
;; wasn't instrumented do nothing. we do this after the above
;; because its possible the function got un-instrumented due to
;; circumstances beyond our control. Also, check to make sure
;; that the current function symbol points to elp-wrapper. If
;; not, then the user probably did an eval-defun while the
;; function was instrumented and we don't want to destroy the new
;; definition.
(and info
(assq 'elp-wrapper (symbol-function funsym))
(fset funsym (aref info 2)))))
(defun elp-instrument-list (&optional list)
"Instrument for profiling, all functions in `elp-function-list'.
Use optional LIST if provided instead."
(interactive "PList of functions to instrument: ")
(let ((list (or list elp-function-list)))
(mapcar 'elp-instrument-function list)))
(defun elp-restore-list (&optional list)
"Restore the original definitions for all functions in `elp-function-list'.
Use optional LIST if provided instead."
(interactive "PList of functions to restore: ")
(let ((list (or list elp-function-list)))
(mapcar 'elp-restore-function list)))
(defun elp-restore-all ()
"Restores the original definitions of all functions being profiled."
(interactive)
(elp-restore-list elp-all-instrumented-list))
(defun elp-reset-function (funsym)
"Reset the profiling information for FUNSYM."
(interactive "aFunction to reset: ")
(let ((info (get funsym elp-timer-info-property)))
(or info
(error "%s is not instrumented for profiling." funsym))
(aset info 0 0) ;reset call counter
(aset info 1 0.0) ;reset total time
;; don't muck with aref 2 as that is the old symbol definition
))
(defun elp-reset-list (&optional list)
"Reset the profiling information for all functions in `elp-function-list'.
Use optional LIST if provided instead."
(interactive "PList of functions to reset: ")
(let ((list (or list elp-function-list)))
(mapcar 'elp-reset-function list)))
(defun elp-reset-all ()
"Reset the profiling information for all functions being profiled."
(interactive)
(elp-reset-list elp-all-instrumented-list))
(defun elp-set-master (funsym)
"Set the master function for profiling."
(interactive "aMaster function: ")
;; when there's a master function, recording is turned off by
;; default
(setq elp-master funsym
elp-record-p nil)
;; make sure master function is instrumented
(or (memq funsym elp-all-instrumented-list)
(elp-instrument-function funsym)))
(defun elp-unset-master ()
"Unsets the master function."
;; when there's no master function, recording is turned on by default.
(setq elp-master nil
elp-record-p t))
(defsubst elp-get-time ()
;; get current time in seconds and microseconds. I throw away the
;; most significant 16 bits of seconds since I doubt we'll ever want
;; to profile lisp on the order of 18 hours. See notes at top of file.
(let ((now (current-time)))
(+ (float (nth 1 now)) (/ (float (nth 2 now)) 1000000.0))))
(defun elp-wrapper (funsym interactive-p args)
"This function has been instrumented for profiling by the ELP.
ELP is the Emacs Lisp Profiler. To restore the function to its
original definition, use \\[elp-restore-function] or \\[elp-restore-all]."
;; turn on recording if this is the master function
(if (and elp-master
(eq funsym elp-master))
(setq elp-record-p t))
;; get info vector and original function symbol
(let* ((info (get funsym elp-timer-info-property))
(func (aref info 2))
result)
(or func
(error "%s is not instrumented for profiling." funsym))
(if (not elp-record-p)
;; when not recording, just call the original function symbol
;; and return the results.
(setq result
(if interactive-p
(call-interactively func)
(apply func args)))
;; we are recording times
(let ((enter-time (elp-get-time)))
;; increment the call-counter
(aset info 0 (1+ (aref info 0)))
;; now call the old symbol function, checking to see if it
;; should be called interactively. make sure we return the
;; correct value
(setq result
(if interactive-p
(call-interactively func)
(apply func args)))
;; calculate total time in function
(aset info 1 (+ (aref info 1) (- (elp-get-time) enter-time)))
))
;; turn off recording if this is the master function
(if (and elp-master
(eq funsym elp-master))
(setq elp-record-p nil))
result))
;; shut the byte-compiler up
(defvar elp-field-len nil)
(defvar elp-cc-len nil)
(defvar elp-at-len nil)
(defvar elp-et-len nil)
(defun elp-sort-by-call-count (vec1 vec2)
;; sort by highest call count. See `sort'.
(>= (aref vec1 0) (aref vec2 0)))
(defun elp-sort-by-total-time (vec1 vec2)
;; sort by highest total time spent in function. See `sort'.
(>= (aref vec1 1) (aref vec2 1)))
(defun elp-sort-by-average-time (vec1 vec2)
;; sort by highest average time spent in function. See `sort'.
(>= (aref vec1 2) (aref vec2 2)))
(defun elp-output-result (resultvec)
;; output the RESULTVEC into the results buffer. RESULTVEC is a 4 or
;; more element vector where aref 0 is the call count, aref 1 is the
;; total time spent in the function, aref 2 is the average time
;; spent in the function, and aref 3 is the symbol's string
;; name. All other elements in the vector are ignored.
(let* ((cc (aref resultvec 0))
(tt (aref resultvec 1))
(at (aref resultvec 2))
(symname (aref resultvec 3))
callcnt totaltime avetime)
(insert symname)
(insert-char 32 (+ elp-field-len (- (length symname)) 2))
(setq callcnt (number-to-string cc)
totaltime (number-to-string tt)
avetime (number-to-string at))
;; print stuff out, formatting it nicely
(insert callcnt)
(insert-char 32 (+ elp-cc-len (- (length callcnt)) 2))
(if (> (length totaltime) elp-et-len)
(insert (substring totaltime 0 elp-et-len) " ")
(insert totaltime)
(insert-char 32 (+ elp-et-len (- (length totaltime)) 2)))
(if (> (length avetime) elp-at-len)
(insert (substring avetime 0 elp-at-len))
(insert avetime))
(insert "\n")))
(defun elp-results ()
"Display current profiling results.
If `elp-reset-after-results' is non-nil, then current profiling
information for all instrumented functions are reset after results are
displayed."
(interactive)
(let ((curbuf (current-buffer))
(resultsbuf (get-buffer-create elp-results-buffer)))
(set-buffer resultsbuf)
(erase-buffer)
(beginning-of-buffer)
;; get the length of the longest function name being profiled
(let* ((longest 0)
(title "Function Name")
(titlelen (length title))
(elp-field-len titlelen)
(cc-header "Call Count")
(elp-cc-len (length cc-header))
(et-header "Elapsed Time")
(elp-et-len (length et-header))
(at-header "Average Time")
(elp-at-len (length at-header))
(resvec
(mapcar
(function
(lambda (funsym)
(let* ((info (get funsym elp-timer-info-property))
(symname (format "%s" funsym))
(cc (aref info 0))
(tt (aref info 1)))
(if (not info)
(insert "No profiling information found for: "
symname)
(setq longest (max longest (length symname)))
(vector cc tt (if (zerop cc)
0.0 ;avoid arithmetic div-by-zero errors
(/ (float tt) (float cc)))
symname)))))
elp-all-instrumented-list))
) ; end let*
(insert title)
(if (> longest titlelen)
(progn
(insert-char 32 (- longest titlelen))
(setq elp-field-len longest)))
(insert " " cc-header " " et-header " " at-header "\n")
(insert-char ?= elp-field-len)
(insert " ")
(insert-char ?= elp-cc-len)
(insert " ")
(insert-char ?= elp-et-len)
(insert " ")
(insert-char ?= elp-at-len)
(insert "\n")
;; if sorting is enabled, then sort the results list. in either
;; case, call elp-output-result to output the result in the
;; buffer
(if elp-sort-by-function
(setq resvec (sort resvec elp-sort-by-function)))
(mapcar 'elp-output-result resvec))
;; now pop up results buffer
(set-buffer curbuf)
(pop-to-buffer resultsbuf)
;; reset profiling info if desired
(and elp-reset-after-results
(elp-reset-all))))
(eval-when-compile
(require 'reporter))
(defun elp-submit-bug-report ()
"Submit via mail, a bug report on elp."
(interactive)
(and
(y-or-n-p "Do you want to submit a report on elp? ")
(require 'reporter)
(reporter-submit-bug-report
elp-help-address (concat "elp " elp-version)
'(elp-reset-after-results
elp-sort-by-function))))
(provide 'elp)
;; elp.el ends here

773
lisp/progmodes/cpp.el Normal file
View File

@ -0,0 +1,773 @@
;;; cpp.el --- Highlight or hide text according to cpp conditionals.
;; Copyright (C) 1994 Free Software Foundation
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Version: $Id: 0.2 ALPHA RELEASE WITH BUGS $
;; Keywords: c, faces, tools
;; LCD Archive Entry:
;; cpp|Per Abrahamsen|abraham@iesd.auc.dk|
;; Highlight or hide text according to cpp conditionals|
;; $Date: 1994-07-20 $|$Revision: 0.2 $|~/misc/cpp.Z|
;; This program 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.
;;
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Comments:
;; Parse a text for C preprocessor conditionals, and highlight or hide
;; the text inside the conditionals as you wish.
;; Insert the following in your `emacs' to activate it. This assumes
;; you use BAW's superior cc-mode instead of Boring Old C-Mode.
;; (autoload 'cpp-parse-buffer "cpp" "Parse and display cpp conditionals." t)
;; (eval-after-load "cc-mode"
;; '(progn
;; (define-key c-mode-map "\C-c\C-x" 'cpp-parse-buffer)
;; (define-key-after (bar (lookup-key c-mode-map [ menu-bar c ]))
;; [ cpp-parse ] '("Parse Conditionals" . cpp-parse-buffer) 'up))))
;; Requires GNU Emacs 19.
;;; Todo:
;; Should parse "#if" and "#elif" expressions and merge the faces
;; somehow.
;; Somehow it is sometimes possible to make changes near a read only
;; area which you can't undo. Their are other strange effects in that
;; area.
;; The Edit buffer should -- optionally -- appear in its own frame.
;; Conditionals seem to be rear-sticky. They shouldn't be.
;; Restore window configurations when exiting CPP Edit buffer.
;;; Code:
;;; Customization:
(defvar cpp-known-face 'invisible
"*Face used for known cpp symbols.")
(defvar cpp-unknown-face 'highlight
"*Face used for unknown cpp cymbols.")
(defvar cpp-face-type 'light
"*Indicate what background face type you prefer.
Can be either light or dark for color screens, mono for monochrome
screens, and none if you don't use a window system.")
(defvar cpp-known-writable t
"*Non-nil means you are allowed to modify the known conditionals.")
(defvar cpp-unknown-writable t
"*Non-nil means you are allowed to modify the unknown conditionals.")
;;; Parse Buffer:
(defvar cpp-parse-symbols nil
"List of cpp macros used in the local buffer.")
(make-variable-buffer-local 'cpp-parse-symbols)
(defconst cpp-parse-regexp
;; Regexp matching all tokens needed to find conditionals.
(concat
"'\\|\"\\|/\\*\\|//\\|"
"\\(^[ \t]*#[ \t]*\\(ifdef\\|ifndef\\|if\\|"
"elif\\|else\\|endif\\)\\b\\)"))
;;;###autoload
(defun cpp-parse-buffer (arg)
"Parse all conditionals in the current buffer end edit symbols.
A prefix arg supress editing the symbols."
(interactive "P")
(setq cpp-parse-symbols nil)
(cpp-parse-reset)
(if (null cpp-edit-list)
(cpp-edit-load))
(let (stack)
(save-excursion
(goto-char (point-min))
(cpp-progress-message "Parsing...")
(while (re-search-forward cpp-parse-regexp nil t)
(cpp-progress-message "Parsing...%d%%"
(/ (* 100 (- (point) (point-min))) (buffer-size)))
(let ((match (buffer-substring (match-beginning 0) (match-end 0))))
(cond ((or (string-equal match "'")
(string-equal match "\""))
(goto-char (match-beginning 0))
(condition-case nil
(forward-sexp)
(error (cpp-parse-error
"Unterminated string or character"))))
((string-equal match "/*")
(or (search-forward "*/" nil t)
(error "Unterminated comment")))
((string-equal match "//")
(skip-chars-forward "^\n\r"))
(t
(end-of-line 1)
(let ((from (match-beginning 1))
(to (1+ (point)))
(type (buffer-substring (match-beginning 2)
(match-end 2)))
(expr (buffer-substring (match-end 1) (point))))
(cond ((string-equal type "ifdef")
(cpp-parse-open t expr from to))
((string-equal type "ifndef")
(cpp-parse-open nil expr from to))
((string-equal type "if")
(cpp-parse-open t expr from to))
((string-equal type "elif")
(let (cpp-known-face cpp-unknown-face)
(cpp-parse-close from to))
(cpp-parse-open t expr from to))
((string-equal type "else")
(or stack (cpp-parse-error "Top level #else"))
(let ((entry (list (not (nth 0 (car stack)))
(nth 1 (car stack))
from to)))
(cpp-parse-close from to)
(setq stack (cons entry stack))))
((string-equal type "endif")
(cpp-parse-close from to))
(t
(cpp-parse-error "Parser error"))))))))
(message "Parsing...done"))
(if stack
(save-excursion
(goto-char (nth 3 (car stack)))
(cpp-parse-error "Unclosed conditional"))))
(or arg
(null cpp-parse-symbols)
(cpp-parse-edit)))
(defun cpp-parse-open (branch expr begin end)
;; Push information about conditional to stack.
(while (string-match "\\b[ \t]*/\\*.*\\*/[ \t]*\\b" expr)
(setq expr (concat (substring expr 0 (match-beginning 0))
(substring expr (match-end 0)))))
(if (string-match "\\b[ \t]*\\(//.*\\)?$" expr)
(setq expr (substring expr 0 (match-beginning 0))))
(while (string-match "[ \t]+" expr)
(setq expr (concat (substring expr 0 (match-beginning 0))
(substring expr (match-end 0)))))
(setq stack (cons (list branch expr begin end) stack))
(or (member expr cpp-parse-symbols)
(setq cpp-parse-symbols
(cons expr cpp-parse-symbols)))
(if (assoc expr cpp-edit-list)
(cpp-make-known-overlay begin end)
(cpp-make-unknown-overlay begin end)))
(defun cpp-parse-close (from to)
;; Pop top of stack and create overlay.
(let ((entry (assoc (nth 1 (car stack)) cpp-edit-list))
(branch (nth 0 (car stack)))
(begin (nth 2 (car stack)))
(end (nth 3 (car stack))))
(setq stack (cdr stack))
(if entry
(let ((face (nth (if branch 1 2) entry))
(read-only (eq (not branch) (nth 3 entry)))
(priority (length stack))
(overlay (make-overlay end from)))
(cpp-make-known-overlay from to)
(setq cpp-overlay-list (cons overlay cpp-overlay-list))
(if priority (overlay-put overlay 'priority priority))
(cond ((eq face 'invisible)
(cpp-make-overlay-hidden overlay))
((eq face 'default))
(t
(overlay-put overlay 'face face)))
(if read-only
(cpp-make-overlay-read-only overlay)
(cpp-make-overlay-sticky overlay)))
(cpp-make-unknown-overlay from to))))
(defun cpp-parse-error (error)
;; Error message issued by the cpp parser.
(error (concat error " at line %d") (count-lines (point-min) (point))))
(defun cpp-parse-reset ()
"Reset display of cpp conditionals to normal."
(interactive)
(while cpp-overlay-list
(delete-overlay (car cpp-overlay-list))
(setq cpp-overlay-list (cdr cpp-overlay-list))))
;;;###autoload
(defun cpp-parse-edit ()
"Edit display information for cpp conditionals."
(interactive)
(or cpp-parse-symbols
(cpp-parse-buffer t))
(let ((buffer (current-buffer)))
(pop-to-buffer "*CPP Edit*")
(cpp-edit-mode)
(setq cpp-edit-buffer buffer)
(cpp-edit-reset)))
;;; Overlays:
(defvar cpp-overlay-list nil)
;; List of cpp overlays active in the current buffer.
(make-variable-buffer-local 'cpp-overlay-list)
(defun cpp-make-known-overlay (start end)
;; Create an overlay for a known cpp command from START to END.
(let ((overlay (make-overlay start end)))
(if (eq cpp-known-face 'invisible)
(cpp-make-overlay-hidden overlay)
(or (eq cpp-known-face 'default)
(overlay-put overlay 'face cpp-known-face))
(if cpp-known-writable
()
(overlay-put overlay 'modification-hooks '(cpp-signal-read-only))
(overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only))))
(setq cpp-overlay-list (cons overlay cpp-overlay-list))))
(defun cpp-make-unknown-overlay (start end)
;; Create an overlay for an unknown cpp command from START to END.
(let ((overlay (make-overlay start end)))
(cond ((eq cpp-unknown-face 'invisible)
(cpp-make-overlay-hidden overlay))
((eq cpp-unknown-face 'default))
(t
(overlay-put overlay 'face cpp-unknown-face)))
(if cpp-unknown-writable
()
(overlay-put overlay 'modification-hooks '(cpp-signal-read-only))
(overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only)))
(setq cpp-overlay-list (cons overlay cpp-overlay-list))))
(defun cpp-make-overlay-hidden (overlay)
;; Make overlay hidden and intangible.
(overlay-put overlay 'invisible t)
(overlay-put overlay 'intangible t)
;; Unfortunately `intangible' is not implemented for overlays yet,
;; so we make is read-only instead.
(overlay-put overlay 'modification-hooks '(cpp-signal-read-only)))
(defun cpp-make-overlay-read-only (overlay)
;; Make overlay read only.
(overlay-put overlay 'modification-hooks '(cpp-signal-read-only))
(overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only))
(overlay-put overlay 'insert-behind-hooks '(cpp-signal-read-only)))
(defun cpp-make-overlay-sticky (overlay)
;; Make OVERLAY grow when you insert text at either end.
(overlay-put overlay 'insert-in-front-hooks '(cpp-grow-overlay))
(overlay-put overlay 'insert-behind-hooks '(cpp-grow-overlay)))
(defun cpp-signal-read-only (overlay start end)
;; Only allow deleting the whole overlay.
;; Trying to change a read-only overlay.
(if (or (< (overlay-start overlay) start)
(> (overlay-end overlay) end))
(error "This text is read only")))
(defun cpp-grow-overlay (overlay start end)
;; Make OVERLAY grow to contain range START to END.
(move-overlay overlay
(min start (overlay-start overlay))
(max end (overlay-end overlay))))
;;; Edit Buffer:
(defvar cpp-edit-list nil
"Alist of cpp macros and information about how they should be displayed.
Each entry is a list with the following elements:
0. The name of the macro (a string).
1. Face used for text that is `ifdef' the macro.
2. Face used for text that is `ifndef' the macro.
3. `t', `nil', or `both' depending on what text may be edited.")
(defvar cpp-edit-map nil)
;; Keymap for `cpp-edit-mode'.
(if cpp-edit-map
()
(setq cpp-edit-map (make-keymap))
(suppress-keymap cpp-edit-map)
(define-key cpp-edit-map [ down-mouse-2 ] 'cpp-push-button)
(define-key cpp-edit-map [ mouse-2 ] 'ignore)
(define-key cpp-edit-map " " 'scroll-up)
(define-key cpp-edit-map "\C-?" 'scroll-down)
(define-key cpp-edit-map [ delete ] 'scroll-down)
(define-key cpp-edit-map "\C-c\C-c" 'cpp-edit-apply)
(define-key cpp-edit-map "a" 'cpp-edit-apply)
(define-key cpp-edit-map "A" 'cpp-edit-apply)
(define-key cpp-edit-map "r" 'cpp-edit-reset)
(define-key cpp-edit-map "R" 'cpp-edit-reset)
(define-key cpp-edit-map "s" 'cpp-edit-save)
(define-key cpp-edit-map "S" 'cpp-edit-save)
(define-key cpp-edit-map "l" 'cpp-edit-load)
(define-key cpp-edit-map "L" 'cpp-edit-load)
(define-key cpp-edit-map "h" 'cpp-edit-home)
(define-key cpp-edit-map "H" 'cpp-edit-home)
(define-key cpp-edit-map "b" 'cpp-edit-background)
(define-key cpp-edit-map "B" 'cpp-edit-background)
(define-key cpp-edit-map "k" 'cpp-edit-known)
(define-key cpp-edit-map "K" 'cpp-edit-known)
(define-key cpp-edit-map "u" 'cpp-edit-unknown)
(define-key cpp-edit-map "u" 'cpp-edit-unknown)
(define-key cpp-edit-map "t" 'cpp-edit-true)
(define-key cpp-edit-map "T" 'cpp-edit-true)
(define-key cpp-edit-map "f" 'cpp-edit-false)
(define-key cpp-edit-map "F" 'cpp-edit-false)
(define-key cpp-edit-map "w" 'cpp-edit-write)
(define-key cpp-edit-map "W" 'cpp-edit-write)
(define-key cpp-edit-map "X" 'cpp-edit-toggle-known)
(define-key cpp-edit-map "x" 'cpp-edit-toggle-known)
(define-key cpp-edit-map "Y" 'cpp-edit-toggle-unknown)
(define-key cpp-edit-map "y" 'cpp-edit-toggle-unknown)
(define-key cpp-edit-map "q" 'bury-buffer)
(define-key cpp-edit-map "Q" 'bury-buffer))
(defvar cpp-edit-buffer nil)
;; Real buffer whose cpp display information we are editing.
(make-variable-buffer-local 'cpp-edit-buffer)
(defvar cpp-edit-symbols nil)
;; Symbols defined in the edit buffer.
(make-variable-buffer-local 'cpp-edit-symbols)
(defun cpp-edit-mode ()
"Major mode for editing cpp display information.
Click on objects to change them.
You can also use the keyboard accelerators indicated like this: [K]ey."
(kill-all-local-variables)
(buffer-disable-undo)
(auto-save-mode -1)
(setq buffer-read-only t)
(setq major-mode 'cpp-edit-mode)
(setq mode-name "CPP Edit")
(use-local-map cpp-edit-map))
(defun cpp-edit-apply ()
"Apply edited display information to original buffer."
(interactive)
(cpp-edit-home)
(cpp-parse-buffer t))
(defun cpp-edit-reset ()
"Reset display information from original buffer."
(interactive)
(let ((buffer (current-buffer))
(buffer-read-only nil)
(start (window-start))
(pos (point))
symbols)
(set-buffer cpp-edit-buffer)
(setq symbols cpp-parse-symbols)
(set-buffer buffer)
(setq cpp-edit-symbols symbols)
(erase-buffer)
(insert "CPP Display Information for `")
(cpp-make-button (buffer-name cpp-edit-buffer) 'cpp-edit-home)
(insert "' ")
(cpp-make-button "[H]ome" 'cpp-edit-home)
(insert " ")
(cpp-make-button "[A]pply" 'cpp-edit-apply)
(insert " ")
(cpp-make-button "[S]ave" 'cpp-edit-save)
(insert " ")
(cpp-make-button "[L]oad" 'cpp-edit-load)
(insert "\n\nClick mouse-2 on item you want to change or use\n"
"keyboard equivalent indicated with brackets like [T]his.\n\n")
(insert "[B]ackground: ")
(cpp-make-button (car (rassq cpp-face-type cpp-face-type-list))
'cpp-edit-background)
(insert "\n[K]nown conditionals: ")
(cpp-make-button (cpp-face-name cpp-known-face)
'cpp-edit-known nil t)
(insert " [X] ")
(cpp-make-button (car (rassq cpp-known-writable cpp-writable-list))
'cpp-edit-toggle-known)
(insert "\n[U]nknown conditionals: ")
(cpp-make-button (cpp-face-name cpp-unknown-face)
'cpp-edit-unknown nil t)
(insert " [Y] ")
(cpp-make-button (car (rassq cpp-unknown-writable cpp-writable-list))
'cpp-edit-toggle-unknown)
(insert (format "\n\n\n%39s: %14s %14s %7s\n\n" "Expression"
"[T]rue Face" "[F]alse Face" "[W]rite"))
(while symbols
(let* ((symbol (car symbols))
(entry (assoc symbol cpp-edit-list))
(true (nth 1 entry))
(false (nth 2 entry))
(write (if entry (nth 3 entry) 'both)))
(setq symbols (cdr symbols))
(if (and entry ; Make default entries unknown.
(or (null true) (eq true 'default))
(or (null false) (eq false 'default))
(eq write 'both))
(setq cpp-edit-list (delq entry cpp-edit-list)
entry nil))
(if (> (length symbol) 29)
(insert (substring symbol 0 39) ": ")
(insert (format "%39s: " symbol)))
(cpp-make-button (cpp-face-name true)
'cpp-edit-true symbol t 14)
(insert " ")
(cpp-make-button (cpp-face-name false)
'cpp-edit-false symbol t 14)
(insert " ")
(cpp-make-button (car (rassq write cpp-branch-list))
'cpp-edit-write symbol nil 6)
(insert "\n")))
(insert "\n\n")
(set-window-start nil start)
(goto-char pos)))
(defun cpp-edit-load ()
"Load cpp configuration."
(interactive)
(cond ((file-readable-p ".cpp.el")
(load-file ".cpp.el"))
((file-readable-p "~/.cpp.el")
(load-file ".cpp.el")))
(cpp-edit-reset))
(defun cpp-edit-save ()
"Load cpp configuration."
(interactive)
(require 'pp)
(save-excursion
(set-buffer cpp-edit-buffer)
(let ((buffer (find-file-noselect ".cpp.el")))
(set-buffer buffer)
(erase-buffer)
(pp (list 'setq 'cpp-known-face
(list 'quote cpp-known-face)) buffer)
(pp (list 'setq 'cpp-unknown-face
(list 'quote cpp-unknown-face)) buffer)
(pp (list 'setq 'cpp-face-type
(list 'quote cpp-face-type)) buffer)
(pp (list 'setq 'cpp-known-writable
(list 'quote cpp-known-writable)) buffer)
(pp (list 'setq 'cpp-unknown-writable
(list 'quote cpp-unknown-writable)) buffer)
(pp (list 'setq 'cpp-edit-list
(list 'quote cpp-edit-list)) buffer)
(write-file ".cpp.el"))))
(defun cpp-edit-home ()
"Switch back to original buffer."
(interactive)
(if cpp-button-event
(read-event))
(pop-to-buffer cpp-edit-buffer))
(defun cpp-edit-background ()
"Change default face collection."
(interactive)
(call-interactively 'cpp-choose-default-face)
(cpp-edit-reset))
(defun cpp-edit-known ()
"Select default for known conditionals."
(interactive)
(setq cpp-known-face (cpp-choose-face "Known face" cpp-known-face))
(cpp-edit-reset))
(defun cpp-edit-unknown ()
"Select default for unknown conditionals."
(interactive)
(setq cpp-unknown-face (cpp-choose-face "Unknown face" cpp-unknown-face))
(cpp-edit-reset))
(defconst cpp-writable-list
;; Names used for the writable property.
'(("writable" . t)
("read-only" . nil)))
(defun cpp-edit-toggle-known (arg)
"Toggle writable status for known conditionals.
With optional argument ARG, make them writable iff ARG is positive."
(interactive "@P")
(if (or (and (null arg) cpp-known-writable)
(<= (prefix-numeric-value arg) 0))
(setq cpp-known-writable nil)
(setq cpp-known-writable t))
(cpp-edit-reset))
(defun cpp-edit-toggle-unknown (arg)
"Toggle writable status for unknown conditionals.
With optional argument ARG, make them writable iff ARG is positive."
(interactive "@P")
(if (or (and (null arg) cpp-unknown-writable)
(<= (prefix-numeric-value arg) 0))
(setq cpp-unknown-writable nil)
(setq cpp-unknown-writable t))
(cpp-edit-reset))
(defun cpp-edit-true (symbol face)
"Select SYMBOL's true FACE used for highlighting taken conditionals."
(interactive
(let ((symbol (cpp-choose-symbol)))
(list symbol
(cpp-choose-face "True face"
(nth 1 (assoc symbol cpp-edit-list))))))
(setcar (nthcdr 1 (cpp-edit-list-entry-get-or-create symbol)) face)
(cpp-edit-reset))
(defun cpp-edit-false (symbol face)
"Select SYMBOL's false FACE used for highlighting untaken conditionals."
(interactive
(let ((symbol (cpp-choose-symbol)))
(list symbol
(cpp-choose-face "False face"
(nth 2 (assoc symbol cpp-edit-list))))))
(setcar (nthcdr 2 (cpp-edit-list-entry-get-or-create symbol)) face)
(cpp-edit-reset))
(defun cpp-edit-write (symbol branch)
"Set which branches of SYMBOL should be writable to BRANCH.
BRANCH should be either nil (false branch), t (true branch) or 'both."
(interactive (list (cpp-choose-symbol) (cpp-choose-branch)))
(setcar (nthcdr 3 (cpp-edit-list-entry-get-or-create symbol)) branch)
(cpp-edit-reset))
(defun cpp-edit-list-entry-get-or-create (symbol)
;; Return the entry for SYMBOL in `cpp-edit-list'.
;; If it does not exist, create it.
(let ((entry (assoc symbol cpp-edit-list)))
(or entry
(setq entry (list symbol nil nil 'both nil)
cpp-edit-list (cons entry cpp-edit-list)))
entry))
;;; Prompts:
(defun cpp-choose-symbol ()
;; Choose a symbol if called from keyboard, otherwise use the one clicked on.
(if cpp-button-event
data
(completing-read "Symbol: " (mapcar 'list cpp-edit-symbols) nil t)))
(defconst cpp-branch-list
;; Alist of branches.
'(("false" . nil)
("true" . t)
("both" . both)))
(defun cpp-choose-branch ()
;; Choose a branch, either nil, t, or both.
(if cpp-button-event
(x-popup-menu cpp-button-event
(list "Branch" (cons "Branch" cpp-branch-list)))
(cdr (assoc (completing-read "Branch: " cpp-branch-list nil t)
cpp-branch-list))))
(defun cpp-choose-face (prompt default)
;; Choose a face from cpp-face-defalt-list.
;; PROMPT is what to say to the user.
;; DEFAULT is the default face.
(or (if cpp-button-event
(x-popup-menu cpp-button-event
(list prompt (cons prompt cpp-face-default-list)))
(let ((name (car (rassq default cpp-face-default-list))))
(cdr (assoc (completing-read (if name
(concat prompt
" (default " name "): ")
(concat prompt ": "))
cpp-face-default-list nil t)
cpp-face-all-list))))
default))
(defconst cpp-face-type-list
'(("light color background" . light)
("dark color background" . dark)
("monochrome" . mono)
("tty" . none))
"Alist of strings and names of the defined face collections.")
(defun cpp-choose-default-face (type)
;; Choose default face list for screen of TYPE.
;; Type must be one of the types defined in `cpp-face-type-list'.
(interactive (list (if cpp-button-event
(x-popup-menu cpp-button-event
(list "Screen type"
(cons "Screen type"
cpp-face-type-list)))
(cdr (assoc (completing-read "Screen type: "
cpp-face-type-list
nil t)
cpp-face-type-list)))))
(cond ((null type))
((eq type 'light)
(if cpp-face-light-list
()
(setq cpp-face-light-list
(mapcar 'cpp-create-bg-face cpp-face-light-name-list))
(setq cpp-face-all-list
(append cpp-face-all-list cpp-face-light-list)))
(setq cpp-face-type 'light)
(setq cpp-face-default-list
(append cpp-face-light-list cpp-face-none-list)))
((eq type 'dark)
(if cpp-face-dark-list
()
(setq cpp-face-dark-list
(mapcar 'cpp-create-bg-face cpp-face-dark-name-list))
(setq cpp-face-all-list
(append cpp-face-all-list cpp-face-dark-list)))
(setq cpp-face-type 'dark)
(setq cpp-face-default-list
(append cpp-face-dark-list cpp-face-none-list)))
((eq type 'mono)
(setq cpp-face-type 'mono)
(setq cpp-face-default-list
(append cpp-face-mono-list cpp-face-none-list)))
(t
(setq cpp-face-type 'none)
(setq cpp-face-default-list cpp-face-none-list))))
;;; Buttons:
(defvar cpp-button-event nil)
;; This will be t in the callback for `cpp-make-button'.
(defun cpp-make-button (name callback &optional data face padding)
;; Create a button at point.
;; NAME is the name of the button.
;; CALLBACK is the function to call when the button is pushed.
;; DATA will be available to CALLBACK as a free variable.
;; FACE means that NAME is the name of a face in `cpp-face-all-list'.
;; PADDING means NAME will be right justified at that length.
(let ((name (format "%s" name))
from to)
(cond ((null padding)
(setq from (point))
(insert name))
((> (length name) padding)
(setq from (point))
(insert (substring name 0 padding)))
(t
(insert (make-string (- padding (length name)) ? ))
(setq from (point))
(insert name)))
(setq to (point))
(setq face
(if face
(let ((check (cdr (assoc name cpp-face-all-list))))
(if (memq check '(default invisible))
'bold
check))
'bold))
(add-text-properties from to
(append (list 'face face)
'(mouse-face highlight)
(list 'cpp-callback callback)
(if data (list 'cpp-data data))))))
(defun cpp-push-button (event)
;; Pushed a CPP button.
(interactive "@e")
(set-buffer (window-buffer (posn-window (event-start event))))
(let ((pos (posn-point (event-start event))))
(let ((data (get-text-property pos 'cpp-data))
(fun (get-text-property pos 'cpp-callback))
(cpp-button-event event))
(cond (fun
(call-interactively (get-text-property pos 'cpp-callback)))
((lookup-key global-map [ down-mouse-2])
(call-interactively (lookup-key global-map [ down-mouse-2])))))))
;;; Faces:
(defvar cpp-face-light-name-list
'("light gray" "light blue" "light cyan" "light yellow" "light pink"
"pale green" "beige" "orange" "magenta" "violet" "medium purple"
"turquoise")
"Background colours useful with dark foreground colors.")
(defvar cpp-face-dark-name-list
'("dim gray" "blue" "cyan" "yellow" "red"
"dark green" "brown" "dark orange" "dark khaki" "dark violet" "purple"
"dark turquoise")
"Background colours useful with light foreground colors.")
(defvar cpp-face-light-list nil
"Alist of names and faces to be used for light backgrounds.")
(defvar cpp-face-dark-list nil
"Alist of names and faces to be used for dark backgrounds.")
(defvar cpp-face-mono-list
'(("bold" . 'bold)
("bold-italic" . 'bold-italic)
("italic" . 'italic)
("underline" . 'underline))
"Alist of names and faces to be used for monocrome screens.")
(defvar cpp-face-none-list
'(("default" . default)
("invisible" . invisible))
"Alist of names and faces available even if you don't use a window system.")
(defvar cpp-face-all-list
(append cpp-face-light-list
cpp-face-dark-list
cpp-face-mono-list
cpp-face-none-list)
"All faces used for highligting text inside cpp conditionals.")
(defvar cpp-face-default-list nil
"List of faces you can choose from for cpp conditionals.")
(defun cpp-create-bg-face (color)
;; Create entry for face with background COLOR.
(let ((name (intern (concat "cpp " color))))
(make-face name)
(set-face-background name color)
(cons color name)))
(cpp-choose-default-face (if window-system cpp-face-type 'none))
(defun cpp-face-name (face)
;; Return the name of FACE from `cpp-face-all-list'.
(let ((entry (rassq (if face face 'default) cpp-face-all-list)))
(if entry
(car entry)
(format "<%s>" face))))
;;; Utilities:
(defvar cpp-progress-time 0)
;; Last time we issued a progress message.
(defun cpp-progress-message (&rest args)
;; Report progress at most once a second. Take same ARGS as `message'.
(let ((time (nth 1 (current-time))))
(if (= time cpp-progress-time)
()
(setq cpp-progress-time time)
(apply 'message args))))
(provide 'cpp)
;;; cpp.el ends here