mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-23 07:19:15 +00:00
784ff9c5d3
* lisp/progmodes/cpp.el (cpp-highlight-buffer): Use progress reporter. (cpp-progress-time, cpp-progress-message): Make obsolete in favor of 'make-progress-reporter'. (cpp-message-min-time-interval): Doc fix.
839 lines
28 KiB
EmacsLisp
839 lines
28 KiB
EmacsLisp
;;; cpp.el --- highlight or hide text according to cpp conditionals -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 1994-2022 Free Software Foundation, Inc.
|
|
|
|
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
|
|
;; Keywords: c, faces, tools
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs 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 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Parse a text for C preprocessor conditionals, and highlight or hide
|
|
;; the text inside the conditionals as you wish.
|
|
|
|
;; This package is inspired by Jim Coplien's delta editor for SCCS.
|
|
|
|
;;; 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:
|
|
(defgroup cpp nil
|
|
"Highlight or hide text according to cpp conditionals."
|
|
:link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
|
|
:group 'c
|
|
:prefix "cpp-")
|
|
|
|
(defcustom cpp-config-file (convert-standard-filename ".cpp.el")
|
|
"File name to save cpp configuration."
|
|
:type 'file)
|
|
|
|
(define-widget 'cpp-face 'lazy
|
|
"Either a face or the special symbol `invisible'."
|
|
:type '(choice (const invisible) (face)))
|
|
|
|
(defcustom cpp-known-face 'invisible
|
|
"Face used for known cpp symbols."
|
|
:type 'cpp-face)
|
|
|
|
(defcustom cpp-unknown-face 'highlight
|
|
"Face used for unknown cpp symbols."
|
|
:type 'cpp-face)
|
|
|
|
(defcustom 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 and don't have
|
|
a color-capable display."
|
|
:options '(light dark mono nil)
|
|
:type 'symbol)
|
|
|
|
(defcustom cpp-known-writable t
|
|
"Non-nil means you are allowed to modify the known conditionals."
|
|
:type 'boolean)
|
|
|
|
(defcustom cpp-unknown-writable t
|
|
"Non-nil means you are allowed to modify the unknown conditionals."
|
|
:type 'boolean)
|
|
|
|
(defcustom 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."
|
|
:type '(repeat (list (string :tag "Macro")
|
|
(cpp-face :tag "True")
|
|
(cpp-face :tag "False")
|
|
(choice (const :tag "True branch writable" t)
|
|
(const :tag "False branch writable" nil)
|
|
(const :tag "Both branches writable" both)))))
|
|
|
|
(defcustom cpp-message-min-time-interval 1.0
|
|
"Minimum time interval in seconds for `cpp-highlight-buffer' progress messages.
|
|
If nil, `cpp-highlight-buffer' prints no progress messages."
|
|
:type '(choice (const :tag "Disable progress messages" nil)
|
|
float)
|
|
:version "26.1")
|
|
|
|
(defvar-local cpp-overlay-list nil
|
|
"List of cpp overlays active in the current buffer.")
|
|
|
|
(defvar cpp-callback-data)
|
|
(defvar cpp-state-stack)
|
|
|
|
(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.")
|
|
|
|
(defconst cpp-writable-list
|
|
;; Names used for the writable property.
|
|
'(("writable" . t)
|
|
("read-only" . nil)))
|
|
|
|
(defvar cpp-button-event nil)
|
|
;; This will be t in the callback for `cpp-make-button'.
|
|
|
|
(defvar-local cpp-edit-buffer nil
|
|
"Real buffer whose cpp display information we are editing.")
|
|
|
|
(defconst cpp-branch-list
|
|
;; Alist of branches.
|
|
'(("false" . nil)
|
|
("true" . t)
|
|
("both" . both)))
|
|
|
|
;; FIXME Gets clobbered by cpp-choose-face, so why is even it a defcustom?
|
|
(defcustom cpp-face-default-list nil
|
|
"Alist of faces you can choose from for cpp conditionals.
|
|
Each element has the form (STRING . FACE), where STRING
|
|
serves as a name (for `cpp-highlight-buffer' only)
|
|
and FACE is either a face (a symbol)
|
|
or a cons cell (background-color . COLOR)."
|
|
:type '(alist :key-type (string :tag "Name")
|
|
:value-type (choice face
|
|
(const invisible)
|
|
(cons (const background-color)
|
|
(string :tag "Color")))))
|
|
|
|
(defcustom 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 colors useful with dark foreground colors."
|
|
:type '(repeat string))
|
|
|
|
(defcustom cpp-face-dark-name-list
|
|
'("dim gray" "blue" "cyan" "yellow" "red"
|
|
"dark green" "brown" "dark orange" "dark khaki" "dark violet" "purple"
|
|
"dark turquoise")
|
|
"Background colors useful with light foreground colors."
|
|
:type '(repeat string))
|
|
|
|
(defcustom cpp-face-light-list nil
|
|
"Alist of names and faces to be used for light backgrounds."
|
|
:type '(repeat (cons string (choice face
|
|
(cons (const background-color) string)))))
|
|
|
|
(defcustom cpp-face-dark-list nil
|
|
"Alist of names and faces to be used for dark backgrounds."
|
|
:type '(repeat (cons string (choice face
|
|
(cons (const background-color) string)))))
|
|
|
|
(defcustom cpp-face-mono-list
|
|
'(("bold" . bold)
|
|
("bold-italic" . bold-italic)
|
|
("italic" . italic)
|
|
("underline" . underline))
|
|
"Alist of names and faces to be used for monochrome screens."
|
|
:type '(repeat (cons string face)))
|
|
|
|
(defcustom cpp-face-none-list
|
|
'(("default" . default)
|
|
("invisible" . invisible))
|
|
"Alist of names and faces available even if you don't use a window system."
|
|
:type '(repeat (cons string cpp-face)))
|
|
|
|
(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 highlighting text inside cpp conditionals.")
|
|
|
|
;;; Parse Buffer:
|
|
|
|
(defvar-local cpp-parse-symbols nil
|
|
"List of cpp macros used in the local buffer.")
|
|
|
|
(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-highlight-buffer (arg)
|
|
"Highlight C code according to preprocessor conditionals.
|
|
This command pops up a buffer which you should edit to specify
|
|
what kind of highlighting to use, and the criteria for highlighting.
|
|
A prefix arg suppresses display of that buffer."
|
|
(interactive "P")
|
|
(unless (or (eq t buffer-invisibility-spec)
|
|
(memq 'cpp buffer-invisibility-spec))
|
|
(add-to-invisibility-spec 'cpp))
|
|
(setq cpp-parse-symbols nil)
|
|
(cpp-parse-reset)
|
|
(if (null cpp-edit-list)
|
|
(cpp-edit-load))
|
|
(let ((reporter
|
|
(and cpp-message-min-time-interval
|
|
(make-progress-reporter "Parsing..." (point-min) (point-max)
|
|
nil nil cpp-message-min-time-interval)))
|
|
cpp-state-stack)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(while (re-search-forward cpp-parse-regexp nil t)
|
|
(when reporter (progress-reporter-update reporter (point)))
|
|
(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 cpp-state-stack
|
|
(cpp-parse-error "Top level #else"))
|
|
(let ((entry (list (not (nth 0 (car cpp-state-stack)))
|
|
(nth 1 (car cpp-state-stack))
|
|
from to)))
|
|
(cpp-parse-close from to)
|
|
(setq cpp-state-stack (cons entry cpp-state-stack))))
|
|
((string-equal type "endif")
|
|
(cpp-parse-close from to))
|
|
(t
|
|
(cpp-parse-error "Parser error"))))))))
|
|
(when reporter (progress-reporter-done reporter)))
|
|
(if cpp-state-stack
|
|
(save-excursion
|
|
(goto-char (nth 3 (car cpp-state-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-beginning onto `cpp-state-stack'."
|
|
;; Discard comments within this line.
|
|
(while (string-match "\\b[ \t]*/\\*.*\\*/[ \t]*\\b" expr)
|
|
(setq expr (concat (substring expr 0 (match-beginning 0))
|
|
(substring expr (match-end 0)))))
|
|
;; If a comment starts on this line and continues past, discard it.
|
|
(if (string-match "\\b[ \t]*/\\*" expr)
|
|
(setq expr (substring expr 0 (match-beginning 0))))
|
|
;; Delete any C++ comment from the line.
|
|
(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 cpp-state-stack (cons (list branch expr begin end) cpp-state-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 cpp-state-stack and create overlay.
|
|
(let ((entry (assoc (nth 1 (car cpp-state-stack)) cpp-edit-list))
|
|
(branch (nth 0 (car cpp-state-stack)))
|
|
(end (nth 3 (car cpp-state-stack))))
|
|
(setq cpp-state-stack (cdr cpp-state-stack))
|
|
(if entry
|
|
(let ((face (nth (if branch 1 2) entry))
|
|
(read-only (eq (not branch) (nth 3 entry)))
|
|
(priority (length cpp-state-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 "%s at line %d" error (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-highlight-buffer t))
|
|
(let ((buffer (current-buffer)))
|
|
(pop-to-buffer "*CPP Edit*")
|
|
(cpp-edit-mode)
|
|
(setq cpp-edit-buffer buffer)
|
|
(cpp-edit-reset)))
|
|
|
|
;;; Overlays:
|
|
|
|
(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 'cpp)
|
|
(overlay-put overlay 'modification-hooks '(cpp-signal-read-only))
|
|
(overlay-put overlay 'insert-in-front-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 after start end &optional _len)
|
|
;; Only allow deleting the whole overlay.
|
|
;; Trying to change a read-only overlay.
|
|
(if (and (not after)
|
|
(or (< (overlay-start overlay) start)
|
|
(> (overlay-end overlay) end)))
|
|
(error "This text is read only")))
|
|
|
|
(defun cpp-grow-overlay (overlay after start end &optional _len)
|
|
;; Make OVERLAY grow to contain range START to END.
|
|
(if after
|
|
(move-overlay overlay
|
|
(min start (overlay-start overlay))
|
|
(max end (overlay-end overlay)))))
|
|
|
|
;;; Edit Buffer:
|
|
|
|
(defvar-keymap cpp-edit-mode-map
|
|
:doc "Keymap for `cpp-edit-mode'."
|
|
:full t
|
|
:suppress t
|
|
"<down-mouse-2>" #'cpp-push-button
|
|
"<mouse-2>" #'ignore
|
|
"SPC" #'scroll-up-command
|
|
"S-SPC" #'scroll-down-command
|
|
"DEL" #'scroll-down-command
|
|
"<delete>" #'scroll-down
|
|
"C-c C-c" #'cpp-edit-apply
|
|
"a" #'cpp-edit-apply
|
|
"A" #'cpp-edit-apply
|
|
"r" #'cpp-edit-reset
|
|
"R" #'cpp-edit-reset
|
|
"s" #'cpp-edit-save
|
|
"S" #'cpp-edit-save
|
|
"l" #'cpp-edit-load
|
|
"L" #'cpp-edit-load
|
|
"h" #'cpp-edit-home
|
|
"H" #'cpp-edit-home
|
|
"b" #'cpp-edit-background
|
|
"B" #'cpp-edit-background
|
|
"k" #'cpp-edit-known
|
|
"K" #'cpp-edit-known
|
|
"u" #'cpp-edit-unknown
|
|
"U" #'cpp-edit-unknown
|
|
"t" #'cpp-edit-true
|
|
"T" #'cpp-edit-true
|
|
"f" #'cpp-edit-false
|
|
"F" #'cpp-edit-false
|
|
"w" #'cpp-edit-write
|
|
"W" #'cpp-edit-write
|
|
"X" #'cpp-edit-toggle-known
|
|
"x" #'cpp-edit-toggle-known
|
|
"Y" #'cpp-edit-toggle-unknown
|
|
"y" #'cpp-edit-toggle-unknown
|
|
"q" #'bury-buffer
|
|
"Q" #'bury-buffer)
|
|
|
|
|
|
(defvar-local cpp-edit-symbols nil
|
|
"Symbols defined in the edit buffer.")
|
|
|
|
(define-derived-mode cpp-edit-mode fundamental-mode "CPP Edit"
|
|
"Major mode for editing the criteria for highlighting cpp conditionals.
|
|
Click on objects to change them.
|
|
You can also use the keyboard accelerators indicated like this: [K]ey."
|
|
(buffer-disable-undo)
|
|
(auto-save-mode -1)
|
|
(setq buffer-read-only t))
|
|
|
|
(defun cpp-edit-apply ()
|
|
"Apply edited display information to original buffer."
|
|
(interactive)
|
|
(cpp-edit-home)
|
|
(cpp-highlight-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 (substitute-command-keys "CPP Display Information for `"))
|
|
(cpp-make-button (buffer-name cpp-edit-buffer) 'cpp-edit-home)
|
|
(insert (substitute-command-keys
|
|
"'\n\nClick mouse-2 on item you want to change or use\n")
|
|
"or switch to this buffer and type the keyboard equivalents.\n"
|
|
"Keyboard equivalents are indicated with brackets like [T]his.\n\n")
|
|
(cpp-make-button "[H]ome (display the C file)" 'cpp-edit-home)
|
|
(insert " ")
|
|
(cpp-make-button "[A]pply new settings" 'cpp-edit-apply)
|
|
(insert "\n")
|
|
(cpp-make-button "[S]ave settings" 'cpp-edit-save)
|
|
(insert " ")
|
|
(cpp-make-button "[L]oad settings" 'cpp-edit-load)
|
|
(insert "\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"))
|
|
|
|
(setq symbols (reverse symbols))
|
|
(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) 39)
|
|
(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-locate-user-emacs-file (file)
|
|
(locate-user-emacs-file
|
|
;; Remove initial '.' from file.
|
|
(if (eq (aref file 0) ?.)
|
|
(substring file 1)
|
|
file)
|
|
file))
|
|
|
|
(defun cpp-edit-load ()
|
|
"Load cpp configuration."
|
|
(interactive)
|
|
(cond ((null init-file-user)
|
|
;; If -q was specified, don't load any init files.
|
|
nil)
|
|
((file-readable-p cpp-config-file)
|
|
(load-file cpp-config-file))
|
|
((file-readable-p (cpp-locate-user-emacs-file cpp-config-file))
|
|
(load-file (cpp-locate-user-emacs-file cpp-config-file))))
|
|
(if (derived-mode-p 'cpp-edit-mode)
|
|
(cpp-edit-reset)))
|
|
|
|
(defun cpp-edit-save ()
|
|
"Save the current cpp configuration in a file."
|
|
(interactive)
|
|
(require 'pp)
|
|
(with-current-buffer cpp-edit-buffer
|
|
(let* ((config-file (if (file-writable-p cpp-config-file)
|
|
cpp-config-file
|
|
(cpp-locate-user-emacs-file cpp-config-file)))
|
|
(buffer (find-file-noselect config-file)))
|
|
(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 config-file))))
|
|
|
|
(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))
|
|
|
|
(defun cpp-edit-toggle-known (arg)
|
|
"Toggle writable status for known conditionals.
|
|
With optional argument ARG, make them writable if ARG is positive,
|
|
otherwise make them unwritable."
|
|
(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 if ARG is positive,
|
|
otherwise make them unwritable."
|
|
(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
|
|
cpp-callback-data
|
|
(completing-read "Symbol: " cpp-edit-symbols nil t)))
|
|
|
|
(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-default-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 (format-prompt "%s" name prompt)
|
|
cpp-face-default-list nil t)
|
|
cpp-face-all-list))))
|
|
default))
|
|
|
|
(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:
|
|
|
|
(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 made available to CALLBACK
|
|
;;in the free variable cpp-callback-data.
|
|
;; 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)
|
|
'(help-echo "mouse-2: change/use this item")
|
|
(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 ((cpp-callback-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:
|
|
|
|
(defun cpp-create-bg-face (color)
|
|
;; Create entry for face with background COLOR.
|
|
(cons color (cons 'background-color color)))
|
|
|
|
(cpp-choose-default-face
|
|
(if (or window-system (display-color-p)) 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:
|
|
|
|
(make-obsolete-variable 'cpp-progress-time nil "29.1")
|
|
(defvar cpp-progress-time 0
|
|
"Last time `cpp-progress-message' issued a progress message.")
|
|
|
|
(defun cpp-progress-message (&rest args)
|
|
"Report progress by printing messages used by \"cpp-\" functions.
|
|
|
|
Print messages at most once every `cpp-message-min-time-interval' seconds.
|
|
If that option is nil, don't prints messages.
|
|
ARGS are the same as for `message'."
|
|
(declare (obsolete make-progress-reporter "29.1"))
|
|
(when cpp-message-min-time-interval
|
|
(let ((time (current-time)))
|
|
(unless (time-less-p cpp-message-min-time-interval
|
|
(time-subtract time cpp-progress-time))
|
|
(setq cpp-progress-time time)
|
|
(apply 'message args)))))
|
|
|
|
(provide 'cpp)
|
|
|
|
;;; cpp.el ends here
|