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