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