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