OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [dejagnu/] [tcl-mode.el] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
;; tcl.el --- Tcl code editing commands for Emacs
2
 
3
;; Copyright (C) 1994 Free Software Foundation, Inc.
4
 
5
;; Maintainer: Tom Tromey <tromey@busco.lanl.gov>
6
;; Author: Tom Tromey <tromey@busco.lanl.gov>
7
;;    Chris Lindblad <cjl@lcs.mit.edu>
8
;; Keywords: languages tcl modes
9
;; Version: 1.49
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
15
;; the Free Software Foundation; either version 1, or (at your option)
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
24
;; along with GNU Emacs; see the file COPYING.  If not, write to
25
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
26
 
27
;; HOW TO INSTALL:
28
;; Put the following forms in your .emacs to enable autoloading of Tcl
29
;; mode, and auto-recognition of ".tcl" files.
30
;;
31
;;   (autoload 'tcl-mode "tcl" "Tcl mode." t)
32
;;   (autoload 'inferior-tcl "tcl" "Run inferior Tcl process." t)
33
;;   (setq auto-mode-alist (append '(("\\.tcl$" . tcl-mode)) auto-mode-alist))
34
;;
35
;; If you plan to use the interface to the TclX help files, you must
36
;; set the variable tcl-help-directory-list to point to the topmost
37
;; directories containing the TclX help files.  Eg:
38
;;
39
;;   (setq tcl-help-directory-list '("/usr/local/lib/tclx/help"))
40
;;
41
;; Also you will want to add the following to your .emacs:
42
;;
43
;;   (autoload 'tcl-help-on-word "tcl" "Help on Tcl commands" t)
44
;;
45
;; FYI a *very* useful thing to do is nroff all the Tk man pages and
46
;; put them in a subdir of the help system.
47
;;
48
 
49
;;; Commentary:
50
 
51
;; LCD Archive Entry:
52
;; tcl|Tom Tromey|tromey@busco.lanl.gov|
53
;; Major mode for editing Tcl|
54
;; 1995/12/07 18:27:47|1.49|~/modes/tcl.el.Z|
55
 
56
;; CUSTOMIZATION NOTES:
57
;; * tcl-proc-list can be used to customize a list of things that
58
;; "define" other things.  Eg in my project I put "defvar" in this
59
;; list.
60
;; * tcl-typeword-list is similar, but uses font-lock-type-face.
61
;; * tcl-keyword-list is a list of keywords.  I've generally used this
62
;; for flow-control words.  Eg I add "unwind_protect" to this list.
63
;; * tcl-type-alist can be used to minimally customize indentation
64
;; according to context.
65
 
66
;; Change log:
67
;; tcl.el,v
68
;; Revision 1.49  1995/12/07  18:27:47  tromey
69
;; (add-log-tcl-defun): Don't use tcl-beginning-of-defun; just go to end
70
;; of line before searching.
71
;;
72
;; Revision 1.48  1995/12/07  18:18:21  tromey
73
;; (add-log-tcl-defun): Now uses tcl-beginning-of-defun.
74
;;
75
;; Revision 1.47  1995/08/22  17:49:45  tromey
76
;; (tcl-hilit): New function from "Chris Alfeld" <calfeld@math.utah.edu>
77
;; (tcl-mode): Call it
78
;;
79
;; Revision 1.46  1995/08/07  16:02:01  tromey
80
;; (tcl-do-auto-fill): Only fill past fill-column; for 19.29.
81
;; (tcl-auto-fill-mode): Use force-mode-line-update.
82
;;
83
;; Revision 1.45  1995/07/23  23:51:25  tromey
84
;; (tcl-word-no-props): New function.
85
;; (tcl-figure-type): Use it.
86
;; (tcl-current-word): Ditto.
87
;;
88
;; Revision 1.44  1995/07/23  20:26:47  tromey
89
;; Doc fixes.
90
;;
91
;; Revision 1.43  1995/07/17  19:59:49  tromey
92
;; (inferior-tcl-mode): Use modeline-process if it exists.
93
;;
94
;; Revision 1.42  1995/07/17  19:55:25  tromey
95
;; XEmacs currently must use tcl-internal-end-of-defun
96
;;
97
;; Revision 1.41  1995/07/14  21:54:56  tromey
98
;; Changes to make menus work in XEmacs.
99
;; From Mike Scheidler <c23mts@kocrsv01.delcoelect.com>
100
;;
101
;; Revision 1.40  1995/07/11  03:13:15  tromey
102
;; (tcl-mode): Customize for new dabbrev.
103
;;
104
;; Revision 1.39  1995/07/09  21:58:03  tromey
105
;; (tcl-do-fill-paragraph): New function.
106
;; (tcl-mode): Set up for paragraph filling.
107
;;
108
;; Revision 1.38  1995/07/09  21:30:32  tromey
109
;; (tcl-mode): Fixes to 19.29 paragraph variables.
110
;;
111
;; Revision 1.37  1995/07/09  18:52:16  tromey
112
;; (tcl-do-auto-fill): Set fill-prefix.
113
;;
114
;; Revision 1.36  1995/07/09  01:07:57  tromey
115
;; (tcl-imenu-create-index-function): Work with imenu from Emacs 19.29
116
;;
117
;; Revision 1.35  1995/06/27  20:12:00  tromey
118
;; (tcl-type-alist): More itcl changes.
119
;;
120
;; Revision 1.34  1995/06/27  20:06:05  tromey
121
;; More changes for itcl.
122
;; Bug fixes for Emacs 19.29.
123
;;
124
;; Revision 1.33  1995/06/27  20:01:29  tromey
125
;; (tcl-set-proc-regexp): Allow leading spaces.
126
;; (tcl-proc-list): Changes for itcl.
127
;; (tcl-typeword-list): Ditto.
128
;; (tcl-keyword-list): Ditto.
129
;;
130
;; Revision 1.32  1995/05/11  22:12:49  tromey
131
;; (tcl-type-alist): Include entry for "proc".
132
;;
133
;; Revision 1.31  1995/05/10  23:38:12  tromey
134
;; (tcl-add-fsf-menu): Use make-lucid-menu-keymap, not
135
;; "make-xemacs-menu-keymap".
136
;;
137
;; Revision 1.30  1995/05/10  18:22:21  tromey
138
;; Bug fix in menu code for XEmacs.
139
;;
140
;; Revision 1.29  1995/05/09  21:36:53  tromey
141
;; Changed "Lucid Emacs" to "XEmacs".
142
;; Tcl's popup menu now added to existing one, courtesy
143
;; dfarmer@evolving.com (Doug Farmer)
144
;;
145
;; Revision 1.28  1995/04/08  19:52:50  tromey
146
;; (tcl-outline-level): New function
147
;; (tcl-mode): Added outline-handling stuff.
148
;; From Jesper Pedersen <blackie@imada.ou.dk>
149
;;
150
;; Revision 1.27  1994/10/11  02:01:27  tromey
151
;; (tcl-mode): imenu-create-index-function made buffer local.
152
;;
153
;; Revision 1.26  1994/09/01  18:06:24  tromey
154
;; Added filename completion in inferior tcl mode
155
;;
156
;; Revision 1.25  1994/08/22  15:56:24  tromey
157
;; tcl-load-file default to current buffer.
158
;;
159
;; Revision 1.24  1994/08/21  20:33:05  tromey
160
;; Fixed bug in tcl-guess-application.
161
;;
162
;; Revision 1.23  1994/08/21  03:54:45  tromey
163
;; Keybindings don't overshadown comint bindings.
164
;;
165
;; Revision 1.22  1994/07/26  00:46:07  tromey
166
;; Emacs 18 changes from Carl Witty.
167
;;
168
;; Revision 1.21  1994/07/14  22:49:21  tromey
169
;; Added ";;;###autoload" comments where appropriate.
170
;;
171
; Revision 1.20  1994/06/05  16:57:22  tromey
172
; tcl-current-word does the right thing in inferior-tcl-mode.
173
;
174
; Revision 1.19  1994/06/03  21:09:19  tromey
175
; Another menu fix.
176
;
177
; Revision 1.18  1994/06/03  20:39:14  tromey
178
; Fixed menu bug.
179
;
180
; Revision 1.17  1994/06/03  00:47:15  tromey
181
; Fixed bug in bug-reporting code.
182
;
183
; Revision 1.16  1994/05/26  05:06:14  tromey
184
; Menu items now sensitive as appropriate.
185
;
186
; Revision 1.15  1994/05/22  20:38:11  tromey
187
; Added bug-report keybindings and menu entries.
188
;
189
; Revision 1.14  1994/05/22  20:18:28  tromey
190
; Even more compile stuff.
191
;
192
; Revision 1.13  1994/05/22  20:17:15  tromey
193
; Moved emacs version checking code to very beginning.
194
;
195
; Revision 1.12  1994/05/22  20:14:59  tromey
196
; Compile fixes.
197
;
198
; Revision 1.11  1994/05/22  20:12:44  tromey
199
; Fixed mark-defun for 19.23.
200
; More menu fixes.
201
;
202
; Revision 1.10  1994/05/22  20:02:03  tromey
203
; Fixed bug with M-;.
204
; Wrote bug-reporting code.
205
;
206
; Revision 1.9  1994/05/22  05:26:51  tromey
207
; Fixes for imenu.
208
;
209
; Revision 1.8  1994/05/22  03:38:07  tromey
210
; Fixed menu support.
211
;
212
; Revision 1.7  1994/05/03  01:23:42  tromey
213
; *** empty log message ***
214
;
215
; Revision 1.6  1994/04/23  16:23:36  tromey
216
; Wrote tcl-indent-for-comment
217
;
218
;;
219
;; 18-Mar-1994          Tom Tromey      Fourth beta release.
220
;;    Added {un,}comment-region to menu.  Idea from
221
;;    Mike Scheidler <c23mts@kocrsv01.delcoelect.com>
222
;; 17-Mar-1994          Tom Tromey
223
;;    Fixed tcl-restart-with-file.  Bug fix attempt in
224
;;    tcl-internal-end-of-defun.
225
;; 16-Mar-1994          Tom Tromey      Third beta release
226
;;    Added support code for menu (from Tcl mode written by
227
;;    schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid)).
228
;; 12-Mar-1994          Tom Tromey
229
;;    Better documentation for inferior-tcl-buffer.  Wrote
230
;;    tcl-restart-with-file.  Wrote Lucid Emacs menu (but no
231
;;    code to install it).
232
;; 12-Mar-1994          Tom Tromey
233
;;    Wrote tcl-guess-application.  Another stab at making
234
;;    tcl-omit-ws-regexp work.
235
;; 10-Mar-1994          Tom Tromey      Second beta release
236
;;    Last Modified: Thu Mar 10 01:24:25 1994 (Tom Tromey)
237
;;    Wrote perl-mode style line indentation command.
238
;;    Wrote more documentation.  Added tcl-continued-indent-level.
239
;;    Integrated help code.
240
;; 8-Mar-1994           Tom Tromey
241
;;    Last Modified: Tue Mar  8 11:58:44 1994 (Tom Tromey)
242
;;    Bug fixes.
243
;; 6-Mar-1994           Tom Tromey
244
;;    Last Modified: Sun Mar  6 18:55:41 1994 (Tom Tromey)
245
;;    Updated auto-newline support.
246
;; 6-Mar-1994           Tom Tromey      Beta release
247
;;    Last Modified: Sat Mar  5 17:24:32 1994 (Tom Tromey)
248
;;    Wrote tcl-hashify-buffer.  Other minor bug fixes.
249
;; 5-Mar-1994           Tom Tromey
250
;;    Last Modified: Sat Mar  5 16:11:20 1994 (Tom Tromey)
251
;;    Wrote electric-hash code.
252
;; 3-Mar-1994           Tom Tromey
253
;;    Last Modified: Thu Mar  3 02:53:40 1994 (Tom Tromey)
254
;;    Added code to handle auto-fill in comments.
255
;;    Added imenu support code.
256
;;    Cleaned up code.
257
;;    Better font-lock support.
258
;; 28-Feb-1994          Tom Tromey
259
;;    Last Modified: Mon Feb 28 14:08:05 1994 (Tom Tromey)
260
;;    Made tcl-figure-type more easily configurable.
261
;; 28-Feb-1994          Tom Tromey
262
;;    Last Modified: Mon Feb 28 01:02:58 1994 (Tom Tromey)
263
;;    Wrote inferior-tcl mode.
264
;; 16-Feb-1994          Tom Tromey
265
;;    Last Modified: Wed Feb 16 17:05:19 1994 (Tom Tromey)
266
;;    Added support for font-lock-mode.
267
;; 29-Oct-1993          Tom Tromey
268
;;    Last Modified: Sun Oct 24 17:39:14 1993 (Tom Tromey)
269
;;    Patches from Guido Bosch to make things work with Lucid Emacs.
270
;; 22-Oct-1993          Tom Tromey
271
;;    Last Modified: Fri Oct 22 15:26:46 1993 (Tom Tromey)
272
;;    Made many characters have "_" syntax class; suggested by Guido
273
;;    Bosch <Guido.Bosch@loria.fr>.  Note that this includes the "$"
274
;;    character, which might be a change you'd notice.
275
;; 21-Oct-1993          Tom Tromey
276
;;    Last Modified: Thu Oct 21 20:28:40 1993 (Tom Tromey)
277
;;    More fixes for tcl-omit-ws-regexp.
278
;; 20-Oct-1993          Tom Tromey
279
;;    Started keeping history.  Fixed tcl-{beginning,end}-of-defun.
280
;;    Added some code to make things work with Emacs 18.
281
 
282
;; THANKS TO:
283
;; Guido Bosch <Guido.Bosch@loria.fr>
284
;; pgs1002@esc.cam.ac.uk (Dr P.G. Sjoerdsma)
285
;; Mike Scheidler <c23mts@kocrsv01.delcoelect.com>
286
;; Matt Newman <men@charney.colorado.edu>
287
;; rwhitby@research.canon.oz.au (Rod Whitby)
288
;; h9118101@hkuxa.hku.hk (Yip Chi Lap [Beta])
289
;; Pertti Tapio Kasanen <ptk@delta.hut.fi>
290
;; schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid)
291
;; warsaw@nlm.nih.gov (Barry A. Warsaw)
292
;; Carl Witty <cwitty@ai.mit.edu>
293
;; T. V. Raman <raman@crl.dec.com>
294
;; Jesper Pedersen <blackie@imada.ou.dk>
295
;; dfarmer@evolving.com (Doug Farmer)
296
;; "Chris Alfeld" <calfeld@math.utah.edu>
297
 
298
;; KNOWN BUGS:
299
;; * indent-region should skip blank lines.  (It does in v19, so I'm
300
;;   not motivated to fix it here).
301
;; * In Tcl "#" is not always a comment character.  This can confuse
302
;;   tcl.el in certain circumstances.  For now the only workaround is
303
;;   to enclose offending hash characters in quotes or precede it with
304
;;   a backslash.  Note that using braces won't work -- quotes change
305
;;   the syntax class of characters between them, while braces do not.
306
;;   The electric-# mode helps alleviate this problem somewhat.
307
;; * indent-tcl-exp is untested.
308
;; * Doesn't work under Emacs 18 yet.
309
;; * There's been a report that font-lock does strange things under
310
;;   Lucid Emacs 19.6.  For instance in "proc foobar", the space
311
;;   before "foobar" is highlighted.
312
 
313
;; TODO:
314
;; * make add-log-tcl-defun smarter.  should notice if we are in the
315
;;   middle of a defun, or between defuns.  should notice if point is
316
;;   on first line of defun (or maybe even in comments before defun).
317
;; * Allow continuation lines to be indented under the first argument
318
;;   of the preceeding line, like this:
319
;;      [list something \
320
;;            something-else]
321
;; * There is a request that indentation work like this:
322
;;        button .fred -label Fred \
323
;;                     -command {puts fred}
324
;; * Should have tcl-complete-symbol that queries the inferior process.
325
;; * Should have describe-symbol that works by sending the magic
326
;;   command to a tclX process.
327
;; * Need C-x C-e binding (tcl-eval-last-exp).
328
;; * Write indent-region function that is faster than indenting each
329
;;   line individually.
330
;; * tcl-figure-type should stop at "beginning of line" (only ws
331
;;   before point, and no "\" on previous line).  (see tcl-real-command-p).
332
;; * overrides some comint keybindings; fix.
333
;; * Trailing \ will eat blank lines.  Should deal with this.
334
;;   (this would help catch some potential bugs).
335
;; * Inferior should display in half the screen, not the whole screen.
336
;; * Indentation should deal with "switch".
337
;; * Consider writing code to find help files automatically (for
338
;;   common cases).
339
;; * `#' shouldn't insert `\#' when point is in string.
340
 
341
 
342
 
343
;;; Code:
344
 
345
;; I sure wish Emacs had a package that made it easy to extract this
346
;; sort of information.
347
(defconst tcl-using-emacs-19 (string-match "19\\." emacs-version)
348
  "Nil unless using Emacs 19 (XEmacs or FSF).")
349
 
350
;; FIXME this will break on Emacs 19.100.
351
(defconst tcl-using-emacs-19-23
352
  (string-match "19\\.\\(2[3-9]\\|[3-9][0-9]\\)" emacs-version)
353
  "Nil unless using Emacs 19-23 or later.")
354
 
355
(defconst tcl-using-xemacs-19 (string-match "XEmacs" emacs-version)
356
  "Nil unless using XEmacs).")
357
 
358
(require 'comint)
359
 
360
;; When compiling under GNU Emacs, load imenu during compilation.  If
361
;; you have 19.22 or earlier, comment this out, or get imenu.
362
(and (fboundp 'eval-when-compile)
363
     (eval-when-compile
364
       (if (and (string-match "19\\." emacs-version)
365
                (not (string-match "XEmacs" emacs-version)))
366
           (require 'imenu))
367
       ()))
368
 
369
(defconst tcl-version "1.49")
370
(defconst tcl-maintainer "Tom Tromey <tromey@drip.colorado.edu>")
371
 
372
;;
373
;; User variables.
374
;;
375
 
376
(defvar tcl-indent-level 4
377
  "*Indentation of Tcl statements with respect to containing block.")
378
 
379
(defvar tcl-continued-indent-level 4
380
  "*Indentation of continuation line relative to first line of command.")
381
 
382
(defvar tcl-auto-newline nil
383
  "*Non-nil means automatically newline before and after braces
384
inserted in Tcl code.")
385
 
386
(defvar tcl-tab-always-indent t
387
  "*Control effect of TAB key.
388
If t (the default), always indent current line.
389
If nil and point is not in the indentation area at the beginning of
390
the line, a TAB is inserted.
391
Other values cause the first possible action from the following list
392
to take place:
393
 
394
  1. Move from beginning of line to correct indentation.
395
  2. Delete an empty comment.
396
  3. Move forward to start of comment, indenting if necessary.
397
  4. Move forward to end of line, indenting if necessary.
398
  5. Create an empty comment.
399
  6. Move backward to start of comment, indenting if necessary.")
400
 
401
(defvar tcl-use-hairy-comment-detector t
402
  "*If not `nil', the the more complicated, but slower, comment
403
detecting function is used.  This variable is only used in GNU Emacs
404
19 (the fast function is always used elsewhere).")
405
 
406
(defvar tcl-electric-hash-style 'smart
407
  "*Style of electric hash insertion to use.
408
Possible values are 'backslash, meaning that `\\' quoting should be
409
done; 'quote, meaning that `\"' quoting should be done; 'smart,
410
meaning that the choice between 'backslash and 'quote should be
411
made depending on the number of hashes inserted; or nil, meaning that
412
no quoting should be done.  Any other value for this variable is
413
taken to mean 'smart.  The default is 'smart.")
414
 
415
(defvar tcl-help-directory-list nil
416
  "*List of topmost directories containing TclX help files")
417
 
418
(defvar tcl-use-smart-word-finder t
419
  "*If not nil, use a better way of finding the current word when
420
looking up help on a Tcl command.")
421
 
422
(defvar tcl-application "wish"
423
  "*Name of Tcl application to run in inferior Tcl mode.")
424
 
425
(defvar tcl-command-switches nil
426
  "*Switches to supply to `tcl-application'.")
427
 
428
(defvar tcl-prompt-regexp "^\\(% \\|\\)"
429
  "*If not nil, a regexp that will match the prompt in the inferior process.
430
If nil, the prompt is the name of the application with \">\" appended.
431
 
432
The default is \"^\\(% \\|\\)\", which will match the default primary
433
and secondary prompts for tclsh and wish.")
434
 
435
(defvar inferior-tcl-source-command "source %s\n"
436
  "*Format-string for building a Tcl command to load a file.
437
This format string should use `%s' to substitute a file name
438
and should result in a Tcl expression that will command the
439
inferior Tcl to load that file.  The filename will be appropriately
440
quoted for Tcl.")
441
 
442
;;
443
;; Keymaps, abbrevs, syntax tables.
444
;;
445
 
446
(defvar tcl-mode-abbrev-table nil
447
  "Abbrev table in use in Tcl-mode buffers.")
448
(if tcl-mode-abbrev-table
449
    ()
450
  (define-abbrev-table 'tcl-mode-abbrev-table ()))
451
 
452
(defvar tcl-mode-map ()
453
  "Keymap used in Tcl mode.")
454
 
455
(defvar tcl-mode-syntax-table nil
456
  "Syntax table in use in Tcl-mode buffers.")
457
(if tcl-mode-syntax-table
458
    ()
459
  (setq tcl-mode-syntax-table (make-syntax-table))
460
  (modify-syntax-entry ?%  "_" tcl-mode-syntax-table)
461
  (modify-syntax-entry ?@  "_" tcl-mode-syntax-table)
462
  (modify-syntax-entry ?&  "_" tcl-mode-syntax-table)
463
  (modify-syntax-entry ?*  "_" tcl-mode-syntax-table)
464
  (modify-syntax-entry ?+  "_" tcl-mode-syntax-table)
465
  (modify-syntax-entry ?-  "_" tcl-mode-syntax-table)
466
  (modify-syntax-entry ?.  "_" tcl-mode-syntax-table)
467
  (modify-syntax-entry ?:  "_" tcl-mode-syntax-table)
468
  (modify-syntax-entry ?!  "_" tcl-mode-syntax-table)
469
  (modify-syntax-entry ?$  "_" tcl-mode-syntax-table) ; FIXME use "'"?
470
  (modify-syntax-entry ?/  "_" tcl-mode-syntax-table)
471
  (modify-syntax-entry ?~  "_" tcl-mode-syntax-table)
472
  (modify-syntax-entry ?<  "_" tcl-mode-syntax-table)
473
  (modify-syntax-entry ?=  "_" tcl-mode-syntax-table)
474
  (modify-syntax-entry ?>  "_" tcl-mode-syntax-table)
475
  (modify-syntax-entry ?|  "_" tcl-mode-syntax-table)
476
  (modify-syntax-entry ?\(  "()" tcl-mode-syntax-table)
477
  (modify-syntax-entry ?\)  ")(" tcl-mode-syntax-table)
478
  (modify-syntax-entry ?\;  "." tcl-mode-syntax-table)
479
  (modify-syntax-entry ?\n ">   " tcl-mode-syntax-table)
480
  (modify-syntax-entry ?\f ">   " tcl-mode-syntax-table)
481
  (modify-syntax-entry ?# "<   " tcl-mode-syntax-table))
482
 
483
(defvar inferior-tcl-mode-map nil
484
  "Keymap used in Inferior Tcl mode.")
485
 
486
;; XEmacs menu.
487
(defvar tcl-xemacs-menu
488
  '(["Beginning of function" tcl-beginning-of-defun t]
489
    ["End of function" tcl-end-of-defun t]
490
    ["Mark function" tcl-mark-defun t]
491
    ["Indent region" indent-region (tcl-mark)]
492
    ["Comment region" comment-region (tcl-mark)]
493
    ["Uncomment region" tcl-uncomment-region (tcl-mark)]
494
    "----"
495
    ["Show Tcl process buffer" inferior-tcl t]
496
    ["Send function to Tcl process" tcl-eval-defun
497
     (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))]
498
    ["Send region to Tcl process" tcl-eval-region
499
     (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))]
500
    ["Send file to Tcl process" tcl-load-file
501
     (and inferior-tcl-buffer (get-buffer inferior-tcl-buffer))]
502
    ["Restart Tcl process with file" tcl-restart-with-file t]
503
    "----"
504
    ["Tcl help" tcl-help-on-word tcl-help-directory-list]
505
    ["Send bug report" tcl-submit-bug-report t])
506
  "XEmacs menu for Tcl mode.")
507
 
508
;; GNU Emacs does menus via keymaps.  Do it in a function in case we
509
;; later decide to add it to inferior Tcl mode as well.
510
(defun tcl-add-fsf-menu (map)
511
  (define-key map [menu-bar] (make-sparse-keymap))
512
  ;; This fails in Emacs 19.22 and earlier.
513
  (require 'lmenu)
514
  (let ((menu (make-lucid-menu-keymap "Tcl" tcl-xemacs-menu)))
515
    (define-key map [menu-bar tcl] (cons "Tcl" menu))
516
    ;; The following is intended to compute the key sequence
517
    ;; information for the menu.  It doesn't work.
518
    (x-popup-menu nil menu)))
519
 
520
(defun tcl-fill-mode-map ()
521
  (define-key tcl-mode-map "{" 'tcl-electric-char)
522
  (define-key tcl-mode-map "}" 'tcl-electric-brace)
523
  (define-key tcl-mode-map "[" 'tcl-electric-char)
524
  (define-key tcl-mode-map "]" 'tcl-electric-char)
525
  (define-key tcl-mode-map ";" 'tcl-electric-char)
526
  (define-key tcl-mode-map "#" 'tcl-electric-hash)
527
  ;; FIXME.
528
  (define-key tcl-mode-map "\e\C-a" 'tcl-beginning-of-defun)
529
  ;; FIXME.
530
  (define-key tcl-mode-map "\e\C-e" 'tcl-end-of-defun)
531
  ;; FIXME.
532
  (define-key tcl-mode-map "\e\C-h" 'tcl-mark-defun)
533
  (define-key tcl-mode-map "\e\C-q" 'indent-tcl-exp)
534
  (define-key tcl-mode-map "\177" 'backward-delete-char-untabify)
535
  (define-key tcl-mode-map "\t" 'tcl-indent-command)
536
  (define-key tcl-mode-map "\M-;" 'tcl-indent-for-comment)
537
  (define-key tcl-mode-map "\M-\C-x" 'tcl-eval-defun)
538
  (define-key tcl-mode-map "\C-c\C-b" 'tcl-submit-bug-report)
539
  (and (fboundp 'comment-region)
540
       (define-key tcl-mode-map "\C-c\C-c" 'comment-region))
541
  (define-key tcl-mode-map "\C-c\C-i" 'tcl-help-on-word)
542
  (define-key tcl-mode-map "\C-c\C-v" 'tcl-eval-defun)
543
  (define-key tcl-mode-map "\C-c\C-f" 'tcl-load-file)
544
  (define-key tcl-mode-map "\C-c\C-t" 'inferior-tcl)
545
  (define-key tcl-mode-map "\C-c\C-x" 'tcl-eval-region)
546
  (define-key tcl-mode-map "\C-c\C-s" 'switch-to-tcl)
547
 
548
  ;; Make menus.
549
  (if (and tcl-using-emacs-19 (not tcl-using-xemacs-19))
550
      (progn
551
        (tcl-add-fsf-menu tcl-mode-map))))
552
 
553
(defun tcl-fill-inferior-map ()
554
  (define-key inferior-tcl-mode-map "\t" 'comint-dynamic-complete)
555
  (define-key inferior-tcl-mode-map "\M-?"
556
    'comint-dynamic-list-filename-completions)
557
  (define-key inferior-tcl-mode-map "\e\C-a" 'tcl-beginning-of-defun)
558
  (define-key inferior-tcl-mode-map "\e\C-e" 'tcl-end-of-defun)
559
  (define-key inferior-tcl-mode-map "\177" 'backward-delete-char-untabify)
560
  (define-key inferior-tcl-mode-map "\M-\C-x" 'tcl-eval-defun)
561
  (define-key inferior-tcl-mode-map "\C-c\C-b" 'tcl-submit-bug-report)
562
  (define-key inferior-tcl-mode-map "\C-c\C-i" 'tcl-help-on-word)
563
  (define-key inferior-tcl-mode-map "\C-c\C-v" 'tcl-eval-defun)
564
  (define-key inferior-tcl-mode-map "\C-c\C-f" 'tcl-load-file)
565
  (define-key inferior-tcl-mode-map "\C-c\C-t" 'inferior-tcl)
566
  (define-key inferior-tcl-mode-map "\C-c\C-x" 'tcl-eval-region)
567
  (define-key inferior-tcl-mode-map "\C-c\C-s" 'switch-to-tcl))
568
 
569
(if tcl-mode-map
570
    ()
571
  (setq tcl-mode-map (make-sparse-keymap))
572
  (tcl-fill-mode-map))
573
 
574
(if inferior-tcl-mode-map
575
    ()
576
  ;; FIXME Use keymap inheritance here?  FIXME we override comint
577
  ;; keybindings here.  Maybe someone has a better set?
578
  (setq inferior-tcl-mode-map (copy-keymap comint-mode-map))
579
  (tcl-fill-inferior-map))
580
 
581
 
582
(defvar inferior-tcl-buffer nil
583
  "*The current inferior-tcl process buffer.
584
 
585
MULTIPLE PROCESS SUPPORT
586
===========================================================================
587
To run multiple Tcl processes, you start the first up with
588
\\[inferior-tcl].  It will be in a buffer named `*inferior-tcl*'.
589
Rename this buffer with \\[rename-buffer].  You may now start up a new
590
process with another \\[inferior-tcl].  It will be in a new buffer,
591
named `*inferior-tcl*'.  You can switch between the different process
592
buffers with \\[switch-to-buffer].
593
 
594
Commands that send text from source buffers to Tcl processes -- like
595
`tcl-eval-defun' or `tcl-load-file' -- have to choose a process to
596
send to, when you have more than one Tcl process around.  This is
597
determined by the global variable `inferior-tcl-buffer'.  Suppose you
598
have three inferior Lisps running:
599
    Buffer              Process
600
    foo                 inferior-tcl
601
    bar                 inferior-tcl<2>
602
    *inferior-tcl*      inferior-tcl<3>
603
If you do a \\[tcl-eval-defun] command on some Lisp source code, what
604
process do you send it to?
605
 
606
- If you're in a process buffer (foo, bar, or *inferior-tcl*),
607
  you send it to that process.
608
- If you're in some other buffer (e.g., a source file), you
609
  send it to the process attached to buffer `inferior-tcl-buffer'.
610
This process selection is performed by function `inferior-tcl-proc'.
611
 
612
Whenever \\[inferior-tcl] fires up a new process, it resets
613
`inferior-tcl-buffer' to be the new process's buffer.  If you only run
614
one process, this does the right thing.  If you run multiple
615
processes, you can change `inferior-tcl-buffer' to another process
616
buffer with \\[set-variable].")
617
 
618
;;
619
;; Hooks and other customization.
620
;;
621
 
622
(defvar tcl-mode-hook nil
623
  "Hook run on entry to Tcl mode.
624
 
625
Several functions exist which are useful to run from your
626
`tcl-mode-hook' (see each function's documentation for more
627
information):
628
 
629
  tcl-guess-application
630
    Guesses a default setting for `tcl-application' based on any
631
    \"#!\" line at the top of the file.
632
  tcl-hashify-buffer
633
    Quotes all \"#\" characters that don't correspond to actual
634
    Tcl comments.  (Useful when editing code not originally created
635
    with this mode).
636
  tcl-auto-fill-mode
637
    Auto-filling of Tcl comments.
638
 
639
Emacs 19 users can add functions to the hook with `add-hook':
640
 
641
   (add-hook 'tcl-mode-hook 'tcl-guess-application)
642
 
643
Emacs 18 users must use `setq':
644
 
645
   (setq tcl-mode-hook (cons 'tcl-guess-application tcl-mode-hook))")
646
 
647
 
648
(defvar inferior-tcl-mode-hook nil
649
  "Hook for customizing Inferior Tcl mode.")
650
 
651
(defvar tcl-proc-list
652
  '("proc" "method" "itcl_class")
653
  "List of commands whose first argument defines something.
654
This exists because some people (eg, me) use \"defvar\" et al.
655
Call `tcl-set-proc-regexp' and `tcl-set-font-lock-keywords'
656
after changing this list.")
657
 
658
(defvar tcl-proc-regexp nil
659
  "Regexp to use when matching proc headers.")
660
 
661
(defvar tcl-typeword-list
662
  '("global" "upvar" "inherit" "public" "protected" "common")
663
  "List of Tcl keywords denoting \"type\".  Used only for highlighting.
664
Call `tcl-set-font-lock-keywords' after changing this list.")
665
 
666
;; Generally I've picked control operators to be keywords.
667
(defvar tcl-keyword-list
668
  '("if" "then" "else" "elseif" "for" "foreach" "break" "continue" "while"
669
    "eval" "case" "in" "switch" "default" "exit" "error" "proc" "return"
670
    "uplevel" "constructor" "destructor" "itcl_class" "loop" "for_array_keys"
671
    "for_recursive_glob" "for_file")
672
  "List of Tcl keywords.  Used only for highlighting.
673
Default list includes some TclX keywords.
674
Call `tcl-set-font-lock-keywords' after changing this list.")
675
 
676
(defvar tcl-font-lock-keywords nil
677
  "Keywords to highlight for Tcl.  See variable `font-lock-keywords'.
678
This variable is generally set from `tcl-proc-regexp',
679
`tcl-typeword-list', and `tcl-keyword-list' by the function
680
`tcl-set-font-lock-keywords'.")
681
 
682
;; FIXME need some way to recognize variables because array refs look
683
;; like 2 sexps.
684
(defvar tcl-type-alist
685
  '(
686
    ("proc" nil tcl-expr tcl-commands)
687
    ("method" nil tcl-expr tcl-commands)
688
    ("destructor" tcl-commands)
689
    ("constructor" tcl-commands)
690
    ("expr" tcl-expr)
691
    ("catch" tcl-commands)
692
    ("if" tcl-expr "then" tcl-commands)
693
    ("elseif" tcl-expr "then" tcl-commands)
694
    ("elseif" tcl-expr tcl-commands)
695
    ("if" tcl-expr tcl-commands)
696
    ("while" tcl-expr tcl-commands)
697
    ("for" tcl-commands tcl-expr tcl-commands tcl-commands)
698
    ("foreach" nil nil tcl-commands)
699
    ("for_file" nil nil tcl-commands)
700
    ("for_array_keys" nil nil tcl-commands)
701
    ("for_recursive_glob" nil nil nil tcl-commands)
702
    ;; Loop handling is not perfect, because the third argument can be
703
    ;; either a command or an expr, and there is no real way to look
704
    ;; forward.
705
    ("loop" nil tcl-expr tcl-expr tcl-commands)
706
    ("loop" nil tcl-expr tcl-commands)
707
    )
708
  "Alist that controls indentation.
709
\(Actually, this really only controls what happens on continuation lines).
710
Each entry looks like `(KEYWORD TYPE ...)'.
711
Each type entry describes a sexp after the keyword, and can be one of:
712
* nil, meaning that this sexp has no particular type.
713
* tcl-expr, meaning that this sexp is an arithmetic expression.
714
* tcl-commands, meaning that this sexp holds Tcl commands.
715
* a string, which must exactly match the string at the corresponding
716
  position for a match to be made.
717
 
718
For example, the entry for the \"loop\" command is:
719
 
720
   (\"loop\" nil tcl-expr tcl-commands)
721
 
722
This means that the \"loop\" command has three arguments.  The first
723
argument is ignored (for indentation purposes).  The second argument
724
is a Tcl expression, and the last argument is Tcl commands.")
725
 
726
(defvar tcl-explain-indentation nil
727
  "If not `nil', debugging message will be printed during indentation.")
728
 
729
 
730
 
731
;;
732
;; Work around differences between various versions of Emacs.
733
;;
734
 
735
;; We use this because Lemacs 19.9 has what we need.
736
(defconst tcl-pps-has-arg-6
737
  (or tcl-using-emacs-19
738
      (and tcl-using-xemacs-19
739
           (condition-case nil
740
               (progn
741
                 (parse-partial-sexp (point) (point) nil nil nil t)
742
                 t)
743
             (error nil))))
744
  "t if using an emacs which supports sixth (\"commentstop\") argument
745
to parse-partial-sexp.")
746
 
747
;; Its pretty bogus to have to do this, but there is no easier way to
748
;; say "match not syntax-1 and not syntax-2".  Too bad you can't put
749
;; \s in [...].  This sickness is used in Emacs 19 to match a defun
750
;; starter.  (It is used for this in v18 as well).
751
;;(defconst tcl-omit-ws-regexp
752
;;  (concat "^\\(\\s"
753
;;        (mapconcat 'char-to-string "w_.()\"\\$'/" "\\|\\s")
754
;;        "\\)\\S(*")
755
;;  "Regular expression that matches everything except space, comment
756
;;starter, and comment ender syntax codes.")
757
 
758
;; FIXME?  Instead of using the hairy regexp above, we just use a
759
;; simple one.
760
;;(defconst tcl-omit-ws-regexp "^[^] \t\n#}]\\S(*"
761
;;  "Regular expression used in locating function definitions.")
762
 
763
;; Here's another stab.  I think this one actually works.  Now the
764
;; problem seems to be that there is a bug in Emacs 19.22 where
765
;; end-of-defun doesn't really use the brace matching the one that
766
;; trails defun-prompt-regexp.
767
(defconst tcl-omit-ws-regexp "^[^ \t\n#}][^\n}]+}*[ \t]+")
768
 
769
(defun tcl-internal-beginning-of-defun (&optional arg)
770
  "Move backward to next beginning-of-defun.
771
With argument, do this that many times.
772
Returns t unless search stops due to end of buffer."
773
  (interactive "p")
774
  (if (or (null arg) (= arg 0))
775
      (setq arg 1))
776
  (let (success)
777
    (while (progn
778
             (setq arg (1- arg))
779
             (and (>= arg 0)
780
                  (setq success
781
                        (re-search-backward tcl-omit-ws-regexp nil 'move 1))))
782
      (while (and (looking-at "[]#}]")
783
                  (setq success
784
                        (re-search-backward tcl-omit-ws-regexp nil 'move 1)))))
785
    (beginning-of-line)
786
    (not (null success))))
787
 
788
(defun tcl-internal-end-of-defun (&optional arg)
789
  "Move forward to next end of defun.
790
An end of a defun is found by moving forward from the beginning of one."
791
  (interactive "p")
792
  (if (or (null arg) (= arg 0)) (setq arg 1))
793
  (let ((start (point)))
794
    ;; Was forward-char.  I think this works a little better.
795
    (forward-line)
796
    (tcl-beginning-of-defun)
797
    (while (> arg 0)
798
      (while (and (re-search-forward tcl-omit-ws-regexp nil 'move 1)
799
                  (progn (beginning-of-line) t)
800
                  (looking-at "[]#}]")
801
                  (progn (forward-line) t)))
802
      (let ((next-line (save-excursion
803
                         (forward-line)
804
                         (point))))
805
        (while (< (point) next-line)
806
          (forward-sexp)))
807
      (forward-line)
808
      (if (> (point) start) (setq arg (1- arg))))))
809
 
810
;; In Emacs 19, we can use begining-of-defun as long as we set up a
811
;; certain regexp.  In Emacs 18, we need our own function.
812
(fset 'tcl-beginning-of-defun
813
      (if tcl-using-emacs-19
814
          'beginning-of-defun
815
        'tcl-internal-beginning-of-defun))
816
 
817
;; Ditto end-of-defun.
818
(fset 'tcl-end-of-defun
819
      (if (and tcl-using-emacs-19 (not tcl-using-xemacs-19))
820
          'end-of-defun
821
        'tcl-internal-end-of-defun))
822
 
823
;; Internal mark-defun that is used for losing Emacsen.
824
(defun tcl-internal-mark-defun ()
825
  "Put mark at end of Tcl function, point at beginning."
826
  (interactive)
827
  (push-mark (point))
828
  (tcl-end-of-defun)
829
  (if tcl-using-emacs-19
830
      (push-mark (point) nil t)
831
    (push-mark (point)))
832
  (tcl-beginning-of-defun)
833
  (backward-paragraph))
834
 
835
;; In GNU Emacs 19-23 and later, mark-defun works as advertised.  I
836
;; don't know about XEmacs, so for now it and Emacs 18 just lose.
837
(fset 'tcl-mark-defun
838
      (if tcl-using-emacs-19-23
839
          'mark-defun
840
        'tcl-internal-mark-defun))
841
 
842
;; In GNU Emacs 19, mark takes an additional "force" argument.  I
843
;; don't know about XEmacs, so I'm just assuming it is the same.
844
;; Emacs 18 doesn't have this argument.
845
(defun tcl-mark ()
846
  "Return mark, or nil if none."
847
  (if tcl-using-emacs-19
848
      (mark t)
849
    (mark)))
850
 
851
 
852
 
853
;;
854
;; Some helper functions.
855
;;
856
 
857
(defun tcl-set-proc-regexp ()
858
  "Set `tcl-proc-regexp' from variable `tcl-proc-list'."
859
  (setq tcl-proc-regexp (concat "^\\s-*\\("
860
                                (mapconcat 'identity tcl-proc-list "\\|")
861
                                "\\)[ \t]+")))
862
 
863
(defun tcl-set-font-lock-keywords ()
864
  "Set `tcl-font-lock-keywords'.
865
Uses variables `tcl-proc-regexp' and `tcl-keyword-list'."
866
  (setq tcl-font-lock-keywords
867
        (list
868
         ;; Names of functions (and other "defining things").
869
         (list (concat tcl-proc-regexp "\\([^ \t\n]+\\)")
870
               2 'font-lock-function-name-face)
871
 
872
         ;; Names of type-defining things.
873
         (list (concat "\\(\\s-\\|^\\)\\("
874
                       ;; FIXME Use 'regexp-quote?
875
                       (mapconcat 'identity tcl-typeword-list "\\|")
876
                       "\\)\\(\\s-\\|$\\)")
877
               2 'font-lock-type-face)
878
 
879
         ;; Keywords.  Only recognized if surrounded by whitespace.
880
         ;; FIXME consider using "not word or symbol", not
881
         ;; "whitespace".
882
         (cons (concat "\\(\\s-\\|^\\)\\("
883
                       ;; FIXME Use regexp-quote?
884
                       (mapconcat 'identity tcl-keyword-list "\\|")
885
                       "\\)\\(\\s-\\|$\\)")
886
               2)
887
         )))
888
 
889
(if tcl-proc-regexp
890
    ()
891
  (tcl-set-proc-regexp))
892
 
893
(if tcl-font-lock-keywords
894
    ()
895
  (tcl-set-font-lock-keywords))
896
 
897
 
898
 
899
;;
900
;; The mode itself.
901
;;
902
 
903
;;;###autoload
904
(defun tcl-mode ()
905
  "Major mode for editing Tcl code.
906
Expression and list commands understand all Tcl brackets.
907
Tab indents for Tcl code.
908
Paragraphs are separated by blank lines only.
909
Delete converts tabs to spaces as it moves back.
910
 
911
Variables controlling indentation style:
912
  tcl-indent-level
913
    Indentation of Tcl statements within surrounding block.
914
  tcl-continued-indent-level
915
    Indentation of continuation line relative to first line of command.
916
 
917
Variables controlling user interaction with mode (see variable
918
documentation for details):
919
  tcl-tab-always-indent
920
    Controls action of TAB key.
921
  tcl-auto-newline
922
    Non-nil means automatically newline before and after braces, brackets,
923
    and semicolons inserted in Tcl code.
924
  tcl-electric-hash-style
925
    Controls action of `#' key.
926
  tcl-use-hairy-comment-detector
927
    If t, use more complicated, but slower, comment detector.
928
    This variable is only used in GNU Emacs 19.
929
  tcl-use-smart-word-finder
930
    If not nil, use a smarter, Tcl-specific way to find the current
931
    word when looking up help on a Tcl command.
932
 
933
Turning on Tcl mode calls the value of the variable `tcl-mode-hook'
934
with no args, if that value is non-nil.  Read the documentation for
935
`tcl-mode-hook' to see what kinds of interesting hook functions
936
already exist.
937
 
938
Commands:
939
\\{tcl-mode-map}"
940
  (interactive)
941
  (kill-all-local-variables)
942
  (use-local-map tcl-mode-map)
943
  (setq major-mode 'tcl-mode)
944
  (setq mode-name "Tcl")
945
  (setq local-abbrev-table tcl-mode-abbrev-table)
946
  (set-syntax-table tcl-mode-syntax-table)
947
 
948
  (make-local-variable 'paragraph-start)
949
  (make-local-variable 'paragraph-separate)
950
  (if (and tcl-using-emacs-19-23
951
           (>= emacs-minor-version 29))
952
      (progn
953
        ;; In Emacs 19.29, you aren't supposed to start these with a
954
        ;; ^.
955
        (setq paragraph-start "$\\|")
956
        (setq paragraph-separate paragraph-start))
957
    (setq paragraph-start (concat "^$\\|" page-delimiter))
958
    (setq paragraph-separate paragraph-start))
959
  (make-local-variable 'paragraph-ignore-fill-prefix)
960
  (setq paragraph-ignore-fill-prefix t)
961
  (make-local-variable 'fill-paragraph-function)
962
  (setq fill-paragraph-function 'tcl-do-fill-paragraph)
963
 
964
  (make-local-variable 'indent-line-function)
965
  (setq indent-line-function 'tcl-indent-line)
966
  ;; Tcl doesn't require a final newline.
967
  ;; (make-local-variable 'require-final-newline)
968
  ;; (setq require-final-newline t)
969
 
970
  (make-local-variable 'comment-start)
971
  (setq comment-start "# ")
972
  (make-local-variable 'comment-start-skip)
973
  (setq comment-start-skip "#+ *")
974
  (make-local-variable 'comment-column)
975
  (setq comment-column 40)
976
  (make-local-variable 'comment-end)
977
  (setq comment-end "")
978
 
979
  (make-local-variable 'outline-regexp)
980
  (setq outline-regexp "[^\n\^M]")
981
  (make-local-variable 'outline-level)
982
  (setq outline-level 'tcl-outline-level)
983
 
984
  (make-local-variable 'font-lock-keywords)
985
  (setq font-lock-keywords tcl-font-lock-keywords)
986
 
987
  ;; The following only really makes sense under GNU Emacs 19.
988
  (make-local-variable 'imenu-create-index-function)
989
  (setq imenu-create-index-function 'tcl-imenu-create-index-function)
990
  (make-local-variable 'parse-sexp-ignore-comments)
991
 
992
  ;; Settings for new dabbrev code.
993
  (make-local-variable 'dabbrev-case-fold-search)
994
  (setq dabbrev-case-fold-search nil)
995
  (make-local-variable 'dabbrev-case-replace)
996
  (setq dabbrev-case-replace nil)
997
  (make-local-variable 'dabbrev-abbrev-skip-leading-regexp)
998
  (setq dabbrev-abbrev-skip-leading-regexp "[$!]")
999
  (make-local-variable 'dabbrev-abbrev-char-regexp)
1000
  (setq dabbrev-abbrev-char-regexp "\\sw\\|\\s_")
1001
 
1002
  (if tcl-using-emacs-19
1003
      (progn
1004
        ;; This can only be set to t in Emacs 19 and XEmacs.
1005
        ;; Emacs 18 and Epoch lose.
1006
        (setq parse-sexp-ignore-comments t)
1007
        ;; XEmacs has defun-prompt-regexp, but I don't believe
1008
        ;; that it works for end-of-defun -- only for
1009
        ;; beginning-of-defun.
1010
        (make-local-variable 'defun-prompt-regexp)
1011
        (setq defun-prompt-regexp tcl-omit-ws-regexp)
1012
        ;; The following doesn't work in Lucid Emacs 19.6, but maybe
1013
        ;; it will appear in later versions.
1014
        (make-local-variable 'add-log-current-defun-function)
1015
        (setq add-log-current-defun-function 'add-log-tcl-defun))
1016
    (setq parse-sexp-ignore-comments nil))
1017
 
1018
  ;; Put Tcl menu into menubar for XEmacs.  This happens
1019
  ;; automatically for GNU Emacs.
1020
  (if (and tcl-using-xemacs-19
1021
           current-menubar
1022
           (not (assoc "Tcl" current-menubar)))
1023
      (progn
1024
        (set-buffer-menubar (copy-sequence current-menubar))
1025
        (add-menu nil "Tcl" tcl-xemacs-menu)))
1026
  ;; Append Tcl menu to popup menu for XEmacs.
1027
  (if (and tcl-using-xemacs-19 (boundp 'mode-popup-menu))
1028
      (setq mode-popup-menu
1029
            (cons (concat mode-name " Mode Commands") tcl-xemacs-menu)))
1030
 
1031
  ;; If hilit19 is loaded, add our stuff.
1032
  (if (featurep 'hilit19)
1033
      (tcl-hilit))
1034
 
1035
  (run-hooks 'tcl-mode-hook))
1036
 
1037
 
1038
 
1039
;; This is used for braces, brackets, and semi (except for closing
1040
;; braces, which are handled specially).
1041
(defun tcl-electric-char (arg)
1042
  "Insert character and correct line's indentation."
1043
  (interactive "p")
1044
  ;; Indent line first; this looks better if parens blink.
1045
  (tcl-indent-line)
1046
  (self-insert-command arg)
1047
  (if (and tcl-auto-newline (= last-command-char ?\;))
1048
      (progn
1049
        (newline)
1050
        (tcl-indent-line))))
1051
 
1052
;; This is used for closing braces.  If tcl-auto-newline is set, can
1053
;; insert a newline both before and after the brace, depending on
1054
;; context.  FIXME should this be configurable?  Does anyone use this?
1055
(defun tcl-electric-brace (arg)
1056
  "Insert character and correct line's indentation."
1057
  (interactive "p")
1058
  ;; If auto-newlining and there is stuff on the same line, insert a
1059
  ;; newline first.
1060
  (if tcl-auto-newline
1061
      (progn
1062
        (if (save-excursion
1063
              (skip-chars-backward " \t")
1064
              (bolp))
1065
            ()
1066
          (tcl-indent-line)
1067
          (newline))
1068
        ;; In auto-newline case, must insert a newline after each
1069
        ;; brace.  So an explicit loop is needed.
1070
        (while (> arg 0)
1071
          (insert last-command-char)
1072
          (tcl-indent-line)
1073
          (newline)
1074
          (setq arg (1- arg))))
1075
    (self-insert-command arg))
1076
  (tcl-indent-line))
1077
 
1078
 
1079
 
1080
(defun tcl-indent-command (&optional arg)
1081
  "Indent current line as Tcl code, or in some cases insert a tab character.
1082
If tcl-tab-always-indent is t (the default), always indent current line.
1083
If tcl-tab-always-indent is nil and point is not in the indentation
1084
area at the beginning of the line, a TAB is inserted.
1085
Other values of tcl-tab-always-indent cause the first possible action
1086
from the following list to take place:
1087
 
1088
  1. Move from beginning of line to correct indentation.
1089
  2. Delete an empty comment.
1090
  3. Move forward to start of comment, indenting if necessary.
1091
  4. Move forward to end of line, indenting if necessary.
1092
  5. Create an empty comment.
1093
  6. Move backward to start of comment, indenting if necessary."
1094
  (interactive "p")
1095
  (cond
1096
   ((not tcl-tab-always-indent)
1097
    ;; Indent if in indentation area, otherwise insert TAB.
1098
    (if (<= (current-column) (current-indentation))
1099
        (tcl-indent-line)
1100
      (self-insert-command arg)))
1101
   ((eq tcl-tab-always-indent t)
1102
    ;; Always indent.
1103
    (tcl-indent-line))
1104
   (t
1105
    ;; "Perl-mode" style TAB command.
1106
    (let* ((ipoint (point))
1107
           (eolpoint (progn
1108
                       (end-of-line)
1109
                       (point)))
1110
           (comment-p (tcl-in-comment)))
1111
      (cond
1112
       ((= ipoint (save-excursion
1113
                    (beginning-of-line)
1114
                    (point)))
1115
        (beginning-of-line)
1116
        (tcl-indent-line)
1117
        ;; If indenting didn't leave us in column 0, go to the
1118
        ;; indentation.  Otherwise leave point at end of line.  This
1119
        ;; is a hack.
1120
        (if (= (point) (save-excursion
1121
                         (beginning-of-line)
1122
                         (point)))
1123
            (end-of-line)
1124
          (back-to-indentation)))
1125
       ((and comment-p (looking-at "[ \t]*$"))
1126
        ;; Empty comment, so delete it.  We also delete any ";"
1127
        ;; characters at the end of the line.  I think this is
1128
        ;; friendlier, but I don't know how other people will feel.
1129
        (backward-char)
1130
        (skip-chars-backward " \t;")
1131
        (delete-region (point) eolpoint))
1132
       ((and comment-p (< ipoint (point)))
1133
        ;; Before comment, so skip to it.
1134
        (tcl-indent-line)
1135
        (indent-for-comment))
1136
       ((/= ipoint eolpoint)
1137
        ;; Go to end of line (since we're not there yet).
1138
        (goto-char eolpoint)
1139
        (tcl-indent-line))
1140
       ((not comment-p)
1141
        (tcl-indent-line)
1142
        (tcl-indent-for-comment))
1143
       (t
1144
        ;; Go to start of comment.  We don't leave point where it is
1145
        ;; because we want to skip comment-start-skip.
1146
        (tcl-indent-line)
1147
        (indent-for-comment)))))))
1148
 
1149
(defun tcl-indent-line ()
1150
  "Indent current line as Tcl code.
1151
Return the amount the indentation changed by."
1152
  (let ((indent (calculate-tcl-indent nil))
1153
        beg shift-amt
1154
        (case-fold-search nil)
1155
        (pos (- (point-max) (point))))
1156
    (beginning-of-line)
1157
    (setq beg (point))
1158
    (cond ((eq indent nil)
1159
           (setq indent (current-indentation)))
1160
          (t
1161
           (skip-chars-forward " \t")
1162
           (if (listp indent) (setq indent (car indent)))
1163
           (cond ((= (following-char) ?})
1164
                  (setq indent (- indent tcl-indent-level)))
1165
                 ((= (following-char) ?\])
1166
                  (setq indent (- indent 1))))))
1167
    (skip-chars-forward " \t")
1168
    (setq shift-amt (- indent (current-column)))
1169
    (if (zerop shift-amt)
1170
        (if (> (- (point-max) pos) (point))
1171
            (goto-char (- (point-max) pos)))
1172
      (delete-region beg (point))
1173
      (indent-to indent)
1174
      ;; If initial point was within line's indentation,
1175
      ;; position after the indentation.  Else stay at same point in text.
1176
      (if (> (- (point-max) pos) (point))
1177
          (goto-char (- (point-max) pos))))
1178
    shift-amt))
1179
 
1180
(defun tcl-figure-type ()
1181
  "Determine type of sexp at point.
1182
This is either 'tcl-expr, 'tcl-commands, or nil.  Puts point at start
1183
of sexp that indicates types.
1184
 
1185
See documentation for variable `tcl-type-alist' for more information."
1186
  (let ((count 0)
1187
        result
1188
        word-stack)
1189
    (while (and (< count 5)
1190
                (not result))
1191
      (condition-case nil
1192
          (progn
1193
            ;; FIXME should use "tcl-backward-sexp", which would skip
1194
            ;; over entire variables, etc.
1195
            (backward-sexp)
1196
            (if (looking-at "[a-zA-Z_]+")
1197
                (let ((list tcl-type-alist)
1198
                      entry)
1199
                  (setq word-stack (cons (tcl-word-no-props) word-stack))
1200
                  (while (and list (not result))
1201
                    (setq entry (car list))
1202
                    (setq list (cdr list))
1203
                    (let ((index 0))
1204
                      (while (and entry (<= index count))
1205
                        ;; Abort loop if string does not match word on
1206
                        ;; stack.
1207
                        (and (stringp (car entry))
1208
                             (not (string= (car entry)
1209
                                           (nth index word-stack)))
1210
                             (setq entry nil))
1211
                        (setq entry (cdr entry))
1212
                        (setq index (1+ index)))
1213
                      (and (> index count)
1214
                           (not (stringp (car entry)))
1215
                           (setq result (car entry)))
1216
                      )))
1217
              (setq word-stack (cons nil word-stack))))
1218
        (error nil))
1219
      (setq count (1+ count)))
1220
    (and tcl-explain-indentation
1221
         (message "Indentation type %s" result))
1222
    result))
1223
 
1224
(defun calculate-tcl-indent (&optional parse-start)
1225
  "Return appropriate indentation for current line as Tcl code.
1226
In usual case returns an integer: the column to indent to.
1227
Returns nil if line starts inside a string, t if in a comment."
1228
  (save-excursion
1229
    (beginning-of-line)
1230
    (let* ((indent-point (point))
1231
           (case-fold-search nil)
1232
           (continued-line
1233
            (save-excursion
1234
              (if (bobp)
1235
                  nil
1236
                (backward-char)
1237
                (= ?\\ (preceding-char)))))
1238
           (continued-indent-value (if continued-line
1239
                                       tcl-continued-indent-level
1240
                                     0))
1241
           state
1242
           containing-sexp
1243
           found-next-line)
1244
      (if parse-start
1245
          (goto-char parse-start)
1246
        (tcl-beginning-of-defun))
1247
      (while (< (point) indent-point)
1248
        (setq parse-start (point))
1249
        (setq state (parse-partial-sexp (point) indent-point 0))
1250
        (setq containing-sexp (car (cdr state))))
1251
      (cond ((or (nth 3 state) (nth 4 state))
1252
             ;; Inside comment or string.  Return nil or t if should
1253
             ;; not change this line
1254
             (nth 4 state))
1255
            ((null containing-sexp)
1256
             ;; Line is at top level.
1257
             continued-indent-value)
1258
            (t
1259
             ;; Set expr-p if we are looking at the expression part of
1260
             ;; an "if", "expr", etc statement.  Set commands-p if we
1261
             ;; are looking at the body part of an if, while, etc
1262
             ;; statement.  FIXME Should check for "for" loops here.
1263
             (goto-char containing-sexp)
1264
             (let* ((sexpr-type (tcl-figure-type))
1265
                    (expr-p (eq sexpr-type 'tcl-expr))
1266
                    (commands-p (eq sexpr-type 'tcl-commands))
1267
                    (expr-start (point)))
1268
               ;; Find the first statement in the block and indent
1269
               ;; like it.  The first statement in the block might be
1270
               ;; on the same line, so what we do is skip all
1271
               ;; "virtually blank" lines, looking for a non-blank
1272
               ;; one.  A line is virtually blank if it only contains
1273
               ;; a comment and whitespace.  FIXME continued comments
1274
               ;; aren't supported.  They are a wart on Tcl anyway.
1275
               ;; We do it this funky way because we want to know if
1276
               ;; we've found a statement on some line _after_ the
1277
               ;; line holding the sexp opener.
1278
               (goto-char containing-sexp)
1279
               (forward-char)
1280
               (if (and (< (point) indent-point)
1281
                        (looking-at "[ \t]*\\(#.*\\)?$"))
1282
                   (progn
1283
                     (forward-line)
1284
                     (while (and (< (point) indent-point)
1285
                                 (looking-at "[ \t]*\\(#.*\\)?$"))
1286
                       (setq found-next-line t)
1287
                       (forward-line))))
1288
               (if (or continued-line
1289
                       (/= (char-after containing-sexp) ?{)
1290
                       expr-p)
1291
                   (progn
1292
                     ;; Line is continuation line, or the sexp opener
1293
                     ;; is not a curly brace, or we are are looking at
1294
                     ;; an `expr' expression (which must be split
1295
                     ;; specially).  So indentation is column of first
1296
                     ;; good spot after sexp opener (with some added
1297
                     ;; in the continued-line case).  If there is no
1298
                     ;; nonempty line before the indentation point, we
1299
                     ;; use the column of the character after the sexp
1300
                     ;; opener.
1301
                     (if (>= (point) indent-point)
1302
                         (progn
1303
                           (goto-char containing-sexp)
1304
                           (forward-char))
1305
                       (skip-chars-forward " \t"))
1306
                     (+ (current-column) continued-indent-value))
1307
                 ;; After a curly brace, and not a continuation line.
1308
                 ;; So take indentation from first good line after
1309
                 ;; start of block, unless that line is on the same
1310
                 ;; line as the opening brace.  In this case use the
1311
                 ;; indentation of the opening brace's line, plus
1312
                 ;; another indent step.  If we are in the body part
1313
                 ;; of an "if" or "while" then the indentation is
1314
                 ;; taken from the line holding the start of the
1315
                 ;; statement.
1316
                 (if (and (< (point) indent-point)
1317
                          found-next-line)
1318
                     (current-indentation)
1319
                   (if commands-p
1320
                       (goto-char expr-start)
1321
                     (goto-char containing-sexp))
1322
                   (+ (current-indentation) tcl-indent-level)))))))))
1323
 
1324
 
1325
 
1326
(defun indent-tcl-exp ()
1327
  "Indent each line of the Tcl grouping following point."
1328
  (interactive)
1329
  (let ((indent-stack (list nil))
1330
        (contain-stack (list (point)))
1331
        (case-fold-search nil)
1332
        outer-loop-done inner-loop-done state ostate
1333
        this-indent last-sexp continued-line
1334
        (next-depth 0)
1335
        last-depth)
1336
    (save-excursion
1337
      (forward-sexp 1))
1338
    (save-excursion
1339
      (setq outer-loop-done nil)
1340
      (while (and (not (eobp)) (not outer-loop-done))
1341
        (setq last-depth next-depth)
1342
        ;; Compute how depth changes over this line
1343
        ;; plus enough other lines to get to one that
1344
        ;; does not end inside a comment or string.
1345
        ;; Meanwhile, do appropriate indentation on comment lines.
1346
        (setq inner-loop-done nil)
1347
        (while (and (not inner-loop-done)
1348
                    (not (and (eobp) (setq outer-loop-done t))))
1349
          (setq ostate state)
1350
          (setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
1351
                                          nil nil state))
1352
          (setq next-depth (car state))
1353
          (if (and (car (cdr (cdr state)))
1354
                   (>= (car (cdr (cdr state))) 0))
1355
              (setq last-sexp (car (cdr (cdr state)))))
1356
          (if (or (nth 4 ostate))
1357
              (tcl-indent-line))
1358
          (if (or (nth 3 state))
1359
              (forward-line 1)
1360
            (setq inner-loop-done t)))
1361
        (if (<= next-depth 0)
1362
            (setq outer-loop-done t))
1363
        (if outer-loop-done
1364
            nil
1365
          ;; If this line had ..))) (((.. in it, pop out of the levels
1366
          ;; that ended anywhere in this line, even if the final depth
1367
          ;; doesn't indicate that they ended.
1368
          (while (> last-depth (nth 6 state))
1369
            (setq indent-stack (cdr indent-stack)
1370
                  contain-stack (cdr contain-stack)
1371
                  last-depth (1- last-depth)))
1372
          (if (/= last-depth next-depth)
1373
              (setq last-sexp nil))
1374
          ;; Add levels for any parens that were started in this line.
1375
          (while (< last-depth next-depth)
1376
            (setq indent-stack (cons nil indent-stack)
1377
                  contain-stack (cons nil contain-stack)
1378
                  last-depth (1+ last-depth)))
1379
          (if (null (car contain-stack))
1380
              (setcar contain-stack
1381
                      (or (car (cdr state))
1382
                          (save-excursion
1383
                            (forward-sexp -1)
1384
                            (point)))))
1385
          (forward-line 1)
1386
          (setq continued-line
1387
                (save-excursion
1388
                  (backward-char)
1389
                  (= (preceding-char) ?\\)))
1390
          (skip-chars-forward " \t")
1391
          (if (eolp)
1392
              nil
1393
            (if (and (car indent-stack)
1394
                     (>= (car indent-stack) 0))
1395
                ;; Line is on an existing nesting level.
1396
                (setq this-indent (car indent-stack))
1397
              ;; Just started a new nesting level.
1398
              ;; Compute the standard indent for this level.
1399
              (let ((val (calculate-tcl-indent
1400
                          (if (car indent-stack)
1401
                              (- (car indent-stack))))))
1402
                (setcar indent-stack
1403
                        (setq this-indent val))
1404
                (setq continued-line nil)))
1405
            (cond ((not (numberp this-indent)))
1406
                  ((= (following-char) ?})
1407
                   (setq this-indent (- this-indent tcl-indent-level)))
1408
                  ((= (following-char) ?\])
1409
                   (setq this-indent (- this-indent 1))))
1410
            ;; Put chosen indentation into effect.
1411
            (or (null this-indent)
1412
                (= (current-column)
1413
                   (if continued-line
1414
                       (+ this-indent tcl-indent-level)
1415
                     this-indent))
1416
                (progn
1417
                  (delete-region (point) (progn (beginning-of-line) (point)))
1418
                  (indent-to
1419
                   (if continued-line
1420
                       (+ this-indent tcl-indent-level)
1421
                     this-indent)))))))))
1422
  )
1423
 
1424
 
1425
 
1426
;;
1427
;; Interfaces to other packages.
1428
;;
1429
 
1430
(defun tcl-imenu-create-index-function ()
1431
  "Generate alist of indices for imenu."
1432
  (let ((re (concat tcl-proc-regexp "\\([^ \t\n{]+\\)"))
1433
        alist prev-pos)
1434
    (goto-char (point-min))
1435
    (imenu-progress-message prev-pos 0)
1436
    (save-match-data
1437
      (while (re-search-forward re nil t)
1438
        (imenu-progress-message prev-pos)
1439
        ;; Position on start of proc name, not beginning of line.
1440
        (setq alist (cons
1441
                     (cons (buffer-substring (match-beginning 2) (match-end 2))
1442
                           (match-beginning 2))
1443
                     alist))))
1444
    (imenu-progress-message prev-pos 100)
1445
    (nreverse alist)))
1446
 
1447
;; FIXME Definition of function is very ad-hoc.  Should use
1448
;; tcl-beginning-of-defun.  Also has incestuous knowledge about the
1449
;; format of tcl-proc-regexp.
1450
(defun add-log-tcl-defun ()
1451
  "Return name of Tcl function point is in, or nil."
1452
  (save-excursion
1453
    (end-of-line)
1454
    (if (re-search-backward (concat tcl-proc-regexp "\\([^ \t\n{]+\\)") nil t)
1455
        (buffer-substring (match-beginning 2)
1456
                          (match-end 2)))))
1457
 
1458
(defun tcl-outline-level ()
1459
  (save-excursion
1460
    (skip-chars-forward " \t")
1461
    (current-column)))
1462
 
1463
 
1464
 
1465
;;
1466
;; Helper functions for inferior Tcl mode.
1467
;;
1468
 
1469
;; This exists to let us delete the prompt when commands are sent
1470
;; directly to the inferior Tcl.  See gud.el for an explanation of how
1471
;; it all works (I took it from there).  This stuff doesn't really
1472
;; work as well as I'd like it to.  But I don't believe there is
1473
;; anything useful that can be done.
1474
(defvar inferior-tcl-delete-prompt-marker nil)
1475
 
1476
(defun tcl-filter (proc string)
1477
  (let ((inhibit-quit t))
1478
    (save-excursion
1479
      (set-buffer (process-buffer proc))
1480
      (goto-char (process-mark proc))
1481
      ;; Delete prompt if requested.
1482
      (if (marker-buffer inferior-tcl-delete-prompt-marker)
1483
          (progn
1484
            (delete-region (point) inferior-tcl-delete-prompt-marker)
1485
            (set-marker inferior-tcl-delete-prompt-marker nil)))))
1486
  (if tcl-using-emacs-19
1487
      (comint-output-filter proc string)
1488
    (funcall comint-output-filter string)))
1489
 
1490
(defun tcl-send-string (proc string)
1491
  (save-excursion
1492
    (set-buffer (process-buffer proc))
1493
    (goto-char (process-mark proc))
1494
    (beginning-of-line)
1495
    (if (looking-at comint-prompt-regexp)
1496
        (set-marker inferior-tcl-delete-prompt-marker (point))))
1497
  (comint-send-string proc string))
1498
 
1499
(defun tcl-send-region (proc start end)
1500
  (save-excursion
1501
    (set-buffer (process-buffer proc))
1502
    (goto-char (process-mark proc))
1503
    (beginning-of-line)
1504
    (if (looking-at comint-prompt-regexp)
1505
        (set-marker inferior-tcl-delete-prompt-marker (point))))
1506
  (comint-send-region proc start end))
1507
 
1508
(defun switch-to-tcl (eob-p)
1509
  "Switch to inferior Tcl process buffer.
1510
With argument, positions cursor at end of buffer."
1511
  (interactive "P")
1512
  (if (get-buffer inferior-tcl-buffer)
1513
      (pop-to-buffer inferior-tcl-buffer)
1514
    (error "No current inferior Tcl buffer"))
1515
  (cond (eob-p
1516
         (push-mark)
1517
         (goto-char (point-max)))))
1518
 
1519
(defun inferior-tcl-proc ()
1520
  "Return current inferior Tcl process.
1521
See variable `inferior-tcl-buffer'."
1522
  (let ((proc (get-buffer-process (if (eq major-mode 'inferior-tcl-mode)
1523
                                      (current-buffer)
1524
                                    inferior-tcl-buffer))))
1525
    (or proc
1526
        (error "No Tcl process; see variable `inferior-tcl-buffer'"))))
1527
 
1528
(defun tcl-eval-region (start end &optional and-go)
1529
  "Send the current region to the inferior Tcl process.
1530
Prefix argument means switch to the Tcl buffer afterwards."
1531
  (interactive "r\nP")
1532
  (let ((proc (inferior-tcl-proc)))
1533
    (tcl-send-region proc start end)
1534
    (tcl-send-string proc "\n")
1535
    (if and-go (switch-to-tcl t))))
1536
 
1537
(defun tcl-eval-defun (&optional and-go)
1538
  "Send the current defun to the inferior Tcl process.
1539
Prefix argument means switch to the Tcl buffer afterwards."
1540
  (interactive "P")
1541
  (save-excursion
1542
    (tcl-end-of-defun)
1543
    (let ((end (point)))
1544
      (tcl-beginning-of-defun)
1545
      (tcl-eval-region (point) end)))
1546
  (if and-go (switch-to-tcl t)))
1547
 
1548
 
1549
 
1550
;;
1551
;; Inferior Tcl mode itself.
1552
;;
1553
 
1554
(defun inferior-tcl-mode ()
1555
  "Major mode for interacting with Tcl interpreter.
1556
 
1557
A Tcl process can be started with M-x inferior-tcl.
1558
 
1559
Entry to this mode runs the hooks comint-mode-hook and
1560
inferior-tcl-mode-hook, in that order.
1561
 
1562
You can send text to the inferior Tcl process from other buffers
1563
containing Tcl source.
1564
 
1565
Variables controlling Inferior Tcl mode:
1566
  tcl-application
1567
    Name of program to run.
1568
  tcl-command-switches
1569
    Command line arguments to `tcl-application'.
1570
  tcl-prompt-regexp
1571
    Matches prompt.
1572
  inferior-tcl-source-command
1573
    Command to use to read Tcl file in running application.
1574
  inferior-tcl-buffer
1575
    The current inferior Tcl process buffer.  See variable
1576
    documentation for details on multiple-process support.
1577
 
1578
The following commands are available:
1579
\\{inferior-tcl-mode-map}"
1580
  (interactive)
1581
  (comint-mode)
1582
  (setq comint-prompt-regexp (or tcl-prompt-regexp
1583
                                 (concat "^"
1584
                                         (regexp-quote tcl-application)
1585
                                         ">")))
1586
  (setq major-mode 'inferior-tcl-mode)
1587
  (setq mode-name "Inferior Tcl")
1588
  (if (boundp 'modeline-process)
1589
      (setq modeline-process '(": %s")) ; For XEmacs.
1590
    (setq mode-line-process '(": %s")))
1591
  (use-local-map inferior-tcl-mode-map)
1592
  (setq local-abbrev-table tcl-mode-abbrev-table)
1593
  (set-syntax-table tcl-mode-syntax-table)
1594
  (if tcl-using-emacs-19
1595
      (progn
1596
        (make-local-variable 'defun-prompt-regexp)
1597
        (setq defun-prompt-regexp tcl-omit-ws-regexp)))
1598
  (make-local-variable 'inferior-tcl-delete-prompt-marker)
1599
  (setq inferior-tcl-delete-prompt-marker (make-marker))
1600
  (set-process-filter (get-buffer-process (current-buffer)) 'tcl-filter)
1601
  (run-hooks 'inferior-tcl-mode-hook))
1602
 
1603
;;;###autoload
1604
(defun inferior-tcl (cmd)
1605
  "Run inferior Tcl process.
1606
Prefix arg means enter program name interactively.
1607
See documentation for function `inferior-tcl-mode' for more information."
1608
  (interactive
1609
   (list (if current-prefix-arg
1610
             (read-string "Run Tcl: " tcl-application)
1611
           tcl-application)))
1612
  (if (not (comint-check-proc "*inferior-tcl*"))
1613
      (progn
1614
        (set-buffer (apply (function make-comint) "inferior-tcl" cmd nil
1615
                           tcl-command-switches))
1616
        (inferior-tcl-mode)))
1617
  (make-local-variable 'tcl-application)
1618
  (setq tcl-application cmd)
1619
  (setq inferior-tcl-buffer "*inferior-tcl*")
1620
  (switch-to-buffer "*inferior-tcl*"))
1621
 
1622
(and (fboundp 'defalias)
1623
     (defalias 'run-tcl 'inferior-tcl))
1624
 
1625
 
1626
 
1627
;;
1628
;; Auto-fill support.
1629
;;
1630
 
1631
(defun tcl-real-command-p ()
1632
  "Return nil if point is not at the beginning of a command.
1633
A command is the first word on an otherwise empty line, or the
1634
first word following a semicolon, opening brace, or opening bracket."
1635
  (save-excursion
1636
    (skip-chars-backward " \t")
1637
    (cond
1638
     ((bobp) t)
1639
     ((bolp)
1640
      (backward-char)
1641
      ;; Note -- continued comments are not supported here.  I
1642
      ;; consider those to be a wart on the language.
1643
      (not (eq ?\\ (preceding-char))))
1644
     (t
1645
      (memq (preceding-char) '(?\; ?{ ?\[))))))
1646
 
1647
;; FIXME doesn't actually return t.  See last case.
1648
(defun tcl-real-comment-p ()
1649
  "Return t if point is just after the `#' beginning a real comment.
1650
Does not check to see if previous char is actually `#'.
1651
A real comment is either at the beginning of the buffer,
1652
preceeded only by whitespace on the line, or has a preceeding
1653
semicolon, opening brace, or opening bracket on the same line."
1654
  (save-excursion
1655
    (backward-char)
1656
    (tcl-real-command-p)))
1657
 
1658
(defun tcl-hairy-scan-for-comment (state end always-stop)
1659
  "Determine if point is in a comment.
1660
Returns a list of the form `(FLAG . STATE)'.  STATE can be used
1661
as input to future invocations.  FLAG is nil if not in comment,
1662
t otherwise.  If in comment, leaves point at beginning of comment.
1663
Only works in Emacs 19.  See also `tcl-simple-scan-for-comment', a
1664
simpler version that is often right, and works in Emacs 18."
1665
  (let ((bol (save-excursion
1666
               (goto-char end)
1667
               (beginning-of-line)
1668
               (point)))
1669
        real-comment
1670
        last-cstart)
1671
    (while (and (not last-cstart) (< (point) end))
1672
      (setq real-comment nil)           ;In case we've looped around and it is
1673
                                        ;set.
1674
      (setq state (parse-partial-sexp (point) end nil nil state t))
1675
      (if (nth 4 state)
1676
          (progn
1677
            ;; If ALWAYS-STOP is set, stop even if we don't have a
1678
            ;; real comment, or if the comment isn't on the same line
1679
            ;; as the end.
1680
            (if always-stop (setq last-cstart (point)))
1681
            ;; If we have a real comment, then set the comment
1682
            ;; starting point if we are on the same line as the ending
1683
            ;; location.
1684
            (setq real-comment (tcl-real-comment-p))
1685
            (if real-comment
1686
                (progn
1687
                  (and (> (point) bol) (setq last-cstart (point)))
1688
                  ;; NOTE Emacs 19 has a misfeature whereby calling
1689
                  ;; parse-partial-sexp with COMMENTSTOP set and with
1690
                  ;; an initial list that says point is in a comment
1691
                  ;; will cause an immediate return.  So we must skip
1692
                  ;; over the comment ourselves.
1693
                  (beginning-of-line 2)))
1694
            ;; Frob the state to make it look like we aren't in a
1695
            ;; comment.
1696
            (setcar (nthcdr 4 state) nil))))
1697
    (and last-cstart
1698
         (goto-char last-cstart))
1699
    (cons real-comment state)))
1700
 
1701
(defun tcl-hairy-in-comment ()
1702
  "Return t if point is in a comment, and leave point at beginning
1703
of comment."
1704
  (let ((save (point)))
1705
    (tcl-beginning-of-defun)
1706
    (car (tcl-hairy-scan-for-comment nil save nil))))
1707
 
1708
(defun tcl-simple-in-comment ()
1709
  "Return t if point is in comment, and leave point at beginning
1710
of comment.  This is faster that `tcl-hairy-in-comment', but is
1711
correct less often."
1712
  (let ((save (point))
1713
        comment)
1714
    (beginning-of-line)
1715
    (while (and (< (point) save) (not comment))
1716
      (search-forward "#" save 'move)
1717
      (setq comment (tcl-real-comment-p)))
1718
    comment))
1719
 
1720
(defun tcl-in-comment ()
1721
  "Return t if point is in comment, and leave point at beginning
1722
of comment."
1723
  (if (and tcl-pps-has-arg-6
1724
           tcl-use-hairy-comment-detector)
1725
      (tcl-hairy-in-comment)
1726
    (tcl-simple-in-comment)))
1727
 
1728
(defun tcl-do-fill-paragraph (ignore)
1729
  "fill-paragraph function for Tcl mode.  Only fills in a comment."
1730
  (let (in-comment col where)
1731
    (save-excursion
1732
      (end-of-line)
1733
      (setq in-comment (tcl-in-comment))
1734
      (if in-comment
1735
          (progn
1736
            (setq where (1+ (point)))
1737
            (setq col (1- (current-column))))))
1738
    (and in-comment
1739
         (save-excursion
1740
           (back-to-indentation)
1741
           (= col (current-column)))
1742
         ;; In a comment.  Set the fill prefix, and find the paragraph
1743
         ;; boundaries by searching for lines that look like
1744
         ;; comment-only lines.
1745
         (let ((fill-prefix (buffer-substring (progn
1746
                                                (beginning-of-line)
1747
                                                (point))
1748
                                              where))
1749
               p-start p-end)
1750
           ;; Search backwards.
1751
           (save-excursion
1752
             (while (looking-at "^[ \t]*#")
1753
               (forward-line -1))
1754
             (forward-line)
1755
             (setq p-start (point)))
1756
 
1757
           ;; Search forwards.
1758
           (save-excursion
1759
             (while (looking-at "^[ \t]*#")
1760
               (forward-line))
1761
             (setq p-end (point)))
1762
 
1763
           ;; Narrow and do the fill.
1764
           (save-restriction
1765
             (narrow-to-region p-start p-end)
1766
             (fill-paragraph ignore)))))
1767
  t)
1768
 
1769
(defun tcl-do-auto-fill ()
1770
  "Auto-fill function for Tcl mode.  Only auto-fills in a comment."
1771
  (if (> (current-column) fill-column)
1772
      (let ((fill-prefix "# ")
1773
            in-comment col)
1774
        (save-excursion
1775
          (setq in-comment (tcl-in-comment))
1776
          (if in-comment
1777
              (setq col (1- (current-column)))))
1778
        (if in-comment
1779
            (progn
1780
              (do-auto-fill)
1781
              (save-excursion
1782
                (back-to-indentation)
1783
                (delete-region (point) (save-excursion
1784
                                         (beginning-of-line)
1785
                                         (point)))
1786
                (indent-to-column col)))))))
1787
 
1788
 
1789
 
1790
;;
1791
;; Help-related code.
1792
;;
1793
 
1794
(defvar tcl-help-saved-dirs nil
1795
  "Saved help directories.
1796
If `tcl-help-directory-list' changes, this allows `tcl-help-on-word'
1797
to update the alist.")
1798
 
1799
(defvar tcl-help-alist nil
1800
  "Alist with command names as keys and filenames as values.")
1801
 
1802
(defun tcl-help-snarf-commands (dirlist)
1803
  "Build alist of commands and filenames."
1804
  (while dirlist
1805
    (let ((files (directory-files (car dirlist) t)))
1806
      (while files
1807
        (if (and (file-directory-p (car files))
1808
                 (not
1809
                  (let ((fpart (file-name-nondirectory (car files))))
1810
                    (or (equal fpart ".")
1811
                        (equal fpart "..")))))
1812
            (let ((matches (directory-files (car files) t)))
1813
              (while matches
1814
                (or (file-directory-p (car matches))
1815
                    (setq tcl-help-alist
1816
                          (cons
1817
                           (cons (file-name-nondirectory (car matches))
1818
                                 (car matches))
1819
                           tcl-help-alist)))
1820
                (setq matches (cdr matches)))))
1821
        (setq files (cdr files))))
1822
    (setq dirlist (cdr dirlist))))
1823
 
1824
(defun tcl-reread-help-files ()
1825
  "Set up to re-read files, and then do it."
1826
  (interactive)
1827
  (message "Building Tcl help file index...")
1828
  (setq tcl-help-saved-dirs tcl-help-directory-list)
1829
  (setq tcl-help-alist nil)
1830
  (tcl-help-snarf-commands tcl-help-directory-list)
1831
  (message "Building Tcl help file index...done"))
1832
 
1833
(defun tcl-word-no-props ()
1834
  "Like current-word, but strips properties."
1835
  (let ((word (current-word)))
1836
    (and (fboundp 'set-text-properties)
1837
         (set-text-properties 0 (length word) nil word))
1838
    word))
1839
 
1840
(defun tcl-current-word (flag)
1841
  "Return current command word, or nil.
1842
If FLAG is nil, just uses `current-word'.
1843
Otherwise scans backward for most likely Tcl command word."
1844
  (if (and flag
1845
           (memq major-mode '(tcl-mode inferior-tcl-mode)))
1846
      (condition-case nil
1847
          (save-excursion
1848
            ;; Look backward for first word actually in alist.
1849
            (if (bobp)
1850
                ()
1851
              (while (and (not (bobp))
1852
                          (not (tcl-real-command-p)))
1853
                (backward-sexp)))
1854
            (if (assoc (tcl-word-no-props) tcl-help-alist)
1855
                (tcl-word-no-props)))
1856
        (error nil))
1857
    (tcl-word-no-props)))
1858
 
1859
;;;###autoload
1860
(defun tcl-help-on-word (command &optional arg)
1861
  "Get help on Tcl command.  Default is word at point.
1862
Prefix argument means invert sense of `tcl-use-smart-word-finder'."
1863
  (interactive
1864
   (list
1865
    (progn
1866
      (if (not (equal tcl-help-directory-list tcl-help-saved-dirs))
1867
          (tcl-reread-help-files))
1868
      (let ((word (tcl-current-word
1869
                   (if current-prefix-arg
1870
                       (not tcl-use-smart-word-finder)
1871
                     tcl-use-smart-word-finder))))
1872
        (completing-read
1873
         (if (or (null word) (string= word ""))
1874
             "Help on Tcl command: "
1875
           (format "Help on Tcl command (default %s): " word))
1876
         tcl-help-alist nil t)))
1877
    current-prefix-arg))
1878
  (if (not (equal tcl-help-directory-list tcl-help-saved-dirs))
1879
      (tcl-reread-help-files))
1880
  (if (string= command "")
1881
      (setq command (tcl-current-word
1882
                     (if arg
1883
                         (not tcl-use-smart-word-finder)
1884
                       tcl-use-smart-word-finder))))
1885
  (let* ((help (get-buffer-create "*Tcl help*"))
1886
         (cell (assoc command tcl-help-alist))
1887
         (file (and cell (cdr cell))))
1888
    (set-buffer help)
1889
    (delete-region (point-min) (point-max))
1890
    (if file
1891
        (progn
1892
          (insert "*** " command "\n\n")
1893
          (insert-file-contents file))
1894
      (if (string= command "")
1895
          (insert "Magical Pig!")
1896
        (insert "Tcl command " command " not in help\n")))
1897
    (set-buffer-modified-p nil)
1898
    (goto-char (point-min))
1899
    (display-buffer help)))
1900
 
1901
 
1902
 
1903
;;
1904
;; Other interactive stuff.
1905
;;
1906
 
1907
(defvar tcl-previous-dir/file nil
1908
  "Record last directory and file used in loading.
1909
This holds a cons cell of the form `(DIRECTORY . FILE)'
1910
describing the last `tcl-load-file' command.")
1911
 
1912
(defun tcl-load-file (file &optional and-go)
1913
  "Load a Tcl file into the inferior Tcl process.
1914
Prefix argument means switch to the Tcl buffer afterwards."
1915
  (interactive
1916
   (list
1917
    ;; car because comint-get-source returns a list holding the
1918
    ;; filename.
1919
    (car (comint-get-source "Load Tcl file: "
1920
                            (or (and
1921
                                 (eq major-mode 'tcl-mode)
1922
                                 (buffer-file-name))
1923
                                tcl-previous-dir/file)
1924
                            '(tcl-mode) t))
1925
    current-prefix-arg))
1926
  (comint-check-source file)
1927
  (setq tcl-previous-dir/file (cons (file-name-directory file)
1928
                                    (file-name-nondirectory file)))
1929
  (tcl-send-string (inferior-tcl-proc)
1930
                   (format inferior-tcl-source-command (tcl-quote file)))
1931
  (if and-go (switch-to-tcl t)))
1932
 
1933
(defun tcl-restart-with-file (file &optional and-go)
1934
  "Restart inferior Tcl with file.
1935
If an inferior Tcl process exists, it is killed first.
1936
Prefix argument means switch to the Tcl buffer afterwards."
1937
  (interactive
1938
   (list
1939
    (car (comint-get-source "Restart with Tcl file: "
1940
                            (or (and
1941
                                 (eq major-mode 'tcl-mode)
1942
                                 (buffer-file-name))
1943
                                tcl-previous-dir/file)
1944
                            '(tcl-mode) t))
1945
    current-prefix-arg))
1946
  (let* ((buf (if (eq major-mode 'inferior-tcl-mode)
1947
                  (current-buffer)
1948
                inferior-tcl-buffer))
1949
         (proc (and buf (get-process buf))))
1950
    (cond
1951
     ((not (and buf (get-buffer buf)))
1952
      ;; I think this will be ok.
1953
      (inferior-tcl tcl-application)
1954
      (tcl-load-file file and-go))
1955
     ((or
1956
       (not (comint-check-proc buf))
1957
       (yes-or-no-p
1958
        "A Tcl process is running, are you sure you want to reset it? "))
1959
      (save-excursion
1960
        (comint-check-source file)
1961
        (setq tcl-previous-dir/file (cons (file-name-directory file)
1962
                                          (file-name-nondirectory file)))
1963
        (comint-exec (get-buffer-create buf)
1964
                     (if proc
1965
                         (process-name proc)
1966
                       "inferior-tcl")
1967
                     tcl-application file tcl-command-switches)
1968
        (if and-go (switch-to-tcl t)))))))
1969
 
1970
;; FIXME I imagine you can do this under Emacs 18.  I just don't know
1971
;; how.
1972
(defun tcl-auto-fill-mode (&optional arg)
1973
  "Like `auto-fill-mode', but controls filling of Tcl comments."
1974
  (interactive "P")
1975
  (and (not tcl-using-emacs-19)
1976
       (error "You must use Emacs 19 to get this feature."))
1977
  ;; Following code taken from "auto-fill-mode" (simple.el).
1978
  (prog1
1979
      (setq auto-fill-function
1980
            (if (if (null arg)
1981
                    (not auto-fill-function)
1982
                  (> (prefix-numeric-value arg) 0))
1983
                'tcl-do-auto-fill
1984
              nil))
1985
    (force-mode-line-update)))
1986
 
1987
;; hilit19 support from "Chris Alfeld" <calfeld@math.utah.edu>
1988
(defun tcl-hilit ()
1989
  (hilit-set-mode-patterns
1990
   '(tcl-mode)
1991
   '(
1992
     ("\\(^ *\\|\; *\\)#.*$" nil comment)
1993
     ("[^\\]\\(\\$[A-Za-z0-9\\-\\_./\\(\\)]+\\)" 1 label)
1994
     ("[^_]\\<\\(append\\|array\\|auto_execok\\|auto_load\\|auto_mkindex\\|auto_reset\\|break\\|case\\|catch\\|cd\\|close\\|concat\\|continue\\|eof\\|error\\|eval\\|exec\\|exit\\|expr\\|file\\|flush\\|for\\|foreach\\|format\\|gets\\|glob\\|global\\|history\\|if\\|incr\\|info\\|join\\|lappend\\|lindex\\|linsert\\|list\\|llength\\|lrange\\|lreplace\\|lsearch\\|lsort\\|open\\|pid\\|proc\\|puts\\|pwd\\|read\\|regexp\\|regsub\\|rename\\|return\\|scan\\|seek\\|set\\|source\\|split\\|string\\|switch\\|tell\\|time\\|trace\\|unknown\\|unset\\|uplevel\\|upvar\\|while\\)\\>[^_]" 1 keyword) ; tcl keywords
1995
     ("[^_]\\<\\(after\\|bell\\|bind\\|bindtags\\|clipboard\\|destroy\\|fileevent\\|focus\\|grab\\|image\\|lower\\|option\\|pack\\|place\\|raise\\|scale\\|selection\\|send\\|subst\\|tk\\|tk_popup\\|tkwait\\|update\\|winfo\\|wm\\)\\>[^_]" 1 define) ; tk keywords
1996
     ("[^_]\\<\\(button\\|canvas\\|checkbutton\\|entry\\|frame\\|label\\|listbox\\|menu\\|menubutton\\|message\\|radiobutton\\|scrollbar\\|text\\|toplevel\\)\\>[^_]" 1 decl) ; tk widgets
1997
     ("[^_]\\<\\(tix\\((ButtonBox\\|Baloon\\|Control\\|DirList\\|ExFileSelectBox\\|ExFileSelectDialog\\|FileEntry\\|HList\\|LabelEntry\\|LabelFrame\\|NoteBook\\|OptionMenu\\|PanedWindow\\|PopupMenu\\|ScrolledHList\\|ScrolledText\\|ScrolledWindow\\|Select\\|StdButtonBox\\)\\)\\>[^_]" 1 defun) ; tix widgets
1998
     ("[{}\\\"\\(\\)]" nil include) ; misc punctuation
1999
     )))
2000
 
2001
(defun tcl-electric-hash (&optional count)
2002
  "Insert a `#' and quote if it does not start a real comment.
2003
Prefix arg is number of `#'s to insert.
2004
See variable `tcl-electric-hash-style' for description of quoting
2005
styles."
2006
  (interactive "p")
2007
  (or count (setq count 1))
2008
  (if (> count 0)
2009
      (let ((type
2010
             (if (eq tcl-electric-hash-style 'smart)
2011
                 (if (> count 3)        ; FIXME what is "smart"?
2012
                     'quote
2013
                   'backslash)
2014
               tcl-electric-hash-style))
2015
            comment)
2016
        (if type
2017
            (progn
2018
              (save-excursion
2019
                (insert "#")
2020
                (setq comment (tcl-in-comment)))
2021
              (delete-char 1)
2022
              (and tcl-explain-indentation (message "comment: %s" comment))
2023
              (cond
2024
               ((eq type 'quote)
2025
                (if (not comment)
2026
                    (insert "\"")))
2027
               ((eq type 'backslash)
2028
                ;; The following will set count to 0, so the
2029
                ;; insert-char can still be run.
2030
                (if (not comment)
2031
                    (while (> count 0)
2032
                      (insert "\\#")
2033
                      (setq count (1- count)))))
2034
               (t nil))))
2035
        (insert-char ?# count))))
2036
 
2037
(defun tcl-hashify-buffer ()
2038
  "Quote all `#'s in current buffer that aren't Tcl comments."
2039
  (interactive)
2040
  (save-excursion
2041
    (goto-char (point-min))
2042
    (if (and tcl-pps-has-arg-6 tcl-use-hairy-comment-detector)
2043
        (let (state
2044
              result)
2045
          (while (< (point) (point-max))
2046
            (setq result (tcl-hairy-scan-for-comment state (point-max) t))
2047
            (if (car result)
2048
                (beginning-of-line 2)
2049
              (backward-char)
2050
              (if (eq ?# (following-char))
2051
                  (insert "\\"))
2052
              (forward-char))
2053
            (setq state (cdr result))))
2054
      (while (and (< (point) (point-max))
2055
                  (search-forward "#" nil 'move))
2056
        (if (tcl-real-comment-p)
2057
            (beginning-of-line 2)
2058
          ;; There's really no good way for the simple converter to
2059
          ;; work.  So we just quote # if it isn't already quoted.
2060
          ;; Bogus, but it works.
2061
          (backward-char)
2062
          (if (not (eq ?\\ (preceding-char)))
2063
              (insert "\\"))
2064
          (forward-char))))))
2065
 
2066
(defun tcl-indent-for-comment ()
2067
  "Indent this line's comment to comment column, or insert an empty comment.
2068
Is smart about syntax of Tcl comments.
2069
Parts of this were taken from indent-for-comment (simple.el)."
2070
  (interactive "*")
2071
  (end-of-line)
2072
  (or (tcl-in-comment)
2073
      (progn
2074
        ;; Not in a comment, so we have to insert one.  Create an
2075
        ;; empty comment (since there isn't one on this line).  If
2076
        ;; line is not blank, make sure we insert a ";" first.
2077
        (skip-chars-backward " \t")
2078
        (let ((eolpoint (point)))
2079
          (beginning-of-line)
2080
          (if (/= (point) eolpoint)
2081
              (progn
2082
                (goto-char eolpoint)
2083
                (insert
2084
                 (if (tcl-real-command-p) "" ";")
2085
                 "# ")
2086
                (backward-char))))))
2087
  ;; Point is just after the "#" starting a comment.  Move it as
2088
  ;; appropriate.
2089
  (let* ((indent (if comment-indent-hook
2090
                     (funcall comment-indent-hook)
2091
                   (funcall comment-indent-function)))
2092
         (begpos (progn
2093
                   (backward-char)
2094
                   (point))))
2095
    (if (/= begpos indent)
2096
        (progn
2097
          (skip-chars-backward " \t" (save-excursion
2098
                                       (beginning-of-line)
2099
                                       (point)))
2100
          (delete-region (point) begpos)
2101
          (indent-to indent)))
2102
    (looking-at comment-start-skip)     ; Always true.
2103
    (goto-char (match-end 0))
2104
    ;; I don't like the effect of the next two.
2105
    ;;(skip-chars-backward " \t" (match-beginning 0))
2106
    ;;(skip-chars-backward "^ \t" (match-beginning 0))
2107
    ))
2108
 
2109
;; The following was inspired by the Tcl editing mode written by
2110
;; Gregor Schmid <schmid@fb3-s7.math.TU-Berlin.DE>.  His version also
2111
;; attempts to snarf the command line options from the command line,
2112
;; but I didn't think that would really be that helpful (doesn't seem
2113
;; like it owould be right enough.  His version also looks for the
2114
;; "#!/bin/csh ... exec" hack, but that seemed even less useful.
2115
;; FIXME should make sure that the application mentioned actually
2116
;; exists.
2117
(defun tcl-guess-application ()
2118
  "Attempt to guess Tcl application by looking at first line.
2119
The first line is assumed to look like \"#!.../program ...\"."
2120
  (save-excursion
2121
    (goto-char (point-min))
2122
    (if (looking-at "#![^ \t]*/\\([^ \t\n/]+\\)\\([ \t]\\|$\\)")
2123
        (progn
2124
          (make-local-variable 'tcl-application)
2125
          (setq tcl-application (buffer-substring (match-beginning 1)
2126
                                                  (match-end 1)))))))
2127
 
2128
;; This only exists to put on the menubar.  I couldn't figure out any
2129
;; other way to do it.  FIXME should take "number of #-marks"
2130
;; argument.
2131
(defun tcl-uncomment-region (beg end)
2132
  "Uncomment region."
2133
  (interactive "r")
2134
  (comment-region beg end -1))
2135
 
2136
 
2137
 
2138
;;
2139
;; XEmacs menu support.
2140
;; Taken from schmid@fb3-s7.math.TU-Berlin.DE (Gregor Schmid),
2141
;; who wrote a different Tcl mode.
2142
;; We also have support for menus in FSF.  We do this by
2143
;; loading the XEmacs menu emulation code.
2144
;;
2145
 
2146
(defun tcl-popup-menu (e)
2147
  (interactive "@e")
2148
  (and tcl-using-emacs-19
2149
       (not tcl-using-xemacs-19)
2150
       (if tcl-using-emacs-19-23
2151
           (require 'lmenu)
2152
         ;; CAVEATS:
2153
         ;; * lmenu.el provides 'menubar, which is bogus.
2154
         ;; * lmenu.el causes menubars to be turned on everywhere.
2155
         ;;   Doubly bogus!
2156
         ;; Both of these problems are fixed in Emacs 19.23.  People
2157
         ;; using an Emacs before that just suffer.
2158
         (require 'menubar "lmenu")))  ;; This is annoying
2159
  ;; IMHO popup-menu should be autoloaded in FSF Emacs.  Oh well.
2160
  (popup-menu tcl-xemacs-menu))
2161
 
2162
 
2163
 
2164
;;
2165
;; Quoting and unquoting functions.
2166
;;
2167
 
2168
;; This quoting is sufficient to protect eg a filename from any sort
2169
;; of expansion or splitting.  Tcl quoting sure sucks.
2170
(defun tcl-quote (string)
2171
  "Quote STRING according to Tcl rules."
2172
  (mapconcat (function (lambda (char)
2173
                         (if (memq char '(?[ ?] ?{ ?} ?\\ ?\" ?$ ?  ?\;))
2174
                             (concat "\\" (char-to-string char))
2175
                           (char-to-string char))))
2176
             string ""))
2177
 
2178
 
2179
 
2180
;;
2181
;; Bug reporting.
2182
;;
2183
 
2184
(and (fboundp 'eval-when-compile)
2185
     (eval-when-compile
2186
       (require 'reporter)))
2187
 
2188
(defun tcl-submit-bug-report ()
2189
  "Submit via mail a bug report on Tcl mode."
2190
  (interactive)
2191
  (require 'reporter)
2192
  (and
2193
   (y-or-n-p "Do you really want to submit a bug report on Tcl mode? ")
2194
   (reporter-submit-bug-report
2195
    tcl-maintainer
2196
    (concat "Tcl mode " tcl-version)
2197
    '(tcl-indent-level
2198
      tcl-continued-indent-level
2199
      tcl-auto-newline
2200
      tcl-tab-always-indent
2201
      tcl-use-hairy-comment-detector
2202
      tcl-electric-hash-style
2203
      tcl-help-directory-list
2204
      tcl-use-smart-word-finder
2205
      tcl-application
2206
      tcl-command-switches
2207
      tcl-prompt-regexp
2208
      inferior-tcl-source-command
2209
      tcl-using-emacs-19
2210
      tcl-using-emacs-19-23
2211
      tcl-using-xemacs-19
2212
      tcl-proc-list
2213
      tcl-proc-regexp
2214
      tcl-typeword-list
2215
      tcl-keyword-list
2216
      tcl-font-lock-keywords
2217
      tcl-pps-has-arg-6))))
2218
 
2219
 
2220
 
2221
(provide 'tcl)
2222
 
2223
;;; tcl.el ends here

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.