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

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