Commit | Line | Data |
---|---|---|
e8af40ee | 1 | ;;; tcl.el --- Tcl code editing commands for Emacs |
9875e646 | 2 | |
4e643dd2 | 3 | ;; Copyright (C) 1994, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 |
4c5113c7 | 4 | ;; Free Software Foundation, Inc. |
9875e646 | 5 | |
2c7cdd69 | 6 | ;; Maintainer: FSF |
0472b23e | 7 | ;; Author: Tom Tromey <tromey@redhat.com> |
db2e9cdd TT |
8 | ;; Chris Lindblad <cjl@lcs.mit.edu> |
9 | ;; Keywords: languages tcl modes | |
9875e646 TT |
10 | |
11 | ;; This file is part of GNU Emacs. | |
12 | ||
b1fc2b50 | 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
9875e646 | 14 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
15 | ;; the Free Software Foundation, either version 3 of the License, or |
16 | ;; (at your option) any later version. | |
9875e646 TT |
17 | |
18 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 | ;; GNU General Public License for more details. | |
22 | ||
23 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
9875e646 | 25 | |
2f585cfe | 26 | ;; BEFORE USE: |
9875e646 TT |
27 | ;; |
28 | ;; If you plan to use the interface to the TclX help files, you must | |
95338744 TT |
29 | ;; set the variable tcl-help-directory-list to point to the topmost |
30 | ;; directories containing the TclX help files. Eg: | |
9875e646 | 31 | ;; |
95338744 | 32 | ;; (setq tcl-help-directory-list '("/usr/local/lib/tclx/help")) |
9875e646 | 33 | ;; |
9875e646 TT |
34 | ;;; Commentary: |
35 | ||
9875e646 TT |
36 | ;; CUSTOMIZATION NOTES: |
37 | ;; * tcl-proc-list can be used to customize a list of things that | |
38 | ;; "define" other things. Eg in my project I put "defvar" in this | |
39 | ;; list. | |
40 | ;; * tcl-typeword-list is similar, but uses font-lock-type-face. | |
41 | ;; * tcl-keyword-list is a list of keywords. I've generally used this | |
42 | ;; for flow-control words. Eg I add "unwind_protect" to this list. | |
d6d43bde | 43 | ;; * tcl-builtin-list lists commands to be given font-lock-builtin-face. |
9875e646 TT |
44 | ;; * tcl-type-alist can be used to minimally customize indentation |
45 | ;; according to context. | |
46 | ||
94662de7 | 47 | ;; THANKS FOR CRITICISM AND SUGGESTIONS TO: |
9875e646 TT |
48 | ;; Guido Bosch <Guido.Bosch@loria.fr> |
49 | ;; pgs1002@esc.cam.ac.uk (Dr P.G. Sjoerdsma) | |
50 | ;; Mike Scheidler <c23mts@kocrsv01.delcoelect.com> | |
51 | ;; Matt Newman <men@charney.colorado.edu> | |
52 | ;; rwhitby@research.canon.oz.au (Rod Whitby) | |
53 | ;; h9118101@hkuxa.hku.hk (Yip Chi Lap [Beta]) | |
54 | ;; Pertti Tapio Kasanen <ptk@delta.hut.fi> | |
55 | ;; schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid) | |
597c7ed5 TT |
56 | ;; warsaw@nlm.nih.gov (Barry A. Warsaw) |
57 | ;; Carl Witty <cwitty@ai.mit.edu> | |
3530a317 | 58 | ;; T. V. Raman <raman@crl.dec.com> |
50776640 | 59 | ;; Jesper Pedersen <blackie@imada.ou.dk> |
e9e7f5f2 | 60 | ;; dfarmer@evolving.com (Doug Farmer) |
8967cd6e | 61 | ;; "Chris Alfeld" <calfeld@math.utah.edu> |
2c7cdd69 | 62 | ;; Ben Wing <ben@xemacs.org> |
9875e646 TT |
63 | |
64 | ;; KNOWN BUGS: | |
2c7cdd69 SM |
65 | ;; * In Tcl "#" is not always a comment character. This can confuse tcl.el |
66 | ;; in certain circumstances. For now the only workaround is to use | |
67 | ;; font-lock which will mark the # chars accordingly or enclose offending | |
68 | ;; hash characters in quotes or precede them with a backslash. Note that | |
69 | ;; using braces won't work -- quotes change the syntax class of characters | |
70 | ;; between them, while braces do not. If you don't use font-lock, the | |
71 | ;; electric-# mode helps alleviate this problem somewhat. | |
9875e646 | 72 | ;; * indent-tcl-exp is untested. |
9875e646 TT |
73 | |
74 | ;; TODO: | |
75 | ;; * make add-log-tcl-defun smarter. should notice if we are in the | |
76 | ;; middle of a defun, or between defuns. should notice if point is | |
77 | ;; on first line of defun (or maybe even in comments before defun). | |
78 | ;; * Allow continuation lines to be indented under the first argument | |
9ad79cb4 | 79 | ;; of the preceding line, like this: |
9875e646 TT |
80 | ;; [list something \ |
81 | ;; something-else] | |
82 | ;; * There is a request that indentation work like this: | |
83 | ;; button .fred -label Fred \ | |
84 | ;; -command {puts fred} | |
85 | ;; * Should have tcl-complete-symbol that queries the inferior process. | |
86 | ;; * Should have describe-symbol that works by sending the magic | |
87 | ;; command to a tclX process. | |
88 | ;; * Need C-x C-e binding (tcl-eval-last-exp). | |
89 | ;; * Write indent-region function that is faster than indenting each | |
90 | ;; line individually. | |
91 | ;; * tcl-figure-type should stop at "beginning of line" (only ws | |
92 | ;; before point, and no "\" on previous line). (see tcl-real-command-p). | |
9875e646 TT |
93 | ;; * overrides some comint keybindings; fix. |
94 | ;; * Trailing \ will eat blank lines. Should deal with this. | |
95 | ;; (this would help catch some potential bugs). | |
96 | ;; * Inferior should display in half the screen, not the whole screen. | |
95338744 TT |
97 | ;; * Indentation should deal with "switch". |
98 | ;; * Consider writing code to find help files automatically (for | |
99 | ;; common cases). | |
6be8057e | 100 | ;; * `#' shouldn't insert `\#' when point is in string. |
9875e646 TT |
101 | |
102 | \f | |
103 | ||
104 | ;;; Code: | |
105 | ||
850d5045 | 106 | (eval-when-compile |
c2ca5171 | 107 | (require 'imenu) |
850d5045 GM |
108 | (require 'outline) |
109 | (require 'dabbrev) | |
110 | (require 'add-log)) | |
111 | ||
9875e646 TT |
112 | (require 'comint) |
113 | ||
114 | ;; | |
115 | ;; User variables. | |
116 | ;; | |
117 | ||
94662de7 | 118 | (defgroup tcl nil |
5089af27 | 119 | "Major mode for editing Tcl source in Emacs." |
8ec3bce0 | 120 | :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) |
94662de7 | 121 | :group 'languages) |
9875e646 | 122 | |
94662de7 RS |
123 | (defcustom tcl-indent-level 4 |
124 | "*Indentation of Tcl statements with respect to containing block." | |
f5307782 JB |
125 | :type 'integer |
126 | :group 'tcl) | |
b14d552b | 127 | (put 'tcl-indent-level 'safe-local-variable 'integerp) |
9875e646 | 128 | |
94662de7 RS |
129 | (defcustom tcl-continued-indent-level 4 |
130 | "*Indentation of continuation line relative to first line of command." | |
f5307782 JB |
131 | :type 'integer |
132 | :group 'tcl) | |
b14d552b | 133 | (put 'tcl-continued-indent-level 'safe-local-variable 'integerp) |
9875e646 | 134 | |
94662de7 RS |
135 | (defcustom tcl-auto-newline nil |
136 | "*Non-nil means automatically newline before and after braces you insert." | |
f5307782 JB |
137 | :type 'boolean |
138 | :group 'tcl) | |
94662de7 | 139 | |
6612afc0 | 140 | (defcustom tcl-tab-always-indent tab-always-indent |
9875e646 TT |
141 | "*Control effect of TAB key. |
142 | If t (the default), always indent current line. | |
143 | If nil and point is not in the indentation area at the beginning of | |
144 | the line, a TAB is inserted. | |
145 | Other values cause the first possible action from the following list | |
146 | to take place: | |
147 | ||
148 | 1. Move from beginning of line to correct indentation. | |
149 | 2. Delete an empty comment. | |
150 | 3. Move forward to start of comment, indenting if necessary. | |
151 | 4. Move forward to end of line, indenting if necessary. | |
152 | 5. Create an empty comment. | |
94662de7 | 153 | 6. Move backward to start of comment, indenting if necessary." |
94662de7 RS |
154 | :type '(choice (const :tag "Always" t) |
155 | (const :tag "Beginning only" nil) | |
f5307782 JB |
156 | (const :tag "Maybe move or make or delete comment" 'tcl)) |
157 | :group 'tcl) | |
94662de7 | 158 | |
9875e646 | 159 | |
2c7cdd69 | 160 | (defcustom tcl-electric-hash-style nil ;; 'smart |
9875e646 | 161 | "*Style of electric hash insertion to use. |
2f585cfe RS |
162 | Possible values are `backslash', meaning that `\\' quoting should be |
163 | done; `quote', meaning that `\"' quoting should be done; `smart', | |
164 | meaning that the choice between `backslash' and `quote' should be | |
9875e646 TT |
165 | made depending on the number of hashes inserted; or nil, meaning that |
166 | no quoting should be done. Any other value for this variable is | |
2c7cdd69 | 167 | taken to mean `smart'. The default is nil." |
f5307782 JB |
168 | :type '(choice (const backslash) (const quote) (const smart) (const nil)) |
169 | :group 'tcl) | |
94662de7 RS |
170 | |
171 | (defcustom tcl-help-directory-list nil | |
172 | "*List of topmost directories containing TclX help files." | |
f5307782 JB |
173 | :type '(repeat directory) |
174 | :group 'tcl) | |
94662de7 RS |
175 | |
176 | (defcustom tcl-use-smart-word-finder t | |
177 | "*If not nil, use smart way to find current word, for Tcl help feature." | |
f5307782 JB |
178 | :type 'boolean |
179 | :group 'tcl) | |
94662de7 RS |
180 | |
181 | (defcustom tcl-application "wish" | |
182 | "*Name of Tcl program to run in inferior Tcl mode." | |
f5307782 JB |
183 | :type 'string |
184 | :group 'tcl) | |
94662de7 RS |
185 | |
186 | (defcustom tcl-command-switches nil | |
187 | "*List of switches to supply to the `tcl-application' program." | |
f5307782 JB |
188 | :type '(repeat string) |
189 | :group 'tcl) | |
94662de7 RS |
190 | |
191 | (defcustom tcl-prompt-regexp "^\\(% \\|\\)" | |
9875e646 TT |
192 | "*If not nil, a regexp that will match the prompt in the inferior process. |
193 | If nil, the prompt is the name of the application with \">\" appended. | |
194 | ||
195 | The default is \"^\\(% \\|\\)\", which will match the default primary | |
94662de7 | 196 | and secondary prompts for tclsh and wish." |
f5307782 JB |
197 | :type 'regexp |
198 | :group 'tcl) | |
9875e646 | 199 | |
94662de7 | 200 | (defcustom inferior-tcl-source-command "source %s\n" |
9875e646 TT |
201 | "*Format-string for building a Tcl command to load a file. |
202 | This format string should use `%s' to substitute a file name | |
203 | and should result in a Tcl expression that will command the | |
204 | inferior Tcl to load that file. The filename will be appropriately | |
94662de7 | 205 | quoted for Tcl." |
f5307782 JB |
206 | :type 'string |
207 | :group 'tcl) | |
9875e646 | 208 | |
d6d43bde GM |
209 | (defface tcl-escaped-newline '((t :inherit font-lock-string-face)) |
210 | "Face used for (non-escaped) backslash at end of a line in Tcl mode." | |
211 | :group 'tcl | |
212 | :version "22.1") | |
213 | ||
9875e646 TT |
214 | ;; |
215 | ;; Keymaps, abbrevs, syntax tables. | |
216 | ;; | |
217 | ||
c2ca5171 SM |
218 | (defvar tcl-mode-map |
219 | (let ((map (make-sparse-keymap))) | |
220 | (define-key map "{" 'tcl-electric-char) | |
221 | (define-key map "}" 'tcl-electric-brace) | |
222 | (define-key map "[" 'tcl-electric-char) | |
223 | (define-key map "]" 'tcl-electric-char) | |
224 | (define-key map ";" 'tcl-electric-char) | |
225 | (define-key map "#" 'tcl-electric-hash) ;Remove? -stef | |
226 | (define-key map "\e\C-q" 'tcl-indent-exp) | |
227 | (define-key map "\177" 'backward-delete-char-untabify) | |
228 | (define-key map "\t" 'tcl-indent-command) | |
229 | (define-key map "\M-\C-x" 'tcl-eval-defun) | |
230 | (define-key map "\C-c\C-i" 'tcl-help-on-word) | |
231 | (define-key map "\C-c\C-v" 'tcl-eval-defun) | |
232 | (define-key map "\C-c\C-f" 'tcl-load-file) | |
233 | (define-key map "\C-c\C-t" 'inferior-tcl) | |
234 | (define-key map "\C-c\C-x" 'tcl-eval-region) | |
235 | (define-key map "\C-c\C-s" 'switch-to-tcl) | |
236 | map) | |
237 | "Keymap used in `tcl-mode'.") | |
238 | ||
239 | (defvar tcl-mode-syntax-table | |
240 | (let ((st (make-syntax-table))) | |
241 | (modify-syntax-entry ?% "_" st) | |
242 | (modify-syntax-entry ?@ "_" st) | |
243 | (modify-syntax-entry ?& "_" st) | |
244 | (modify-syntax-entry ?* "_" st) | |
245 | (modify-syntax-entry ?+ "_" st) | |
246 | (modify-syntax-entry ?- "_" st) | |
247 | (modify-syntax-entry ?. "_" st) | |
248 | (modify-syntax-entry ?: "_" st) | |
249 | (modify-syntax-entry ?! "_" st) | |
250 | (modify-syntax-entry ?$ "_" st) ; FIXME use "'"? | |
251 | (modify-syntax-entry ?/ "_" st) | |
252 | (modify-syntax-entry ?~ "_" st) | |
253 | (modify-syntax-entry ?< "_" st) | |
254 | (modify-syntax-entry ?= "_" st) | |
255 | (modify-syntax-entry ?> "_" st) | |
256 | (modify-syntax-entry ?| "_" st) | |
257 | (modify-syntax-entry ?\( "()" st) | |
258 | (modify-syntax-entry ?\) ")(" st) | |
259 | (modify-syntax-entry ?\; "." st) | |
260 | (modify-syntax-entry ?\n ">" st) | |
261 | ;; (modify-syntax-entry ?\f ">" st) | |
262 | (modify-syntax-entry ?# "<" st) | |
263 | st) | |
264 | "Syntax table in use in `tcl-mode' buffers.") | |
265 | ||
266 | (defvar inferior-tcl-mode-map | |
267 | ;; FIXME we override comint keybindings here. | |
268 | ;; Maybe someone has a better set? | |
269 | (let ((map (make-sparse-keymap))) | |
270 | ;; Will inherit from `comint-mode-map' thanks to define-derived-mode. | |
271 | (define-key map "\t" 'comint-dynamic-complete) | |
272 | (define-key map "\M-?" 'comint-dynamic-list-filename-completions) | |
273 | (define-key map "\177" 'backward-delete-char-untabify) | |
274 | (define-key map "\M-\C-x" 'tcl-eval-defun) | |
275 | (define-key map "\C-c\C-i" 'tcl-help-on-word) | |
276 | (define-key map "\C-c\C-v" 'tcl-eval-defun) | |
277 | (define-key map "\C-c\C-f" 'tcl-load-file) | |
278 | (define-key map "\C-c\C-t" 'inferior-tcl) | |
279 | (define-key map "\C-c\C-x" 'tcl-eval-region) | |
280 | (define-key map "\C-c\C-s" 'switch-to-tcl) | |
281 | map) | |
282 | "Keymap used in `inferior-tcl-mode'.") | |
283 | ||
284 | (easy-menu-define tcl-mode-menu tcl-mode-map "Menu used in `tcl-mode'." | |
285 | '("Tcl" | |
286 | ["Beginning of function" beginning-of-defun t] | |
287 | ["End of function" end-of-defun t] | |
288 | ["Mark function" mark-defun t] | |
289 | ["Indent region" indent-region (mark t)] | |
290 | ["Comment region" comment-region (mark t)] | |
291 | ["Uncomment region" uncomment-region (mark t)] | |
9875e646 TT |
292 | "----" |
293 | ["Show Tcl process buffer" inferior-tcl t] | |
dc509e64 | 294 | ["Send function to Tcl process" tcl-eval-defun |
efd7d762 | 295 | (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] |
dc509e64 | 296 | ["Send region to Tcl process" tcl-eval-region |
efd7d762 | 297 | (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] |
dc509e64 | 298 | ["Send file to Tcl process" tcl-load-file |
efd7d762 | 299 | (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] |
9875e646 TT |
300 | ["Restart Tcl process with file" tcl-restart-with-file t] |
301 | "----" | |
c2ca5171 | 302 | ["Tcl help" tcl-help-on-word tcl-help-directory-list])) |
9875e646 TT |
303 | |
304 | (defvar inferior-tcl-buffer nil | |
305 | "*The current inferior-tcl process buffer. | |
306 | ||
307 | MULTIPLE PROCESS SUPPORT | |
308 | =========================================================================== | |
309 | To run multiple Tcl processes, you start the first up with | |
310 | \\[inferior-tcl]. It will be in a buffer named `*inferior-tcl*'. | |
311 | Rename this buffer with \\[rename-buffer]. You may now start up a new | |
312 | process with another \\[inferior-tcl]. It will be in a new buffer, | |
313 | named `*inferior-tcl*'. You can switch between the different process | |
314 | buffers with \\[switch-to-buffer]. | |
315 | ||
316 | Commands that send text from source buffers to Tcl processes -- like | |
317 | `tcl-eval-defun' or `tcl-load-file' -- have to choose a process to | |
318 | send to, when you have more than one Tcl process around. This is | |
319 | determined by the global variable `inferior-tcl-buffer'. Suppose you | |
320 | have three inferior Lisps running: | |
321 | Buffer Process | |
322 | foo inferior-tcl | |
323 | bar inferior-tcl<2> | |
324 | *inferior-tcl* inferior-tcl<3> | |
325 | If you do a \\[tcl-eval-defun] command on some Lisp source code, what | |
326 | process do you send it to? | |
327 | ||
a1506d29 | 328 | - If you're in a process buffer (foo, bar, or *inferior-tcl*), |
9875e646 TT |
329 | you send it to that process. |
330 | - If you're in some other buffer (e.g., a source file), you | |
331 | send it to the process attached to buffer `inferior-tcl-buffer'. | |
332 | This process selection is performed by function `inferior-tcl-proc'. | |
333 | ||
334 | Whenever \\[inferior-tcl] fires up a new process, it resets | |
335 | `inferior-tcl-buffer' to be the new process's buffer. If you only run | |
336 | one process, this does the right thing. If you run multiple | |
337 | processes, you can change `inferior-tcl-buffer' to another process | |
338 | buffer with \\[set-variable].") | |
339 | ||
340 | ;; | |
341 | ;; Hooks and other customization. | |
342 | ;; | |
343 | ||
344 | (defvar tcl-mode-hook nil | |
345 | "Hook run on entry to Tcl mode. | |
346 | ||
347 | Several functions exist which are useful to run from your | |
348 | `tcl-mode-hook' (see each function's documentation for more | |
349 | information): | |
350 | ||
c2ca5171 | 351 | `tcl-guess-application' |
9875e646 TT |
352 | Guesses a default setting for `tcl-application' based on any |
353 | \"#!\" line at the top of the file. | |
c2ca5171 | 354 | `tcl-hashify-buffer' |
9875e646 TT |
355 | Quotes all \"#\" characters that don't correspond to actual |
356 | Tcl comments. (Useful when editing code not originally created | |
357 | with this mode). | |
c2ca5171 | 358 | `tcl-auto-fill-mode' |
9875e646 TT |
359 | Auto-filling of Tcl comments. |
360 | ||
2f585cfe | 361 | Add functions to the hook with `add-hook': |
9875e646 | 362 | |
c2ca5171 | 363 | (add-hook 'tcl-mode-hook 'tcl-guess-application)") |
9875e646 | 364 | |
9875e646 TT |
365 | |
366 | (defvar tcl-proc-list | |
47448891 | 367 | '("proc" "method" "itcl_class" "body" "configbody" "class") |
9875e646 | 368 | "List of commands whose first argument defines something. |
2f585cfe | 369 | This exists because some people (eg, me) use `defvar' et al. |
9875e646 TT |
370 | Call `tcl-set-proc-regexp' and `tcl-set-font-lock-keywords' |
371 | after changing this list.") | |
372 | ||
373 | (defvar tcl-proc-regexp nil | |
374 | "Regexp to use when matching proc headers.") | |
375 | ||
376 | (defvar tcl-typeword-list | |
55c6d8fc | 377 | '("global" "upvar" "inherit" "public" "protected" "private" |
5bc0f801 | 378 | "common" "itk_option" "variable") |
9aa88f3e | 379 | "List of Tcl keywords denoting \"type\". Used only for highlighting. |
9875e646 TT |
380 | Call `tcl-set-font-lock-keywords' after changing this list.") |
381 | ||
382 | ;; Generally I've picked control operators to be keywords. | |
383 | (defvar tcl-keyword-list | |
384 | '("if" "then" "else" "elseif" "for" "foreach" "break" "continue" "while" | |
385 | "eval" "case" "in" "switch" "default" "exit" "error" "proc" "return" | |
a0defa81 | 386 | "uplevel" "constructor" "destructor" "itcl_class" "loop" "for_array_keys" |
c2ca5171 SM |
387 | "for_recursive_glob" "for_file" "method" "body" "configbody" "class" |
388 | "chain") | |
9875e646 TT |
389 | "List of Tcl keywords. Used only for highlighting. |
390 | Default list includes some TclX keywords. | |
391 | Call `tcl-set-font-lock-keywords' after changing this list.") | |
392 | ||
d6d43bde GM |
393 | (defvar tcl-builtin-list |
394 | '("after" "append" "array" "bgerror" "binary" "catch" "cd" "clock" | |
395 | "close" "concat" "console" "dde" "encoding" "eof" "exec" "expr" | |
396 | "fblocked" "fconfigure" "fcopy" "file" "fileevent" "flush" | |
397 | "format" "gets" "glob" "history" "incr" "info" "interp" "join" | |
398 | "lappend" "lindex" "linsert" "list" "llength" "load" "lrange" | |
399 | "lreplace" "lsort" "namespace" "open" "package" "pid" "puts" "pwd" | |
400 | "read" "regexp" "registry" "regsub" "rename" "scan" "seek" "set" | |
401 | "socket" "source" "split" "string" "subst" "tell" "time" "trace" | |
402 | "unknown" "unset" "vwait") | |
403 | "List of Tcl commands. Used only for highlighting. | |
404 | Call `tcl-set-font-lock-keywords' after changing this list. | |
405 | This list excludes those commands already found in `tcl-proc-list' and | |
406 | `tcl-keyword-list'.") | |
407 | ||
9875e646 TT |
408 | (defvar tcl-font-lock-keywords nil |
409 | "Keywords to highlight for Tcl. See variable `font-lock-keywords'. | |
410 | This variable is generally set from `tcl-proc-regexp', | |
411 | `tcl-typeword-list', and `tcl-keyword-list' by the function | |
412 | `tcl-set-font-lock-keywords'.") | |
413 | ||
c2ca5171 SM |
414 | (defvar tcl-font-lock-syntactic-keywords |
415 | ;; Mark the few `#' that are not comment-markers. | |
416 | '(("[^;[{ \t\n][ \t]*\\(#\\)" (1 "."))) | |
417 | "Syntactic keywords for `tcl-mode'.") | |
418 | ||
9875e646 TT |
419 | ;; FIXME need some way to recognize variables because array refs look |
420 | ;; like 2 sexps. | |
421 | (defvar tcl-type-alist | |
c2ca5171 | 422 | '(("proc" nil tcl-expr tcl-commands) |
a7efef53 | 423 | ("method" nil tcl-expr tcl-commands) |
fe8fa72d TT |
424 | ("destructor" tcl-commands) |
425 | ("constructor" tcl-commands) | |
9875e646 TT |
426 | ("expr" tcl-expr) |
427 | ("catch" tcl-commands) | |
428 | ("if" tcl-expr "then" tcl-commands) | |
429 | ("elseif" tcl-expr "then" tcl-commands) | |
430 | ("elseif" tcl-expr tcl-commands) | |
431 | ("if" tcl-expr tcl-commands) | |
432 | ("while" tcl-expr tcl-commands) | |
433 | ("for" tcl-commands tcl-expr tcl-commands tcl-commands) | |
434 | ("foreach" nil nil tcl-commands) | |
435 | ("for_file" nil nil tcl-commands) | |
436 | ("for_array_keys" nil nil tcl-commands) | |
437 | ("for_recursive_glob" nil nil nil tcl-commands) | |
438 | ;; Loop handling is not perfect, because the third argument can be | |
439 | ;; either a command or an expr, and there is no real way to look | |
440 | ;; forward. | |
441 | ("loop" nil tcl-expr tcl-expr tcl-commands) | |
c2ca5171 | 442 | ("loop" nil tcl-expr tcl-commands)) |
9875e646 TT |
443 | "Alist that controls indentation. |
444 | \(Actually, this really only controls what happens on continuation lines). | |
445 | Each entry looks like `(KEYWORD TYPE ...)'. | |
446 | Each type entry describes a sexp after the keyword, and can be one of: | |
447 | * nil, meaning that this sexp has no particular type. | |
448 | * tcl-expr, meaning that this sexp is an arithmetic expression. | |
449 | * tcl-commands, meaning that this sexp holds Tcl commands. | |
450 | * a string, which must exactly match the string at the corresponding | |
451 | position for a match to be made. | |
452 | ||
453 | For example, the entry for the \"loop\" command is: | |
454 | ||
455 | (\"loop\" nil tcl-expr tcl-commands) | |
456 | ||
457 | This means that the \"loop\" command has three arguments. The first | |
458 | argument is ignored (for indentation purposes). The second argument | |
459 | is a Tcl expression, and the last argument is Tcl commands.") | |
460 | ||
461 | (defvar tcl-explain-indentation nil | |
dccab430 | 462 | "If non-nil, debugging message will be printed during indentation.") |
9875e646 TT |
463 | |
464 | \f | |
465 | ||
a2c6faea SM |
466 | ;; Here's another stab. I think this one actually works. |
467 | ;; We have to be careful that the open-brace following this regexp | |
468 | ;; is indeed the one corresponding to the function's body so | |
469 | ;; that end-of-defun works correctly. Tricky cases are: | |
470 | ;; proc foo { {arg1 def} arg2 } { | |
471 | ;; as well as | |
472 | ;; proc foo { \n {arg1 def} \n arg2 } { | |
473 | ;; The current setting handles the first case properly but not the second. | |
474 | ;; It also fails if `proc' is not in column-0 (e.g. it's in a namespace). | |
9921b91a | 475 | (defconst tcl-omit-ws-regexp "^[^]\" \t\n#}][^\n\"#]+[ \t]+") |
9875e646 | 476 | |
9875e646 TT |
477 | \f |
478 | ||
479 | ;; | |
480 | ;; Some helper functions. | |
481 | ;; | |
482 | ||
483 | (defun tcl-set-proc-regexp () | |
484 | "Set `tcl-proc-regexp' from variable `tcl-proc-list'." | |
c2ca5171 SM |
485 | (setq tcl-proc-regexp |
486 | (concat "^\\s-*" (regexp-opt tcl-proc-list t) "[ \t]+"))) | |
9875e646 TT |
487 | |
488 | (defun tcl-set-font-lock-keywords () | |
489 | "Set `tcl-font-lock-keywords'. | |
490 | Uses variables `tcl-proc-regexp' and `tcl-keyword-list'." | |
491 | (setq tcl-font-lock-keywords | |
492 | (list | |
493 | ;; Names of functions (and other "defining things"). | |
494 | (list (concat tcl-proc-regexp "\\([^ \t\n]+\\)") | |
495 | 2 'font-lock-function-name-face) | |
496 | ||
497 | ;; Names of type-defining things. | |
c2ca5171 SM |
498 | (list (concat "\\(\\s-\\|^\\)" |
499 | (regexp-opt tcl-typeword-list t) | |
500 | "\\(\\s-\\|$\\)") | |
9875e646 TT |
501 | 2 'font-lock-type-face) |
502 | ||
d6d43bde GM |
503 | (list (concat "\\_<" (regexp-opt tcl-builtin-list t) "\\_>") |
504 | 1 'font-lock-builtin-face) | |
505 | ||
506 | ;; When variable names are enclosed in {} braces, any | |
507 | ;; character can be used. Otherwise just letters, digits, | |
508 | ;; underscores. Variable names can be prefixed with any | |
509 | ;; number of "namespace::" qualifiers. A leading "::" refers | |
510 | ;; to the global namespace. | |
511 | '("\\${\\([^}]+\\)}" 1 font-lock-variable-name-face) | |
512 | '("\\$\\(\\(?:::\\)?\\(?:[[:alnum:]_]+::\\)*[[:alnum:]_]+\\)" | |
513 | 1 font-lock-variable-name-face) | |
514 | '("\\(?:\\s-\\|^\\|\\[\\)set\\s-+{\\([^}]+\\)}" | |
515 | 1 font-lock-variable-name-face keep) | |
516 | '("\\(?:\\s-\\|^\\|\\[\\)set\\s-+\\(\\(?:::\\)?\ | |
517 | \\(?:[[:alnum:]_]+::\\)*[[:alnum:]_]+\\)" | |
518 | 1 font-lock-variable-name-face keep) | |
519 | ||
520 | '("\\(^\\|[^\\]\\)\\(\\\\\\\\\\)*\\(\\\\\\)$" 3 'tcl-escaped-newline) | |
521 | ||
9875e646 TT |
522 | ;; Keywords. Only recognized if surrounded by whitespace. |
523 | ;; FIXME consider using "not word or symbol", not | |
524 | ;; "whitespace". | |
4c5113c7 | 525 | (cons (concat "\\_<" (regexp-opt tcl-keyword-list t) "\\_>") |
d6d43bde | 526 | 1)))) |
9875e646 TT |
527 | |
528 | (if tcl-proc-regexp | |
529 | () | |
530 | (tcl-set-proc-regexp)) | |
531 | ||
532 | (if tcl-font-lock-keywords | |
533 | () | |
534 | (tcl-set-font-lock-keywords)) | |
535 | ||
031a5886 RS |
536 | |
537 | (defvar tcl-imenu-generic-expression | |
2c7cdd69 | 538 | `((nil ,(concat tcl-proc-regexp "\\([-A-Za-z0-9_:+*]+\\)") 2)) |
031a5886 RS |
539 | "Imenu generic expression for `tcl-mode'. See `imenu-generic-expression'.") |
540 | ||
9875e646 TT |
541 | \f |
542 | ||
543 | ;; | |
544 | ;; The mode itself. | |
545 | ;; | |
546 | ||
cd754bf5 | 547 | ;;;###autoload |
c2ca5171 | 548 | (define-derived-mode tcl-mode nil "Tcl" |
9875e646 TT |
549 | "Major mode for editing Tcl code. |
550 | Expression and list commands understand all Tcl brackets. | |
551 | Tab indents for Tcl code. | |
552 | Paragraphs are separated by blank lines only. | |
553 | Delete converts tabs to spaces as it moves back. | |
554 | ||
555 | Variables controlling indentation style: | |
c2ca5171 | 556 | `tcl-indent-level' |
9875e646 | 557 | Indentation of Tcl statements within surrounding block. |
c2ca5171 | 558 | `tcl-continued-indent-level' |
9875e646 TT |
559 | Indentation of continuation line relative to first line of command. |
560 | ||
561 | Variables controlling user interaction with mode (see variable | |
562 | documentation for details): | |
c2ca5171 | 563 | `tcl-tab-always-indent' |
9875e646 | 564 | Controls action of TAB key. |
c2ca5171 | 565 | `tcl-auto-newline' |
9875e646 TT |
566 | Non-nil means automatically newline before and after braces, brackets, |
567 | and semicolons inserted in Tcl code. | |
c2ca5171 | 568 | `tcl-use-smart-word-finder' |
a37875b4 TT |
569 | If not nil, use a smarter, Tcl-specific way to find the current |
570 | word when looking up help on a Tcl command. | |
9875e646 | 571 | |
a2c6faea | 572 | Turning on Tcl mode runs `tcl-mode-hook'. Read the documentation for |
9875e646 TT |
573 | `tcl-mode-hook' to see what kinds of interesting hook functions |
574 | already exist. | |
575 | ||
576 | Commands: | |
577 | \\{tcl-mode-map}" | |
031a5886 | 578 | (unless (and (boundp 'filladapt-mode) filladapt-mode) |
cd21c04a | 579 | (set (make-local-variable 'paragraph-ignore-fill-prefix) t)) |
c2ca5171 SM |
580 | |
581 | (set (make-local-variable 'indent-line-function) 'tcl-indent-line) | |
582 | (set (make-local-variable 'comment-indent-function) 'tcl-comment-indent) | |
9875e646 TT |
583 | ;; Tcl doesn't require a final newline. |
584 | ;; (make-local-variable 'require-final-newline) | |
585 | ;; (setq require-final-newline t) | |
9aa88f3e | 586 | |
c2ca5171 | 587 | (set (make-local-variable 'comment-start) "# ") |
a2c6faea SM |
588 | (set (make-local-variable 'comment-start-skip) |
589 | "\\(\\(^\\|[;{[]\\)\\s-*\\)#+ *") | |
c2ca5171 | 590 | (set (make-local-variable 'comment-end) "") |
50776640 | 591 | |
cd21c04a | 592 | (set (make-local-variable 'outline-regexp) ".") |
c2ca5171 | 593 | (set (make-local-variable 'outline-level) 'tcl-outline-level) |
a3dfa2c0 | 594 | |
c2ca5171 SM |
595 | (set (make-local-variable 'font-lock-defaults) |
596 | '(tcl-font-lock-keywords nil nil nil beginning-of-defun | |
d6d43bde GM |
597 | (font-lock-syntactic-keywords . tcl-font-lock-syntactic-keywords) |
598 | (parse-sexp-lookup-properties . t))) | |
9aa88f3e | 599 | |
031a5886 | 600 | (set (make-local-variable 'imenu-generic-expression) |
ec91f773 | 601 | tcl-imenu-generic-expression) |
a1506d29 | 602 | |
68734e7b | 603 | ;; Settings for new dabbrev code. |
c2ca5171 SM |
604 | (set (make-local-variable 'dabbrev-case-fold-search) nil) |
605 | (set (make-local-variable 'dabbrev-case-replace) nil) | |
606 | (set (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) "[$!]") | |
607 | (set (make-local-variable 'dabbrev-abbrev-char-regexp) "\\sw\\|\\s_") | |
608 | ||
609 | ;; This can only be set to t in Emacs 19 and XEmacs. | |
610 | ;; Emacs 18 and Epoch lose. | |
611 | (set (make-local-variable 'parse-sexp-ignore-comments) t) | |
612 | ;; XEmacs has defun-prompt-regexp, but I don't believe | |
613 | ;; that it works for end-of-defun -- only for | |
614 | ;; beginning-of-defun. | |
615 | (set (make-local-variable 'defun-prompt-regexp) tcl-omit-ws-regexp) | |
616 | ;; The following doesn't work in Lucid Emacs 19.6, but maybe | |
617 | ;; it will appear in later versions. | |
618 | (set (make-local-variable 'add-log-current-defun-function) | |
619 | 'tcl-add-log-defun) | |
620 | ||
621 | (easy-menu-add tcl-mode-menu) | |
e9e7f5f2 | 622 | ;; Append Tcl menu to popup menu for XEmacs. |
c2ca5171 | 623 | (if (boundp 'mode-popup-menu) |
c803d3a7 | 624 | (setq mode-popup-menu |
c2ca5171 | 625 | (cons (concat mode-name " Mode Commands") tcl-mode-menu)))) |
9875e646 TT |
626 | |
627 | \f | |
628 | ||
629 | ;; This is used for braces, brackets, and semi (except for closing | |
630 | ;; braces, which are handled specially). | |
631 | (defun tcl-electric-char (arg) | |
632 | "Insert character and correct line's indentation." | |
633 | (interactive "p") | |
634 | ;; Indent line first; this looks better if parens blink. | |
635 | (tcl-indent-line) | |
636 | (self-insert-command arg) | |
637 | (if (and tcl-auto-newline (= last-command-char ?\;)) | |
638 | (progn | |
639 | (newline) | |
640 | (tcl-indent-line)))) | |
641 | ||
642 | ;; This is used for closing braces. If tcl-auto-newline is set, can | |
643 | ;; insert a newline both before and after the brace, depending on | |
644 | ;; context. FIXME should this be configurable? Does anyone use this? | |
645 | (defun tcl-electric-brace (arg) | |
646 | "Insert character and correct line's indentation." | |
647 | (interactive "p") | |
648 | ;; If auto-newlining and there is stuff on the same line, insert a | |
649 | ;; newline first. | |
650 | (if tcl-auto-newline | |
651 | (progn | |
652 | (if (save-excursion | |
653 | (skip-chars-backward " \t") | |
654 | (bolp)) | |
655 | () | |
656 | (tcl-indent-line) | |
657 | (newline)) | |
658 | ;; In auto-newline case, must insert a newline after each | |
659 | ;; brace. So an explicit loop is needed. | |
660 | (while (> arg 0) | |
661 | (insert last-command-char) | |
662 | (tcl-indent-line) | |
663 | (newline) | |
664 | (setq arg (1- arg)))) | |
665 | (self-insert-command arg)) | |
666 | (tcl-indent-line)) | |
667 | ||
668 | \f | |
669 | ||
670 | (defun tcl-indent-command (&optional arg) | |
671 | "Indent current line as Tcl code, or in some cases insert a tab character. | |
2f585cfe RS |
672 | If `tcl-tab-always-indent' is t (the default), always indent current line. |
673 | If `tcl-tab-always-indent' is nil and point is not in the indentation | |
9875e646 | 674 | area at the beginning of the line, a TAB is inserted. |
2f585cfe | 675 | Other values of `tcl-tab-always-indent' cause the first possible action |
9875e646 TT |
676 | from the following list to take place: |
677 | ||
678 | 1. Move from beginning of line to correct indentation. | |
679 | 2. Delete an empty comment. | |
680 | 3. Move forward to start of comment, indenting if necessary. | |
681 | 4. Move forward to end of line, indenting if necessary. | |
682 | 5. Create an empty comment. | |
683 | 6. Move backward to start of comment, indenting if necessary." | |
684 | (interactive "p") | |
05794f14 SM |
685 | (if (memq tcl-tab-always-indent '(nil t)) |
686 | (let ((tab-always-indent tcl-tab-always-indent)) | |
687 | (call-interactively 'indent-for-tab-command)) | |
9875e646 TT |
688 | ;; "Perl-mode" style TAB command. |
689 | (let* ((ipoint (point)) | |
690 | (eolpoint (progn | |
691 | (end-of-line) | |
692 | (point))) | |
693 | (comment-p (tcl-in-comment))) | |
694 | (cond | |
c2ca5171 | 695 | ((= ipoint (line-beginning-position)) |
9875e646 TT |
696 | (beginning-of-line) |
697 | (tcl-indent-line) | |
698 | ;; If indenting didn't leave us in column 0, go to the | |
699 | ;; indentation. Otherwise leave point at end of line. This | |
700 | ;; is a hack. | |
c2ca5171 | 701 | (if (= (point) (line-beginning-position)) |
9875e646 TT |
702 | (end-of-line) |
703 | (back-to-indentation))) | |
704 | ((and comment-p (looking-at "[ \t]*$")) | |
705 | ;; Empty comment, so delete it. We also delete any ";" | |
706 | ;; characters at the end of the line. I think this is | |
707 | ;; friendlier, but I don't know how other people will feel. | |
708 | (backward-char) | |
709 | (skip-chars-backward " \t;") | |
710 | (delete-region (point) eolpoint)) | |
711 | ((and comment-p (< ipoint (point))) | |
712 | ;; Before comment, so skip to it. | |
713 | (tcl-indent-line) | |
714 | (indent-for-comment)) | |
715 | ((/= ipoint eolpoint) | |
716 | ;; Go to end of line (since we're not there yet). | |
717 | (goto-char eolpoint) | |
718 | (tcl-indent-line)) | |
719 | ((not comment-p) | |
9875e646 | 720 | (tcl-indent-line) |
c2ca5171 | 721 | (comment-indent)) |
9875e646 TT |
722 | (t |
723 | ;; Go to start of comment. We don't leave point where it is | |
724 | ;; because we want to skip comment-start-skip. | |
725 | (tcl-indent-line) | |
05794f14 | 726 | (indent-for-comment)))))) |
9875e646 TT |
727 | |
728 | (defun tcl-indent-line () | |
729 | "Indent current line as Tcl code. | |
730 | Return the amount the indentation changed by." | |
c2ca5171 | 731 | (let ((indent (tcl-calculate-indent nil)) |
9875e646 TT |
732 | beg shift-amt |
733 | (case-fold-search nil) | |
734 | (pos (- (point-max) (point)))) | |
05794f14 SM |
735 | (if (null indent) |
736 | 'noindent | |
737 | (beginning-of-line) | |
738 | (setq beg (point)) | |
739 | (skip-chars-forward " \t") | |
740 | (if (listp indent) (setq indent (car indent))) | |
741 | (cond ((= (following-char) ?}) | |
742 | (setq indent (- indent tcl-indent-level))) | |
743 | ((= (following-char) ?\]) | |
744 | (setq indent (- indent 1)))) | |
745 | (skip-chars-forward " \t") | |
746 | (setq shift-amt (- indent (current-column))) | |
747 | (if (zerop shift-amt) | |
748 | (if (> (- (point-max) pos) (point)) | |
749 | (goto-char (- (point-max) pos))) | |
750 | (delete-region beg (point)) | |
751 | (indent-to indent) | |
752 | ;; If initial point was within line's indentation, | |
753 | ;; position after the indentation. Else stay at same point in text. | |
754 | (if (> (- (point-max) pos) (point)) | |
755 | (goto-char (- (point-max) pos)))) | |
756 | shift-amt))) | |
9875e646 TT |
757 | |
758 | (defun tcl-figure-type () | |
759 | "Determine type of sexp at point. | |
2f585cfe | 760 | This is either `tcl-expr', `tcl-commands', or nil. Puts point at start |
9875e646 TT |
761 | of sexp that indicates types. |
762 | ||
763 | See documentation for variable `tcl-type-alist' for more information." | |
764 | (let ((count 0) | |
765 | result | |
766 | word-stack) | |
767 | (while (and (< count 5) | |
768 | (not result)) | |
769 | (condition-case nil | |
770 | (progn | |
771 | ;; FIXME should use "tcl-backward-sexp", which would skip | |
772 | ;; over entire variables, etc. | |
773 | (backward-sexp) | |
774 | (if (looking-at "[a-zA-Z_]+") | |
775 | (let ((list tcl-type-alist) | |
776 | entry) | |
6654e1b1 | 777 | (setq word-stack (cons (tcl-word-no-props) word-stack)) |
9875e646 TT |
778 | (while (and list (not result)) |
779 | (setq entry (car list)) | |
780 | (setq list (cdr list)) | |
781 | (let ((index 0)) | |
782 | (while (and entry (<= index count)) | |
783 | ;; Abort loop if string does not match word on | |
784 | ;; stack. | |
785 | (and (stringp (car entry)) | |
786 | (not (string= (car entry) | |
787 | (nth index word-stack))) | |
788 | (setq entry nil)) | |
789 | (setq entry (cdr entry)) | |
790 | (setq index (1+ index))) | |
791 | (and (> index count) | |
792 | (not (stringp (car entry))) | |
793 | (setq result (car entry))) | |
794 | ))) | |
795 | (setq word-stack (cons nil word-stack)))) | |
796 | (error nil)) | |
797 | (setq count (1+ count))) | |
798 | (and tcl-explain-indentation | |
799 | (message "Indentation type %s" result)) | |
800 | result)) | |
801 | ||
c2ca5171 | 802 | (defun tcl-calculate-indent (&optional parse-start) |
9875e646 TT |
803 | "Return appropriate indentation for current line as Tcl code. |
804 | In usual case returns an integer: the column to indent to. | |
805 | Returns nil if line starts inside a string, t if in a comment." | |
806 | (save-excursion | |
807 | (beginning-of-line) | |
808 | (let* ((indent-point (point)) | |
809 | (case-fold-search nil) | |
a1506d29 | 810 | (continued-line |
9875e646 TT |
811 | (save-excursion |
812 | (if (bobp) | |
813 | nil | |
814 | (backward-char) | |
815 | (= ?\\ (preceding-char))))) | |
816 | (continued-indent-value (if continued-line | |
817 | tcl-continued-indent-level | |
818 | 0)) | |
819 | state | |
820 | containing-sexp | |
821 | found-next-line) | |
822 | (if parse-start | |
823 | (goto-char parse-start) | |
c2ca5171 | 824 | (beginning-of-defun)) |
9875e646 TT |
825 | (while (< (point) indent-point) |
826 | (setq parse-start (point)) | |
827 | (setq state (parse-partial-sexp (point) indent-point 0)) | |
828 | (setq containing-sexp (car (cdr state)))) | |
829 | (cond ((or (nth 3 state) (nth 4 state)) | |
830 | ;; Inside comment or string. Return nil or t if should | |
831 | ;; not change this line | |
832 | (nth 4 state)) | |
833 | ((null containing-sexp) | |
834 | ;; Line is at top level. | |
835 | continued-indent-value) | |
836 | (t | |
837 | ;; Set expr-p if we are looking at the expression part of | |
838 | ;; an "if", "expr", etc statement. Set commands-p if we | |
839 | ;; are looking at the body part of an if, while, etc | |
840 | ;; statement. FIXME Should check for "for" loops here. | |
841 | (goto-char containing-sexp) | |
842 | (let* ((sexpr-type (tcl-figure-type)) | |
843 | (expr-p (eq sexpr-type 'tcl-expr)) | |
844 | (commands-p (eq sexpr-type 'tcl-commands)) | |
845 | (expr-start (point))) | |
846 | ;; Find the first statement in the block and indent | |
847 | ;; like it. The first statement in the block might be | |
848 | ;; on the same line, so what we do is skip all | |
849 | ;; "virtually blank" lines, looking for a non-blank | |
850 | ;; one. A line is virtually blank if it only contains | |
851 | ;; a comment and whitespace. FIXME continued comments | |
852 | ;; aren't supported. They are a wart on Tcl anyway. | |
853 | ;; We do it this funky way because we want to know if | |
854 | ;; we've found a statement on some line _after_ the | |
855 | ;; line holding the sexp opener. | |
856 | (goto-char containing-sexp) | |
857 | (forward-char) | |
858 | (if (and (< (point) indent-point) | |
859 | (looking-at "[ \t]*\\(#.*\\)?$")) | |
860 | (progn | |
861 | (forward-line) | |
862 | (while (and (< (point) indent-point) | |
863 | (looking-at "[ \t]*\\(#.*\\)?$")) | |
864 | (setq found-next-line t) | |
865 | (forward-line)))) | |
866 | (if (or continued-line | |
867 | (/= (char-after containing-sexp) ?{) | |
868 | expr-p) | |
869 | (progn | |
870 | ;; Line is continuation line, or the sexp opener | |
871 | ;; is not a curly brace, or we are are looking at | |
872 | ;; an `expr' expression (which must be split | |
873 | ;; specially). So indentation is column of first | |
874 | ;; good spot after sexp opener (with some added | |
875 | ;; in the continued-line case). If there is no | |
876 | ;; nonempty line before the indentation point, we | |
877 | ;; use the column of the character after the sexp | |
878 | ;; opener. | |
879 | (if (>= (point) indent-point) | |
880 | (progn | |
881 | (goto-char containing-sexp) | |
882 | (forward-char)) | |
883 | (skip-chars-forward " \t")) | |
884 | (+ (current-column) continued-indent-value)) | |
885 | ;; After a curly brace, and not a continuation line. | |
886 | ;; So take indentation from first good line after | |
887 | ;; start of block, unless that line is on the same | |
888 | ;; line as the opening brace. In this case use the | |
889 | ;; indentation of the opening brace's line, plus | |
890 | ;; another indent step. If we are in the body part | |
891 | ;; of an "if" or "while" then the indentation is | |
892 | ;; taken from the line holding the start of the | |
893 | ;; statement. | |
894 | (if (and (< (point) indent-point) | |
895 | found-next-line) | |
896 | (current-indentation) | |
897 | (if commands-p | |
898 | (goto-char expr-start) | |
899 | (goto-char containing-sexp)) | |
900 | (+ (current-indentation) tcl-indent-level))))))))) | |
901 | ||
902 | \f | |
903 | ||
c2ca5171 | 904 | (defun tcl-indent-exp () |
9875e646 TT |
905 | "Indent each line of the Tcl grouping following point." |
906 | (interactive) | |
907 | (let ((indent-stack (list nil)) | |
908 | (contain-stack (list (point))) | |
909 | (case-fold-search nil) | |
910 | outer-loop-done inner-loop-done state ostate | |
6612afc0 | 911 | this-indent continued-line |
9875e646 TT |
912 | (next-depth 0) |
913 | last-depth) | |
914 | (save-excursion | |
915 | (forward-sexp 1)) | |
916 | (save-excursion | |
917 | (setq outer-loop-done nil) | |
918 | (while (and (not (eobp)) (not outer-loop-done)) | |
919 | (setq last-depth next-depth) | |
920 | ;; Compute how depth changes over this line | |
921 | ;; plus enough other lines to get to one that | |
922 | ;; does not end inside a comment or string. | |
923 | ;; Meanwhile, do appropriate indentation on comment lines. | |
924 | (setq inner-loop-done nil) | |
925 | (while (and (not inner-loop-done) | |
926 | (not (and (eobp) (setq outer-loop-done t)))) | |
927 | (setq ostate state) | |
928 | (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) | |
929 | nil nil state)) | |
930 | (setq next-depth (car state)) | |
9875e646 TT |
931 | (if (or (nth 4 ostate)) |
932 | (tcl-indent-line)) | |
933 | (if (or (nth 3 state)) | |
934 | (forward-line 1) | |
935 | (setq inner-loop-done t))) | |
936 | (if (<= next-depth 0) | |
937 | (setq outer-loop-done t)) | |
938 | (if outer-loop-done | |
939 | nil | |
940 | ;; If this line had ..))) (((.. in it, pop out of the levels | |
941 | ;; that ended anywhere in this line, even if the final depth | |
942 | ;; doesn't indicate that they ended. | |
943 | (while (> last-depth (nth 6 state)) | |
944 | (setq indent-stack (cdr indent-stack) | |
945 | contain-stack (cdr contain-stack) | |
946 | last-depth (1- last-depth))) | |
9875e646 TT |
947 | ;; Add levels for any parens that were started in this line. |
948 | (while (< last-depth next-depth) | |
949 | (setq indent-stack (cons nil indent-stack) | |
950 | contain-stack (cons nil contain-stack) | |
951 | last-depth (1+ last-depth))) | |
952 | (if (null (car contain-stack)) | |
a1506d29 | 953 | (setcar contain-stack |
9875e646 TT |
954 | (or (car (cdr state)) |
955 | (save-excursion | |
956 | (forward-sexp -1) | |
957 | (point))))) | |
958 | (forward-line 1) | |
a1506d29 | 959 | (setq continued-line |
9875e646 TT |
960 | (save-excursion |
961 | (backward-char) | |
962 | (= (preceding-char) ?\\))) | |
963 | (skip-chars-forward " \t") | |
964 | (if (eolp) | |
965 | nil | |
966 | (if (and (car indent-stack) | |
967 | (>= (car indent-stack) 0)) | |
968 | ;; Line is on an existing nesting level. | |
969 | (setq this-indent (car indent-stack)) | |
970 | ;; Just started a new nesting level. | |
971 | ;; Compute the standard indent for this level. | |
c2ca5171 | 972 | (let ((val (tcl-calculate-indent |
9875e646 TT |
973 | (if (car indent-stack) |
974 | (- (car indent-stack)))))) | |
975 | (setcar indent-stack | |
976 | (setq this-indent val)) | |
977 | (setq continued-line nil))) | |
978 | (cond ((not (numberp this-indent))) | |
979 | ((= (following-char) ?}) | |
980 | (setq this-indent (- this-indent tcl-indent-level))) | |
981 | ((= (following-char) ?\]) | |
982 | (setq this-indent (- this-indent 1)))) | |
983 | ;; Put chosen indentation into effect. | |
984 | (or (null this-indent) | |
a1506d29 JB |
985 | (= (current-column) |
986 | (if continued-line | |
9875e646 TT |
987 | (+ this-indent tcl-indent-level) |
988 | this-indent)) | |
989 | (progn | |
990 | (delete-region (point) (progn (beginning-of-line) (point))) | |
a1506d29 JB |
991 | (indent-to |
992 | (if continued-line | |
9875e646 TT |
993 | (+ this-indent tcl-indent-level) |
994 | this-indent))))))))) | |
995 | ) | |
996 | ||
997 | \f | |
998 | ||
999 | ;; | |
1000 | ;; Interfaces to other packages. | |
1001 | ;; | |
1002 | ||
9875e646 | 1003 | ;; FIXME Definition of function is very ad-hoc. Should use |
c2ca5171 | 1004 | ;; beginning-of-defun. Also has incestuous knowledge about the |
9875e646 | 1005 | ;; format of tcl-proc-regexp. |
c2ca5171 | 1006 | (defun tcl-add-log-defun () |
9875e646 TT |
1007 | "Return name of Tcl function point is in, or nil." |
1008 | (save-excursion | |
150269d5 TT |
1009 | (end-of-line) |
1010 | (if (re-search-backward (concat tcl-proc-regexp "\\([^ \t\n{]+\\)") nil t) | |
c2ca5171 | 1011 | (match-string 2)))) |
9875e646 | 1012 | |
50776640 TT |
1013 | (defun tcl-outline-level () |
1014 | (save-excursion | |
1015 | (skip-chars-forward " \t") | |
1016 | (current-column))) | |
1017 | ||
9875e646 TT |
1018 | \f |
1019 | ||
1020 | ;; | |
1021 | ;; Helper functions for inferior Tcl mode. | |
1022 | ;; | |
1023 | ||
1024 | ;; This exists to let us delete the prompt when commands are sent | |
1025 | ;; directly to the inferior Tcl. See gud.el for an explanation of how | |
1026 | ;; it all works (I took it from there). This stuff doesn't really | |
1027 | ;; work as well as I'd like it to. But I don't believe there is | |
1028 | ;; anything useful that can be done. | |
1029 | (defvar inferior-tcl-delete-prompt-marker nil) | |
1030 | ||
1031 | (defun tcl-filter (proc string) | |
1032 | (let ((inhibit-quit t)) | |
c2ca5171 | 1033 | (with-current-buffer (process-buffer proc) |
9875e646 TT |
1034 | (goto-char (process-mark proc)) |
1035 | ;; Delete prompt if requested. | |
1036 | (if (marker-buffer inferior-tcl-delete-prompt-marker) | |
1037 | (progn | |
1038 | (delete-region (point) inferior-tcl-delete-prompt-marker) | |
1039 | (set-marker inferior-tcl-delete-prompt-marker nil))))) | |
c2ca5171 | 1040 | (comint-output-filter proc string)) |
9875e646 TT |
1041 | |
1042 | (defun tcl-send-string (proc string) | |
c2ca5171 | 1043 | (with-current-buffer (process-buffer proc) |
9875e646 | 1044 | (goto-char (process-mark proc)) |
75669e02 | 1045 | (forward-line 0) ;Not (beginning-of-line) because of fields. |
9875e646 TT |
1046 | (if (looking-at comint-prompt-regexp) |
1047 | (set-marker inferior-tcl-delete-prompt-marker (point)))) | |
1048 | (comint-send-string proc string)) | |
1049 | ||
1050 | (defun tcl-send-region (proc start end) | |
c2ca5171 | 1051 | (with-current-buffer (process-buffer proc) |
9875e646 | 1052 | (goto-char (process-mark proc)) |
75669e02 | 1053 | (forward-line 0) ;Not (beginning-of-line) because of fields. |
9875e646 TT |
1054 | (if (looking-at comint-prompt-regexp) |
1055 | (set-marker inferior-tcl-delete-prompt-marker (point)))) | |
1056 | (comint-send-region proc start end)) | |
1057 | ||
1058 | (defun switch-to-tcl (eob-p) | |
1059 | "Switch to inferior Tcl process buffer. | |
1060 | With argument, positions cursor at end of buffer." | |
1061 | (interactive "P") | |
1062 | (if (get-buffer inferior-tcl-buffer) | |
1063 | (pop-to-buffer inferior-tcl-buffer) | |
1064 | (error "No current inferior Tcl buffer")) | |
1065 | (cond (eob-p | |
1066 | (push-mark) | |
1067 | (goto-char (point-max))))) | |
1068 | ||
1069 | (defun inferior-tcl-proc () | |
1070 | "Return current inferior Tcl process. | |
1071 | See variable `inferior-tcl-buffer'." | |
1072 | (let ((proc (get-buffer-process (if (eq major-mode 'inferior-tcl-mode) | |
1073 | (current-buffer) | |
1074 | inferior-tcl-buffer)))) | |
1075 | (or proc | |
1076 | (error "No Tcl process; see variable `inferior-tcl-buffer'")))) | |
1077 | ||
1078 | (defun tcl-eval-region (start end &optional and-go) | |
1079 | "Send the current region to the inferior Tcl process. | |
1080 | Prefix argument means switch to the Tcl buffer afterwards." | |
1081 | (interactive "r\nP") | |
1082 | (let ((proc (inferior-tcl-proc))) | |
75669e02 SM |
1083 | (tcl-send-region |
1084 | proc | |
1085 | ;; Strip leading and trailing whitespace. | |
1086 | (save-excursion (goto-char start) (skip-chars-forward " \t\n") (point)) | |
1087 | (save-excursion (goto-char end) (skip-chars-backward " \t\n") (point))) | |
9875e646 TT |
1088 | (tcl-send-string proc "\n") |
1089 | (if and-go (switch-to-tcl t)))) | |
1090 | ||
1091 | (defun tcl-eval-defun (&optional and-go) | |
1092 | "Send the current defun to the inferior Tcl process. | |
1093 | Prefix argument means switch to the Tcl buffer afterwards." | |
1094 | (interactive "P") | |
1095 | (save-excursion | |
c2ca5171 | 1096 | (end-of-defun) |
9875e646 | 1097 | (let ((end (point))) |
c2ca5171 | 1098 | (beginning-of-defun) |
9875e646 TT |
1099 | (tcl-eval-region (point) end))) |
1100 | (if and-go (switch-to-tcl t))) | |
1101 | ||
1102 | \f | |
1103 | ||
1104 | ;; | |
1105 | ;; Inferior Tcl mode itself. | |
1106 | ;; | |
1107 | ||
c2ca5171 | 1108 | (define-derived-mode inferior-tcl-mode comint-mode "Inferior Tcl" |
9875e646 TT |
1109 | "Major mode for interacting with Tcl interpreter. |
1110 | ||
031a5886 | 1111 | You can start a Tcl process with \\[inferior-tcl]. |
9875e646 | 1112 | |
2f585cfe RS |
1113 | Entry to this mode runs the normal hooks `comint-mode-hook' and |
1114 | `inferior-tcl-mode-hook', in that order. | |
9875e646 TT |
1115 | |
1116 | You can send text to the inferior Tcl process from other buffers | |
1117 | containing Tcl source. | |
1118 | ||
1119 | Variables controlling Inferior Tcl mode: | |
c2ca5171 | 1120 | `tcl-application' |
9875e646 | 1121 | Name of program to run. |
c2ca5171 | 1122 | `tcl-command-switches' |
9875e646 | 1123 | Command line arguments to `tcl-application'. |
c2ca5171 | 1124 | `tcl-prompt-regexp' |
9875e646 | 1125 | Matches prompt. |
c2ca5171 | 1126 | `inferior-tcl-source-command' |
9875e646 | 1127 | Command to use to read Tcl file in running application. |
c2ca5171 | 1128 | `inferior-tcl-buffer' |
9875e646 TT |
1129 | The current inferior Tcl process buffer. See variable |
1130 | documentation for details on multiple-process support. | |
1131 | ||
1132 | The following commands are available: | |
1133 | \\{inferior-tcl-mode-map}" | |
c2ca5171 SM |
1134 | (set (make-local-variable 'comint-prompt-regexp) |
1135 | (or tcl-prompt-regexp | |
1136 | (concat "^" (regexp-quote tcl-application) ">"))) | |
1137 | (setq mode-line-process '(": %s")) | |
9875e646 TT |
1138 | (setq local-abbrev-table tcl-mode-abbrev-table) |
1139 | (set-syntax-table tcl-mode-syntax-table) | |
c2ca5171 SM |
1140 | (set (make-local-variable 'defun-prompt-regexp) tcl-omit-ws-regexp) |
1141 | (set (make-local-variable 'inferior-tcl-delete-prompt-marker) (make-marker)) | |
1142 | (set-process-filter (get-buffer-process (current-buffer)) 'tcl-filter)) | |
9875e646 | 1143 | |
cd754bf5 | 1144 | ;;;###autoload |
9875e646 TT |
1145 | (defun inferior-tcl (cmd) |
1146 | "Run inferior Tcl process. | |
1147 | Prefix arg means enter program name interactively. | |
1148 | See documentation for function `inferior-tcl-mode' for more information." | |
1149 | (interactive | |
1150 | (list (if current-prefix-arg | |
1151 | (read-string "Run Tcl: " tcl-application) | |
1152 | tcl-application))) | |
a2052295 JH |
1153 | (unless (comint-check-proc "*inferior-tcl*") |
1154 | (set-buffer (apply (function make-comint) "inferior-tcl" cmd nil | |
1155 | tcl-command-switches)) | |
75669e02 SM |
1156 | (inferior-tcl-mode) |
1157 | ;; Make tclsh display a prompt on ms-windows (or under Unix, when a tty | |
1158 | ;; wasn't used). Doesn't affect wish, unfortunately. | |
1159 | (unless (process-tty-name (inferior-tcl-proc)) | |
1160 | (tcl-send-string (inferior-tcl-proc) | |
1161 | "set ::tcl_interactive 1; concat\n"))) | |
a2052295 | 1162 | (set (make-local-variable 'tcl-application) cmd) |
9875e646 | 1163 | (setq inferior-tcl-buffer "*inferior-tcl*") |
a2052295 | 1164 | (pop-to-buffer "*inferior-tcl*")) |
9875e646 | 1165 | |
c2ca5171 | 1166 | (defalias 'run-tcl 'inferior-tcl) |
9875e646 TT |
1167 | |
1168 | \f | |
1169 | ||
1170 | ;; | |
1171 | ;; Auto-fill support. | |
1172 | ;; | |
1173 | ||
1174 | (defun tcl-real-command-p () | |
1175 | "Return nil if point is not at the beginning of a command. | |
1176 | A command is the first word on an otherwise empty line, or the | |
1177 | first word following a semicolon, opening brace, or opening bracket." | |
1178 | (save-excursion | |
1179 | (skip-chars-backward " \t") | |
1180 | (cond | |
1181 | ((bobp) t) | |
1182 | ((bolp) | |
1183 | (backward-char) | |
1184 | ;; Note -- continued comments are not supported here. I | |
1185 | ;; consider those to be a wart on the language. | |
1186 | (not (eq ?\\ (preceding-char)))) | |
1187 | (t | |
1188 | (memq (preceding-char) '(?\; ?{ ?\[)))))) | |
1189 | ||
1190 | ;; FIXME doesn't actually return t. See last case. | |
1191 | (defun tcl-real-comment-p () | |
1192 | "Return t if point is just after the `#' beginning a real comment. | |
1193 | Does not check to see if previous char is actually `#'. | |
1194 | A real comment is either at the beginning of the buffer, | |
9ad79cb4 | 1195 | preceded only by whitespace on the line, or has a preceding |
9875e646 TT |
1196 | semicolon, opening brace, or opening bracket on the same line." |
1197 | (save-excursion | |
1198 | (backward-char) | |
1199 | (tcl-real-command-p))) | |
1200 | ||
1201 | (defun tcl-hairy-scan-for-comment (state end always-stop) | |
1202 | "Determine if point is in a comment. | |
1203 | Returns a list of the form `(FLAG . STATE)'. STATE can be used | |
1204 | as input to future invocations. FLAG is nil if not in comment, | |
1205 | t otherwise. If in comment, leaves point at beginning of comment. | |
2f585cfe RS |
1206 | |
1207 | This function does not work in Emacs 18. | |
1208 | See also `tcl-simple-scan-for-comment', a | |
9875e646 TT |
1209 | simpler version that is often right, and works in Emacs 18." |
1210 | (let ((bol (save-excursion | |
1211 | (goto-char end) | |
1212 | (beginning-of-line) | |
1213 | (point))) | |
1214 | real-comment | |
1215 | last-cstart) | |
1216 | (while (and (not last-cstart) (< (point) end)) | |
c2ca5171 | 1217 | (setq real-comment nil) ;In case we've looped around and it is set. |
9875e646 TT |
1218 | (setq state (parse-partial-sexp (point) end nil nil state t)) |
1219 | (if (nth 4 state) | |
1220 | (progn | |
1221 | ;; If ALWAYS-STOP is set, stop even if we don't have a | |
1222 | ;; real comment, or if the comment isn't on the same line | |
1223 | ;; as the end. | |
1224 | (if always-stop (setq last-cstart (point))) | |
1225 | ;; If we have a real comment, then set the comment | |
1226 | ;; starting point if we are on the same line as the ending | |
1227 | ;; location. | |
1228 | (setq real-comment (tcl-real-comment-p)) | |
1229 | (if real-comment | |
1230 | (progn | |
1231 | (and (> (point) bol) (setq last-cstart (point))) | |
1232 | ;; NOTE Emacs 19 has a misfeature whereby calling | |
1233 | ;; parse-partial-sexp with COMMENTSTOP set and with | |
1234 | ;; an initial list that says point is in a comment | |
1235 | ;; will cause an immediate return. So we must skip | |
1236 | ;; over the comment ourselves. | |
1237 | (beginning-of-line 2))) | |
1238 | ;; Frob the state to make it look like we aren't in a | |
1239 | ;; comment. | |
1240 | (setcar (nthcdr 4 state) nil)))) | |
1241 | (and last-cstart | |
1242 | (goto-char last-cstart)) | |
1243 | (cons real-comment state))) | |
1244 | ||
c2ca5171 | 1245 | (defun tcl-in-comment () |
2f585cfe | 1246 | "Return t if point is in a comment, and leave point at beginning of comment." |
9875e646 | 1247 | (let ((save (point))) |
c2ca5171 | 1248 | (beginning-of-defun) |
9875e646 | 1249 | (car (tcl-hairy-scan-for-comment nil save nil)))) |
6be8057e | 1250 | |
9875e646 TT |
1251 | \f |
1252 | ||
1253 | ;; | |
1254 | ;; Help-related code. | |
1255 | ;; | |
1256 | ||
95338744 TT |
1257 | (defvar tcl-help-saved-dirs nil |
1258 | "Saved help directories. | |
1259 | If `tcl-help-directory-list' changes, this allows `tcl-help-on-word' | |
1260 | to update the alist.") | |
9875e646 TT |
1261 | |
1262 | (defvar tcl-help-alist nil | |
1263 | "Alist with command names as keys and filenames as values.") | |
1264 | ||
c2ca5171 SM |
1265 | (defun tcl-files-alist (dir &optional alist) |
1266 | "Recursively add all pairs (FILE . PATH) under DIR to ALIST." | |
1267 | (dolist (file (directory-files dir t) alist) | |
1268 | (cond | |
1269 | ((not (file-directory-p file)) | |
1270 | (push (cons (file-name-nondirectory file) file) alist)) | |
1271 | ((member (file-name-nondirectory file) '("." ".."))) | |
1272 | (t (setq alist (tcl-files-alist file alist)))))) | |
1273 | ||
95338744 | 1274 | (defun tcl-help-snarf-commands (dirlist) |
c2ca5171 SM |
1275 | "Return alist of commands and filenames." |
1276 | (let ((alist nil)) | |
1277 | (dolist (dir dirlist alist) | |
1278 | (when (file-directory-p dir) | |
1279 | (setq alist (tcl-files-alist dir alist)))))) | |
9875e646 TT |
1280 | |
1281 | (defun tcl-reread-help-files () | |
1282 | "Set up to re-read files, and then do it." | |
1283 | (interactive) | |
1284 | (message "Building Tcl help file index...") | |
95338744 | 1285 | (setq tcl-help-saved-dirs tcl-help-directory-list) |
c2ca5171 | 1286 | (setq tcl-help-alist (tcl-help-snarf-commands tcl-help-directory-list)) |
9875e646 TT |
1287 | (message "Building Tcl help file index...done")) |
1288 | ||
6654e1b1 | 1289 | (defun tcl-word-no-props () |
c2ca5171 | 1290 | "Like `current-word', but strips properties." |
6654e1b1 | 1291 | (let ((word (current-word))) |
c2ca5171 | 1292 | (set-text-properties 0 (length word) nil word) |
6654e1b1 TT |
1293 | word)) |
1294 | ||
9875e646 TT |
1295 | (defun tcl-current-word (flag) |
1296 | "Return current command word, or nil. | |
1297 | If FLAG is nil, just uses `current-word'. | |
1298 | Otherwise scans backward for most likely Tcl command word." | |
f5608c76 TT |
1299 | (if (and flag |
1300 | (memq major-mode '(tcl-mode inferior-tcl-mode))) | |
9875e646 TT |
1301 | (condition-case nil |
1302 | (save-excursion | |
1303 | ;; Look backward for first word actually in alist. | |
1304 | (if (bobp) | |
1305 | () | |
1306 | (while (and (not (bobp)) | |
1307 | (not (tcl-real-command-p))) | |
1308 | (backward-sexp))) | |
6654e1b1 TT |
1309 | (if (assoc (tcl-word-no-props) tcl-help-alist) |
1310 | (tcl-word-no-props))) | |
9875e646 | 1311 | (error nil)) |
6654e1b1 | 1312 | (tcl-word-no-props))) |
9875e646 | 1313 | |
cd754bf5 | 1314 | ;;;###autoload |
9875e646 TT |
1315 | (defun tcl-help-on-word (command &optional arg) |
1316 | "Get help on Tcl command. Default is word at point. | |
1317 | Prefix argument means invert sense of `tcl-use-smart-word-finder'." | |
1318 | (interactive | |
1319 | (list | |
1320 | (progn | |
95338744 | 1321 | (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) |
9875e646 TT |
1322 | (tcl-reread-help-files)) |
1323 | (let ((word (tcl-current-word | |
1324 | (if current-prefix-arg | |
1325 | (not tcl-use-smart-word-finder) | |
1326 | tcl-use-smart-word-finder)))) | |
1327 | (completing-read | |
1328 | (if (or (null word) (string= word "")) | |
1329 | "Help on Tcl command: " | |
1330 | (format "Help on Tcl command (default %s): " word)) | |
c2ca5171 | 1331 | tcl-help-alist nil t nil nil word))) |
9875e646 | 1332 | current-prefix-arg)) |
95338744 | 1333 | (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) |
9875e646 TT |
1334 | (tcl-reread-help-files)) |
1335 | (if (string= command "") | |
1336 | (setq command (tcl-current-word | |
1337 | (if arg | |
1338 | (not tcl-use-smart-word-finder) | |
1339 | tcl-use-smart-word-finder)))) | |
1340 | (let* ((help (get-buffer-create "*Tcl help*")) | |
1341 | (cell (assoc command tcl-help-alist)) | |
1342 | (file (and cell (cdr cell)))) | |
1343 | (set-buffer help) | |
1344 | (delete-region (point-min) (point-max)) | |
1345 | (if file | |
1346 | (progn | |
1347 | (insert "*** " command "\n\n") | |
1348 | (insert-file-contents file)) | |
1349 | (if (string= command "") | |
1350 | (insert "Magical Pig!") | |
1351 | (insert "Tcl command " command " not in help\n"))) | |
1352 | (set-buffer-modified-p nil) | |
1353 | (goto-char (point-min)) | |
1354 | (display-buffer help))) | |
1355 | ||
1356 | \f | |
1357 | ||
1358 | ;; | |
1359 | ;; Other interactive stuff. | |
1360 | ;; | |
1361 | ||
1362 | (defvar tcl-previous-dir/file nil | |
1363 | "Record last directory and file used in loading. | |
1364 | This holds a cons cell of the form `(DIRECTORY . FILE)' | |
1365 | describing the last `tcl-load-file' command.") | |
1366 | ||
1367 | (defun tcl-load-file (file &optional and-go) | |
1368 | "Load a Tcl file into the inferior Tcl process. | |
1369 | Prefix argument means switch to the Tcl buffer afterwards." | |
1370 | (interactive | |
1371 | (list | |
1372 | ;; car because comint-get-source returns a list holding the | |
1373 | ;; filename. | |
700a20bf TT |
1374 | (car (comint-get-source "Load Tcl file: " |
1375 | (or (and | |
1376 | (eq major-mode 'tcl-mode) | |
1377 | (buffer-file-name)) | |
1378 | tcl-previous-dir/file) | |
9875e646 TT |
1379 | '(tcl-mode) t)) |
1380 | current-prefix-arg)) | |
1381 | (comint-check-source file) | |
1382 | (setq tcl-previous-dir/file (cons (file-name-directory file) | |
1383 | (file-name-nondirectory file))) | |
1384 | (tcl-send-string (inferior-tcl-proc) | |
1385 | (format inferior-tcl-source-command (tcl-quote file))) | |
1386 | (if and-go (switch-to-tcl t))) | |
1387 | ||
9875e646 TT |
1388 | (defun tcl-restart-with-file (file &optional and-go) |
1389 | "Restart inferior Tcl with file. | |
1390 | If an inferior Tcl process exists, it is killed first. | |
1391 | Prefix argument means switch to the Tcl buffer afterwards." | |
1392 | (interactive | |
1393 | (list | |
1394 | (car (comint-get-source "Restart with Tcl file: " | |
1395 | (or (and | |
1396 | (eq major-mode 'tcl-mode) | |
1397 | (buffer-file-name)) | |
1398 | tcl-previous-dir/file) | |
1399 | '(tcl-mode) t)) | |
1400 | current-prefix-arg)) | |
1401 | (let* ((buf (if (eq major-mode 'inferior-tcl-mode) | |
1402 | (current-buffer) | |
1403 | inferior-tcl-buffer)) | |
1404 | (proc (and buf (get-process buf)))) | |
1405 | (cond | |
1406 | ((not (and buf (get-buffer buf))) | |
1407 | ;; I think this will be ok. | |
1408 | (inferior-tcl tcl-application) | |
1409 | (tcl-load-file file and-go)) | |
1410 | ((or | |
1411 | (not (comint-check-proc buf)) | |
1412 | (yes-or-no-p | |
1413 | "A Tcl process is running, are you sure you want to reset it? ")) | |
1414 | (save-excursion | |
1415 | (comint-check-source file) | |
1416 | (setq tcl-previous-dir/file (cons (file-name-directory file) | |
1417 | (file-name-nondirectory file))) | |
1418 | (comint-exec (get-buffer-create buf) | |
1419 | (if proc | |
1420 | (process-name proc) | |
1421 | "inferior-tcl") | |
1422 | tcl-application file tcl-command-switches) | |
1423 | (if and-go (switch-to-tcl t))))))) | |
1424 | ||
9875e646 | 1425 | (defun tcl-auto-fill-mode (&optional arg) |
2c7cdd69 | 1426 | "Like `auto-fill-mode', but sets `comment-auto-fill-only-comments'." |
9875e646 | 1427 | (interactive "P") |
2c7cdd69 SM |
1428 | (auto-fill-mode arg) |
1429 | (if auto-fill-function | |
1430 | (set (make-local-variable 'comment-auto-fill-only-comments) t) | |
1431 | (kill-local-variable 'comment-auto-fill-only-comments))) | |
9875e646 TT |
1432 | |
1433 | (defun tcl-electric-hash (&optional count) | |
1434 | "Insert a `#' and quote if it does not start a real comment. | |
1435 | Prefix arg is number of `#'s to insert. | |
1436 | See variable `tcl-electric-hash-style' for description of quoting | |
1437 | styles." | |
1438 | (interactive "p") | |
1439 | (or count (setq count 1)) | |
1440 | (if (> count 0) | |
1441 | (let ((type | |
1442 | (if (eq tcl-electric-hash-style 'smart) | |
1443 | (if (> count 3) ; FIXME what is "smart"? | |
1444 | 'quote | |
1445 | 'backslash) | |
1446 | tcl-electric-hash-style)) | |
1447 | comment) | |
1448 | (if type | |
1449 | (progn | |
1450 | (save-excursion | |
1451 | (insert "#") | |
1452 | (setq comment (tcl-in-comment))) | |
1453 | (delete-char 1) | |
1454 | (and tcl-explain-indentation (message "comment: %s" comment)) | |
1455 | (cond | |
1456 | ((eq type 'quote) | |
1457 | (if (not comment) | |
1458 | (insert "\""))) | |
1459 | ((eq type 'backslash) | |
1460 | ;; The following will set count to 0, so the | |
1461 | ;; insert-char can still be run. | |
1462 | (if (not comment) | |
1463 | (while (> count 0) | |
1464 | (insert "\\#") | |
1465 | (setq count (1- count))))) | |
1466 | (t nil)))) | |
1467 | (insert-char ?# count)))) | |
1468 | ||
1469 | (defun tcl-hashify-buffer () | |
1470 | "Quote all `#'s in current buffer that aren't Tcl comments." | |
1471 | (interactive) | |
1472 | (save-excursion | |
1473 | (goto-char (point-min)) | |
c2ca5171 SM |
1474 | (let (state |
1475 | result) | |
1476 | (while (< (point) (point-max)) | |
1477 | (setq result (tcl-hairy-scan-for-comment state (point-max) t)) | |
1478 | (if (car result) | |
9875e646 | 1479 | (beginning-of-line 2) |
9875e646 | 1480 | (backward-char) |
c2ca5171 | 1481 | (if (eq ?# (following-char)) |
9875e646 | 1482 | (insert "\\")) |
c2ca5171 SM |
1483 | (forward-char)) |
1484 | (setq state (cdr result)))))) | |
1485 | ||
1486 | (defun tcl-comment-indent () | |
1487 | "Return the desired indentation, but be careful to add a `;' if needed." | |
1488 | (save-excursion | |
1489 | ;; If line is not blank, make sure we insert a ";" first. | |
1490 | (skip-chars-backward " \t") | |
1491 | (unless (or (bolp) (tcl-real-command-p)) | |
1492 | (insert ";") | |
1493 | ;; Try and erase a non-significant char to keep charpos identical. | |
5089af27 | 1494 | (if (memq (char-after) '(?\t ?\s)) (delete-char 1)))) |
c2ca5171 | 1495 | (funcall (default-value 'comment-indent-function))) |
95338744 | 1496 | |
9875e646 TT |
1497 | ;; The following was inspired by the Tcl editing mode written by |
1498 | ;; Gregor Schmid <schmid@fb3-s7.math.TU-Berlin.DE>. His version also | |
1499 | ;; attempts to snarf the command line options from the command line, | |
1500 | ;; but I didn't think that would really be that helpful (doesn't seem | |
c2ca5171 | 1501 | ;; like it would be right enough. His version also looks for the |
9875e646 | 1502 | ;; "#!/bin/csh ... exec" hack, but that seemed even less useful. |
95338744 TT |
1503 | ;; FIXME should make sure that the application mentioned actually |
1504 | ;; exists. | |
9875e646 TT |
1505 | (defun tcl-guess-application () |
1506 | "Attempt to guess Tcl application by looking at first line. | |
1507 | The first line is assumed to look like \"#!.../program ...\"." | |
1508 | (save-excursion | |
1509 | (goto-char (point-min)) | |
3530a317 | 1510 | (if (looking-at "#![^ \t]*/\\([^ \t\n/]+\\)\\([ \t]\\|$\\)") |
c2ca5171 | 1511 | (set (make-local-variable 'tcl-application) (match-string 1))))) |
9875e646 TT |
1512 | |
1513 | \f | |
1514 | ||
1515 | ;; | |
e9e7f5f2 | 1516 | ;; XEmacs menu support. |
9875e646 TT |
1517 | ;; Taken from schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid), |
1518 | ;; who wrote a different Tcl mode. | |
2f585cfe | 1519 | ;; We also have support for menus in Emacs. We do this by |
e9e7f5f2 | 1520 | ;; loading the XEmacs menu emulation code. |
9875e646 TT |
1521 | ;; |
1522 | ||
9875e646 | 1523 | (defun tcl-popup-menu (e) |
9aa88f3e | 1524 | (interactive "@e") |
c2ca5171 | 1525 | (popup-menu tcl-mode-menu)) |
9875e646 TT |
1526 | |
1527 | \f | |
1528 | ||
1529 | ;; | |
1530 | ;; Quoting and unquoting functions. | |
1531 | ;; | |
1532 | ||
1533 | ;; This quoting is sufficient to protect eg a filename from any sort | |
1534 | ;; of expansion or splitting. Tcl quoting sure sucks. | |
1535 | (defun tcl-quote (string) | |
1536 | "Quote STRING according to Tcl rules." | |
c2ca5171 | 1537 | (mapconcat (lambda (char) |
5089af27 | 1538 | (if (memq char '(?[ ?] ?{ ?} ?\\ ?\" ?$ ?\s ?\;)) |
c2ca5171 SM |
1539 | (concat "\\" (char-to-string char)) |
1540 | (char-to-string char))) | |
9875e646 TT |
1541 | string "")) |
1542 | ||
6be8057e TT |
1543 | ;; |
1544 | ;; Bug reporting. | |
1545 | ;; | |
6be8057e TT |
1546 | \f |
1547 | ||
c2ca5171 SM |
1548 | ;; These are relics kept "just in case". |
1549 | (defalias 'tcl-uncomment-region 'uncomment-region) | |
1550 | (defalias 'tcl-indent-for-comment 'comment-indent) | |
1551 | (defalias 'add-log-tcl-defun 'tcl-add-log-defun) | |
1552 | (defalias 'indent-tcl-exp 'tcl-indent-exp) | |
1553 | (defalias 'calculate-tcl-indent 'tcl-calculate-indent) | |
1554 | (defalias 'tcl-beginning-of-defun 'beginning-of-defun) | |
1555 | (defalias 'tcl-end-of-defun 'end-of-defun) | |
1556 | (defalias 'tcl-mark-defun 'mark-defun) | |
1557 | (defun tcl-mark () (mark t)) | |
1558 | ||
9875e646 TT |
1559 | (provide 'tcl) |
1560 | ||
4c5113c7 | 1561 | ;; arch-tag: 8a032554-c3ef-422e-b84c-acec0522179d |
9875e646 | 1562 | ;;; tcl.el ends here |