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