New Tcl backend.

17 files changed, 2266 insertions, 28 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 9b8d000..fc2237c 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,45 @@
+2002-03-03  Bruno Haible  <bruno@clisp.org>
+
+	* message.h (format_type): New enum value 'format_tcl'.
+	(NFORMATS): Increment.
+	* message.c (format_language): Add format_tcl entry.
+	(format_language_pretty): Likewise.
+	* format.h (formatstring_tcl): New declaration.
+	* format-tcl.c: New file.
+	* format.c (formatstring_parsers): Add formatstring_tcl.
+	* x-tcl.h: New file.
+	* x-tcl.c: New file.
+	* xgettext.c: Include x-tcl.h.
+	(main): Call x_tcl_extract_all, x_tcl_keyword.
+	(language_to_scanner): Add Tcl rule.
+	(extension_to_language): Add Tcl rule.
+	* write-tcl.h: New file.
+	* write-tcl.c: New file.
+	* msgfmt.c: Include write-tcl.h.
+	(tcl_mode, tcl_locale_name, tcl_base_directory): New variables.
+	(long_options): Add option "--tcl".
+	(main): Handle --tcl option. Set tcl_mode, tcl_locale_name,
+	tcl_base_directory. More checks for contradicting options. Call
+	msgdomain_write_tcl.
+	(usage): Mention Tcl mode.
+	(format_directive_domain): Ignore domain directive if in Tcl mode.
+	* read-tcl.h: New file.
+	* read-tcl.c: New file.
+	* msgunfmt.c: Include read-tcl.h.
+	(tcl_mode, tcl_locale_name, tcl_base_directory): New variables.
+	(long_options): Add option "--tcl".
+	(main): Handle --tcl and -d options. Set tcl_mode, tcl_locale_name,
+	tcl_base_directory. More checks for contradicting options. Call
+	msgdomain_read_tcl.
+	(usage): Mention Tcl mode.
+	* Makefile.am (noinst_HEADERS): Add read-tcl.h, write-tcl.h, x-tcl.h.
+	(DEFS): Add -DGETTEXTDATADIR.
+	(FORMAT_SOURCE): Add format-tcl.c.
+	(msgfmt_SOURCES): Add write-tcl.c.
+	(msgunfmt_SOURCES): Add read-tcl.c.
+	(xgettext_SOURCES): Add x-tcl.c.
+	(install-tcl, installdirs-tcl, uninstall-tcl): New targets.
+
 2002-03-02  Bruno Haible  <bruno@clisp.org>
 
 	* msgfmt.c (check_pair): Don't count "&&" as an accelerator designator,
diff --git a/src/FILES b/src/FILES
index b67655e..0c25794 100644
--- a/src/FILES
+++ b/src/FILES
@@ -149,6 +149,9 @@ po-time.c
 | read-java.h
 | read-java.c
 |               Reading Java ResourceBundle files.
+| read-tcl.h
+| read-tcl.c
+|               Reading Tcl .msg files.
 | msgunfmt.c
 |               Main source for the 'msgunfmt' program.
 |
@@ -163,6 +166,7 @@ format-librep.c Format string handling for librep.
 format-java.c   Format string handling for Java.
 format-pascal.c Format string handling for Object Pascal.
 format-ycp.c    Format string handling for YCP.
+format-tcl.c    Format string handling for Tcl.
 format.c        Table of the language dependent format string handlers.
 
 +-------------- The 'msgfmt' program
@@ -178,6 +182,9 @@ format.c        Table of the language dependent format string handlers.
 | write-java.h
 | write-java.c
 |               Generating Java ResourceBundle files.
+| write-tcl.h
+| write-tcl.c
+|               Generating Tcl .msg files.
 | msgfmt.c
 |               Main source for the 'msgfmt' program.
 |
@@ -207,6 +214,9 @@ format.c        Table of the language dependent format string handlers.
 | x-ycp.h
 | x-ycp.c
 |               String extractor for YCP.
+| x-tcl.h
+| x-tcl.c
+|               String extractor for Tcl.
 | x-rst.h
 | x-rst.c
 |               String extractor from .rst files, for Object Pascal.
diff --git a/src/Makefile.am b/src/Makefile.am
index 9eeaca9..915fbc1 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -31,9 +31,9 @@ noinst_HEADERS = pos.h message.h po-gram.h po-hash.h po-charset.h po-lex.h \
 po.h open-po.h read-po.h str-list.h write-po.h dir-list.h file-list.h \
 po-gram-gen.h po-hash-gen.h msgl-charset.h msgl-equal.h msgl-iconv.h \
 msgl-ascii.h msgl-cat.h msgl-english.h msgfmt.h msgunfmt.h read-mo.h \
-write-mo.h read-java.h write-java.h po-time.h plural-table.h format.h \
-xgettext.h x-c.h x-po.h x-python.h x-lisp.h x-elisp.h x-librep.h x-java.h \
-x-awk.h x-ycp.h x-rst.h x-glade.h
+write-mo.h read-java.h write-java.h read-tcl.h write-tcl.h po-time.h \
+plural-table.h format.h xgettext.h x-c.h x-po.h x-python.h x-lisp.h \
+x-elisp.h x-librep.h x-java.h x-awk.h x-ycp.h x-tcl.h x-rst.h x-glade.h
 
 EXTRA_DIST = FILES project-id \
 gnu/gettext/DumpResource.java gnu/gettext/GetURL.java
@@ -45,7 +45,8 @@ projectsdir = $(pkgdatadir)/projects
 INCLUDES = -I. -I$(srcdir) -I.. -I$(top_srcdir)/libuniname \
 -I../lib -I$(top_srcdir)/lib -I../intl -I$(top_srcdir)/intl
 DEFS = -DLOCALEDIR=\"$(localedir)\" -DGETTEXTJAR=\"$(jardir)/gettext.jar\" \
--DLIBDIR=\"$(libdir)\" -DPROJECTSDIR=\"$(projectsdir)\" @DEFS@
+-DLIBDIR=\"$(libdir)\" -DGETTEXTDATADIR=\"$(pkgdatadir)\" \
+-DPROJECTSDIR=\"$(projectsdir)\" @DEFS@
 LDADD = ../lib/libgettextlib.la @LTLIBINTL@
 
 SED = sed
@@ -68,7 +69,7 @@ open-po.c dir-list.c str-list.c
 # xgettext and msgfmt deal with format strings.
 FORMAT_SOURCE = format.c \
 format-c.c format-python.c format-lisp.c format-elisp.c format-librep.c \
-format-java.c format-awk.c format-pascal.c format-ycp.c
+format-java.c format-awk.c format-pascal.c format-ycp.c format-tcl.c
 
 # libgettextsrc contains all code that is needed by at least two programs.
 libgettextsrc_la_SOURCES = \
@@ -83,12 +84,12 @@ LIBUNINAME = ../libuniname/libuniname.a
 gettext_SOURCES = gettext.c
 ngettext_SOURCES = ngettext.c
 msgcmp_SOURCES = msgcmp.c
-msgfmt_SOURCES = msgfmt.c write-mo.c write-java.c plural-eval.c
+msgfmt_SOURCES = msgfmt.c write-mo.c write-java.c write-tcl.c plural-eval.c
 msgmerge_SOURCES = msgmerge.c
-msgunfmt_SOURCES = msgunfmt.c read-mo.c read-java.c
+msgunfmt_SOURCES = msgunfmt.c read-mo.c read-java.c read-tcl.c
 xgettext_SOURCES = xgettext.c \
   x-c.c x-po.c x-python.c x-lisp.c x-elisp.c x-librep.c x-java.l x-awk.c \
-  x-ycp.c x-rst.c x-glade.c
+  x-ycp.c x-tcl.c x-rst.c x-glade.c
 msgattrib_SOURCES = msgattrib.c
 msgcat_SOURCES = msgcat.c
 msgcomm_SOURCES = msgcomm.c
@@ -200,5 +201,21 @@ uninstall-java-yes:
 	$(RM) $(DESTDIR)$(jardir)/gettext.jar
 
 
+# Special rules for Tcl auxiliary program.
+
+install-data-local: install-tcl
+install-tcl:
+	$(mkinstalldirs) $(DESTDIR)$(pkgdatadir)
+	$(INSTALL_DATA) $(srcdir)/msgunfmt.tcl $(DESTDIR)$(pkgdatadir)/msgunfmt.tcl
+
+installdirs-local: installdirs-tcl
+installdirs-tcl:
+	$(mkinstalldirs) $(DESTDIR)$(pkgdatadir)
+
+uninstall-local: uninstall-tcl
+uninstall-tcl:
+	$(RM) $(DESTDIR)$(pkgdatadir)/msgunfmt.tcl
+
+
 # One more automake bug.
 installdirs: installdirs-local
