lisp/progmodes/cpp.el

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