lisp/progmodes/tcl.el

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