aboutsummaryrefslogtreecommitdiffstats
path: root/lisp/progmodes/cpp.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/progmodes/cpp.el')
-rw-r--r--lisp/progmodes/cpp.el773
1 files changed, 773 insertions, 0 deletions
diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el
new file mode 100644
index 0000000000..0d21c22f68
--- /dev/null
+++ b/lisp/progmodes/cpp.el
@@ -0,0 +1,773 @@
+;;; cpp.el --- Highlight or hide text according to cpp conditionals.
+
+;; Copyright (C) 1994 Free Software Foundation
+
+;; Author: Per Abrahamsen <[email protected]>
+;; Version: $Id: 0.2 ALPHA RELEASE WITH BUGS $
+;; Keywords: c, faces, tools
+
+;; LCD Archive Entry:
+;; cpp|Per Abrahamsen|[email protected]|
+;; 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
+