diff --git a/src/format-tcl.c b/src/format-tcl.c
new file mode 100644
index 0000000..d765308
--- /dev/null
+++ b/src/format-tcl.c
@@ -0,0 +1,542 @@
+/* Tcl format strings.
+   Copyright (C) 2001-2002 Free Software Foundation, Inc.
+   Written by Bruno Haible <haible@clisp.cons.org>, 2002.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2, or (at your option)
+   any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software Foundation,
+   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdbool.h>
+#include <stdlib.h>
+
+#include "format.h"
+#include "xmalloc.h"
+#include "error.h"
+#include "progname.h"
+#include "gettext.h"
+
+#define _(str) gettext (str)
+
+/* Tcl format strings are described in the tcl8.3.3/doc/format.n manual
+   page and implemented in the function Tcl_FormatObjCmd in
+   tcl8.3.3/generic/tclCmdAH.c.
+   A directive
+   - starts with '%' or '%m$' where m is a positive integer,
+   - is optionally followed by any of the characters '#', '0', '-', ' ', '+',
+     each of which acts as a flag,
+   - is optionally followed by a width specification: '*' (reads an argument)
+     or a nonempty digit sequence,
+   - is optionally followed by '.' and a precision specification: '*' (reads
+     an argument) or a nonempty digit sequence,
+   - is optionally followed by a size specifier, 'h' or 'l'. 'l' is ignored.
+   - is finished by a specifier
+       - '%', that needs no argument,
+       - 'c', that needs a character argument,
+       - 's', that needs a string argument,
+       - 'i', 'd', that need a signed integer argument,
+       - 'o', 'u', 'x', 'X', that need an unsigned integer argument,
+       - 'e', 'E', 'f', 'g', 'G', that need a floating-point argument.
+   Numbered ('%m$') and unnumbered argument specifications cannot be used
+   in the same string.
+ */
+
+enum format_arg_type
+{
+  FAT_NONE,
+  FAT_CHARACTER,
+  FAT_STRING,
+  FAT_INTEGER,
+  FAT_UNSIGNED_INTEGER,
+  FAT_SHORT_INTEGER,
+  FAT_SHORT_UNSIGNED_INTEGER,
+  FAT_FLOAT
+};
+
+struct numbered_arg
+{
+  unsigned int number;
+  enum format_arg_type type;
+};
+
+struct spec
+{
+  unsigned int directives;
+  unsigned int numbered_arg_count;
+  unsigned int allocated;
+  struct numbered_arg *numbered;
+};
+
+/* Locale independent test for a decimal digit.
+   Argument can be  'char' or 'unsigned char'.  (Whereas the argument of
+   <ctype.h> isdigit must be an 'unsigned char'.)  */
+#undef isdigit
+#define isdigit(c) ((unsigned int) ((c) - '0') < 10)
+
+
+/* Prototypes for local functions.  Needed to ensure compiler checking of
+   function argument counts despite of K&R C function definition syntax.  */
+static int numbered_arg_compare PARAMS ((const void *p1, const void *p2));
+static void *format_parse PARAMS ((const char *format));
+static void format_free PARAMS ((void *descr));
+static int format_get_number_of_directives PARAMS ((void *descr));
+static bool format_check PARAMS ((const lex_pos_ty *pos,
+				  void *msgid_descr, void *msgstr_descr,
+				  bool equality,
+				  bool noisy, const char *pretty_msgstr));
+
+
+static int
+numbered_arg_compare (p1, p2)
+     const void *p1;
+     const void *p2;
+{
+  unsigned int n1 = ((const struct numbered_arg *) p1)->number;
+  unsigned int n2 = ((const struct numbered_arg *) p2)->number;
+
+  return (n1 > n2 ? 1 : n1 < n2 ? -1 : 0);
+}
+
+static void *
+format_parse (format)
+     const char *format;
+{
+  struct spec spec;
+  struct spec *result;
+  bool seen_numbered_arg;
+  bool seen_unnumbered_arg;
+  unsigned int number;
+
+  spec.directives = 0;
+  spec.numbered_arg_count = 0;
+  spec.allocated = 0;
+  spec.numbered = NULL;
+  seen_numbered_arg = false;
+  seen_unnumbered_arg = false;
+  number = 1;
+
+  for (; *format != '\0';)
+    if (*format++ == '%')
+      {
+	/* A directive.  */
+	spec.directives++;
+
+	if (*format != '%')
+	  {
+	    bool is_numbered_arg;
+	    bool short_flag;
+	    enum format_arg_type type;
+
+	    is_numbered_arg = false;
+	    if (isdigit (*format))
+	      {
+		const char *f = format;
+		unsigned int m = 0;
+
+		do
+		  {
+		    m = 10 * m + (*f - '0');
+		    f++;
+		  }
+		while (isdigit (*f));
+
+		if (*f == '$')
+		  {
+		    if (m == 0)
+		      goto bad_format;
+		    number = m;
+		    format = ++f;
+
+		    /* Numbered and unnumbered specifications are exclusive.  */
+		    if (seen_unnumbered_arg)
+		      goto bad_format;
+		    is_numbered_arg = true;
+		    seen_numbered_arg = true;
+		  }
+	      }
+
+	    /* Numbered and unnumbered specifications are exclusive.  */
+	    if (!is_numbered_arg)
+	      {
+		if (seen_numbered_arg)
+		  goto bad_format;
+		seen_unnumbered_arg = true;
+	      }
+
+	    /* Parse flags.  */
+	    while (*format == ' ' || *format == '+' || *format == '-'
+		   || *format == '#' || *format == '0')
+	      format++;
+
+	    /* Parse width.  */
+	    if (*format == '*')
+	      {
+		format++;
+
+		if (spec.allocated == spec.numbered_arg_count)
+		  {
+		    spec.allocated = 2 * spec.allocated + 1;
+		    spec.numbered = (struct numbered_arg *) xrealloc (spec.numbered, spec.allocated * sizeof (struct numbered_arg));
+		  }
+		spec.numbered[spec.numbered_arg_count].number = number;
+		spec.numbered[spec.numbered_arg_count].type = FAT_INTEGER;
+		spec.numbered_arg_count++;
+
+		number++;
+	      }
+	    else if (isdigit (*format))
+	      {
+		do format++; while (isdigit (*format));
+	      }
+
+	    /* Parse precision.  */
+	    if (*format == '.')
+	      {
+		format++;
+
+		if (*format == '*')
+		  {
+		    format++;
+
+		    if (spec.allocated == spec.numbered_arg_count)
+		      {
+			spec.allocated = 2 * spec.allocated + 1;
+			spec.numbered = (struct numbered_arg *) xrealloc (spec.numbered, spec.allocated * sizeof (struct numbered_arg));
+		      }
+		    spec.numbered[spec.numbered_arg_count].number = number;
+		    spec.numbered[spec.numbered_arg_count].type = FAT_INTEGER;
+		    spec.numbered_arg_count++;
+
+		    number++;
+		  }
+		else if (isdigit (*format))
+		  {
+		    do format++; while (isdigit (*format));
+		  }
+	      }
+
+	    /* Parse optional size specification.  */
+	    short_flag = false;
+	    if (*format == 'h')
+	      short_flag = true, format++;
+	    else if (*format == 'l')
+	      format++;
+
+	    switch (*format)
+	      {
+	      case 'c':
+		type = FAT_CHARACTER;
+		break;
+	      case 's':
+		type = FAT_STRING;
+		break;
+	      case 'i': case 'd':
+		type = (short_flag ? FAT_SHORT_INTEGER : FAT_INTEGER);
+		break;
+	      case 'u': case 'o': case 'x': case 'X':
+		type = (short_flag ? FAT_SHORT_UNSIGNED_INTEGER : FAT_UNSIGNED_INTEGER);
+		break;
+	      case 'e': case 'E': case 'f': case 'g': case 'G':
+		type = FAT_FLOAT;
+		break;
+	      default:
+		goto bad_format;
+	      }
+
+	    if (spec.allocated == spec.numbered_arg_count)
+	      {
+		spec.allocated = 2 * spec.allocated + 1;
+		spec.numbered = (struct numbered_arg *) xrealloc (spec.numbered, spec.allocated * sizeof (struct numbered_arg));
+	      }
+	    spec.numbered[spec.numbered_arg_count].number = number;
+	    spec.numbered[spec.numbered_arg_count].type = type;
+	    spec.numbered_arg_count++;
+
+	    number++;
+	  }
+
+	format++;
+      }
+
+  /* Sort the numbered argument array, and eliminate duplicates.  */
+  if (spec.numbered_arg_count > 1)
+    {
+      unsigned int i, j;
+      bool err;
+
+      qsort (spec.numbered, spec.numbered_arg_count,
+	     sizeof (struct numbered_arg), numbered_arg_compare);
+
+      /* Remove duplicates: Copy from i to j, keeping 0 <= j <= i.  */
+      err = false;
+      for (i = j = 0; i < spec.numbered_arg_count; i++)
+	if (j > 0 && spec.numbered[i].number == spec.numbered[j-1].number)
+	  {
+	    enum format_arg_type type1 = spec.numbered[i].type;
+	    enum format_arg_type type2 = spec.numbered[j-1].type;
+	    enum format_arg_type type_both;
+
+	    if (type1 == type2)
+	      type_both = type1;
+	    else
+	      /* Incompatible types.  */
+	      type_both = FAT_NONE, err = true;
+
+	    spec.numbered[j-1].type = type_both;
+	  }
+	else
+	  {
+	    if (j < i)
+	      {
+		spec.numbered[j].number = spec.numbered[i].number;
+		spec.numbered[j].type = spec.numbered[i].type;
+	      }
+	    j++;
+	  }
+      spec.numbered_arg_count = j;
+      if (err)
+	goto bad_format;
+    }
+
+  result = (struct spec *) xmalloc (sizeof (struct spec));
+  *result = spec;
+  return result;
+
+ bad_format:
+  if (spec.numbered != NULL)
+    free (spec.numbered);
+  return NULL;
+}
+
+static void
+format_free (descr)
+     void *descr;
+{
+  struct spec *spec = (struct spec *) descr;
+
+  if (spec->numbered != NULL)
+    free (spec->numbered);
+  free (spec);
+}
+
+static int
+format_get_number_of_directives (descr)
+     void *descr;
+{
+  struct spec *spec = (struct spec *) descr;
+
+  return spec->directives;
+}
+
+static bool
+format_check (pos, msgid_descr, msgstr_descr, equality, noisy, pretty_msgstr)
+     const lex_pos_ty *pos;
+     void *msgid_descr;
+     void *msgstr_descr;
+     bool equality;
+     bool noisy;
+     const char *pretty_msgstr;
+{
+  struct spec *spec1 = (struct spec *) msgid_descr;
+  struct spec *spec2 = (struct spec *) msgstr_descr;
+  bool err = false;
+
+  if (spec1->numbered_arg_count + spec2->numbered_arg_count > 0)
+    {
+      unsigned int i, j;
+      unsigned int n1 = spec1->numbered_arg_count;
+      unsigned int n2 = spec2->numbered_arg_count;
+
+      /* Check the argument names are the same.
+	 Both arrays are sorted.  We search for the first difference.  */
+      for (i = 0, j = 0; i < n1 || j < n2; )
+	{
+	  int cmp = (i >= n1 ? 1 :
+		     j >= n2 ? -1 :
+		     spec1->numbered[i].number > spec2->numbered[j].number ? 1 :
+		     spec1->numbered[i].number < spec2->numbered[j].number ? -1 :
+		     0);
+
+	  if (cmp > 0)
+	    {
+	      if (noisy)
+		{
+		  error_with_progname = false;
+		  error_at_line (0, 0, pos->file_name, pos->line_number,
+				 _("a format specification for argument %u, as in '%s', doesn't exist in 'msgid'"),
+				 spec2->numbered[j].number, pretty_msgstr);
+		  error_with_progname = true;
+		}
+	      err = true;
+	      break;
+	    }
+	  else if (cmp < 0)
+	    {
+	      if (equality)
+		{
+		  if (noisy)
+		    {
+		      error_with_progname = false;
+		      error_at_line (0, 0, pos->file_name, pos->line_number,
+				     _("a format specification for argument %u doesn't exist in '%s'"),
+				     spec1->numbered[i].number, pretty_msgstr);
+		      error_with_progname = true;
+		    }
+		  err = true;
+		  break;
+		}
+	      else
+		i++;
+	    }
+	  else
+	    j++, i++;
+	}
+      /* Check the argument types are the same.  */
+      if (!err)
+	for (i = 0, j = 0; j < n2; )
+	  {
+	    if (spec1->numbered[i].number == spec2->numbered[j].number)
+	      {
+		if (spec1->numbered[i].type != spec2->numbered[j].type)
+		  {
+		    if (noisy)
+		      {
+			error_with_progname = false;
+			error_at_line (0, 0, pos->file_name, pos->line_number,
+				       _("format specifications in 'msgid' and '%s' for argument %u are not the same"),
+				       pretty_msgstr,
+				       spec2->numbered[j].number);
+			error_with_progname = true;
+		      }
+		    err = true;
+		    break;
+		  }
+		j++, i++;
+	      }
+	    else
+	      i++;
+	  }
+    }
+
+  return err;
+}
+
+
+struct formatstring_parser formatstring_tcl =
+{
+  format_parse,
+  format_free,
+  format_get_number_of_directives,
+  format_check
+};
+
+
+#ifdef TEST
+
+/* Test program: Print the argument list specification returned by
+   format_parse for strings read from standard input.  */
+
+#include <stdio.h>
+#include "getline.h"
+
+static void
+format_print (descr)
+     void *descr;
+{
+  struct spec *spec = (struct spec *) descr;
+  unsigned int last;
+  unsigned int i;
+
+  if (spec == NULL)
+    {
+      printf ("INVALID");
+      return;
+    }
+
+  printf ("(");
+  last = 1;
+  for (i = 0; i < spec->numbered_arg_count; i++)
+    {
+      unsigned int number = spec->numbered[i].number;
+
+      if (i > 0)
+	printf (" ");
+      if (number < last)
+	abort ();
+      for (; last < number; last++)
+	printf ("_ ");
+      switch (spec->numbered[i].type)
+	{
+	case FAT_CHARACTER:
+	  printf ("c");
+	  break;
+	case FAT_STRING:
+	  printf ("s");
+	  break;
+	case FAT_INTEGER:
+	  printf ("i");
+	  break;
+	case FAT_UNSIGNED_INTEGER:
+	  printf ("[unsigned]i");
+	  break;
+	case FAT_SHORT_INTEGER:
+	  printf ("hi");
+	  break;
+	case FAT_UNSIGNED_SHORT_INTEGER:
+	  printf ("[unsigned]hi");
+	  break;
+	case FAT_FLOAT:
+	  printf ("f");
+	  break;
+	default:
+	  abort ();
+	}
+      last = number + 1;
+    }
+  printf (")");
+}
+
+int
+main ()
+{
+  for (;;)
+    {
+      char *line = NULL;
+      size_t line_len = 0;
+      void *descr;
+
+      if (getline (&line, &line_len, stdin) < 0)
+	break;
+
+      descr = format_parse (line);
+
+      format_print (descr);
+      printf ("\n");
+
+      free (line);
+    }
+
+  return 0;
+}
+
+/*
+ * For Emacs M-x compile
+ * Local Variables:
+ * compile-command: "/bin/sh ../libtool --mode=link gcc -o a.out -static -O -g -Wall -I.. -I../lib -I../intl -DHAVE_CONFIG_H -DTEST format-tcl.c ../lib/libgettextlib.la"
+ * End:
+ */
+
+#endif /* TEST */
diff --git a/src/format.c b/src/format.c
index 6b43460..a981eb7 100644
--- a/src/format.c
+++ b/src/format.c
@@ -35,5 +35,6 @@ struct formatstring_parser *formatstring_parsers[NFORMATS] =
   /* format_java */		&formatstring_java,
   /* format_awk */		&formatstring_awk,
   /* format_pascal */		&formatstring_pascal,
