1 ;;; cpp.el --- Highlight or hide text according to cpp conditionals.
3 ;; Copyright (C) 1994, 1995 Free Software Foundation
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Keywords: c, faces, tools
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 ;; Parse a text for C preprocessor conditionals, and highlight or hide
28 ;; the text inside the conditionals as you wish.
30 ;; This package is inspired by Jim Coplien's delta editor for SCCS.
34 ;; Should parse "#if" and "#elif" expressions and merge the faces
37 ;; Somehow it is sometimes possible to make changes near a read only
38 ;; area which you can't undo. Their are other strange effects in that
41 ;; The Edit buffer should -- optionally -- appear in its own frame.
43 ;; Conditionals seem to be rear-sticky. They shouldn't be.
45 ;; Restore window configurations when exiting CPP Edit buffer.
51 "Highlight or hide text according to cpp conditionals."
55 (defcustom cpp-config-file
(convert-standard-filename ".cpp.el")
56 "*File name to save cpp configuration."
60 (defcustom cpp-known-face
'invisible
61 "*Face used for known cpp symbols."
65 (defcustom cpp-unknown-face
'highlight
66 "*Face used for unknown cpp symbols."
70 (defcustom cpp-face-type
'light
71 "*Indicate what background face type you prefer.
72 Can be either light or dark for color screens, mono for monochrome
73 screens, and none if you don't use a window system and don't have
74 a color-capable display."
75 :options
'(light dark mono nil
)
79 (defcustom cpp-known-writable t
80 "*Non-nil means you are allowed to modify the known conditionals."
84 (defcustom cpp-unknown-writable t
85 "*Non-nil means you are allowed to modify the unknown conditionals."
89 (defcustom cpp-edit-list nil
90 "Alist of cpp macros and information about how they should be displayed.
91 Each entry is a list with the following elements:
92 0. The name of the macro (a string).
93 1. Face used for text that is `ifdef' the macro.
94 2. Face used for text that is `ifndef' the macro.
95 3. `t', `nil', or `both' depending on what text may be edited."
96 :type
'(repeat (list string face face
102 (defvar cpp-overlay-list nil
)
103 ;; List of cpp overlays active in the current buffer.
104 (make-variable-buffer-local 'cpp-overlay-list
)
106 (defvar cpp-callback-data
)
107 (defvar cpp-state-stack
)
109 (defconst cpp-face-type-list
110 '(("light color background" . light
)
111 ("dark color background" . dark
)
112 ("monochrome" . mono
)
114 "Alist of strings and names of the defined face collections.")
116 (defconst cpp-writable-list
117 ;; Names used for the writable property.
119 ("read-only" . nil
)))
121 (defvar cpp-button-event nil
)
122 ;; This will be t in the callback for `cpp-make-button'.
124 (defvar cpp-edit-buffer nil
)
125 ;; Real buffer whose cpp display information we are editing.
126 (make-variable-buffer-local 'cpp-edit-buffer
)
128 (defconst cpp-branch-list
129 ;; Alist of branches.
134 (defcustom cpp-face-default-list nil
135 "Alist of faces you can choose from for cpp conditionals.
136 Each element has the form (STRING . FACE), where STRING
137 serves as a name (for `cpp-highlight-buffer' only)
138 and FACE is either a face (a symbol)
139 or a cons cell (background-color . COLOR)."
140 :type
'(repeat (cons string
(choice face
(cons (const background-color
) string
))))
143 (defcustom cpp-face-light-name-list
144 '("light gray" "light blue" "light cyan" "light yellow" "light pink"
145 "pale green" "beige" "orange" "magenta" "violet" "medium purple"
147 "Background colours useful with dark foreground colors."
148 :type
'(repeat string
)
151 (defcustom cpp-face-dark-name-list
152 '("dim gray" "blue" "cyan" "yellow" "red"
153 "dark green" "brown" "dark orange" "dark khaki" "dark violet" "purple"
155 "Background colours useful with light foreground colors."
156 :type
'(repeat string
)
159 (defcustom cpp-face-light-list nil
160 "Alist of names and faces to be used for light backgrounds."
161 :type
'(repeat (cons string
(choice face
162 (cons (const background-color
) string
))))
165 (defcustom cpp-face-dark-list nil
166 "Alist of names and faces to be used for dark backgrounds."
167 :type
'(repeat (cons string
(choice face
168 (cons (const background-color
) string
))))
171 (defcustom cpp-face-mono-list
173 ("bold-italic" . bold-italic
)
175 ("underline" . underline
))
176 "Alist of names and faces to be used for monochrome screens."
177 :type
'(repeat (cons string face
))
180 (defcustom cpp-face-none-list
181 '(("default" . default
)
182 ("invisible" . invisible
))
183 "Alist of names and faces available even if you don't use a window system."
184 :type
'(repeat (cons string face
))
187 (defvar cpp-face-all-list
188 (append cpp-face-light-list
192 "All faces used for highlighting text inside cpp conditionals.")
196 (defvar cpp-parse-symbols nil
197 "List of cpp macros used in the local buffer.")
198 (make-variable-buffer-local 'cpp-parse-symbols
)
200 (defconst cpp-parse-regexp
201 ;; Regexp matching all tokens needed to find conditionals.
203 "'\\|\"\\|/\\*\\|//\\|"
204 "\\(^[ \t]*#[ \t]*\\(ifdef\\|ifndef\\|if\\|"
205 "elif\\|else\\|endif\\)\\b\\)"))
208 (defun cpp-highlight-buffer (arg)
209 "Highlight C code according to preprocessor conditionals.
210 This command pops up a buffer which you should edit to specify
211 what kind of highlighting to use, and the criteria for highlighting.
212 A prefix arg suppresses display of that buffer."
214 (unless (or (eq t buffer-invisibility-spec
)
215 (memq 'cpp buffer-invisibility-spec
))
216 (add-to-invisibility-spec 'cpp
))
217 (setq cpp-parse-symbols nil
)
219 (if (null cpp-edit-list
)
221 (let (cpp-state-stack)
223 (goto-char (point-min))
224 (cpp-progress-message "Parsing...")
225 (while (re-search-forward cpp-parse-regexp nil t
)
226 (cpp-progress-message "Parsing...%d%%"
227 (/ (* 100 (- (point) (point-min))) (buffer-size)))
228 (let ((match (buffer-substring (match-beginning 0) (match-end 0))))
229 (cond ((or (string-equal match
"'")
230 (string-equal match
"\""))
231 (goto-char (match-beginning 0))
234 (error (cpp-parse-error
235 "Unterminated string or character"))))
236 ((string-equal match
"/*")
237 (or (search-forward "*/" nil t
)
238 (error "Unterminated comment")))
239 ((string-equal match
"//")
240 (skip-chars-forward "^\n\r"))
243 (let ((from (match-beginning 1))
245 (type (buffer-substring (match-beginning 2)
247 (expr (buffer-substring (match-end 1) (point))))
248 (cond ((string-equal type
"ifdef")
249 (cpp-parse-open t expr from to
))
250 ((string-equal type
"ifndef")
251 (cpp-parse-open nil expr from to
))
252 ((string-equal type
"if")
253 (cpp-parse-open t expr from to
))
254 ((string-equal type
"elif")
255 (let (cpp-known-face cpp-unknown-face
)
256 (cpp-parse-close from to
))
257 (cpp-parse-open t expr from to
))
258 ((string-equal type
"else")
260 (cpp-parse-error "Top level #else"))
261 (let ((entry (list (not (nth 0 (car cpp-state-stack
)))
262 (nth 1 (car cpp-state-stack
))
264 (cpp-parse-close from to
)
265 (setq cpp-state-stack
(cons entry cpp-state-stack
))))
266 ((string-equal type
"endif")
267 (cpp-parse-close from to
))
269 (cpp-parse-error "Parser error"))))))))
270 (message "Parsing...done"))
273 (goto-char (nth 3 (car cpp-state-stack
)))
274 (cpp-parse-error "Unclosed conditional"))))
276 (null cpp-parse-symbols
)
279 (defun cpp-parse-open (branch expr begin end
)
280 "Push information about conditional-beginning onto `cpp-state-stack'."
281 ;; Discard comments within this line.
282 (while (string-match "\\b[ \t]*/\\*.*\\*/[ \t]*\\b" expr
)
283 (setq expr
(concat (substring expr
0 (match-beginning 0))
284 (substring expr
(match-end 0)))))
285 ;; If a comment starts on this line and continues past, discard it.
286 (if (string-match "\\b[ \t]*/\\*" expr
)
287 (setq expr
(substring expr
0 (match-beginning 0))))
288 ;; Delete any C++ comment from the line.
289 (if (string-match "\\b[ \t]*\\(//.*\\)?$" expr
)
290 (setq expr
(substring expr
0 (match-beginning 0))))
291 (while (string-match "[ \t]+" expr
)
292 (setq expr
(concat (substring expr
0 (match-beginning 0))
293 (substring expr
(match-end 0)))))
294 (setq cpp-state-stack
(cons (list branch expr begin end
) cpp-state-stack
))
295 (or (member expr cpp-parse-symbols
)
296 (setq cpp-parse-symbols
297 (cons expr cpp-parse-symbols
)))
298 (if (assoc expr cpp-edit-list
)
299 (cpp-make-known-overlay begin end
)
300 (cpp-make-unknown-overlay begin end
)))
302 (defun cpp-parse-close (from to
)
303 ;; Pop top of cpp-state-stack and create overlay.
304 (let ((entry (assoc (nth 1 (car cpp-state-stack
)) cpp-edit-list
))
305 (branch (nth 0 (car cpp-state-stack
)))
306 (begin (nth 2 (car cpp-state-stack
)))
307 (end (nth 3 (car cpp-state-stack
))))
308 (setq cpp-state-stack
(cdr cpp-state-stack
))
310 (let ((face (nth (if branch
1 2) entry
))
311 (read-only (eq (not branch
) (nth 3 entry
)))
312 (priority (length cpp-state-stack
))
313 (overlay (make-overlay end from
)))
314 (cpp-make-known-overlay from to
)
315 (setq cpp-overlay-list
(cons overlay cpp-overlay-list
))
316 (if priority
(overlay-put overlay
'priority priority
))
317 (cond ((eq face
'invisible
)
318 (cpp-make-overlay-hidden overlay
))
321 (overlay-put overlay
'face face
)))
323 (cpp-make-overlay-read-only overlay
)
324 (cpp-make-overlay-sticky overlay
)))
325 (cpp-make-unknown-overlay from to
))))
327 (defun cpp-parse-error (error)
328 ;; Error message issued by the cpp parser.
329 (error "%s at line %d" error
(count-lines (point-min) (point))))
331 (defun cpp-parse-reset ()
332 "Reset display of cpp conditionals to normal."
334 (while cpp-overlay-list
335 (delete-overlay (car cpp-overlay-list
))
336 (setq cpp-overlay-list
(cdr cpp-overlay-list
))))
339 (defun cpp-parse-edit ()
340 "Edit display information for cpp conditionals."
342 (or cpp-parse-symbols
343 (cpp-highlight-buffer t
))
344 (let ((buffer (current-buffer)))
345 (pop-to-buffer "*CPP Edit*")
347 (setq cpp-edit-buffer buffer
)
352 (defun cpp-make-known-overlay (start end
)
353 ;; Create an overlay for a known cpp command from START to END.
354 (let ((overlay (make-overlay start end
)))
355 (if (eq cpp-known-face
'invisible
)
356 (cpp-make-overlay-hidden overlay
)
357 (or (eq cpp-known-face
'default
)
358 (overlay-put overlay
'face cpp-known-face
))
359 (if cpp-known-writable
361 (overlay-put overlay
'modification-hooks
'(cpp-signal-read-only))
362 (overlay-put overlay
'insert-in-front-hooks
'(cpp-signal-read-only))))
363 (setq cpp-overlay-list
(cons overlay cpp-overlay-list
))))
365 (defun cpp-make-unknown-overlay (start end
)
366 ;; Create an overlay for an unknown cpp command from START to END.
367 (let ((overlay (make-overlay start end
)))
368 (cond ((eq cpp-unknown-face
'invisible
)
369 (cpp-make-overlay-hidden overlay
))
370 ((eq cpp-unknown-face
'default
))
372 (overlay-put overlay
'face cpp-unknown-face
)))
373 (if cpp-unknown-writable
375 (overlay-put overlay
'modification-hooks
'(cpp-signal-read-only))
376 (overlay-put overlay
'insert-in-front-hooks
'(cpp-signal-read-only)))
377 (setq cpp-overlay-list
(cons overlay cpp-overlay-list
))))
379 (defun cpp-make-overlay-hidden (overlay)
380 ;; Make overlay hidden and intangible.
381 (overlay-put overlay
'invisible
'cpp
)
382 (overlay-put overlay
'intangible t
)
383 ;; Unfortunately `intangible' is not implemented for overlays yet,
384 ;; so we make is read-only instead.
385 (overlay-put overlay
'modification-hooks
'(cpp-signal-read-only))
386 (overlay-put overlay
'insert-in-front-hooks
'(cpp-signal-read-only)))
388 (defun cpp-make-overlay-read-only (overlay)
389 ;; Make overlay read only.
390 (overlay-put overlay
'modification-hooks
'(cpp-signal-read-only))
391 (overlay-put overlay
'insert-in-front-hooks
'(cpp-signal-read-only))
392 (overlay-put overlay
'insert-behind-hooks
'(cpp-signal-read-only)))
394 (defun cpp-make-overlay-sticky (overlay)
395 ;; Make OVERLAY grow when you insert text at either end.
396 (overlay-put overlay
'insert-in-front-hooks
'(cpp-grow-overlay))
397 (overlay-put overlay
'insert-behind-hooks
'(cpp-grow-overlay)))
399 (defun cpp-signal-read-only (overlay after start end
&optional len
)
400 ;; Only allow deleting the whole overlay.
401 ;; Trying to change a read-only overlay.
403 (or (< (overlay-start overlay
) start
)
404 (> (overlay-end overlay
) end
)))
405 (error "This text is read only")))
407 (defun cpp-grow-overlay (overlay after start end
&optional len
)
408 ;; Make OVERLAY grow to contain range START to END.
410 (move-overlay overlay
411 (min start
(overlay-start overlay
))
412 (max end
(overlay-end overlay
)))))
416 (defvar cpp-edit-map nil
)
417 ;; Keymap for `cpp-edit-mode'.
421 (setq cpp-edit-map
(make-keymap))
422 (suppress-keymap cpp-edit-map
)
423 (define-key cpp-edit-map
[ down-mouse-2
] 'cpp-push-button
)
424 (define-key cpp-edit-map
[ mouse-2
] 'ignore
)
425 (define-key cpp-edit-map
" " 'scroll-up
)
426 (define-key cpp-edit-map
"\C-?" 'scroll-down
)
427 (define-key cpp-edit-map
[ delete
] 'scroll-down
)
428 (define-key cpp-edit-map
"\C-c\C-c" 'cpp-edit-apply
)
429 (define-key cpp-edit-map
"a" 'cpp-edit-apply
)
430 (define-key cpp-edit-map
"A" 'cpp-edit-apply
)
431 (define-key cpp-edit-map
"r" 'cpp-edit-reset
)
432 (define-key cpp-edit-map
"R" 'cpp-edit-reset
)
433 (define-key cpp-edit-map
"s" 'cpp-edit-save
)
434 (define-key cpp-edit-map
"S" 'cpp-edit-save
)
435 (define-key cpp-edit-map
"l" 'cpp-edit-load
)
436 (define-key cpp-edit-map
"L" 'cpp-edit-load
)
437 (define-key cpp-edit-map
"h" 'cpp-edit-home
)
438 (define-key cpp-edit-map
"H" 'cpp-edit-home
)
439 (define-key cpp-edit-map
"b" 'cpp-edit-background
)
440 (define-key cpp-edit-map
"B" 'cpp-edit-background
)
441 (define-key cpp-edit-map
"k" 'cpp-edit-known
)
442 (define-key cpp-edit-map
"K" 'cpp-edit-known
)
443 (define-key cpp-edit-map
"u" 'cpp-edit-unknown
)
444 (define-key cpp-edit-map
"u" 'cpp-edit-unknown
)
445 (define-key cpp-edit-map
"t" 'cpp-edit-true
)
446 (define-key cpp-edit-map
"T" 'cpp-edit-true
)
447 (define-key cpp-edit-map
"f" 'cpp-edit-false
)
448 (define-key cpp-edit-map
"F" 'cpp-edit-false
)
449 (define-key cpp-edit-map
"w" 'cpp-edit-write
)
450 (define-key cpp-edit-map
"W" 'cpp-edit-write
)
451 (define-key cpp-edit-map
"X" 'cpp-edit-toggle-known
)
452 (define-key cpp-edit-map
"x" 'cpp-edit-toggle-known
)
453 (define-key cpp-edit-map
"Y" 'cpp-edit-toggle-unknown
)
454 (define-key cpp-edit-map
"y" 'cpp-edit-toggle-unknown
)
455 (define-key cpp-edit-map
"q" 'bury-buffer
)
456 (define-key cpp-edit-map
"Q" 'bury-buffer
))
458 (defvar cpp-edit-symbols nil
)
459 ;; Symbols defined in the edit buffer.
460 (make-variable-buffer-local 'cpp-edit-symbols
)
462 (defun cpp-edit-mode ()
463 "Major mode for editing the criteria for highlighting cpp conditionals.
464 Click on objects to change them.
465 You can also use the keyboard accelerators indicated like this: [K]ey."
466 (kill-all-local-variables)
467 (buffer-disable-undo)
469 (setq buffer-read-only t
)
470 (setq major-mode
'cpp-edit-mode
)
471 (setq mode-name
"CPP Edit")
472 (use-local-map cpp-edit-map
))
474 (defun cpp-edit-apply ()
475 "Apply edited display information to original buffer."
478 (cpp-highlight-buffer t
))
480 (defun cpp-edit-reset ()
481 "Reset display information from original buffer."
483 (let ((buffer (current-buffer))
484 (buffer-read-only nil
)
485 (start (window-start))
488 (set-buffer cpp-edit-buffer
)
489 (setq symbols cpp-parse-symbols
)
491 (setq cpp-edit-symbols symbols
)
493 (insert "CPP Display Information for `")
494 (cpp-make-button (buffer-name cpp-edit-buffer
) 'cpp-edit-home
)
495 (insert "'\n\nClick mouse-2 on item you want to change or use\n"
496 "or switch to this buffer and type the keyboard equivalents.\n"
497 "Keyboard equivalents are indicated with brackets like [T]his.\n\n")
498 (cpp-make-button "[H]ome (display the C file)" 'cpp-edit-home
)
500 (cpp-make-button "[A]pply new settings" 'cpp-edit-apply
)
502 (cpp-make-button "[S]ave settings" 'cpp-edit-save
)
504 (cpp-make-button "[L]oad settings" 'cpp-edit-load
)
507 (insert "[B]ackground: ")
508 (cpp-make-button (car (rassq cpp-face-type cpp-face-type-list
))
509 'cpp-edit-background
)
510 (insert "\n[K]nown conditionals: ")
511 (cpp-make-button (cpp-face-name cpp-known-face
)
512 'cpp-edit-known nil t
)
514 (cpp-make-button (car (rassq cpp-known-writable cpp-writable-list
))
515 'cpp-edit-toggle-known
)
516 (insert "\n[U]nknown conditionals: ")
517 (cpp-make-button (cpp-face-name cpp-unknown-face
)
518 'cpp-edit-unknown nil t
)
520 (cpp-make-button (car (rassq cpp-unknown-writable cpp-writable-list
))
521 'cpp-edit-toggle-unknown
)
522 (insert (format "\n\n\n%39s: %14s %14s %7s\n\n" "Expression"
523 "[T]rue Face" "[F]alse Face" "[W]rite"))
525 (let* ((symbol (car symbols
))
526 (entry (assoc symbol cpp-edit-list
))
528 (false (nth 2 entry
))
529 (write (if entry
(nth 3 entry
) 'both
)))
530 (setq symbols
(cdr symbols
))
532 (if (and entry
; Make default entries unknown.
533 (or (null true
) (eq true
'default
))
534 (or (null false
) (eq false
'default
))
536 (setq cpp-edit-list
(delq entry cpp-edit-list
)
539 (if (> (length symbol
) 39)
540 (insert (substring symbol
0 39) ": ")
541 (insert (format "%39s: " symbol
)))
543 (cpp-make-button (cpp-face-name true
)
544 'cpp-edit-true symbol t
14)
546 (cpp-make-button (cpp-face-name false
)
547 'cpp-edit-false symbol t
14)
549 (cpp-make-button (car (rassq write cpp-branch-list
))
550 'cpp-edit-write symbol nil
6)
553 (set-window-start nil start
)
556 (defun cpp-edit-load ()
557 "Load cpp configuration."
559 (cond ((null init-file-user
)
560 ;; If -q was specified, don't load any init files.
562 ((file-readable-p cpp-config-file
)
563 (load-file cpp-config-file
))
564 ((file-readable-p (concat "~/" cpp-config-file
))
565 (load-file cpp-config-file
)))
566 (if (eq major-mode
'cpp-edit-mode
)
569 (defun cpp-edit-save ()
570 "Save the current cpp configuration in a file."
574 (set-buffer cpp-edit-buffer
)
575 (let ((buffer (find-file-noselect cpp-config-file
)))
578 (pp (list 'setq
'cpp-known-face
579 (list 'quote cpp-known-face
)) buffer
)
580 (pp (list 'setq
'cpp-unknown-face
581 (list 'quote cpp-unknown-face
)) buffer
)
582 (pp (list 'setq
'cpp-face-type
583 (list 'quote cpp-face-type
)) buffer
)
584 (pp (list 'setq
'cpp-known-writable
585 (list 'quote cpp-known-writable
)) buffer
)
586 (pp (list 'setq
'cpp-unknown-writable
587 (list 'quote cpp-unknown-writable
)) buffer
)
588 (pp (list 'setq
'cpp-edit-list
589 (list 'quote cpp-edit-list
)) buffer
)
590 (write-file cpp-config-file
))))
592 (defun cpp-edit-home ()
593 "Switch back to original buffer."
597 (pop-to-buffer cpp-edit-buffer
))
599 (defun cpp-edit-background ()
600 "Change default face collection."
602 (call-interactively 'cpp-choose-default-face
)
605 (defun cpp-edit-known ()
606 "Select default for known conditionals."
608 (setq cpp-known-face
(cpp-choose-face "Known face" cpp-known-face
))
611 (defun cpp-edit-unknown ()
612 "Select default for unknown conditionals."
614 (setq cpp-unknown-face
(cpp-choose-face "Unknown face" cpp-unknown-face
))
617 (defun cpp-edit-toggle-known (arg)
618 "Toggle writable status for known conditionals.
619 With optional argument ARG, make them writable iff ARG is positive."
621 (if (or (and (null arg
) cpp-known-writable
)
622 (<= (prefix-numeric-value arg
) 0))
623 (setq cpp-known-writable nil
)
624 (setq cpp-known-writable t
))
627 (defun cpp-edit-toggle-unknown (arg)
628 "Toggle writable status for unknown conditionals.
629 With optional argument ARG, make them writable iff ARG is positive."
631 (if (or (and (null arg
) cpp-unknown-writable
)
632 (<= (prefix-numeric-value arg
) 0))
633 (setq cpp-unknown-writable nil
)
634 (setq cpp-unknown-writable t
))
637 (defun cpp-edit-true (symbol face
)
638 "Select SYMBOL's true FACE used for highlighting taken conditionals."
640 (let ((symbol (cpp-choose-symbol)))
642 (cpp-choose-face "True face"
643 (nth 1 (assoc symbol cpp-edit-list
))))))
644 (setcar (nthcdr 1 (cpp-edit-list-entry-get-or-create symbol
)) face
)
647 (defun cpp-edit-false (symbol face
)
648 "Select SYMBOL's false FACE used for highlighting untaken conditionals."
650 (let ((symbol (cpp-choose-symbol)))
652 (cpp-choose-face "False face"
653 (nth 2 (assoc symbol cpp-edit-list
))))))
654 (setcar (nthcdr 2 (cpp-edit-list-entry-get-or-create symbol
)) face
)
657 (defun cpp-edit-write (symbol branch
)
658 "Set which branches of SYMBOL should be writable to BRANCH.
659 BRANCH should be either nil (false branch), t (true branch) or 'both."
660 (interactive (list (cpp-choose-symbol) (cpp-choose-branch)))
661 (setcar (nthcdr 3 (cpp-edit-list-entry-get-or-create symbol
)) branch
)
664 (defun cpp-edit-list-entry-get-or-create (symbol)
665 ;; Return the entry for SYMBOL in `cpp-edit-list'.
666 ;; If it does not exist, create it.
667 (let ((entry (assoc symbol cpp-edit-list
)))
669 (setq entry
(list symbol nil nil
'both nil
)
670 cpp-edit-list
(cons entry cpp-edit-list
)))
675 (defun cpp-choose-symbol ()
676 ;; Choose a symbol if called from keyboard, otherwise use the one clicked on.
679 (completing-read "Symbol: " (mapcar 'list cpp-edit-symbols
) nil t
)))
681 (defun cpp-choose-branch ()
682 ;; Choose a branch, either nil, t, or both.
684 (x-popup-menu cpp-button-event
685 (list "Branch" (cons "Branch" cpp-branch-list
)))
686 (cdr (assoc (completing-read "Branch: " cpp-branch-list nil t
)
689 (defun cpp-choose-face (prompt default
)
690 ;; Choose a face from cpp-face-defalt-list.
691 ;; PROMPT is what to say to the user.
692 ;; DEFAULT is the default face.
693 (or (if cpp-button-event
694 (x-popup-menu cpp-button-event
695 (list prompt
(cons prompt cpp-face-default-list
)))
696 (let ((name (car (rassq default cpp-face-default-list
))))
697 (cdr (assoc (completing-read (if name
699 " (default " name
"): ")
700 (concat prompt
": "))
701 cpp-face-default-list nil t
)
702 cpp-face-all-list
))))
705 (defun cpp-choose-default-face (type)
706 ;; Choose default face list for screen of TYPE.
707 ;; Type must be one of the types defined in `cpp-face-type-list'.
708 (interactive (list (if cpp-button-event
709 (x-popup-menu cpp-button-event
712 cpp-face-type-list
)))
713 (cdr (assoc (completing-read "Screen type: "
716 cpp-face-type-list
)))))
719 (if cpp-face-light-list
721 (setq cpp-face-light-list
722 (mapcar 'cpp-create-bg-face cpp-face-light-name-list
))
723 (setq cpp-face-all-list
724 (append cpp-face-all-list cpp-face-light-list
)))
725 (setq cpp-face-type
'light
)
726 (setq cpp-face-default-list
727 (append cpp-face-light-list cpp-face-none-list
)))
729 (if cpp-face-dark-list
731 (setq cpp-face-dark-list
732 (mapcar 'cpp-create-bg-face cpp-face-dark-name-list
))
733 (setq cpp-face-all-list
734 (append cpp-face-all-list cpp-face-dark-list
)))
735 (setq cpp-face-type
'dark
)
736 (setq cpp-face-default-list
737 (append cpp-face-dark-list cpp-face-none-list
)))
739 (setq cpp-face-type
'mono
)
740 (setq cpp-face-default-list
741 (append cpp-face-mono-list cpp-face-none-list
)))
743 (setq cpp-face-type
'none
)
744 (setq cpp-face-default-list cpp-face-none-list
))))
748 (defun cpp-make-button (name callback
&optional data face padding
)
749 ;; Create a button at point.
750 ;; NAME is the name of the button.
751 ;; CALLBACK is the function to call when the button is pushed.
752 ;; DATA will be made available to CALLBACK
753 ;;in the free variable cpp-callback-data.
754 ;; FACE means that NAME is the name of a face in `cpp-face-all-list'.
755 ;; PADDING means NAME will be right justified at that length.
756 (let ((name (format "%s" name
))
758 (cond ((null padding
)
761 ((> (length name
) padding
)
763 (insert (substring name
0 padding
)))
765 (insert (make-string (- padding
(length name
)) ?
))
771 (let ((check (cdr (assoc name cpp-face-all-list
))))
772 (if (memq check
'(default invisible
))
776 (add-text-properties from to
777 (append (list 'face face
)
778 '(mouse-face highlight
)
779 (list 'cpp-callback callback
)
780 (if data
(list 'cpp-data data
))))))
782 (defun cpp-push-button (event)
783 ;; Pushed a CPP button.
785 (set-buffer (window-buffer (posn-window (event-start event
))))
786 (let ((pos (posn-point (event-start event
))))
787 (let ((cpp-callback-data (get-text-property pos
'cpp-data
))
788 (fun (get-text-property pos
'cpp-callback
))
789 (cpp-button-event event
))
791 (call-interactively (get-text-property pos
'cpp-callback
)))
792 ((lookup-key global-map
[ down-mouse-2
])
793 (call-interactively (lookup-key global-map
[ down-mouse-2
])))))))
797 (defun cpp-create-bg-face (color)
798 ;; Create entry for face with background COLOR.
799 (cons color
(cons 'background-color color
)))
801 (cpp-choose-default-face
802 (if (or window-system
(display-color-p)) cpp-face-type
'none
))
804 (defun cpp-face-name (face)
805 ;; Return the name of FACE from `cpp-face-all-list'.
806 (let ((entry (rassq (if face face
'default
) cpp-face-all-list
)))
809 (format "<%s>" face
))))
813 (defvar cpp-progress-time
0)
814 ;; Last time we issued a progress message.
816 (defun cpp-progress-message (&rest args
)
817 ;; Report progress at most once a second. Take same ARGS as `message'.
818 (let ((time (nth 1 (current-time))))
819 (if (= time cpp-progress-time
)
821 (setq cpp-progress-time time
)
822 (apply 'message args
))))