lisp/progmodes/cpp.el

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