Commit | Line | Data |
---|---|---|
e8af40ee | 1 | ;;; tcl.el --- Tcl code editing commands for Emacs |
9875e646 | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 1994, 1998-2011 Free Software Foundation, Inc. |
9875e646 | 4 | |
2c7cdd69 | 5 | ;; Maintainer: FSF |
0472b23e | 6 | ;; Author: Tom Tromey <tromey@redhat.com> |
db2e9cdd TT |
7 | ;; Chris Lindblad <cjl@lcs.mit.edu> |
8 | ;; Keywords: languages tcl modes | |
9875e646 TT |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
b1fc2b50 | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
9875e646 | 13 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
9875e646 TT |
16 | |
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
9875e646 | 24 | |
2f585cfe | 25 | ;; BEFORE USE: |
9875e646 TT |
26 | ;; |
27 | ;; If you plan to use the interface to the TclX help files, you must | |
95338744 TT |
28 | ;; set the variable tcl-help-directory-list to point to the topmost |
29 | ;; directories containing the TclX help files. Eg: | |
9875e646 | 30 | ;; |
95338744 | 31 | ;; (setq tcl-help-directory-list '("/usr/local/lib/tclx/help")) |
9875e646 | 32 | ;; |
9875e646 TT |
33 | ;;; Commentary: |
34 | ||
9875e646 TT |
35 | ;; CUSTOMIZATION NOTES: |
36 | ;; * tcl-proc-list can be used to customize a list of things that | |
37 | ;; "define" other things. Eg in my project I put "defvar" in this | |
38 | ;; list. | |
39 | ;; * tcl-typeword-list is similar, but uses font-lock-type-face. | |
40 | ;; * tcl-keyword-list is a list of keywords. I've generally used this | |
41 | ;; for flow-control words. Eg I add "unwind_protect" to this list. | |
d6d43bde | 42 | ;; * tcl-builtin-list lists commands to be given font-lock-builtin-face. |
9875e646 TT |
43 | ;; * tcl-type-alist can be used to minimally customize indentation |
44 | ;; according to context. | |
45 | ||
94662de7 | 46 | ;; THANKS FOR CRITICISM AND SUGGESTIONS TO: |
9875e646 TT |
47 | ;; Guido Bosch <Guido.Bosch@loria.fr> |
48 | ;; pgs1002@esc.cam.ac.uk (Dr P.G. Sjoerdsma) | |
49 | ;; Mike Scheidler <c23mts@kocrsv01.delcoelect.com> | |
50 | ;; Matt Newman <men@charney.colorado.edu> | |
51 | ;; rwhitby@research.canon.oz.au (Rod Whitby) | |
52 | ;; h9118101@hkuxa.hku.hk (Yip Chi Lap [Beta]) | |
53 | ;; Pertti Tapio Kasanen <ptk@delta.hut.fi> | |
54 | ;; schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid) | |
597c7ed5 TT |
55 | ;; warsaw@nlm.nih.gov (Barry A. Warsaw) |
56 | ;; Carl Witty <cwitty@ai.mit.edu> | |
3530a317 | 57 | ;; T. V. Raman <raman@crl.dec.com> |
50776640 | 58 | ;; Jesper Pedersen <blackie@imada.ou.dk> |
e9e7f5f2 | 59 | ;; dfarmer@evolving.com (Doug Farmer) |
8967cd6e | 60 | ;; "Chris Alfeld" <calfeld@math.utah.edu> |
2c7cdd69 | 61 | ;; Ben Wing <ben@xemacs.org> |
9875e646 TT |
62 | |
63 | ;; KNOWN BUGS: | |
2c7cdd69 SM |
64 | ;; * In Tcl "#" is not always a comment character. This can confuse tcl.el |
65 | ;; in certain circumstances. For now the only workaround is to use | |
66 | ;; font-lock which will mark the # chars accordingly or enclose offending | |
67 | ;; hash characters in quotes or precede them with a backslash. Note that | |
68 | ;; using braces won't work -- quotes change the syntax class of characters | |
69 | ;; between them, while braces do not. If you don't use font-lock, the | |
70 | ;; electric-# mode helps alleviate this problem somewhat. | |
9875e646 | 71 | ;; * indent-tcl-exp is untested. |
9875e646 TT |
72 | |
73 | ;; TODO: | |
74 | ;; * make add-log-tcl-defun smarter. should notice if we are in the | |
75 | ;; middle of a defun, or between defuns. should notice if point is | |
76 | ;; on first line of defun (or maybe even in comments before defun). | |
77 | ;; * Allow continuation lines to be indented under the first argument | |
9ad79cb4 | 78 | ;; of the preceding line, like this: |
9875e646 TT |
79 | ;; [list something \ |
80 | ;; something-else] | |
81 | ;; * There is a request that indentation work like this: | |
82 | ;; button .fred -label Fred \ | |
83 | ;; -command {puts fred} | |
84 | ;; * Should have tcl-complete-symbol that queries the inferior process. | |
85 | ;; * Should have describe-symbol that works by sending the magic | |
86 | ;; command to a tclX process. | |
87 | ;; * Need C-x C-e binding (tcl-eval-last-exp). | |
88 | ;; * Write indent-region function that is faster than indenting each | |
89 | ;; line individually. | |
90 | ;; * tcl-figure-type should stop at "beginning of line" (only ws | |
91 | ;; before point, and no "\" on previous line). (see tcl-real-command-p). | |
9875e646 TT |
92 | ;; * overrides some comint keybindings; fix. |
93 | ;; * Trailing \ will eat blank lines. Should deal with this. | |
94 | ;; (this would help catch some potential bugs). | |
95 | ;; * Inferior should display in half the screen, not the whole screen. | |
95338744 TT |
96 | ;; * Indentation should deal with "switch". |
97 | ;; * Consider writing code to find help files automatically (for | |
98 | ;; common cases). | |
6be8057e | 99 | ;; * `#' shouldn't insert `\#' when point is in string. |
9875e646 TT |
100 | |
101 | \f | |
102 | ||
103 | ;;; Code: | |
104 | ||
850d5045 | 105 | (eval-when-compile |
c2ca5171 | 106 | (require 'imenu) |
850d5045 GM |
107 | (require 'outline) |
108 | (require 'dabbrev) | |
109 | (require 'add-log)) | |
110 | ||
9875e646 TT |
111 | (require 'comint) |
112 | ||
113 | ;; | |
114 | ;; User variables. | |
115 | ;; | |
116 | ||
94662de7 | 117 | (defgroup tcl nil |
5089af27 | 118 | "Major mode for editing Tcl source in Emacs." |
8ec3bce0 | 119 | :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) |
94662de7 | 120 | :group 'languages) |
9875e646 | 121 | |
94662de7 RS |
122 | (defcustom tcl-indent-level 4 |
123 | "*Indentation of Tcl statements with respect to containing block." | |
f5307782 JB |
124 | :type 'integer |
125 | :group 'tcl) | |
b14d552b | 126 | (put 'tcl-indent-level 'safe-local-variable 'integerp) |
9875e646 | 127 | |
94662de7 RS |
128 | (defcustom tcl-continued-indent-level 4 |
129 | "*Indentation of continuation line relative to first line of command." | |
f5307782 JB |
130 | :type 'integer |
131 | :group 'tcl) | |
b14d552b | 132 | (put 'tcl-continued-indent-level 'safe-local-variable 'integerp) |
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 | ||
cf38dd42 SM |
413 | (defconst tcl-syntax-propertize-function |
414 | (syntax-propertize-rules | |
415 | ;; Mark the few `#' that are not comment-markers. | |
416 | ("[^;[{ \t\n][ \t]*\\(#\\)" (1 "."))) | |
c2ca5171 SM |
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 |
ae0c2494 | 548 | (define-derived-mode tcl-mode prog-mode "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 | 573 | `tcl-mode-hook' to see what kinds of interesting hook functions |
175069ef | 574 | already exist." |
031a5886 | 575 | (unless (and (boundp 'filladapt-mode) filladapt-mode) |
cd21c04a | 576 | (set (make-local-variable 'paragraph-ignore-fill-prefix) t)) |
c2ca5171 SM |
577 | |
578 | (set (make-local-variable 'indent-line-function) 'tcl-indent-line) | |
579 | (set (make-local-variable 'comment-indent-function) 'tcl-comment-indent) | |
9875e646 TT |
580 | ;; Tcl doesn't require a final newline. |
581 | ;; (make-local-variable 'require-final-newline) | |
582 | ;; (setq require-final-newline t) | |
9aa88f3e | 583 | |
c2ca5171 | 584 | (set (make-local-variable 'comment-start) "# ") |
a2c6faea SM |
585 | (set (make-local-variable 'comment-start-skip) |
586 | "\\(\\(^\\|[;{[]\\)\\s-*\\)#+ *") | |
c2ca5171 | 587 | (set (make-local-variable 'comment-end) "") |
50776640 | 588 | |
cd21c04a | 589 | (set (make-local-variable 'outline-regexp) ".") |
c2ca5171 | 590 | (set (make-local-variable 'outline-level) 'tcl-outline-level) |
a3dfa2c0 | 591 | |
c2ca5171 | 592 | (set (make-local-variable 'font-lock-defaults) |
cf38dd42 SM |
593 | '(tcl-font-lock-keywords nil nil nil beginning-of-defun)) |
594 | (set (make-local-variable 'syntax-propertize-function) | |
595 | tcl-syntax-propertize-function) | |
9aa88f3e | 596 | |
031a5886 | 597 | (set (make-local-variable 'imenu-generic-expression) |
ec91f773 | 598 | tcl-imenu-generic-expression) |
a1506d29 | 599 | |
68734e7b | 600 | ;; Settings for new dabbrev code. |
c2ca5171 SM |
601 | (set (make-local-variable 'dabbrev-case-fold-search) nil) |
602 | (set (make-local-variable 'dabbrev-case-replace) nil) | |
603 | (set (make-local-variable 'dabbrev-abbrev-skip-leading-regexp) "[$!]") | |
604 | (set (make-local-variable 'dabbrev-abbrev-char-regexp) "\\sw\\|\\s_") | |
605 | ||
c2ca5171 SM |
606 | (set (make-local-variable 'parse-sexp-ignore-comments) t) |
607 | ;; XEmacs has defun-prompt-regexp, but I don't believe | |
608 | ;; that it works for end-of-defun -- only for | |
609 | ;; beginning-of-defun. | |
610 | (set (make-local-variable 'defun-prompt-regexp) tcl-omit-ws-regexp) | |
c2ca5171 SM |
611 | (set (make-local-variable 'add-log-current-defun-function) |
612 | 'tcl-add-log-defun) | |
613 | ||
614 | (easy-menu-add tcl-mode-menu) | |
e9e7f5f2 | 615 | ;; Append Tcl menu to popup menu for XEmacs. |
c2ca5171 | 616 | (if (boundp 'mode-popup-menu) |
c803d3a7 | 617 | (setq mode-popup-menu |
c2ca5171 | 618 | (cons (concat mode-name " Mode Commands") tcl-mode-menu)))) |
9875e646 TT |
619 | |
620 | \f | |
621 | ||
622 | ;; This is used for braces, brackets, and semi (except for closing | |
623 | ;; braces, which are handled specially). | |
624 | (defun tcl-electric-char (arg) | |
625 | "Insert character and correct line's indentation." | |
626 | (interactive "p") | |
627 | ;; Indent line first; this looks better if parens blink. | |
628 | (tcl-indent-line) | |
629 | (self-insert-command arg) | |
1ba983e8 | 630 | (if (and tcl-auto-newline (= last-command-event ?\;)) |
9875e646 TT |
631 | (progn |
632 | (newline) | |
633 | (tcl-indent-line)))) | |
634 | ||
635 | ;; This is used for closing braces. If tcl-auto-newline is set, can | |
636 | ;; insert a newline both before and after the brace, depending on | |
637 | ;; context. FIXME should this be configurable? Does anyone use this? | |
638 | (defun tcl-electric-brace (arg) | |
639 | "Insert character and correct line's indentation." | |
640 | (interactive "p") | |
641 | ;; If auto-newlining and there is stuff on the same line, insert a | |
642 | ;; newline first. | |
643 | (if tcl-auto-newline | |
644 | (progn | |
645 | (if (save-excursion | |
646 | (skip-chars-backward " \t") | |
647 | (bolp)) | |
648 | () | |
649 | (tcl-indent-line) | |
650 | (newline)) | |
651 | ;; In auto-newline case, must insert a newline after each | |
652 | ;; brace. So an explicit loop is needed. | |
653 | (while (> arg 0) | |
1ba983e8 | 654 | (insert last-command-event) |
9875e646 TT |
655 | (tcl-indent-line) |
656 | (newline) | |
657 | (setq arg (1- arg)))) | |
658 | (self-insert-command arg)) | |
659 | (tcl-indent-line)) | |
660 | ||
661 | \f | |
662 | ||
663 | (defun tcl-indent-command (&optional arg) | |
664 | "Indent current line as Tcl code, or in some cases insert a tab character. | |
2f585cfe RS |
665 | If `tcl-tab-always-indent' is t (the default), always indent current line. |
666 | If `tcl-tab-always-indent' is nil and point is not in the indentation | |
9875e646 | 667 | area at the beginning of the line, a TAB is inserted. |
2f585cfe | 668 | Other values of `tcl-tab-always-indent' cause the first possible action |
9875e646 TT |
669 | from the following list to take place: |
670 | ||
671 | 1. Move from beginning of line to correct indentation. | |
672 | 2. Delete an empty comment. | |
673 | 3. Move forward to start of comment, indenting if necessary. | |
674 | 4. Move forward to end of line, indenting if necessary. | |
675 | 5. Create an empty comment. | |
676 | 6. Move backward to start of comment, indenting if necessary." | |
677 | (interactive "p") | |
05794f14 SM |
678 | (if (memq tcl-tab-always-indent '(nil t)) |
679 | (let ((tab-always-indent tcl-tab-always-indent)) | |
680 | (call-interactively 'indent-for-tab-command)) | |
9875e646 TT |
681 | ;; "Perl-mode" style TAB command. |
682 | (let* ((ipoint (point)) | |
683 | (eolpoint (progn | |
684 | (end-of-line) | |
685 | (point))) | |
686 | (comment-p (tcl-in-comment))) | |
687 | (cond | |
c2ca5171 | 688 | ((= ipoint (line-beginning-position)) |
9875e646 TT |
689 | (beginning-of-line) |
690 | (tcl-indent-line) | |
691 | ;; If indenting didn't leave us in column 0, go to the | |
692 | ;; indentation. Otherwise leave point at end of line. This | |
693 | ;; is a hack. | |
c2ca5171 | 694 | (if (= (point) (line-beginning-position)) |
9875e646 TT |
695 | (end-of-line) |
696 | (back-to-indentation))) | |
697 | ((and comment-p (looking-at "[ \t]*$")) | |
698 | ;; Empty comment, so delete it. We also delete any ";" | |
699 | ;; characters at the end of the line. I think this is | |
700 | ;; friendlier, but I don't know how other people will feel. | |
701 | (backward-char) | |
702 | (skip-chars-backward " \t;") | |
703 | (delete-region (point) eolpoint)) | |
704 | ((and comment-p (< ipoint (point))) | |
705 | ;; Before comment, so skip to it. | |
706 | (tcl-indent-line) | |
707 | (indent-for-comment)) | |
708 | ((/= ipoint eolpoint) | |
709 | ;; Go to end of line (since we're not there yet). | |
710 | (goto-char eolpoint) | |
711 | (tcl-indent-line)) | |
712 | ((not comment-p) | |
9875e646 | 713 | (tcl-indent-line) |
c2ca5171 | 714 | (comment-indent)) |
9875e646 TT |
715 | (t |
716 | ;; Go to start of comment. We don't leave point where it is | |
717 | ;; because we want to skip comment-start-skip. | |
718 | (tcl-indent-line) | |
05794f14 | 719 | (indent-for-comment)))))) |
9875e646 TT |
720 | |
721 | (defun tcl-indent-line () | |
722 | "Indent current line as Tcl code. | |
723 | Return the amount the indentation changed by." | |
c2ca5171 | 724 | (let ((indent (tcl-calculate-indent nil)) |
9875e646 TT |
725 | beg shift-amt |
726 | (case-fold-search nil) | |
727 | (pos (- (point-max) (point)))) | |
05794f14 SM |
728 | (if (null indent) |
729 | 'noindent | |
730 | (beginning-of-line) | |
731 | (setq beg (point)) | |
732 | (skip-chars-forward " \t") | |
733 | (if (listp indent) (setq indent (car indent))) | |
734 | (cond ((= (following-char) ?}) | |
735 | (setq indent (- indent tcl-indent-level))) | |
736 | ((= (following-char) ?\]) | |
737 | (setq indent (- indent 1)))) | |
738 | (skip-chars-forward " \t") | |
739 | (setq shift-amt (- indent (current-column))) | |
740 | (if (zerop shift-amt) | |
741 | (if (> (- (point-max) pos) (point)) | |
742 | (goto-char (- (point-max) pos))) | |
743 | (delete-region beg (point)) | |
744 | (indent-to indent) | |
745 | ;; If initial point was within line's indentation, | |
746 | ;; position after the indentation. Else stay at same point in text. | |
747 | (if (> (- (point-max) pos) (point)) | |
748 | (goto-char (- (point-max) pos)))) | |
749 | shift-amt))) | |
9875e646 TT |
750 | |
751 | (defun tcl-figure-type () | |
752 | "Determine type of sexp at point. | |
2f585cfe | 753 | This is either `tcl-expr', `tcl-commands', or nil. Puts point at start |
9875e646 TT |
754 | of sexp that indicates types. |
755 | ||
756 | See documentation for variable `tcl-type-alist' for more information." | |
757 | (let ((count 0) | |
758 | result | |
759 | word-stack) | |
760 | (while (and (< count 5) | |
761 | (not result)) | |
762 | (condition-case nil | |
763 | (progn | |
764 | ;; FIXME should use "tcl-backward-sexp", which would skip | |
765 | ;; over entire variables, etc. | |
766 | (backward-sexp) | |
767 | (if (looking-at "[a-zA-Z_]+") | |
768 | (let ((list tcl-type-alist) | |
769 | entry) | |
6654e1b1 | 770 | (setq word-stack (cons (tcl-word-no-props) word-stack)) |
9875e646 TT |
771 | (while (and list (not result)) |
772 | (setq entry (car list)) | |
773 | (setq list (cdr list)) | |
774 | (let ((index 0)) | |
775 | (while (and entry (<= index count)) | |
776 | ;; Abort loop if string does not match word on | |
777 | ;; stack. | |
778 | (and (stringp (car entry)) | |
779 | (not (string= (car entry) | |
780 | (nth index word-stack))) | |
781 | (setq entry nil)) | |
782 | (setq entry (cdr entry)) | |
783 | (setq index (1+ index))) | |
784 | (and (> index count) | |
785 | (not (stringp (car entry))) | |
786 | (setq result (car entry))) | |
787 | ))) | |
788 | (setq word-stack (cons nil word-stack)))) | |
789 | (error nil)) | |
790 | (setq count (1+ count))) | |
791 | (and tcl-explain-indentation | |
792 | (message "Indentation type %s" result)) | |
793 | result)) | |
794 | ||
c2ca5171 | 795 | (defun tcl-calculate-indent (&optional parse-start) |
9875e646 TT |
796 | "Return appropriate indentation for current line as Tcl code. |
797 | In usual case returns an integer: the column to indent to. | |
798 | Returns nil if line starts inside a string, t if in a comment." | |
799 | (save-excursion | |
800 | (beginning-of-line) | |
801 | (let* ((indent-point (point)) | |
802 | (case-fold-search nil) | |
a1506d29 | 803 | (continued-line |
9875e646 TT |
804 | (save-excursion |
805 | (if (bobp) | |
806 | nil | |
807 | (backward-char) | |
808 | (= ?\\ (preceding-char))))) | |
809 | (continued-indent-value (if continued-line | |
810 | tcl-continued-indent-level | |
811 | 0)) | |
812 | state | |
813 | containing-sexp | |
814 | found-next-line) | |
815 | (if parse-start | |
816 | (goto-char parse-start) | |
c2ca5171 | 817 | (beginning-of-defun)) |
9875e646 TT |
818 | (while (< (point) indent-point) |
819 | (setq parse-start (point)) | |
820 | (setq state (parse-partial-sexp (point) indent-point 0)) | |
821 | (setq containing-sexp (car (cdr state)))) | |
822 | (cond ((or (nth 3 state) (nth 4 state)) | |
823 | ;; Inside comment or string. Return nil or t if should | |
824 | ;; not change this line | |
825 | (nth 4 state)) | |
826 | ((null containing-sexp) | |
827 | ;; Line is at top level. | |
828 | continued-indent-value) | |
829 | (t | |
830 | ;; Set expr-p if we are looking at the expression part of | |
831 | ;; an "if", "expr", etc statement. Set commands-p if we | |
832 | ;; are looking at the body part of an if, while, etc | |
833 | ;; statement. FIXME Should check for "for" loops here. | |
834 | (goto-char containing-sexp) | |
835 | (let* ((sexpr-type (tcl-figure-type)) | |
836 | (expr-p (eq sexpr-type 'tcl-expr)) | |
837 | (commands-p (eq sexpr-type 'tcl-commands)) | |
838 | (expr-start (point))) | |
839 | ;; Find the first statement in the block and indent | |
840 | ;; like it. The first statement in the block might be | |
841 | ;; on the same line, so what we do is skip all | |
842 | ;; "virtually blank" lines, looking for a non-blank | |
843 | ;; one. A line is virtually blank if it only contains | |
844 | ;; a comment and whitespace. FIXME continued comments | |
845 | ;; aren't supported. They are a wart on Tcl anyway. | |
846 | ;; We do it this funky way because we want to know if | |
847 | ;; we've found a statement on some line _after_ the | |
848 | ;; line holding the sexp opener. | |
849 | (goto-char containing-sexp) | |
850 | (forward-char) | |
851 | (if (and (< (point) indent-point) | |
852 | (looking-at "[ \t]*\\(#.*\\)?$")) | |
853 | (progn | |
854 | (forward-line) | |
855 | (while (and (< (point) indent-point) | |
856 | (looking-at "[ \t]*\\(#.*\\)?$")) | |
857 | (setq found-next-line t) | |
858 | (forward-line)))) | |
859 | (if (or continued-line | |
860 | (/= (char-after containing-sexp) ?{) | |
861 | expr-p) | |
862 | (progn | |
863 | ;; Line is continuation line, or the sexp opener | |
864 | ;; is not a curly brace, or we are are looking at | |
865 | ;; an `expr' expression (which must be split | |
866 | ;; specially). So indentation is column of first | |
867 | ;; good spot after sexp opener (with some added | |
868 | ;; in the continued-line case). If there is no | |
869 | ;; nonempty line before the indentation point, we | |
870 | ;; use the column of the character after the sexp | |
871 | ;; opener. | |
872 | (if (>= (point) indent-point) | |
873 | (progn | |
874 | (goto-char containing-sexp) | |
875 | (forward-char)) | |
876 | (skip-chars-forward " \t")) | |
877 | (+ (current-column) continued-indent-value)) | |
878 | ;; After a curly brace, and not a continuation line. | |
879 | ;; So take indentation from first good line after | |
880 | ;; start of block, unless that line is on the same | |
881 | ;; line as the opening brace. In this case use the | |
882 | ;; indentation of the opening brace's line, plus | |
883 | ;; another indent step. If we are in the body part | |
884 | ;; of an "if" or "while" then the indentation is | |
885 | ;; taken from the line holding the start of the | |
886 | ;; statement. | |
887 | (if (and (< (point) indent-point) | |
888 | found-next-line) | |
889 | (current-indentation) | |
890 | (if commands-p | |
891 | (goto-char expr-start) | |
892 | (goto-char containing-sexp)) | |
893 | (+ (current-indentation) tcl-indent-level))))))))) | |
894 | ||
895 | \f | |
896 | ||
c2ca5171 | 897 | (defun tcl-indent-exp () |
9875e646 TT |
898 | "Indent each line of the Tcl grouping following point." |
899 | (interactive) | |
900 | (let ((indent-stack (list nil)) | |
901 | (contain-stack (list (point))) | |
902 | (case-fold-search nil) | |
903 | outer-loop-done inner-loop-done state ostate | |
6612afc0 | 904 | this-indent continued-line |
9875e646 TT |
905 | (next-depth 0) |
906 | last-depth) | |
907 | (save-excursion | |
908 | (forward-sexp 1)) | |
909 | (save-excursion | |
910 | (setq outer-loop-done nil) | |
911 | (while (and (not (eobp)) (not outer-loop-done)) | |
912 | (setq last-depth next-depth) | |
913 | ;; Compute how depth changes over this line | |
914 | ;; plus enough other lines to get to one that | |
915 | ;; does not end inside a comment or string. | |
916 | ;; Meanwhile, do appropriate indentation on comment lines. | |
917 | (setq inner-loop-done nil) | |
918 | (while (and (not inner-loop-done) | |
919 | (not (and (eobp) (setq outer-loop-done t)))) | |
920 | (setq ostate state) | |
921 | (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) | |
922 | nil nil state)) | |
923 | (setq next-depth (car state)) | |
9875e646 TT |
924 | (if (or (nth 4 ostate)) |
925 | (tcl-indent-line)) | |
926 | (if (or (nth 3 state)) | |
927 | (forward-line 1) | |
928 | (setq inner-loop-done t))) | |
929 | (if (<= next-depth 0) | |
930 | (setq outer-loop-done t)) | |
931 | (if outer-loop-done | |
932 | nil | |
933 | ;; If this line had ..))) (((.. in it, pop out of the levels | |
934 | ;; that ended anywhere in this line, even if the final depth | |
935 | ;; doesn't indicate that they ended. | |
936 | (while (> last-depth (nth 6 state)) | |
937 | (setq indent-stack (cdr indent-stack) | |
938 | contain-stack (cdr contain-stack) | |
939 | last-depth (1- last-depth))) | |
9875e646 TT |
940 | ;; Add levels for any parens that were started in this line. |
941 | (while (< last-depth next-depth) | |
942 | (setq indent-stack (cons nil indent-stack) | |
943 | contain-stack (cons nil contain-stack) | |
944 | last-depth (1+ last-depth))) | |
945 | (if (null (car contain-stack)) | |
a1506d29 | 946 | (setcar contain-stack |
9875e646 TT |
947 | (or (car (cdr state)) |
948 | (save-excursion | |
949 | (forward-sexp -1) | |
950 | (point))))) | |
951 | (forward-line 1) | |
a1506d29 | 952 | (setq continued-line |
9875e646 TT |
953 | (save-excursion |
954 | (backward-char) | |
955 | (= (preceding-char) ?\\))) | |
956 | (skip-chars-forward " \t") | |
957 | (if (eolp) | |
958 | nil | |
959 | (if (and (car indent-stack) | |
960 | (>= (car indent-stack) 0)) | |
961 | ;; Line is on an existing nesting level. | |
962 | (setq this-indent (car indent-stack)) | |
963 | ;; Just started a new nesting level. | |
964 | ;; Compute the standard indent for this level. | |
c2ca5171 | 965 | (let ((val (tcl-calculate-indent |
9875e646 TT |
966 | (if (car indent-stack) |
967 | (- (car indent-stack)))))) | |
968 | (setcar indent-stack | |
969 | (setq this-indent val)) | |
970 | (setq continued-line nil))) | |
971 | (cond ((not (numberp this-indent))) | |
972 | ((= (following-char) ?}) | |
973 | (setq this-indent (- this-indent tcl-indent-level))) | |
974 | ((= (following-char) ?\]) | |
975 | (setq this-indent (- this-indent 1)))) | |
976 | ;; Put chosen indentation into effect. | |
977 | (or (null this-indent) | |
a1506d29 JB |
978 | (= (current-column) |
979 | (if continued-line | |
9875e646 TT |
980 | (+ this-indent tcl-indent-level) |
981 | this-indent)) | |
982 | (progn | |
983 | (delete-region (point) (progn (beginning-of-line) (point))) | |
a1506d29 JB |
984 | (indent-to |
985 | (if continued-line | |
9875e646 TT |
986 | (+ this-indent tcl-indent-level) |
987 | this-indent))))))))) | |
988 | ) | |
989 | ||
990 | \f | |
991 | ||
992 | ;; | |
993 | ;; Interfaces to other packages. | |
994 | ;; | |
995 | ||
9875e646 | 996 | ;; FIXME Definition of function is very ad-hoc. Should use |
c2ca5171 | 997 | ;; beginning-of-defun. Also has incestuous knowledge about the |
9875e646 | 998 | ;; format of tcl-proc-regexp. |
c2ca5171 | 999 | (defun tcl-add-log-defun () |
9875e646 TT |
1000 | "Return name of Tcl function point is in, or nil." |
1001 | (save-excursion | |
150269d5 TT |
1002 | (end-of-line) |
1003 | (if (re-search-backward (concat tcl-proc-regexp "\\([^ \t\n{]+\\)") nil t) | |
c2ca5171 | 1004 | (match-string 2)))) |
9875e646 | 1005 | |
50776640 TT |
1006 | (defun tcl-outline-level () |
1007 | (save-excursion | |
1008 | (skip-chars-forward " \t") | |
1009 | (current-column))) | |
1010 | ||
9875e646 TT |
1011 | \f |
1012 | ||
1013 | ;; | |
1014 | ;; Helper functions for inferior Tcl mode. | |
1015 | ;; | |
1016 | ||
1017 | ;; This exists to let us delete the prompt when commands are sent | |
1018 | ;; directly to the inferior Tcl. See gud.el for an explanation of how | |
1019 | ;; it all works (I took it from there). This stuff doesn't really | |
1020 | ;; work as well as I'd like it to. But I don't believe there is | |
1021 | ;; anything useful that can be done. | |
1022 | (defvar inferior-tcl-delete-prompt-marker nil) | |
1023 | ||
1024 | (defun tcl-filter (proc string) | |
723d286f | 1025 | (let ((inhibit-quit t)) ;FIXME: Isn't that redundant? |
c2ca5171 | 1026 | (with-current-buffer (process-buffer proc) |
9875e646 | 1027 | ;; Delete prompt if requested. |
723d286f SM |
1028 | (when (marker-buffer inferior-tcl-delete-prompt-marker) |
1029 | (delete-region (process-mark proc) inferior-tcl-delete-prompt-marker) | |
1030 | (set-marker inferior-tcl-delete-prompt-marker nil)))) | |
c2ca5171 | 1031 | (comint-output-filter proc string)) |
9875e646 TT |
1032 | |
1033 | (defun tcl-send-string (proc string) | |
c2ca5171 | 1034 | (with-current-buffer (process-buffer proc) |
9875e646 | 1035 | (goto-char (process-mark proc)) |
75669e02 | 1036 | (forward-line 0) ;Not (beginning-of-line) because of fields. |
9875e646 TT |
1037 | (if (looking-at comint-prompt-regexp) |
1038 | (set-marker inferior-tcl-delete-prompt-marker (point)))) | |
1039 | (comint-send-string proc string)) | |
1040 | ||
1041 | (defun tcl-send-region (proc start end) | |
c2ca5171 | 1042 | (with-current-buffer (process-buffer proc) |
9875e646 | 1043 | (goto-char (process-mark proc)) |
75669e02 | 1044 | (forward-line 0) ;Not (beginning-of-line) because of fields. |
9875e646 TT |
1045 | (if (looking-at comint-prompt-regexp) |
1046 | (set-marker inferior-tcl-delete-prompt-marker (point)))) | |
1047 | (comint-send-region proc start end)) | |
1048 | ||
1049 | (defun switch-to-tcl (eob-p) | |
1050 | "Switch to inferior Tcl process buffer. | |
1051 | With argument, positions cursor at end of buffer." | |
1052 | (interactive "P") | |
1053 | (if (get-buffer inferior-tcl-buffer) | |
1054 | (pop-to-buffer inferior-tcl-buffer) | |
1055 | (error "No current inferior Tcl buffer")) | |
1056 | (cond (eob-p | |
1057 | (push-mark) | |
1058 | (goto-char (point-max))))) | |
1059 | ||
1060 | (defun inferior-tcl-proc () | |
1061 | "Return current inferior Tcl process. | |
1062 | See variable `inferior-tcl-buffer'." | |
175069ef | 1063 | (let ((proc (get-buffer-process (if (derived-mode-p 'inferior-tcl-mode) |
9875e646 TT |
1064 | (current-buffer) |
1065 | inferior-tcl-buffer)))) | |
1066 | (or proc | |
1067 | (error "No Tcl process; see variable `inferior-tcl-buffer'")))) | |
1068 | ||
1069 | (defun tcl-eval-region (start end &optional and-go) | |
1070 | "Send the current region to the inferior Tcl process. | |
1071 | Prefix argument means switch to the Tcl buffer afterwards." | |
1072 | (interactive "r\nP") | |
1073 | (let ((proc (inferior-tcl-proc))) | |
75669e02 SM |
1074 | (tcl-send-region |
1075 | proc | |
1076 | ;; Strip leading and trailing whitespace. | |
1077 | (save-excursion (goto-char start) (skip-chars-forward " \t\n") (point)) | |
1078 | (save-excursion (goto-char end) (skip-chars-backward " \t\n") (point))) | |
9875e646 TT |
1079 | (tcl-send-string proc "\n") |
1080 | (if and-go (switch-to-tcl t)))) | |
1081 | ||
1082 | (defun tcl-eval-defun (&optional and-go) | |
1083 | "Send the current defun to the inferior Tcl process. | |
1084 | Prefix argument means switch to the Tcl buffer afterwards." | |
1085 | (interactive "P") | |
1086 | (save-excursion | |
c2ca5171 | 1087 | (end-of-defun) |
9875e646 | 1088 | (let ((end (point))) |
c2ca5171 | 1089 | (beginning-of-defun) |
9875e646 TT |
1090 | (tcl-eval-region (point) end))) |
1091 | (if and-go (switch-to-tcl t))) | |
1092 | ||
1093 | \f | |
1094 | ||
1095 | ;; | |
1096 | ;; Inferior Tcl mode itself. | |
1097 | ;; | |
1098 | ||
c2ca5171 | 1099 | (define-derived-mode inferior-tcl-mode comint-mode "Inferior Tcl" |
9875e646 TT |
1100 | "Major mode for interacting with Tcl interpreter. |
1101 | ||
031a5886 | 1102 | You can start a Tcl process with \\[inferior-tcl]. |
9875e646 | 1103 | |
2f585cfe RS |
1104 | Entry to this mode runs the normal hooks `comint-mode-hook' and |
1105 | `inferior-tcl-mode-hook', in that order. | |
9875e646 TT |
1106 | |
1107 | You can send text to the inferior Tcl process from other buffers | |
1108 | containing Tcl source. | |
1109 | ||
1110 | Variables controlling Inferior Tcl mode: | |
c2ca5171 | 1111 | `tcl-application' |
9875e646 | 1112 | Name of program to run. |
c2ca5171 | 1113 | `tcl-command-switches' |
9875e646 | 1114 | Command line arguments to `tcl-application'. |
c2ca5171 | 1115 | `tcl-prompt-regexp' |
9875e646 | 1116 | Matches prompt. |
c2ca5171 | 1117 | `inferior-tcl-source-command' |
9875e646 | 1118 | Command to use to read Tcl file in running application. |
c2ca5171 | 1119 | `inferior-tcl-buffer' |
9875e646 TT |
1120 | The current inferior Tcl process buffer. See variable |
1121 | documentation for details on multiple-process support. | |
1122 | ||
1123 | The following commands are available: | |
1124 | \\{inferior-tcl-mode-map}" | |
c2ca5171 SM |
1125 | (set (make-local-variable 'comint-prompt-regexp) |
1126 | (or tcl-prompt-regexp | |
1127 | (concat "^" (regexp-quote tcl-application) ">"))) | |
1128 | (setq mode-line-process '(": %s")) | |
9875e646 TT |
1129 | (setq local-abbrev-table tcl-mode-abbrev-table) |
1130 | (set-syntax-table tcl-mode-syntax-table) | |
c2ca5171 SM |
1131 | (set (make-local-variable 'defun-prompt-regexp) tcl-omit-ws-regexp) |
1132 | (set (make-local-variable 'inferior-tcl-delete-prompt-marker) (make-marker)) | |
1133 | (set-process-filter (get-buffer-process (current-buffer)) 'tcl-filter)) | |
9875e646 | 1134 | |
cd754bf5 | 1135 | ;;;###autoload |
9875e646 TT |
1136 | (defun inferior-tcl (cmd) |
1137 | "Run inferior Tcl process. | |
1138 | Prefix arg means enter program name interactively. | |
1139 | See documentation for function `inferior-tcl-mode' for more information." | |
1140 | (interactive | |
1141 | (list (if current-prefix-arg | |
1142 | (read-string "Run Tcl: " tcl-application) | |
1143 | tcl-application))) | |
a2052295 JH |
1144 | (unless (comint-check-proc "*inferior-tcl*") |
1145 | (set-buffer (apply (function make-comint) "inferior-tcl" cmd nil | |
1146 | tcl-command-switches)) | |
75669e02 SM |
1147 | (inferior-tcl-mode) |
1148 | ;; Make tclsh display a prompt on ms-windows (or under Unix, when a tty | |
1149 | ;; wasn't used). Doesn't affect wish, unfortunately. | |
1150 | (unless (process-tty-name (inferior-tcl-proc)) | |
1151 | (tcl-send-string (inferior-tcl-proc) | |
1152 | "set ::tcl_interactive 1; concat\n"))) | |
a2052295 | 1153 | (set (make-local-variable 'tcl-application) cmd) |
9875e646 | 1154 | (setq inferior-tcl-buffer "*inferior-tcl*") |
a2052295 | 1155 | (pop-to-buffer "*inferior-tcl*")) |
9875e646 | 1156 | |
c2ca5171 | 1157 | (defalias 'run-tcl 'inferior-tcl) |
9875e646 TT |
1158 | |
1159 | \f | |
1160 | ||
1161 | ;; | |
1162 | ;; Auto-fill support. | |
1163 | ;; | |
1164 | ||
1165 | (defun tcl-real-command-p () | |
1166 | "Return nil if point is not at the beginning of a command. | |
1167 | A command is the first word on an otherwise empty line, or the | |
1168 | first word following a semicolon, opening brace, or opening bracket." | |
1169 | (save-excursion | |
1170 | (skip-chars-backward " \t") | |
1171 | (cond | |
1172 | ((bobp) t) | |
1173 | ((bolp) | |
1174 | (backward-char) | |
1175 | ;; Note -- continued comments are not supported here. I | |
1176 | ;; consider those to be a wart on the language. | |
1177 | (not (eq ?\\ (preceding-char)))) | |
1178 | (t | |
1179 | (memq (preceding-char) '(?\; ?{ ?\[)))))) | |
1180 | ||
1181 | ;; FIXME doesn't actually return t. See last case. | |
1182 | (defun tcl-real-comment-p () | |
1183 | "Return t if point is just after the `#' beginning a real comment. | |
1184 | Does not check to see if previous char is actually `#'. | |
1185 | A real comment is either at the beginning of the buffer, | |
9ad79cb4 | 1186 | preceded only by whitespace on the line, or has a preceding |
9875e646 TT |
1187 | semicolon, opening brace, or opening bracket on the same line." |
1188 | (save-excursion | |
1189 | (backward-char) | |
1190 | (tcl-real-command-p))) | |
1191 | ||
1192 | (defun tcl-hairy-scan-for-comment (state end always-stop) | |
1193 | "Determine if point is in a comment. | |
1194 | Returns a list of the form `(FLAG . STATE)'. STATE can be used | |
1195 | as input to future invocations. FLAG is nil if not in comment, | |
14121c52 | 1196 | t otherwise. If in comment, leaves point at beginning of comment." |
9875e646 TT |
1197 | (let ((bol (save-excursion |
1198 | (goto-char end) | |
9b026d9f | 1199 | (line-beginning-position))) |
9875e646 TT |
1200 | real-comment |
1201 | last-cstart) | |
1202 | (while (and (not last-cstart) (< (point) end)) | |
c2ca5171 | 1203 | (setq real-comment nil) ;In case we've looped around and it is set. |
9875e646 TT |
1204 | (setq state (parse-partial-sexp (point) end nil nil state t)) |
1205 | (if (nth 4 state) | |
1206 | (progn | |
1207 | ;; If ALWAYS-STOP is set, stop even if we don't have a | |
1208 | ;; real comment, or if the comment isn't on the same line | |
1209 | ;; as the end. | |
1210 | (if always-stop (setq last-cstart (point))) | |
1211 | ;; If we have a real comment, then set the comment | |
1212 | ;; starting point if we are on the same line as the ending | |
1213 | ;; location. | |
1214 | (setq real-comment (tcl-real-comment-p)) | |
1215 | (if real-comment | |
1216 | (progn | |
1217 | (and (> (point) bol) (setq last-cstart (point))) | |
1218 | ;; NOTE Emacs 19 has a misfeature whereby calling | |
1219 | ;; parse-partial-sexp with COMMENTSTOP set and with | |
1220 | ;; an initial list that says point is in a comment | |
1221 | ;; will cause an immediate return. So we must skip | |
1222 | ;; over the comment ourselves. | |
1223 | (beginning-of-line 2))) | |
1224 | ;; Frob the state to make it look like we aren't in a | |
1225 | ;; comment. | |
1226 | (setcar (nthcdr 4 state) nil)))) | |
1227 | (and last-cstart | |
1228 | (goto-char last-cstart)) | |
1229 | (cons real-comment state))) | |
1230 | ||
c2ca5171 | 1231 | (defun tcl-in-comment () |
2f585cfe | 1232 | "Return t if point is in a comment, and leave point at beginning of comment." |
9875e646 | 1233 | (let ((save (point))) |
c2ca5171 | 1234 | (beginning-of-defun) |
9875e646 | 1235 | (car (tcl-hairy-scan-for-comment nil save nil)))) |
6be8057e | 1236 | |
9875e646 TT |
1237 | \f |
1238 | ||
1239 | ;; | |
1240 | ;; Help-related code. | |
1241 | ;; | |
1242 | ||
95338744 TT |
1243 | (defvar tcl-help-saved-dirs nil |
1244 | "Saved help directories. | |
1245 | If `tcl-help-directory-list' changes, this allows `tcl-help-on-word' | |
1246 | to update the alist.") | |
9875e646 TT |
1247 | |
1248 | (defvar tcl-help-alist nil | |
1249 | "Alist with command names as keys and filenames as values.") | |
1250 | ||
c2ca5171 SM |
1251 | (defun tcl-files-alist (dir &optional alist) |
1252 | "Recursively add all pairs (FILE . PATH) under DIR to ALIST." | |
1253 | (dolist (file (directory-files dir t) alist) | |
1254 | (cond | |
1255 | ((not (file-directory-p file)) | |
1256 | (push (cons (file-name-nondirectory file) file) alist)) | |
1257 | ((member (file-name-nondirectory file) '("." ".."))) | |
1258 | (t (setq alist (tcl-files-alist file alist)))))) | |
1259 | ||
95338744 | 1260 | (defun tcl-help-snarf-commands (dirlist) |
c2ca5171 SM |
1261 | "Return alist of commands and filenames." |
1262 | (let ((alist nil)) | |
1263 | (dolist (dir dirlist alist) | |
1264 | (when (file-directory-p dir) | |
1265 | (setq alist (tcl-files-alist dir alist)))))) | |
9875e646 TT |
1266 | |
1267 | (defun tcl-reread-help-files () | |
1268 | "Set up to re-read files, and then do it." | |
1269 | (interactive) | |
1270 | (message "Building Tcl help file index...") | |
95338744 | 1271 | (setq tcl-help-saved-dirs tcl-help-directory-list) |
c2ca5171 | 1272 | (setq tcl-help-alist (tcl-help-snarf-commands tcl-help-directory-list)) |
9875e646 TT |
1273 | (message "Building Tcl help file index...done")) |
1274 | ||
6654e1b1 | 1275 | (defun tcl-word-no-props () |
c2ca5171 | 1276 | "Like `current-word', but strips properties." |
6654e1b1 | 1277 | (let ((word (current-word))) |
c2ca5171 | 1278 | (set-text-properties 0 (length word) nil word) |
6654e1b1 TT |
1279 | word)) |
1280 | ||
9875e646 TT |
1281 | (defun tcl-current-word (flag) |
1282 | "Return current command word, or nil. | |
1283 | If FLAG is nil, just uses `current-word'. | |
1284 | Otherwise scans backward for most likely Tcl command word." | |
f5608c76 | 1285 | (if (and flag |
175069ef | 1286 | (derived-mode-p 'tcl-mode 'inferior-tcl-mode)) |
9875e646 TT |
1287 | (condition-case nil |
1288 | (save-excursion | |
1289 | ;; Look backward for first word actually in alist. | |
1290 | (if (bobp) | |
1291 | () | |
1292 | (while (and (not (bobp)) | |
1293 | (not (tcl-real-command-p))) | |
1294 | (backward-sexp))) | |
6654e1b1 TT |
1295 | (if (assoc (tcl-word-no-props) tcl-help-alist) |
1296 | (tcl-word-no-props))) | |
9875e646 | 1297 | (error nil)) |
6654e1b1 | 1298 | (tcl-word-no-props))) |
9875e646 | 1299 | |
cd754bf5 | 1300 | ;;;###autoload |
9875e646 TT |
1301 | (defun tcl-help-on-word (command &optional arg) |
1302 | "Get help on Tcl command. Default is word at point. | |
1303 | Prefix argument means invert sense of `tcl-use-smart-word-finder'." | |
1304 | (interactive | |
1305 | (list | |
1306 | (progn | |
95338744 | 1307 | (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) |
9875e646 TT |
1308 | (tcl-reread-help-files)) |
1309 | (let ((word (tcl-current-word | |
1310 | (if current-prefix-arg | |
1311 | (not tcl-use-smart-word-finder) | |
1312 | tcl-use-smart-word-finder)))) | |
1313 | (completing-read | |
1314 | (if (or (null word) (string= word "")) | |
1315 | "Help on Tcl command: " | |
1316 | (format "Help on Tcl command (default %s): " word)) | |
c2ca5171 | 1317 | tcl-help-alist nil t nil nil word))) |
9875e646 | 1318 | current-prefix-arg)) |
95338744 | 1319 | (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) |
9875e646 TT |
1320 | (tcl-reread-help-files)) |
1321 | (if (string= command "") | |
1322 | (setq command (tcl-current-word | |
1323 | (if arg | |
1324 | (not tcl-use-smart-word-finder) | |
1325 | tcl-use-smart-word-finder)))) | |
1326 | (let* ((help (get-buffer-create "*Tcl help*")) | |
1327 | (cell (assoc command tcl-help-alist)) | |
1328 | (file (and cell (cdr cell)))) | |
1329 | (set-buffer help) | |
1330 | (delete-region (point-min) (point-max)) | |
1331 | (if file | |
1332 | (progn | |
1333 | (insert "*** " command "\n\n") | |
1334 | (insert-file-contents file)) | |
1335 | (if (string= command "") | |
1336 | (insert "Magical Pig!") | |
1337 | (insert "Tcl command " command " not in help\n"))) | |
1338 | (set-buffer-modified-p nil) | |
1339 | (goto-char (point-min)) | |
1340 | (display-buffer help))) | |
1341 | ||
1342 | \f | |
1343 | ||
1344 | ;; | |
1345 | ;; Other interactive stuff. | |
1346 | ;; | |
1347 | ||
1348 | (defvar tcl-previous-dir/file nil | |
1349 | "Record last directory and file used in loading. | |
1350 | This holds a cons cell of the form `(DIRECTORY . FILE)' | |
1351 | describing the last `tcl-load-file' command.") | |
1352 | ||
1353 | (defun tcl-load-file (file &optional and-go) | |
1354 | "Load a Tcl file into the inferior Tcl process. | |
1355 | Prefix argument means switch to the Tcl buffer afterwards." | |
1356 | (interactive | |
1357 | (list | |
1358 | ;; car because comint-get-source returns a list holding the | |
1359 | ;; filename. | |
700a20bf TT |
1360 | (car (comint-get-source "Load Tcl file: " |
1361 | (or (and | |
175069ef | 1362 | (derived-mode-p 'tcl-mode) |
700a20bf TT |
1363 | (buffer-file-name)) |
1364 | tcl-previous-dir/file) | |
9875e646 TT |
1365 | '(tcl-mode) t)) |
1366 | current-prefix-arg)) | |
1367 | (comint-check-source file) | |
1368 | (setq tcl-previous-dir/file (cons (file-name-directory file) | |
1369 | (file-name-nondirectory file))) | |
1370 | (tcl-send-string (inferior-tcl-proc) | |
1371 | (format inferior-tcl-source-command (tcl-quote file))) | |
1372 | (if and-go (switch-to-tcl t))) | |
1373 | ||
9875e646 TT |
1374 | (defun tcl-restart-with-file (file &optional and-go) |
1375 | "Restart inferior Tcl with file. | |
1376 | If an inferior Tcl process exists, it is killed first. | |
1377 | Prefix argument means switch to the Tcl buffer afterwards." | |
1378 | (interactive | |
1379 | (list | |
1380 | (car (comint-get-source "Restart with Tcl file: " | |
1381 | (or (and | |
175069ef | 1382 | (derived-mode-p 'tcl-mode) |
9875e646 TT |
1383 | (buffer-file-name)) |
1384 | tcl-previous-dir/file) | |
1385 | '(tcl-mode) t)) | |
1386 | current-prefix-arg)) | |
175069ef | 1387 | (let* ((buf (if (derived-mode-p 'inferior-tcl-mode) |
9875e646 TT |
1388 | (current-buffer) |
1389 | inferior-tcl-buffer)) | |
1390 | (proc (and buf (get-process buf)))) | |
1391 | (cond | |
1392 | ((not (and buf (get-buffer buf))) | |
1393 | ;; I think this will be ok. | |
1394 | (inferior-tcl tcl-application) | |
1395 | (tcl-load-file file and-go)) | |
1396 | ((or | |
1397 | (not (comint-check-proc buf)) | |
1398 | (yes-or-no-p | |
1399 | "A Tcl process is running, are you sure you want to reset it? ")) | |
1400 | (save-excursion | |
1401 | (comint-check-source file) | |
1402 | (setq tcl-previous-dir/file (cons (file-name-directory file) | |
1403 | (file-name-nondirectory file))) | |
1404 | (comint-exec (get-buffer-create buf) | |
1405 | (if proc | |
1406 | (process-name proc) | |
1407 | "inferior-tcl") | |
1408 | tcl-application file tcl-command-switches) | |
1409 | (if and-go (switch-to-tcl t))))))) | |
1410 | ||
9875e646 | 1411 | (defun tcl-auto-fill-mode (&optional arg) |
2c7cdd69 | 1412 | "Like `auto-fill-mode', but sets `comment-auto-fill-only-comments'." |
9875e646 | 1413 | (interactive "P") |
2c7cdd69 SM |
1414 | (auto-fill-mode arg) |
1415 | (if auto-fill-function | |
1416 | (set (make-local-variable 'comment-auto-fill-only-comments) t) | |
1417 | (kill-local-variable 'comment-auto-fill-only-comments))) | |
9875e646 TT |
1418 | |
1419 | (defun tcl-electric-hash (&optional count) | |
1420 | "Insert a `#' and quote if it does not start a real comment. | |
1421 | Prefix arg is number of `#'s to insert. | |
1422 | See variable `tcl-electric-hash-style' for description of quoting | |
1423 | styles." | |
1424 | (interactive "p") | |
1425 | (or count (setq count 1)) | |
1426 | (if (> count 0) | |
1427 | (let ((type | |
1428 | (if (eq tcl-electric-hash-style 'smart) | |
1429 | (if (> count 3) ; FIXME what is "smart"? | |
1430 | 'quote | |
1431 | 'backslash) | |
1432 | tcl-electric-hash-style)) | |
1433 | comment) | |
1434 | (if type | |
1435 | (progn | |
1436 | (save-excursion | |
1437 | (insert "#") | |
1438 | (setq comment (tcl-in-comment))) | |
1439 | (delete-char 1) | |
1440 | (and tcl-explain-indentation (message "comment: %s" comment)) | |
1441 | (cond | |
1442 | ((eq type 'quote) | |
1443 | (if (not comment) | |
1444 | (insert "\""))) | |
1445 | ((eq type 'backslash) | |
1446 | ;; The following will set count to 0, so the | |
1447 | ;; insert-char can still be run. | |
1448 | (if (not comment) | |
1449 | (while (> count 0) | |
1450 | (insert "\\#") | |
1451 | (setq count (1- count))))) | |
1452 | (t nil)))) | |
1453 | (insert-char ?# count)))) | |
1454 | ||
1455 | (defun tcl-hashify-buffer () | |
1456 | "Quote all `#'s in current buffer that aren't Tcl comments." | |
1457 | (interactive) | |
1458 | (save-excursion | |
1459 | (goto-char (point-min)) | |
c2ca5171 SM |
1460 | (let (state |
1461 | result) | |
1462 | (while (< (point) (point-max)) | |
1463 | (setq result (tcl-hairy-scan-for-comment state (point-max) t)) | |
1464 | (if (car result) | |
9875e646 | 1465 | (beginning-of-line 2) |
9875e646 | 1466 | (backward-char) |
c2ca5171 | 1467 | (if (eq ?# (following-char)) |
9875e646 | 1468 | (insert "\\")) |
c2ca5171 SM |
1469 | (forward-char)) |
1470 | (setq state (cdr result)))))) | |
1471 | ||
1472 | (defun tcl-comment-indent () | |
1473 | "Return the desired indentation, but be careful to add a `;' if needed." | |
1474 | (save-excursion | |
1475 | ;; If line is not blank, make sure we insert a ";" first. | |
1476 | (skip-chars-backward " \t") | |
1477 | (unless (or (bolp) (tcl-real-command-p)) | |
1478 | (insert ";") | |
1479 | ;; Try and erase a non-significant char to keep charpos identical. | |
5089af27 | 1480 | (if (memq (char-after) '(?\t ?\s)) (delete-char 1)))) |
c2ca5171 | 1481 | (funcall (default-value 'comment-indent-function))) |
95338744 | 1482 | |
9875e646 TT |
1483 | ;; The following was inspired by the Tcl editing mode written by |
1484 | ;; Gregor Schmid <schmid@fb3-s7.math.TU-Berlin.DE>. His version also | |
1485 | ;; attempts to snarf the command line options from the command line, | |
1486 | ;; but I didn't think that would really be that helpful (doesn't seem | |
c2ca5171 | 1487 | ;; like it would be right enough. His version also looks for the |
9875e646 | 1488 | ;; "#!/bin/csh ... exec" hack, but that seemed even less useful. |
95338744 TT |
1489 | ;; FIXME should make sure that the application mentioned actually |
1490 | ;; exists. | |
9875e646 TT |
1491 | (defun tcl-guess-application () |
1492 | "Attempt to guess Tcl application by looking at first line. | |
1493 | The first line is assumed to look like \"#!.../program ...\"." | |
1494 | (save-excursion | |
1495 | (goto-char (point-min)) | |
3530a317 | 1496 | (if (looking-at "#![^ \t]*/\\([^ \t\n/]+\\)\\([ \t]\\|$\\)") |
c2ca5171 | 1497 | (set (make-local-variable 'tcl-application) (match-string 1))))) |
9875e646 TT |
1498 | |
1499 | \f | |
1500 | ||
1501 | ;; | |
e9e7f5f2 | 1502 | ;; XEmacs menu support. |
9875e646 TT |
1503 | ;; Taken from schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid), |
1504 | ;; who wrote a different Tcl mode. | |
2f585cfe | 1505 | ;; We also have support for menus in Emacs. We do this by |
e9e7f5f2 | 1506 | ;; loading the XEmacs menu emulation code. |
9875e646 TT |
1507 | ;; |
1508 | ||
9875e646 | 1509 | (defun tcl-popup-menu (e) |
9aa88f3e | 1510 | (interactive "@e") |
c2ca5171 | 1511 | (popup-menu tcl-mode-menu)) |
9875e646 TT |
1512 | |
1513 | \f | |
1514 | ||
1515 | ;; | |
1516 | ;; Quoting and unquoting functions. | |
1517 | ;; | |
1518 | ||
1519 | ;; This quoting is sufficient to protect eg a filename from any sort | |
1520 | ;; of expansion or splitting. Tcl quoting sure sucks. | |
1521 | (defun tcl-quote (string) | |
1522 | "Quote STRING according to Tcl rules." | |
c2ca5171 | 1523 | (mapconcat (lambda (char) |
5089af27 | 1524 | (if (memq char '(?[ ?] ?{ ?} ?\\ ?\" ?$ ?\s ?\;)) |
c2ca5171 SM |
1525 | (concat "\\" (char-to-string char)) |
1526 | (char-to-string char))) | |
9875e646 TT |
1527 | string "")) |
1528 | ||
6be8057e TT |
1529 | ;; |
1530 | ;; Bug reporting. | |
1531 | ;; | |
6be8057e TT |
1532 | \f |
1533 | ||
c2ca5171 SM |
1534 | ;; These are relics kept "just in case". |
1535 | (defalias 'tcl-uncomment-region 'uncomment-region) | |
1536 | (defalias 'tcl-indent-for-comment 'comment-indent) | |
1537 | (defalias 'add-log-tcl-defun 'tcl-add-log-defun) | |
1538 | (defalias 'indent-tcl-exp 'tcl-indent-exp) | |
1539 | (defalias 'calculate-tcl-indent 'tcl-calculate-indent) | |
1540 | (defalias 'tcl-beginning-of-defun 'beginning-of-defun) | |
1541 | (defalias 'tcl-end-of-defun 'end-of-defun) | |
1542 | (defalias 'tcl-mark-defun 'mark-defun) | |
1543 | (defun tcl-mark () (mark t)) | |
1544 | ||
9875e646 TT |
1545 | (provide 'tcl) |
1546 | ||
1547 | ;;; tcl.el ends here |