lisp/progmodes/cpp.el

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