code.delx.au - gnu-emacs/blob - lisp/progmodes/cpp.el

   1 ;;; cpp.el --- highlight or hide text according to cpp conditionals
   2
   3 ;; Copyright (C) 1994-1995, 2001-2011
   4 ;; Free Software Foundation
   5
   6 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
   7 ;; Keywords: c, faces, tools
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Parse a text for C preprocessor conditionals, and highlight or hide
  27 ;; the text inside the conditionals as you wish.
  28
  29 ;; This package is inspired by Jim Coplien's delta editor for SCCS.
  30
  31 ;;; Todo:
  32
  33 ;; Should parse "#if" and "#elif" expressions and merge the faces
  34 ;; somehow.
  35
  36 ;; Somehow it is sometimes possible to make changes near a read only
  37 ;; area which you can't undo.  Their are other strange effects in that
  38 ;; area.
  39
  40 ;; The Edit buffer should -- optionally -- appear in its own frame.
  41
  42 ;; Conditionals seem to be rear-sticky.  They shouldn't be.
  43
  44 ;; Restore window configurations when exiting CPP Edit buffer.
  45
  46 ;;; Code:
  47
  48 ;;; Customization:
  49 (defgroup cpp nil
  50   "Highlight or hide text according to cpp conditionals."
  51   :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
  52   :group 'c
  53   :prefix "cpp-")
  54
  55 (defcustom cpp-config-file (convert-standard-filename ".cpp.el")
  56   "*File name to save cpp configuration."
  57   :type 'file
  58   :group 'cpp)
  59
  60 (define-widget 'cpp-face 'lazy
  61   "Either a face or the special symbol 'invisible'."
  62   :type '(choice (const invisible) (face)))
  63
  64 (defcustom cpp-known-face 'invisible
  65   "*Face used for known cpp symbols."
  66   :type 'cpp-face
  67   :group 'cpp)
  68
  69 (defcustom cpp-unknown-face 'highlight
  70   "*Face used for unknown cpp symbols."
  71   :type 'cpp-face
  72   :group 'cpp)
  73
  74 (defcustom cpp-face-type 'light
  75   "*Indicate what background face type you prefer.
  76 Can be either light or dark for color screens, mono for monochrome
  77 screens, and none if you don't use a window system and don't have
  78 a color-capable display."
  79   :options '(light dark mono nil)
  80   :type 'symbol
  81   :group 'cpp)
  82
  83 (defcustom cpp-known-writable t
  84   "*Non-nil means you are allowed to modify the known conditionals."
  85   :type 'boolean
  86   :group 'cpp)
  87
  88 (defcustom cpp-unknown-writable t
  89   "*Non-nil means you are allowed to modify the unknown conditionals."
  90   :type 'boolean
  91   :group 'cpp)
  92
  93 (defcustom cpp-edit-list nil
  94   "Alist of cpp macros and information about how they should be displayed.
  95 Each entry is a list with the following elements:
  96 0. The name of the macro (a string).
  97 1. Face used for text that is `ifdef' the macro.
  98 2. Face used for text that is `ifndef' the macro.
  99 3. t, nil, or `both' depending on what text may be edited."
 100   :type '(repeat (list (string :tag "Macro")
 101                        (cpp-face :tag "True")
 102                        (cpp-face :tag "False")
 103                        (choice (const :tag "True branch writable" t)
 104                                (const :tag "False branch writable" nil)
 105                                (const :tag "Both branches writable" both))))
 106   :group 'cpp)
 107
 108 (defvar cpp-overlay-list nil)
 109 ;; List of cpp overlays active in the current buffer.
 110 (make-variable-buffer-local 'cpp-overlay-list)
 111
 112 (defvar cpp-callback-data)
 113 (defvar cpp-state-stack)
 114
 115 (defconst cpp-face-type-list
 116   '(("light color background" . light)
 117     ("dark color background" . dark)
 118     ("monochrome" . mono)
 119     ("tty" . none))
 120   "Alist of strings and names of the defined face collections.")
 121
 122 (defconst cpp-writable-list
 123   ;; Names used for the writable property.
 124   '(("writable" . t)
 125     ("read-only" . nil)))
 126
 127 (defvar cpp-button-event nil)
 128 ;; This will be t in the callback for `cpp-make-button'.
 129
 130 (defvar cpp-edit-buffer nil)
 131 ;; Real buffer whose cpp display information we are editing.
 132 (make-variable-buffer-local 'cpp-edit-buffer)
 133
 134 (defconst cpp-branch-list
 135   ;; Alist of branches.
 136   '(("false" . nil)
 137     ("true" . t)
 138     ("both" . both)))
 139
 140 (defcustom cpp-face-default-list nil
 141   "Alist of faces you can choose from for cpp conditionals.
 142 Each element has the form (STRING . FACE), where STRING
 143 serves as a name (for `cpp-highlight-buffer' only)
 144 and FACE is either a face (a symbol)
 145 or a cons cell (background-color . COLOR)."
 146   :type '(repeat (cons string (choice face (cons (const background-color) string))))
 147   :group 'cpp)
 148
 149 (defcustom cpp-face-light-name-list
 150   '("light gray" "light blue" "light cyan" "light yellow" "light pink"
 151     "pale green" "beige" "orange" "magenta" "violet" "medium purple"
 152     "turquoise")
 153   "Background colors useful with dark foreground colors."
 154   :type '(repeat string)
 155   :group 'cpp)
 156
 157 (defcustom cpp-face-dark-name-list
 158   '("dim gray" "blue" "cyan" "yellow" "red"
 159     "dark green" "brown" "dark orange" "dark khaki" "dark violet" "purple"
 160     "dark turquoise")
 161   "Background colors useful with light foreground colors."
 162   :type '(repeat string)
 163   :group 'cpp)
 164
 165 (defcustom cpp-face-light-list nil
 166   "Alist of names and faces to be used for light backgrounds."
 167   :type '(repeat (cons string (choice face
 168                                       (cons (const background-color) string))))
 169   :group 'cpp)
 170
 171 (defcustom cpp-face-dark-list nil
 172   "Alist of names and faces to be used for dark backgrounds."
 173   :type '(repeat (cons string (choice face
 174                                       (cons (const background-color) string))))
 175   :group 'cpp)
 176
 177 (defcustom cpp-face-mono-list
 178   '(("bold" . bold)
 179     ("bold-italic" . bold-italic)
 180     ("italic" . italic)
 181     ("underline" . underline))
 182   "Alist of names and faces to be used for monochrome screens."
 183   :type '(repeat (cons string face))
 184   :group 'cpp)
 185
 186 (defcustom cpp-face-none-list
 187    '(("default" . default)
 188      ("invisible" . invisible))
 189    "Alist of names and faces available even if you don't use a window system."
 190   :type '(repeat (cons string cpp-face))
 191   :group 'cpp)
 192
 193 (defvar cpp-face-all-list
 194   (append cpp-face-light-list
 195           cpp-face-dark-list
 196           cpp-face-mono-list
 197           cpp-face-none-list)
 198   "All faces used for highlighting text inside cpp conditionals.")
 199
 200 ;;; Parse Buffer:
 201
 202 (defvar cpp-parse-symbols nil
 203   "List of cpp macros used in the local buffer.")
 204 (make-variable-buffer-local 'cpp-parse-symbols)
 205
 206 (defconst cpp-parse-regexp
 207   ;; Regexp matching all tokens needed to find conditionals.
 208   (concat
 209    "'\\|\"\\|/\\*\\|//\\|"
 210    "\\(^[ \t]*#[ \t]*\\(ifdef\\|ifndef\\|if\\|"
 211    "elif\\|else\\|endif\\)\\b\\)"))
 212
 213 ;;;###autoload
 214 (defun cpp-highlight-buffer (arg)
 215   "Highlight C code according to preprocessor conditionals.
 216 This command pops up a buffer which you should edit to specify
 217 what kind of highlighting to use, and the criteria for highlighting.
 218 A prefix arg suppresses display of that buffer."
 219   (interactive "P")
 220   (unless (or (eq t buffer-invisibility-spec)
 221               (memq 'cpp buffer-invisibility-spec))
 222     (add-to-invisibility-spec 'cpp))
 223   (setq cpp-parse-symbols nil)
 224   (cpp-parse-reset)
 225   (if (null cpp-edit-list)
 226       (cpp-edit-load))
 227   (let (cpp-state-stack)
 228     (save-excursion
 229       (goto-char (point-min))
 230       (cpp-progress-message "Parsing...")
 231       (while (re-search-forward cpp-parse-regexp nil t)
 232         (cpp-progress-message "Parsing...%d%%"
 233                           (/ (* 100 (- (point) (point-min))) (buffer-size)))
 234         (let ((match (buffer-substring (match-beginning 0) (match-end 0))))
 235           (cond ((or (string-equal match "'")
 236                      (string-equal match "\""))
 237                  (goto-char (match-beginning 0))
 238                  (condition-case nil
 239                      (forward-sexp)
 240                    (error (cpp-parse-error
 241                            "Unterminated string or character"))))
 242                 ((string-equal match "/*")
 243                  (or (search-forward "*/" nil t)
 244                      (error "Unterminated comment")))
 245                 ((string-equal match "//")
 246                  (skip-chars-forward "^\n\r"))
 247                 (t
 248                  (end-of-line 1)
 249                  (let ((from (match-beginning 1))
 250                        (to (1+ (point)))
 251                        (type (buffer-substring (match-beginning 2)
 252                                                (match-end 2)))
 253                        (expr (buffer-substring (match-end 1) (point))))
 254                    (cond ((string-equal type "ifdef")
 255                           (cpp-parse-open t expr from to))
 256                          ((string-equal type "ifndef")
 257                           (cpp-parse-open nil expr from to))
 258                          ((string-equal type "if")
 259                           (cpp-parse-open t expr from to))
 260                          ((string-equal type "elif")
 261                           (let (cpp-known-face cpp-unknown-face)
 262                             (cpp-parse-close from to))
 263                           (cpp-parse-open t expr from to))
 264                          ((string-equal type "else")
 265                           (or cpp-state-stack
 266                               (cpp-parse-error "Top level #else"))
 267                           (let ((entry (list (not (nth 0 (car cpp-state-stack)))
 268                                              (nth 1 (car cpp-state-stack))
 269                                              from to)))
 270                             (cpp-parse-close from to)
 271                             (setq cpp-state-stack (cons entry cpp-state-stack))))
 272                          ((string-equal type "endif")
 273                           (cpp-parse-close from to))
 274                          (t
 275                           (cpp-parse-error "Parser error"))))))))
 276       (message "Parsing...done"))
 277     (if cpp-state-stack
 278       (save-excursion
 279         (goto-char (nth 3 (car cpp-state-stack)))
 280         (cpp-parse-error "Unclosed conditional"))))
 281   (or arg
 282       (null cpp-parse-symbols)
 283       (cpp-parse-edit)))
 284
 285 (defun cpp-parse-open (branch expr begin end)
 286   "Push information about conditional-beginning onto `cpp-state-stack'."
 287   ;; Discard comments within this line.
 288   (while (string-match "\\b[ \t]*/\\*.*\\*/[ \t]*\\b" expr)
 289     (setq expr (concat (substring expr 0 (match-beginning 0))
 290                        (substring expr (match-end 0)))))
 291   ;; If a comment starts on this line and continues past, discard it.
 292   (if (string-match "\\b[ \t]*/\\*" expr)
 293       (setq expr (substring expr 0 (match-beginning 0))))
 294   ;; Delete any C++ comment from the line.
 295   (if (string-match "\\b[ \t]*\\(//.*\\)?$" expr)
 296       (setq expr (substring expr 0 (match-beginning 0))))
 297   (while (string-match "[ \t]+" expr)
 298       (setq expr (concat (substring expr 0 (match-beginning 0))
 299                          (substring expr (match-end 0)))))
 300   (setq cpp-state-stack (cons (list branch expr begin end) cpp-state-stack))
 301   (or (member expr cpp-parse-symbols)
 302       (setq cpp-parse-symbols
 303             (cons expr cpp-parse-symbols)))
 304   (if (assoc expr cpp-edit-list)
 305       (cpp-make-known-overlay begin end)
 306     (cpp-make-unknown-overlay begin end)))
 307
 308 (defun cpp-parse-close (from to)
 309   ;; Pop top of cpp-state-stack and create overlay.
 310   (let ((entry (assoc (nth 1 (car cpp-state-stack)) cpp-edit-list))
 311         (branch (nth 0 (car cpp-state-stack)))
 312         (begin (nth 2 (car cpp-state-stack)))
 313         (end (nth 3 (car cpp-state-stack))))
 314     (setq cpp-state-stack (cdr cpp-state-stack))
 315     (if entry
 316         (let ((face (nth (if branch 1 2) entry))
 317               (read-only (eq (not branch) (nth 3 entry)))
 318               (priority (length cpp-state-stack))
 319               (overlay (make-overlay end from)))
 320           (cpp-make-known-overlay from to)
 321           (setq cpp-overlay-list (cons overlay cpp-overlay-list))
 322           (if priority (overlay-put overlay 'priority priority))
 323           (cond ((eq face 'invisible)
 324                  (cpp-make-overlay-hidden overlay))
 325                 ((eq face 'default))
 326                 (t
 327                  (overlay-put overlay 'face face)))
 328           (if read-only
 329               (cpp-make-overlay-read-only overlay)
 330             (cpp-make-overlay-sticky overlay)))
 331       (cpp-make-unknown-overlay from to))))
 332
 333 (defun cpp-parse-error (error)
 334   ;; Error message issued by the cpp parser.
 335   (error "%s at line %d" error (count-lines (point-min) (point))))
 336
 337 (defun cpp-parse-reset ()
 338   "Reset display of cpp conditionals to normal."
 339   (interactive)
 340   (while cpp-overlay-list
 341     (delete-overlay (car cpp-overlay-list))
 342     (setq cpp-overlay-list (cdr cpp-overlay-list))))
 343
 344 ;;;###autoload
 345 (defun cpp-parse-edit ()
 346   "Edit display information for cpp conditionals."
 347   (interactive)
 348   (or cpp-parse-symbols
 349       (cpp-highlight-buffer t))
 350   (let ((buffer (current-buffer)))
 351     (pop-to-buffer "*CPP Edit*")
 352     (cpp-edit-mode)
 353     (setq cpp-edit-buffer buffer)
 354     (cpp-edit-reset)))
 355
 356 ;;; Overlays:
 357
 358 (defun cpp-make-known-overlay (start end)
 359   ;; Create an overlay for a known cpp command from START to END.
 360   (let ((overlay (make-overlay start end)))
 361     (if (eq cpp-known-face 'invisible)
 362         (cpp-make-overlay-hidden overlay)
 363       (or (eq cpp-known-face 'default)
 364           (overlay-put overlay 'face cpp-known-face))
 365       (if cpp-known-writable
 366           ()
 367         (overlay-put overlay 'modification-hooks '(cpp-signal-read-only))
 368         (overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only))))
 369     (setq cpp-overlay-list (cons overlay cpp-overlay-list))))
 370
 371 (defun cpp-make-unknown-overlay (start end)
 372   ;; Create an overlay for an unknown cpp command from START to END.
 373   (let ((overlay (make-overlay start end)))
 374     (cond ((eq cpp-unknown-face 'invisible)
 375            (cpp-make-overlay-hidden overlay))
 376           ((eq cpp-unknown-face 'default))
 377           (t
 378            (overlay-put overlay 'face cpp-unknown-face)))
 379     (if cpp-unknown-writable
 380         ()
 381       (overlay-put overlay 'modification-hooks '(cpp-signal-read-only))
 382       (overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only)))
 383     (setq cpp-overlay-list (cons overlay cpp-overlay-list))))
 384
 385 (defun cpp-make-overlay-hidden (overlay)
 386   ;; Make overlay hidden and intangible.
 387   (overlay-put overlay 'invisible 'cpp)
 388   (overlay-put overlay 'modification-hooks '(cpp-signal-read-only))
 389   (overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only)))
 390
 391 (defun cpp-make-overlay-read-only (overlay)
 392   ;; Make overlay read only.
 393   (overlay-put overlay 'modification-hooks '(cpp-signal-read-only))
 394   (overlay-put overlay 'insert-in-front-hooks '(cpp-signal-read-only))
 395   (overlay-put overlay 'insert-behind-hooks '(cpp-signal-read-only)))
 396
 397 (defun cpp-make-overlay-sticky (overlay)
 398   ;; Make OVERLAY grow when you insert text at either end.
 399   (overlay-put overlay 'insert-in-front-hooks '(cpp-grow-overlay))
 400   (overlay-put overlay 'insert-behind-hooks '(cpp-grow-overlay)))
 401
 402 (defun cpp-signal-read-only (overlay after start end &optional len)
 403   ;; Only allow deleting the whole overlay.
 404   ;; Trying to change a read-only overlay.
 405   (if (and (not after)
 406            (or (< (overlay-start overlay) start)
 407                (> (overlay-end overlay) end)))
 408       (error "This text is read only")))
 409
 410 (defun cpp-grow-overlay (overlay after start end &optional len)
 411   ;; Make OVERLAY grow to contain range START to END.
 412   (if after
 413       (move-overlay overlay
 414                     (min start (overlay-start overlay))
 415                     (max end (overlay-end overlay)))))
 416
 417 ;;; Edit Buffer:
 418
 419 (defvar cpp-edit-mode-map
 420   (let ((map (make-keymap)))
 421     (suppress-keymap map)
 422     (define-key map [ down-mouse-2 ] 'cpp-push-button)
 423     (define-key map [ mouse-2 ] 'ignore)
 424     (define-key map " " 'scroll-up)
 425     (define-key map "\C-?" 'scroll-down)
 426     (define-key map [ delete ] 'scroll-down)
 427     (define-key map "\C-c\C-c" 'cpp-edit-apply)
 428     (define-key map "a" 'cpp-edit-apply)
 429     (define-key map "A" 'cpp-edit-apply)
 430     (define-key map "r" 'cpp-edit-reset)
 431     (define-key map "R" 'cpp-edit-reset)
 432     (define-key map "s" 'cpp-edit-save)
 433     (define-key map "S" 'cpp-edit-save)
 434     (define-key map "l" 'cpp-edit-load)
 435     (define-key map "L" 'cpp-edit-load)
 436     (define-key map "h" 'cpp-edit-home)
 437     (define-key map "H" 'cpp-edit-home)
 438     (define-key map "b" 'cpp-edit-background)
 439     (define-key map "B" 'cpp-edit-background)
 440     (define-key map "k" 'cpp-edit-known)
 441     (define-key map "K" 'cpp-edit-known)
 442     (define-key map "u" 'cpp-edit-unknown)
 443     (define-key map "u" 'cpp-edit-unknown)
 444     (define-key map "t" 'cpp-edit-true)
 445     (define-key map "T" 'cpp-edit-true)
 446     (define-key map "f" 'cpp-edit-false)
 447     (define-key map "F" 'cpp-edit-false)
 448     (define-key map "w" 'cpp-edit-write)
 449     (define-key map "W" 'cpp-edit-write)
 450     (define-key map "X" 'cpp-edit-toggle-known)
 451     (define-key map "x" 'cpp-edit-toggle-known)
 452     (define-key map "Y" 'cpp-edit-toggle-unknown)
 453     (define-key map "y" 'cpp-edit-toggle-unknown)
 454     (define-key map "q" 'bury-buffer)
 455     (define-key map "Q" 'bury-buffer)
 456     map)
 457   "Keymap for `cpp-edit-mode'.")
 458
 459
 460
 461 (defvar cpp-edit-symbols nil)
 462 ;; Symbols defined in the edit buffer.
 463 (make-variable-buffer-local 'cpp-edit-symbols)
 464
 465 (define-derived-mode cpp-edit-mode fundamental-mode "CPP Edit"
 466   "Major mode for editing the criteria for highlighting cpp conditionals.
 467 Click on objects to change them.
 468 You can also use the keyboard accelerators indicated like this: [K]ey."
 469   (buffer-disable-undo)
 470   (auto-save-mode -1)
 471   (setq buffer-read-only t))
 472
 473 (defun cpp-edit-apply ()
 474   "Apply edited display information to original buffer."
 475   (interactive)
 476   (cpp-edit-home)
 477   (cpp-highlight-buffer t))
 478
 479 (defun cpp-edit-reset ()
 480   "Reset display information from original buffer."
 481   (interactive)
 482   (let ((buffer (current-buffer))
 483         (buffer-read-only nil)
 484         (start (window-start))
 485         (pos (point))
 486         symbols)
 487     (set-buffer cpp-edit-buffer)
 488     (setq symbols cpp-parse-symbols)
 489     (set-buffer buffer)
 490     (setq cpp-edit-symbols symbols)
 491     (erase-buffer)
 492     (insert "CPP Display Information for `")
 493     (cpp-make-button (buffer-name cpp-edit-buffer) 'cpp-edit-home)
 494     (insert "'\n\nClick mouse-2 on item you want to change or use\n"
 495             "or switch to this buffer and type the keyboard equivalents.\n"
 496             "Keyboard equivalents are indicated with brackets like [T]his.\n\n")
 497     (cpp-make-button "[H]ome (display the C file)" 'cpp-edit-home)
 498     (insert "  ")
 499     (cpp-make-button "[A]pply new settings" 'cpp-edit-apply)
 500     (insert "\n")
 501     (cpp-make-button "[S]ave settings" 'cpp-edit-save)
 502     (insert "  ")
 503     (cpp-make-button "[L]oad settings" 'cpp-edit-load)
 504     (insert "\n\n")
 505
 506     (insert "[B]ackground: ")
 507     (cpp-make-button (car (rassq cpp-face-type cpp-face-type-list))
 508                      'cpp-edit-background)
 509     (insert "\n[K]nown conditionals: ")
 510     (cpp-make-button (cpp-face-name cpp-known-face)
 511                      'cpp-edit-known nil t)
 512     (insert " [X] ")
 513     (cpp-make-button (car (rassq cpp-known-writable cpp-writable-list))
 514                      'cpp-edit-toggle-known)
 515     (insert "\n[U]nknown conditionals: ")
 516     (cpp-make-button (cpp-face-name cpp-unknown-face)
 517                      'cpp-edit-unknown nil t)
 518     (insert " [Y] ")
 519     (cpp-make-button (car (rassq cpp-unknown-writable cpp-writable-list))
 520                      'cpp-edit-toggle-unknown)
 521     (insert (format "\n\n\n%39s: %14s %14s %7s\n\n" "Expression"
 522                     "[T]rue Face" "[F]alse Face" "[W]rite"))
 523
 524     (setq symbols (reverse symbols))
 525     (while symbols
 526       (let*  ((symbol (car symbols))
 527               (entry (assoc symbol cpp-edit-list))
 528               (true (nth 1 entry))
 529               (false (nth 2 entry))
 530               (write (if entry (nth 3 entry) 'both)))
 531         (setq symbols (cdr symbols))
 532
 533         (if (and entry                  ; Make default entries unknown.
 534                  (or (null true) (eq true 'default))
 535                  (or (null false) (eq false 'default))
 536                  (eq write 'both))
 537             (setq cpp-edit-list (delq entry cpp-edit-list)
 538                   entry nil))
 539
 540         (if (> (length symbol) 39)
 541             (insert (substring symbol 0 39) ": ")
 542           (insert (format "%39s: " symbol)))
 543
 544         (cpp-make-button (cpp-face-name true)
 545                          'cpp-edit-true symbol t 14)
 546         (insert " ")
 547         (cpp-make-button (cpp-face-name false)
 548                          'cpp-edit-false symbol t 14)
 549         (insert " ")
 550         (cpp-make-button (car (rassq write cpp-branch-list))
 551                          'cpp-edit-write symbol nil 6)
 552         (insert "\n")))
 553     (insert "\n\n")
 554     (set-window-start nil start)
 555     (goto-char pos)))
 556
 557 (defun cpp-edit-load ()
 558   "Load cpp configuration."
 559   (interactive)
 560   (cond ((null init-file-user)
 561          ;; If -q was specified, don't load any init files.
 562          nil)
 563         ((file-readable-p cpp-config-file)
 564          (load-file cpp-config-file))
 565         ((file-readable-p (concat "~/" cpp-config-file))
 566          (load-file cpp-config-file)))
 567   (if (derived-mode-p 'cpp-edit-mode)
 568       (cpp-edit-reset)))
 569
 570 (defun cpp-edit-save ()
 571   "Save the current cpp configuration in a file."
 572   (interactive)
 573   (require 'pp)
 574   (with-current-buffer cpp-edit-buffer
 575     (let ((buffer (find-file-noselect cpp-config-file)))
 576       (set-buffer buffer)
 577       (erase-buffer)
 578       (pp (list 'setq 'cpp-known-face
 579                 (list 'quote cpp-known-face)) buffer)
 580       (pp (list 'setq 'cpp-unknown-face
 581                 (list 'quote cpp-unknown-face)) buffer)
 582       (pp (list 'setq 'cpp-face-type
 583                 (list 'quote cpp-face-type)) buffer)
 584       (pp (list 'setq 'cpp-known-writable
 585                 (list 'quote cpp-known-writable)) buffer)
 586       (pp (list 'setq 'cpp-unknown-writable
 587                 (list 'quote cpp-unknown-writable)) buffer)
 588       (pp (list 'setq 'cpp-edit-list
 589                 (list 'quote cpp-edit-list)) buffer)
 590       (write-file cpp-config-file))))
 591
 592 (defun cpp-edit-home ()
 593   "Switch back to original buffer."
 594   (interactive)
 595   (if cpp-button-event
 596       (read-event))
 597   (pop-to-buffer cpp-edit-buffer))
 598
 599 (defun cpp-edit-background ()
 600   "Change default face collection."
 601   (interactive)
 602   (call-interactively 'cpp-choose-default-face)
 603   (cpp-edit-reset))
 604
 605 (defun cpp-edit-known ()
 606   "Select default for known conditionals."
 607   (interactive)
 608   (setq cpp-known-face (cpp-choose-face "Known face" cpp-known-face))
 609   (cpp-edit-reset))
 610
 611 (defun cpp-edit-unknown ()
 612   "Select default for unknown conditionals."
 613   (interactive)
 614   (setq cpp-unknown-face (cpp-choose-face "Unknown face" cpp-unknown-face))
 615   (cpp-edit-reset))
 616
 617 (defun cpp-edit-toggle-known (arg)
 618   "Toggle writable status for known conditionals.
 619 With optional argument ARG, make them writable if ARG is positive,
 620 otherwise make them unwritable."
 621   (interactive "@P")
 622   (if (or (and (null arg) cpp-known-writable)
 623           (<= (prefix-numeric-value arg) 0))
 624       (setq cpp-known-writable nil)
 625     (setq cpp-known-writable t))
 626   (cpp-edit-reset))
 627
 628 (defun cpp-edit-toggle-unknown (arg)
 629   "Toggle writable status for unknown conditionals.
 630 With optional argument ARG, make them writable if ARG is positive,
 631 otherwise make them unwritable."
 632   (interactive "@P")
 633   (if (or (and (null arg) cpp-unknown-writable)
 634           (<= (prefix-numeric-value arg) 0))
 635       (setq cpp-unknown-writable nil)
 636     (setq cpp-unknown-writable t))
 637   (cpp-edit-reset))
 638
 639 (defun cpp-edit-true (symbol face)
 640   "Select SYMBOL's true FACE used for highlighting taken conditionals."
 641   (interactive
 642    (let ((symbol (cpp-choose-symbol)))
 643      (list symbol
 644            (cpp-choose-face "True face"
 645                             (nth 1 (assoc symbol cpp-edit-list))))))
 646   (setcar (nthcdr 1 (cpp-edit-list-entry-get-or-create symbol)) face)
 647   (cpp-edit-reset))
 648
 649 (defun cpp-edit-false (symbol face)
 650   "Select SYMBOL's false FACE used for highlighting untaken conditionals."
 651   (interactive
 652    (let ((symbol (cpp-choose-symbol)))
 653      (list symbol
 654            (cpp-choose-face "False face"
 655                             (nth 2 (assoc symbol cpp-edit-list))))))
 656   (setcar (nthcdr 2 (cpp-edit-list-entry-get-or-create symbol)) face)
 657   (cpp-edit-reset))
 658
 659 (defun cpp-edit-write (symbol branch)
 660   "Set which branches of SYMBOL should be writable to BRANCH.
 661 BRANCH should be either nil (false branch), t (true branch) or 'both."
 662   (interactive (list (cpp-choose-symbol) (cpp-choose-branch)))
 663   (setcar (nthcdr 3 (cpp-edit-list-entry-get-or-create symbol)) branch)
 664   (cpp-edit-reset))
 665
 666 (defun cpp-edit-list-entry-get-or-create (symbol)
 667   ;; Return the entry for SYMBOL in `cpp-edit-list'.
 668   ;; If it does not exist, create it.
 669   (let ((entry (assoc symbol cpp-edit-list)))
 670     (or entry
 671         (setq entry (list symbol nil nil 'both nil)
 672               cpp-edit-list (cons entry cpp-edit-list)))
 673     entry))
 674
 675 ;;; Prompts:
 676
 677 (defun cpp-choose-symbol ()
 678   ;; Choose a symbol if called from keyboard, otherwise use the one clicked on.
 679   (if cpp-button-event
 680       cpp-callback-data
 681     (completing-read "Symbol: " cpp-edit-symbols nil t)))
 682
 683 (defun cpp-choose-branch ()
 684   ;; Choose a branch, either nil, t, or both.
 685   (if cpp-button-event
 686       (x-popup-menu cpp-button-event
 687                     (list "Branch" (cons "Branch" cpp-branch-list)))
 688     (cdr (assoc (completing-read "Branch: " cpp-branch-list nil t)
 689                 cpp-branch-list))))
 690
 691 (defun cpp-choose-face (prompt default)
 692   ;; Choose a face from cpp-face-default-list.
 693   ;; PROMPT is what to say to the user.
 694   ;; DEFAULT is the default face.
 695   (or (if cpp-button-event
 696           (x-popup-menu cpp-button-event
 697                         (list prompt (cons prompt cpp-face-default-list)))
 698         (let ((name (car (rassq default cpp-face-default-list))))
 699           (cdr (assoc (completing-read (if name
 700                                            (concat prompt
 701                                                    " (default " name "): ")
 702                                          (concat prompt ": "))
 703                                        cpp-face-default-list nil t)
 704                       cpp-face-all-list))))
 705       default))
 706
 707 (defun cpp-choose-default-face (type)
 708   ;; Choose default face list for screen of TYPE.
 709   ;; Type must be one of the types defined in `cpp-face-type-list'.
 710   (interactive (list (if cpp-button-event
 711                          (x-popup-menu cpp-button-event
 712                                        (list "Screen type"
 713                                              (cons "Screen type"
 714                                                    cpp-face-type-list)))
 715                        (cdr (assoc (completing-read "Screen type: "
 716                                                     cpp-face-type-list
 717                                                     nil t)
 718                                    cpp-face-type-list)))))
 719   (cond ((null type))
 720         ((eq type 'light)
 721          (if cpp-face-light-list
 722              ()
 723            (setq cpp-face-light-list
 724                  (mapcar 'cpp-create-bg-face cpp-face-light-name-list))
 725            (setq cpp-face-all-list
 726                  (append cpp-face-all-list cpp-face-light-list)))
 727          (setq cpp-face-type 'light)
 728          (setq cpp-face-default-list
 729                (append cpp-face-light-list cpp-face-none-list)))
 730         ((eq type 'dark)
 731          (if cpp-face-dark-list
 732              ()
 733            (setq cpp-face-dark-list
 734                  (mapcar 'cpp-create-bg-face cpp-face-dark-name-list))
 735            (setq cpp-face-all-list
 736                  (append cpp-face-all-list cpp-face-dark-list)))
 737          (setq cpp-face-type 'dark)
 738          (setq cpp-face-default-list
 739                (append cpp-face-dark-list cpp-face-none-list)))
 740         ((eq type 'mono)
 741          (setq cpp-face-type 'mono)
 742          (setq cpp-face-default-list
 743                (append cpp-face-mono-list cpp-face-none-list)))
 744         (t
 745          (setq cpp-face-type 'none)
 746          (setq cpp-face-default-list cpp-face-none-list))))
 747
 748 ;;; Buttons:
 749
 750 (defun cpp-make-button (name callback &optional data face padding)
 751   ;; Create a button at point.
 752   ;; NAME is the name of the button.
 753   ;; CALLBACK is the function to call when the button is pushed.
 754   ;; DATA will be made available to CALLBACK
 755   ;;in the free variable cpp-callback-data.
 756   ;; FACE means that NAME is the name of a face in `cpp-face-all-list'.
 757   ;; PADDING means NAME will be right justified at that length.
 758   (let ((name (format "%s" name))
 759         from to)
 760     (cond ((null padding)
 761            (setq from (point))
 762            (insert name))
 763           ((> (length name) padding)
 764            (setq from (point))
 765            (insert (substring name 0 padding)))
 766           (t
 767            (insert (make-string (- padding (length name)) ? ))
 768            (setq from (point))
 769            (insert name)))
 770     (setq to (point))
 771     (setq face
 772           (if face
 773               (let ((check (cdr (assoc name cpp-face-all-list))))
 774                 (if (memq check '(default invisible))
 775                     'bold
 776                   check))
 777             'bold))
 778     (add-text-properties from to
 779                          (append (list 'face face)
 780                                  '(mouse-face highlight)
 781                                  '(help-echo "mouse-2: change/use this item")
 782                                  (list 'cpp-callback callback)
 783                                  (if data (list 'cpp-data data))))))
 784
 785 (defun cpp-push-button (event)
 786   ;; Pushed a CPP button.
 787   (interactive "@e")
 788   (set-buffer (window-buffer (posn-window (event-start event))))
 789   (let ((pos (posn-point (event-start event))))
 790     (let ((cpp-callback-data (get-text-property pos 'cpp-data))
 791           (fun (get-text-property pos 'cpp-callback))
 792           (cpp-button-event event))
 793       (cond (fun
 794              (call-interactively (get-text-property pos 'cpp-callback)))
 795             ((lookup-key global-map [ down-mouse-2])
 796              (call-interactively (lookup-key global-map [ down-mouse-2])))))))
 797
 798 ;;; Faces:
 799
 800 (defun cpp-create-bg-face (color)
 801   ;; Create entry for face with background COLOR.
 802   (cons color (cons 'background-color color)))
 803
 804 (cpp-choose-default-face
 805  (if (or window-system (display-color-p)) cpp-face-type 'none))
 806
 807 (defun cpp-face-name (face)
 808   ;; Return the name of FACE from `cpp-face-all-list'.
 809   (let ((entry (rassq (if face face 'default) cpp-face-all-list)))
 810     (if entry
 811         (car entry)
 812       (format "<%s>" face))))
 813
 814 ;;; Utilities:
 815
 816 (defvar cpp-progress-time 0)
 817 ;; Last time we issued a progress message.
 818
 819 (defun cpp-progress-message (&rest args)
 820   ;; Report progress at most once a second.  Take same ARGS as `message'.
 821   (let ((time (nth 1 (current-time))))
 822     (if (= time cpp-progress-time)
 823         ()
 824       (setq cpp-progress-time time)
 825       (apply 'message args))))
 826
 827 (provide 'cpp)
 828
 829 ;;; cpp.el ends here