-  /* format_ycp */		&formatstring_ycp
+  /* format_ycp */		&formatstring_ycp,
+  /* format_tcl */		&formatstring_tcl
 };
diff --git a/src/format.h b/src/format.h
index 1df1c14..37f0564 100644
--- a/src/format.h
+++ b/src/format.h
@@ -64,6 +64,7 @@ extern struct formatstring_parser formatstring_java;
 extern struct formatstring_parser formatstring_awk;
 extern struct formatstring_parser formatstring_pascal;
 extern struct formatstring_parser formatstring_ycp;
+extern struct formatstring_parser formatstring_tcl;
 
 /* Table of all format string parsers.  */
 extern struct formatstring_parser *formatstring_parsers[NFORMATS];
diff --git a/src/message.c b/src/message.c
index bbfb002..9ffcf30 100644
--- a/src/message.c
+++ b/src/message.c
@@ -49,7 +49,8 @@ const char *const format_language[NFORMATS] =
   /* format_java */		"java",
   /* format_awk */		"awk",
   /* format_pascal */		"object-pascal",
-  /* format_ycp */		"ycp"
+  /* format_ycp */		"ycp",
+  /* format_tcl */		"tcl"
 };
 
 const char *const format_language_pretty[NFORMATS] =
@@ -63,7 +64,8 @@ const char *const format_language_pretty[NFORMATS] =
   /* format_java */		"Java",
   /* format_awk */		"awk",
   /* format_pascal */		"Object Pascal",
-  /* format_ycp */		"YCP"
+  /* format_ycp */		"YCP",
+  /* format_tcl */		"Tcl"
 };
 
 
diff --git a/src/message.h b/src/message.h
index 74fa4a7..abe361f 100644
--- a/src/message.h
+++ b/src/message.h
@@ -43,9 +43,10 @@ enum format_type
   format_java,
   format_awk,
   format_pascal,
-  format_ycp
+  format_ycp,
+  format_tcl
 };
-#define NFORMATS 10	/* Number of format_type enum values.  */
+#define NFORMATS 11	/* Number of format_type enum values.  */
 extern const char *const format_language[NFORMATS];
 extern const char *const format_language_pretty[NFORMATS];
 
diff --git a/src/msgfmt.c b/src/msgfmt.c
index 5b2ca40..f8883f9 100644
--- a/src/msgfmt.c
+++ b/src/msgfmt.c
@@ -45,6 +45,7 @@
 #include "msgfmt.h"
 #include "write-mo.h"
 #include "write-java.h"
+#include "write-tcl.h"
 
 #include "gettext.h"
 #include "message.h"
@@ -92,6 +93,11 @@ static const char *java_resource_name;
 static const char *java_locale_name;
 static const char *java_class_directory;
 
+/* Tcl mode output file specification.  */
+static bool tcl_mode;
+static const char *tcl_locale_name;
+static const char *tcl_base_directory;
+
 /* We may have more than one input file.  Domains with same names in
    different files have to merged.  So we need a list of tables for
    each output file.  */
@@ -163,6 +169,7 @@ static const struct option long_options[] =
   { "resource", required_argument, NULL, 'r' },
   { "statistics", no_argument, &do_statistics, 1 },
   { "strict", no_argument, NULL, 'S' },
+  { "tcl", no_argument, NULL, CHAR_MAX + 7 },
   { "use-fuzzy", no_argument, NULL, 'f' },
   { "verbose", no_argument, NULL, 'v' },
   { "version", no_argument, NULL, 'V' },
@@ -266,6 +273,7 @@ main (argc, argv)
 	break;
       case 'd':
 	java_class_directory = optarg;
+	tcl_base_directory = optarg;
 	break;
       case 'D':
 	dir_list_append (optarg);
@@ -281,6 +289,7 @@ main (argc, argv)
 	break;
       case 'l':
 	java_locale_name = optarg;
+	tcl_locale_name = optarg;
 	break;
       case 'o':
 	output_file_name = optarg;
@@ -326,6 +335,9 @@ main (argc, argv)
       case CHAR_MAX + 6:
 	no_hash_table = true;
 	break;
+      case CHAR_MAX + 7:
+	tcl_mode = true;
+	break;
       default:
 	usage (EXIT_FAILURE);
 	break;
@@ -357,18 +369,43 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\
     }
 
   /* Check for contradicting options.  */
+  if (java_mode && tcl_mode)
+    error (EXIT_FAILURE, 0, _("%s and %s are mutually exclusive"),
+	   "--java", "--tcl");
   if (java_mode)
     {
       if (output_file_name != NULL)
 	{
 	  error (EXIT_FAILURE, 0, _("%s and %s are mutually exclusive"),
-		 "--java-mode", "--output-file");
+		 "--java", "--output-file");
 	}
       if (java_class_directory == NULL)
 	{
 	  error (EXIT_SUCCESS, 0,
 		 _("%s requires a \"-d directory\" specification"),
-		 "--java-mode");
+		 "--java");
+	  usage (EXIT_FAILURE);
+	}
+    }
+  else if (tcl_mode)
+    {
+      if (output_file_name != NULL)
+	{
+	  error (EXIT_FAILURE, 0, _("%s and %s are mutually exclusive"),
+		 "--tcl", "--output-file");
+	}
+      if (tcl_locale_name == NULL)
+	{
+	  error (EXIT_SUCCESS, 0,
+		 _("%s requires a \"-l locale\" specification"),
+		 "--tcl");
+	  usage (EXIT_FAILURE);
+	}
+      if (tcl_base_directory == NULL)
+	{
+	  error (EXIT_SUCCESS, 0,
+		 _("%s requires a \"-d directory\" specification"),
+		 "--tcl");
 	  usage (EXIT_FAILURE);
 	}
     }
