Commit | Line | Data |
---|---|---|
e8af40ee | 1 | ;;; tcl.el --- Tcl code editing commands for Emacs |
9875e646 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1994, 1998-2014 Free Software Foundation, Inc. |
9875e646 | 4 | |
34dc21db | 5 | ;; Maintainer: emacs-devel@gnu.org |
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 'dabbrev) |
108 | (require 'add-log)) | |
109 | ||
9875e646 TT |
110 | (require 'comint) |
111 | ||
112 | ;; | |
113 | ;; User variables. | |
114 | ;; | |
115 | ||
94662de7 | 116 | (defgroup tcl nil |
5089af27 | 117 | "Major mode for editing Tcl source in Emacs." |
8ec3bce0 | 118 | :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) |
94662de7 | 119 | :group 'languages) |
9875e646 | 120 | |
94662de7 | 121 | (defcustom tcl-indent-level 4 |
fb7ada5f | 122 | "Indentation of Tcl statements with respect to containing block." |
f5307782 JB |
123 | :type 'integer |
124 | :group 'tcl) | |
b14d552b | 125 | (put 'tcl-indent-level 'safe-local-variable 'integerp) |
9875e646 | 126 | |
94662de7 | 127 | (defcustom tcl-continued-indent-level 4 |
fb7ada5f | 128 | "Indentation of continuation line relative to first line of command." |
f5307782 JB |
129 | :type 'integer |
130 | :group 'tcl) | |
b14d552b | 131 | (put 'tcl-continued-indent-level 'safe-local-variable 'integerp) |
9875e646 | 132 | |
94662de7 | 133 | (defcustom tcl-auto-newline nil |
fb7ada5f | 134 | "Non-nil means automatically newline before and after braces you insert." |
f5307782 JB |
135 | :type 'boolean |
136 | :group 'tcl) | |
94662de7 | 137 | |
6612afc0 | 138 | (defcustom tcl-tab-always-indent tab-always-indent |
fb7ada5f | 139 | "Control effect of TAB key. |
9875e646 TT |
140 | If t (the default), always indent current line. |
141 | If nil and point is not in the indentation area at the beginning of | |
142 | the line, a TAB is inserted. | |
143 | Other values cause the first possible action from the following list | |
144 | to take place: | |
145 | ||
146 | 1. Move from beginning of line to correct indentation. | |
147 | 2. Delete an empty comment. | |
148 | 3. Move forward to start of comment, indenting if necessary. | |
149 | 4. Move forward to end of line, indenting if necessary. | |
150 | 5. Create an empty comment. | |
94662de7 | 151 | 6. Move backward to start of comment, indenting if necessary." |
94662de7 RS |
152 | :type '(choice (const :tag "Always" t) |
153 | (const :tag "Beginning only" nil) | |
9c61f806 | 154 | (other :tag "Maybe move or make or delete comment" tcl)) |
f5307782 | 155 | :group 'tcl) |
94662de7 | 156 | |
9875e646 | 157 | |
2c7cdd69 | 158 | (defcustom tcl-electric-hash-style nil ;; 'smart |
fb7ada5f | 159 | "Style of electric hash insertion to use. |
2f585cfe RS |
160 | Possible values are `backslash', meaning that `\\' quoting should be |
161 | done; `quote', meaning that `\"' quoting should be done; `smart', | |
162 | meaning that the choice between `backslash' and `quote' should be | |
9875e646 TT |
163 | made depending on the number of hashes inserted; or nil, meaning that |
164 | no quoting should be done. Any other value for this variable is | |
2c7cdd69 | 165 | taken to mean `smart'. The default is nil." |
f5307782 JB |
166 | :type '(choice (const backslash) (const quote) (const smart) (const nil)) |
167 | :group 'tcl) | |
94662de7 RS |
168 | |
169 | (defcustom tcl-help-directory-list nil | |
fb7ada5f | 170 | "List of topmost directories containing TclX help files." |
f5307782 JB |
171 | :type '(repeat directory) |
172 | :group 'tcl) | |
94662de7 RS |
173 | |
174 | (defcustom tcl-use-smart-word-finder t | |
fb7ada5f | 175 | "If not nil, use smart way to find current word, for Tcl help feature." |
f5307782 JB |
176 | :type 'boolean |
177 | :group 'tcl) | |
94662de7 RS |
178 | |
179 | (defcustom tcl-application "wish" | |
fb7ada5f | 180 | "Name of Tcl program to run in inferior Tcl mode." |
f5307782 JB |
181 | :type 'string |
182 | :group 'tcl) | |
94662de7 RS |
183 | |
184 | (defcustom tcl-command-switches nil | |
fb7ada5f | 185 | "List of switches to supply to the `tcl-application' program." |
f5307782 JB |
186 | :type '(repeat string) |
187 | :group 'tcl) | |
94662de7 RS |
188 | |
189 | (defcustom tcl-prompt-regexp "^\\(% \\|\\)" | |
fb7ada5f | 190 | "If not nil, a regexp that will match the prompt in the inferior process. |
9875e646 TT |
191 | If nil, the prompt is the name of the application with \">\" appended. |
192 | ||
193 | The default is \"^\\(% \\|\\)\", which will match the default primary | |
94662de7 | 194 | and secondary prompts for tclsh and wish." |
f5307782 JB |
195 | :type 'regexp |
196 | :group 'tcl) | |
9875e646 | 197 | |
94662de7 | 198 | (defcustom inferior-tcl-source-command "source %s\n" |
fb7ada5f | 199 | "Format-string for building a Tcl command to load a file. |
9875e646 TT |
200 | This format string should use `%s' to substitute a file name |
201 | and should result in a Tcl expression that will command the | |
202 | inferior Tcl to load that file. The filename will be appropriately | |
94662de7 | 203 | quoted for Tcl." |
f5307782 JB |
204 | :type 'string |
205 | :group 'tcl) | |
9875e646 | 206 | |
d6d43bde GM |
207 | (defface tcl-escaped-newline '((t :inherit font-lock-string-face)) |
208 | "Face used for (non-escaped) backslash at end of a line in Tcl mode." | |
209 | :group 'tcl | |
210 | :version "22.1") | |
211 | ||
9875e646 TT |
212 | ;; |
213 | ;; Keymaps, abbrevs, syntax tables. | |
214 | ;; | |
215 | ||
c2ca5171 SM |
216 | (defvar tcl-mode-map |
217 | (let ((map (make-sparse-keymap))) | |
218 | (define-key map "{" 'tcl-electric-char) | |
219 | (define-key map "}" 'tcl-electric-brace) | |
220 | (define-key map "[" 'tcl-electric-char) | |
221 | (define-key map "]" 'tcl-electric-char) | |
222 | (define-key map ";" 'tcl-electric-char) | |
223 | (define-key map "#" 'tcl-electric-hash) ;Remove? -stef | |
224 | (define-key map "\e\C-q" 'tcl-indent-exp) | |
225 | (define-key map "\177" 'backward-delete-char-untabify) | |
226 | (define-key map "\t" 'tcl-indent-command) | |
227 | (define-key map "\M-\C-x" 'tcl-eval-defun) | |
228 | (define-key map "\C-c\C-i" 'tcl-help-on-word) | |
229 | (define-key map "\C-c\C-v" 'tcl-eval-defun) | |
230 | (define-key map "\C-c\C-f" 'tcl-load-file) | |
231 | (define-key map "\C-c\C-t" 'inferior-tcl) | |
232 | (define-key map "\C-c\C-x" 'tcl-eval-region) | |
233 | (define-key map "\C-c\C-s" 'switch-to-tcl) | |
234 | map) | |
235 | "Keymap used in `tcl-mode'.") | |
236 | ||
237 | (defvar tcl-mode-syntax-table | |
238 | (let ((st (make-syntax-table))) | |
239 | (modify-syntax-entry ?% "_" st) | |
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) ; FIXME use "'"? | |
249 | (modify-syntax-entry ?/ "_" st) | |
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 ?\n ">" st) | |
259 | ;; (modify-syntax-entry ?\f ">" st) | |
260 | (modify-syntax-entry ?# "<" st) | |
261 | st) | |
262 | "Syntax table in use in `tcl-mode' buffers.") | |
263 | ||
264 | (defvar inferior-tcl-mode-map | |
265 | ;; FIXME we override comint keybindings here. | |
266 | ;; Maybe someone has a better set? | |
267 | (let ((map (make-sparse-keymap))) | |
268 | ;; Will inherit from `comint-mode-map' thanks to define-derived-mode. | |
ee9f1acc | 269 | (define-key map "\t" 'completion-at-point) |
c2ca5171 SM |
270 | (define-key map "\M-?" 'comint-dynamic-list-filename-completions) |
271 | (define-key map "\177" 'backward-delete-char-untabify) | |
272 | (define-key map "\M-\C-x" 'tcl-eval-defun) | |
273 | (define-key map "\C-c\C-i" 'tcl-help-on-word) | |
274 | (define-key map "\C-c\C-v" 'tcl-eval-defun) | |
275 | (define-key map "\C-c\C-f" 'tcl-load-file) | |
276 | (define-key map "\C-c\C-t" 'inferior-tcl) | |
277 | (define-key map "\C-c\C-x" 'tcl-eval-region) | |
278 | (define-key map "\C-c\C-s" 'switch-to-tcl) | |
279 | map) | |
280 | "Keymap used in `inferior-tcl-mode'.") | |
281 | ||
282 | (easy-menu-define tcl-mode-menu tcl-mode-map "Menu used in `tcl-mode'." | |
283 | '("Tcl" | |
284 | ["Beginning of function" beginning-of-defun t] | |
285 | ["End of function" end-of-defun t] | |
286 | ["Mark function" mark-defun t] | |
287 | ["Indent region" indent-region (mark t)] | |
288 | ["Comment region" comment-region (mark t)] | |
289 | ["Uncomment region" uncomment-region (mark t)] | |
9875e646 TT |
290 | "----" |
291 | ["Show Tcl process buffer" inferior-tcl t] | |
dc509e64 | 292 | ["Send function to Tcl process" tcl-eval-defun |
efd7d762 | 293 | (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] |
dc509e64 | 294 | ["Send region to Tcl process" tcl-eval-region |
efd7d762 | 295 | (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] |
dc509e64 | 296 | ["Send file to Tcl process" tcl-load-file |
efd7d762 | 297 | (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))] |
9875e646 TT |
298 | ["Restart Tcl process with file" tcl-restart-with-file t] |
299 | "----" | |
c2ca5171 | 300 | ["Tcl help" tcl-help-on-word tcl-help-directory-list])) |
9875e646 TT |
301 | |
302 | (defvar inferior-tcl-buffer nil | |
fb7ada5f | 303 | "The current inferior-tcl process buffer. |
9875e646 TT |
304 | |
305 | MULTIPLE PROCESS SUPPORT | |
306 | =========================================================================== | |
307 | To run multiple Tcl processes, you start the first up with | |
308 | \\[inferior-tcl]. It will be in a buffer named `*inferior-tcl*'. | |
309 | Rename this buffer with \\[rename-buffer]. You may now start up a new | |
310 | process with another \\[inferior-tcl]. It will be in a new buffer, | |
311 | named `*inferior-tcl*'. You can switch between the different process | |
312 | buffers with \\[switch-to-buffer]. | |
313 | ||
314 | Commands that send text from source buffers to Tcl processes -- like | |
315 | `tcl-eval-defun' or `tcl-load-file' -- have to choose a process to | |
316 | send to, when you have more than one Tcl process around. This is | |
317 | determined by the global variable `inferior-tcl-buffer'. Suppose you | |
318 | have three inferior Lisps running: | |
319 | Buffer Process | |
320 | foo inferior-tcl | |
321 | bar inferior-tcl<2> | |
322 | *inferior-tcl* inferior-tcl<3> | |
323 | If you do a \\[tcl-eval-defun] command on some Lisp source code, what | |
324 | process do you send it to? | |
325 | ||
a1506d29 | 326 | - If you're in a process buffer (foo, bar, or *inferior-tcl*), |
9875e646 TT |
327 | you send it to that process. |
328 | - If you're in some other buffer (e.g., a source file), you | |
329 | send it to the process attached to buffer `inferior-tcl-buffer'. | |
330 | This process selection is performed by function `inferior-tcl-proc'. | |
331 | ||
332 | Whenever \\[inferior-tcl] fires up a new process, it resets | |
333 | `inferior-tcl-buffer' to be the new process's buffer. If you only run | |
334 | one process, this does the right thing. If you run multiple | |
f4146d98 GM |
335 | processes, you might need to set `inferior-tcl-buffer' to |
336 | whichever process buffer you want to use.") | |
9875e646 TT |
337 | |
338 | ;; | |
339 | ;; Hooks and other customization. | |
340 | ;; | |
341 | ||
342 | (defvar tcl-mode-hook nil | |
343 | "Hook run on entry to Tcl mode. | |
344 | ||
345 | Several functions exist which are useful to run from your | |
346 | `tcl-mode-hook' (see each function's documentation for more | |
347 | information): | |
348 | ||
c2ca5171 | 349 | `tcl-guess-application' |
9875e646 TT |
350 | Guesses a default setting for `tcl-application' based on any |
351 | \"#!\" line at the top of the file. | |
c2ca5171 | 352 | `tcl-hashify-buffer' |
9875e646 TT |
353 | Quotes all \"#\" characters that don't correspond to actual |
354 | Tcl comments. (Useful when editing code not originally created | |
355 | with this mode). | |
c2ca5171 | 356 | `tcl-auto-fill-mode' |
9875e646 TT |
357 | Auto-filling of Tcl comments. |
358 | ||
2f585cfe | 359 | Add functions to the hook with `add-hook': |
9875e646 | 360 | |
c2ca5171 | 361 | (add-hook 'tcl-mode-hook 'tcl-guess-application)") |
9875e646 | 362 | |
9875e646 TT |
363 | |
364 | (defvar tcl-proc-list | |
47448891 | 365 | '("proc" "method" "itcl_class" "body" "configbody" "class") |
9875e646 | 366 | "List of commands whose first argument defines something. |
2f585cfe | 367 | This exists because some people (eg, me) use `defvar' et al. |
9875e646 TT |
368 | Call `tcl-set-proc-regexp' and `tcl-set-font-lock-keywords' |
369 | after changing this list.") | |
370 | ||
371 | (defvar tcl-proc-regexp nil | |
372 | "Regexp to use when matching proc headers.") | |
373 | ||
374 | (defvar tcl-typeword-list | |
55c6d8fc | 375 | '("global" "upvar" "inherit" "public" "protected" "private" |
5bc0f801 | 376 | "common" "itk_option" "variable") |
9aa88f3e | 377 | "List of Tcl keywords denoting \"type\". Used only for highlighting. |
9875e646 TT |
378 | Call `tcl-set-font-lock-keywords' after changing this list.") |
379 | ||
380 | ;; Generally I've picked control operators to be keywords. | |
381 | (defvar tcl-keyword-list | |
382 | '("if" "then" "else" "elseif" "for" "foreach" "break" "continue" "while" | |
383 | "eval" "case" "in" "switch" "default" "exit" "error" "proc" "return" | |
a0defa81 | 384 | "uplevel" "constructor" "destructor" "itcl_class" "loop" "for_array_keys" |
c2ca5171 SM |
385 | "for_recursive_glob" "for_file" "method" "body" "configbody" "class" |
386 | "chain") | |
9875e646 TT |
387 | "List of Tcl keywords. Used only for highlighting. |
388 | Default list includes some TclX keywords. | |
389 | Call `tcl-set-font-lock-keywords' after changing this list.") | |
390 | ||
d6d43bde GM |
391 | (defvar tcl-builtin-list |
392 | '("after" "append" "array" "bgerror" "binary" "catch" "cd" "clock" | |
393 | "close" "concat" "console" "dde" "encoding" "eof" "exec" "expr" | |
394 | "fblocked" "fconfigure" "fcopy" "file" "fileevent" "flush" | |
395 | "format" "gets" "glob" "history" "incr" "info" "interp" "join" | |
396 | "lappend" "lindex" "linsert" "list" "llength" "load" "lrange" | |
397 | "lreplace" "lsort" "namespace" "open" "package" "pid" "puts" "pwd" | |
398 | "read" "regexp" "registry" "regsub" "rename" "scan" "seek" "set" | |
399 | "socket" "source" "split" "string" "subst" "tell" "time" "trace" | |
400 | "unknown" "unset" "vwait") | |
401 | "List of Tcl commands. Used only for highlighting. | |
402 | Call `tcl-set-font-lock-keywords' after changing this list. | |
403 | This list excludes those commands already found in `tcl-proc-list' and | |
404 | `tcl-keyword-list'.") | |
405 | ||
9875e646 TT |
406 | (defvar tcl-font-lock-keywords nil |
407 | "Keywords to highlight for Tcl. See variable `font-lock-keywords'. | |
408 | This variable is generally set from `tcl-proc-regexp', | |
409 | `tcl-typeword-list', and `tcl-keyword-list' by the function | |
410 | `tcl-set-font-lock-keywords'.") | |
411 | ||
cf38dd42 SM |
412 | (defconst tcl-syntax-propertize-function |
413 | (syntax-propertize-rules | |
414 | ;; Mark the few `#' that are not comment-markers. | |
415 | ("[^;[{ \t\n][ \t]*\\(#\\)" (1 "."))) | |
c2ca5171 SM |
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 | ||
cc1783c2 GM |
546 | (defvar outline-regexp) |
547 | (defvar outline-level) | |
548 | ||
cd754bf5 | 549 | ;;;###autoload |
ae0c2494 | 550 | (define-derived-mode tcl-mode prog-mode "Tcl" |
9875e646 TT |
551 | "Major mode for editing Tcl code. |
552 | Expression and list commands understand all Tcl brackets. | |
553 | Tab indents for Tcl code. | |
554 | Paragraphs are separated by blank lines only. | |
555 | Delete converts tabs to spaces as it moves back. | |
556 | ||
557 | Variables controlling indentation style: | |
c2ca5171 | 558 | `tcl-indent-level' |
9875e646 | 559 | Indentation of Tcl statements within surrounding block. |
c2ca5171 | 560 | `tcl-continued-indent-level' |
9875e646 TT |
561 | Indentation of continuation line relative to first line of command. |
562 | ||
563 | Variables controlling user interaction with mode (see variable | |
564 | documentation for details): | |
c2ca5171 | 565 | `tcl-tab-always-indent' |
9875e646 | 566 | Controls action of TAB key. |
c2ca5171 | 567 | `tcl-auto-newline' |
9875e646 TT |
568 | Non-nil means automatically newline before and after braces, brackets, |
569 | and semicolons inserted in Tcl code. | |
c2ca5171 | 570 | `tcl-use-smart-word-finder' |
a37875b4 TT |
571 | If not nil, use a smarter, Tcl-specific way to find the current |
572 | word when looking up help on a Tcl command. | |
9875e646 | 573 | |
a2c6faea | 574 | Turning on Tcl mode runs `tcl-mode-hook'. Read the documentation for |
9875e646 | 575 | `tcl-mode-hook' to see what kinds of interesting hook functions |
175069ef | 576 | already exist." |
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 | 594 | (set (make-local-variable 'font-lock-defaults) |
cf38dd42 SM |
595 | '(tcl-font-lock-keywords nil nil nil beginning-of-defun)) |
596 | (set (make-local-variable 'syntax-propertize-function) | |
597 | tcl-syntax-propertize-function) | |
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 | ||
c2ca5171 SM |
608 | (set (make-local-variable 'parse-sexp-ignore-comments) t) |
609 | ;; XEmacs has defun-prompt-regexp, but I don't believe | |
610 | ;; that it works for end-of-defun -- only for | |
611 | ;; beginning-of-defun. | |
612 | (set (make-local-variable 'defun-prompt-regexp) tcl-omit-ws-regexp) | |
c2ca5171 SM |
613 | (set (make-local-variable 'add-log-current-defun-function) |
614 | 'tcl-add-log-defun) | |
615 | ||
616 | (easy-menu-add tcl-mode-menu) | |
e9e7f5f2 | 617 | ;; Append Tcl menu to popup menu for XEmacs. |
c2ca5171 | 618 | (if (boundp 'mode-popup-menu) |
c803d3a7 | 619 | (setq mode-popup-menu |
c2ca5171 | 620 | (cons (concat mode-name " Mode Commands") tcl-mode-menu)))) |
9875e646 TT |
621 | |
622 | \f | |
623 | ||
624 | ;; This is used for braces, brackets, and semi (except for closing | |
625 | ;; braces, which are handled specially). | |
626 | (defun tcl-electric-char (arg) | |
627 | "Insert character and correct line's indentation." | |
628 | (interactive "p") | |
629 | ;; Indent line first; this looks better if parens blink. | |
630 | (tcl-indent-line) | |
631 | (self-insert-command arg) | |
1ba983e8 | 632 | (if (and tcl-auto-newline (= last-command-event ?\;)) |
9875e646 TT |
633 | (progn |
634 | (newline) | |
635 | (tcl-indent-line)))) | |
636 | ||
637 | ;; This is used for closing braces. If tcl-auto-newline is set, can | |
638 | ;; insert a newline both before and after the brace, depending on | |
639 | ;; context. FIXME should this be configurable? Does anyone use this? | |
640 | (defun tcl-electric-brace (arg) | |
641 | "Insert character and correct line's indentation." | |
642 | (interactive "p") | |
643 | ;; If auto-newlining and there is stuff on the same line, insert a | |
644 | ;; newline first. | |
645 | (if tcl-auto-newline | |
646 | (progn | |
647 | (if (save-excursion | |
648 | (skip-chars-backward " \t") | |
649 | (bolp)) | |
650 | () | |
651 | (tcl-indent-line) | |
652 | (newline)) | |
653 | ;; In auto-newline case, must insert a newline after each | |
654 | ;; brace. So an explicit loop is needed. | |
655 | (while (> arg 0) | |
1ba983e8 | 656 | (insert last-command-event) |
9875e646 TT |
657 | (tcl-indent-line) |
658 | (newline) | |
659 | (setq arg (1- arg)))) | |
660 | (self-insert-command arg)) | |
661 | (tcl-indent-line)) | |
662 | ||
663 | \f | |
664 | ||
e02f48d7 | 665 | (defun tcl-indent-command (&optional _arg) |
9875e646 | 666 | "Indent current line as Tcl code, or in some cases insert a tab character. |
2f585cfe RS |
667 | If `tcl-tab-always-indent' is t (the default), always indent current line. |
668 | If `tcl-tab-always-indent' is nil and point is not in the indentation | |
9875e646 | 669 | area at the beginning of the line, a TAB is inserted. |
2f585cfe | 670 | Other values of `tcl-tab-always-indent' cause the first possible action |
9875e646 TT |
671 | from the following list to take place: |
672 | ||
673 | 1. Move from beginning of line to correct indentation. | |
674 | 2. Delete an empty comment. | |
675 | 3. Move forward to start of comment, indenting if necessary. | |
676 | 4. Move forward to end of line, indenting if necessary. | |
677 | 5. Create an empty comment. | |
678 | 6. Move backward to start of comment, indenting if necessary." | |
679 | (interactive "p") | |
05794f14 SM |
680 | (if (memq tcl-tab-always-indent '(nil t)) |
681 | (let ((tab-always-indent tcl-tab-always-indent)) | |
682 | (call-interactively 'indent-for-tab-command)) | |
9875e646 TT |
683 | ;; "Perl-mode" style TAB command. |
684 | (let* ((ipoint (point)) | |
685 | (eolpoint (progn | |
686 | (end-of-line) | |
687 | (point))) | |
688 | (comment-p (tcl-in-comment))) | |
689 | (cond | |
c2ca5171 | 690 | ((= ipoint (line-beginning-position)) |
9875e646 TT |
691 | (beginning-of-line) |
692 | (tcl-indent-line) | |
693 | ;; If indenting didn't leave us in column 0, go to the | |
694 | ;; indentation. Otherwise leave point at end of line. This | |
695 | ;; is a hack. | |
c2ca5171 | 696 | (if (= (point) (line-beginning-position)) |
9875e646 TT |
697 | (end-of-line) |
698 | (back-to-indentation))) | |
699 | ((and comment-p (looking-at "[ \t]*$")) | |
700 | ;; Empty comment, so delete it. We also delete any ";" | |
701 | ;; characters at the end of the line. I think this is | |
702 | ;; friendlier, but I don't know how other people will feel. | |
703 | (backward-char) | |
704 | (skip-chars-backward " \t;") | |
705 | (delete-region (point) eolpoint)) | |
706 | ((and comment-p (< ipoint (point))) | |
707 | ;; Before comment, so skip to it. | |
708 | (tcl-indent-line) | |
709 | (indent-for-comment)) | |
710 | ((/= ipoint eolpoint) | |
711 | ;; Go to end of line (since we're not there yet). | |
712 | (goto-char eolpoint) | |
713 | (tcl-indent-line)) | |
714 | ((not comment-p) | |
9875e646 | 715 | (tcl-indent-line) |
c2ca5171 | 716 | (comment-indent)) |
9875e646 TT |
717 | (t |
718 | ;; Go to start of comment. We don't leave point where it is | |
719 | ;; because we want to skip comment-start-skip. | |
720 | (tcl-indent-line) | |
05794f14 | 721 | (indent-for-comment)))))) |
9875e646 TT |
722 | |
723 | (defun tcl-indent-line () | |
724 | "Indent current line as Tcl code. | |
725 | Return the amount the indentation changed by." | |
c2ca5171 | 726 | (let ((indent (tcl-calculate-indent nil)) |
9875e646 TT |
727 | beg shift-amt |
728 | (case-fold-search nil) | |
729 | (pos (- (point-max) (point)))) | |
05794f14 SM |
730 | (if (null indent) |
731 | 'noindent | |
732 | (beginning-of-line) | |
733 | (setq beg (point)) | |
734 | (skip-chars-forward " \t") | |
735 | (if (listp indent) (setq indent (car indent))) | |
736 | (cond ((= (following-char) ?}) | |
737 | (setq indent (- indent tcl-indent-level))) | |
738 | ((= (following-char) ?\]) | |
739 | (setq indent (- indent 1)))) | |
740 | (skip-chars-forward " \t") | |
741 | (setq shift-amt (- indent (current-column))) | |
742 | (if (zerop shift-amt) | |
743 | (if (> (- (point-max) pos) (point)) | |
744 | (goto-char (- (point-max) pos))) | |
745 | (delete-region beg (point)) | |
746 | (indent-to indent) | |
747 | ;; If initial point was within line's indentation, | |
748 | ;; position after the indentation. Else stay at same point in text. | |
749 | (if (> (- (point-max) pos) (point)) | |
750 | (goto-char (- (point-max) pos)))) | |
751 | shift-amt))) | |
9875e646 TT |
752 | |
753 | (defun tcl-figure-type () | |
754 | "Determine type of sexp at point. | |
2f585cfe | 755 | This is either `tcl-expr', `tcl-commands', or nil. Puts point at start |
9875e646 TT |
756 | of sexp that indicates types. |
757 | ||
758 | See documentation for variable `tcl-type-alist' for more information." | |
759 | (let ((count 0) | |
760 | result | |
761 | word-stack) | |
762 | (while (and (< count 5) | |
763 | (not result)) | |
764 | (condition-case nil | |
765 | (progn | |
766 | ;; FIXME should use "tcl-backward-sexp", which would skip | |
767 | ;; over entire variables, etc. | |
768 | (backward-sexp) | |
769 | (if (looking-at "[a-zA-Z_]+") | |
770 | (let ((list tcl-type-alist) | |
771 | entry) | |
6654e1b1 | 772 | (setq word-stack (cons (tcl-word-no-props) word-stack)) |
9875e646 TT |
773 | (while (and list (not result)) |
774 | (setq entry (car list)) | |
775 | (setq list (cdr list)) | |
776 | (let ((index 0)) | |
777 | (while (and entry (<= index count)) | |
778 | ;; Abort loop if string does not match word on | |
779 | ;; stack. | |
780 | (and (stringp (car entry)) | |
781 | (not (string= (car entry) | |
782 | (nth index word-stack))) | |
783 | (setq entry nil)) | |
784 | (setq entry (cdr entry)) | |
785 | (setq index (1+ index))) | |
786 | (and (> index count) | |
787 | (not (stringp (car entry))) | |
788 | (setq result (car entry))) | |
789 | ))) | |
790 | (setq word-stack (cons nil word-stack)))) | |
791 | (error nil)) | |
792 | (setq count (1+ count))) | |
793 | (and tcl-explain-indentation | |
794 | (message "Indentation type %s" result)) | |
795 | result)) | |
796 | ||
c2ca5171 | 797 | (defun tcl-calculate-indent (&optional parse-start) |
9875e646 TT |
798 | "Return appropriate indentation for current line as Tcl code. |
799 | In usual case returns an integer: the column to indent to. | |
800 | Returns nil if line starts inside a string, t if in a comment." | |
801 | (save-excursion | |
802 | (beginning-of-line) | |
803 | (let* ((indent-point (point)) | |
804 | (case-fold-search nil) | |
a1506d29 | 805 | (continued-line |
9875e646 TT |
806 | (save-excursion |
807 | (if (bobp) | |
808 | nil | |
809 | (backward-char) | |
810 | (= ?\\ (preceding-char))))) | |
811 | (continued-indent-value (if continued-line | |
812 | tcl-continued-indent-level | |
813 | 0)) | |
814 | state | |
815 | containing-sexp | |
816 | found-next-line) | |
817 | (if parse-start | |
818 | (goto-char parse-start) | |
c2ca5171 | 819 | (beginning-of-defun)) |
9875e646 TT |
820 | (while (< (point) indent-point) |
821 | (setq parse-start (point)) | |
822 | (setq state (parse-partial-sexp (point) indent-point 0)) | |
823 | (setq containing-sexp (car (cdr state)))) | |
824 | (cond ((or (nth 3 state) (nth 4 state)) | |
825 | ;; Inside comment or string. Return nil or t if should | |
826 | ;; not change this line | |
827 | (nth 4 state)) | |
828 | ((null containing-sexp) | |
829 | ;; Line is at top level. | |
830 | continued-indent-value) | |
831 | (t | |
832 | ;; Set expr-p if we are looking at the expression part of | |
833 | ;; an "if", "expr", etc statement. Set commands-p if we | |
834 | ;; are looking at the body part of an if, while, etc | |
835 | ;; statement. FIXME Should check for "for" loops here. | |
836 | (goto-char containing-sexp) | |
837 | (let* ((sexpr-type (tcl-figure-type)) | |
838 | (expr-p (eq sexpr-type 'tcl-expr)) | |
839 | (commands-p (eq sexpr-type 'tcl-commands)) | |
840 | (expr-start (point))) | |
841 | ;; Find the first statement in the block and indent | |
842 | ;; like it. The first statement in the block might be | |
843 | ;; on the same line, so what we do is skip all | |
844 | ;; "virtually blank" lines, looking for a non-blank | |
845 | ;; one. A line is virtually blank if it only contains | |
846 | ;; a comment and whitespace. FIXME continued comments | |
847 | ;; aren't supported. They are a wart on Tcl anyway. | |
848 | ;; We do it this funky way because we want to know if | |
849 | ;; we've found a statement on some line _after_ the | |
850 | ;; line holding the sexp opener. | |
851 | (goto-char containing-sexp) | |
852 | (forward-char) | |
853 | (if (and (< (point) indent-point) | |
854 | (looking-at "[ \t]*\\(#.*\\)?$")) | |
855 | (progn | |
856 | (forward-line) | |
857 | (while (and (< (point) indent-point) | |
858 | (looking-at "[ \t]*\\(#.*\\)?$")) | |
859 | (setq found-next-line t) | |
860 | (forward-line)))) | |
861 | (if (or continued-line | |
862 | (/= (char-after containing-sexp) ?{) | |
863 | expr-p) | |
864 | (progn | |
865 | ;; Line is continuation line, or the sexp opener | |
58179cce | 866 | ;; is not a curly brace, or we are looking at |
9875e646 TT |
867 | ;; an `expr' expression (which must be split |
868 | ;; specially). So indentation is column of first | |
869 | ;; good spot after sexp opener (with some added | |
870 | ;; in the continued-line case). If there is no | |
871 | ;; nonempty line before the indentation point, we | |
872 | ;; use the column of the character after the sexp | |
873 | ;; opener. | |
874 | (if (>= (point) indent-point) | |
875 | (progn | |
876 | (goto-char containing-sexp) | |
877 | (forward-char)) | |
878 | (skip-chars-forward " \t")) | |
879 | (+ (current-column) continued-indent-value)) | |
880 | ;; After a curly brace, and not a continuation line. | |
881 | ;; So take indentation from first good line after | |
882 | ;; start of block, unless that line is on the same | |
883 | ;; line as the opening brace. In this case use the | |
884 | ;; indentation of the opening brace's line, plus | |
885 | ;; another indent step. If we are in the body part | |
886 | ;; of an "if" or "while" then the indentation is | |
887 | ;; taken from the line holding the start of the | |
888 | ;; statement. | |
889 | (if (and (< (point) indent-point) | |
890 | found-next-line) | |
891 | (current-indentation) | |
892 | (if commands-p | |
893 | (goto-char expr-start) | |
894 | (goto-char containing-sexp)) | |
895 | (+ (current-indentation) tcl-indent-level))))))))) | |
896 | ||
897 | \f | |
898 | ||
c2ca5171 | 899 | (defun tcl-indent-exp () |
9875e646 TT |
900 | "Indent each line of the Tcl grouping following point." |
901 | (interactive) | |
902 | (let ((indent-stack (list nil)) | |
903 | (contain-stack (list (point))) | |
904 | (case-fold-search nil) | |
905 | outer-loop-done inner-loop-done state ostate | |
6612afc0 | 906 | this-indent continued-line |
9875e646 TT |
907 | (next-depth 0) |
908 | last-depth) | |
909 | (save-excursion | |
910 | (forward-sexp 1)) | |
911 | (save-excursion | |
912 | (setq outer-loop-done nil) | |
913 | (while (and (not (eobp)) (not outer-loop-done)) | |
914 | (setq last-depth next-depth) | |
915 | ;; Compute how depth changes over this line | |
916 | ;; plus enough other lines to get to one that | |
917 | ;; does not end inside a comment or string. | |
918 | ;; Meanwhile, do appropriate indentation on comment lines. | |
919 | (setq inner-loop-done nil) | |
920 | (while (and (not inner-loop-done) | |
921 | (not (and (eobp) (setq outer-loop-done t)))) | |
922 | (setq ostate state) | |
923 | (setq state (parse-partial-sexp (point) (progn (end-of-line) (point)) | |
924 | nil nil state)) | |
925 | (setq next-depth (car state)) | |
9875e646 TT |
926 | (if (or (nth 4 ostate)) |
927 | (tcl-indent-line)) | |
928 | (if (or (nth 3 state)) | |
929 | (forward-line 1) | |
930 | (setq inner-loop-done t))) | |
931 | (if (<= next-depth 0) | |
932 | (setq outer-loop-done t)) | |
933 | (if outer-loop-done | |
934 | nil | |
935 | ;; If this line had ..))) (((.. in it, pop out of the levels | |
936 | ;; that ended anywhere in this line, even if the final depth | |
937 | ;; doesn't indicate that they ended. | |
938 | (while (> last-depth (nth 6 state)) | |
939 | (setq indent-stack (cdr indent-stack) | |
940 | contain-stack (cdr contain-stack) | |
941 | last-depth (1- last-depth))) | |
9875e646 TT |
942 | ;; Add levels for any parens that were started in this line. |
943 | (while (< last-depth next-depth) | |
944 | (setq indent-stack (cons nil indent-stack) | |
945 | contain-stack (cons nil contain-stack) | |
946 | last-depth (1+ last-depth))) | |
947 | (if (null (car contain-stack)) | |
a1506d29 | 948 | (setcar contain-stack |
9875e646 TT |
949 | (or (car (cdr state)) |
950 | (save-excursion | |
951 | (forward-sexp -1) | |
952 | (point))))) | |
953 | (forward-line 1) | |
a1506d29 | 954 | (setq continued-line |
9875e646 TT |
955 | (save-excursion |
956 | (backward-char) | |
957 | (= (preceding-char) ?\\))) | |
958 | (skip-chars-forward " \t") | |
959 | (if (eolp) | |
960 | nil | |
961 | (if (and (car indent-stack) | |
962 | (>= (car indent-stack) 0)) | |
963 | ;; Line is on an existing nesting level. | |
964 | (setq this-indent (car indent-stack)) | |
965 | ;; Just started a new nesting level. | |
966 | ;; Compute the standard indent for this level. | |
c2ca5171 | 967 | (let ((val (tcl-calculate-indent |
9875e646 TT |
968 | (if (car indent-stack) |
969 | (- (car indent-stack)))))) | |
970 | (setcar indent-stack | |
971 | (setq this-indent val)) | |
972 | (setq continued-line nil))) | |
973 | (cond ((not (numberp this-indent))) | |
974 | ((= (following-char) ?}) | |
975 | (setq this-indent (- this-indent tcl-indent-level))) | |
976 | ((= (following-char) ?\]) | |
977 | (setq this-indent (- this-indent 1)))) | |
978 | ;; Put chosen indentation into effect. | |
979 | (or (null this-indent) | |
a1506d29 JB |
980 | (= (current-column) |
981 | (if continued-line | |
9875e646 TT |
982 | (+ this-indent tcl-indent-level) |
983 | this-indent)) | |
984 | (progn | |
985 | (delete-region (point) (progn (beginning-of-line) (point))) | |
a1506d29 JB |
986 | (indent-to |
987 | (if continued-line | |
9875e646 TT |
988 | (+ this-indent tcl-indent-level) |
989 | this-indent))))))))) | |
990 | ) | |
991 | ||
992 | \f | |
993 | ||
994 | ;; | |
995 | ;; Interfaces to other packages. | |
996 | ;; | |
997 | ||
9875e646 | 998 | ;; FIXME Definition of function is very ad-hoc. Should use |
c2ca5171 | 999 | ;; beginning-of-defun. Also has incestuous knowledge about the |
9875e646 | 1000 | ;; format of tcl-proc-regexp. |
c2ca5171 | 1001 | (defun tcl-add-log-defun () |
9875e646 TT |
1002 | "Return name of Tcl function point is in, or nil." |
1003 | (save-excursion | |
150269d5 TT |
1004 | (end-of-line) |
1005 | (if (re-search-backward (concat tcl-proc-regexp "\\([^ \t\n{]+\\)") nil t) | |
c2ca5171 | 1006 | (match-string 2)))) |
9875e646 | 1007 | |
50776640 TT |
1008 | (defun tcl-outline-level () |
1009 | (save-excursion | |
1010 | (skip-chars-forward " \t") | |
1011 | (current-column))) | |
1012 | ||
9875e646 TT |
1013 | \f |
1014 | ||
1015 | ;; | |
1016 | ;; Helper functions for inferior Tcl mode. | |
1017 | ;; | |
1018 | ||
1019 | ;; This exists to let us delete the prompt when commands are sent | |
1020 | ;; directly to the inferior Tcl. See gud.el for an explanation of how | |
1021 | ;; it all works (I took it from there). This stuff doesn't really | |
1022 | ;; work as well as I'd like it to. But I don't believe there is | |
1023 | ;; anything useful that can be done. | |
1024 | (defvar inferior-tcl-delete-prompt-marker nil) | |
1025 | ||
1026 | (defun tcl-filter (proc string) | |
723d286f | 1027 | (let ((inhibit-quit t)) ;FIXME: Isn't that redundant? |
c2ca5171 | 1028 | (with-current-buffer (process-buffer proc) |
9875e646 | 1029 | ;; Delete prompt if requested. |
723d286f SM |
1030 | (when (marker-buffer inferior-tcl-delete-prompt-marker) |
1031 | (delete-region (process-mark proc) inferior-tcl-delete-prompt-marker) | |
1032 | (set-marker inferior-tcl-delete-prompt-marker nil)))) | |
c2ca5171 | 1033 | (comint-output-filter proc string)) |
9875e646 TT |
1034 | |
1035 | (defun tcl-send-string (proc string) | |
c2ca5171 | 1036 | (with-current-buffer (process-buffer proc) |
9875e646 | 1037 | (goto-char (process-mark proc)) |
75669e02 | 1038 | (forward-line 0) ;Not (beginning-of-line) because of fields. |
9875e646 TT |
1039 | (if (looking-at comint-prompt-regexp) |
1040 | (set-marker inferior-tcl-delete-prompt-marker (point)))) | |
1041 | (comint-send-string proc string)) | |
1042 | ||
1043 | (defun tcl-send-region (proc start end) | |
c2ca5171 | 1044 | (with-current-buffer (process-buffer proc) |
9875e646 | 1045 | (goto-char (process-mark proc)) |
75669e02 | 1046 | (forward-line 0) ;Not (beginning-of-line) because of fields. |
9875e646 TT |
1047 | (if (looking-at comint-prompt-regexp) |
1048 | (set-marker inferior-tcl-delete-prompt-marker (point)))) | |
1049 | (comint-send-region proc start end)) | |
1050 | ||
1051 | (defun switch-to-tcl (eob-p) | |
1052 | "Switch to inferior Tcl process buffer. | |
1053 | With argument, positions cursor at end of buffer." | |
1054 | (interactive "P") | |
1055 | (if (get-buffer inferior-tcl-buffer) | |
1056 | (pop-to-buffer inferior-tcl-buffer) | |
1057 | (error "No current inferior Tcl buffer")) | |
1058 | (cond (eob-p | |
1059 | (push-mark) | |
1060 | (goto-char (point-max))))) | |
1061 | ||
1062 | (defun inferior-tcl-proc () | |
1063 | "Return current inferior Tcl process. | |
1064 | See variable `inferior-tcl-buffer'." | |
175069ef | 1065 | (let ((proc (get-buffer-process (if (derived-mode-p 'inferior-tcl-mode) |
9875e646 TT |
1066 | (current-buffer) |
1067 | inferior-tcl-buffer)))) | |
1068 | (or proc | |
1069 | (error "No Tcl process; see variable `inferior-tcl-buffer'")))) | |
1070 | ||
1071 | (defun tcl-eval-region (start end &optional and-go) | |
1072 | "Send the current region to the inferior Tcl process. | |
1073 | Prefix argument means switch to the Tcl buffer afterwards." | |
1074 | (interactive "r\nP") | |
1075 | (let ((proc (inferior-tcl-proc))) | |
75669e02 SM |
1076 | (tcl-send-region |
1077 | proc | |
1078 | ;; Strip leading and trailing whitespace. | |
1079 | (save-excursion (goto-char start) (skip-chars-forward " \t\n") (point)) | |
1080 | (save-excursion (goto-char end) (skip-chars-backward " \t\n") (point))) | |
9875e646 TT |
1081 | (tcl-send-string proc "\n") |
1082 | (if and-go (switch-to-tcl t)))) | |
1083 | ||
1084 | (defun tcl-eval-defun (&optional and-go) | |
1085 | "Send the current defun to the inferior Tcl process. | |
1086 | Prefix argument means switch to the Tcl buffer afterwards." | |
1087 | (interactive "P") | |
1088 | (save-excursion | |
c2ca5171 | 1089 | (end-of-defun) |
9875e646 | 1090 | (let ((end (point))) |
c2ca5171 | 1091 | (beginning-of-defun) |
9875e646 TT |
1092 | (tcl-eval-region (point) end))) |
1093 | (if and-go (switch-to-tcl t))) | |
1094 | ||
1095 | \f | |
1096 | ||
1097 | ;; | |
1098 | ;; Inferior Tcl mode itself. | |
1099 | ;; | |
1100 | ||
c2ca5171 | 1101 | (define-derived-mode inferior-tcl-mode comint-mode "Inferior Tcl" |
9875e646 TT |
1102 | "Major mode for interacting with Tcl interpreter. |
1103 | ||
031a5886 | 1104 | You can start a Tcl process with \\[inferior-tcl]. |
9875e646 | 1105 | |
2f585cfe RS |
1106 | Entry to this mode runs the normal hooks `comint-mode-hook' and |
1107 | `inferior-tcl-mode-hook', in that order. | |
9875e646 TT |
1108 | |
1109 | You can send text to the inferior Tcl process from other buffers | |
1110 | containing Tcl source. | |
1111 | ||
1112 | Variables controlling Inferior Tcl mode: | |
c2ca5171 | 1113 | `tcl-application' |
9875e646 | 1114 | Name of program to run. |
c2ca5171 | 1115 | `tcl-command-switches' |
9875e646 | 1116 | Command line arguments to `tcl-application'. |
c2ca5171 | 1117 | `tcl-prompt-regexp' |
9875e646 | 1118 | Matches prompt. |
c2ca5171 | 1119 | `inferior-tcl-source-command' |
9875e646 | 1120 | Command to use to read Tcl file in running application. |
c2ca5171 | 1121 | `inferior-tcl-buffer' |
9875e646 TT |
1122 | The current inferior Tcl process buffer. See variable |
1123 | documentation for details on multiple-process support. | |
1124 | ||
1125 | The following commands are available: | |
1126 | \\{inferior-tcl-mode-map}" | |
c2ca5171 SM |
1127 | (set (make-local-variable 'comint-prompt-regexp) |
1128 | (or tcl-prompt-regexp | |
1129 | (concat "^" (regexp-quote tcl-application) ">"))) | |
1130 | (setq mode-line-process '(": %s")) | |
9875e646 TT |
1131 | (setq local-abbrev-table tcl-mode-abbrev-table) |
1132 | (set-syntax-table tcl-mode-syntax-table) | |
c2ca5171 SM |
1133 | (set (make-local-variable 'defun-prompt-regexp) tcl-omit-ws-regexp) |
1134 | (set (make-local-variable 'inferior-tcl-delete-prompt-marker) (make-marker)) | |
1135 | (set-process-filter (get-buffer-process (current-buffer)) 'tcl-filter)) | |
9875e646 | 1136 | |
cd754bf5 | 1137 | ;;;###autoload |
9875e646 TT |
1138 | (defun inferior-tcl (cmd) |
1139 | "Run inferior Tcl process. | |
1140 | Prefix arg means enter program name interactively. | |
1141 | See documentation for function `inferior-tcl-mode' for more information." | |
1142 | (interactive | |
1143 | (list (if current-prefix-arg | |
1144 | (read-string "Run Tcl: " tcl-application) | |
1145 | tcl-application))) | |
a2052295 JH |
1146 | (unless (comint-check-proc "*inferior-tcl*") |
1147 | (set-buffer (apply (function make-comint) "inferior-tcl" cmd nil | |
1148 | tcl-command-switches)) | |
75669e02 SM |
1149 | (inferior-tcl-mode) |
1150 | ;; Make tclsh display a prompt on ms-windows (or under Unix, when a tty | |
1151 | ;; wasn't used). Doesn't affect wish, unfortunately. | |
1152 | (unless (process-tty-name (inferior-tcl-proc)) | |
1153 | (tcl-send-string (inferior-tcl-proc) | |
1154 | "set ::tcl_interactive 1; concat\n"))) | |
a2052295 | 1155 | (set (make-local-variable 'tcl-application) cmd) |
9875e646 | 1156 | (setq inferior-tcl-buffer "*inferior-tcl*") |
a2052295 | 1157 | (pop-to-buffer "*inferior-tcl*")) |
9875e646 | 1158 | |
c2ca5171 | 1159 | (defalias 'run-tcl 'inferior-tcl) |
9875e646 TT |
1160 | |
1161 | \f | |
1162 | ||
1163 | ;; | |
1164 | ;; Auto-fill support. | |
1165 | ;; | |
1166 | ||
1167 | (defun tcl-real-command-p () | |
1168 | "Return nil if point is not at the beginning of a command. | |
1169 | A command is the first word on an otherwise empty line, or the | |
1170 | first word following a semicolon, opening brace, or opening bracket." | |
1171 | (save-excursion | |
1172 | (skip-chars-backward " \t") | |
1173 | (cond | |
1174 | ((bobp) t) | |
1175 | ((bolp) | |
1176 | (backward-char) | |
1177 | ;; Note -- continued comments are not supported here. I | |
1178 | ;; consider those to be a wart on the language. | |
1179 | (not (eq ?\\ (preceding-char)))) | |
1180 | (t | |
1181 | (memq (preceding-char) '(?\; ?{ ?\[)))))) | |
1182 | ||
1183 | ;; FIXME doesn't actually return t. See last case. | |
1184 | (defun tcl-real-comment-p () | |
1185 | "Return t if point is just after the `#' beginning a real comment. | |
1186 | Does not check to see if previous char is actually `#'. | |
1187 | A real comment is either at the beginning of the buffer, | |
9ad79cb4 | 1188 | preceded only by whitespace on the line, or has a preceding |
9875e646 TT |
1189 | semicolon, opening brace, or opening bracket on the same line." |
1190 | (save-excursion | |
1191 | (backward-char) | |
1192 | (tcl-real-command-p))) | |
1193 | ||
1194 | (defun tcl-hairy-scan-for-comment (state end always-stop) | |
1195 | "Determine if point is in a comment. | |
1196 | Returns a list of the form `(FLAG . STATE)'. STATE can be used | |
1197 | as input to future invocations. FLAG is nil if not in comment, | |
14121c52 | 1198 | t otherwise. If in comment, leaves point at beginning of comment." |
9875e646 TT |
1199 | (let ((bol (save-excursion |
1200 | (goto-char end) | |
9b026d9f | 1201 | (line-beginning-position))) |
9875e646 TT |
1202 | real-comment |
1203 | last-cstart) | |
1204 | (while (and (not last-cstart) (< (point) end)) | |
c2ca5171 | 1205 | (setq real-comment nil) ;In case we've looped around and it is set. |
9875e646 TT |
1206 | (setq state (parse-partial-sexp (point) end nil nil state t)) |
1207 | (if (nth 4 state) | |
1208 | (progn | |
1209 | ;; If ALWAYS-STOP is set, stop even if we don't have a | |
1210 | ;; real comment, or if the comment isn't on the same line | |
1211 | ;; as the end. | |
1212 | (if always-stop (setq last-cstart (point))) | |
1213 | ;; If we have a real comment, then set the comment | |
1214 | ;; starting point if we are on the same line as the ending | |
1215 | ;; location. | |
1216 | (setq real-comment (tcl-real-comment-p)) | |
1217 | (if real-comment | |
1218 | (progn | |
1219 | (and (> (point) bol) (setq last-cstart (point))) | |
1220 | ;; NOTE Emacs 19 has a misfeature whereby calling | |
1221 | ;; parse-partial-sexp with COMMENTSTOP set and with | |
1222 | ;; an initial list that says point is in a comment | |
1223 | ;; will cause an immediate return. So we must skip | |
1224 | ;; over the comment ourselves. | |
1225 | (beginning-of-line 2))) | |
1226 | ;; Frob the state to make it look like we aren't in a | |
1227 | ;; comment. | |
1228 | (setcar (nthcdr 4 state) nil)))) | |
1229 | (and last-cstart | |
1230 | (goto-char last-cstart)) | |
1231 | (cons real-comment state))) | |
1232 | ||
c2ca5171 | 1233 | (defun tcl-in-comment () |
2f585cfe | 1234 | "Return t if point is in a comment, and leave point at beginning of comment." |
9875e646 | 1235 | (let ((save (point))) |
c2ca5171 | 1236 | (beginning-of-defun) |
9875e646 | 1237 | (car (tcl-hairy-scan-for-comment nil save nil)))) |
6be8057e | 1238 | |
9875e646 TT |
1239 | \f |
1240 | ||
1241 | ;; | |
1242 | ;; Help-related code. | |
1243 | ;; | |
1244 | ||
95338744 TT |
1245 | (defvar tcl-help-saved-dirs nil |
1246 | "Saved help directories. | |
1247 | If `tcl-help-directory-list' changes, this allows `tcl-help-on-word' | |
1248 | to update the alist.") | |
9875e646 TT |
1249 | |
1250 | (defvar tcl-help-alist nil | |
1251 | "Alist with command names as keys and filenames as values.") | |
1252 | ||
c2ca5171 SM |
1253 | (defun tcl-files-alist (dir &optional alist) |
1254 | "Recursively add all pairs (FILE . PATH) under DIR to ALIST." | |
1255 | (dolist (file (directory-files dir t) alist) | |
1256 | (cond | |
1257 | ((not (file-directory-p file)) | |
1258 | (push (cons (file-name-nondirectory file) file) alist)) | |
1259 | ((member (file-name-nondirectory file) '("." ".."))) | |
1260 | (t (setq alist (tcl-files-alist file alist)))))) | |
1261 | ||
95338744 | 1262 | (defun tcl-help-snarf-commands (dirlist) |
c2ca5171 SM |
1263 | "Return alist of commands and filenames." |
1264 | (let ((alist nil)) | |
1265 | (dolist (dir dirlist alist) | |
1266 | (when (file-directory-p dir) | |
1267 | (setq alist (tcl-files-alist dir alist)))))) | |
9875e646 TT |
1268 | |
1269 | (defun tcl-reread-help-files () | |
1270 | "Set up to re-read files, and then do it." | |
1271 | (interactive) | |
1272 | (message "Building Tcl help file index...") | |
95338744 | 1273 | (setq tcl-help-saved-dirs tcl-help-directory-list) |
c2ca5171 | 1274 | (setq tcl-help-alist (tcl-help-snarf-commands tcl-help-directory-list)) |
9875e646 TT |
1275 | (message "Building Tcl help file index...done")) |
1276 | ||
6654e1b1 | 1277 | (defun tcl-word-no-props () |
c2ca5171 | 1278 | "Like `current-word', but strips properties." |
6654e1b1 | 1279 | (let ((word (current-word))) |
c2ca5171 | 1280 | (set-text-properties 0 (length word) nil word) |
6654e1b1 TT |
1281 | word)) |
1282 | ||
9875e646 TT |
1283 | (defun tcl-current-word (flag) |
1284 | "Return current command word, or nil. | |
1285 | If FLAG is nil, just uses `current-word'. | |
1286 | Otherwise scans backward for most likely Tcl command word." | |
f5608c76 | 1287 | (if (and flag |
175069ef | 1288 | (derived-mode-p 'tcl-mode 'inferior-tcl-mode)) |
9875e646 TT |
1289 | (condition-case nil |
1290 | (save-excursion | |
1291 | ;; Look backward for first word actually in alist. | |
1292 | (if (bobp) | |
1293 | () | |
1294 | (while (and (not (bobp)) | |
1295 | (not (tcl-real-command-p))) | |
1296 | (backward-sexp))) | |
6654e1b1 TT |
1297 | (if (assoc (tcl-word-no-props) tcl-help-alist) |
1298 | (tcl-word-no-props))) | |
9875e646 | 1299 | (error nil)) |
6654e1b1 | 1300 | (tcl-word-no-props))) |
9875e646 | 1301 | |
cd754bf5 | 1302 | ;;;###autoload |
9875e646 TT |
1303 | (defun tcl-help-on-word (command &optional arg) |
1304 | "Get help on Tcl command. Default is word at point. | |
1305 | Prefix argument means invert sense of `tcl-use-smart-word-finder'." | |
1306 | (interactive | |
1307 | (list | |
1308 | (progn | |
95338744 | 1309 | (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) |
9875e646 TT |
1310 | (tcl-reread-help-files)) |
1311 | (let ((word (tcl-current-word | |
1312 | (if current-prefix-arg | |
1313 | (not tcl-use-smart-word-finder) | |
1314 | tcl-use-smart-word-finder)))) | |
1315 | (completing-read | |
1316 | (if (or (null word) (string= word "")) | |
1317 | "Help on Tcl command: " | |
1318 | (format "Help on Tcl command (default %s): " word)) | |
c2ca5171 | 1319 | tcl-help-alist nil t nil nil word))) |
9875e646 | 1320 | current-prefix-arg)) |
95338744 | 1321 | (if (not (equal tcl-help-directory-list tcl-help-saved-dirs)) |
9875e646 TT |
1322 | (tcl-reread-help-files)) |
1323 | (if (string= command "") | |
1324 | (setq command (tcl-current-word | |
1325 | (if arg | |
1326 | (not tcl-use-smart-word-finder) | |
1327 | tcl-use-smart-word-finder)))) | |
1328 | (let* ((help (get-buffer-create "*Tcl help*")) | |
1329 | (cell (assoc command tcl-help-alist)) | |
1330 | (file (and cell (cdr cell)))) | |
1331 | (set-buffer help) | |
1332 | (delete-region (point-min) (point-max)) | |
1333 | (if file | |
1334 | (progn | |
1335 | (insert "*** " command "\n\n") | |
1336 | (insert-file-contents file)) | |
1337 | (if (string= command "") | |
1338 | (insert "Magical Pig!") | |
1339 | (insert "Tcl command " command " not in help\n"))) | |
1340 | (set-buffer-modified-p nil) | |
1341 | (goto-char (point-min)) | |
1342 | (display-buffer help))) | |
1343 | ||
1344 | \f | |
1345 | ||
1346 | ;; | |
1347 | ;; Other interactive stuff. | |
1348 | ;; | |
1349 | ||
1350 | (defvar tcl-previous-dir/file nil | |
1351 | "Record last directory and file used in loading. | |
1352 | This holds a cons cell of the form `(DIRECTORY . FILE)' | |
1353 | describing the last `tcl-load-file' command.") | |
1354 | ||
1355 | (defun tcl-load-file (file &optional and-go) | |
1356 | "Load a Tcl file into the inferior Tcl process. | |
1357 | Prefix argument means switch to the Tcl buffer afterwards." | |
1358 | (interactive | |
1359 | (list | |
1360 | ;; car because comint-get-source returns a list holding the | |
1361 | ;; filename. | |
700a20bf TT |
1362 | (car (comint-get-source "Load Tcl file: " |
1363 | (or (and | |
175069ef | 1364 | (derived-mode-p 'tcl-mode) |
700a20bf TT |
1365 | (buffer-file-name)) |
1366 | tcl-previous-dir/file) | |
9875e646 TT |
1367 | '(tcl-mode) t)) |
1368 | current-prefix-arg)) | |
1369 | (comint-check-source file) | |
1370 | (setq tcl-previous-dir/file (cons (file-name-directory file) | |
1371 | (file-name-nondirectory file))) | |
1372 | (tcl-send-string (inferior-tcl-proc) | |
1373 | (format inferior-tcl-source-command (tcl-quote file))) | |
1374 | (if and-go (switch-to-tcl t))) | |
1375 | ||
9875e646 TT |
1376 | (defun tcl-restart-with-file (file &optional and-go) |
1377 | "Restart inferior Tcl with file. | |
1378 | If an inferior Tcl process exists, it is killed first. | |
1379 | Prefix argument means switch to the Tcl buffer afterwards." | |
1380 | (interactive | |
1381 | (list | |
1382 | (car (comint-get-source "Restart with Tcl file: " | |
1383 | (or (and | |
175069ef | 1384 | (derived-mode-p 'tcl-mode) |
9875e646 TT |
1385 | (buffer-file-name)) |
1386 | tcl-previous-dir/file) | |
1387 | '(tcl-mode) t)) | |
1388 | current-prefix-arg)) | |
175069ef | 1389 | (let* ((buf (if (derived-mode-p 'inferior-tcl-mode) |
9875e646 TT |
1390 | (current-buffer) |
1391 | inferior-tcl-buffer)) | |
1392 | (proc (and buf (get-process buf)))) | |
1393 | (cond | |
1394 | ((not (and buf (get-buffer buf))) | |
1395 | ;; I think this will be ok. | |
1396 | (inferior-tcl tcl-application) | |
1397 | (tcl-load-file file and-go)) | |
1398 | ((or | |
1399 | (not (comint-check-proc buf)) | |
1400 | (yes-or-no-p | |
1401 | "A Tcl process is running, are you sure you want to reset it? ")) | |
1402 | (save-excursion | |
1403 | (comint-check-source file) | |
1404 | (setq tcl-previous-dir/file (cons (file-name-directory file) | |
1405 | (file-name-nondirectory file))) | |
1406 | (comint-exec (get-buffer-create buf) | |
1407 | (if proc | |
1408 | (process-name proc) | |
1409 | "inferior-tcl") | |
1410 | tcl-application file tcl-command-switches) | |
1411 | (if and-go (switch-to-tcl t))))))) | |
1412 | ||
9875e646 | 1413 | (defun tcl-auto-fill-mode (&optional arg) |
2c7cdd69 | 1414 | "Like `auto-fill-mode', but sets `comment-auto-fill-only-comments'." |
9875e646 | 1415 | (interactive "P") |
2c7cdd69 SM |
1416 | (auto-fill-mode arg) |
1417 | (if auto-fill-function | |
1418 | (set (make-local-variable 'comment-auto-fill-only-comments) t) | |
1419 | (kill-local-variable 'comment-auto-fill-only-comments))) | |
9875e646 TT |
1420 | |
1421 | (defun tcl-electric-hash (&optional count) | |
1422 | "Insert a `#' and quote if it does not start a real comment. | |
1423 | Prefix arg is number of `#'s to insert. | |
1424 | See variable `tcl-electric-hash-style' for description of quoting | |
1425 | styles." | |
1426 | (interactive "p") | |
1427 | (or count (setq count 1)) | |
1428 | (if (> count 0) | |
1429 | (let ((type | |
1430 | (if (eq tcl-electric-hash-style 'smart) | |
1431 | (if (> count 3) ; FIXME what is "smart"? | |
1432 | 'quote | |
1433 | 'backslash) | |
1434 | tcl-electric-hash-style)) | |
1435 | comment) | |
1436 | (if type | |
1437 | (progn | |
1438 | (save-excursion | |
1439 | (insert "#") | |
1440 | (setq comment (tcl-in-comment))) | |
1441 | (delete-char 1) | |
1442 | (and tcl-explain-indentation (message "comment: %s" comment)) | |
1443 | (cond | |
1444 | ((eq type 'quote) | |
1445 | (if (not comment) | |
1446 | (insert "\""))) | |
1447 | ((eq type 'backslash) | |
1448 | ;; The following will set count to 0, so the | |
1449 | ;; insert-char can still be run. | |
1450 | (if (not comment) | |
1451 | (while (> count 0) | |
1452 | (insert "\\#") | |
1453 | (setq count (1- count))))) | |
1454 | (t nil)))) | |
1455 | (insert-char ?# count)))) | |
1456 | ||
1457 | (defun tcl-hashify-buffer () | |
1458 | "Quote all `#'s in current buffer that aren't Tcl comments." | |
1459 | (interactive) | |
1460 | (save-excursion | |
1461 | (goto-char (point-min)) | |
c2ca5171 SM |
1462 | (let (state |
1463 | result) | |
1464 | (while (< (point) (point-max)) | |
1465 | (setq result (tcl-hairy-scan-for-comment state (point-max) t)) | |
1466 | (if (car result) | |
9875e646 | 1467 | (beginning-of-line 2) |
9875e646 | 1468 | (backward-char) |
c2ca5171 | 1469 | (if (eq ?# (following-char)) |
9875e646 | 1470 | (insert "\\")) |
c2ca5171 SM |
1471 | (forward-char)) |
1472 | (setq state (cdr result)))))) | |
1473 | ||
1474 | (defun tcl-comment-indent () | |
1475 | "Return the desired indentation, but be careful to add a `;' if needed." | |
1476 | (save-excursion | |
1477 | ;; If line is not blank, make sure we insert a ";" first. | |
1478 | (skip-chars-backward " \t") | |
1479 | (unless (or (bolp) (tcl-real-command-p)) | |
1480 | (insert ";") | |
1481 | ;; Try and erase a non-significant char to keep charpos identical. | |
5089af27 | 1482 | (if (memq (char-after) '(?\t ?\s)) (delete-char 1)))) |
c2ca5171 | 1483 | (funcall (default-value 'comment-indent-function))) |
95338744 | 1484 | |
9875e646 TT |
1485 | ;; The following was inspired by the Tcl editing mode written by |
1486 | ;; Gregor Schmid <schmid@fb3-s7.math.TU-Berlin.DE>. His version also | |
1487 | ;; attempts to snarf the command line options from the command line, | |
1488 | ;; but I didn't think that would really be that helpful (doesn't seem | |
c2ca5171 | 1489 | ;; like it would be right enough. His version also looks for the |
9875e646 | 1490 | ;; "#!/bin/csh ... exec" hack, but that seemed even less useful. |
95338744 TT |
1491 | ;; FIXME should make sure that the application mentioned actually |
1492 | ;; exists. | |
9875e646 TT |
1493 | (defun tcl-guess-application () |
1494 | "Attempt to guess Tcl application by looking at first line. | |
1495 | The first line is assumed to look like \"#!.../program ...\"." | |
1496 | (save-excursion | |
1497 | (goto-char (point-min)) | |
3530a317 | 1498 | (if (looking-at "#![^ \t]*/\\([^ \t\n/]+\\)\\([ \t]\\|$\\)") |
c2ca5171 | 1499 | (set (make-local-variable 'tcl-application) (match-string 1))))) |
9875e646 TT |
1500 | |
1501 | \f | |
1502 | ||
1503 | ;; | |
e9e7f5f2 | 1504 | ;; XEmacs menu support. |
9875e646 TT |
1505 | ;; Taken from schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid), |
1506 | ;; who wrote a different Tcl mode. | |
2f585cfe | 1507 | ;; We also have support for menus in Emacs. We do this by |
e9e7f5f2 | 1508 | ;; loading the XEmacs menu emulation code. |
9875e646 TT |
1509 | ;; |
1510 | ||
e02f48d7 | 1511 | (defun tcl-popup-menu (_e) |
9aa88f3e | 1512 | (interactive "@e") |
c2ca5171 | 1513 | (popup-menu tcl-mode-menu)) |
9875e646 TT |
1514 | |
1515 | \f | |
1516 | ||
1517 | ;; | |
1518 | ;; Quoting and unquoting functions. | |
1519 | ;; | |
1520 | ||
1521 | ;; This quoting is sufficient to protect eg a filename from any sort | |
1522 | ;; of expansion or splitting. Tcl quoting sure sucks. | |
1523 | (defun tcl-quote (string) | |
1524 | "Quote STRING according to Tcl rules." | |
c2ca5171 | 1525 | (mapconcat (lambda (char) |
5089af27 | 1526 | (if (memq char '(?[ ?] ?{ ?} ?\\ ?\" ?$ ?\s ?\;)) |
c2ca5171 SM |
1527 | (concat "\\" (char-to-string char)) |
1528 | (char-to-string char))) | |
9875e646 TT |
1529 | string "")) |
1530 | ||
6be8057e TT |
1531 | ;; |
1532 | ;; Bug reporting. | |
1533 | ;; | |
6be8057e TT |
1534 | \f |
1535 | ||
c2ca5171 SM |
1536 | ;; These are relics kept "just in case". |
1537 | (defalias 'tcl-uncomment-region 'uncomment-region) | |
1538 | (defalias 'tcl-indent-for-comment 'comment-indent) | |
1539 | (defalias 'add-log-tcl-defun 'tcl-add-log-defun) | |
1540 | (defalias 'indent-tcl-exp 'tcl-indent-exp) | |
1541 | (defalias 'calculate-tcl-indent 'tcl-calculate-indent) | |
1542 | (defalias 'tcl-beginning-of-defun 'beginning-of-defun) | |
1543 | (defalias 'tcl-end-of-defun 'end-of-defun) | |
1544 | (defalias 'tcl-mark-defun 'mark-defun) | |
1545 | (defun tcl-mark () (mark t)) | |
1546 | ||
9875e646 TT |
1547 | (provide 'tcl) |
1548 | ||
1549 | ;;; tcl.el ends here |