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