@@ -377,19 +414,19 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\
       if (java_resource_name != NULL)
 	{
 	  error (EXIT_SUCCESS, 0, _("%s is only valid with %s"),
-		 "--resource", "--java-mode");
+		 "--resource", "--java");
 	  usage (EXIT_FAILURE);
 	}
       if (java_locale_name != NULL)
 	{
-	  error (EXIT_SUCCESS, 0, _("%s is only valid with %s"),
-		 "--locale", "--java-mode");
+	  error (EXIT_SUCCESS, 0, _("%s is only valid with %s or %s"),
+		 "--locale", "--java", "--tcl");
 	  usage (EXIT_FAILURE);
 	}
       if (java_class_directory != NULL)
 	{
-	  error (EXIT_SUCCESS, 0, _("%s is only valid with %s"),
-		 "-d", "--java-mode");
+	  error (EXIT_SUCCESS, 0, _("%s is only valid with %s or %s"),
+		 "-d", "--java", "--tcl");
 	  usage (EXIT_FAILURE);
 	}
     }
@@ -440,6 +477,12 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\
 				    assume_java2))
 	    exit_status = EXIT_FAILURE;
 	}
+      else if (tcl_mode)
+	{
+	  if (msgdomain_write_tcl (domain->mlp,
+				   tcl_locale_name, tcl_base_directory))
+	    exit_status = EXIT_FAILURE;
+	}
       else
 	{
 	  if (msgdomain_write_mo (domain->mlp, domain->domain_name,
@@ -514,6 +557,7 @@ If input file is -, standard input is read.\n\
 Operation mode:\n\
   -j, --java                  Java mode: generate a Java ResourceBundle class\n\
       --java2                 like --java, and assume Java2 (JDK 1.2 or higher)\n\
+      --tcl                   Tcl mode: generate a tcl/msgcat .msg file\n\
 "));
       printf ("\n");
       /* xgettext: no-wrap */
@@ -537,6 +581,15 @@ written under the specified directory.\n\
       printf ("\n");
       /* xgettext: no-wrap */
       printf (_("\
+Output file location in Tcl mode:\n\
+  -l, --locale=LOCALE         locale name, either language or language_COUNTRY\n\
+  -d DIRECTORY                base directory of .msg message catalogs\n\
+The -l and -d options are mandatory.  The .msg file is written in the\n\
+specified directory.\n\
+"));
+      printf ("\n");
+      /* xgettext: no-wrap */
+      printf (_("\
 Input file interpretation:\n\
   -c, --check                 perform all the checks implied by\n\
                                 --check-format, --check-header, --check-domain\n\
@@ -1336,7 +1389,7 @@ format_directive_domain (pop, name)
 {
   /* If no output file was given, we change it with each `domain'
      directive.  */
-  if (!java_mode && output_file_name == NULL)
+  if (!java_mode && !tcl_mode && output_file_name == NULL)
     {
       size_t correct;
 
diff --git a/src/msgunfmt.c b/src/msgunfmt.c
index 23ffea2..0dbce68 100644
--- a/src/msgunfmt.c
+++ b/src/msgunfmt.c
@@ -21,6 +21,7 @@
 #endif
 
 #include <getopt.h>
+#include <limits.h>
 #include <stdbool.h>
 #include <stdio.h>
 #include <stdlib.h>
@@ -34,6 +35,7 @@
 #include "msgunfmt.h"
 #include "read-mo.h"
 #include "read-java.h"
+#include "read-tcl.h"
 #include "write-po.h"
 #include "gettext.h"
 
@@ -48,6 +50,11 @@ static bool java_mode;
 static const char *java_resource_name;
 static const char *java_locale_name;
 
+/* Tcl mode input file specification.  */
+static bool tcl_mode;
+static const char *tcl_locale_name;
+static const char *tcl_base_directory;
+
 /* Force output of PO file even if empty.  */
 static int force_po;
 
@@ -65,6 +72,7 @@ static const struct option long_options[] =
   { "resource", required_argument, NULL, 'r' },
   { "sort-output", no_argument, NULL, 's' },
   { "strict", no_argument, NULL, 'S' },
+  { "tcl", no_argument, NULL, CHAR_MAX + 1 },
   { "verbose", no_argument, NULL, 'v' },
   { "version", no_argument, NULL, 'V' },
   { "width", required_argument, NULL, 'w', },
@@ -102,8 +110,8 @@ main (argc, argv)
   bindtextdomain (PACKAGE, LOCALEDIR);
   textdomain (PACKAGE);
 
-  while ((optchar = getopt_long (argc, argv, "eEhijl:o:r:svVw:", long_options,
-				 NULL))
+  while ((optchar = getopt_long (argc, argv, "d:eEhijl:o:r:svVw:",
+				 long_options, NULL))
 	 != EOF)
     switch (optchar)
       {
@@ -111,6 +119,10 @@ main (argc, argv)
 	/* long option */
 	break;
 
+      case 'd':
+	tcl_base_directory = optarg;
+	break;
+
       case 'e':
 	message_print_style_escape (false);
 	break;
@@ -133,6 +145,7 @@ main (argc, argv)
 
       case 'l':
 	java_locale_name = optarg;
+	tcl_locale_name = optarg;
 	break;
 
       case 'o':
@@ -169,6 +182,10 @@ main (argc, argv)
 	}
 	break;
 
+      case CHAR_MAX + 1:
+	tcl_mode = true;
+	break;
+
       default:
 	usage (EXIT_FAILURE);
 	break;
@@ -193,13 +210,39 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\
     usage (EXIT_SUCCESS);
 
   /* Check for contradicting options.  */
+  if (java_mode && tcl_mode)
+    error (EXIT_FAILURE, 0, _("%s and %s are mutually exclusive"),
+	   "--java", "--tcl");
   if (java_mode)
     {
       if (optind < argc)
 	{
 	  error (EXIT_FAILURE, 0,
 		 _("%s and explicit file names are mutually exclusive"),
-		 "--java-mode");
+		 "--java");
+	}
+    }
+  else if (tcl_mode)
+    {
+      if (optind < argc)
+	{
+	  error (EXIT_FAILURE, 0,
+		 _("%s and explicit file names are mutually exclusive"),
+		 "--tcl");
+	}
+      if (tcl_locale_name == NULL)
+	{
+	  error (EXIT_SUCCESS, 0,
+		 _("%s requires a \"-l locale\" specification"),
+		 "--tcl");
+	  usage (EXIT_FAILURE);
+	}
+      if (tcl_base_directory == NULL)
+	{
+	  error (EXIT_SUCCESS, 0,
+		 _("%s requires a \"-d directory\" specification"),
+		 "--tcl");
+	  usage (EXIT_FAILURE);
 	}
     }
   else
@@ -207,13 +250,13 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\
       if (java_resource_name != NULL)
 	{
 	  error (EXIT_SUCCESS, 0, _("%s is only valid with %s"),
-		 "--resource", "--java-mode");
+		 "--resource", "--java");
 	  usage (EXIT_FAILURE);
 	}
       if (java_locale_name != NULL)
 	{
 	  error (EXIT_SUCCESS, 0, _("%s is only valid with %s"),
-		 "--locale", "--java-mode");
+		 "--locale", "--java");
 	  usage (EXIT_FAILURE);
 	}
     }
@@ -223,6 +266,10 @@ warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\
     {
       result = msgdomain_read_java (java_resource_name, java_locale_name);
     }
+  else if (tcl_mode)
+    {
+      result = msgdomain_read_tcl (tcl_locale_name, tcl_base_directory);
+    }
   else
     {
       message_list_ty *mlp;
@@ -281,7 +328,8 @@ Mandatory arguments to long options are mandatory for short options too.\n\
       /* xgettext: no-wrap */
       printf (_("\
 Operation mode:\n\
-  -j, --java               Java mode: generate a Java ResourceBundle class\n\
+  -j, --java               Java mode: input is a Java ResourceBundle class\n\
+      --tcl                Tcl mode: input is a tcl/msgcat .msg file\n\
 "));
       printf ("\n");
       /* xgettext: no-wrap */
@@ -302,6 +350,15 @@ separated with an underscore.  The class is located using the CLASSPATH.\n\
       printf ("\n");
       /* xgettext: no-wrap */
       printf (_("\
+Input file location in Tcl mode:\n\
+  -l, --locale=LOCALE      locale name, either language or language_COUNTRY\n\
+  -d DIRECTORY             base directory of .msg message catalogs\n\
+The -l and -d options are mandatory.  The .msg file is located in the\n\
+specified directory.\n\
+"));
+      printf ("\n");
+      /* xgettext: no-wrap */
+      printf (_("\
 Output file location:\n\
   -o, --output-file=FILE   write output to specified file\n\
 The results are written to standard output if no output file is specified\n\
diff --git a/src/read-tcl.c b/src/read-tcl.c
new file mode 100644
index 0000000..49c0aed
--- /dev/null
+++ b/src/read-tcl.c
@@ -0,0 +1,155 @@
+/* Reading tcl/msgcat .msg files.
+   Copyright (C) 2002 Free Software Foundation, Inc.
+   Written by Bruno Haible <bruno@clisp.org>, 2002.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2, or (at your option)
+   any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software Foundation,
+   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+#include "liballoca.h"
+
+/* Specification.  */
+#include "read-tcl.h"
+
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#include "msgunfmt.h"
+#include "pathname.h"
+#include "sh-quote.h"
+#include "pipe.h"
+#include "wait-process.h"
+#include "read-po.h"
+#include "error.h"
+#include "exit.h"
+#include "gettext.h"
+
+#define _(str) gettext (str)
+
+
+/* A Tcl .msg file contains Tcl commands.  It is best interpreted by Tcl
+   itself.  But we redirect the msgcat::mcset function so that it passes
+   the msgid/msgstr pair to us, instead of storing it in the hash table.  */
+
+msgdomain_list_ty *
+msgdomain_read_tcl (locale_name, directory)
+     const char *locale_name;
+     const char *directory;
+{
+  const char *gettextdatadir;
+  char *tclscript;
+  size_t len;
+  char *frobbed_locale_name;
+  char *p;
+  char *file_name;
+  char *argv[4];
+  pid_t child;
+  int fd[1];
+  FILE *fp;
+  msgdomain_list_ty *mdlp;
+  int exitstatus;
+  size_t k;
+
+  /* Make it possible to override the msgunfmt.tcl location.  This is
+     necessary for running the testsuite before "make install".  */
+  gettextdatadir = getenv ("GETTEXTDATADIR");
+  if (gettextdatadir == NULL || gettextdatadir[0] == '\0')
+    gettextdatadir = GETTEXTDATADIR;
+
+  tclscript = concatenated_pathname (gettextdatadir, "msgunfmt.tcl", NULL);
+
+  /* Convert the locale name to lowercase and remove any encoding.  */
+  len = strlen (locale_name);
+  frobbed_locale_name = (char *) alloca (len + 1);
+  memcpy (frobbed_locale_name, locale_name, len + 1);
+  for (p = frobbed_locale_name; *p != '\0'; p++)
+    if (*p >= 'A' && *p <= 'Z')
+      *p = *p - 'A' + 'a';
+    else if (*p == '.')
+      {
+	*p = '\0';
+	break;
+      }
+
+  file_name = concatenated_pathname (directory, frobbed_locale_name, ".msg");
+
+  /* Prepare arguments.  */
+  argv[0] = "tclsh";
+  argv[1] = tclscript;
+  argv[2] = file_name;
+  argv[3] = NULL;
+
+  if (verbose)
+    {
+      char *command = shell_quote_argv (argv);
+      printf ("%s\n", command);
+      free (command);
+    }
+
+  /* Open a pipe to the Tcl interpreter.  */
+  child = create_pipe_in ("tclsh", "tclsh", argv, "/dev/null", false, true,
+			  fd);
+
+  fp = fdopen (fd[0], "r");
+  if (fp == NULL)
+    error (EXIT_FAILURE, errno, _("fdopen() failed"));
+
+  /* Read the message list.  */
+  mdlp = read_po (fp, "(pipe)", "(pipe)");
+
+  fclose (fp);
+
+  /* Remove zombie process from process list, and retrieve exit status.  */
+  exitstatus = wait_subprocess (child, "tclsh", true);
+  if (exitstatus != 0)
+    {
+      if (exitstatus == 2)
+	/* Special exitcode provided by msgunfmt.tcl.  */
+	error (EXIT_FAILURE, ENOENT,
+	       _("error while opening \"%s\" for reading"), file_name);
+      else
+	error (EXIT_FAILURE, 0, _("%s subprocess failed with exit code %d"),
+	       "tclsh", exitstatus);
+    }
+
+  free (tclscript);
+
+  /* Move the header entry to the beginning.  */
+  for (k = 0; k < mdlp->nitems; k++)
+    {
+      message_list_ty *mlp = mdlp->item[k]->messages;
+      size_t j;
+
+      for (j = 0; j < mlp->nitems; j++)
+	if (mlp->item[j]->msgid[0] == '\0')
+	  {
+	    /* Found the header entry.  */
+	    if (j > 0)
+	      {
+		message_ty *header = mlp->item[j];
+		size_t i;
+
+		for (i = j; i > 0; i--)
+		  mlp->item[i] = mlp->item[i - 1];
+		mlp->item[0] = header;
+	      }
+	    break;
+	  }
+    }
+
+  return mdlp;
+}
diff --git a/src/read-tcl.h b/src/read-tcl.h
new file mode 100644
index 0000000..5ffcfaf
--- /dev/null
+++ b/src/read-tcl.h
@@ -0,0 +1,30 @@
+/* Reading tcl/msgcat .msg files.
+   Copyright (C) 2002 Free Software Foundation, Inc.
+   Written by Bruno Haible <bruno@clisp.org>, 2002.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2, or (at your option)
+   any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software Foundation,
+   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
+
+#ifndef _READ_TCL_H
+#define _READ_TCL_H
+
+#include "message.h"
+
+/* Read the Tcl msg file given by locale_name and directory.
+   Returns a list of messages.  */
+extern msgdomain_list_ty *
+       msgdomain_read_tcl PARAMS ((const char *locale_name,
+				   const char *directory));
+
+#endif /* _READ_TCL_H */
diff --git a/src/write-tcl.c b/src/write-tcl.c
new file mode 100644
index 0000000..0ba0337
--- /dev/null
+++ b/src/write-tcl.c
@@ -0,0 +1,221 @@
+/* Writing tcl/msgcat .msg files.
+   Copyright (C) 2002 Free Software Foundation, Inc.
+   Written by Bruno Haible <bruno@clisp.org>, 2002.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2, or (at your option)
+   any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software Foundation,
+   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+#include "liballoca.h"
+
+/* Specification.  */
+#include "write-tcl.h"
+
+#include <errno.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "error.h"
+#include "xerror.h"
+#include "message.h"
+#include "msgl-iconv.h"
+#include "po-charset.h"
+#include "xmalloc.h"
+#include "pathname.h"
+#include "exit.h"
+#include "utf8-ucs4.h"
+#include "gettext.h"
+
+#define _(str) gettext (str)
+
+
+/* Prototypes for local functions.  Needed to ensure compiler checking of
+   function argument counts despite of K&R C function definition syntax.  */
+static void write_tcl_string PARAMS ((FILE *stream, const char *str));
+static void write_msg PARAMS ((FILE *output_file, message_list_ty *mlp,
+			       const char *locale_name));
+
+
+/* Write a string in Tcl Unicode notation to the given stream.
+   Tcl 8 uses Unicode for its internal string representation.
+   In tcl-8.3.3, the .msg files are read in using the locale dependent
+   encoding.  The only way to specify strings in an encoding independent
+   form is the \unnnn notation.  Newer tcl versions have this fixed:
+   they read the .msg files in UTF-8 encoding.  */
+static void
+write_tcl_string (stream, str)
+     FILE *stream;
+     const char *str;
+{
+  static const char hexdigit[] = "0123456789abcdef";
+  const char *str_limit = str + strlen (str);
+
+  fprintf (stream, "\"");
+  while (str < str_limit)
+    {
+      unsigned int uc;
+      unsigned int count;
+      count = u8_mbtouc (&uc, str, str_limit - str);
+      if (uc < 0x10000)
+	{
+	  /* Single UCS-2 'char'.  */
+	  if (uc == 0x000a)
+	    fprintf (stream, "\\n");
+	  else if (uc == 0x000d)
+	    fprintf (stream, "\\r");
+	  else if (uc == 0x0022)
+	    fprintf (stream, "\\\"");
+	  else if (uc == 0x0024)
+	    fprintf (stream, "\\$");
+	  else if (uc == 0x005b)
+	    fprintf (stream, "\\[");
+	  else if (uc == 0x005c)
+	    fprintf (stream, "\\\\");
+	  else if (uc == 0x005d)
+	    fprintf (stream, "\\]");
+	  /* No need to escape '{' and '}' because we don't have opening
+	     braces outside the strings.  */
+#if 0
+	  else if (uc == 0x007b)
+	    fprintf (stream, "\\{");
+	  else if (uc == 0x007d)
+	    fprintf (stream, "\\}");
+#endif
+	  else if (uc >= 0x0020 && uc < 0x007f)
+	    fprintf (stream, "%c", uc);
+	  else
+	    fprintf (stream, "\\u%c%c%c%c",
+		     hexdigit[(uc >> 12) & 0x0f], hexdigit[(uc >> 8) & 0x0f],
+		     hexdigit[(uc >> 4) & 0x0f], hexdigit[uc & 0x0f]);
+	}
+      else
+	/* The \unnnn notation doesn't support characters >= 0x10000.
+	   We output them as UTF-8 byte sequences and hope that either
+	   the Tcl version reading them will be new enough or that the
+	   user is using an UTF-8 locale.  */
+	fwrite (str, 1, count, stream);
+      str += count;
+    }
+  fprintf (stream, "\"");
+}
+
+
+static void
+write_msg (output_file, mlp, locale_name)
+     FILE *output_file;
+     message_list_ty *mlp;
+     const char *locale_name;
+{
+  size_t j;
+
+  /* We don't care about esthetic formattic of the output (like respecting
+     a maximum line width, or including the translator comments) because
+     the \unnnn notation is unesthetic anyway.  Translators shall edit
+     the PO file.  */
+  for (j = 0; j < mlp->nitems; j++)
+    {
+      message_ty *mp = mlp->item[j];
+
+      if (mp->msgid[0] == '\0')
+	/* Tcl's msgcat unit ignores this, but msgunfmt needs it.  */
+	fprintf (output_file, "set ::msgcat::header ");
+      else
+	{
+	  fprintf (output_file, "::msgcat::mcset %s ", locale_name);
+	  write_tcl_string (output_file, mp->msgid);
+	  fprintf (output_file, " ");
+	}
+      write_tcl_string (output_file, mp->msgstr);
+      fprintf (output_file, "\n");
+    }
+}
+
+int
+msgdomain_write_tcl (mlp, locale_name, directory)
+     message_list_ty *mlp;
+     const char *locale_name;
+     const char *directory;
+{
+  /* If no entry for this domain don't even create the file.  */
+  if (mlp->nitems == 0)
+    return 0;
+
+  /* Determine whether mlp has plural entries.  */
+  {
+    bool has_plural;
+    size_t j;
+
+    has_plural = false;
+    for (j = 0; j < mlp->nitems; j++)
+      if (mlp->item[j]->msgid_plural != NULL)
+	has_plural = true;
+    if (has_plural)
+      {
+	multiline_error (xstrdup (""),
+			 xstrdup (_("\
+message catalog has plural form translations\n\
+but the Tcl message catalog format doesn't support plural handling\n")));
+	return 1;
+      }
+  }
+
+  /* Convert the messages to Unicode.  */
+  iconv_message_list (mlp, NULL, po_charset_canonicalize ("UTF-8"));
+
+  /* Now create the file.  */
+  {
+    size_t len;
+    char *frobbed_locale_name;
+    char *p;
+    char *file_name;
+    FILE *output_file;
+
+    /* Convert the locale name to lowercase and remove any encoding.  */
+    len = strlen (locale_name);
+    frobbed_locale_name = (char *) alloca (len + 1);
+    memcpy (frobbed_locale_name, locale_name, len + 1);
+    for (p = frobbed_locale_name; *p != '\0'; p++)
+      if (*p >= 'A' && *p <= 'Z')
+	*p = *p - 'A' + 'a';
+      else if (*p == '.')
+	{
+	  *p = '\0';
+	  break;
+	}
+
+    file_name = concatenated_pathname (directory, frobbed_locale_name, ".msg");
+      
+    output_file = fopen (file_name, "w");
+    if (output_file == NULL)
+      {
+	error (0, errno, _("error while opening \"%s\" for writing"),
+	       file_name);
+	return 1;
+      }
+
+    write_msg (output_file, mlp, frobbed_locale_name);
+
+    /* Make sure nothing went wrong.  */
+    if (fflush (output_file) || ferror (output_file))
+      error (EXIT_FAILURE, errno, _("error while writing \"%s\" file"),
+	     file_name);
+
+    fclose (output_file);
+  }
+
+  return 0;
+}
diff --git a/src/write-tcl.h b/src/write-tcl.h
new file mode 100644
index 0000000..0ccb442
--- /dev/null
+++ b/src/write-tcl.h
@@ -0,0 +1,33 @@
+/* Writing tcl/msgcat .msg files.
+   Copyright (C) 2002 Free Software Foundation, Inc.
+   Written by Bruno Haible <bruno@clisp.org>, 2002.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2, or (at your option)
+   any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software Foundation,
+   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
+
+#ifndef _WRITE_TCL_H
+#define _WRITE_TCL_H
+
+#include "message.h"
+
+/* Write a Tcl msg file.  mlp is a list containing the messages to be output.
+   locale_name is the locale name (with underscore separators), directory is
+   the base directory.
+   Return 0 if ok, nonzero on error.  */
+extern int
+       msgdomain_write_tcl PARAMS ((message_list_ty *mlp,
+				    const char *locale_name,
+				    const char *directory));
+
+#endif /* _WRITE_TCL_H */
diff --git a/src/x-tcl.c b/src/x-tcl.c
new file mode 100644
index 0000000..7f5ec60
--- /dev/null
+++ b/src/x-tcl.c
@@ -0,0 +1,1033 @@
+/* xgettext Tcl backend.
+   Copyright (C)2002 Free Software Foundation, Inc.
+
+   This file was written by Bruno Haible <haible@clisp.cons.org>, 2002.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2, or (at your option)
+   any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software Foundation,
+   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
+
+#ifdef HAVE_CONFIG_H
+# include "config.h"
+#endif
+
+#include <assert.h>
+#include <errno.h>
+#include <limits.h>
+#include <stdbool.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "message.h"
+#include "x-tcl.h"
+#include "xgettext.h"
+#include "error.h"
+#include "xmalloc.h"
+#include "exit.h"
+#include "hash.h"
+#include "c-ctype.h"
+#include "po-charset.h"
+#include "msgl-ascii.h"
+#include "msgl-iconv.h"
+#include "ucs4-utf8.h"
+#include "gettext.h"
+
+#define _(s) gettext(s)
+
+#if HAVE_C_BACKSLASH_A
+# define ALERT_CHAR '\a'
+#else
+# define ALERT_CHAR '\7'
+#endif
+
+
+/* The Tcl syntax is defined in the Tcl.n manual page.
+   Summary of Tcl syntax:
+   Like sh syntax, except that `...` is replaced with [...]. In detail:
+   - In a preprocessing pass, backslash-newline-anywhitespace is replaced
+     with single space.
+   - Input is broken into words, which are then subject to command
+     substitution [...] , variable substitution $var, backslash substitution
+     \escape.
+   - Strings are enclosed in "..."; command substitution, variable
+     substitution and backslash substitutions are performed here as well.
+   - {...} is a string without substitutions.
+   - The list of resulting words is split into commands by semicolon and
+     newline.
+   - '#' at the beginning of a command introduces a comment until end of line.
+   The parser is implemented in tcl8.3.3/generic/tclParse.c.  */
+
+
+/* Prototypes for local functions.  Needed to ensure compiler checking of
+   function argument counts despite of K&R C function definition syntax.  */
+struct token;
+struct word;
+static void init_keywords PARAMS ((void));
+static int do_getc PARAMS ((void));
+static void do_ungetc PARAMS ((int c));
+static int phase1_getc PARAMS ((void));
+static void phase1_ungetc PARAMS ((int c));
+static int phase2_push PARAMS ((void));
+static void phase2_pop PARAMS ((int previous_depth));
+static int phase2_getc PARAMS ((void));
+static void phase2_ungetc PARAMS ((int c));
+static inline void init_token PARAMS ((struct token *tp));
+static inline void free_token PARAMS ((struct token *tp));
+static inline void grow_token PARAMS ((struct token *tp));
+static inline void comment_start PARAMS ((void));
+static inline void comment_add PARAMS ((int c));
+static inline void comment_line_end PARAMS ((void));
+static inline void free_word PARAMS ((struct word *wp));
+static char * string_of_word PARAMS ((const struct word *wp));
+static int do_getc_escaped PARAMS ((void));
+
+
+/* ====================== Keyword set customization.  ====================== */
+
+/* If true extract all strings.  */
+static bool extract_all = false;
+
+static hash_table keywords;
+static bool default_keywords = true;
+
+
+void
+x_tcl_extract_all ()
+{
+  extract_all = true;
+}
+
+
+void
+x_tcl_keyword (name)
+     const char *name;
+{
+  if (name == NULL)
+    default_keywords = false;
+  else
+    {
+      const char *end;
+      int argnum1;
+      int argnum2;
+
+      if (keywords.table == NULL)
+	init_hash (&keywords, 100);
+
+      split_keywordspec (name, &end, &argnum1, &argnum2);
+
+      /* The characters between name and end should form a valid Tcl
+	 function name.  A leading "::" is redundant.  */
+      if (end - name >= 2 && name[0] == ':' && name[1] == ':')
+	name += 2;
+
+      if (argnum1 == 0)
+	argnum1 = 1;
+      insert_entry (&keywords, name, end - name,
+		    (void *) (long) (argnum1 + (argnum2 << 10)));
+    }
+}
+
+/* Finish initializing the keywords hash table.
+   Called after argument processing, before each file is processed.  */
+static void
+init_keywords ()
+{
+  if (default_keywords)
+    {
+      x_tcl_keyword ("::msgcat::mc");
+      default_keywords = false;
+    }
+}
+
+
+/* ======================== Reading of characters.  ======================== */
+
+/* Real filename, used in error messages about the input file.  */
+static const char *real_file_name;
+
+/* Logical filename and line number, used to label the extracted messages.  */
+static char *logical_file_name;
+static int line_number;
+
+/* The input file stream.  */
+static FILE *fp;
+
+
+/* Fetch the next character from the input file.  */
+static int
+do_getc ()
+{
+  int c = getc (fp);
+
+  if (c == EOF)
+    {
+      if (ferror (fp))
+	error (EXIT_FAILURE, errno, _("\
+error while reading \"%s\""), real_file_name);
+    }
+  else if (c == '\n')
+   line_number++;
+
+  return c;
+}
+
+/* Put back the last fetched character, not EOF.  */
+static void
+do_ungetc (c)
+     int c;
+{
+  if (c == '\n')
+    line_number--;
+  ungetc (c, fp);
+}
+
+
+/* Combine backslash followed by newline and additional whitespace to
+   a single space.  Cope with potentially 2 characters of pushback.  */
+
+/* An int that becomes a space when casted to 'unsigned char'.  */
+#define BS_NL (UCHAR_MAX + 1 + ' ')
+
+/* Maximum used guaranteed to be < 4.  */
+static int phase1_pushback[4];
+static int phase1_pushback_length;
+
+static int
+phase1_getc ()
+{
+  int c;
+
+  if (phase1_pushback_length)
+    {
+      c = phase1_pushback[--phase1_pushback_length];
+      if (c == '\n' || c == BS_NL)
+	++line_number;
+      return c;
+    }
+  c = do_getc ();
+  if (c != '\\')
+    return c;
+  c = do_getc ();
+  if (c != '\n')
+    {
+      if (c != EOF)
+	do_ungetc (c);
+      return '\\';
+    }
+  for (;;)
+    {
+      c = do_getc ();
+      if (!(c == ' ' || c == '\t'))
+	break;
+    }
+  if (c != EOF)
+    do_ungetc (c);
+  return BS_NL;
+}
+
+static void
+phase1_ungetc (c)
+     int c;
+{
+  switch (c)
+    {
+    case EOF:
+      break;
+
+    case '\n':
+    case BS_NL:
+      --line_number;
+      /* FALLTHROUGH */
+
+    default:
+      phase1_pushback[phase1_pushback_length++] = c;
+      break;
+    }
+}
+
+
+/* Keep track of brace nesting depth.
+   When a word starts with an opening brace, a character group begins that
+   ends with the corresponding closing brace.  In theory these character
+   groups are string literals, but they are used by so many Tcl primitives
+   (proc, if, ...) as representing command lists, that we treat them as
+   command lists.  */
+
+/* An int that becomes a closing brace when casted to 'unsigned char'.  */
+#define CL_BRACE (UCHAR_MAX + 1 + '}')
+
+/* Maximum used guaranteed to be < 4.  */
+static int phase2_pushback[4];
+static int phase2_pushback_length;
+
+/* Brace nesting depth inside the current character group.  */
+static int brace_depth;
+
+static int
+phase2_push ()
+{
+  int previous_depth = brace_depth;
+  brace_depth = 1;
+  return previous_depth;
+}
+
+static void
+phase2_pop (previous_depth)
+     int previous_depth;
+{
+  brace_depth = previous_depth;
+}
+
+static int
+phase2_getc ()
+{
+  int c;
+
+  if (phase2_pushback_length)
+    {
+      c = phase2_pushback[--phase2_pushback_length];
+      if (c == '\n' || c == BS_NL)
+	++line_number;
+      else if (c == '{')
+	++brace_depth;
+      else if (c == '}')
+	--brace_depth;
+      return c;
+    }
+  c = phase1_getc ();
+  if (c == '{')
+    ++brace_depth;
+  else if (c == '}')
+    {
+      if (--brace_depth == 0)
+	c = CL_BRACE;
+    }
+  return c;
+}
+
+static void
+phase2_ungetc (c)
+     int c;
+{
+  if (c != EOF)
+    {
+      switch (c)
+	{
+	case '\n':
+	case BS_NL:
+	  --line_number;
+	  break;
+
+	case '{':
+	  --brace_depth;
+	  break;
+
+	case '}':
+	  ++brace_depth;
+	  break;
+	}
+      phase2_pushback[phase2_pushback_length++] = c;
+    }
+}
+
+
+/* ========================== Reading of tokens.  ========================== */
+
+
+/* A token consists of a sequence of characters.  */
+struct token
+{
+  int allocated;		/* number of allocated 'token_char's */
+  int charcount;		/* number of used 'token_char's */
+  char *chars;			/* the token's constituents */
+};
+
+/* Initialize a 'struct token'.  */
+static inline void
+init_token (tp)
+     struct token *tp;
+{
+  tp->allocated = 10;
+  tp->chars = (char *) xmalloc (tp->allocated * sizeof (char));
+  tp->charcount = 0;
+}
+
+/* Free the memory pointed to by a 'struct token'.  */
+static inline void
+free_token (tp)
+     struct token *tp;
+{
+  free (tp->chars);
+}
+
+/* Ensure there is enough room in the token for one more character.  */
+static inline void
+grow_token (tp)
+     struct token *tp;
+{
+  if (tp->charcount == tp->allocated)
+    {
+      tp->allocated *= 2;
+      tp->chars = (char *) xrealloc (tp->chars, tp->allocated * sizeof (char));
+    }
+}
+
+
+/* ========================= Accumulating comments ========================= */
+
+
+static char *buffer;
+static size_t bufmax;
+static size_t buflen;
+
+static inline void
+comment_start ()
+{
+  buflen = 0;
+}
+
+static inline void
+comment_add (c)
+     int c;
+{
+  if (buflen >= bufmax)
+    {
+      bufmax += 100;
+      buffer = xrealloc (buffer, bufmax);
+    }
+  buffer[buflen++] = c;
+}
+
+static inline void
+comment_line_end ()
+{
+  while (buflen >= 1
+	 && (buffer[buflen - 1] == ' ' || buffer[buflen - 1] == '\t'))
+    --buflen;
+  if (buflen >= bufmax)
+    {
+      bufmax += 100;
+      buffer = xrealloc (buffer, bufmax);
+    }
+  buffer[buflen] = '\0';
+  xgettext_comment_add (buffer);
+}
+
+
+/* These are for tracking whether comments count as immediately before
+   keyword.  */
+static int last_comment_line;
+static int last_non_comment_line;
+
+
+/* ========================= Accumulating messages ========================= */
+
+
+static message_list_ty *mlp;
+
+
+/* ========================== Reading of commands ========================== */
+
+
+/* We are only interested in constant strings (e.g. "msgcat::mc" or other
+   string literals).  Other words need not to be represented precisely.  */
+enum word_type
+{
+  t_string,	/* constant string */
+  t_other,	/* other string */
+  t_separator,	/* command separator: semicolon or newline */
+  t_bracket,	/* ']' pseudo word */
+  t_brace,	/* '}' pseudo word */
+  t_eof		/* EOF marker */
+};
+
+struct word
+{
+  enum word_type type;
+  struct token *token;		/* for t_string */
+  int line_number_at_start;	/* for t_string */
+};
+
+/* Free the memory pointed to by a 'struct word'.  */
+static inline void
+free_word (wp)
+     struct word *wp;
+{
+  if (wp->type == t_string)
+    {
+      free_token (wp->token);
+      free (wp->token);
+    }
+}
+
+/* Convert a t_string token to a char*.  */
+static char *
+string_of_word (wp)
+     const struct word *wp;
+{
+  char *str;
+  int n;
+
+  if (!(wp->type == t_string))
+    abort ();
+  n = wp->token->charcount;
+  str = (char *) xmalloc (n + 1);
+  memcpy (str, wp->token->chars, n);
+  str[n] = '\0';
+  return str;
+}
+
+
+/* Read an escape sequence.  The value is an ISO-8859-1 character (in the
+   range 0x00..0xff) or a Unicode character (in the range 0x0000..0xffff).  */
+static int
+do_getc_escaped ()
+{
+  int c;
+
+  c = phase1_getc ();
+  switch (c)
+    {
+    case EOF:
+      return '\\';
+    case 'a':
+      return ALERT_CHAR;
+    case 'b':
+      return '\b';
+    case 'f':
+      return '\f';
+    case 'n':
+      return '\n';
+    case 'r':
+      return '\r';
+    case 't':
+      return '\t';
+    case 'v':
+      return '\v';
+    case 'x':
+      {
+	int n = 0;
+	unsigned int i;
+
+	for (i = 0;; i++)
+	  {
+	    c = phase1_getc ();
+	    if (c == EOF || !c_isxdigit ((unsigned char) c))
+	      break;
+
+	    if (c >= '0' && c <= '9')
+	      n = (n << 4) + (c - '0');
+	    else if (c >= 'A' && c <= 'F')
+	      n = (n << 4) + (c - 'A' + 10);
+	    else if (c >= 'a' && c <= 'f')
+	      n = (n << 4) + (c - 'a' + 10);
+	  }
+	phase1_ungetc (c);
+	return (i > 0 ? (unsigned char) n : 'x');
+      }
+    case 'u':
+      {
+	int n = 0;
+	unsigned int i;
+
+	for (i = 0; i < 4; i++)
+	  {
+	    c = phase1_getc ();
+	    if (c == EOF || !c_isxdigit ((unsigned char) c))
+	      break;
+
+	    if (c >= '0' && c <= '9')
+	      n = (n << 4) + (c - '0');
+	    else if (c >= 'A' && c <= 'F')
+	      n = (n << 4) + (c - 'A' + 10);
+	    else if (c >= 'a' && c <= 'f')
+	      n = (n << 4) + (c - 'a' + 10);
+	  }
+	phase1_ungetc (c);
+	return (i > 0 ? n : 'u');
+      }
+    case '0': case '1': case '2': case '3': case '4':
+    case '5': case '6': case '7':
+      {
+	int n = c - '0';
+
+        c = phase1_getc ();
+	if (c != EOF)
+	  {
+	    if (c >= '0' && c <= '7')
+	      {
+		n = (n << 3) + (c - '0');
+		c = phase1_getc ();
+		if (c != EOF)
+		  {
+		    if (c >= '0' && c <= '7')
+		      n = (n << 3) + (c - '0');
+		    else
+		      phase1_ungetc (c);
+		  }
+	      }
+	    else
+	      phase1_ungetc (c);
+	  }
+	return (unsigned char) n;
+      }
+    default:
+      /* Note: If c is non-ASCII, Tcl's behaviour is undefined here.  */
+      return (unsigned char) c;
+    }
+}
+
+
+enum terminator
+{
+  te_space_separator,		/* looking for space semicolon newline */
+  te_space_separator_bracket,	/* looking for space semicolon newline ']' */
+  te_paren,			/* looking for ')' */
+  te_quote			/* looking for '"' */
+};
+
+/* Prototypes for local functions.  Needed to ensure compiler checking of
+   function argument counts despite of K&R C function definition syntax.  */
+static int accumulate_word PARAMS ((struct word *wp,
+				    enum terminator looking_for));
+static void read_word PARAMS ((struct word *wp, int looking_for));
+static enum word_type read_command PARAMS ((int looking_for));
+static enum word_type read_command_list PARAMS ((int looking_for));
+
+/* Accumulate tokens into the given word.
+   'looking_for' denotes a parse terminator combination.  */
+static int
+accumulate_word (wp, looking_for)
+     struct word *wp;
+     enum terminator looking_for;
+{
+  int c;
+
+  for (;;)
+    {
+      c = phase2_getc ();
+
+      if (c == EOF || c == CL_BRACE)
+	return c;
+      if ((looking_for == te_space_separator
+	   || looking_for == te_space_separator_bracket)
+	  && (c == ' ' || c == BS_NL
+	      || c == '\t' || c == '\v' || c == '\f' || c == '\r'
+	      || c == ';' || c == '\n'))
+	return c;
+      if (looking_for == te_space_separator_bracket && c == ']')
+	return c;
+      if (looking_for == te_paren && c == ')')
+	return c;
+      if (looking_for == te_quote && c == '"')
+	return c;
+
+      if (c == '$')
+	{
+	  /* Distinguish $varname, ${varname} and lone $.  */
+	  c = phase2_getc ();
+	  if (c == '{')
+	    {
+	      /* ${varname} */
+	      do
+		c = phase2_getc ();
+	      while (c != EOF && c != '}');
+	      wp->type = t_other;
+	    }
+	  else
+	    {
+	      bool nonempty = false;
+
+	      for (; c != EOF && c != CL_BRACE; c = phase2_getc ())
+		{
+		  if (c_isalnum ((unsigned char) c) || (c == '_'))
+		    {
+		      nonempty = true;
+		      continue;
+		    }
+		  if (c == ':')
+		    {
+		      c = phase2_getc ();
+		      if (c == ':')
+			{
+			  do
+			    c = phase2_getc ();
+			  while (c == ':');
+
+			  phase2_ungetc (c);
+			  nonempty = true;
+			  continue;
+			}
+		      phase2_ungetc (c);
+		      c = ':';
+		    }
+		  break;
+		}
+	      if (c == '(')
+		{
+		  /* $varname(index) */
+		  struct word index_word;
+
+		  index_word.type = t_other;
+		  c = accumulate_word (&index_word, te_paren);
+		  if (c != EOF && c != ')')
+		    phase2_ungetc (c);
+		  wp->type = t_other;
+		}
+	      else
+		{
+		  phase2_ungetc (c);
+		  if (nonempty)
+		    {
+		      /* $varname */
+		      wp->type = t_other;
+		    }
+		  else
+		    {
+		      /* lone $ */
+		      if (wp->type == t_string)
+			{
+			  grow_token (wp->token);
+			  wp->token->chars[wp->token->charcount++] = '$';
+			}
+		    }
+		}
+	    }
+	}
+      else if (c == '[')
+	{
+	  read_command_list (']');
+	  wp->type = t_other;
+	}
+      else if (c == '\\')
+	{
+	  unsigned int uc;
+	  unsigned char utf8buf[6];
+	  int count;
+	  int i;
+
+	  uc = do_getc_escaped ();
+	  assert (uc < 0x10000);
+	  count = u8_uctomb (utf8buf, uc, 6);
+	  assert (count > 0);
+	  if (wp->type == t_string)
+	    for (i = 0; i < count; i++)
+	      {
+		grow_token (wp->token);
+		wp->token->chars[wp->token->charcount++] = utf8buf[i];
+	      }
+	}
+      else
+	{
+	  if (wp->type == t_string)
+	    {
+	      grow_token (wp->token);
+	      wp->token->chars[wp->token->charcount++] = (unsigned char) c;
+	    }
+	}
+    }
+}
+
+
+/* Read the next word.
+   'looking_for' denotes a parse terminator, either ']' or '\0'.  */
+static void
+read_word (wp, looking_for)
+     struct word *wp;
+     int looking_for;
+{
+  int c;
+
+  do
+    c = phase2_getc ();
+  while (c == ' ' || c == BS_NL);
+
+  if (c == EOF)
+    {
+      wp->type = t_eof;
+      return;
+    }
+
+  if (c == CL_BRACE)
+    {
+      wp->type = t_brace;
+      last_non_comment_line = line_number;
+      return;
+    }
+
+  if (c == '\n')
+    {
+      /* Comments assumed to be grouped with a message must immediately
+	 precede it, with no non-whitespace token on a line between both.  */
+      if (last_non_comment_line > last_comment_line)
+	xgettext_comment_reset ();
+      wp->type = t_separator;
+      return;
+    }
+
+  if (c == ';')
+    {
+      wp->type = t_separator;
+      last_non_comment_line = line_number;
+      return;
+    }
+
+  if (looking_for == ']' && c == ']')
+    {
+      wp->type = t_bracket;
+      last_non_comment_line = line_number;
+      return;
+    }
+
+  if (c == '{')
+    {
+      int previous_depth;
+      enum word_type terminator;
+
+      /* Start a new nested character group, which lasts until the next
+	 balanced '}' (ignoring \} things).  */
+      previous_depth = phase2_push () - 1;
+
+      /* Interpret it as a command list.  */
+      terminator = read_command_list ('\0');
+
+      if (terminator == t_brace)
+	phase2_pop (previous_depth);
+
+      wp->type = t_other;
+      last_non_comment_line = line_number;
+      return;
+    }
+
+  wp->type = t_string;
+  wp->token = (struct token *) xmalloc (sizeof (struct token));
+  init_token (wp->token);
+  wp->line_number_at_start = line_number;
+
+  if (c == '"')
+    {
+      c = accumulate_word (wp, te_quote);
+      if (c != EOF && c != '"')
+	phase2_ungetc (c);
+    }
+  else
+    {
+      phase2_ungetc (c);
+      c = accumulate_word (wp,
+			   looking_for == ']'
+			   ? te_space_separator_bracket
+			   : te_space_separator);
+      if (c != EOF)
+	phase2_ungetc (c);
+    }
+
+  if (wp->type != t_string)
+    {
+      free_token (wp->token);
+      free (wp->token);
+    }
+  last_non_comment_line = line_number;
+}
+
+
+/* Read the next command.
+   'looking_for' denotes a parse terminator, either ']' or '\0'.
+   Returns the type of the word that terminated the command: t_separator or
+   t_bracket (only if looking_for is ']') or t_brace or t_eof.  */
+static enum word_type
+read_command (looking_for)
+     int looking_for;
+{
+  int c;
+
+  /* Skip whitespace and comments.  */
+  for (;;)
+    {
+      c = phase2_getc ();
+
+      if (c == ' ' || c == BS_NL
+	  || c == '\t' || c == '\v' || c == '\f' || c == '\r')
+	continue;
+      if (c == '#')
+	{
+	  /* Skip a comment up to end of line.  */
+	  last_comment_line = line_number;
+	  comment_start ();
+	  for (;;)
+	    {
+	      c = phase2_getc ();
+	      if (c == EOF || c == CL_BRACE || c == '\n')
+		break;
+	      comment_add (c);
+	    }
+	  comment_line_end ();
+	  continue;
+	}
+      break;
+    }
+  phase2_ungetc (c);
+
+  /* Read the words that make up the command.  */
+  {
+    int arg = 0;		/* Current argument number.  */
+    int argnum1 = 0;		/* First string position.  */
+    int argnum2 = 0;		/* Plural string position.  */
+    message_ty *plural_mp = NULL;	/* Remember the msgid.  */
+
+    for (;; arg++)
+      {
+	struct word inner;
+
+	read_word (&inner, looking_for);
+
+	/* Recognize end of command.  */
+	if (inner.type == t_separator || inner.type == t_bracket
+	    || inner.type == t_brace || inner.type == t_eof)
+	  return inner.type;
+
+	if (extract_all)
+	  {
+	    if (inner.type == t_string)
+	      {
+		lex_pos_ty pos;
+
+		pos.file_name = logical_file_name;
+		pos.line_number = inner.line_number_at_start;
+		remember_a_message (mlp, string_of_word (&inner), &pos);
+	      }
+	  }
+	else
+	  {
+	    if (arg == 0)
+	      {
+		/* This is the function position.  */
+		if (inner.type == t_string)
+		  {
+		    char *function_name = string_of_word (&inner);
+		    char *stripped_name;
+		    void *keyword_value;
+
+		    /* A leading "::" is redundant.  */
+		    stripped_name = function_name;
+		    if (function_name[0] == ':' && function_name[1] == ':')
+		      stripped_name += 2;
+
+		    if (find_entry (&keywords,
+				    stripped_name, strlen (stripped_name),
+				    &keyword_value)
+			== 0)
+		      {
+			argnum1 = (int) (long) keyword_value & ((1 << 10) - 1);
+			argnum2 = (int) (long) keyword_value >> 10;
+		      }
+
+		    free (function_name);
+		  }
+	      }
+	    else
+	      {
+		/* These are the argument positions.
+		   Extract a string if we have reached the right
+		   argument position.  */
+		if (arg == argnum1)
+		  {
+		    if (inner.type == t_string)
+		      {
+			lex_pos_ty pos;
+			message_ty *mp;
+
+			pos.file_name = logical_file_name;
+			pos.line_number = inner.line_number_at_start;
+			mp = remember_a_message (mlp, string_of_word (&inner), &pos);
+			if (argnum2 > 0)
+			  plural_mp = mp;
+		      }
+		  }
+		else if (arg == argnum2)
+		  {
+		    if (inner.type == t_string && plural_mp != NULL)
+		      {
+			lex_pos_ty pos;
+
+			pos.file_name = logical_file_name;
+			pos.line_number = inner.line_number_at_start;
+			remember_a_message_plural (plural_mp, string_of_word (&inner), &pos);
+		      }
+		  }
+	      }
+	  }
+
+	free_word (&inner);
+      }
+  }
+}
+
+
+/* Read a list of commands.
+   'looking_for' denotes a parse terminator, either ']' or '\0'.
+   Returns the type of the word that terminated the command list:
+   t_bracket (only if looking_for is ']') or t_brace or t_eof.  */
+static enum word_type
+read_command_list (looking_for)
+     int looking_for;
+{
+  for (;;)
+    {
+      enum word_type terminator;
+
+      terminator = read_command (looking_for);
+      if (terminator != t_separator)
+	return terminator;
+    }
+}
+
+
+void
+extract_tcl (f, real_filename, logical_filename, mdlp)
+     FILE *f;
+     const char *real_filename;
+     const char *logical_filename;
+     msgdomain_list_ty *mdlp;
+{
+  mlp = mdlp->item[0]->messages;
+
+  fp = f;
+  real_file_name = real_filename;
+  logical_file_name = xstrdup (logical_filename);
+  line_number = 1;
+
+  /* Initially, no brace is open.  */
+  brace_depth = 1000000;
+
+  last_comment_line = -1;
+  last_non_comment_line = -1;
+
+  init_keywords ();
+
+  /* Eat tokens until eof is seen.  */
+  read_command_list ('\0');
+
+  /* We converted our strings to UTF-8 encoding.  If not all the strings
+     were plain ASCII, set the charset in the header to UTF-8.  */
+  if (!is_ascii_message_list (mlp))
+    {
+      const char *canon_utf_8 = po_charset_canonicalize ("UTF-8");
+      iconv_message_list (mlp, canon_utf_8, canon_utf_8);
+    }
+
+  fp = NULL;
+  real_file_name = NULL;
+  logical_file_name = NULL;
+  line_number = 0;
+}
diff --git a/src/x-tcl.h b/src/x-tcl.h
new file mode 100644
index 0000000..d2b39f7
--- /dev/null
+++ b/src/x-tcl.h
@@ -0,0 +1,35 @@
+/* xgettext Tcl Lisp backend.
+   Copyright (C) 2002 Free Software Foundation, Inc.
+   Written by Bruno Haible <haible@clisp.cons.org>, 2002.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2, or (at your option)
+   any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software Foundation,
+   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
+
+
+#define EXTENSIONS_TCL \
+  { "tcl",       "Tcl"           },					\
+
+#define SCANNERS_TCL \
+  { "Tcl",        extract_tcl, &formatstring_tcl },			\
+
+/* Scan a Tcl file and add its translatable strings to mdlp.  */
+extern void extract_tcl PARAMS ((FILE *fp, const char *real_filename,
+				 const char *logical_filename,
+				 msgdomain_list_ty *mdlp));
+
+
+/* Handling of options specific to this language.  */
+
+extern void x_tcl_extract_all PARAMS ((void));
+extern void x_tcl_keyword PARAMS ((const char *name));
diff --git a/src/xgettext.c b/src/xgettext.c
index c9381be..cc6a432 100644
--- a/src/xgettext.c
+++ b/src/xgettext.c
@@ -66,6 +66,7 @@
 #include "x-java.h"
 #include "x-awk.h"
 #include "x-ycp.h"
+#include "x-tcl.h"
 #include "x-rst.h"
 #include "x-glade.h"
 
@@ -232,6 +233,7 @@ main (argc, argv)
 	x_librep_extract_all ();
 	x_java_extract_all ();
 	x_awk_extract_all ();
+	x_tcl_extract_all ();
 	x_glade_extract_all ();
 	break;
       case 'c':
@@ -289,6 +291,7 @@ main (argc, argv)
 	    x_librep_keyword (optarg);
 	    x_java_keyword (optarg);
 	    x_awk_keyword (optarg);
+	    x_tcl_keyword (optarg);
 	    x_glade_keyword (optarg);
 	  }
 	break;
@@ -1260,6 +1263,7 @@ language_to_extractor (name)
     SCANNERS_JAVA
     SCANNERS_AWK
     SCANNERS_YCP
+    SCANNERS_TCL
     SCANNERS_RST
     SCANNERS_GLADE
     /* Here will follow more languages and their scanners: perl, etc...
@@ -1305,9 +1309,10 @@ extension_to_language (extension)
     EXTENSIONS_JAVA
     EXTENSIONS_AWK
     EXTENSIONS_YCP
+    EXTENSIONS_TCL
     EXTENSIONS_RST
     EXTENSIONS_GLADE
-    /* Here will follow more file extensions: sh, pl, tcl ... */
+    /* Here will follow more file extensions: sh, pl ... */
   };
 
   table_ty *tp;