Merge 8.6.5

http://www.mcvoy.com/lm/little/index.html

doc/L/pod2html.l

@@ -0,0 +1,253 @@
+#!../../unix/tclsh
+
+int
+main(string av[])
+{
+	FILE	f;
+	int	i, ul;
+	int	space = 0, dd = 0, p = 0, pre = 0;
+	string	buf, c, tmp, title, trim, all[];
+
+	/*
+	 * -t<title> or --title=<title>
+	 */
+	while (c = getopt(av, "t:", {"title:"})) {
+		switch (c) {
+		    case "t":
+		    case "title":
+			title = optarg;
+			break;
+		}
+	}
+	unless (av[optind] && (f = fopen(av[optind], "r"))) {
+		die("usage: ${av[0]} filename");
+	}
+	unless (title) title = av[optind];
+
+	header(title);
+
+	/*
+	 * Load up the whole file in all[] and spit out the index.
+	 */
+	puts("<ul>");
+	ul = 1;
+	while (buf = <f>) {
+		push(&all, buf);
+		if (buf =~ /^=head(\d+)\s+(.*)/) {
+			i = (int)$1;
+			while (ul > i) {
+				puts("</ul>");
+				ul--;
+			}
+			while (i > ul) {
+				puts("<ul>");
+				ul++;
+			}
+			tmp = $2;
+			tmp =~ s/\s+/_/g;
+			buf =~ s/^=head(\d+)\s+//;
+			puts("<li><a href=\"#${tmp}\">${buf}</a></li>");
+		}
+	}
+	while (ul--) puts("</ul>");
+	fclose(f);
+
+	/*
+	 * Now walk all[] and process the markup.  We currently handle:
+	 * =head%d title
+	 * =over
+	 * =item name
+	 * =proto return_type func(args)
+	 * =back
+	 * <blank line>
+	 * B<bold this>
+	 * C<some code>
+	 * I<italics>
+	 */
+	// The <= is intentional to run an empty string through at the end
+	// to kick out any final </pre> etc.
+	for (i = 0; i <= length(all); i++) {
+		buf = inline(all[i]);
+		if (buf =~ /^=head(\d+)\s+(.*)/) {
+			if ((int)$1 == 1) puts("<HR>");
+			tmp = $2;
+			tmp =~ s/\s+/_/g;
+			printf("<H%d><a name=\"%s\">%s</a></H%d>\n",
+			    $1, tmp, $2, $1);
+		} else if (buf =~ /^=over/) {
+			puts("<dl>");
+		} else if (buf =~ /^=item\s+(.*)/) {
+			if (dd) {
+				puts("</dd>");
+				dd--;
+			}
+			puts("<dt><strong>${$1}</strong></dt><dd>");
+			dd++;
+		} else if (buf =~ /^=proto\s+([^ \t]+)\s+(.*)/) {
+			if (dd) {
+				puts("</dd>");
+				dd--;
+			}
+			puts("<dt><b>${$1} ${$2}</b></dt><dd>");
+			dd++;
+		} else if (buf =~ /^=back/) {
+			if (dd) {
+				puts("</dd>");
+				dd--;
+			}
+			puts("</dl>");
+		} else if (buf =~ /^\s*$/) {
+			if (p) {
+				puts("</p>");
+				p = 0;
+			}
+			if (pre) {
+				/*
+				 * If we see a blank line in a preformatted
+				 * block, we don't want to stop the pre
+				 * unless the next line is not indented.
+				 * So peek ahead.
+				 */
+				if (defined(buf = all[i+1]) && (buf =~ /^\s/)) {
+					puts("");
+					continue;
+				}
+				puts("</pre>");
+				pre = 0;
+				trim = undef;
+			}
+			space = 1;
+		} else {
+			if (space) {
+				if (buf =~ /^(\s+)[^ \t]+/) {
+					trim = $1;
+					puts("<pre>");
+					pre = 1;
+				} else {
+					puts("<p>");
+					p = 1;
+				}
+				space = 0;
+			}
+			if (defined(trim)) buf =~ s/^${trim}//;
+			puts(buf);
+		}
+	}
+	puts("</body></html>");
+	return (0);
+}
+
+/*
+ * header and style sheet
+ */
+void
+header(string title)
+{
+	string	head = <<EOF
+<html>
+<head>
+<title>${title}</title>
+<style>
+pre {
+	background: #eeeedd;
+	border-width: 1px;
+	border-style: solid solid solid solid;
+	border-color: #ccc;
+	padding: 5px 5px 5px 5px;
+	font-family: monospace;
+	font-weight: bolder;
+}
+body {
+	padding-left: 10px;
+}
+dt {
+	font-size: large;
+}
+</style>
+</head>
+<body>
+EOF
+	puts(head);
+	puts("<h1>${title}</h1>");
+}
+
+/*
+ * Process B<bold>, C<code>, I<italic>, F<italic>, L<link>, S<non-breaking>.
+ * This will handle nested stuff like C<if (!I<condition>)>
+ * but dies if there are nested ones of the same type, i.e.,
+ * C<whatever C<some more>>
+ */
+string
+inline(string buf)
+{
+	string	c, prev, result = "", link, stack[];
+	int	B = 0, C = 0, I = 0, L = 0, S = 0;
+
+	unless (buf) buf = "";
+	foreach (c in buf) {
+		if ((c == "<") && prev) {
+			if (prev == "B") {
+				if (B++) die("Nested B<> unsupported: ${buf}");
+				result[END] = "";
+				result .= "<B>";
+				push(&stack, "B");
+			} else if (prev == "C") {
+				if (C++) die("Nested C<> unsupported: ${buf}");
+				result[END] = "";
+				result .= "<CODE>";
+				push(&stack, "CODE");
+			} else if (prev == "I" || prev == "F") {
+				if (I++) die("Nested I<> unsupported: ${buf}");
+				result[END] = "";
+				result .= "<I>";
+				push(&stack, "I");
+			} else if (prev == "L") {
+				if (L++) die("Nested L<> unsupported: ${buf}");
+				result[END] = "";
+				result .= "<a href=\"";
+				link = "";
+				push(&stack, "L");
+			} else if (prev == "S") {
+				if (S++) die("Nested S<> unsupported: ${buf}");
+				result[END] = "";
+				push(&stack, "S");
+			} else {
+				result .= "&lt;";
+				prev = c;
+			}
+		} else if ((c == ">") && length(stack)) {
+			c = pop(&stack);
+			if (c == "B") {
+				B--;
+			} else if (c == "CODE") {
+				C--;
+			} else if (c == "I") {
+				I--;
+			} else if (c == "L") {
+				L--;
+				result .= "\">${link}</a>";
+				c = undef;
+			} else {
+				S--;
+				c = undef;
+			}
+			if (c) {
+				result .= "</" . c . ">";
+			}
+			prev = undef;
+		} else {
+			if (S && isspace(c)) {
+				result .= "&nbsp;";
+			} else if (c == "<") {
+				result .= "&lt;";
+			} else if (c == ">") {
+				result .= "&gt;";
+			} else {
+				result .= c;
+			}
+			if (L) link .= c;
+			prev = c;
+		}
+	}
+	return (result);
+}

doc/L/pod2man

@@ -0,0 +1,513 @@
+#!/usr/bin/perl
+    eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
+        if $running_under_some_shell;
+
+# pod2man -- Convert POD data to formatted *roff input.
+# $Id: pod2man.PL,v 1.10 2002/07/15 05:45:56 eagle Exp $
+#
+# Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>
+#
+# This program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Man ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin (which Pod::Parser
+# does correctly).
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options, trying to retain backwards compatibility with pod2man but
+# allowing short forms as well.  --lax is currently ignored.
+my %options;
+Getopt::Long::config ('bundling_override');
+GetOptions (\%options, 'section|s=s', 'release|r:s', 'center|c=s',
+            'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s',
+            'fixedbolditalic=s', 'name|n=s', 'official|o', 'quotes|q=s',
+            'lax|l', 'help|h', 'verbose|v') or exit 1;
+pod2usage (0) if $options{help};
+
+# Official sets --center, but don't override things explicitly set.
+if ($options{official} && !defined $options{center}) {
+    $options{center} = 'Perl Programmers Reference Guide';
+}
+
+# Verbose is only our flag, not a Pod::Man flag.
+my $verbose = $options{verbose};
+delete $options{verbose};
+
+# This isn't a valid Pod::Man option and is only accepted for backwards
+# compatibility.
+delete $options{lax};
+
+# Initialize and run the formatter, pulling a pair of input and output off at
+# a time.
+my $parser = Pod::Man->new (%options);
+my @files;
+do {
+    @files = splice (@ARGV, 0, 2);
+    print "  $files[1]\n" if $verbose;
+    $parser->parse_from_file (@files);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2man - Convert POD data to formatted *roff input
+
+=head1 SYNOPSIS
+
+pod2man [B<--section>=I<manext>] [B<--release>=I<version>]
+[B<--center>=I<string>] [B<--date>=I<string>] [B<--fixed>=I<font>]
+[B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
+[B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--official>]
+[B<--lax>] [B<--quotes>=I<quotes>] [B<--verbose>]
+[I<input> [I<output>] ...]
+
+pod2man B<--help>
+
+=head1 DESCRIPTION
+
+B<pod2man> is a front-end for Pod::Man, using it to generate *roff input
+from POD source.  The resulting *roff code is suitable for display on a
+terminal using nroff(1), normally via man(1), or printing using troff(1).
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code).  If I<input> isn't given, it defaults to STDIN.  I<output>, if given,
+is the file to which to write the formatted output.  If I<output> isn't
+given, the formatted output is written to STDOUT.  Several POD files can be
+processed in the same B<pod2man> invocation (saving module load and compile
+times) by providing multiple pairs of I<input> and I<output> files on the
+command line.
+
+B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can be
+used to set the headers and footers to use; if not given, Pod::Man will
+assume various defaults.  See below or L<Pod::Man> for details.
+
+B<pod2man> assumes that your *roff formatters have a fixed-width font named
+CW.  If yours is called something else (like CR), use B<--fixed> to specify
+it.  This generally only matters for troff output for printing.  Similarly,
+you can set the fonts used for bold, italic, and bold italic fixed-width
+output.
+
+Besides the obvious pod conversions, Pod::Man, and therefore pod2man also
+takes care of formatting func(), func(n), and simple variable references
+like $foo or @bar so you don't have to use code escapes for them; complex
+expressions like C<$fred{'stuff'}> will still need to be escaped, though.
+It also translates dashes that aren't used as hyphens into en dashes, makes
+long dashes--like this--into proper em dashes, fixes "paired quotes," and
+takes care of several other troff-specific tweaks.  See L<Pod::Man> for
+complete information.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-c> I<string>, B<--center>=I<string>
+
+Sets the centered page header to I<string>.  The default is "User
+Contributed Perl Documentation", but also see B<--official> below.
+
+=item B<-d> I<string>, B<--date>=I<string>
+
+Set the left-hand footer string to this value.  By default, the modification
+date of the input file will be used, or the current date if input comes from
+STDIN.
+
+=item B<--fixed>=I<font>
+
+The fixed-width font to use for vertabim text and code.  Defaults to CW.
+Some systems may want CR instead.  Only matters for troff(1) output.
+
+=item B<--fixedbold>=I<font>
+
+Bold version of the fixed-width font.  Defaults to CB.  Only matters for
+troff(1) output.
+
+=item B<--fixeditalic>=I<font>
+
+Italic version of the fixed-width font (actually, something of a misnomer,
+since most fixed-width fonts only have an oblique version, not an italic
+version).  Defaults to CI.  Only matters for troff(1) output.
+
+=item B<--fixedbolditalic>=I<font>
+
+Bold italic (probably actually oblique) version of the fixed-width font.
+Pod::Man doesn't assume you have this, and defaults to CB.  Some systems
+(such as Solaris) have this font available as CX.  Only matters for troff(1)
+output.
+
+=item B<-h>, B<--help>
+
+Print out usage information.
+
+=item B<-l>, B<--lax>
+
+No longer used.  B<pod2man> used to check its input for validity as a manual
+page, but this should now be done by L<podchecker(1)> instead.  Accepted for
+backwards compatibility; this option no longer does anything.
+
+=item B<-n> I<name>, B<--name>=I<name>
+
+Set the name of the manual page to I<name>.  Without this option, the manual
+name is set to the uppercased base name of the file being converted unless
+the manual section is 3, in which case the path is parsed to see if it is a
+Perl module path.  If it is, a path like C<.../lib/Pod/Man.pm> is converted
+into a name like C<Pod::Man>.  This option, if given, overrides any
+automatic determination of the name.
+
+Note that this option is probably not useful when converting multiple POD
+files at once.  The convention for Unix man pages for commands is for the
+man page title to be in all-uppercase even if the command isn't.
+
+=item B<-o>, B<--official>
+
+Set the default header to indicate that this page is part of the standard
+Perl release, if B<--center> is not also given.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>.  If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> may also be set to the special value C<none>, in which case no
+quote marks are added around CE<lt>> text (but the font is still changed for
+troff output).
+
+=item B<-r>, B<--release>
+
+Set the centered footer.  By default, this is the version of Perl you run
+B<pod2man> under.  Note that some system an macro sets assume that the
+centered footer will be a modification date and will prepend something like
+"Last modified: "; if this is the case, you may want to set B<--release> to
+the last modified date and B<--date> to the version number.
+
+=item B<-s>, B<--section>
+
+Set the section for the C<.TH> macro.  The standard section numbering
+convention is to use 1 for user commands, 2 for system calls, 3 for
+functions, 4 for devices, 5 for file formats, 6 for games, 7 for
+miscellaneous information, and 8 for administrator commands.  There is a lot
+of variation here, however; some systems (like Solaris) use 4 for file
+formats, 5 for miscellaneous information, and 7 for devices.  Still others
+use 1m instead of 8, or some mix of both.  About the only section numbers
+that are reliably consistent are 1, 2, and 3.
+
+By default, section 1 will be used unless the file ends in .pm in which case
+section 3 will be selected.
+
+=item B<-v>, B<--verbose>
+
+Print out the name of each output file as it is being generated.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Parser> for
+information about what those errors might mean.
+
+=head1 EXAMPLES
+
+    pod2man program > program.1
+    pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3
+    pod2man --section=7 note.pod > note.7
+
+If you would like to print out a lot of man page continuously, you probably
+want to set the C and D registers to set contiguous page numbering and
+even/odd paging, at least on some versions of man(7).
+
+    troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ...
+
+To get index entries on stderr, turn on the F register, as in:
+
+    troff -man -rF1 perl.1
+
+The indexing merely outputs messages via C<.tm> for each major page,
+section, subsection, item, and any C<XE<lt>E<gt>> directives.  See
+L<Pod::Man> for more details.
+
+=head1 BUGS
+
+Lots of this documentation is duplicated from L<Pod::Man>.
+
+=head1 NOTES
+
+For those not sure of the proper layout of a man page, here are some notes
+on writing a proper man page.
+
+The name of the program being documented is conventionally written in bold
+(using BE<lt>E<gt>) wherever it occurs, as are all program options.
+Arguments should be written in italics (IE<lt>E<gt>).  Functions are
+traditionally written in italics; if you write a function as function(),
+Pod::Man will take care of this for you.  Literal code or commands should
+be in CE<lt>E<gt>.  References to other man pages should be in the form
+C<manpage(section)>, and Pod::Man will automatically format those
+appropriately.  As an exception, it's traditional not to use this form when
+referring to module documentation; use C<LE<lt>Module::NameE<gt>> instead.
+
+References to other programs or functions are normally in the form of man
+page references so that cross-referencing tools can provide the user with
+links and the like.  It's possible to overdo this, though, so be careful not
+to clutter your documentation with too much markup.
+
+The major headers should be set out using a C<=head1> directive, and are
+historically written in the rather startling ALL UPPER CASE format, although
+this is not mandatory.  Minor headers may be included using C<=head2>, and
+are typically in mixed case.
+
+The standard sections of a manual page are:
+
+=over 4
+
+=item NAME
+
+Mandatory section; should be a comma-separated list of programs or functions
+documented by this podpage, such as:
+
+    foo, bar - programs to do something
+
+Manual page indexers are often extremely picky about the format of this
+section, so don't put anything in it except this line.  A single dash, and
+only a single dash, should separate the list of programs or functions from
+the description.  Functions should not be qualified with C<()> or the like.
+The description should ideally fit on a single line, even if a man program
+replaces the dash with a few tabs.
+
+=item SYNOPSIS
+
+A short usage summary for programs and functions.  This section is mandatory
+for section 3 pages.
+
+=item DESCRIPTION
+
+Extended description and discussion of the program or functions, or the body
+of the documentation for man pages that document something else.  If
+particularly long, it's a good idea to break this up into subsections
+C<=head2> directives like:
+
+    =head2 Normal Usage
+
+    =head2 Advanced Features
+
+    =head2 Writing Configuration Files
+
+or whatever is appropriate for your documentation.
+
+=item OPTIONS
+
+Detailed description of each of the command-line options taken by the
+program.  This should be separate from the description for the use of things
+like L<Pod::Usage|Pod::Usage>.  This is normally presented as a list, with
+each option as a separate C<=item>.  The specific option string should be
+enclosed in BE<lt>E<gt>.  Any values that the option takes should be
+enclosed in IE<lt>E<gt>.  For example, the section for the option
+B<--section>=I<manext> would be introduced with:
+
+    =item B<--section>=I<manext>
+
+Synonymous options (like both the short and long forms) are separated by a
+comma and a space on the same C<=item> line, or optionally listed as their
+own item with a reference to the canonical name.  For example, since
+B<--section> can also be written as B<-s>, the above would be:
+
+    =item B<-s> I<manext>, B<--section>=I<manext>
+
+(Writing the short option first is arguably easier to read, since the long
+option is long enough to draw the eye to it anyway and the short option can
+otherwise get lost in visual noise.)
+
+=item RETURN VALUE
+
+What the program or function returns, if successful.  This section can be
+omitted for programs whose precise exit codes aren't important, provided
+they return 0 on success as is standard.  It should always be present for
+functions.
+
+=item ERRORS
+
+Exceptions, error return codes, exit statuses, and errno settings.
+Typically used for function documentation; program documentation uses
+DIAGNOSTICS instead.  The general rule of thumb is that errors printed to
+STDOUT or STDERR and intended for the end user are documented in DIAGNOSTICS
+while errors passed internal to the calling program and intended for other
+programmers are documented in ERRORS.  When documenting a function that sets
+errno, a full list of the possible errno values should be given here.
+
+=item DIAGNOSTICS
+
+All possible messages the program can print out--and what they mean.  You
+may wish to follow the same documentation style as the Perl documentation;
+see perldiag(1) for more details (and look at the POD source as well).
+
+If applicable, please include details on what the user should do to correct
+the error; documenting an error as indicating "the input buffer is too
+small" without telling the user how to increase the size of the input buffer
+(or at least telling them that it isn't possible) aren't very useful.
+
+=item EXAMPLES
+
+Give some example uses of the program or function.  Don't skimp; users often
+find this the most useful part of the documentation.  The examples are
+generally given as verbatim paragraphs.
+
+Don't just present an example without explaining what it does.  Adding a
+short paragraph saying what the example will do can increase the value of
+the example immensely.
+
+=item ENVIRONMENT
+
+Environment variables that the program cares about, normally presented as a
+list using C<=over>, C<=item>, and C<=back>.  For example:
+
+    =over 6
+
+    =item HOME
+
+    Used to determine the user's home directory.  F<.foorc> in this
+    directory is read for configuration details, if it exists.
+
+    =back
+
+Since environment variables are normally in all uppercase, no additional
+special formatting is generally needed; they're glaring enough as it is.
+
+=item FILES
+
+All files used by the program or function, normally presented as a list, and
+what it uses them for.  File names should be enclosed in FE<lt>E<gt>.  It's
+particularly important to document files that will be potentially modified.
+
+=item CAVEATS
+
+Things to take special care with, sometimes called WARNINGS.
+
+=item BUGS
+
+Things that are broken or just don't work quite right.
+
+=item RESTRICTIONS
+
+Bugs you don't plan to fix.  :-)
+
+=item NOTES
+
+Miscellaneous commentary.
+
+=item SEE ALSO
+
+Other man pages to check out, like man(1), man(7), makewhatis(8), or
+catman(8).  Normally a simple list of man pages separated by commas, or a
+paragraph giving the name of a reference work.  Man page references, if they
+use the standard C<name(section)> form, don't have to be enclosed in
+LE<lt>E<gt> (although it's recommended), but other things in this section
+probably should be when appropriate.
+
+If the package has a mailing list, include a URL or subscription
+instructions here.
+
+If the package has a web site, include a URL here.
+
+=item AUTHOR
+
+Who wrote it (use AUTHORS for multiple people).  Including your current
+e-mail address (or some e-mail address to which bug reports should be sent)
+so that users have a way of contacting you is a good idea.  Remember that
+program documentation tends to roam the wild for far longer than you expect
+and pick an e-mail address that's likely to last if possible.
+
+=item COPYRIGHT AND LICENSE
+
+For copyright
+
+    Copyright YEAR(s) by YOUR NAME(s)
+
+(No, (C) is not needed.  No, "all rights reserved" is not needed.)
+
+For licensing the easiest way is to use the same licensing as Perl itself:
+
+    This library is free software; you may redistribute it and/or modify
+    it under the same terms as Perl itself.
+
+This makes it easy for people to use your module with Perl.  Note that
+this licensing is neither an endorsement or a requirement, you are of
+course free to choose any licensing.
+
+=item HISTORY
+
+Programs derived from other sources sometimes have this, or you might keep
+a modification log here.  If the log gets overly long or detailed,
+consider maintaining it in a separate file, though.
+
+=back
+
+In addition, some systems use CONFORMING TO to note conformance to relevant
+standards and MT-LEVEL to note safeness for use in threaded programs or
+signal handlers.  These headings are primarily useful when documenting parts
+of a C library.  Documentation of object-oriented libraries or modules may
+use CONSTRUCTORS and METHODS sections for detailed documentation of the
+parts of the library and save the DESCRIPTION section for an overview; other
+large modules may use FUNCTIONS for similar reasons.  Some people use
+OVERVIEW to summarize the description if it's quite long.
+
+Section ordering varies, although NAME should I<always> be the first section
+(you'll break some man page systems otherwise), and NAME, SYNOPSIS,
+DESCRIPTION, and OPTIONS generally always occur first and in that order if
+present.  In general, SEE ALSO, AUTHOR, and similar material should be left
+for last.  Some systems also move WARNINGS and NOTES to last.  The order
+given above should be reasonable for most purposes.
+
+Finally, as a general note, try not to use an excessive amount of markup.
+As documented here and in L<Pod::Man>, you can safely leave Perl variables,
+function names, man page references, and the like unadorned by markup and
+the POD translators will figure it out for you.  This makes it much easier
+to later edit the documentation.  Note that many existing translators
+(including this one currently) will do the wrong thing with e-mail addresses
+or URLs when wrapped in LE<lt>E<gt>, so don't do that.
+
+For additional information that may be more accurate for your specific
+system, see either L<man(5)> or L<man(7)> depending on your system manual
+section numbering conventions.
+
+=head1 SEE ALSO
+
+L<Pod::Man>, L<Pod::Parser>, L<man(1)>, L<nroff(1)>, L<podchecker(1)>,
+L<troff(1)>, L<man(7)>
+
+The man page documenting the an macro set may be L<man(5)> instead of
+L<man(7)> on your system.
+
+The current version of this script is always available from its web site at
+L<http://www.eyrie.org/~eagle/software/podlators/>.  It is also part of the
+Perl core distribution as of 5.6.0.
+
+=head1 AUTHOR
+
+Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original
+B<pod2man> by Larry Wall and Tom Christiansen.  Large portions of this
+documentation, particularly the sections on the anatomy of a proper man
+page, are taken from the B<pod2man> documentation by Tom.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001 by Russ Allbery <rra@stanford.edu>.
+
+This program is free software; you may redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut

doc/l-paper/NOTES

@@ -0,0 +1,165 @@
+[Fri Sep 22 16:07:30 PDT 2006]
+
+The problem is pass by reference vs value.  There isn't a nice way to do it
+like C so we're inventing a different way, trying to keep it readable.
+
+proc tcl_ref {setme} {
+	upvar $setme ptr
+	set ptr "some string"
+}
+
+/*
+ * how this works is that the compiler sees the &setme and generates code like:
+ * upvar ${&setme} setme
+ */
+void
+L_ref(string &setme)
+{
+	setme = "some string";
+}
+
+It does mean that if I want to call gets() from L I need to do
+
+	while (gets(fd, &buf) > 0) {
+		...
+	}
+
+which isn't very C like.  That's OK, L isn't C because strings are first
+class in L and they aren't in C.  Oscar wacked that into my head.  Slowly.
+
+The next issue is compound types like arrays / hashes.  I want those to be
+implicit references, like C.  So no &my_array in args, it's just my_array.
+
+/*
+ * as above, the compiler sees foo[] and subs in &foo as the parameter
+ * and does the upvar ${&foo} foo
+ */
+void
+L_array_ref(int foo[])
+{
+	foo[3] = 3;
+}
+
+/*
+ * as above, the compiler sees foo{} and does the code like
+ * upvar $foo 0foo
+ *
+ * Note also the new full specified syntax for a hash declaration.
+ * The following are the same thing and for 1.0 we implement the 
+ * first one only.  But the second form allows us to have var/poly/int
+ * etc. as keys or indices.  The syntax is "value" varname{"key"} where
+ * value is the type of the value and key is the type of the key.  Nifty.
+ * hash	foo{};
+ * string foo{string};
+ *
+ * For 1.0 this is just
+ * L_hash_ref(hash foo)
+ * and I do want to insist on the {} in declarations (args and formal) because
+ * it gets people used to the foo{"string"} syntax.
+ */
+void
+L_hash_ref(string foo{string})
+{
+	int	mine{};
+
+	foo{"some key"} = "some value";
+}
+
+A calling wrinkle.
+
+When calling an L function/tcl proc which expects a reference, i.e.,
+func(string &buf) or proc foo {bufname} { upvar $bufname buf ... },
+from an L context, there is a question as to whether or not the 
+L variable needs a leading &.  And the answer is: depends on what you
+want.  All the leading ampersand does is to push the name of the 
+variable on the stack instead of the value of the variable (w/ all
+the COW semantics).  So consider this
+
+void
+stomp(string &buf)
+{
+	buf = "stomped";
+}
+
+void
+L_caller()
+{
+	string	foo = "bar";
+	string	fooname = "foo";
+
+	if (what_I_would_expect) {
+		stomp(&foo);	// foo will get "stomped"
+	} else {
+		stomp(fooname);	// foo will get "stomped" this way too
+	}
+}
+
+The stomp(fooname) could work but we should disallow it in L 1.0 - we
+can allow it in the future.  Tim points out that we can throw a syntax
+error for L calling L and the type mismatch but not for L calling tcl,
+i.e., calling gets, unless we have some sort of extern int gets(FILE fd,
+string &buf) that we use to load the function signature table (what is
+that called?)
+
+Tcl calling L
+
+Suppose we had an L procedure that implemented puts, maybe it's written
+in C, but it would be declared like
+
+void
+L_puts(string stuff_to_print[])
+{
+	print it
+}
+
+If we are in tcl and we do
+
+	set stuff [list a b c]
+
+and we want to print it it would look like
+
+	puts $stuff
+
+but if we're calling L that won't work, it should be an arg miss match because
+
+	L_puts $stuff
+
+is like calling
+
+	L_puts("a", "b", "c")
+
+and L_puts wants a single arg.  
+
+We get around this by noting that L implements pass by reference by passing
+by name and doing an upvar so the calling syntax is:
+
+	L_puts stuff
+
+Kind of annoying but that's a ramification of the impedance mismatch between
+L and tcl.  If you want to make breakfast you have to break some eggs.
+
+============================================================================
+
+Structs
+
+	struct foo {
+		int	a;	/* I am A */
+		string	b;	/* oh, love those strings */
+	}
+
+results in the creation of a list in ::L like
+
+	# Note the offset into the list is the index into the struct "list"
+	set ::L::{struct foo} [list \
+	    [list int a {I am A}] \
+	    [list string b {oh, love those strings}] \
+	    ]
+
+and now I can pass a struct to tcl just like an other COW thingy and I
+can make a little struct command that gets me fields, sets them, does
+introspection, etc.
+
+And the cool thing is L can do the introspection which means I can write
+my little preferences struct and call some wacky code that takes the
+struct and con's up the code to make a preference dialogue.
+

doc/l-paper/btree.l

@@ -0,0 +1,43 @@
+struct node {
+	double	i;
+};
+
+struct node tree[100000];
+
+int
+insert(int node, struct node element)
+{
+	/* using Tcl's {} as NULL */
+	if (tree[node] == "{}") {
+		tree[node] = element;
+	} else if (tree[node].i > element.i) {
+		insert(2*node+1, element);
+	} else {
+		insert(2*node+2, element);
+	}
+}
+
+int
+print(int node)
+{
+	if (tree[node] == "{}") {
+		return;
+	}
+	print(2*node+1);
+	puts(tree[node].i);
+	print(2*node+2);
+}
+
+int
+main()
+{
+	struct node tmp;
+	int	i;
+
+	namespace("import", "::tcl::mathfunc::*");
+	for (i = 0; i < 100; i++) {
+		tmp.i = floor(rand()*100);
+		insert(0, tmp);
+	}
+	print(0);
+}

doc/l-paper/cat.l

@@ -0,0 +1,16 @@
+typedef string FILE;
+
+main(int ac, string av[])
+{
+	int	i;
+	FILE	fd;
+
+	if (ac == 1) {
+		puts("-nonewline", read("stdin"));
+	} else {
+		for (i = 1; defined(av[i]); i++) {
+			fd = open(av[i], "r");
+			puts("-nonewline", read(fd));
+		}
+	}
+}

doc/l-paper/echo.l

@@ -0,0 +1,8 @@
+main(int argc, string argv[])
+{
+	int	i;
+
+	for (i = 0; defined(argv[i]); i++) {
+		printf("[%d] = %s\n", i, argv[i]);
+	}
+}

doc/l-paper/grep.l

@@ -0,0 +1,35 @@
+typedef string FILE;
+
+main(int ac, string av[], hash env)
+{
+	int	i;
+	string	regex;
+	FILE	fd;
+
+        if (ac < 2) {
+                error("Not enough arguments.");
+        }
+	regex = av[1];
+	ac--;
+	if (ac == 1) {
+		grep(regex, "stdin");
+	} else {
+		for (i = 2; defined(av[i]); i++) {
+			fd = open(av[i], "r");
+			grep(regex, fd);
+			close(fd);
+		}
+	}
+}
+
+void
+grep(string regex, FILE in)
+{
+	string	buf;
+
+	while (gets(in, &buf) >= 0) {
+		if (buf =~ /${regex}/) {
+			printf("%s\n", buf);
+		}
+	}
+}

doc/l-paper/interop.l

@@ -0,0 +1,36 @@
+#lang(L)
+
+/*
+ * Demonstrate interop between L and tcl.
+ * We want to show that you can pass any data structure between L and tcl.
+ *
+ * Base types, pass them, modify them.
+ * Structures, pass them, iterate over the fields.
+ * Arrays & hashes.
+ * Pointers to base types.
+ */
+main(int ac, string av[])
+{
+	
+}
+
+/*
+ * L calling tcl functions
+ */
+L_to_tcl()
+{
+	string	s = "Hi there mom";
+	int	a = 1234;
+
+	puts(a);			// prints 1234\n
+	puts(s);			// prints Hi there mom\n
+	set(&s, "Hi yourself");
+	puts(s);			// prints Hi yourself\n
+	puts(:nonewline, "Hi ");	// prints Hi 
+	puts("there");			// prints there\n
+}
+
+set(string &out, string value)
+{
+	out = value;
+}

doc/l-paper/julia.l

@@ -0,0 +1,103 @@
+#pragma language L
+
+julia(int size, int depth, double zreal, double zimag)
+{
+	double  z[2];
+	double  real_min = -1.2, real_max = 1.2, imag_min = -1.2;
+	double  xreal, ximag;
+	double delta = (real_max - real_min) / size;
+	int    i = 0, j = 0;
+
+	wm("title", ".", "Pretty Julia");
+	wm("geometry", ".", "+1+1");
+	canvas(".c1", "-width", size, "-height", size);
+	pack(".c1");
+	update();
+	z[0] = zreal;
+	z[1] = zimag;
+	xreal = real_min;
+	while (i < size) {
+		j = 0;
+		ximag = imag_min;
+		while (j < size) {
+			double  count = 0.0;
+			double  x[2];
+
+			x[0] = xreal;
+			x[1] = ximag;
+			while ((count < depth) && (complex_abs(x) < 2.0)) {
+				count = count + 1;
+				x = complex_add(complex_multiply(x, x), z);
+			}
+			if (complex_abs(x) <= 2.0) {
+				.c1("create", "rectangle", i, j, i, j,
+				    "-outline", make_color(0, 0, 0));
+			} else {
+				double  intensity = count / depth;
+
+				if (intensity > 0.001) {
+					.c1("create", "rectangle", i, j, i, j,
+					    "-outline",
+					    make_color(round(255.0 / depth *
+						    (depth -
+							depth * intensity)),
+						round(255.0 / depth * (depth -
+							depth * intensity)),
+						round(255.0 / depth * depth)));
+				}
+			}
+			j++;
+			ximag = ximag + delta;
+		} i++;
+		puts("-nonewline", format("%d .. ", i));
+		flush("stdout");
+		update();
+		xreal = xreal + delta;
+	} z[0] = zreal;
+	z[1] = zimag;
+	puts("\nDONE");
+}
+
+string
+make_color(int r, int g, int b)
+{
+	return format("#%02X%02X%02X", r, g, b);
+}
+
+double
+complex_multiply(double c1[2], double c2[2])
+{
+	double  c3[2];
+
+	c3[0] = c1[0] * c2[0] - c1[1] * c2[1];
+	c3[1] = c1[0] * c2[1] + c1[1] * c2[0];
+	return c3;
+}
+
+double
+complex_add(double c1[2], double c2[2])
+{
+	double  c3[2];
+
+	c3[0] = c1[0] + c2[0];
+	c3[1] = c1[1] + c2[1];
+	return c3;
+}
+
+#pragma end
+
+interp alias {} sqrt {} tcl::mathfunc::sqrt
+interp alias {} round {} tcl::mathfunc::round
+proc complex_abs {x} {
+    puts "complex_abs $x"
+    set a [lindex $x 0]
+    set b [lindex $x 1]
+    expr {sqrt(($a * $a)+($b * $b))}
+}
+#puts [time {julia 100 25 -0.74543 0.11302}]
+puts [time {julia 300 25 -0.84543 0.21302}]
+# bigger, different coords:
+#julia 256 25 -0.84543 0.21302
+# if you raise the depth, the islands get smaller:
+#julia 256 50 -0.84543 0.21302
+

doc/l-paper/l-language.me

@@ -0,0 +1,113 @@
+.\" The L Programming Language
+.\" Copyright (c) 2006 BitMover, Inc.
+.\"
+.\" process with 
+.\"    groff -R -me l-language.me > l-language.ps
+.\"
+.\" Commands for refer
+.R1
+database references
+accumulate
+.R2
+.\" Title, authors, etc.
+.+c
+.(l C
+.sz 16
+.b "The L Programming Language"
+.sz
+or
+.sz 12
+Tcl for C Programmers
+.sz
+.sp 3
+.i "Oscar Bonilla, Tim Daly, Jr., Jeff Hobbs, Larry McVoy"
+.sp
+BitMover, Inc.
+300 Orchard City Drive, Suite 132
+Campbell, CA 95008
+\f(CR
+l@bitmover.com
+\fP
+.)l
+.sp 3
+.\" Abstract
+.(l F
+.b Abstract.
+This paper describes a new programming language called L.  The goal of
+L is to make it easy for C programmers to take full advantage of
+Tcl/Tk without requiring them to be proficient in Tcl. L is a new
+programming language that shares most of its syntax and semantics with
+C, including pointers and a weak static type system.  We have modified
+the Tcl parser to add a special command which can be used to switch
+between L and Tcl syntax. Source code written in L syntax is passed to
+a simple compiler which emits Tcl bytecode. So L source code can be
+mixed freely with Tcl source code, and Tcl and L can share data and
+functions transparently. L is free and open source, and the authors
+hope it will bring many new people to the Tcl community.
+.)l
+.\" Main text
+.sh 1 "Introduction"
+.lp 
+At BitMover, we are great fans of code reading. We spend much more
+time reading our source code than writing it. Most of our source base
+is written in C, but our GUI is written in Tcl. It would greatly
+simplify things for us if everything was in a common language.
+However, using Tk from C would be difficult and error-prone.
+.pp
+For that reason, we've decided to implement a new language that shares
+the Tcl runtime. By keeping the language similar to C we can use the
+same idioms as we would in C, avoiding confusion. To make access to Tk
+and other Tcl libraries seamless, the language runs right in the Tcl
+runtime. Its functions are Tcl functions, and its types are Tcl types.
+.pp
+In keeping with the grand tradition of one letter language names, this
+new language is called L. In the next section, we will go into more
+detail about some interesting aspects of the language. After that we
+discuss its implementation as a front-end for Tcl.  Finally we touch
+on our plans for the future of L, and tell you where you can get a
+copy.
+.sh 1 "The L Language"
+.lp 
+Say that we're mostly like C and then go on to describe where we're
+different.  Explain how L types correspond to Tcl types, and give an
+example of the interaction between the two languages.
+.\" This is an example reference so that I don't forget how to make one
+.[
+kernighan cherry eqn
+.]
+.sh 1 "The Implementation"
+.lp 
+The first step in processing an L program is to read in the source
+code.  L source code can be in its own file, or it can be in a mixed
+file together with Tcl source code.
+.sh 2 "Parsing Mixed Languages"
+.lp
+The most obvious approach to embedding L code within a Tcl program
+would be to pass the L code as an argument to a new Tcl command which
+implements L.  However, the Tcl syntax rule that "braces nest within a
+word" [cite endekalogue/tcl book?] means that we would still be
+required to match (or escape) braces within the L code.  This would be
+an unpleasant wrinkle for the L programmer to deal with.
+.pp
+In order to free the brace characters from the reign of Tcl, it was
+necessary to modify the Tcl parser.  We added support for special
+comments that start with the word "pragma".  The parser consumes the
+input from an opening pragma to a closing pragma, and packages it as a
+pair of Tcl words -- the name of the command that implements L,
+followed by the source code between the pragmas.  In this way, the
+result of parsing embedded L code is the same as if the L code had
+been properly escaped.
+.sh 1 "..."
+.lp
+Mention using Tcl to generate C code, and explain how L pointers work.
+Take opportunity to release bile about Tcl being a bizarre backend for
+a C compiler.
+.sh 1 "Current Status, Availability"
+.lp 
+L is completely finished and golden, and has a magic shield of +2
+anti-bitrot.  You can get it from sunsite, tsx-11, or wuarchive.
+Build instructions are for sissies.
+.\"  All done, print the references
+.[
+$LIST$
+.]

doc/l-paper/little.ol

@@ -0,0 +1,129 @@
+Outline
+	What is it?
+	Why is that interesting?
+	Why not some other runtime?
+	Why not just tcl?
+	Language details
+	Code examples
+	Status or what doesn't work yet
+	Future directions
+	License and Availability
+	What people are saying 
+What is it?
+	C-like syntax on top of the Tcl runtime
+	Alternate compiler that generates tcl byte codes
+	Does not change tcl system
+	Interoperates with the tcl system
+	Leverages the tcl runtime
+	An example of a multi-syntax system (can have tcl & L in same file)
+Why not some other runtime?
+	Lotso good stuff about the tcl runtime
+Why not pure tcl?
+	Tcl cons from below
+Why did we do it?
+	Already comitted to tcl/tk
+	Tcl pros
+		Stable runtime
+		Easy to extend in C
+		Powerful, dynamic language
+	Tcl cons
+		Hard to read (for us)
+		No structs - probably the single biggest reason
+		Lots of missing syntactic sugar
+			foo[3] or [lindex foo 3]
+			if (buf =~ /blah.*blech/)
+			or
+			if {[regexp blah.*blah buf]}
+			etc.
+			Pass by reference with upvar is annoying
+	We're a conservative development organization.	We sell
+	to enterprise customers and we support releases going back
+	indefinitely in some cases.  All code goes through peer review and
+	is optimized for ease of reading more than for ease of writing.
+	We found tcl to be suboptimal in this environment, particularly
+	because of the lack of structs but also because of the lack of 
+	syntactic sugar - calling procs to do array indexing is way over
+	our threshold of pain for readability.
+Language details
+	C-like syntax compiled to tcl byte code
+		L can call tcl, tcl can call L
+	Additions over C
+		perl like regex in statements
+		associative arrays
+		defined() for variables, hashes, arrays
+			defined(foo)		[info exists] or winfo ???
+			defined(foo{"bar"})
+			defined(blech[2])
+		strings are a basic type like int/float
+	Additions over tcl
+		structs
+		type checking
+		pass by reference improvements
+		function fingerprints
+	Types
+		string (same as tcl string)
+		int, float (type checked)
+		var (unknown type, strongly typed on first assignment)
+		poly (like tcl variable, no type checking)
+		hash (associative array, currently string types for key/val)
+			Implemented as dicts
+			string types as key/values
+			We could allow
+				hash	poly foo{poly}
+			if we ever want that fucked up syntax.
+		structs
+			like C structs
+			implemented as lists
+			fields are in ::L::{struct name} as a list of lists,
+			each list is {type name comments}
+			struct struct {
+				string	type;
+				string	name;
+				string	comments;
+			}
+	Pass by reference or value?
+		base types are all by value, COW, like tcl
+		arrays and hashes are implicit references
+			pass an array to a proc, modify array[3], caller sees
+		base types and structures may be passed by reference
+			pass by reference is done with &variable in the
+			caller which is an alias for "variable", i.e., 
+			we pass by name.
+			In the callee the argument also wants a & and it means
+			do an automagic upvar to get the real variable
+	Returns
+		All returns are by value
+			all types just work as expected
+				push the object onto the stack
+				the other end gets the object into it's 
+				variable name.
+Code examples
+	printenv.l
+Status or what doesn't work yet
+	Well there are issues
+Future directions
+	Scoping so you can do modules
+	Precompiled modules (and byte code loader)
+	Optimizations
+	Debugging support
+	Having an L contest for the best ($10K seem right?)
+License and Availability
+	Same license as Tcl
+	Exported as tarballs nightly
+What people are saying
+	"It'll make your jaw drop"
+	    -- Steve Jobs
+	"It's an amazing, amazing innovation."
+	    -- Steve Ballmer
+	"I want to thank Larry McVoy" 
+	    -- Richard Stallman
+	"L == Tcl 9.0"
+	    -- Jeff Hobbs
+	"L?  Of course I like it.  It's named for me.  Right?"
+	    -- Linus Torvalds
+	"It's like perl without the nastiest bits"
+	    -- Donal K Fellows
+	"I think that's easier to read."
+	    -- Larry Wall
+	"L is the coolest thing I've ever seen"
+	    -- Vadim Gelfer

doc/l-paper/printenv.l

@@ -0,0 +1,9 @@
+main(int argc, string argv[], hash env)
+{
+	string	key, val;
+
+	foreach (env as key => val) {
+		printf("env{%s} = %s\n", key, val);
+	}
+
+}

doc/l-paper/references

@@ -0,0 +1,56 @@
+%A Brian W. Kernighan
+%A Lorinda L. Cherry
+%T A System for Typesetting Mathematics
+%J J. Comm. ACM
+%V 18
+%N 3
+%D March 1978
+%P 151-157
+%K eqn
+
+%A Fred Brooks
+%T The Mythical Man Month
+%D 1975
+%K mythical man month
+
+%A The Tcler's Wiki
+%T shimmering
+%J http://wiki.tcl.tk/3033
+%D Dec 2005
+%K shimmering
+
+%A The Tcler's Wiki
+%T use_ref
+%J http://wiki.tcl.tk/15120
+%D Dec 2005
+%K pass by reference
+
+%A Michael Hind 
+%T Pointer Analysis: Haven't We Solved This Problem Yet?" 
+%D 2001
+%K aliasing1
+
+%A Steven S. Muchnick 
+%T Advanced Compiler Design and Implementation
+%D 1997
+%I Morgan Kaufmann
+%K optimization
+
+%A Brian W. Kernighan
+%A Dennis M. Ritchie
+%I Prentice-Hall, Inc.
+%T The C Programming Language
+%D 1978
+%K C
+
+%T Pointer-Induced Aliasing: A Clarification
+%A Thomas J. Marlowe
+%A Jong-Deok Choi
+%A William G. Landi
+%A Michael G. Burke
+%A Barbara G. Ryder
+%A Paul Carini
+%J ACM SIGPLAN Notices
+%D September 1993
+%N Volume 28, No. 9
+%K aliasing2

generic/Last.c

@@ -0,0 +1,386 @@
+/*
+ * used to be: tclsh gen-l-ast2.tcl to regenerate
+ * As of Feb 2008 it is maintained by hand.
+ */
+#include "tclInt.h"
+#include "Lcompile.h"
+
+private void
+ast_init(void *node, Node_k type, YYLTYPE beg, YYLTYPE end)
+{
+	Ast	*ast = (Ast *)node;
+
+	ast->type     = type;
+	ast->loc.beg  = beg.beg;
+	ast->loc.end  = end.end;
+	ast->loc.line = beg.line;
+	ast->loc.file = beg.file;
+	ast->next     = L->ast_list;
+	L->ast_list   = (void *)ast;
+}
+
+Block *
+ast_mkBlock(VarDecl *decls, Stmt *body, YYLTYPE beg, YYLTYPE end)
+{
+	Block	*block = (Block *)ckalloc(sizeof(Block));
+	memset(block, 0, sizeof(Block));
+	block->body  = body;
+	block->decls = decls;
+	ast_init(block, L_NODE_BLOCK, beg, end);
+	return (block);
+}
+
+Expr *
+ast_mkExpr(Expr_k kind, Op_k op, Expr *a, Expr *b, Expr *c, YYLTYPE beg,
+	   YYLTYPE end)
+{
+	Expr	*expr = (Expr *)ckalloc(sizeof(Expr));
+	memset(expr, 0, sizeof(Expr));
+	expr->a    = a;
+	expr->b    = b;
+	expr->c    = c;
+	expr->kind = kind;
+	expr->op   = op;
+	ast_init(expr, L_NODE_EXPR, beg, end);
+	return (expr);
+}
+
+ForEach *
+ast_mkForeach(Expr *expr, Expr *key, Expr *value, Stmt *body,
+	      YYLTYPE beg, YYLTYPE end)
+{
+	ForEach	*foreach = (ForEach *)ckalloc(sizeof(ForEach));
+	memset(foreach, 0, sizeof(ForEach));
+	foreach->expr  = expr;
+	foreach->key   = key;
+	foreach->value = value;
+	foreach->body  = body;
+	ast_init(foreach, L_NODE_FOREACH_LOOP, beg, end);
+	return (foreach);
+}
+
+FnDecl *
+ast_mkFnDecl(VarDecl *decl, Block *body, YYLTYPE beg, YYLTYPE end)
+{
+	FnDecl *fndecl = (FnDecl *)ckalloc(sizeof(FnDecl));
+	memset(fndecl, 0, sizeof(FnDecl));
+	fndecl->body = body;
+	fndecl->decl = decl;
+	/*
+	 * Propagate tracing attributes from L->options, which come
+	 * from cmd-line options or #pragmas.  Any attributes
+	 * specified in the function declaration end up overwriting
+	 * these.
+	 */
+	fndecl->attrs = Tcl_NewDictObj();
+	hash_put(fndecl->attrs, "fntrace", hash_get(L->options, "fntrace"));
+	hash_put(fndecl->attrs, "fnhook", hash_get(L->options, "fnhook"));
+	hash_put(fndecl->attrs, "trace_depth",
+		 hash_get(L->options, "trace_depth"));
+	ast_init(fndecl, L_NODE_FUNCTION_DECL, beg, end);
+	return (fndecl);
+}
+
+Cond *
+ast_mkIfUnless(Expr *expr, Stmt *if_body, Stmt *else_body, YYLTYPE beg,
+	       YYLTYPE end)
+{
+	Cond *cond = (Cond *)ckalloc(sizeof(Cond));
+	memset(cond, 0, sizeof(Cond));
+	cond->cond      = expr;
+	cond->else_body = else_body;
+	cond->if_body   = if_body;
+	ast_init(cond, L_NODE_IF_UNLESS, beg, end);
+	return (cond);
+}
+
+Loop *
+ast_mkLoop(Loop_k kind, Expr *pre, Expr *cond, Expr *post, Stmt *body,
+	   YYLTYPE beg, YYLTYPE end)
+{
+	Loop *loop = (Loop *)ckalloc(sizeof(Loop));
+	memset(loop, 0, sizeof(Loop));
+	loop->cond = cond;
+	loop->post = post;
+	loop->pre  = pre;
+	loop->kind = kind;
+	loop->body = body;
+	ast_init(loop, L_NODE_LOOP, beg, end);
+	return (loop);
+}
+
+Switch *
+ast_mkSwitch(Expr *expr, Case *cases, YYLTYPE beg, YYLTYPE end)
+{
+	Switch	*sw = (Switch *)ckalloc(sizeof(Switch));
+	memset(sw, 0, sizeof(Switch));
+	sw->expr  = expr;
+	sw->cases = cases;
+	ast_init(sw, L_NODE_SWITCH, beg, end);
+	return (sw);
+}
+
+Case *
+ast_mkCase(Expr *expr, Stmt *body, YYLTYPE beg, YYLTYPE end)
+{
+	Case	*c = (Case *)ckalloc(sizeof(Case));
+	memset(c, 0, sizeof(Case));
+	c->expr = expr;
+	c->body = body;
+	ast_init(c, L_NODE_CASE, beg, end);
+	return (c);
+}
+
+Try *
+ast_mkTry(Stmt *try, Expr *msg, Stmt *catch)
+{
+	Try	*t = (Try *)ckalloc(sizeof(Try));
+	memset(t, 0, sizeof(Try));
+	t->try   = try;
+	t->msg   = msg;
+	t->catch = catch;
+	return (t);
+}
+
+Stmt *
+ast_mkStmt(Stmt_k kind, Stmt *next, YYLTYPE beg, YYLTYPE end)
+{
+	Stmt *stmt = (Stmt *)ckalloc(sizeof(Stmt));
+	memset(stmt, 0, sizeof(Stmt));
+	stmt->next = next;
+	stmt->kind = kind;
+	ast_init(stmt, L_NODE_STMT, beg, end);
+	return (stmt);
+}
+
+TopLev *
+ast_mkTopLevel(Toplv_k kind, TopLev *next, YYLTYPE beg, YYLTYPE end)
+{
+	TopLev *toplev = (TopLev *)ckalloc(sizeof(TopLev));
+	memset(toplev, 0, sizeof(TopLev));
+	toplev->next = next;
+	toplev->kind = kind;
+	ast_init(toplev, L_NODE_TOPLEVEL, beg, end);
+	return (toplev);
+}
+
+VarDecl *
+ast_mkVarDecl(Type *type, Expr *id, YYLTYPE beg, YYLTYPE end)
+{
+	VarDecl *vardecl = (VarDecl *)ckalloc(sizeof(VarDecl));
+	memset(vardecl, 0, sizeof(VarDecl));
+	vardecl->id   = id;
+	vardecl->type = type;
+	ast_init(vardecl, L_NODE_VAR_DECL, beg, end);
+	return (vardecl);
+}
+
+ClsDecl *
+ast_mkClsDecl(VarDecl *decl, YYLTYPE beg, YYLTYPE end)
+{
+	ClsDecl *clsdecl = (ClsDecl *)ckalloc(sizeof(ClsDecl));
+	memset(clsdecl, 0, sizeof(ClsDecl));
+	clsdecl->decl = decl;
+	ast_init(clsdecl, L_NODE_CLASS_DECL, beg, end);
+	return (clsdecl);
+}
+
+/* Build a default constructor if the user didn't provide one. */
+FnDecl *
+ast_mkConstructor(ClsDecl *class)
+{
+	char	*name;
+	Type	*type;
+	Expr	*id;
+	VarDecl	*decl;
+	Block	*block;
+	FnDecl	*fn;
+	YYLTYPE	loc = class->node.loc;
+
+	type  = type_mkFunc(class->decl->type, NULL);
+	name  = cksprintf("%s_new", class->decl->id->str);
+	id    = ast_mkId(name, loc, loc);
+	decl  = ast_mkVarDecl(type, id, loc, loc);
+	decl->flags |= SCOPE_GLOBAL | DECL_CLASS_FN | DECL_PUBLIC |
+		DECL_CLASS_CONST;
+	decl->clsdecl = class;
+	block = ast_mkBlock(NULL, NULL, loc, loc);
+	fn    = ast_mkFnDecl(decl, block, loc, loc);
+
+	return (fn);
+}
+
+/* Build a default destructor if the user didn't provide one. */
+FnDecl *
+ast_mkDestructor(ClsDecl *class)
+{
+	char	*name;
+	Type	*type;
+	Expr	*id, *self;
+	VarDecl	*decl, *parm;
+	Block	*block;
+	FnDecl	*fn;
+	YYLTYPE	loc = class->node.loc;
+
+	self = ast_mkId("self", loc, loc);
+	parm = ast_mkVarDecl(class->decl->type, self, loc, loc);
+	parm->flags = SCOPE_LOCAL | DECL_LOCAL_VAR;
+	type = type_mkFunc(L_void, parm);
+	name = cksprintf("%s_delete", class->decl->id->str);
+	id   = ast_mkId(name, loc, loc);
+	decl = ast_mkVarDecl(type, id, loc, loc);
+	decl->flags |= SCOPE_GLOBAL | DECL_CLASS_FN | DECL_PUBLIC |
+		DECL_CLASS_DESTR;
+	decl->clsdecl = class;
+	block = ast_mkBlock(NULL, NULL, loc, loc);
+	fn    = ast_mkFnDecl(decl, block, loc, loc);
+
+	return (fn);
+}
+
+Expr *
+ast_mkUnOp(Op_k op, Expr *e1, YYLTYPE beg, YYLTYPE end)
+{
+	return (ast_mkExpr(L_EXPR_UNOP, op, e1, NULL, NULL, beg, end));
+}
+
+Expr *
+ast_mkBinOp(Op_k op, Expr *e1, Expr *e2, YYLTYPE beg, YYLTYPE end)
+{
+	return (ast_mkExpr(L_EXPR_BINOP, op, e1, e2, NULL, beg, end));
+}
+
+Expr *
+ast_mkTrinOp(Op_k op, Expr *e1, Expr *e2, Expr *e3, YYLTYPE beg,
+	     YYLTYPE end)
+{
+	return (ast_mkExpr(L_EXPR_TRINOP, op, e1, e2, e3, beg, end));
+}
+
+Expr *
+ast_mkConst(Type *type, char *str, YYLTYPE beg, YYLTYPE end)
+{
+	Expr *e = ast_mkExpr(L_EXPR_CONST, L_OP_NONE, NULL, NULL, NULL,
+			    beg, end);
+	e->type = type;
+	e->str  = str;
+	return (e);
+}
+
+Expr *
+ast_mkRegexp(char *re, YYLTYPE beg, YYLTYPE end)
+{
+	Expr *e = ast_mkExpr(L_EXPR_RE, L_OP_NONE, NULL, NULL, NULL, beg, end);
+	e->str  = re;
+	e->type = L_string;
+	return (e);
+}
+
+Expr *
+ast_mkFnCall(Expr *id, Expr *arg_list, YYLTYPE beg, YYLTYPE end)
+{
+	Expr *e = ast_mkExpr(L_EXPR_FUNCALL, L_OP_NONE, id, arg_list, NULL,
+			    beg, end);
+	return (e);
+}
+
+Expr *
+ast_mkId(char *name, YYLTYPE beg, YYLTYPE end)
+{
+	Expr *e = ast_mkExpr(L_EXPR_ID, L_OP_NONE, NULL, NULL, NULL, beg, end);
+	e->str = ckstrdup(name);
+	return (e);
+}
+
+private Type *
+type_alloc(Type_k kind)
+{
+	Type *type = (Type *)ckalloc(sizeof(Type));
+	memset(type, 0, sizeof(Type));
+	type->kind   = kind;
+	type->list   = L->type_list;
+	L->type_list = type;
+	return (type);
+}
+
+Type *
+type_dup(Type *type)
+{
+	Type *dup = (Type *)ckalloc(sizeof(Type));
+	*dup = *type;
+	if (type->name) {
+		dup->name = ckstrdup(type->name);
+	}
+	if ((type->kind == L_STRUCT) && type->u.struc.tag) {
+		dup->u.struc.tag = ckstrdup(type->u.struc.tag);
+	}
+	dup->list    = L->type_list;
+	L->type_list = dup;
+	return (dup);
+}
+
+Type *
+type_mkScalar(Type_k kind)
+{
+	Type *type = type_alloc(kind);
+	return (type);
+}
+
+Type *
+type_mkArray(Expr *size, Type *base_type)
+{
+	Type *type = type_alloc(L_ARRAY);
+	type->u.array.size = size;
+	type->base_type    = base_type;
+	return (type);
+}
+
+Type *
+type_mkHash(Type *index_type, Type *base_type)
+{
+	Type *type = type_alloc(L_HASH);
+	type->u.hash.idx_type = index_type;
+	type->base_type       = base_type;
+	return (type);
+}
+
+Type *
+type_mkStruct(char *tag, VarDecl *members)
+{
+	Type *type = type_alloc(L_STRUCT);
+	type->u.struc.tag     = ckstrdup(tag);
+	type->u.struc.members = members;
+	return (type);
+}
+
+Type *
+type_mkNameOf(Type *base_type)
+{
+	Type *type = type_alloc(L_NAMEOF);
+	type->base_type = base_type;
+	return (type);
+}
+
+Type *
+type_mkFunc(Type *ret_type, VarDecl *formals)
+{
+	Type *type = type_alloc(L_FUNCTION);
+	type->base_type      = ret_type;
+	type->u.func.formals = formals;
+	return (type);
+}
+
+Type *
+type_mkList(Type *a)
+{
+	Type *type = type_alloc(L_LIST);
+	type->base_type = a;
+	return (type);
+}
+
+Type *
+type_mkClass(void)
+{
+	Type *type = type_alloc(L_CLASS);
+	return (type);
+}

generic/Last.h

@@ -0,0 +1,490 @@
+/*
+ * used to be: tclsh gen-l-ast2.tcl to regenerate
+ * As of Feb 2008 it is maintained by hand.
+ */
+#ifndef L_AST_H
+#define L_AST_H
+
+#define	unless(p)	if (!(p))
+#define	private		static
+
+typedef struct Ast	Ast;
+typedef struct Block	Block;
+typedef struct VarDecl	VarDecl;
+typedef struct FnDecl	FnDecl;
+typedef struct ClsDecl	ClsDecl;
+typedef struct Stmt	Stmt;
+typedef struct TopLev	TopLev;
+typedef struct ClsLev	ClsLev;
+typedef struct Cond	Cond;
+typedef struct Loop	Loop;
+typedef struct ForEach	ForEach;
+typedef struct Switch	Switch;
+typedef struct Case	Case;
+typedef struct Expr	Expr;
+typedef struct Type	Type;
+typedef struct Try	Try;
+typedef struct Sym	Sym;
+
+/*
+ * Source-file offset and line # of an AST node, token, or
+ * nonterminal.  Set by the scanner and parser.
+ */
+typedef struct {
+	int	beg;	// source offset of first char
+	int	end;	// source offset of last char + 1
+	int	line;	// line # of first char adjusted for any #include's
+	char	*file;	// file name
+} YYLTYPE;
+#define YYLTYPE YYLTYPE
+
+typedef enum {
+	L_LOOP_DO,
+	L_LOOP_FOR,
+	L_LOOP_WHILE,
+} Loop_k;
+
+typedef enum {
+	L_STMT_BLOCK,
+	L_STMT_BREAK,
+	L_STMT_COND,
+	L_STMT_CONTINUE,
+	L_STMT_DECL,
+	L_STMT_EXPR,
+	L_STMT_FOREACH,
+	L_STMT_SWITCH,
+	L_STMT_LOOP,
+	L_STMT_RETURN,
+	L_STMT_GOTO,
+	L_STMT_LABEL,
+	L_STMT_PRAGMA,
+	L_STMT_TRY,
+} Stmt_k;
+
+typedef enum {
+	L_TOPLEVEL_CLASS,
+	L_TOPLEVEL_FUN,
+	L_TOPLEVEL_GLOBAL,
+	L_TOPLEVEL_STMT,
+} Toplv_k;
+
+typedef enum {
+	L_NODE_BLOCK,
+	L_NODE_EXPR,
+	L_NODE_FOREACH_LOOP,
+	L_NODE_FUNCTION_DECL,
+	L_NODE_IF_UNLESS,
+	L_NODE_SWITCH,
+	L_NODE_CASE,
+	L_NODE_LOOP,
+	L_NODE_STMT,
+	L_NODE_TOPLEVEL,
+	L_NODE_CLSLEVEL,
+	L_NODE_VAR_DECL,
+	L_NODE_CLASS_DECL,
+} Node_k;
+
+/*
+ * A compiler temp.
+ */
+typedef struct Tmp Tmp;
+struct Tmp {
+	int	free;
+	int	idx;	// local variable slot #
+	char	*name;
+	Tmp	*next;
+};
+
+/*
+ * An L type name is represented with exactly one instance of a
+ * Type structure.  All references to the type name point to that
+ * structure, so pointer comparison can be used to check for name
+ * equivalence of types.
+ *
+ * L_int, L_float, etc are the global Type pointers for the
+ * pre-defined types.  L_INT, L_FLOAT, etc are the type kinds
+ * (enum) used in the type structure.
+ *
+ * L_NAMEOF is like an address in other languages.  An expression
+ * of this type holds the name of an lvalue (e.g., &p has the value
+ * "p").  The base_type is the type of the name.
+ */
+
+typedef enum {
+	L_INT		= 0x0001,
+	L_FLOAT		= 0x0002,
+	L_STRING	= 0x0004,
+	L_ARRAY		= 0x0008,
+	L_HASH		= 0x0010,
+	L_STRUCT	= 0x0020,
+	L_LIST		= 0x0040,
+	L_VOID		= 0x0080,
+	L_POLY		= 0x0100,
+	L_NAMEOF	= 0x0200,
+	L_FUNCTION	= 0x0400,
+	L_CLASS		= 0x0800,
+	L_WIDGET	= 0x1000,
+} Type_k;
+
+struct Type {
+	Type_k	kind;
+	Type	*base_type;	// for array, hash, list, nameof, etc
+	Type	*next;		// for linking list types
+	char	*name;		// if a typedef, the type name being declared
+	union {
+		struct {
+			Expr	*size;
+		} array;
+		struct {
+			Type	*idx_type;
+		} hash;
+		struct {
+			char	*tag;
+			VarDecl	*members;
+		} struc;
+		struct {
+			VarDecl	*formals;
+		} func;
+		struct {
+			ClsDecl	*clsdecl;
+		} class;
+	} u;
+	Type	*list;  // links all type structures ever allocated
+};
+
+struct Ast {
+	Node_k	type;
+	Ast	*next;	// links all nodes in an AST
+	YYLTYPE	loc;
+};
+
+struct Block {
+	Ast	node;
+	Stmt	*body;
+	VarDecl	*decls;
+};
+
+typedef enum {
+	L_EXPR_ID,
+	L_EXPR_CONST,
+	L_EXPR_FUNCALL,
+	L_EXPR_UNOP,
+	L_EXPR_BINOP,
+	L_EXPR_TRINOP,
+	L_EXPR_RE,
+} Expr_k;
+
+typedef enum {
+	L_OP_NONE,
+	L_OP_CAST,
+	L_OP_BANG,
+	L_OP_ADDROF,
+	L_OP_MINUS,
+	L_OP_UMINUS,
+	L_OP_PLUS,
+	L_OP_UPLUS,
+	L_OP_PLUSPLUS_PRE,
+	L_OP_PLUSPLUS_POST,
+	L_OP_MINUSMINUS_PRE,
+	L_OP_MINUSMINUS_POST,
+	L_OP_EQUALS,
+	L_OP_EQPLUS,
+	L_OP_EQMINUS,
+	L_OP_EQSTAR,
+	L_OP_EQSLASH,
+	L_OP_EQPERC,
+	L_OP_EQBITAND,
+	L_OP_EQBITOR,
+	L_OP_EQBITXOR,
+	L_OP_EQLSHIFT,
+	L_OP_EQRSHIFT,
+	L_OP_EQTWID,
+	L_OP_BANGTWID,
+	L_OP_EQDOT,
+	L_OP_STAR,
+	L_OP_SLASH,
+	L_OP_PERC,
+	L_OP_STR_EQ,
+	L_OP_STR_NE,
+	L_OP_STR_GT,
+	L_OP_STR_LT,
+	L_OP_STR_GE,
+	L_OP_STR_LE,
+	L_OP_EQUALEQUAL,
+	L_OP_NOTEQUAL,
+	L_OP_GREATER,
+	L_OP_LESSTHAN,
+	L_OP_GREATEREQ,
+	L_OP_LESSTHANEQ,
+	L_OP_ANDAND,
+	L_OP_OROR,
+	L_OP_LSHIFT,
+	L_OP_RSHIFT,
+	L_OP_BITOR,
+	L_OP_BITAND,
+	L_OP_BITXOR,
+	L_OP_BITNOT,
+	L_OP_DEFINED,
+	L_OP_ARRAY_INDEX,
+	L_OP_HASH_INDEX,
+	L_OP_DOT,
+	L_OP_POINTS,
+	L_OP_CLASS_INDEX,
+	L_OP_INTERP_STRING,
+	L_OP_INTERP_RE,
+	L_OP_LIST,
+	L_OP_KV,
+	L_OP_COMMA,
+	L_OP_ARRAY_SLICE,
+	L_OP_EXPAND,
+	L_OP_CONCAT,
+	L_OP_CMDSUBST,
+	L_OP_TERNARY_COND,
+	L_OP_FILE,
+} Op_k;
+
+/*
+ * Flags for L expression compilation.  Bits are used for simplicity
+ * even though some of these are mutually exclusive.  These are used
+ * in various places such as calls to compile_expr() and in the AST.
+ */
+typedef enum {
+	L_EXPR_RE_I   = 0x00000001, // expr is an re with "i" qualifier
+	L_EXPR_RE_G   = 0x00000002, // expr is an re with "g" qualifier
+	L_EXPR_RE_T   = 0x00000004, // expr is an re with "t" qualifier
+	L_EXPR_DEEP   = 0x00000008, // expr is the result of a deep dive
+	L_IDX_ARRAY   = 0x00000010, // what kind of thing we're indexing
+	L_IDX_HASH    = 0x00000020,
+	L_IDX_STRING  = 0x00000040,
+	L_LVALUE      = 0x00000080, // if we will be writing the obj
+	L_DELETE      = 0x00000100, // delete from parent hash/array/string
+	L_PUSH_VAL    = 0x00000200, // what we want INST_L_INDEX to leave on
+	L_PUSH_PTR    = 0x00000400, //   the stack
+	L_PUSH_VALPTR = 0x00000800,
+	L_PUSH_PTRVAL = 0x00001000,
+	L_DISCARD     = 0x00002000, // have compile_expr push nothing
+	L_PUSH_NAME   = 0x00004000, // have compile_expr push name not val
+	L_PUSH_NEW    = 0x00008000, // whether INST_L_DEEP_WRITE should push
+	L_PUSH_OLD    = 0x00010000, //   the new or old value
+	L_SAVE_IDX    = 0x00020000, // save idx to a tmp var (for copy in/out)
+	L_REUSE_IDX   = 0x00040000, // get idx from tmp var instead of expr
+	L_NOTUSED     = 0x00080000, // do not update used_p in symtab entry
+	L_NOWARN      = 0x00100000, // issue no err if symbol undefined
+	L_SPLIT_RE    = 0x00200000, // split on a regexp
+	L_SPLIT_STR   = 0x00400000, // split on a string
+	L_SPLIT_LIM   = 0x00800000, // enforce split limit
+	L_INSERT_ELT  = 0x01000000, // insert a single elt into a list
+	L_INSERT_LIST = 0x02000000, // insert a list into a list
+	L_NEG_OK      = 0x04000000, // indexing element -1 is OK
+	L_EXPR_RE_L   = 0x08000000, // expr is an re with "l" qualifier
+} Expr_f;
+
+struct Expr {
+	Ast	node;
+	Expr_k	kind;
+	Op_k	op;
+	Type	*type;
+	Expr	*a;
+	Expr	*b;
+	Expr	*c;
+	Expr_f	flags;
+	Sym	*sym;  // for id, ptr to symbol table entry
+	char	*str;  // for constants/id/re/struct-index
+	union {
+		struct {
+			Tmp	*idx;
+			Tmp	*val;
+		} deepdive;
+	} u;
+	Expr	*next;
+};
+
+struct ForEach {
+	Ast	node;
+	Expr	*expr;
+	Expr	*key;
+	Expr	*value;
+	Stmt	*body;
+};
+
+struct FnDecl {
+	Ast	node;
+	Block	*body;
+	VarDecl	*decl;
+	FnDecl	*next;
+	Tcl_Obj	*attrs;		// hash of function attributes, if any
+};
+
+struct ClsDecl {
+	Ast	node;
+	VarDecl	*decl;
+	VarDecl	*clsvars;
+	VarDecl	*instvars;
+	FnDecl	*fns;
+	FnDecl	*constructors;
+	FnDecl	*destructors;
+	Tcl_HashTable *symtab;
+};
+
+struct Cond {
+	Ast	node;
+	Expr	*cond;
+	Stmt	*else_body;
+	Stmt	*if_body;
+};
+
+struct Loop {
+	Ast	node;
+	Expr	*cond;
+	Expr	*post;
+	Expr	*pre;
+	Loop_k	kind;
+	Stmt	*body;
+};
+
+struct Switch {
+	Ast	node;
+	Expr	*expr;
+	Case	*cases;
+};
+
+struct Case {
+	Ast	node;
+	Expr	*expr;
+	Stmt	*body;
+	Case	*next;
+};
+
+struct Try {
+	Ast	node;
+	Stmt	*try;
+	Stmt	*catch;
+	Expr	*msg;
+};
+
+struct Stmt {
+	Ast	node;
+	Stmt	*next;
+	Stmt_k	kind;
+	union {
+		Block	*block;
+		Expr	*expr;
+		ForEach	*foreach;
+		Cond	*cond;
+		Loop	*loop;
+		Switch	*swich;  // not a typo -- illegal to call it "switch"
+		VarDecl	*decl;
+		char	*label;
+		Try	*try;
+	} u;
+};
+
+struct TopLev {
+	Ast	node;
+	TopLev	*next;
+	Toplv_k	kind;
+	union {
+		ClsDecl	*class;
+		FnDecl	*fun;
+		Stmt	*stmt;
+		VarDecl	*global;
+	} u;
+};
+
+/*
+ * These encode both scope information and the kind of declaration.
+ * Some flags are redundant but were chosen for clarity.
+ */
+typedef enum {
+	SCOPE_LOCAL		= 0x00000001, // scope the symbol should go in
+	SCOPE_SCRIPT		= 0x00000002, //   visible in current script
+	SCOPE_GLOBAL		= 0x00000004, //   visible across scripts
+	SCOPE_CLASS		= 0x00000008, //   visible in a class
+	DECL_GLOBAL_VAR		= 0x00000010, // the kind of declaration
+	DECL_LOCAL_VAR		= 0x00000020,
+	DECL_ERR		= 0x00000040, //   added on undeclared var
+	DECL_FN			= 0x00000080, //   regular function
+	DECL_CLASS_VAR		= 0x00000100, //   class variable
+	DECL_CLASS_INST_VAR	= 0x00000200, //   class instance variable
+	DECL_CLASS_FN		= 0x00000400, //   class member fn
+	DECL_CLASS_CONST	= 0x00000800, //   class constructor
+	DECL_CLASS_DESTR	= 0x00001000, //   class destructor
+	DECL_REST_ARG		= 0x00002000, //   ...arg formal parameter
+	DECL_EXTERN		= 0x00004000, // decl has extern qualifier
+	DECL_PRIVATE		= 0x00008000, // decl has private qualifier
+	DECL_PUBLIC		= 0x00010000, // decl has public qualifier
+	DECL_REF		= 0x00020000, // decl has & qualifier
+	DECL_ARGUSED		= 0x00040000, // decl has _argused qualifier
+	DECL_OPTIONAL		= 0x00080000, // decl has _optional qualifier
+	DECL_NAME_EQUIV		= 0x00100000, // decl has _mustbetype qualifier
+	DECL_FORWARD		= 0x00200000, // a forward decl
+	DECL_DONE		= 0x00400000, // decl already processed
+	FN_PROTO_ONLY		= 0x00800000, // compile fn proto only
+	FN_PROTO_AND_BODY	= 0x01000000, // compile entire fn decl
+} Decl_f;
+
+struct VarDecl {
+	Ast	node;
+	Expr	*id;
+	char	*tclprefix;	// prepend to L var name to create Tcl var name
+	Expr	*initializer;
+	Expr	*attrs;		// optional _attributes(...)
+	Type	*type;
+	ClsDecl	*clsdecl;	// for class member fns, class & instance vars
+	Sym	*refsym;	// for a call-by-ref parm x, ptr to &x sym
+	VarDecl	*next;
+	Decl_f	flags;
+};
+
+extern Expr	*ast_mkBinOp(Op_k op, Expr *e1, Expr *e2, YYLTYPE beg,
+			     YYLTYPE end);
+extern Block	*ast_mkBlock(VarDecl *decls,Stmt *body, YYLTYPE beg,
+			     YYLTYPE end);
+extern Case	*ast_mkCase(Expr *expr, Stmt *body, YYLTYPE beg,
+			    YYLTYPE end);
+extern ClsDecl	*ast_mkClsDecl(VarDecl *decl, YYLTYPE beg, YYLTYPE end);
+extern Expr	*ast_mkConst(Type *type, char *str, YYLTYPE beg,
+			     YYLTYPE end);
+extern FnDecl	*ast_mkConstructor(ClsDecl *class);
+extern FnDecl	*ast_mkDestructor(ClsDecl *class);
+extern Expr	*ast_mkExpr(Expr_k kind, Op_k op, Expr *a, Expr *b, Expr *c,
+			    YYLTYPE beg, YYLTYPE end);
+extern Expr	*ast_mkFnCall(Expr *id, Expr *arg_list, YYLTYPE beg,
+			      YYLTYPE end);
+extern FnDecl	*ast_mkFnDecl(VarDecl *decl, Block *body, YYLTYPE beg,
+			      YYLTYPE end);
+extern ForEach	*ast_mkForeach(Expr *hash, Expr *key, Expr *value,
+			       Stmt *body, YYLTYPE beg, YYLTYPE end);
+extern Expr	*ast_mkId(char *name, YYLTYPE beg, YYLTYPE end);
+extern Cond	*ast_mkIfUnless(Expr *expr, Stmt *if_body, Stmt *else_body,
+				YYLTYPE beg, YYLTYPE end);
+extern Loop	*ast_mkLoop(Loop_k kind, Expr *pre, Expr *cond, Expr *post,
+			    Stmt *body, YYLTYPE beg, YYLTYPE end);
+extern Expr	*ast_mkRegexp(char *re, YYLTYPE beg, YYLTYPE end);
+extern Stmt	*ast_mkStmt(Stmt_k kind, Stmt *next, YYLTYPE beg,
+			    YYLTYPE end);
+extern Switch	*ast_mkSwitch(Expr *expr, Case *cases, YYLTYPE beg,
+			      YYLTYPE end);
+extern TopLev	*ast_mkTopLevel(Toplv_k kind, TopLev *next, YYLTYPE beg,
+				YYLTYPE end);
+extern Expr	*ast_mkTrinOp(Op_k op, Expr *e1, Expr *e2, Expr *e3,
+			      YYLTYPE beg, YYLTYPE end);
+extern Try	*ast_mkTry(Stmt *try, Expr *msg, Stmt *catch);
+extern Expr	*ast_mkUnOp(Op_k op, Expr *e1, YYLTYPE beg, YYLTYPE end);
+extern VarDecl	*ast_mkVarDecl(Type *type, Expr *name, YYLTYPE beg,
+			       YYLTYPE end);
+extern void	hash_dump(Tcl_Obj *hash);
+extern char	*hash_get(Tcl_Obj *hash, char *key);
+extern void	hash_put(Tcl_Obj *hash, char *key, char *val);
+extern void	hash_rm(Tcl_Obj *hash, char *key);
+extern Type	*type_dup(Type *type);
+extern Type	*type_mkArray(Expr *size, Type *base_type);
+extern Type	*type_mkClass(void);
+extern Type	*type_mkFunc(Type *base_type, VarDecl *formals);
+extern Type	*type_mkHash(Type *index_type, Type *base_type);
+extern Type	*type_mkList(Type *a);
+extern Type	*type_mkNameOf(Type *base_type);
+extern Type	*type_mkScalar(Type_k kind);
+extern Type	*type_mkStruct(char *tag, VarDecl *members);
+
+#endif /* L_AST_H */

generic/Lcompile.h

@@ -0,0 +1,606 @@
+/*
+ * Copyright (c) 2006-2008 BitMover, Inc.
+ */
+#ifndef L_COMPILE_H
+#define L_COMPILE_H
+
+#include <setjmp.h>
+#include "tclInt.h"
+#include "tclCompile.h"
+#include "Last.h"
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+#ifndef FALSE
+#define FALSE 0
+#endif
+
+/* For jump fix-ups. */
+typedef struct Jmp Jmp;
+struct Jmp {
+	int	op;	// jmp instruction bytecode (e.g., INST_JUMP1)
+	int	size;	// size of jmp instruction (1 or 4 bytes)
+	int	offset;	// bytecode offset of jmp instruction
+	Jmp	*next;
+};
+
+/* Semantic stack frame. */
+typedef enum {
+	OUTER		= 0x0001,  // is outer-most
+	SCRIPT		= 0x0002,  // is file scope
+	TOPLEV		= 0x0004,  // is for file top-levels
+	CLS_OUTER	= 0x0008,  // is class outer-most
+	CLS_TOPLEV	= 0x0010,  // is for class top-levels
+	FUNC		= 0x0020,  // frame is at top level of a proc
+	LOOP		= 0x0040,  // frame is for a loop
+	SWITCH		= 0x0080,  // frame is for a switch stmt
+	SKIP		= 0x0100,  // skip frame when searching enclosing scopes
+	SEARCH		= 0x0200,  //   don't skip this frame
+	KEEPSYMS	= 0x0400,  // don't free symtab when scope is closed
+} Frame_f;
+typedef enum {
+	LABEL_USE	= 0x01,    // label is being referenced
+	LABEL_DEF	= 0x02,    // label is being defined
+} Label_f;
+typedef struct Label {
+	char	*name;
+	int	offset;
+	Jmp	*fixups;
+} Label;
+typedef struct Frame {
+	CompileEnv	*envPtr;
+	CompileEnv	*bodyEnvPtr;
+	CompileEnv	*prologueEnvPtr;
+	Proc		*proc;
+	char		*name;
+	Tcl_HashTable	*symtab;
+	Tcl_HashTable	*labeltab;
+	ClsDecl		*clsdecl;
+	Frame_f		flags;
+	// When a compile frame corresponds to a block in the code, we
+	// store the AST node of the block here.
+	Ast		*block;
+	// We collect jump fix-ups for all of the jumps emitted for break and
+	// continue statements, so that we can stuff in the correct jump targets
+	// once we're done compiling the loops.
+	Jmp		*continue_jumps;
+	Jmp		*break_jumps;
+	// Jump fix-up for the jump to the prologue code at the end of a proc,
+	// and the bytecode offset for the jump back.
+	Jmp		*end_jmp;
+	int		proc_top;
+	// Fix-ups for return stmts which all jmp to the end.
+	Jmp		*ret_jmps;
+	// List of temps allocated in this frame.
+	Tmp		*tmps;
+	struct Frame	*prevFrame;
+} Frame;
+
+/* Per-scope tables. Scopes are opened and close at parse time. */
+typedef struct scope Scope;
+struct scope {
+	Tcl_HashTable	*structs;
+	Tcl_HashTable	*typedefs;
+	Scope		*prev;
+};
+
+/*
+ * Global L state.  There is only one of these, reachable via L->global.
+ * The general L command line is
+ * tclsh [-tclsh_opt1] ... [-tclsh_optn] script_name [-script_opt1] ... [-script_optm]
+ */
+typedef struct {
+	int	tclsh_argc;
+	Tcl_Obj	*tclsh_argv;
+	int	script_argc;
+	Tcl_Obj	*script_argv;
+	int	forceL;		// wrap input in #lang L directive
+} Lglobal;
+
+/*
+ * Per-interp L state.  When an interp is created, one of these is
+ * allocated for each interp and associated with the interp.  Whenever
+ * the compiler is entered, it is extracted from the interp.
+ */
+typedef struct {
+	Lglobal	*global;	// L global state
+	Frame	*frame;		// current semantic stack frame
+	Scope	*curr_scope;
+	Ast	*ast_list;	// list of all AST nodes
+	Type	*type_list;	// list of all type descriptors
+	void	*ast;		// ptr to AST root, set by parser
+	Tcl_Obj	*errs;
+	int	err;		// =1 if there was any compile error
+	char	*dir;		// absolute path to dir containing L->file
+	char	*file;
+	int	line;
+	int	prev_token_len;
+	int	token_off;	// offset of curr token from start of input
+	int	prev_token_off;	// offset of prev token from start of input
+	Tcl_Obj	*script;	// src of script being compiled
+	int	script_len;
+	Tcl_Obj	*options;	// hash of command-line options
+	FnDecl	*enclosing_func;
+	Frame	*enclosing_func_frame;
+	Ast	*mains_ast;	// root of AST when main() last seen
+	Tcl_HashTable	*include_table;
+	Tcl_Interp	*interp;
+	Op_k	idx_op;		// kind of enclosing index (. -> [] {})
+	int	tmpnum;		// for creating tmp variables
+	char	*toplev;	// name of toplevel proc
+	jmp_buf	jmp;		// for syntax error longjmp bail out
+	int	expr_level;	// compile_expr() recursion depth
+	int	call_level;	// compile_expr() level of last fn call
+	Tcl_Obj	*fn_calls;	// list of all fn calls compiled
+	Tcl_Obj	*fn_decls;	// hash of all L fns
+} Linterp;
+
+/*
+ * Symbol table entry, for variables and functions (typedef and struct
+ * names have their own tables).  The tclname can be different from
+ * the L name if we have to mangle the name as we do for L globals.
+ * The decl pointer is used to get line# info for error messages.
+ */
+typedef enum {
+	L_SYM_LVAR	= 0x0001,	// a local variable
+	L_SYM_GVAR	= 0x0002,	// a global variable
+	L_SYM_LSHADOW	= 0x0004,	// a global upvar shadow (these
+					// are also locals)
+	L_SYM_FN	= 0x0008,	// a function
+	L_SYM_FNBODY	= 0x0010,	// function body has been declared
+} Sym_k;
+struct Sym {
+	Sym_k	kind;
+	char	*name;		// the L name
+	char	*tclname;	// the tcl name (can be same as L name)
+	Type	*type;
+	int	idx;		// slot# for local var
+	int	used_p;		// TRUE iff var has been referenced
+	VarDecl	*decl;
+};
+
+/*
+ * For our getopt.  Note that this renders libc's getopt unusable,
+ * but the #define's are kept for compatibility with our getopt.
+ */
+
+#define getopt  mygetopt
+#define optind  myoptind
+#define optarg  myoptarg
+#define optopt  myoptopt
+
+extern  int     optind;
+extern  int     optopt;
+extern  char    *optarg;
+
+typedef struct {
+	char    *name;	/* name w args ex: "url:" */
+	int     ret;	/* return value from getopt */
+} longopt;
+
+#define GETOPT_EOF	-1
+#define GETOPT_ERR      256
+
+extern char	*cksprintf(const char *fmt, ...);
+extern char	*ckstrdup(const char *str);
+extern char	*ckstrndup(const char *str, int len);
+extern char	*ckvsprintf(const char *fmt, va_list ap, int len);
+extern int	getopt(int ac, char **av, char *opts, longopt *lopts);
+extern void	getoptReset(void);
+extern void	L_bomb(const char *format, ...);
+extern void	L_compile_attributes(Tcl_Obj *hash, Expr *expr,
+				     char *allowed[]);
+extern char	*L_dirname(char *path);
+extern void	L_err(const char *s, ...);
+extern void	L_errf(void *node, const char *format, ...);
+extern int	L_isUndef(Tcl_Obj *o);
+extern void	L_lex_begLhtml();
+extern void	L_lex_endLhtml();
+extern void	L_lex_begReArg(int kind);
+extern void	L_lex_start(void);
+extern int	L_parse(void);			// yyparse
+extern void	L_scope_enter();
+extern void	L_scope_leave();
+extern void	L_set_baseType(Type *type, Type *base_type);
+extern void	L_set_declBaseType(VarDecl *decl, Type *base_type);
+extern Tcl_Obj	*L_split(Tcl_Interp *interp, Tcl_Obj *strobj,
+			 Tcl_Obj *delimobj, Tcl_Obj *limobj, Expr_f flags);
+extern Type	*L_struct_lookup(char *tag, int local);
+extern Type	*L_struct_store(char *tag, VarDecl *members);
+extern void	L_synerr(const char *s);	// yyerror
+extern void	L_synerr2(const char *s, int offset);
+extern void	L_trace(const char *format, ...);
+extern char	*L_type_str(Type_k kind);
+extern void	L_typeck_init();
+extern int	L_typeck_arrElt(Type *var, Type *array);
+extern void	L_typeck_assign(Expr *lhs, Type *rhs);
+extern int	L_typeck_compat(Type *lhs, Type *rhs);
+extern int	L_typeck_declType(VarDecl *decl);
+extern void	L_typeck_deny(Type_k deny, Expr *expr);
+extern void	L_typeck_expect(Type_k want, Expr *expr, char *msg);
+extern void	L_typeck_fncall(VarDecl *formals, Expr *call);
+extern void	L_typeck_main(VarDecl *decl);
+extern int	L_typeck_same(Type *a, Type *b);
+extern Type	*L_typedef_lookup(char *name);
+extern void	L_typedef_store(VarDecl *decl);
+extern Tcl_Obj **L_undefObjPtrPtr();
+extern void	L_warnf(void *node, const char *format, ...);
+
+extern Linterp	*L;
+extern char	*L_attrs_attribute[];
+extern char	*L_attrs_cmdLine[];
+extern char	*L_attrs_pragma[];
+extern Tcl_ObjType L_undefType;
+extern Type	*L_int;
+extern Type	*L_float;
+extern Type	*L_string;
+extern Type	*L_void;
+extern Type	*L_poly;
+extern Type	*L_widget;
+
+static inline int
+istype(Expr *expr, int type_flags)
+{
+	return (expr->type && (expr->type->kind & type_flags));
+}
+static inline int
+isarray(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_ARRAY));
+}
+static inline int
+ishash(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_HASH));
+}
+static inline int
+isstruct(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_STRUCT));
+}
+static inline int
+isint(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_INT));
+}
+static inline int
+isfloat(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_FLOAT));
+}
+static inline int
+isstring(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_STRING));
+}
+static inline int
+iswidget(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_WIDGET));
+}
+static inline int
+isvoid(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_VOID));
+}
+static inline int
+ispoly(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_POLY));
+}
+static inline int
+isscalar(Expr *expr)
+{
+	return (expr->type && (expr->type->kind & (L_INT |
+						   L_FLOAT |
+						   L_STRING |
+						   L_WIDGET |
+						   L_POLY)));
+}
+static inline int
+isconst(Expr *expr)
+{
+	return (expr->kind == L_EXPR_CONST);
+}
+static inline int
+islist(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_LIST));
+}
+static inline int
+isclass(Expr *expr)
+{
+	return (expr->type && (expr->type->kind == L_CLASS));
+}
+static inline int
+isregexp(Expr *expr)
+{
+	return ((expr->kind == L_EXPR_RE) ||
+		((expr->kind == L_EXPR_BINOP) && (expr->op == L_OP_INTERP_RE)));
+}
+static inline int
+ispolytype(Type *type)
+{
+	return (type->kind == L_POLY);
+}
+static inline int
+islisttype(Type *type)
+{
+	return (type->kind == L_LIST);
+}
+static inline int
+ishashtype(Type *type)
+{
+	return (type->kind == L_HASH);
+}
+static inline int
+isfntype(Type *type)
+{
+	return (type->kind == L_FUNCTION);
+}
+static inline int
+isinttype(Type *type)
+{
+	return (type->kind == L_INT);
+}
+static inline int
+isvoidtype(Type *type)
+{
+	return (type->kind == L_VOID);
+}
+static inline int
+isnameoftype(Type *type)
+{
+	return (type->kind == L_NAMEOF);
+}
+static inline int
+isclasstype(Type *type)
+{
+	return (type->kind == L_CLASS);
+}
+static inline int
+isarrayoftype(Type *type, Type_k kind)
+{
+	return ((type->kind == L_ARRAY) && (type->base_type->kind & kind));
+}
+static inline int
+ishashoftype(Type *type, Type_k base, Type_k elt)
+{
+	return ((type->kind == L_HASH) &&
+		(type->base_type->kind & base) &&
+		(type->u.hash.idx_type->kind & elt));
+}
+static inline int
+isaddrof(Expr *expr)
+{
+	return ((expr->kind == L_EXPR_UNOP) && (expr->op == L_OP_ADDROF));
+}
+static inline int
+isexpand(Expr *expr)
+{
+	return ((expr->kind == L_EXPR_UNOP) && (expr->op == L_OP_EXPAND));
+}
+static inline int
+iskv(Expr *expr)
+{
+	return ((expr->kind == L_EXPR_BINOP) && (expr->op == L_OP_KV));
+}
+static inline int
+isinterp(Expr *expr)
+{
+	return ((expr->kind == L_EXPR_BINOP) && (expr->op == L_OP_INTERP_STRING));
+}
+static inline int
+isid(Expr *expr, char *s)
+{
+	return ((expr->kind == L_EXPR_ID) && !strcmp(expr->str, s));
+}
+static inline int
+isarrayof(Expr *expr, Type_k kind)
+{
+	return (isarray(expr) && (expr->type->base_type->kind & kind));
+}
+/*
+ * Return the flags that match the kind of variable we can
+ * dereference: globals, locals, class variables, and class instance
+ * variables.
+ */
+static inline int
+canDeref(Sym *sym)
+{
+	return (sym->decl->flags & (DECL_GLOBAL_VAR | DECL_LOCAL_VAR |
+				    DECL_FN | DECL_CLASS_INST_VAR |
+				    DECL_CLASS_VAR));
+}
+/*
+ * This checks whether the Expr node is a deep-dive operation that has
+ * left a deep-ptr on the run-time stack.
+ */
+static inline int
+isdeepdive(Expr *expr)
+{
+	return (expr->flags & (L_PUSH_PTR | L_PUSH_PTRVAL | L_PUSH_VALPTR));
+}
+static inline int
+isClsConstructor(VarDecl *decl)
+{
+	return (decl->flags & DECL_CLASS_CONST);
+}
+static inline int
+isClsDestructor(VarDecl *decl)
+{
+	return (decl->flags & DECL_CLASS_DESTR);
+}
+static inline int
+isClsFnPublic(VarDecl *decl)
+{
+	return ((decl->flags & (DECL_CLASS_FN | DECL_PUBLIC)) ==
+		(DECL_CLASS_FN | DECL_PUBLIC));
+}
+static inline int
+isClsFnPrivate(VarDecl *decl)
+{
+	return ((decl->flags & (DECL_CLASS_FN | DECL_PRIVATE)) ==
+		(DECL_CLASS_FN | DECL_PRIVATE));
+}
+static inline int
+typeis(Type *type, char *name)
+{
+	return (type->name && !strcmp(type->name, name));
+}
+static inline int
+typeisf(Expr *expr, char *name)
+{
+	return (expr->type->name && !strcmp(expr->type->name, name));
+}
+static inline void
+emit_load_scalar(int idx)
+{
+	/*
+	 * The next line is a hack so we can generate disassemblable
+	 * code even in the presence of obscure compilation errors
+	 * that cause the value of a function name to be attempted to
+	 * be loaded.  Without this, tcl will die trying to output a
+	 * disassembly since the local # (-1) would be invalid.
+	 */
+	if (idx == -1) idx = 0;
+
+	if (idx <= 255) {
+		TclEmitInstInt1(INST_LOAD_SCALAR1, idx, L->frame->envPtr);
+	} else {
+		TclEmitInstInt4(INST_LOAD_SCALAR4, idx, L->frame->envPtr);
+	}
+}
+static inline void
+emit_store_scalar(int idx)
+{
+	if (idx <= 255) {
+		TclEmitInstInt1(INST_STORE_SCALAR1, idx, L->frame->envPtr);
+	} else {
+		TclEmitInstInt4(INST_STORE_SCALAR4, idx, L->frame->envPtr);
+	}
+}
+static inline void
+push_litf(const char *str, ...)
+{
+	va_list ap;
+	int	len = 64;
+	char	*buf;
+
+	va_start(ap, str);
+	while (!(buf = ckvsprintf(str, ap, len))) {
+		va_end(ap);
+		va_start(ap, str);
+		len *= 2;
+	}
+	va_end(ap);
+	/*
+	 * Subtle: register the literal in the body CompileEnv since
+	 * all the code ends up there anyway.  If we put it in the
+	 * prologue CompileEnv, we'd have to fix-up all the literal
+	 * numbers when we splice the prologue into the body.
+	 */
+	TclEmitPush(TclRegisterNewLiteral(L->frame->bodyEnvPtr, buf, strlen(buf)),
+		    L->frame->envPtr);
+	ckfree(buf);
+}
+static inline void
+push_lit(const char *str)
+{
+	/* See comment above about registering in the body CompileEnv. */
+	TclEmitPush(TclRegisterNewLiteral(L->frame->bodyEnvPtr, str,
+					  strlen(str)), L->frame->envPtr);
+}
+static inline void
+emit_invoke(int size)
+{
+	if (size < 256) {
+		TclEmitInstInt1(INST_INVOKE_STK1, size, L->frame->envPtr);
+	} else {
+		TclEmitInstInt4(INST_INVOKE_STK4, size, L->frame->envPtr);
+	}
+}
+static inline void
+emit_invoke_expanded()
+{
+	TclEmitOpcode(INST_INVOKE_EXPANDED, L->frame->envPtr);
+}
+static inline void
+emit_pop()
+{
+	TclEmitOpcode(INST_POP, L->frame->envPtr);
+}
+static inline int
+currOffset(CompileEnv *envPtr)
+{
+	/* Offset of the next instruction to be generated. */
+	return (envPtr->codeNext - envPtr->codeStart);
+}
+
+/*
+ * REVERSE() assumes that l is a singly linked list of type type with
+ * forward pointers named ptr.  The last element in the list becomes
+ * the first and is stored back into l.
+ */
+#define REVERSE(type,ptr,l)						\
+    do {								\
+	type *a, *b, *c;						\
+	for (a = NULL, b = l, c = (l ? ((type *)l)->ptr : NULL);	\
+	     b != NULL;							\
+	     b->ptr = a, a = b, b = c, c = (c ? c->ptr : NULL)) ;	\
+	*(type **)&(l) = a;						\
+    } while (0)
+
+/*
+ * APPEND() starts at a, walks ptr until the end, and then attaches b
+ * to a.  (Note that it's actually NCONC).
+ */
+#define APPEND(type,ptr,a,b)						\
+    do {								\
+	    type *runner;						\
+	    for (runner = a; runner->ptr; runner = runner->ptr) ;	\
+	    runner->ptr = b;						\
+    } while (0)
+
+/*
+ * Like APPEND() but if a is NULL, set a to b.
+ */
+#define APPEND_OR_SET(type,ptr,a,b)					\
+    do {								\
+	    if (a) {							\
+		type *runner;						\
+		for (runner = a; runner->ptr; runner = runner->ptr) ;	\
+		runner->ptr = b;					\
+	    } else {							\
+		a = b;							\
+	    }								\
+    } while (0)
+
+/*
+ * YYLOC_DEFAULT() is invoked by the scanner after matching a pattern
+ * and before executing its code.  It tracks the source-file offset
+ * and line #.
+ */
+extern YYLTYPE L_lloc;
+#define YYLLOC_DEFAULT(c,r,n)				\
+	do {						\
+		if (n) {				\
+			(c).beg = YYRHSLOC(r,1).beg;	\
+			(c).end = YYRHSLOC(r,n).end;	\
+		} else {				\
+			(c).beg = YYRHSLOC(r,0).beg;	\
+			(c).end = YYRHSLOC(r,0).end;	\
+		}					\
+		(c).line = L->line;			\
+		(c).file = L->file;			\
+	} while (0)
+
+#ifdef TCL_COMPILE_DEBUG
+#define ASSERT(c)  unless (c) \
+	L_bomb("Assertion failed: %s:%d: %s\n", __FILE__, __LINE__, #c)
+#else
+#define ASSERT(c)  do {} while(0)
+#endif
+
+#endif /* L_COMPILE_H */

generic/Lgetopt.c

@@ -0,0 +1,238 @@
+#include "Lcompile.h"
+
+/* for compat with code below */
+#define streq(a, b)	(!strcmp(a, b))
+#define strneq(a, b, n)	(!strncmp(a, b, n))
+#define assert(x)
+
+/*
+ * Copyright (c) 1997 L.W.McVoy
+ *
+ * This version handles
+ *
+ *	-	(leaves it and returns)
+ *	--	end of options
+ *	-a
+ *	-abcd
+ *	-r <arg>
+ *	-r<arg>
+ *	-abcr <arg>
+ *	-abcr<arg>
+ *	-r<arg> -R<arg>, etc.
+ *	--long
+ *	--long:<arg>
+ *	--long=<arg>
+ *	--long <arg>
+ *
+ * Patterns in getopt string:
+ *	d	boolean option		-d
+ *	d:	required arg		-dARG or -d ARG
+ *	d;	required arg no space   -dARG
+ *	d|	optionial arg no space	-dARG or -d
+ *
+ * With long options:
+ *	long	boolean option		--long
+ *	long:	required arg		--long=ARG or --long ARG
+ *	long;	required arg no space   --long=ARG
+ *	long|	optionial arg no space	--long=ARG or --long
+ */
+
+int	optopt;		/* option that is in error, if we return an error */
+int	optind;		/* next arg in argv we process */
+char	*optarg;	/* argument to an option */
+static int n;		/* current position == av[optind][n] */
+static int lastn;	/* saved copy of last n */
+
+private	int	doLong(int ac, char **av, longopt *lopts);
+
+void
+getoptReset(void)
+{
+	optopt = optind = 0;
+	optarg = 0;
+}
+
+void
+getoptConsumed(int n1)
+{
+	optind--;
+	unless (optind) optind = 1;
+	n = lastn + n1;
+	// TRACE("optind = %d, n = %d, n1 = %d", optind, n, n1);
+}
+
+/*
+ * Returns:
+ *    - char if option found
+ *    - GETOPT_EOF(-1) if end of arguments reached
+ *    - GETOPT_ERR(256) if unknown option found.
+ */
+int
+getopt(int ac, char **av, char *opts, longopt *lopts)
+{
+	char	*t;
+
+	optarg = 0;	/* clear out arg from last round */
+	optopt = 0;	/* clear error return */
+	if (!optind) {
+		optind = 1;
+		lastn = n;
+		n = 1;
+	}
+	// TRACE("GETOPT ind=%d n=%d av[%d]='%s'", optind, n, optind, av[optind]);
+
+	if ((optind >= ac) || (av[optind][0] != '-') || !av[optind][1]) {
+		return (GETOPT_EOF);
+	}
+	/* Stop processing options at a -- and return arguments after */
+	if (streq(av[optind], "--")) {
+		optind++;
+		lastn = n;
+		n = 1;
+		return (GETOPT_EOF);
+	}
+	if (strneq(av[optind], "--", 2)) return (doLong(ac, av, lopts));
+
+	assert(av[optind][n]);
+	for (t = (char *)opts; *t; t++) {
+		if (*t == av[optind][n]) {
+			break;
+		}
+	}
+	if (!*t) {
+		optopt = av[optind][n];
+		// TRACE("%s", "ran out of option letters");
+		lastn = n;
+		if (av[optind][n+1]) {
+			n++;
+		} else {
+			n = 1;
+			optind++;
+		}
+		return (GETOPT_ERR);
+	}
+
+	/* OK, we found a legit option, let's see what to do with it.
+	 * If it isn't one that takes an option, just advance and return.
+	 */
+	if (t[1] != ':' && t[1] != '|' && t[1] != ';') {
+		lastn = n;
+		if (!av[optind][n+1]) {
+			optind++;
+			n = 1;
+		} else {
+			n++;
+		}
+		// TRACE("Legit singleton %c", *t);
+		return (*t);
+	}
+
+	/* got one with an option, see if it is cozied up to the flag */
+	if (av[optind][n+1]) {
+		optarg = &av[optind][n+1];
+		optind++;
+		lastn = n;
+		n = 1;
+		// TRACE("%c with %s", *t, optarg);
+		return (*t);
+	}
+
+	/* If it was not there, and it is optional, OK */
+	if (t[1] == '|') {
+		optind++;
+		lastn = n;
+		n = 1;
+		// TRACE("%c without arg", *t);
+		return (*t);
+	}
+
+	/* was it supposed to be there? */
+	if (t[1] == ';') {
+		optind++;
+		optopt = *t;
+		// TRACE("%s", "wanted another word");
+		return (GETOPT_ERR);
+	}
+
+	/* Nope, there had better be another word. */
+	if ((optind + 1 == ac) || (av[optind+1][0] == '-')) {
+		optopt = av[optind][n];
+		// TRACE("%s", "wanted another word");
+		return (GETOPT_ERR);
+	}
+	optarg = av[optind+1];
+	optind += 2;
+	lastn = n;
+	n = 1;
+	// TRACE("%c with arg %s", *t, optarg);
+	return (*t);
+}
+
+private int
+doLong(int ac, char **av, longopt *lopts)
+{
+	char	*s, *t;
+	int	len1, len2;
+
+	unless (lopts) {
+err:		n = 1;
+		optind++;
+		optopt = 0;
+		return (GETOPT_ERR);
+	}
+	/* len of option without =value part */
+	s = av[optind] + 2;
+	unless (t = strchr(s, '=')) t = strchr(s, ':');
+	len1 = t ? (t - s) : strlen(s);
+	for (; (t = lopts->name); lopts++) {
+		s = av[optind] + 2;
+		/* len of lopts array without suffix */
+		len2 = strlen(t);
+		if (strspn(t+len2-1, ":;|") == 1) --len2;
+
+		if ((len1 == len2) && strneq(s, t, len1)) {
+			s += len1;
+			t += len2;
+			break;	/* found a match */
+		}
+	}
+	unless (t) goto err;
+
+	/* OK, we found a legit option, let's see what to do with it.
+	 * If it isn't one that takes an option, just advance and return.
+	 */
+	unless (*t) {
+		/* got option anyway */
+		if ((*s == '=') || (*s == ':')) goto err;
+		optind++;
+		n = 1;
+		return (lopts->ret);
+	}
+
+	/* got one with an option, see if it is cozied up to the flag */
+	if ((*s == '=') || (*s == ':')) {
+		optarg = s + 1;
+		optind++;
+		n = 1;
+		return (lopts->ret);
+	}
+
+	/* If it was not there, and it is optional, OK */
+	if (*t == '|') {
+		optind++;
+		n = 1;
+		return (lopts->ret);
+	}
+
+	/* was it supposed to be there? */
+	if (*t == ';') goto err;
+
+	/* Nope, there had better be another word. */
+	if ((optind + 1 == ac) || (av[optind+1][0] == '-')) {
+		goto err;
+	}
+	optarg = av[optind+1];
+	optind += 2;
+	n = 1;
+	return (lopts->ret);
+}

generic/Lgrammar.h

@@ -0,0 +1,233 @@
+/* A Bison parser, made by GNU Bison 2.3.  */
+
+/* Skeleton interface for Bison GLR parsers in C
+
+   Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+
+   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., 51 Franklin Street, Fifth Floor,
+   Boston, MA 02110-1301, USA.  */
+
+/* As a special exception, you may create a larger work that contains
+   part or all of the Bison parser skeleton and distribute that work
+   under terms of your choice, so long as that work isn't itself a
+   parser generator using the skeleton or a modified version thereof
+   as a parser skeleton.  Alternatively, if you modify or redistribute
+   the parser skeleton itself, you may (at your option) remove this
+   special exception, which will cause the skeleton and the resulting
+   Bison output files to be licensed under the GNU General Public
+   License without this special exception.
+
+   This special exception was added by the Free Software Foundation in
+   version 2.2 of Bison.  */
+
+/* Tokens.  */
+#ifndef YYTOKENTYPE
+# define YYTOKENTYPE
+   /* Put the tokens into the symbol table, so that GDB and other debuggers
+      know about them.  */
+   enum yytokentype {
+     END = 0,
+     T_ANDAND = 258,
+     T_ARROW = 259,
+     T_ATTRIBUTE = 260,
+     T_BANG = 261,
+     T_BANGTWID = 262,
+     T_BITAND = 263,
+     T_BITOR = 264,
+     T_BITNOT = 265,
+     T_BITXOR = 266,
+     T_BREAK = 267,
+     T_CLASS = 268,
+     T_COLON = 269,
+     T_COMMA = 270,
+     T_CONSTRUCTOR = 271,
+     T_CONTINUE = 272,
+     T_DEFINED = 273,
+     T_DESTRUCTOR = 274,
+     T_DO = 275,
+     T_DOT = 276,
+     T_DOTDOT = 277,
+     T_ELLIPSIS = 278,
+     T_ELSE = 279,
+     T_EQ = 280,
+     T_EQBITAND = 281,
+     T_EQBITOR = 282,
+     T_EQBITXOR = 283,
+     T_EQDOT = 284,
+     T_EQLSHIFT = 285,
+     T_EQMINUS = 286,
+     T_EQPERC = 287,
+     T_EQPLUS = 288,
+     T_EQRSHIFT = 289,
+     T_EQSTAR = 290,
+     T_EQSLASH = 291,
+     T_EQTWID = 292,
+     T_EQUALS = 293,
+     T_EQUALEQUAL = 294,
+     T_EXPAND = 295,
+     T_EXTERN = 296,
+     T_FLOAT = 297,
+     T_FLOAT_LITERAL = 298,
+     T_FOR = 299,
+     T_FOREACH = 300,
+     T_GOTO = 301,
+     T_GE = 302,
+     T_GREATER = 303,
+     T_GREATEREQ = 304,
+     T_GT = 305,
+     T_HTML = 306,
+     T_ID = 307,
+     T_IF = 308,
+     T_INSTANCE = 309,
+     T_INT = 310,
+     T_INT_LITERAL = 311,
+     T_LHTML_EXPR_START = 312,
+     T_LHTML_EXPR_END = 313,
+     T_LBRACE = 314,
+     T_LBRACKET = 315,
+     T_LE = 316,
+     T_LEFT_INTERPOL = 317,
+     T_LEFT_INTERPOL_RE = 318,
+     T_LESSTHAN = 319,
+     T_LESSTHANEQ = 320,
+     T_LPAREN = 321,
+     T_LSHIFT = 322,
+     T_LT = 323,
+     T_MINUS = 324,
+     T_MINUSMINUS = 325,
+     T_NE = 326,
+     T_NOTEQUAL = 327,
+     T_OROR = 328,
+     T_PATTERN = 329,
+     T_PERC = 330,
+     T_PLUS = 331,
+     T_PLUSPLUS = 332,
+     T_POINTS = 333,
+     T_POLY = 334,
+     T_PRIVATE = 335,
+     T_PUBLIC = 336,
+     T_QUESTION = 337,
+     T_RBRACE = 338,
+     T_RBRACKET = 339,
+     T_RE = 340,
+     T_RE_MODIFIER = 341,
+     T_RETURN = 342,
+     T_RIGHT_INTERPOL = 343,
+     T_RIGHT_INTERPOL_RE = 344,
+     T_RPAREN = 345,
+     T_RSHIFT = 346,
+     T_TRY = 347,
+     T_SEMI = 348,
+     T_SLASH = 349,
+     T_SPLIT = 350,
+     T_STAR = 351,
+     T_START_BACKTICK = 352,
+     T_STR_BACKTICK = 353,
+     T_STR_LITERAL = 354,
+     T_STRCAT = 355,
+     T_STRING = 356,
+     T_STRUCT = 357,
+     T_SUBST = 358,
+     T_TYPE = 359,
+     T_TYPEDEF = 360,
+     T_UNLESS = 361,
+     T_ARGUSED = 362,
+     T_OPTIONAL = 363,
+     T_MUSTBETYPE = 364,
+     T_VOID = 365,
+     T_WIDGET = 366,
+     T_WHILE = 367,
+     T_PRAGMA = 368,
+     T_SWITCH = 369,
+     T_CASE = 370,
+     T_DEFAULT = 371,
+     LOWEST = 372,
+     ADDRESS = 373,
+     UMINUS = 374,
+     UPLUS = 375,
+     PREFIX_INCDEC = 376,
+     HIGHEST = 377
+   };
+#endif
+
+
+/* Copy the first part of user declarations.  */
+#line 1 "/Users/rob/bk/dev-L-lhtml-fix/src/gui/tcltk/tcl/generic/Lgrammar.y"
+
+/*
+ * Copyright (c) 2006-2008 BitMover, Inc.
+ */
+#include <stdio.h>
+#include "Lcompile.h"
+
+/* L_lex is generated by flex. */
+extern int	L_lex (void);
+
+#define YYERROR_VERBOSE
+#define L_error L_synerr
+
+
+#if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
+typedef union YYSTYPE 
+#line 53 "/Users/rob/bk/dev-L-lhtml-fix/src/gui/tcltk/tcl/generic/Lgrammar.y"
+{
+	long	i;
+	char	*s;
+	Tcl_Obj	*obj;
+	Type	*Type;
+	Expr	*Expr;
+	Block	*Block;
+	ForEach	*ForEach;
+	Switch	*Switch;
+	Case	*Case;
+	FnDecl	*FnDecl;
+	Cond	*Cond;
+	Loop	*Loop;
+	Stmt	*Stmt;
+	TopLev	*TopLev;
+	VarDecl	*VarDecl;
+	ClsDecl	*ClsDecl;
+	struct {
+		Type	*t;
+		char	*s;
+	} Typename;
+}
+/* Line 2616 of glr.c.  */
+#line 209 "Lgrammar.h"
+	YYSTYPE;
+# define YYSTYPE_IS_DECLARED 1
+# define YYSTYPE_IS_TRIVIAL 1
+#endif
+
+#if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED
+typedef struct YYLTYPE
+{
+
+  int first_line;
+  int first_column;
+  int last_line;
+  int last_column;
+
+} YYLTYPE;
+# define YYLTYPE_IS_DECLARED 1
+# define YYLTYPE_IS_TRIVIAL 1
+#endif
+
+
+extern YYSTYPE L_lval;
+
+extern YYLTYPE L_lloc;
+
+

generic/Ltypecheck.c

@@ -0,0 +1,498 @@
+/*
+ * Type-checking helpers for the L programming language.
+ *
+ * Copyright (c) 2006-2008 BitMover, Inc.
+ */
+#include <stdio.h>
+#include "tclInt.h"
+#include "Lcompile.h"
+#include "Lgrammar.h"
+
+private int	typeck_declType(Type *type, VarDecl *decl, int nameof_ok);
+private int	typeck_decls(VarDecl *a, VarDecl *b);
+private void	typeck_fmt(Expr *actuals);
+private int	typeck_list(Type *a, Type *b);
+
+/* Create the pre-defined types. */
+void
+L_typeck_init()
+{
+	L_int    = type_mkScalar(L_INT);
+	L_float  = type_mkScalar(L_FLOAT);
+	L_string = type_mkScalar(L_STRING);
+	L_widget = type_mkScalar(L_WIDGET);
+	L_void   = type_mkScalar(L_VOID);
+	L_poly   = type_mkScalar(L_POLY);
+}
+
+private	Tcl_Obj	*typenmObj = NULL;
+
+private void
+str_add(char *s)
+{
+	if (typenmObj) {
+		Tcl_AppendPrintfToObj(typenmObj, " or %s", s);
+	} else {
+		typenmObj = Tcl_NewStringObj(s, -1);
+		Tcl_IncrRefCount(typenmObj);
+	}
+}
+
+char *
+L_type_str(Type_k kind)
+{
+	if (typenmObj) {
+		Tcl_DecrRefCount(typenmObj);
+		typenmObj = NULL;
+	}
+	if (kind & L_INT)      str_add("int");
+	if (kind & L_FLOAT)    str_add("float");
+	if (kind & L_STRING)   str_add("string");
+	if (kind & L_WIDGET)   str_add("widget");
+	if (kind & L_VOID)     str_add("void");
+	if (kind & L_POLY)     str_add("poly");
+	if (kind & L_HASH)     str_add("hash");
+	if (kind & L_STRUCT)   str_add("struct");
+	if (kind & L_ARRAY)    str_add("array");
+	if (kind & L_LIST)     str_add("list");
+	if (kind & L_FUNCTION) str_add("function");
+	if (kind & L_NAMEOF)   str_add("nameof");
+	if (kind & L_CLASS )   str_add("class");
+	return (Tcl_GetString(typenmObj));
+}
+
+private void
+pr_err(Type_k got, Type_k want, char *bef, char *aft, void *node)
+{
+	Tcl_Obj	*obj = Tcl_NewObj();
+
+	Tcl_IncrRefCount(obj);
+	if (bef) Tcl_AppendPrintfToObj(obj, "%s, ", bef);
+	Tcl_AppendPrintfToObj(obj, "expected type %s", L_type_str(want));
+	Tcl_AppendPrintfToObj(obj, " but got %s", L_type_str(got));
+	if (aft) Tcl_AppendPrintfToObj(obj, " %s", aft);
+	L_errf(node, Tcl_GetString(obj));
+	Tcl_DecrRefCount(obj);
+}
+
+void
+L_typeck_deny(Type_k deny, Expr *expr)
+{
+	ASSERT(expr->type);
+
+	if (hash_get(L->options, "poly")) return;
+
+	if (expr->type->kind & deny) {
+		L_errf(expr, "type %s illegal", L_type_str(expr->type->kind));
+		expr->type = L_poly;  // minimize cascading errors
+	}
+}
+
+void
+L_typeck_expect(Type_k want, Expr *expr, char *msg)
+{
+	ASSERT(expr->type);
+
+	if (hash_get(L->options, "poly") ||
+	    ((expr->type->kind | want) & L_POLY)) return;
+
+	unless (expr->type->kind & want) {
+		pr_err(expr->type->kind, want, NULL, msg, expr);
+		expr->type = L_poly;  // minimize cascading errors
+	}
+}
+
+int
+L_typeck_compat(Type *lhs, Type *rhs)
+{
+	if ((lhs->kind == L_POLY) || (rhs->kind == L_POLY)) {
+		return (TRUE);
+	}
+	if (lhs->kind == L_FLOAT) {
+		return (rhs->kind & (L_INT|L_FLOAT));
+	} else {
+		return (L_typeck_same(lhs, rhs));
+	}
+}
+
+void
+L_typeck_assign(Expr *lhs, Type *rhs)
+{
+	if (hash_get(L->options, "poly")) return;
+	unless (lhs && rhs) return;
+
+	if ((rhs->kind == L_VOID) || (lhs->type->kind == L_VOID)) {
+		L_errf(lhs, "type void illegal");
+	}
+	unless (L_typeck_compat(lhs->type, rhs)) {
+		L_errf(lhs, "assignment of incompatible types");
+	}
+}
+
+void
+L_typeck_fncall(VarDecl *formals, Expr *call)
+{
+	int	i, type_ok;
+	int	rest_arg = 0;
+	Expr	*actuals = call->b;
+
+	if (hash_get(L->options, "poly")) return;
+
+	for (i = 1; actuals && formals; ++i) {
+		if (isexpand(actuals)) return;
+		rest_arg = formals->flags & DECL_REST_ARG;  // is it "...id"?
+		if (formals->flags & DECL_NAME_EQUIV) {
+			type_ok = (formals->type == actuals->type);
+		} else {
+			type_ok = L_typeck_compat(formals->type, actuals->type);
+		}
+		unless (type_ok || rest_arg) {
+			L_errf(call, "parameter %d has incompatible type", i);
+		}
+		if (typeis(formals->type, "FMT")) {
+			typeck_fmt(actuals);
+		}
+		actuals = actuals->next;
+		formals = formals->next;
+	}
+	if (actuals && !rest_arg) {
+		L_errf(call, "too many arguments for function %s",
+		       call->a->str);
+	}
+	if (formals) {
+	    unless ((formals->flags & DECL_REST_ARG) ||
+		    (!formals->next && (formals->flags & DECL_OPTIONAL))) {
+		    L_errf(call, "not enough arguments for function %s",
+			   call->a->str);
+	    }
+	}
+}
+
+/*
+ * Type check a FMT arg, like
+ *    printf(FMT format, ...args)
+ * by checking that the number of % format specifiers in "format" matches the
+ * number of actuals in ...args.  We can do this only if "format" is a
+ * string constant and there are no (expand) operators in the args list.
+ */
+private void
+typeck_fmt(Expr *actuals)
+{
+	int	i, nargs = 0;
+	Expr	*a;
+	Tcl_Obj	*obj, **objv;
+
+	unless (isconst(actuals) && isstring(actuals)) return;
+
+	for (a = actuals->next; a; a = a->next) {
+		if (a->op == L_OP_EXPAND) return;
+		++nargs;
+	}
+
+	obj  = Tcl_NewObj();
+	objv = (Tcl_Obj **)ckalloc(nargs * sizeof(Tcl_Obj *));
+	for (i = 0; i < nargs; ++i) {
+		objv[i] = Tcl_NewIntObj(1);
+		Tcl_IncrRefCount(objv[i]);
+	}
+	if (Tcl_AppendFormatToObj(L->interp, obj, actuals->str,
+				  nargs, objv) == TCL_ERROR) {
+		Tcl_ResetResult(L->interp);
+		L_warnf(actuals, "bad format specifier");
+	}
+	Tcl_DecrRefCount(obj);
+	for (i = 0; i < nargs; ++i) {
+		Tcl_DecrRefCount(objv[i]);
+	}
+	ckfree((char *)objv);
+}
+
+/*
+ * Typecheck the declaration of main() against the allowable forms:
+ *
+ * void|int main()
+ * void|int main(void)
+ * void|int main(string av[])
+ * void|int main(int ac, string av[])
+ * void|int main(int ac, string av[], string env{string})
+ */
+void
+L_typeck_main(VarDecl *decl)
+{
+	int	n;
+	Type	*type = decl->type;
+	VarDecl	*v;
+
+	unless (isinttype(type->base_type) || isvoidtype(type->base_type)) {
+		L_errf(decl, "main must have int or void return type");
+	}
+
+	/*
+	 * Avoid later unused-variable errors on the argc, argv, or
+	 * env formals by marking them as used.
+	 */
+	for (n = 0, v = type->u.func.formals; v; v = v->next, ++n) {
+		v->flags |= DECL_ARGUSED;
+	}
+
+	v = type->u.func.formals;
+	switch (n) {
+	    case 0:
+		break;
+	    case 1:
+		unless (isvoidtype(v->type) ||
+			isarrayoftype(v->type, L_STRING)) {
+			L_errf(v, "invalid parameter types for main()");
+		}
+		break;
+	    case 2:
+		unless (isinttype(v->type) &&
+			isarrayoftype(v->next->type, L_STRING)) {
+			L_errf(v, "invalid parameter types for main()");
+		}
+		break;
+	    case 3:
+		unless (isinttype(v->type) &&
+			isarrayoftype(v->next->type, L_STRING) &&
+			ishashoftype(v->next->next->type, L_STRING, L_STRING)) {
+			L_errf(v, "invalid parameter types for main()");
+		}
+		break;
+	    default:
+		L_errf(v, "too many formal parameters for main()");
+		break;
+	}
+}
+
+/*
+ * Check that a declaration uses legal types.  This basically checks
+ * for voids and name-of anywhere in the type where they aren't allowed.
+ */
+int
+L_typeck_declType(VarDecl *decl)
+{
+	return (typeck_declType(decl->type, decl, FALSE));
+}
+private int
+typeck_declType(Type *type, VarDecl *decl, int nameof_ok)
+{
+	int	ret = 1;
+	char	*s = NULL;
+	VarDecl	*v;
+
+	switch (type->kind) {
+	    case L_VOID:
+		s = "void";
+		ret = 0;
+		break;
+	    case L_FUNCTION:
+		/* First check the return type.  Void is legal here. */
+		unless (isvoidtype(type->base_type)) {
+			ret = typeck_declType(type->base_type, decl, FALSE);
+		}
+		/* Now look at the formals. */
+		v = type->u.func.formals;
+		for (v = type->u.func.formals; v; v = v->next) {
+			/* To type-check all formals, don't short-circuit. */
+			ret = typeck_declType(v->type, v, TRUE) && ret;
+		}
+		break;
+	    case L_NAMEOF:
+		if (nameof_ok) {
+			/* Pass FALSE since name-of of a name-of is illegal. */
+			ret = typeck_declType(type->base_type, decl, FALSE);
+		} else {
+			s = "name-of";
+			ret = 0;
+		}
+		break;
+	    case L_ARRAY:
+		ret = typeck_declType(type->base_type, decl, FALSE);
+		break;
+	    case L_HASH:
+		ret = typeck_declType(type->base_type, decl, FALSE) &&
+		      typeck_declType(type->u.hash.idx_type, decl, FALSE);
+		break;
+	    case L_STRUCT:
+		for (v = type->u.struc.members; v; v = v->next) {
+			/* To type-check all members, don't short-circuit. */
+			ret = typeck_declType(v->type, v, FALSE) && ret;
+		}
+		break;
+	    default:
+		break;
+	}
+	if (s) {
+		if (decl->id) {
+			L_errf(decl->id,
+			       "type %s illegal in declaration of '%s'",
+			       s, decl->id->str);
+		} else {
+			L_errf(decl, "type %s illegal", s);
+		}
+	}
+	return (ret);
+}
+
+/*
+ * Determine if two declaration lists have structurally equivalent
+ * type declarations.
+ */
+private int
+typeck_decls(VarDecl *a, VarDecl *b)
+{
+	for (; a && b; a = a->next, b = b->next) {
+		unless (L_typeck_same(a->type, b->type) &&
+			((a->flags & (DECL_OPTIONAL | DECL_NAME_EQUIV)) ==
+			 (b->flags & (DECL_OPTIONAL | DECL_NAME_EQUIV)))) {
+			return (0);
+		}
+	}
+	/* Not the same if one has more declarations. */
+	return !(a || b);
+}
+
+/*
+ * Check that a variable type is compatible with the element type of
+ * an array type or a list type (which can be compatible with an array
+ * type).
+ */
+int
+L_typeck_arrElt(Type *var, Type *array)
+{
+	switch (array->kind) {
+	    case L_ARRAY:
+		// Var must be compat with array element type.
+		return (L_typeck_compat(var, array->base_type));
+	    case L_LIST:
+		// Var must be compat with all list elements.
+		for (; array; array = array->next) {
+			unless (L_typeck_compat(var, array->base_type)) {
+				return (0);
+			}
+		}
+		return (1);
+	    default:
+		return (0);
+	}
+}
+
+/*
+ * Determine if something is structurally compatible with a list type.
+ */
+private int
+typeck_list(Type *a, Type *b)
+{
+	Type	*l, *t;
+	VarDecl	*m;
+
+	ASSERT((a->kind == L_LIST) || (b->kind == L_LIST));
+
+	/* If only one of a,b is a list, put that in "l". */
+	if (a->kind == L_LIST) {
+		l = a;
+		t = b;
+	} else {
+		l = b;
+		t = a;
+	}
+
+	switch (t->kind) {
+	    case L_ARRAY:
+		/*
+		 * A list type is compatible with an array type iff all the
+		 * list elements have the same type as the array base type.
+		 */
+		for (; l; l = l->next) {
+			ASSERT(l->kind == L_LIST);
+			unless (L_typeck_compat(t->base_type, l->base_type)) {
+				return (0);
+			}
+		}
+		return (1);
+	    case L_STRUCT:
+		/*
+		 * A list type is compatible with a struct type iff the list
+		 * element types match up with the struct member types.
+		 */
+		m = t->u.struc.members;
+		while (m && l) {
+			ASSERT(l->kind == L_LIST);
+			unless (L_typeck_compat(l->base_type, m->type)) {
+				return (0);
+			}
+			m = m->next;
+			l = l->next;
+		}
+		return !(l || m);  // not the same if one has more elements
+	    case L_LIST:
+		/*
+		 * Two list types are compatible iff element types
+		 * match up, although one can have more.
+		 */
+		for (; t && l; t = t->next, l = l->next) {
+			unless (L_typeck_same(l->base_type, t->base_type)) {
+				return (0);
+			}
+		}
+		return (1);
+	    default:
+		return (0);
+	}
+}
+
+/*
+ * Determine if two types are structurally equivalent.  Note that
+ * polys match anything and strings and widgets are compatible.
+ */
+int
+L_typeck_same(Type *a, Type *b)
+{
+	unless (a && b) return (0);
+
+	/* Polys match anything. */
+	if ((a->kind == L_POLY) || (b->kind == L_POLY)) return (1);
+
+	/* Strings and widgets are compatible. */
+	if ((a->kind & (L_STRING|L_WIDGET)) && (b->kind & (L_STRING|L_WIDGET))){
+		return (1);
+	}
+
+	if ((a->kind == L_LIST) || (b->kind == L_LIST)) {
+		return (typeck_list(a, b));
+	}
+
+	unless (a->kind == b->kind) return (0);
+
+	switch (a->kind) {
+	    case L_INT:
+	    case L_FLOAT:
+	    case L_STRING:
+	    case L_WIDGET:
+	    case L_VOID:
+		return (1);
+	    case L_ARRAY:
+		/* Element types must match (array sizes are ignored). */
+		return (L_typeck_same(a->base_type, b->base_type));
+	    case L_HASH:
+		/* Element types must match and index types must match. */
+		return (L_typeck_same(a->base_type, b->base_type) &&
+			L_typeck_same(a->u.hash.idx_type, b->u.hash.idx_type));
+	    case L_STRUCT:
+		/* Struct members must match in type and number
+		 * but member names can be different. */
+		return (typeck_decls(a->u.struc.members, b->u.struc.members));
+	    case L_NAMEOF:
+		return (L_typeck_same(a->base_type, b->base_type));
+	    case L_FUNCTION:
+		/* Return types must match and all arg types must match. */
+		return (L_typeck_same(a->base_type, b->base_type) &&
+			typeck_decls(a->u.func.formals, b->u.func.formals));
+	    case L_CLASS:
+		/* Must be the same class. */
+		return (a->u.class.clsdecl == b->u.class.clsdecl);
+	    default:
+		L_bomb("bad type kind in L_typeck_same");
+		return (0);
+	}
+}

generic/blowfish.c

@@ -0,0 +1,446 @@
+#include "blowfish.h"
+
+static u32 bfp[] =
+{
+  0x243f6a88, 0x85a308d3, 0x13198a2e, 0x03707344,
+  0xa4093822, 0x299f31d0, 0x082efa98, 0xec4e6c89,
+  0x452821e6, 0x38d01377, 0xbe5466cf, 0x34e90c6c,
+  0xc0ac29b7, 0xc97c50dd, 0x3f84d5b5, 0xb5470917,
+  0x9216d5d9, 0x8979fb1b,
+};
+
+static u32 ks0[] =
+{
+  0xd1310ba6, 0x98dfb5ac, 0x2ffd72db, 0xd01adfb7,
+  0xb8e1afed, 0x6a267e96, 0xba7c9045, 0xf12c7f99,
+  0x24a19947, 0xb3916cf7, 0x0801f2e2, 0x858efc16,
+  0x636920d8, 0x71574e69, 0xa458fea3, 0xf4933d7e,
+  0x0d95748f, 0x728eb658, 0x718bcd58, 0x82154aee,
+  0x7b54a41d, 0xc25a59b5, 0x9c30d539, 0x2af26013,
+  0xc5d1b023, 0x286085f0, 0xca417918, 0xb8db38ef,
+  0x8e79dcb0, 0x603a180e, 0x6c9e0e8b, 0xb01e8a3e,
+  0xd71577c1, 0xbd314b27, 0x78af2fda, 0x55605c60,
+  0xe65525f3, 0xaa55ab94, 0x57489862, 0x63e81440,
+  0x55ca396a, 0x2aab10b6, 0xb4cc5c34, 0x1141e8ce,
+  0xa15486af, 0x7c72e993, 0xb3ee1411, 0x636fbc2a,
+  0x2ba9c55d, 0x741831f6, 0xce5c3e16, 0x9b87931e,
+  0xafd6ba33, 0x6c24cf5c, 0x7a325381, 0x28958677,
+  0x3b8f4898, 0x6b4bb9af, 0xc4bfe81b, 0x66282193,
+  0x61d809cc, 0xfb21a991, 0x487cac60, 0x5dec8032,
+  0xef845d5d, 0xe98575b1, 0xdc262302, 0xeb651b88,
+  0x23893e81, 0xd396acc5, 0x0f6d6ff3, 0x83f44239,
+  0x2e0b4482, 0xa4842004, 0x69c8f04a, 0x9e1f9b5e,
+  0x21c66842, 0xf6e96c9a, 0x670c9c61, 0xabd388f0,
+  0x6a51a0d2, 0xd8542f68, 0x960fa728, 0xab5133a3,
+  0x6eef0b6c, 0x137a3be4, 0xba3bf050, 0x7efb2a98,
+  0xa1f1651d, 0x39af0176, 0x66ca593e, 0x82430e88,
+  0x8cee8619, 0x456f9fb4, 0x7d84a5c3, 0x3b8b5ebe,
+  0xe06f75d8, 0x85c12073, 0x401a449f, 0x56c16aa6,
+  0x4ed3aa62, 0x363f7706, 0x1bfedf72, 0x429b023d,
+  0x37d0d724, 0xd00a1248, 0xdb0fead3, 0x49f1c09b,
+  0x075372c9, 0x80991b7b, 0x25d479d8, 0xf6e8def7,
+  0xe3fe501a, 0xb6794c3b, 0x976ce0bd, 0x04c006ba,
+  0xc1a94fb6, 0x409f60c4, 0x5e5c9ec2, 0x196a2463,
+  0x68fb6faf, 0x3e6c53b5, 0x1339b2eb, 0x3b52ec6f,
+  0x6dfc511f, 0x9b30952c, 0xcc814544, 0xaf5ebd09,
+  0xbee3d004, 0xde334afd, 0x660f2807, 0x192e4bb3,
+  0xc0cba857, 0x45c8740f, 0xd20b5f39, 0xb9d3fbdb,
+  0x5579c0bd, 0x1a60320a, 0xd6a100c6, 0x402c7279,
+  0x679f25fe, 0xfb1fa3cc, 0x8ea5e9f8, 0xdb3222f8,
+  0x3c7516df, 0xfd616b15, 0x2f501ec8, 0xad0552ab,
+  0x323db5fa, 0xfd238760, 0x53317b48, 0x3e00df82,
+  0x9e5c57bb, 0xca6f8ca0, 0x1a87562e, 0xdf1769db,
+  0xd542a8f6, 0x287effc3, 0xac6732c6, 0x8c4f5573,
+  0x695b27b0, 0xbbca58c8, 0xe1ffa35d, 0xb8f011a0,
+  0x10fa3d98, 0xfd2183b8, 0x4afcb56c, 0x2dd1d35b,
+  0x9a53e479, 0xb6f84565, 0xd28e49bc, 0x4bfb9790,
+  0xe1ddf2da, 0xa4cb7e33, 0x62fb1341, 0xcee4c6e8,
+  0xef20cada, 0x36774c01, 0xd07e9efe, 0x2bf11fb4,
+  0x95dbda4d, 0xae909198, 0xeaad8e71, 0x6b93d5a0,
+  0xd08ed1d0, 0xafc725e0, 0x8e3c5b2f, 0x8e7594b7,
+  0x8ff6e2fb, 0xf2122b64, 0x8888b812, 0x900df01c,
+  0x4fad5ea0, 0x688fc31c, 0xd1cff191, 0xb3a8c1ad,
+  0x2f2f2218, 0xbe0e1777, 0xea752dfe, 0x8b021fa1,
+  0xe5a0cc0f, 0xb56f74e8, 0x18acf3d6, 0xce89e299,
+  0xb4a84fe0, 0xfd13e0b7, 0x7cc43b81, 0xd2ada8d9,
+  0x165fa266, 0x80957705, 0x93cc7314, 0x211a1477,
+  0xe6ad2065, 0x77b5fa86, 0xc75442f5, 0xfb9d35cf,
+  0xebcdaf0c, 0x7b3e89a0, 0xd6411bd3, 0xae1e7e49,
+  0x00250e2d, 0x2071b35e, 0x226800bb, 0x57b8e0af,
+  0x2464369b, 0xf009b91e, 0x5563911d, 0x59dfa6aa,
+  0x78c14389, 0xd95a537f, 0x207d5ba2, 0x02e5b9c5,
+  0x83260376, 0x6295cfa9, 0x11c81968, 0x4e734a41,
+  0xb3472dca, 0x7b14a94a, 0x1b510052, 0x9a532915,
+  0xd60f573f, 0xbc9bc6e4, 0x2b60a476, 0x81e67400,
+  0x08ba6fb5, 0x571be91f, 0xf296ec6b, 0x2a0dd915,
+  0xb6636521, 0xe7b9f9b6, 0xff34052e, 0xc5855664,
+  0x53b02d5d, 0xa99f8fa1, 0x08ba4799, 0x6e85076a
+ };
+
+ static u32 ks1[]=
+ {
+  0x4b7a70e9, 0xb5b32944, 0xdb75092e, 0xc4192623,
+  0xad6ea6b0, 0x49a7df7d, 0x9cee60b8, 0x8fedb266,
+  0xecaa8c71, 0x699a17ff, 0x5664526c, 0xc2b19ee1,
+  0x193602a5, 0x75094c29, 0xa0591340, 0xe4183a3e,
+  0x3f54989a, 0x5b429d65, 0x6b8fe4d6, 0x99f73fd6,
+  0xa1d29c07, 0xefe830f5, 0x4d2d38e6, 0xf0255dc1,
+  0x4cdd2086, 0x8470eb26, 0x6382e9c6, 0x021ecc5e,
+  0x09686b3f, 0x3ebaefc9, 0x3c971814, 0x6b6a70a1,
+  0x687f3584, 0x52a0e286, 0xb79c5305, 0xaa500737,
+  0x3e07841c, 0x7fdeae5c, 0x8e7d44ec, 0x5716f2b8,
+  0xb03ada37, 0xf0500c0d, 0xf01c1f04, 0x0200b3ff,
+  0xae0cf51a, 0x3cb574b2, 0x25837a58, 0xdc0921bd,
+  0xd19113f9, 0x7ca92ff6, 0x94324773, 0x22f54701,
+  0x3ae5e581, 0x37c2dadc, 0xc8b57634, 0x9af3dda7,
+  0xa9446146, 0x0fd0030e, 0xecc8c73e, 0xa4751e41,
+  0xe238cd99, 0x3bea0e2f, 0x3280bba1, 0x183eb331,
+  0x4e548b38, 0x4f6db908, 0x6f420d03, 0xf60a04bf,
+  0x2cb81290, 0x24977c79, 0x5679b072, 0xbcaf89af,
+  0xde9a771f, 0xd9930810, 0xb38bae12, 0xdccf3f2e,
+  0x5512721f, 0x2e6b7124, 0x501adde6, 0x9f84cd87,
+  0x7a584718, 0x7408da17, 0xbc9f9abc, 0xe94b7d8c,
+  0xec7aec3a, 0xdb851dfa, 0x63094366, 0xc464c3d2,
+  0xef1c1847, 0x3215d908, 0xdd433b37, 0x24c2ba16,
+  0x12a14d43, 0x2a65c451, 0x50940002, 0x133ae4dd,
+  0x71dff89e, 0x10314e55, 0x81ac77d6, 0x5f11199b,
+  0x043556f1, 0xd7a3c76b, 0x3c11183b, 0x5924a509,
+  0xf28fe6ed, 0x97f1fbfa, 0x9ebabf2c, 0x1e153c6e,
+  0x86e34570, 0xeae96fb1, 0x860e5e0a, 0x5a3e2ab3,
+  0x771fe71c, 0x4e3d06fa, 0x2965dcb9, 0x99e71d0f,
+  0x803e89d6, 0x5266c825, 0x2e4cc978, 0x9c10b36a,
+  0xc6150eba, 0x94e2ea78, 0xa5fc3c53, 0x1e0a2df4,
+  0xf2f74ea7, 0x361d2b3d, 0x1939260f, 0x19c27960,
+  0x5223a708, 0xf71312b6, 0xebadfe6e, 0xeac31f66,
+  0xe3bc4595, 0xa67bc883, 0xb17f37d1, 0x018cff28,
+  0xc332ddef, 0xbe6c5aa5, 0x65582185, 0x68ab9802,
+  0xeecea50f, 0xdb2f953b, 0x2aef7dad, 0x5b6e2f84,
+  0x1521b628, 0x29076170, 0xecdd4775, 0x619f1510,
+  0x13cca830, 0xeb61bd96, 0x0334fe1e, 0xaa0363cf,
+  0xb5735c90, 0x4c70a239, 0xd59e9e0b, 0xcbaade14,
+  0xeecc86bc, 0x60622ca7, 0x9cab5cab, 0xb2f3846e,
+  0x648b1eaf, 0x19bdf0ca, 0xa02369b9, 0x655abb50,
+  0x40685a32, 0x3c2ab4b3, 0x319ee9d5, 0xc021b8f7,
+  0x9b540b19, 0x875fa099, 0x95f7997e, 0x623d7da8,
+  0xf837889a, 0x97e32d77, 0x11ed935f, 0x16681281,
+  0x0e358829, 0xc7e61fd6, 0x96dedfa1, 0x7858ba99,
+  0x57f584a5, 0x1b227263, 0x9b83c3ff, 0x1ac24696,
+  0xcdb30aeb, 0x532e3054, 0x8fd948e4, 0x6dbc3128,
+  0x58ebf2ef, 0x34c6ffea, 0xfe28ed61, 0xee7c3c73,
+  0x5d4a14d9, 0xe864b7e3, 0x42105d14, 0x203e13e0,
+  0x45eee2b6, 0xa3aaabea, 0xdb6c4f15, 0xfacb4fd0,
+  0xc742f442, 0xef6abbb5, 0x654f3b1d, 0x41cd2105,
+  0xd81e799e, 0x86854dc7, 0xe44b476a, 0x3d816250,
+  0xcf62a1f2, 0x5b8d2646, 0xfc8883a0, 0xc1c7b6a3,
+  0x7f1524c3, 0x69cb7492, 0x47848a0b, 0x5692b285,
+  0x095bbf00, 0xad19489d, 0x1462b174, 0x23820e00,
+  0x58428d2a, 0x0c55f5ea, 0x1dadf43e, 0x233f7061,
+  0x3372f092, 0x8d937e41, 0xd65fecf1, 0x6c223bdb,
+  0x7cde3759, 0xcbee7460, 0x4085f2a7, 0xce77326e,
+  0xa6078084, 0x19f8509e, 0xe8efd855, 0x61d99735,
+  0xa969a7aa, 0xc50c06c2, 0x5a04abfc, 0x800bcadc,
+  0x9e447a2e, 0xc3453484, 0xfdd56705, 0x0e1e9ec9,
+  0xdb73dbd3, 0x105588cd, 0x675fda79, 0xe3674340,
+  0xc5c43465, 0x713e38d8, 0x3d28f89e, 0xf16dff20,
+  0x153e21e7, 0x8fb03d4a, 0xe6e39f2b, 0xdb83adf7
+};
+
+static u32 ks2[] =
+{
+  0xe93d5a68, 0x948140f7, 0xf64c261c, 0x94692934,
+  0x411520f7, 0x7602d4f7, 0xbcf46b2e, 0xd4a20068,
+  0xd4082471, 0x3320f46a, 0x43b7d4b7, 0x500061af,
+  0x1e39f62e, 0x97244546, 0x14214f74, 0xbf8b8840,
+  0x4d95fc1d, 0x96b591af, 0x70f4ddd3, 0x66a02f45,
+  0xbfbc09ec, 0x03bd9785, 0x7fac6dd0, 0x31cb8504,
+  0x96eb27b3, 0x55fd3941, 0xda2547e6, 0xabca0a9a,
+  0x28507825, 0x530429f4, 0x0a2c86da, 0xe9b66dfb,
+  0x68dc1462, 0xd7486900, 0x680ec0a4, 0x27a18dee,
+  0x4f3ffea2, 0xe887ad8c, 0xb58ce006, 0x7af4d6b6,
+  0xaace1e7c, 0xd3375fec, 0xce78a399, 0x406b2a42,
+  0x20fe9e35, 0xd9f385b9, 0xee39d7ab, 0x3b124e8b,
+  0x1dc9faf7, 0x4b6d1856, 0x26a36631, 0xeae397b2,
+  0x3a6efa74, 0xdd5b4332, 0x6841e7f7, 0xca7820fb,
+  0xfb0af54e, 0xd8feb397, 0x454056ac, 0xba489527,
+  0x55533a3a, 0x20838d87, 0xfe6ba9b7, 0xd096954b,
+  0x55a867bc, 0xa1159a58, 0xcca92963, 0x99e1db33,
+  0xa62a4a56, 0x3f3125f9, 0x5ef47e1c, 0x9029317c,
+  0xfdf8e802, 0x04272f70, 0x80bb155c, 0x05282ce3,
+  0x95c11548, 0xe4c66d22, 0x48c1133f, 0xc70f86dc,
+  0x07f9c9ee, 0x41041f0f, 0x404779a4, 0x5d886e17,
+  0x325f51eb, 0xd59bc0d1, 0xf2bcc18f, 0x41113564,
+  0x257b7834, 0x602a9c60, 0xdff8e8a3, 0x1f636c1b,
+  0x0e12b4c2, 0x02e1329e, 0xaf664fd1, 0xcad18115,
+  0x6b2395e0, 0x333e92e1, 0x3b240b62, 0xeebeb922,
+  0x85b2a20e, 0xe6ba0d99, 0xde720c8c, 0x2da2f728,
+  0xd0127845, 0x95b794fd, 0x647d0862, 0xe7ccf5f0,
+  0x5449a36f, 0x877d48fa, 0xc39dfd27, 0xf33e8d1e,
+  0x0a476341, 0x992eff74, 0x3a6f6eab, 0xf4f8fd37,
+  0xa812dc60, 0xa1ebddf8, 0x991be14c, 0xdb6e6b0d,
+  0xc67b5510, 0x6d672c37, 0x2765d43b, 0xdcd0e804,
+  0xf1290dc7, 0xcc00ffa3, 0xb5390f92, 0x690fed0b,
+  0x667b9ffb, 0xcedb7d9c, 0xa091cf0b, 0xd9155ea3,
+  0xbb132f88, 0x515bad24, 0x7b9479bf, 0x763bd6eb,
+  0x37392eb3, 0xcc115979, 0x8026e297, 0xf42e312d,
+  0x6842ada7, 0xc66a2b3b, 0x12754ccc, 0x782ef11c,
+  0x6a124237, 0xb79251e7, 0x06a1bbe6, 0x4bfb6350,
+  0x1a6b1018, 0x11caedfa, 0x3d25bdd8, 0xe2e1c3c9,
+  0x44421659, 0x0a121386, 0xd90cec6e, 0xd5abea2a,
+  0x64af674e, 0xda86a85f, 0xbebfe988, 0x64e4c3fe,
+  0x9dbc8057, 0xf0f7c086, 0x60787bf8, 0x6003604d,
+  0xd1fd8346, 0xf6381fb0, 0x7745ae04, 0xd736fccc,
+  0x83426b33, 0xf01eab71, 0xb0804187, 0x3c005e5f,
+  0x77a057be, 0xbde8ae24, 0x55464299, 0xbf582e61,
+  0x4e58f48f, 0xf2ddfda2, 0xf474ef38, 0x8789bdc2,
+  0x5366f9c3, 0xc8b38e74, 0xb475f255, 0x46fcd9b9,
+  0x7aeb2661, 0x8b1ddf84, 0x846a0e79, 0x915f95e2,
+  0x466e598e, 0x20b45770, 0x8cd55591, 0xc902de4c,
+  0xb90bace1, 0xbb8205d0, 0x11a86248, 0x7574a99e,
+  0xb77f19b6, 0xe0a9dc09, 0x662d09a1, 0xc4324633,
+  0xe85a1f02, 0x09f0be8c, 0x4a99a025, 0x1d6efe10,
+  0x1ab93d1d, 0x0ba5a4df, 0xa186f20f, 0x2868f169,
+  0xdcb7da83, 0x573906fe, 0xa1e2ce9b, 0x4fcd7f52,
+  0x50115e01, 0xa70683fa, 0xa002b5c4, 0x0de6d027,
+  0x9af88c27, 0x773f8641, 0xc3604c06, 0x61a806b5,
+  0xf0177a28, 0xc0f586e0, 0x006058aa, 0x30dc7d62,
+  0x11e69ed7, 0x2338ea63, 0x53c2dd94, 0xc2c21634,
+  0xbbcbee56, 0x90bcb6de, 0xebfc7da1, 0xce591d76,
+  0x6f05e409, 0x4b7c0188, 0x39720a3d, 0x7c927c24,
+  0x86e3725f, 0x724d9db9, 0x1ac15bb4, 0xd39eb8fc,
+  0xed545578, 0x08fca5b5, 0xd83d7cd3, 0x4dad0fc4,
+  0x1e50ef5e, 0xb161e6f8, 0xa28514d9, 0x6c51133c,
+  0x6fd5c7e7, 0x56e14ec4, 0x362abfce, 0xddc6c837,
+  0xd79a3234, 0x92638212, 0x670efa8e, 0x406000e0
+};
+
+static u32 ks3[] =
+{
+  0x3a39ce37, 0xd3faf5cf, 0xabc27737, 0x5ac52d1b,
+  0x5cb0679e, 0x4fa33742, 0xd3822740, 0x99bc9bbe,
+  0xd5118e9d, 0xbf0f7315, 0xd62d1c7e, 0xc700c47b,
+  0xb78c1b6b, 0x21a19045, 0xb26eb1be, 0x6a366eb4,
+  0x5748ab2f, 0xbc946e79, 0xc6a376d2, 0x6549c2c8,
+  0x530ff8ee, 0x468dde7d, 0xd5730a1d, 0x4cd04dc6,
+  0x2939bbdb, 0xa9ba4650, 0xac9526e8, 0xbe5ee304,
+  0xa1fad5f0, 0x6a2d519a, 0x63ef8ce2, 0x9a86ee22,
+  0xc089c2b8, 0x43242ef6, 0xa51e03aa, 0x9cf2d0a4,
+  0x83c061ba, 0x9be96a4d, 0x8fe51550, 0xba645bd6,
+  0x2826a2f9, 0xa73a3ae1, 0x4ba99586, 0xef5562e9,
+  0xc72fefd3, 0xf752f7da, 0x3f046f69, 0x77fa0a59,
+  0x80e4a915, 0x87b08601, 0x9b09e6ad, 0x3b3ee593,
+  0xe990fd5a, 0x9e34d797, 0x2cf0b7d9, 0x022b8b51,
+  0x96d5ac3a, 0x017da67d, 0xd1cf3ed6, 0x7c7d2d28,
+  0x1f9f25cf, 0xadf2b89b, 0x5ad6b472, 0x5a88f54c,
+  0xe029ac71, 0xe019a5e6, 0x47b0acfd, 0xed93fa9b,
+  0xe8d3c48d, 0x283b57cc, 0xf8d56629, 0x79132e28,
+  0x785f0191, 0xed756055, 0xf7960e44, 0xe3d35e8c,
+  0x15056dd4, 0x88f46dba, 0x03a16125, 0x0564f0bd,
+  0xc3eb9e15, 0x3c9057a2, 0x97271aec, 0xa93a072a,
+  0x1b3f6d9b, 0x1e6321f5, 0xf59c66fb, 0x26dcf319,
+  0x7533d928, 0xb155fdf5, 0x03563482, 0x8aba3cbb,
+  0x28517711, 0xc20ad9f8, 0xabcc5167, 0xccad925f,
+  0x4de81751, 0x3830dc8e, 0x379d5862, 0x9320f991,
+  0xea7a90c2, 0xfb3e7bce, 0x5121ce64, 0x774fbe32,
+  0xa8b6e37e, 0xc3293d46, 0x48de5369, 0x6413e680,
+  0xa2ae0810, 0xdd6db224, 0x69852dfd, 0x09072166,
+  0xb39a460a, 0x6445c0dd, 0x586cdecf, 0x1c20c8ae,
+  0x5bbef7dd, 0x1b588d40, 0xccd2017f, 0x6bb4e3bb,
+  0xdda26a7e, 0x3a59ff45, 0x3e350a44, 0xbcb4cdd5,
+  0x72eacea8, 0xfa6484bb, 0x8d6612ae, 0xbf3c6f47,
+  0xd29be463, 0x542f5d9e, 0xaec2771b, 0xf64e6370,
+  0x740e0d8d, 0xe75b1357, 0xf8721671, 0xaf537d5d,
+  0x4040cb08, 0x4eb4e2cc, 0x34d2466a, 0x0115af84,
+  0xe1b00428, 0x95983a1d, 0x06b89fb4, 0xce6ea048,
+  0x6f3f3b82, 0x3520ab82, 0x011a1d4b, 0x277227f8,
+  0x611560b1, 0xe7933fdc, 0xbb3a792b, 0x344525bd,
+  0xa08839e1, 0x51ce794b, 0x2f32c9b7, 0xa01fbac9,
+  0xe01cc87e, 0xbcc7d1f6, 0xcf0111c3, 0xa1e8aac7,
+  0x1a908749, 0xd44fbd9a, 0xd0dadecb, 0xd50ada38,
+  0x0339c32a, 0xc6913667, 0x8df9317c, 0xe0b12b4f,
+  0xf79e59b7, 0x43f5bb3a, 0xf2d519ff, 0x27d9459c,
+  0xbf97222c, 0x15e6fc2a, 0x0f91fc71, 0x9b941525,
+  0xfae59361, 0xceb69ceb, 0xc2a86459, 0x12baa8d1,
+  0xb6c1075e, 0xe3056a0c, 0x10d25065, 0xcb03a442,
+  0xe0ec6e0e, 0x1698db3b, 0x4c98a0be, 0x3278e964,
+  0x9f1f9532, 0xe0d392df, 0xd3a0342b, 0x8971f21e,
+  0x1b0a7441, 0x4ba3348c, 0xc5be7120, 0xc37632d8,
+  0xdf359f8d, 0x9b992f2e, 0xe60b6f47, 0x0fe3f11d,
+  0xe54cda54, 0x1edad891, 0xce6279cf, 0xcd3e7e6f,
+  0x1618b166, 0xfd2c1d05, 0x848fd2c5, 0xf6fb2299,
+  0xf523f357, 0xa6327623, 0x93a83531, 0x56cccd02,
+  0xacf08162, 0x5a75ebb5, 0x6e163697, 0x88d273cc,
+  0xde966292, 0x81b949d0, 0x4c50901b, 0x71c65614,
+  0xe6c6c7bd, 0x327a140a, 0x45e1d006, 0xc3f27b9a,
+  0xc9aa53fd, 0x62a80f00, 0xbb25bfe2, 0x35bdd2f6,
+  0x71126905, 0xb2040222, 0xb6cbcf7c, 0xcd769c2b,
+  0x53113ec0, 0x1640e3d3, 0x38abbd60, 0x2547adf0,
+  0xba38209c, 0xf746ce76, 0x77afa1c5, 0x20756060,
+  0x85cbfe4e, 0x8ae88dd8, 0x7aaaf9b0, 0x4cf9aa7e,
+  0x1948c25c, 0x02fb8a8c, 0x01c36ae4, 0xd6ebe1f9,
+  0x90d4f869, 0xa65cdea0, 0x3f09252d, 0xc208e69f,
+  0xb74e6132, 0xce77e25b, 0x578fdfe3, 0x3ac372e6
+};
+
+#define N               16
+
+static u32
+F(blf_ctx *bc, u32 x)
+{
+	u32	a, b, c, d, y;
+
+	d = x & 0x00FF;
+	x >>= 8;
+	c = x & 0x00FF;
+	x >>= 8;
+	b = x & 0x00FF;
+	x >>= 8;
+	a = x & 0x00FF;
+	y = bc->S[0][a] + bc->S[1][b];
+	y = y ^ bc->S[2][c];
+	y = y + bc->S[3][d];
+
+	return y;
+}
+
+static void
+Blowfish_encipher(blf_ctx *bc, u32 *xl, u32 *xr)
+{
+	u32	Xl, Xr;
+	u32	temp;
+	short	i;
+
+	Xl = *xl;
+	Xr = *xr;
+
+	for (i = 0; i < N; ++i) {
+		Xl = Xl ^ bc->P[i];
+		Xr = F(bc, Xl) ^ Xr;
+
+		temp = Xl;
+		Xl = Xr;
+		Xr = temp;
+	}
+
+	temp = Xl;
+	Xl = Xr;
+	Xr = temp;
+
+	Xr = Xr ^ bc->P[N];
+	Xl = Xl ^ bc->P[N + 1];
+
+	*xl = Xl;
+	*xr = Xr;
+}
+
+static void
+Blowfish_decipher(blf_ctx *bc, u32 *xl, u32 *xr)
+{
+	u32	Xl, Xr;
+	u32	temp;
+	short	i;
+
+	Xl = *xl;
+	Xr = *xr;
+
+	for (i = N + 1; i > 1; --i) {
+		Xl = Xl ^ bc->P[i];
+		Xr = F(bc, Xl) ^ Xr;
+
+		/* Exchange Xl and Xr */
+		temp = Xl;
+		Xl = Xr;
+		Xr = temp;
+	}
+
+	/* Exchange Xl and Xr */
+	temp = Xl;
+	Xl = Xr;
+	Xr = temp;
+
+	Xr = Xr ^ bc->P[1];
+	Xl = Xl ^ bc->P[0];
+
+	*xl = Xl;
+	*xr = Xr;
+}
+
+static short
+InitializeBlowfish(blf_ctx *bc, u8 key[], int keybytes)
+{
+	 short	i, j, k;
+	 u32	data, datal, datar;
+
+	/* initialise p & s-boxes without file read */
+	for (i = 0; i < N+2; i++) {
+		bc->P[i] = bfp[i];
+	}
+	for (i = 0; i < 256; i++) {
+		bc->S[0][i] = ks0[i];
+		bc->S[1][i] = ks1[i];
+		bc->S[2][i] = ks2[i];
+		bc->S[3][i] = ks3[i];
+	}
+
+	j = 0;
+	for (i = 0; i < N + 2; ++i) {
+		data = 0x00000000;
+		for (k = 0; k < 4; ++k) {
+			data = (data << 8) | key[j];
+			j = j + 1;
+			if (j >= keybytes) j = 0;
+		}
+		bc->P[i] = bc->P[i] ^ data;
+	}
+
+	datal = 0x00000000;
+	datar = 0x00000000;
+
+	for (i = 0; i < N + 2; i += 2) {
+		Blowfish_encipher(bc, &datal, &datar);
+
+		bc->P[i] = datal;
+		bc->P[i + 1] = datar;
+	}
+
+	for (i = 0; i < 4; ++i) {
+		for (j = 0; j < 256; j += 2) {
+			Blowfish_encipher(bc, &datal, &datar);
+
+			bc->S[i][j] = datal;
+			bc->S[i][j + 1] = datar;
+		}
+	}
+	return 0;
+}
+
+void
+blf_key (blf_ctx *c, u8 *k, int len)
+{
+	InitializeBlowfish(c, k, len);
+}
+
+void
+blf_enc(blf_ctx *c, u32 *data, int blocks)
+{
+	u32 *d;
+	int i;
+
+	d = data;
+	for (i = 0; i < blocks; i++) {
+		Blowfish_encipher(c, d, d+1);
+		d += 2;
+	}
+}
+
+void
+blf_dec(blf_ctx *c, u32 *data, int blocks)
+{
+	u32 *d;
+	int i;
+
+	d = data;
+	for (i = 0; i < blocks; i++) {
+		Blowfish_decipher(c, d, d+1);
+		d += 2;
+	}
+}

generic/blowfish.h

@@ -0,0 +1,12 @@
+typedef	unsigned int	u32;
+typedef	unsigned char	u8;
+
+typedef struct {
+	u32	S[4][256];
+	u32	P[18];
+} blf_ctx;
+
+void blf_enc(blf_ctx *c, u32 *data, int blocks);
+void blf_dec(blf_ctx *c, u32 *data, int blocks);
+void blf_key(blf_ctx *c, unsigned char *key, int len);
+

generic/keydecode.c

@@ -0,0 +1,29 @@
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+
+char *
+keydecode(char *key)
+{
+	unsigned int len, half, i, j;
+	char	*newkey;
+
+	if (key == NULL) {
+err:		return (key);
+	}
+	len = strlen(key);
+	half = len / 2;
+	if ((len %2) != 0) goto err; /* len must be even */
+	
+	newkey = malloc(len);
+	
+	/* unpack the old bytes */
+	for (j = 1, i = 0; i < half; i++, j +=2) newkey[j] = key[i];
+
+	/* unpack the even bytes */
+	for (j = 0, i = half; i < len; i++, j +=2)  newkey[j] = key[i];
+
+	memcpy(key, newkey, len);
+	free(newkey);
+	return (key);
+}

generic/tcl.h

@@ -9,6 +9,7 @@
  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
  * Copyright (c) 1998-2000 by Scriptics Corporation.
  * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -611,6 +612,10 @@ typedef void (Tcl_ThreadCreateProc) (ClientData clientData);
 #define	TCL_REG_NEWLINE		000300  /* Newlines are line terminators. */
 #define	TCL_REG_CANMATCH	001000  /* Report details on partial/limited
 					 * matches. */
+#define TCL_REG_BYTEOFFSET	002000	/* Use byte offsets instead of
+					   character offsets. */
+#define	TCL_REG_PCRE	0x08000000	/* Make sure it doesn't conflict with
+					 * existing TCL_REG_* or PCRE_* bits */
 
 /*
  * Flags values passed to Tcl_RegExpExecObj.
@@ -807,7 +812,16 @@ typedef struct Tcl_ObjType {
  */
 
 typedef struct Tcl_Obj {
-    int refCount;		/* When 0 the object will be freed. */
+#ifndef TCL_MEM_DEBUG
+    unsigned int undef:1;	/* Used by L to mark an object as having
+				 * the undef value.  Steal a bit from
+				 * refCount to avoid increasing the
+				 * Tcl_Obj memory footprint. */
+    int refCount:31;		/* When 0 the object will be freed. */
+#else
+    int refCount;
+    int undef;
+#endif
     char *bytes;		/* This points to the first byte of the
 				 * object's string representation. The array
 				 * must be followed by a null byte (i.e., at
@@ -1997,6 +2011,9 @@ typedef struct Tcl_Token {
  *				literal character prefix "{*}". This word is
  *				marked to be expanded - that is, broken into
  *				words after substitution is complete.
+ * TCL_TOKEN_PRAGMA      -	This token handles pragma directives that might
+ *				switch the parser used. Currently only the L
+ *				language is supported.                        
  */
 
 #define TCL_TOKEN_WORD		1
@@ -2008,6 +2025,7 @@ typedef struct Tcl_Token {
 #define TCL_TOKEN_SUB_EXPR	64
 #define TCL_TOKEN_OPERATOR	128
 #define TCL_TOKEN_EXPAND_WORD	256
+#define	TCL_TOKEN_PRAGMA	512
 
 /*
  * Parsing error types. On any parsing error, one of these values will be

generic/tclBasic.c

@@ -12,6 +12,7 @@
  * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
  * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
  * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net>
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -258,6 +259,23 @@ static const CmdInfo builtInCmds[] = {
     {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	CMD_IS_SAFE},
     {"yieldto",		NULL,			TclCompileYieldToCmd,	TclNRYieldToObjCmd,	CMD_IS_SAFE},
 
+    /*
+     * L Commands
+     */
+
+    {"L",		Tcl_LObjCmd,		NULL,		NULL, 1},
+    {"shsplit",		Tcl_ShSplitObjCmd,	NULL,		NULL, 1},
+    {"fgetline",	Tcl_FGetlineObjCmd,	NULL,		NULL, 1},
+    {"angle_read_",	Tcl_LAngleReadObjCmd,	NULL,		NULL, 1},
+    {"Lread_",		Tcl_LReadCmd,		NULL,		NULL, 1},
+    {"Lwrite_",		Tcl_LWriteCmd,		NULL,		NULL, 1},
+    {"Lrefcnt",		Tcl_LRefCnt,		NULL,		NULL, 1},
+    {"defined",		Tcl_LDefined,		NULL,		NULL, 1},
+    {"Lhtml",		Tcl_LHtmlObjCmd,	NULL,		NULL, 1},
+    {"LgetNextLine_",	Tcl_LGetNextLine,	NULL,		NULL, 1},
+    {"LgetNextLineInit_",	Tcl_LGetNextLineInit,	NULL,		NULL, 1},
+    {"getdirx",         Tcl_LGetDirX,	        NULL,		NULL, 1},
+
     /*
      * Commands in the OS-interface. Note that many of these are unsafe.
      */
@@ -274,6 +292,8 @@ static const CmdInfo builtInCmds[] = {
     {"fcopy",		Tcl_FcopyObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
     {"fileevent",	Tcl_FileEventObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
     {"flush",		Tcl_FlushObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
+    {"getopt",		Tcl_GetOptObjCmd,	NULL,			NULL,	0},
+    {"getoptReset",	Tcl_GetOptResetObjCmd,	NULL,			NULL,	0},
     {"gets",		Tcl_GetsObjCmd,		NULL,			NULL,	CMD_IS_SAFE},
     {"glob",		Tcl_GlobObjCmd,		NULL,			NULL,	0},
     {"load",		Tcl_LoadObjCmd,		NULL,			NULL,	0},
@@ -594,6 +614,13 @@ Tcl_CreateInterp(void)
     iPtr->evalFlags = 0;
     iPtr->scriptFile = NULL;
     iPtr->flags = 0;
+#ifdef HAVE_PCRE
+#ifdef USE_DEFAULT_PCRE
+    if (getenv("TCL_REGEXP_CLASSIC") == NULL) { iPtr->flags |= INTERP_PCRE; }
+#else
+    if (getenv("TCL_REGEXP_PCRE") != NULL) { iPtr->flags |= INTERP_PCRE; }
+#endif
+#endif
     iPtr->tracePtr = NULL;
     iPtr->tracesForbiddingInline = 0;
     iPtr->activeCmdTracePtr = NULL;
@@ -5185,6 +5212,23 @@ TclEvalEx(
 		    TclContinuationsEnterDerived(objv[objectsUsed],
 			    wordStart - outerScript, wordCLNext);
 		}
+
+		/*
+		 * If this is the L command and we just processed the first
+		 * command word (i.e., the "L"), inject an argument --line=%d
+		 * before the next command word.  This communicates the source
+		 * line # to the L compiler.
+		 */
+		if (!objectsUsed &&
+		    (!strncmp("L", tokenPtr->start, tokenPtr->size) ||
+		     !strncmp("Lhtml", tokenPtr->start, tokenPtr->size))) {
+		    ++numWords;
+		    ++objectsUsed;
+		    ++objectsNeeded;
+		    objv[objectsUsed] = Tcl_ObjPrintf("--line=%d", lines[0]+1);
+		    Tcl_IncrRefCount(objv[objectsUsed]);
+		    expand[objectsUsed] = 0;
+		}
 	    } /* for loop */
 	    iPtr->cmdFramePtr = eeFramePtr;
 	    if (code != TCL_OK) {

generic/tclCmdIL.c

@@ -12,6 +12,7 @@
  * Copyright (c) 1998-1999 by Scriptics Corporation.
  * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
  * Copyright (c) 2005 Donal K. Fellows.
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.

generic/tclCmdMZ.c

@@ -130,24 +130,34 @@ Tcl_RegexpObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    int i, indices, match, about, offset, all, doinline, numMatchesSaved;
-    int cflags, eflags, stringLength, matchLength;
+    int i, indices, about, offset, all, doinline;
+    int cflags, iflags, re_type;
+    Tcl_Obj *startIndex = NULL;
     Tcl_RegExp regExpr;
-    Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
-    Tcl_RegExpInfo info;
     static const char *const options[] = {
 	"-all",		"-about",	"-indices",	"-inline",
 	"-expanded",	"-line",	"-linestop",	"-lineanchor",
-	"-nocase",	"-start",	"--",		NULL
+	"-nocase",	"-start",	"-type",	"--",	NULL
     };
     enum options {
 	REGEXP_ALL,	REGEXP_ABOUT,	REGEXP_INDICES,	REGEXP_INLINE,
 	REGEXP_EXPANDED,REGEXP_LINE,	REGEXP_LINESTOP,REGEXP_LINEANCHOR,
-	REGEXP_NOCASE,	REGEXP_START,	REGEXP_LAST
+	REGEXP_NOCASE,REGEXP_START,	REGEXP_TYPE,	REGEXP_LAST
+    };
+    static CONST char *re_type_opts[] = {
+	"classic",	"pcre",	NULL
+    };
+    enum re_type_opts {
+	RETYPE_CLASSIC,	RETYPE_PCRE,
     };
 
     indices = 0;
     about = 0;
+#ifdef USE_DEFAULT_PCRE
+    re_type = RETYPE_PCRE;
+#else
+    re_type = RETYPE_CLASSIC;
+#endif
     cflags = TCL_REG_ADVANCED;
     offset = 0;
     all = 0;
@@ -208,6 +218,15 @@ Tcl_RegexpObjCmd(
 	    Tcl_IncrRefCount(startIndex);
 	    break;
 	}
+	case REGEXP_TYPE:
+	    if (++i >= objc) {
+		goto endOfForLoop;
+	    }
+	    if (Tcl_GetIndexFromObj(interp, objv[i], re_type_opts, "type",
+			    0, &re_type) != TCL_OK) {
+		goto optionError;
+	    }
+	    break;
 	case REGEXP_LAST:
 	    i++;
 	    goto endOfForLoop;
@@ -233,22 +252,16 @@ Tcl_RegexpObjCmd(
 		"regexp match variables not allowed when using -inline", -1));
 	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP",
 		"MIX_VAR_INLINE", NULL);
-	goto optionError;
+      optionError:
+	if (startIndex) {
+	    Tcl_DecrRefCount(startIndex);
+	}
+	return TCL_ERROR;
     }
 
-    /*
-     * Handle the odd about case separately.
-     */
-
-    if (about) {
-	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
-	if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
-	optionError:
-	    if (startIndex) {
-		Tcl_DecrRefCount(startIndex);
-	    }
-	    return TCL_ERROR;
-	}
+    /* L undef never matches anything. */
+    if (objv[1]->undef) {
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
 	return TCL_OK;
     }
 
@@ -258,10 +271,19 @@ Tcl_RegexpObjCmd(
      * regexp to avoid shimmering problems.
      */
 
-    objPtr = objv[1];
-    stringLength = Tcl_GetCharLength(objPtr);
-
     if (startIndex) {
+	int stringLength;
+
+	if ((enum re_type_opts) re_type == RETYPE_CLASSIC) {
+	    stringLength = Tcl_GetCharLength(objv[1]);
+	} else {
+	    if (objv[1]->typePtr == &tclByteArrayType) {
+		(void) Tcl_GetByteArrayFromObj(objv[1], &stringLength);
+	    } else {
+		/* XXX validate offset by char length */
+		(void) Tcl_GetStringFromObj(objv[1], &stringLength);
+	    }
+	}
 	TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
 	Tcl_DecrRefCount(startIndex);
 	if (offset < 0) {
@@ -269,201 +291,43 @@ Tcl_RegexpObjCmd(
 	}
     }
 
+    /*
+     * Handle the odd about case separately, otherwise pass of to appropriate
+     * RE engine.
+     */
+
+    iflags = ((Interp *)interp)->flags;
+    if ((enum re_type_opts) re_type == RETYPE_PCRE) {
+	cflags |= TCL_REG_PCRE;
+    } else if (iflags & INTERP_PCRE) {
+	/* Prevent -type classic from being overridden compiling RE */
+	((Interp *)interp)->flags &= ~(INTERP_PCRE);
+    }
     regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+    ((Interp *)interp)->flags = iflags;
     if (regExpr == NULL) {
 	return TCL_ERROR;
     }
 
-    objc -= 2;
-    objv += 2;
+    if ((enum re_type_opts) re_type == RETYPE_CLASSIC) {
+	if (about) {
+	    if (TclRegAbout(interp, regExpr) < 0) {
+		return TCL_ERROR;
+	    }
+	    return TCL_OK;
+	}
 
-    if (doinline) {
-	/*
-	 * Save all the subexpressions, as we will return them as a list
-	 */
-
-	numMatchesSaved = -1;
+	return TclRegexpClassic(interp, objc, objv, regExpr,
+		all, indices, doinline, offset);
     } else {
-	/*
-	 * Save only enough subexpressions for matches we want to keep, expect
-	 * in the case of -all, where we need to keep at least one to know
-	 * where to move the offset.
-	 */
+	if (about) {
+	    /* XXX: implement PCRE about */
+	    return TCL_OK;
+	}
 
-	numMatchesSaved = (objc == 0) ? all : objc;
+	return TclRegexpPCRE(interp, objc, objv, regExpr,
+		all, indices, doinline, offset);
     }
-
-    /*
-     * The following loop is to handle multiple matches within the same source
-     * string; each iteration handles one match. If "-all" hasn't been
-     * specified then the loop body only gets executed once. We terminate the
-     * loop when the starting offset is past the end of the string.
-     */
-
-    while (1) {
-	/*
-	 * Pass either 0 or TCL_REG_NOTBOL in the eflags. Passing
-	 * TCL_REG_NOTBOL indicates that the character at offset should not be
-	 * considered the start of the line. If for example the pattern {^} is
-	 * passed and -start is positive, then the pattern will not match the
-	 * start of the string unless the previous character is a newline.
-	 */
-
-	if (offset == 0) {
-	    eflags = 0;
-	} else if (offset > stringLength) {
-	    eflags = TCL_REG_NOTBOL;
-	} else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') {
-	    eflags = 0;
-	} else {
-	    eflags = TCL_REG_NOTBOL;
-	}
-
-	match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
-		numMatchesSaved, eflags);
-	if (match < 0) {
-	    return TCL_ERROR;
-	}
-
-	if (match == 0) {
-	    /*
-	     * We want to set the value of the intepreter result only when
-	     * this is the first time through the loop.
-	     */
-
-	    if (all <= 1) {
-		/*
-		 * If inlining, the interpreter's object result remains an
-		 * empty list, otherwise set it to an integer object w/ value
-		 * 0.
-		 */
-
-		if (!doinline) {
-		    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
-		}
-		return TCL_OK;
-	    }
-	    break;
-	}
-
-	/*
-	 * If additional variable names have been specified, return index
-	 * information in those variables.
-	 */
-
-	Tcl_RegExpGetInfo(regExpr, &info);
-	if (doinline) {
-	    /*
-	     * It's the number of substitutions, plus one for the matchVar at
-	     * index 0
-	     */
-
-	    objc = info.nsubs + 1;
-	    if (all <= 1) {
-		resultPtr = Tcl_NewObj();
-	    }
-	}
-	for (i = 0; i < objc; i++) {
-	    Tcl_Obj *newPtr;
-
-	    if (indices) {
-		int start, end;
-		Tcl_Obj *objs[2];
-
-		/*
-		 * Only adjust the match area if there was a match for that
-		 * area. (Scriptics Bug 4391/SF Bug #219232)
-		 */
-
-		if (i <= info.nsubs && info.matches[i].start >= 0) {
-		    start = offset + info.matches[i].start;
-		    end = offset + info.matches[i].end;
-
-		    /*
-		     * Adjust index so it refers to the last character in the
-		     * match instead of the first character after the match.
-		     */
-
-		    if (end >= offset) {
-			end--;
-		    }
-		} else {
-		    start = -1;
-		    end = -1;
-		}
-
-		objs[0] = Tcl_NewLongObj(start);
-		objs[1] = Tcl_NewLongObj(end);
-
-		newPtr = Tcl_NewListObj(2, objs);
-	    } else {
-		if (i <= info.nsubs) {
-		    newPtr = Tcl_GetRange(objPtr,
-			    offset + info.matches[i].start,
-			    offset + info.matches[i].end - 1);
-		} else {
-		    newPtr = Tcl_NewObj();
-		}
-	    }
-	    if (doinline) {
-		if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
-			!= TCL_OK) {
-		    Tcl_DecrRefCount(newPtr);
-		    Tcl_DecrRefCount(resultPtr);
-		    return TCL_ERROR;
-		}
-	    } else {
-		if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr,
-			TCL_LEAVE_ERR_MSG) == NULL) {
-		    return TCL_ERROR;
-		}
-	    }
-	}
-
-	if (all == 0) {
-	    break;
-	}
-
-	/*
-	 * Adjust the offset to the character just after the last one in the
-	 * matchVar and increment all to count how many times we are making a
-	 * match. We always increment the offset by at least one to prevent
-	 * endless looping (as in the case: regexp -all {a*} a). Otherwise,
-	 * when we match the NULL string at the end of the input string, we
-	 * will loop indefinately (because the length of the match is 0, so
-	 * offset never changes).
-	 */
-
-	matchLength = (info.matches[0].end - info.matches[0].start);
-
-	offset += info.matches[0].end;
-
-	/*
-	 * A match of length zero could happen for {^} {$} or {.*} and in
-	 * these cases we always want to bump the index up one.
-	 */
-
-	if (matchLength == 0) {
-	    offset++;
-	}
-	all++;
-	if (offset >= stringLength) {
-	    break;
-	}
-    }
-
-    /*
-     * Set the interpreter's object result to an integer object with value 1
-     * if -all wasn't specified, otherwise it's all-1 (the number of times
-     * through the while - 1).
-     */
-
-    if (doinline) {
-	Tcl_SetObjResult(interp, resultPtr);
-    } else {
-	Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1));
-    }
-    return TCL_OK;
 }
 
 /*
@@ -490,27 +354,41 @@ Tcl_RegsubObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
-    int start, end, subStart, subEnd, match;
+    int idx, result, cflags, iflags, all, wlen, wsublen, numMatches, offset;
+    int start, end, subStart, subEnd, match, re_type, prevOffset;
+    int subMatchVarsElemc = 0;
     Tcl_RegExp regExpr;
     Tcl_RegExpInfo info;
     Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
+    Tcl_Obj **subMatchVarsElemv = NULL;
     Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
 
     static const char *const options[] = {
 	"-all",		"-nocase",	"-expanded",
 	"-line",	"-linestop",	"-lineanchor",	"-start",
-	"--",		NULL
+	"-submatches",	"-type",	"--",		NULL
     };
     enum options {
 	REGSUB_ALL,	REGSUB_NOCASE,	REGSUB_EXPANDED,
 	REGSUB_LINE,	REGSUB_LINESTOP, REGSUB_LINEANCHOR,	REGSUB_START,
-	REGSUB_LAST
+	REGSUB_SUBMATCHES, REGSUB_TYPE,	REGSUB_LAST
+    };
+    static CONST char *re_type_opts[] = {
+	"classic",	"pcre",	NULL
+    };
+    enum re_type_opts {
+	RETYPE_CLASSIC,	RETYPE_PCRE,
     };
 
+#ifdef USE_DEFAULT_PCRE
+    re_type = RETYPE_PCRE;
+#else
+    re_type = RETYPE_CLASSIC;
+#endif
     cflags = TCL_REG_ADVANCED;
     all = 0;
     offset = 0;
+    prevOffset = 0;
     resultPtr = NULL;
 
     for (idx = 1; idx < objc; idx++) {
@@ -559,9 +437,27 @@ Tcl_RegsubObjCmd(
 	    Tcl_IncrRefCount(startIndex);
 	    break;
 	}
+	case REGSUB_TYPE:
+	    if (++idx >= objc) {
+		goto endOfForLoop;
+	    }
+	    if (Tcl_GetIndexFromObj(interp, objv[idx], re_type_opts, "type",
+			    0, &re_type) != TCL_OK) {
+		goto optionError;
+	    }
+	    break;
 	case REGSUB_LAST:
 	    idx++;
 	    goto endOfForLoop;
+	case REGSUB_SUBMATCHES:
+	    if (++idx >= objc) {
+		goto endOfForLoop;
+	    }
+	    if (TclListObjGetElements(interp, objv[idx], &subMatchVarsElemc,
+				      &subMatchVarsElemv) != TCL_OK) {
+		goto optionError;
+	    }
+	    break;
 	}
     }
 
@@ -580,8 +476,18 @@ Tcl_RegsubObjCmd(
     objv += idx;
 
     if (startIndex) {
-	int stringLength = Tcl_GetCharLength(objv[1]);
+	int stringLength;
 
+	if ((enum re_type_opts) re_type == RETYPE_CLASSIC) {
+	    stringLength = Tcl_GetCharLength(objv[1]);
+	} else {
+	    if (objv[1]->typePtr == &tclByteArrayType) {
+		(void) Tcl_GetByteArrayFromObj(objv[1], &stringLength);
+	    } else {
+		/* XXX validate offset by char length */
+		(void) Tcl_GetStringFromObj(objv[1], &stringLength);
+	    }
+	}
 	TclGetIntForIndexM(NULL, startIndex, stringLength, &offset);
 	Tcl_DecrRefCount(startIndex);
 	if (offset < 0) {
@@ -660,7 +566,15 @@ Tcl_RegsubObjCmd(
 	goto regsubDone;
     }
 
+    iflags = ((Interp *)interp)->flags;
+    if ((enum re_type_opts) re_type == RETYPE_PCRE) {
+	cflags |= TCL_REG_PCRE;
+    } else if (iflags & INTERP_PCRE) {
+	/* Prevent -type classic from being overridden compiling RE */
+	((Interp *)interp)->flags &= ~(INTERP_PCRE);
+    }
     regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+    ((Interp *)interp)->flags = iflags;
     if (regExpr == NULL) {
 	return TCL_ERROR;
     }
@@ -716,6 +630,7 @@ Tcl_RegsubObjCmd(
 	if (match == 0) {
 	    break;
 	}
+	prevOffset = offset;
 	if (numMatches == 0) {
 	    resultPtr = Tcl_NewUnicodeObj(wstring, 0);
 	    Tcl_IncrRefCount(resultPtr);
@@ -764,6 +679,22 @@ Tcl_RegsubObjCmd(
 		    wfirstChar = wsrc + 2;
 		    wsrc++;
 		    continue;
+		} else if (re_type == RETYPE_PCRE) {
+		    switch (ch) {
+			case 'a': *wsrc = '\a'; break;
+			case 'e': *wsrc = '\e'; break;
+			case 'f': *wsrc = '\f'; break;
+			case 'n': *wsrc = '\n'; break;
+			case 'r': *wsrc = '\r'; break;
+			case 't': *wsrc = '\t'; break;
+			default: *wsrc = ch; break;
+		    }
+		    Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
+			    wsrc - wfirstChar + 1);
+		    *wsrc = '\\';
+		    wfirstChar = wsrc + 2;
+		    wsrc++;
+		    continue;
 		} else {
 		    continue;
 		}
@@ -824,6 +755,25 @@ Tcl_RegsubObjCmd(
 	}
     }
 
+    /*
+     * Return the regexp submatches in the requested variables.
+     */
+    if (numMatches && subMatchVarsElemc) {
+	for (idx = 0; (idx <= info.nsubs) && (idx < subMatchVarsElemc); ++idx) {
+	    subStart = info.matches[idx].start;
+	    subEnd = info.matches[idx].end;
+	    Tcl_Obj *obj = Tcl_NewUnicodeObj(wstring + prevOffset + subStart,
+					     subEnd - subStart);
+	    Tcl_IncrRefCount(obj);
+	    if (Tcl_ObjSetVar2(interp, subMatchVarsElemv[idx], NULL, obj,
+			       TCL_LEAVE_ERR_MSG) == NULL) {
+		Tcl_DecrRefCount(obj);
+		return (TCL_ERROR);
+	    }
+	    Tcl_DecrRefCount(obj);
+	}
+    }
+
     /*
      * Copy the portion of the source string after the last match to the
      * result variable.

generic/tclCompCmds.c

@@ -8,6 +8,7 @@
  * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
  * Copyright (c) 2002 ActiveState Corporation.
  * Copyright (c) 2004-2013 by Donal K. Fellows.
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.

generic/tclCompile.c

@@ -7,6 +7,7 @@
  *
  * Copyright (c) 1996-1998 Sun Microsystems, Inc.
  * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -653,6 +654,51 @@ InstructionDesc const tclInstructionTable[] = {
     {"lappendListStk",	 1,	-1,	0,	{OPERAND_NONE}},
 	/* Lappend list to general variable.
 	 * Stack:  ... varName list => ... listVarContents */
+    {"rot",		 2,    0,         1,    {OPERAND_UINT1}},
+	/* Rotate the top opnd elements in the stack */
+    {"l-index",		 5,    -1,        1,    {OPERAND_UINT4}},
+	/* Index into a nested struct/array/hash. opnd contains flags,
+	 * index is stktop, object to index into is stknext. */
+    {"l-deep-write",     9,    -1,        2,    {OPERAND_UINT4, OPERAND_UINT4}},
+	/* Write via L deep pointer pushed by l-index above.  opnd1 is a local
+	 * var index of a var that points to the top-level object being
+	 * indexed; it will be written if the top-level object needed to be
+	 * copied by l-index for copy-on-write.  opnd2 contains flags
+	 * indicating whether to leave old or new value on stack top.
+	 * stktop is the L deep pointer, stknext is the value to write. */
+    {"lsplit",		 2,    0,         1,    {OPERAND_UINT4}},
+	/* Perl-like string split. opnd is a flags word (see Expr_f),
+	 * stack contains the limit (optional), then the delimeter
+	 * (optional) then the string to split. */
+    {"l-defined",	 1,    0,         0,	{OPERAND_NONE}},
+	/* Test whether value at stackTop is the L undefined value. */
+    {"l-push-list-size", 1,    0,         0,	{OPERAND_NONE}},
+	/* Store the size of the list at stktop in the internal L
+	 * sizes stack.  Sizes are used to implement the L END keyword. */
+    {"l-push-string-size", 1,  0,         0,	{OPERAND_NONE}},
+	/* Store the length of the string at stktop in the internal L
+	 * sizes stack. */
+    {"l-read-size",	 1,    1,         0,	{OPERAND_NONE}},
+	/* Push what's on the top of the internal L sizes stack. */
+    {"l-pop-size",	 1,    0,         0,	{OPERAND_NONE}},
+	/* Pop the internal L sizes stack. */
+    {"l-push-undef",	 1,    1,         0,	{OPERAND_NONE}},
+	/* Push the L undef object. */
+    {"expandRot",	 2,    0,	  1,    {OPERAND_UINT1}},
+	/* Rotate the top opnd1 stack elements with those after
+	 * the expand marker (see expandStart). */
+    {"l-lindex-stk",	 2,    1,	  1,	{OPERAND_UINT1}},
+	/* push(listindex stktop opnd) except if opnd is <0 or
+	 * > # list elements then push the L undef object. */
+    {"l-list-insert",    9,    0,         3,    {OPERAND_LVT4, OPERAND_UINT4}},
+	/* Insert into list local var. Operands are local slot index,
+	 * flags, and list index to insert before (0 means prepend,
+	 * -1 means append). */
+    {"unsetLocal",	 5,    0,	  1,	{OPERAND_LVT4}},
+	/* Unset the local variable at index op1. */
+    {"different-obj",	 5,    0,	  1,	{OPERAND_LVT4}},
+	/* Determine whether the variable whose name is at stktop
+	 * points to a different object as the given local. */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
@@ -1799,13 +1845,29 @@ TclCompileInvocation(
     int numWords,
     CompileEnv *envPtr)
 {
-    int wordIdx = 0, depth = TclGetStackDepth(envPtr);
+    int adjust = 0, wordIdx = 0, depth = TclGetStackDepth(envPtr);
+    char *cmd, *s;
+    Tcl_Obj *obj;
     DefineLineInformation;
 
     if (cmdObj) {
 	CompileCmdLiteral(interp, cmdObj, envPtr);
 	wordIdx = 1;
 	tokenPtr = TokenAfter(tokenPtr);
+	cmd = Tcl_GetString(cmdObj);
+	if (!strcmp("L", cmd) || !strcmp("Lhtml", cmd)) {
+	    /*
+	     * If this is the L or Lhtml command, push the argument --line=%d
+	     * to it now.  This communicates the source line # to the L
+	     * compiler.
+	     */
+	    obj = Tcl_ObjPrintf("--line=%d", envPtr->line+1);
+	    Tcl_IncrRefCount(obj);
+	    s = TclGetString(obj);
+	    adjust = TclRegisterNewLiteral(envPtr, s, strlen(s));
+	    Tcl_DecrRefCount(obj);
+	    TclEmitPush(adjust, envPtr);
+	}
     }
 
     for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) {
@@ -1827,6 +1889,14 @@ TclCompileInvocation(
 	TclEmitPush(objIdx, envPtr);
     }
 
+    /*
+     * Possible adjust for L-command argument injection (see comment
+     * above).
+     */
+    if (adjust) {
+	++wordIdx;
+    }
+
     if (wordIdx <= 255) {
 	TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx);
     } else {
@@ -1843,7 +1913,8 @@ CompileExpanded(
     int numWords,
     CompileEnv *envPtr)
 {
-    int wordIdx = 0;
+    int adjust = 0, wordIdx = 0;
+    char *cmd;
     DefineLineInformation;
     int depth = TclGetStackDepth(envPtr);
 
@@ -1852,6 +1923,23 @@ CompileExpanded(
 	CompileCmdLiteral(interp, cmdObj, envPtr);
 	wordIdx = 1;
 	tokenPtr = TokenAfter(tokenPtr);
+	cmd = Tcl_GetString(cmdObj);
+	if (!strcmp("L", cmd) || !strcmp("Lhtml", cmd)) {
+	    /*
+	     * If this is the L or Lhtml command, push the argument --line=%d
+	     * to it now.  This communicates the source line # to the L
+	     * compiler.
+	     */
+	    char *s;
+	    Tcl_Obj *obj;
+
+	    obj = Tcl_ObjPrintf("--line=%d", envPtr->line+1);
+	    Tcl_IncrRefCount(obj);
+	    s = TclGetString(obj);
+	    adjust = TclRegisterNewLiteral(envPtr, s, strlen(s));
+	    Tcl_DecrRefCount(obj);
+	    TclEmitPush(adjust, envPtr);
+	}
     }
 
     for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) {
@@ -1877,6 +1965,14 @@ CompileExpanded(
 	TclEmitPush(objIdx, envPtr);
     }
 
+    /*
+     * Possible adjust for L-command argument injection (see comment
+     * above).
+     */
+    if (adjust) {
+	++wordIdx;
+    }
+
     /*
      * The stack depth during argument expansion can only be managed at
      * runtime, as the number of elements in the expanded lists is not known

generic/tclCompile.h

@@ -5,6 +5,7 @@
  * Copyright (c) 1998-2000 by Scriptics Corporation.
  * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
  * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -821,8 +822,25 @@ typedef struct ByteCode {
 #define INST_LAPPEND_LIST_ARRAY_STK	187
 #define INST_LAPPEND_LIST_STK		188
 
+/* L stuff */
+#define INST_ROT			189
+#define INST_L_INDEX			190
+#define INST_L_DEEP_WRITE		191
+#define INST_L_SPLIT			192
+#define INST_L_DEFINED			193
+#define INST_L_PUSH_LIST_SIZE		194
+#define INST_L_PUSH_STR_SIZE		195
+#define INST_L_READ_SIZE		196
+#define INST_L_POP_SIZE			197
+#define INST_L_PUSH_UNDEF		198
+#define INST_EXPAND_ROT			199
+#define INST_L_LINDEX_STK		200
+#define INST_L_LIST_INSERT		201
+#define INST_UNSET_LOCAL		202
+#define INST_DIFFERENT_OBJ		203
+
 /* The last opcode */
-#define LAST_INST_OPCODE		188
+#define LAST_INST_OPCODE		203
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying

generic/tclDisassemble.c

@@ -857,7 +857,6 @@ PrintSourceToObj(
 {
     register const char *p;
     register int i = 0, len;
-    Tcl_UniChar ch = 0;
 
     if (stringPtr == NULL) {
 	Tcl_AppendToObj(appendObj, "\"\"", -1);
@@ -866,65 +865,38 @@ PrintSourceToObj(
 
     Tcl_AppendToObj(appendObj, "\"", -1);
     p = stringPtr;
-    for (;  (*p != '\0') && (i < maxChars);  p+=len) {
+    for (;  (*p != '\0') && (i < maxChars);  ++i, p+=len) {
+	Tcl_UniChar ch;
 
 	len = TclUtfToUniChar(p, &ch);
 	switch (ch) {
 	case '"':
 	    Tcl_AppendToObj(appendObj, "\\\"", -1);
-	    i += 2;
 	    continue;
 	case '\f':
 	    Tcl_AppendToObj(appendObj, "\\f", -1);
-	    i += 2;
 	    continue;
 	case '\n':
 	    Tcl_AppendToObj(appendObj, "\\n", -1);
-	    i += 2;
 	    continue;
 	case '\r':
 	    Tcl_AppendToObj(appendObj, "\\r", -1);
-	    i += 2;
 	    continue;
 	case '\t':
 	    Tcl_AppendToObj(appendObj, "\\t", -1);
-	    i += 2;
 	    continue;
 	case '\v':
 	    Tcl_AppendToObj(appendObj, "\\v", -1);
-	    i += 2;
 	    continue;
 	default:
-#if TCL_UTF_MAX > 4
-	    if (ch > 0xffff) {
-		Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch);
-		i += 10;
-	    } else
-#elif TCL_UTF_MAX > 3
-	    /* If len == 0, this means we have a char > 0xffff, resulting in
-	     * TclUtfToUniChar producing a surrogate pair. We want to output
-	     * this pair as a single Unicode character.
-	     */
-	    if (len == 0) {
-		int upper = ((ch & 0x3ff) + 1) << 10;
-		len = TclUtfToUniChar(p, &ch);
-		Tcl_AppendPrintfToObj(appendObj, "\\U%08x", upper + (ch & 0x3ff));
-		i += 10;
-	    } else
-#endif
 	    if (ch < 0x20 || ch >= 0x7f) {
 		Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch);
-		i += 6;
 	    } else {
 		Tcl_AppendPrintfToObj(appendObj, "%c", ch);
-		i++;
 	    }
 	    continue;
 	}
     }
-    if (*p != '\0') {
-	Tcl_AppendToObj(appendObj, "...", -1);
-    }
     Tcl_AppendToObj(appendObj, "\"", -1);
 }
 
@@ -1476,13 +1448,6 @@ Tcl_DisassembleObjCmd(
      * Do the actual disassembly.
      */
 
-    if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) {
-	Tcl_SetObjResult(interp, Tcl_NewStringObj(
-		"may not disassemble prebuilt bytecode", -1));
-	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
-		"BYTECODE", NULL);
-	return TCL_ERROR;
-    }
     if (PTR2INT(clientData)) {
 	Tcl_SetObjResult(interp,
 		DisassembleByteCodeAsDicts(interp, codeObjPtr));

generic/tclIO.c

@@ -15,6 +15,9 @@
 #include "tclInt.h"
 #include "tclIO.h"
 #include <assert.h>
+#ifndef MIN
+#	define MIN(x,y) ((x)<(y)?(x):(y))
+#endif
 
 /*
  * For each channel handler registered in a call to Tcl_CreateChannelHandler,
@@ -4167,6 +4170,48 @@ WillRead(
     return 0;
 }
 
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_WriteObjN --
+ *
+ *	Same as Tcl_WriteObj but takes the number of bytes to write.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_WriteObjN(
+    Tcl_Channel chan,		/* The channel to buffer output for. */
+    Tcl_Obj *objPtr,		/* The object to write. */
+    int numBytes)		/* The number of bytes to write. */
+{
+    /*
+     * Always use the topmost channel of the stack
+     */
+
+    Channel *chanPtr;
+    ChannelState *statePtr;	/* State info for channel */
+    const char *src;
+    int srcLen;
+
+    statePtr = ((Channel *) chan)->state;
+    chanPtr = statePtr->topChanPtr;
+
+    if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
+	return -1;
+    }
+    if (statePtr->encoding == NULL) {
+	src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen);
+	numBytes = MIN(numBytes, srcLen);
+	return WriteBytes(chanPtr, src, numBytes);
+    } else {
+	src = TclGetStringFromObj(objPtr, &srcLen);
+	numBytes = MIN(numBytes, srcLen);
+	return WriteChars(chanPtr, src, numBytes);
+    }
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -7777,6 +7822,16 @@ Tcl_GetChannelOption(
 	    return TCL_OK;
 	}
     }
+    if (len == 0 || HaveOpt(2, "-epipe")) {
+	if (len == 0) {
+	    Tcl_DStringAppendElement(dsPtr, "-epipe");
+	}
+	Tcl_DStringAppendElement(dsPtr,
+		(flags & CHANNEL_EXIT_ON_EPIPE) ? "exit" : "error");
+	if (len > 0) {
+	    return TCL_OK;
+	}
+    }
     if (len == 0 || HaveOpt(1, "-translation")) {
 	if (len == 0) {
 	    Tcl_DStringAppendElement(dsPtr, "-translation");
@@ -8030,6 +8085,29 @@ Tcl_SetChannelOption(
 	ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED);
 	statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
 	return TCL_OK;
+    } else if (HaveOpt(2, "-epipe")) {
+	if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
+	    return TCL_ERROR;
+	}
+	if (argc == 1) {
+	    len = strlen(newValue);
+	    if (strncmp(newValue, "exit", len) == 0) {
+		SetFlag(statePtr, CHANNEL_EXIT_ON_EPIPE);
+		ckfree((char *) argv);
+		return TCL_OK;
+	    } else if (strncmp(newValue, "error", len) == 0) {
+		ResetFlag(statePtr, CHANNEL_EXIT_ON_EPIPE);
+		ckfree((char *) argv);
+		return TCL_OK;
+	    }
+	}
+	if (interp) {
+	    Tcl_AppendResult(interp,
+		"bad value for -epipe: must be one of exit or error",
+		NULL);
+	}
+	ckfree((char *) argv);
+	return TCL_ERROR;
     } else if (HaveOpt(1, "-translation")) {
 	const char *readMode, *writeMode;
 

generic/tclIO.h

@@ -282,6 +282,8 @@ typedef struct ChannelState {
 #define CHANNEL_CLOSEDWRITE	(1<<21)	/* Channel write side has been closed.
 					 * No further Tcl-level write IO on
 					 * the channel is allowed. */
+#define CHANNEL_EXIT_ON_EPIPE	(1<<22)	/* Exit on EPIPE (broken pipe) error
+					 * on the stdout channel. */
 
 /*
  * The length of time to wait between synthetic timer events. Must be zero or

generic/tclIOCmd.c

@@ -10,6 +10,7 @@
  */
 
 #include "tclInt.h"
+#include "tclIO.h"
 
 /*
  * Callback structure for accept callback in a TCP server.
@@ -203,6 +204,11 @@ Tcl_PutsObjCmd(
      */
 
   error:
+    if ((chan == Tcl_GetStdChannel(TCL_STDOUT)) &&
+	(((Channel *)chan)->state->flags & CHANNEL_EXIT_ON_EPIPE)) {
+	Tcl_Exit(0);
+	/*NOTREACHED*/
+    }
     if (!TclChanCaughtErrorBypass(interp, chan)) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s",
 		TclGetString(chanObjPtr), Tcl_PosixError(interp)));

generic/tclIOSock.c

@@ -282,6 +282,35 @@ TclCreateSocketAddress(
     return 1;
 }
 
+/*
+ * Work around an omission in earlier versions of MinGW.
+ */
+#ifdef __MINGW32__
+char* WSAAPI
+gai_strerrorA(int ecode)
+{
+	static char message[1024+1];
+	DWORD dwFlags = FORMAT_MESSAGE_FROM_SYSTEM
+		      | FORMAT_MESSAGE_IGNORE_INSERTS
+		      | FORMAT_MESSAGE_MAX_WIDTH_MASK;
+	DWORD dwLanguageId = MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT);
+	FormatMessageA(dwFlags, NULL, ecode, dwLanguageId, (LPSTR)message, 1024, NULL);
+	return message;
+}
+
+WCHAR* WSAAPI
+gai_strerrorW(int ecode)
+{
+	static WCHAR message[1024+1];
+	DWORD dwFlags = FORMAT_MESSAGE_FROM_SYSTEM
+		      | FORMAT_MESSAGE_IGNORE_INSERTS
+		      | FORMAT_MESSAGE_MAX_WIDTH_MASK;
+	DWORD dwLanguageId = MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT);
+	FormatMessageW(dwFlags, NULL, ecode, dwLanguageId, (LPWSTR)message, 1024, NULL);
+	return message;
+}
+#endif
+
 /*
  * Local Variables:
  * mode: c

generic/tclIOUtil.c

@@ -13,6 +13,7 @@
  * Copyright (c) 1991-1994 The Regents of the University of California.
  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  * Copyright (c) 2001-2004 Vincent Darley.
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -23,6 +24,7 @@
 #   include "tclWinInt.h"
 #endif
 #include "tclFileSystem.h"
+#include "Lcompile.h"
 
 #ifdef TCL_TEMPLOAD_NO_UNLINK
 #ifndef NO_FSTATFS
@@ -80,6 +82,8 @@ static void		FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
 			    Tcl_Obj *pathPtr, const char *pattern,
 			    Tcl_GlobTypeData *types);
 static void		FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);
+static Tcl_Obj *	FsMaybeWrapInLLang(Tcl_Interp *interp,
+			    Tcl_Obj *fileContents, const char *path);
 static void		FsRecacheFilesystemList(void);
 static void		Claim(void);
 static void		Disclaim(void);
@@ -1817,15 +1821,14 @@ Tcl_FSEvalFileEx(
     oldScriptFile = iPtr->scriptFile;
     iPtr->scriptFile = pathPtr;
     Tcl_IncrRefCount(iPtr->scriptFile);
+
+    objPtr = FsMaybeWrapInLLang(interp, objPtr, Tcl_GetString(pathPtr));
+
     string = Tcl_GetStringFromObj(objPtr, &length);
-
-    /*
-     * TIP #280 Force the evaluator to open a frame for a sourced file.
-     */
-
+    /* TIP #280 Force the evaluator to open a frame for a sourced
+     * file. */
     iPtr->evalFlags |= TCL_EVAL_FILE;
     result = TclEvalEx(interp, string, length, 0, 1, NULL, string);
-
     /*
      * Now we have to be careful; the script may have changed the
      * iPtr->scriptFile value, so we must reset it without assuming it still
@@ -1955,6 +1958,8 @@ TclNREvalFile(
     iPtr->scriptFile = pathPtr;
     Tcl_IncrRefCount(iPtr->scriptFile);
 
+    objPtr = FsMaybeWrapInLLang(interp, objPtr, Tcl_GetString(pathPtr));
+
     /*
      * TIP #280: Force the evaluator to open a frame for a sourced file.
      */
@@ -1975,7 +1980,6 @@ EvalFileCallback(
     Tcl_Obj *oldScriptFile = data[0];
     Tcl_Obj *pathPtr = data[1];
     Tcl_Obj *objPtr = data[2];
-
     /*
      * Now we have to be careful; the script may have changed the
      * iPtr->scriptFile value, so we must reset it without assuming it still
@@ -2009,6 +2013,47 @@ EvalFileCallback(
     return result;
 }
 
+/*
+ * Handle L and html/L code.
+ *
+ * If the path ends in .l, precede the file contents with #lang L.
+ * If the path ends in .lhtml, with #lang Lhtml.
+ *
+ * Return a Tcl_Obj containing the potentially wrapped string.
+ */
+static Tcl_Obj *
+FsMaybeWrapInLLang(
+    Tcl_Interp *interp,
+    Tcl_Obj *fileContents,
+    const char *path)
+{
+    int flen;
+    int plen = strlen(path);
+    char *s = Tcl_GetStringFromObj(fileContents, &flen);
+    char *append = "";
+    Tcl_Obj *newContents;
+
+    /* Append a newline if not already there. */
+    if (flen && (s[flen-1] != '\n')) append = "\n";
+
+    if (((plen >= 2) && (path[plen-2] == '.') && (path[plen-1] == 'l')) ||
+	(L && L->global->forceL)) {
+	newContents = Tcl_ObjPrintf("#lang L --lineadj=-1\n%s%s#lang tcl",
+				    s, append);
+	Tcl_DecrRefCount(fileContents);
+	Tcl_IncrRefCount(newContents);
+	fileContents = newContents;
+	if (L) L->global->forceL = 0;
+    } else if ((plen >= 6) && !strcmp(path+plen-6, ".lhtml")) {
+	newContents = Tcl_ObjPrintf("#lang Lhtml --lineadj=-1\n%s%s#lang tcl",
+				    s, append);
+	Tcl_DecrRefCount(fileContents);
+	Tcl_IncrRefCount(newContents);
+	fileContents = newContents;
+    }
+    return fileContents;
+}
+
 /*
  *----------------------------------------------------------------------
  *

generic/tclInt.h

@@ -11,6 +11,7 @@
  * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
  * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
  * Copyright (c) 2008 by Miguel Sofer. All rights reserved.
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -48,6 +49,9 @@
 #else
 #include <string.h>
 #endif
+#ifdef HAVE_STRINGS_H
+#include <strings.h>
+#endif
 #ifdef STDC_HEADERS
 #include <stddef.h>
 #else
@@ -2252,6 +2256,7 @@ typedef struct Interp {
  *			script in progress has been canceled thereby allowing
  *			the evaluation stack for the interp to be fully
  *			unwound.
+ * INTERP_PCRE		Non-zero means use PCRE engine by default for REs
  *
  * WARNING: For the sake of some extensions that have made use of former
  * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS)
@@ -2264,6 +2269,7 @@ typedef struct Interp {
 #define DONT_COMPILE_CMDS_INLINE	  0x20
 #define RAND_SEED_INITIALIZED		  0x40
 #define SAFE_INTERP			  0x80
+#define INTERP_PCRE			 0x100
 #define INTERP_TRACE_IN_PROGRESS	 0x200
 #define INTERP_ALTERNATE_WRONG_ARGS	 0x400
 #define ERR_LEGACY_COPY			 0x800
@@ -2484,7 +2490,7 @@ typedef struct List {
  *
  * DICT_PATH_UPDATE indicates that we are going to be doing an update at the
  * tip of the path, so duplication of shared objects should be done along the
- * way.
+ * way. 
  *
  * DICT_PATH_EXISTS indicates that we are performing an existance test and a
  * lookup failure should therefore not be an error. If (and only if) this flag
@@ -2883,6 +2889,7 @@ MODULE_SCOPE void	TclContinuationsCopy(Tcl_Obj *objPtr,
 MODULE_SCOPE int	TclConvertElement(const char *src, int length,
 			    char *dst, int flags);
 MODULE_SCOPE void	TclDeleteNamespaceVars(Namespace *nsPtr);
+MODULE_SCOPE void	TclDuplicateListRep(Tcl_Obj *objPtr);
 MODULE_SCOPE int	TclFindDictElement(Tcl_Interp *interp,
 			    const char *dict, int dictLength,
 			    const char **elementPtr, const char **nextPtr,
@@ -2989,6 +2996,9 @@ MODULE_SCOPE int	TclIsSpaceProc(char byte);
 MODULE_SCOPE int	TclIsBareword(char byte);
 MODULE_SCOPE Tcl_Obj *	TclJoinPath(int elements, Tcl_Obj * const objv[]);
 MODULE_SCOPE int	TclJoinThread(Tcl_ThreadId id, int *result);
+MODULE_SCOPE void	TclLInitCompiler(Tcl_Interp *interp);
+MODULE_SCOPE void	TclLCleanupCompiler(ClientData clientData,
+			    Tcl_Interp *interp);
 MODULE_SCOPE void	TclLimitRemoveAllHandlers(Tcl_Interp *interp);
 MODULE_SCOPE Tcl_Obj *	TclLindexList(Tcl_Interp *interp,
 			    Tcl_Obj *listPtr, Tcl_Obj *argPtr);
@@ -3268,6 +3278,9 @@ MODULE_SCOPE int	Tcl_FconfigureObjCmd(
 MODULE_SCOPE int	Tcl_FcopyObjCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_FGetlineObjCmd(ClientData dummy,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp);
 MODULE_SCOPE int	TclMakeFileCommandSafe(Tcl_Interp *interp);
 MODULE_SCOPE int	Tcl_FileEventObjCmd(ClientData clientData,
@@ -3285,6 +3298,12 @@ MODULE_SCOPE int	Tcl_ForeachObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_FormatObjCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_GetOptObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_GetOptResetObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_GetsObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -3310,9 +3329,24 @@ MODULE_SCOPE int	Tcl_JoinObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_LappendObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LAngleReadObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_LassignObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LDefined(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LGetNextLine(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LGetNextLineInit(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LGetDirX(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_LindexObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -3334,6 +3368,12 @@ MODULE_SCOPE int	Tcl_LoadObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_LrangeObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LReadCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LRefCnt(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_LrepeatObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -3352,6 +3392,9 @@ MODULE_SCOPE int	Tcl_LsetObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_LsortObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LWriteCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp);
 MODULE_SCOPE int	TclNamespaceEnsembleCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
@@ -3399,6 +3442,9 @@ MODULE_SCOPE int	Tcl_SeekObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_SetObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_ShSplitObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE int	Tcl_SplitObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -3453,6 +3499,16 @@ MODULE_SCOPE int	Tcl_VwaitObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_WhileObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_LHtmlObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+MODULE_SCOPE int	Tcl_PtrObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
+
 
 /*
  *----------------------------------------------------------------
@@ -3957,6 +4013,17 @@ MODULE_SCOPE int	TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
 			    Var *varPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
 			    int flags, int leaveErrMsg, int index);
 
+/*
+ * The variant RE engines
+ */
+
+MODULE_SCOPE int	TclRegexpClassic(Tcl_Interp *interp, int objc,
+			    Tcl_Obj *CONST objv[], Tcl_RegExp regExpr,
+			    int all, int indices, int doinline, int offset);
+MODULE_SCOPE int	TclRegexpPCRE(Tcl_Interp *interp, int objc,
+			    Tcl_Obj *CONST objv[], Tcl_RegExp regExpr,
+			    int all, int indices, int doinline, int offset);
+
 /*
  * So tclObj.c and tclDictObj.c can share these implementations.
  */
@@ -4063,7 +4130,8 @@ typedef const char *TclDTraceStr;
  */
 
 #  define TclAllocObjStorageEx(interp, objPtr) \
-	(objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj))
+	(objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); \
+	(objPtr)->undef = 0
 
 #  define TclFreeObjStorageEx(interp, objPtr) \
 	ckfree((char *) (objPtr))
@@ -4108,6 +4176,7 @@ MODULE_SCOPE void	TclpFreeAllocCache(void *);
 	    cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \
 	    --cachePtr->numObjects;					\
 	}								\
+	(objPtr)->undef = 0;						\
     } while (0)
 
 #  define TclFreeObjStorageEx(interp, objPtr)				\
@@ -4149,6 +4218,7 @@ MODULE_SCOPE Tcl_Mutex	tclObjMutex;
 	tclFreeObjList = (Tcl_Obj *)					\
 		tclFreeObjList->internalRep.twoPtrValue.ptr1;		\
 	Tcl_MutexUnlock(&tclObjMutex);					\
+	(objPtr)->undef = 0;						\
     } while (0)
 
 #  define TclFreeObjStorageEx(interp, objPtr) \

generic/tclInterp.c

@@ -489,6 +489,7 @@ TclInterpInit(
 
     Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd,
 	    NULL, NULL);
+    TclLInitCompiler(interp);
 
     Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
     return TCL_OK;
@@ -615,7 +616,8 @@ NRInterpCmd(
 	"eval",		"exists",	"expose",
 	"hide",		"hidden",	"issafe",
 	"invokehidden",	"limit",	"marktrusted",	"recursionlimit",
-	"slaves",	"share",	"target",	"transfer",
+	"regexp",	"slaves",	"share",	"target",
+	"transfer",
 	NULL
     };
     enum option {
@@ -624,7 +626,8 @@ NRInterpCmd(
 	OPT_EVAL,	OPT_EXISTS,	OPT_EXPOSE,
 	OPT_HIDE,	OPT_HIDDEN,	OPT_ISSAFE,
 	OPT_INVOKEHID,	OPT_LIMIT,	OPT_MARKTRUSTED,OPT_RECLIMIT,
-	OPT_SLAVES,	OPT_SHARE,	OPT_TARGET,	OPT_TRANSFER
+	OPT_REGEXP,	OPT_SLAVES,	OPT_SHARE,	OPT_TARGET,
+	OPT_TRANSFER
     };
 
     if (objc < 2) {
@@ -1034,6 +1037,41 @@ NRInterpCmd(
 	Tcl_SetObjResult(interp, resultPtr);
 	return TCL_OK;
     }
+    case OPT_REGEXP: {
+	int re_type;
+	Interp *slaveInterp;
+	static CONST char *re_type_opts[] = {
+	    "classic",	"pcre",	NULL
+	};
+	enum re_type_opts {
+	    RETYPE_CLASSIC,	RETYPE_PCRE,
+	};
+	if (objc != 3 && objc != 4) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "path ?type?");
+	    return TCL_ERROR;
+	}
+	slaveInterp = (Interp *) GetInterp(interp, objv[2]);
+	if (slaveInterp == NULL) {
+	    return TCL_ERROR;
+	}
+	if (objc == 4) {
+	    if (Tcl_GetIndexFromObj(interp, objv[3], re_type_opts, "type",
+			    0, &re_type) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    if ((enum re_type_opts) re_type == RETYPE_PCRE) {
+		slaveInterp->flags |= INTERP_PCRE;
+	    } else {
+		slaveInterp->flags &= ~(INTERP_PCRE);
+	    }
+	}
+	if (slaveInterp->flags & INTERP_PCRE) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj("pcre", -1));
+	} else {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj("classic", -1));
+	}
+	return TCL_OK;
+    }
     case OPT_TRANSFER:
     case OPT_SHARE: {
 	Tcl_Interp *masterInterp;	/* The master of the slave. */

generic/tclListObj.c

@@ -577,6 +577,7 @@ Tcl_ListObjAppendElement(
 
 	if (listPtr->bytes == tclEmptyStringRep) {
 	    Tcl_SetListObj(listPtr, 1, &objPtr);
+	    listPtr->undef = 0;
 	    return TCL_OK;
 	}
 	result = SetListFromAny(interp, listPtr);
@@ -691,6 +692,7 @@ Tcl_ListObjAppendElement(
     *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr;
     Tcl_IncrRefCount(objPtr);
     listRepPtr->elemCount++;
+    listPtr->undef = 0;
 
     /*
      * Invalidate any old string representation since the list's internal
@@ -865,6 +867,7 @@ Tcl_ListObjReplace(
     if (listPtr->typePtr != &tclListType) {
 	if (listPtr->bytes == tclEmptyStringRep) {
 	    if (!objc) {
+		listPtr->undef = 0;
 		return TCL_OK;
 	    }
 	    Tcl_SetListObj(listPtr, objc, NULL);
@@ -1090,6 +1093,7 @@ Tcl_ListObjReplace(
      */
 
     TclInvalidateStringRep(listPtr);
+    listPtr->undef = 0;
     return TCL_OK;
 }
 
@@ -2031,6 +2035,48 @@ UpdateStringOfList(
     }
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDuplicateListRep --
+ *
+ *	Create an unshared copy of a list's internal representation.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The object's internal representation is changed to point to
+ *	a newly allocated copy of its old representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclDuplicateListRep(Tcl_Obj *objPtr)
+{
+    int i, numElems;
+    List *listRepPtr, *oldListRepPtr;
+    Tcl_Obj **elemPtrs, **oldElems;
+
+    listRepPtr = (List *)objPtr->internalRep.twoPtrValue.ptr1;
+    if (listRepPtr->refCount > 1) {
+	oldListRepPtr = listRepPtr;
+	numElems = listRepPtr->elemCount;
+	listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL, 1);
+	oldElems = &oldListRepPtr->elements;
+	elemPtrs = &listRepPtr->elements;
+	for (i=0; i<numElems; i++) {
+	    elemPtrs[i] = oldElems[i];
+	    Tcl_IncrRefCount(elemPtrs[i]);
+	}
+	listRepPtr->elemCount = numElems;
+	listRepPtr->refCount++;
+	oldListRepPtr->refCount--;
+	objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+    }
+}
+
 /*
  * Local Variables:
  * mode: c

generic/tclMain.c

@@ -11,6 +11,7 @@
  * Copyright (c) 1988-1994 The Regents of the University of California.
  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  * Copyright (c) 2000 Ajuba Solutions.
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -32,6 +33,7 @@
 #   endif
 #endif
 
+#include "Lcompile.h"
 #include "tclInt.h"
 
 /*
@@ -309,9 +311,11 @@ Tcl_MainEx(
 				 * but before starting to execute commands. */
     Tcl_Interp *interp)
 {
-    Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
+    Tcl_Obj *path, *resultPtr, *argvPtr, *appName, *LObj;
+    int commandLen;
+    char *commandStr;
     const char *encodingName = NULL;
-    int code, exitCode = 0;
+    int code, exitCode = 0, isL = 0;
     Tcl_MainLoopProc *mainLoopProc;
     Tcl_Channel chan;
     InteractiveState is;
@@ -333,12 +337,18 @@ Tcl_MainEx(
 
     if (NULL == Tcl_GetStartupScript(NULL)) {
 	/*
-	 * Check whether first 3 args (argv[1] - argv[3]) look like
+	 * Check whether initial args (argv[1] and beyond) look like
 	 *  -encoding ENCODING FILENAME
 	 * or like
-	 *  FILENAME
+	 *  [-opt1] [-opt2] ... [-optn] FILENAME
 	 */
 
+	/* Create argv list obj for L. */
+	L->global->tclsh_argc = 1;
+	L->global->tclsh_argv = Tcl_NewObj();
+	Tcl_ListObjAppendElement(NULL, L->global->tclsh_argv,
+				 NewNativeObj(argv[0], -1));
+
 	if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
 		&& ('-' != argv[3][0])) {
 	    Tcl_Obj *value = NewNativeObj(argv[2], -1);
@@ -347,10 +357,21 @@ Tcl_MainEx(
 	    Tcl_DecrRefCount(value);
 	    argc -= 3;
 	    argv += 3;
-	} else if ((argc > 1) && ('-' != argv[1][0])) {
-	    Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
-	    argc--;
-	    argv++;
+	} else if (argc > 1) {
+	    /* Pass over all options to look for a file name. */
+	    int i;
+	    Tcl_Obj *argObj;
+	    for (i = 1; i < argc; ++i) {
+		argObj = NewNativeObj(argv[i], -1);
+		Tcl_ListObjAppendElement(NULL, L->global->tclsh_argv, argObj);
+		++L->global->tclsh_argc;
+		if ('-' != argv[i][0]) {
+		    Tcl_SetStartupScript(argObj, NULL);
+		    argc -= i;
+		    argv += i;
+		    break;
+		}
+	    }
 	}
     }
 
@@ -365,12 +386,15 @@ Tcl_MainEx(
     argv++;
 
     Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
+    L->global->script_argc = argc;
 
     argvPtr = Tcl_NewListObj(0, NULL);
     while (argc--) {
 	Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
     }
     Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
+    L->global->script_argv = argvPtr;
+    Tcl_IncrRefCount(argvPtr);
 
     /*
      * Set the "tcl_interactive" variable.
@@ -416,6 +440,31 @@ Tcl_MainEx(
 
     path = Tcl_GetStartupScript(&encodingName);
     if (path != NULL) {
+	int argc, i;
+	char *av0path;
+	Tcl_Obj **argvObjs, *pathObj;
+
+	/*
+	 * Set L->global->forceL if argv[0] is "L", or "-L" or "--L" was given
+	 * as a cmd-line option.  This causes Tcl_FSEvalFileEx() to wrap the
+	 * input file in a #lang L regardless of its extension.
+	 */
+	if (L->global->tclsh_argv) {
+	    Tcl_ListObjGetElements(interp, L->global->tclsh_argv, &argc,
+				   &argvObjs);
+	    pathObj = Tcl_FSGetNormalizedPath(interp, argvObjs[0]);
+	    av0path = Tcl_GetString(pathObj);
+	    if (av0path) {
+		L->global->forceL = (!strcmp(av0path+strlen(av0path)-2, "/L"));
+	    }
+	    for (i = 1; i < argc; ++i) {
+		if (!strcmp(Tcl_GetString(argvObjs[i]), "--L") ||
+		    !strcmp(Tcl_GetString(argvObjs[i]), "-L")) {
+		    L->global->forceL = 1;
+		}
+	    }
+	}
+
 	Tcl_ResetResult(interp);
 	code = Tcl_FSEvalFileEx(interp, path, encodingName);
 	if (code != TCL_OK) {
@@ -462,6 +511,7 @@ Tcl_MainEx(
      * Get a new value for tty if anyone writes to ::tcl_interactive
      */
 
+    Tcl_LinkVar(interp, "L", (char *) &isL, TCL_LINK_BOOLEAN);
     Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
     is.input = Tcl_GetStdChannel(TCL_STDIN);
     while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
@@ -508,6 +558,17 @@ Tcl_MainEx(
 		break;
 	    }
 
+	    /*
+	     * Check for the #lang comments and sub them out for
+	     * meaningful commands.
+	     */
+	    commandStr = Tcl_GetStringFromObj(is.commandPtr, &commandLen);
+	    if (!isL && strncasecmp(commandStr, "#lang l", 7) == 0) {
+		Tcl_SetStringObj(is.commandPtr, "set ::L 1", -1);
+	    } else if (isL && strncasecmp(commandStr, "#lang tcl", 9) == 0) {
+		Tcl_SetStringObj(is.commandPtr, "set('::L',0);", -1);
+	    }
+
 	    /*
 	     * Add the newline removed by Tcl_GetsObj back to the string. Have
 	     * to add it back before testing completeness, because it can make
@@ -527,6 +588,18 @@ Tcl_MainEx(
 
 	    is.prompt = PROMPT_START;
 
+	    if (isL) {
+	    	LObj = Tcl_NewStringObj("L {", -1);
+		Tcl_AppendObjToObj(LObj, is.commandPtr);
+		if (commandStr[commandLen-1] != ';') {
+		    Tcl_AppendToObj(LObj, ";", -1);
+		}
+		Tcl_AppendToObj(LObj, "}\n", -1);
+		Tcl_DecrRefCount(is.commandPtr);
+		is.commandPtr = LObj;
+		Tcl_IncrRefCount(is.commandPtr);
+	    }
+
 	    /*
 	     * The final newline is syntactically redundant, and causes some
 	     * error messages troubles deeper in, so lop it back off.

generic/tclNamesp.c

@@ -4853,7 +4853,7 @@ TclLogCommandInfo(
 {
     register const char *p;
     Interp *iPtr = (Interp *) interp;
-    int overflow, limit = 150;
+    int overflow, limit = 150, line;
     Var *varPtr, *arrayPtr;
 
     if (iPtr->flags & ERR_ALREADY_LOGGED) {
@@ -4867,12 +4867,18 @@ TclLogCommandInfo(
 
     if (command != NULL) {
 	/*
-	 * Compute the line number where the error occurred.
+	 * Compute the line number where the error occurred, honoring #line
+	 * directives generated by the L compiler.
 	 */
 
 	iPtr->errorLine = 1;
+	if (!strncmp(script,"#line ",6) && ((line = strtoul(script+6,NULL,10)) > 0)) {
+	    iPtr->errorLine = line - 1;
+	}
 	for (p = script; p != command; p++) {
-	    if (*p == '\n') {
+	    if (!strncmp(p,"\n#line ",7) && ((line = strtoul(p+7,NULL,10)) > 0)) {
+		iPtr->errorLine = line - 1;
+	    } else if (*p == '\n') {
 		iPtr->errorLine++;
 	    }
 	}

generic/tclObj.c

@@ -1064,6 +1064,7 @@ TclDbInitNewObj(
     objPtr->bytes = tclEmptyStringRep;
     objPtr->length = 0;
     objPtr->typePtr = NULL;
+    objPtr->undef = 0;
 
 #ifdef TCL_THREADS
     /*
@@ -1576,6 +1577,7 @@ TclObjBeingDeleted(
 		(dupPtr)->typePtr = typePtr;				\
 	    }								\
 	}								\
+	(dupPtr)->undef = (objPtr)->undef;				\
     }
 
 Tcl_Obj *
@@ -1886,6 +1888,10 @@ Tcl_GetBooleanFromObj(
     register Tcl_Obj *objPtr,	/* The object from which to get boolean. */
     register int *boolPtr)	/* Place to store resulting boolean. */
 {
+    if (objPtr->undef) {
+	*boolPtr = 0;
+	return TCL_OK;
+    }
     do {
 	if (objPtr->typePtr == &tclIntType) {
 	    *boolPtr = (objPtr->internalRep.longValue != 0);

generic/tclParse.c

@@ -8,6 +8,7 @@
  * Copyright (c) 1997 Sun Microsystems, Inc.
  * Copyright (c) 1998-2000 Ajuba Solutions.
  * Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,6 +17,7 @@
 #include "tclInt.h"
 #include "tclParse.h"
 #include <assert.h>
+#include "Last.h"
 
 /*
  * The following table provides parsing information about each possible 8-bit
@@ -160,6 +162,8 @@ const char tclCharTypeTable[] = {
  * Prototypes for local functions defined in this file:
  */
 
+static int		ParseLang(Tcl_Interp *interp, const char *src,
+			    int numBytes, Tcl_Parse *parsePtr, int *scanned);
 static inline int	CommandComplete(const char *script, int numBytes);
 static int		ParseComment(const char *src, int numBytes,
 			    Tcl_Parse *parsePtr);
@@ -168,6 +172,105 @@ static int		ParseTokens(const char *src, int numBytes, int mask,
 static int		ParseWhiteSpace(const char *src, int numBytes,
 			    int *incompletePtr, char *typePtr);
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseLang --
+ *	Scans up to numBytes bytes starting at src, consuming a Tcl lang
+ *	directive.
+ *
+ * Results:
+ *	Records in parsePtr information about the parse. Returns either
+ *	TCL_BREAK, meaning the parsing should continue, TCL_OK meaning
+ *	a Language directive was succesfully consumed, or TCL_ERROR meaning
+ *	the lang directive was incomplete (missing end #lang or missing EOF)
+ *	or there was some kind of an error
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ParseLang(
+    Tcl_Interp *interp,		/* Tcl interpreter */
+    CONST char *src,		/* First character to parse. */
+    register int numBytes,	/* Max number of bytes to scan. */
+    Tcl_Parse *parsePtr,	/* Information about parse in progress.
+				 * Updated if parsing indicates an incomplete
+				 * command. */
+    int *scanned)		/* How many bytes we used */
+{
+    register CONST char *p = src;
+    char *eol, *end;
+    Tcl_Token *tokenPtr;
+    Tcl_Parse optsParse;
+    int wordIdx;
+    char *message = "malformed pragma";
+
+    p += 5;
+    eol = strchr(p, '\n') + 1;
+    /* in case there's no \n, use the end of the string instead */
+    if (eol == (char *)1) {
+        eol = (char *)src + numBytes;
+    }
+    if (Tcl_ParseCommand(interp, p, eol - p, 0, &optsParse) != TCL_OK) {
+	goto error;
+    }
+    if (optsParse.numWords < 1) goto error;
+    tokenPtr = optsParse.tokenPtr;
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) goto error;
+    tokenPtr++;
+    if (!strncasecmp("tcl", tokenPtr->start, tokenPtr->size)) {
+	/* treat #lang tcl as a comment */
+	if (!parsePtr->commentStart) {
+	    parsePtr->commentStart = src;
+	}
+	parsePtr->commentSize = eol - src;
+	parsePtr->commandStart = NULL;
+	parsePtr->commandSize = 0;
+	*scanned = eol - src;
+	return TCL_BREAK;
+    }
+    if (!strncmp("L", tokenPtr->start, tokenPtr->size) ||
+	!strncmp("Lhtml", tokenPtr->start, tokenPtr->size)) {
+	/* it's L code, so do the parse again, but side-effect the parsePtr
+	 * this time */
+	Tcl_ParseCommand(interp, p, eol - p, 0, parsePtr);
+	/* now tack on one more word for the L code */
+	/* XXX strstr is not safe -- it expects a NULL on the end. */
+	end = strstr(eol, "\n#lang");
+	if (!end) {
+	    end = (char *)src + numBytes - 1;
+	}
+	TclGrowParseTokenArray(parsePtr, 2);
+	wordIdx = parsePtr->numTokens;
+	tokenPtr = &parsePtr->tokenPtr[wordIdx];
+	tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
+	tokenPtr->start = eol;
+	tokenPtr->size = end - tokenPtr->start + 1;
+	tokenPtr->numComponents = 1;
+	parsePtr->numTokens++;
+	parsePtr->numWords++;
+
+	tokenPtr = &parsePtr->tokenPtr[wordIdx+1];
+	*tokenPtr = parsePtr->tokenPtr[wordIdx];
+	tokenPtr->type = TCL_TOKEN_TEXT;
+	tokenPtr->numComponents = 0;
+	parsePtr->numTokens++;
+	parsePtr->commandSize = end - p;
+	return TCL_OK;
+    }
+ error:
+    parsePtr->commandStart = src;
+    parsePtr->commandSize = eol - src;
+    if (interp) {
+	Tcl_SetResult(interp, message, TCL_STATIC);
+    }
+    Tcl_FreeParse(parsePtr);
+    return TCL_ERROR;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -282,9 +385,10 @@ Tcl_ParseCommand(
      * Parse any leading space and comments before the first word of the
      * command.
      */
-
-    scanned = ParseComment(start, numBytes, parsePtr);
-    src = (start + scanned);
+    src = start;
+comments:
+    scanned = ParseComment(src, numBytes, parsePtr);
+    src += scanned;
     numBytes -= scanned;
     if (numBytes == 0) {
 	if (nested) {
@@ -292,6 +396,19 @@ Tcl_ParseCommand(
 	}
     }
 
+    /*
+     * Check for lang
+     */
+
+    if (strncmp(src, "#lang", 5) == 0) {
+	int rc = ParseLang(interp, src, numBytes, parsePtr, &scanned);
+	if (rc != TCL_BREAK) return rc;
+	src += scanned;
+	numBytes -= scanned;
+	if (numBytes > 0)
+	    goto comments;
+    }
+
     /*
      * The following loop parses the words of the command, one word in each
      * iteration through the loop.
@@ -1033,7 +1150,7 @@ ParseComment(
 	    numBytes -= scanned;
 	} while (numBytes && (*p == '\n') && (p++,numBytes--));
 
-	if ((numBytes == 0) || (*p != '#')) {
+	if ((numBytes == 0) || (*p != '#') || (strncmp(p, "#lang", 5) == 0)) {
 	    break;
 	}
 	if (parsePtr->commentStart == NULL) {

generic/tclPipe.c

@@ -5,6 +5,7 @@
  *	as well as various utility routines used in managing subprocesses.
  *
  * Copyright (c) 1997 by Sun Microsystems, Inc.
+ * Copyright (c) 2007 BitMover, Inc.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.

generic/tclRegexp.c

@@ -75,6 +75,12 @@ typedef struct ThreadSpecificData {
     struct TclRegexp *regexps[NUM_REGEXPS];
 				/* Compiled forms of above strings. Also
 				 * malloc-ed, or NULL if not in use yet. */
+#ifdef HAVE_PCRE
+    Tcl_RegExpIndices *matches;	/* To support PCRE in Tcl_RegExpGetInfo, we
+				 * need a classic info matches area to store
+				 * data in. */
+    int matchelems;		/* length of matches */
+#endif
 } ThreadSpecificData;
 
 static Tcl_ThreadDataKey dataKey;
@@ -253,8 +259,21 @@ Tcl_RegExpRange(
 	} else {
 	    string = regexpPtr->string;
 	}
-	*startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so);
-	*endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo);
+	if (regexpPtr->flags & TCL_REG_PCRE) {
+#ifdef HAVE_PCRE
+	    /* XXX We could check for tclByteArrayType objPtr */
+	    int last = regexpPtr->details.rm_extend.rm_so; /* last offset */
+	    *startPtr = Tcl_UtfAtIndex(string,
+		    regexpPtr->matches[index].rm_so - last);
+	    *endPtr = Tcl_UtfAtIndex(string,
+		    regexpPtr->matches[index].rm_eo - last);
+#else
+	    Tcl_Panic("Cannot get info for PCRE match");
+#endif
+	} else {
+	    *startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so);
+	    *endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo);
+	}
     }
 }
 
@@ -432,9 +451,9 @@ Tcl_RegExpExecObj(
     int flags)			/* Regular expression execution flags. */
 {
     TclRegexp *regexpPtr = (TclRegexp *) re;
-    Tcl_UniChar *udata;
-    int length;
+    int i, length;
     int reflags = regexpPtr->flags;
+    /* We could allow TCL_REG_PCRE to accept glob-fallback as well */
 #define TCL_REG_GLOBOK_FLAGS \
 	(TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)
 
@@ -464,15 +483,109 @@ Tcl_RegExpExecObj(
     regexpPtr->string = NULL;
     regexpPtr->objPtr = textObj;
 
-    udata = Tcl_GetUnicodeFromObj(textObj, &length);
+    if (reflags & TCL_REG_PCRE) {
+#ifdef HAVE_PCRE
+	const char *matchstr;
+	int match, pcreeflags, nm = (regexpPtr->re.re_nsub + 1) * 3;
+	int byteOffset, wlen;
+	unsigned long pcreopts;
 
-    if (offset > length) {
-	offset = length;
+	if (!(flags & TCL_REG_BYTEOFFSET)) {
+	    wlen = Tcl_GetCharLength(textObj);
+	}
+	if (textObj->typePtr == &tclByteArrayType) {
+	    matchstr = (const char*)Tcl_GetByteArrayFromObj(textObj, &length);
+	} else {
+	    matchstr = (const char*)Tcl_GetStringFromObj(textObj, &length);
+	}
+
+	pcreeflags = 0;
+	if (flags & TCL_REG_NOTBOL) {
+	    pcreeflags |= PCRE_NOTBOL;
+	}
+	pcre_fullinfo(regexpPtr->pcre, NULL, PCRE_INFO_OPTIONS, &pcreopts);
+
+	if (!(flags & TCL_REG_BYTEOFFSET)) {
+	    /* To handle UTF8, convert offset from a char index to a byte offset. */
+	    if (offset > wlen) {
+		offset = wlen;
+	    }
+	    byteOffset = Tcl_UtfAtIndex(matchstr, offset) - matchstr;
+	    if (byteOffset > length) {
+		byteOffset = length;
+	    }
+	} else {
+	    if (offset > length) {
+		offset = length;
+	    }
+	    byteOffset = offset;
+	}
+
+	match = pcre_exec(regexpPtr->pcre, regexpPtr->study,
+		matchstr, length, byteOffset, pcreeflags,
+		(int *) regexpPtr->matches, nm);
+
+	if (!(flags & TCL_REG_BYTEOFFSET)) {
+	    /*
+	     * For UTF8, we need the matches array as char offsets, but pcre
+	     * returns byte offsets.  Do the conversion.
+	     * This could be sped up for lots of matches.
+	     */
+	    for (i = 0; i < 2*match; ++i) {
+		int *p = &((int *)regexpPtr->matches)[i];
+		*p = Tcl_NumUtfChars(matchstr, *p);
+	    }
+	}
+
+	/*
+	 * Store last offset to support Tcl_RegExpGetInfo translation.
+	 */
+	if (match == PCRE_ERROR_NOMATCH) {
+	    regexpPtr->details.rm_extend.rm_so = -1;
+	} else {
+	    regexpPtr->details.rm_extend.rm_so = offset;
+	}
+
+	/*
+	 * Check for errors.
+	 */
+
+	if (match == PCRE_ERROR_NOMATCH) {
+	    return 0;
+	} else if (match == 0) {
+	    if (interp != NULL) {
+		Tcl_AppendResult(interp,
+			"pcre_exec had insufficient capture space", NULL);
+	    }
+	    return -1;
+	} else if (match < -1) {
+	    if (interp != NULL) {
+		char buf[32 + TCL_INTEGER_SPACE];
+		sprintf(buf, "pcre_exec returned error code %d", match);
+		Tcl_AppendResult(interp, buf, NULL);
+	    }
+	    return -1;
+	}
+	return 1;
+#else
+	if (interp != NULL) {
+	    Tcl_AppendResult(interp, "PCRE not available", NULL);
+	}
+	return -1;
+#endif
+    } else {
+	Tcl_UniChar *udata;
+
+	udata = Tcl_GetUnicodeFromObj(textObj, &length);
+
+	if (offset > length) {
+	    offset = length;
+	}
+	udata += offset;
+	length -= offset;
+
+	return RegExpExecUniChar(interp, re, udata, length, nmatches, flags);
     }
-    udata += offset;
-    length -= offset;
-
-    return RegExpExecUniChar(interp, re, udata, length, nmatches, flags);
 }
 
 /*
@@ -535,7 +648,32 @@ Tcl_RegExpGetInfo(
     TclRegexp *regexpPtr = (TclRegexp *) regexp;
 
     infoPtr->nsubs = regexpPtr->re.re_nsub;
-    infoPtr->matches = (Tcl_RegExpIndices *) regexpPtr->matches;
+    if (regexpPtr->flags & TCL_REG_PCRE) {
+#ifdef HAVE_PCRE
+	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+	int i, last, *matches = (int *) regexpPtr->matches;
+
+	/*
+	 * This works both to initialize and extend matches as necessary
+	 */
+	if (tsdPtr->matchelems <= infoPtr->nsubs) {
+	    tsdPtr->matchelems = infoPtr->nsubs + 1;
+	    tsdPtr->matches = (Tcl_RegExpIndices *)
+		ckrealloc((char *) tsdPtr->matches,
+			sizeof(Tcl_RegExpIndices) * tsdPtr->matchelems);
+	}
+	last = regexpPtr->details.rm_extend.rm_so; /* last offset */
+	for (i = 0; i <= infoPtr->nsubs; i++) {
+	    tsdPtr->matches[i].start = matches[i*2] - last;
+	    tsdPtr->matches[i].end = matches[i*2+1] - last;
+	}
+	infoPtr->matches = tsdPtr->matches;
+#else
+	Tcl_Panic("Cannot get info for PCRE match");
+#endif
+    } else {
+	infoPtr->matches = (Tcl_RegExpIndices *) regexpPtr->matches;
+    }
     infoPtr->extendStart = regexpPtr->details.rm_extend.rm_so;
 }
 
@@ -580,6 +718,10 @@ Tcl_GetRegExpFromObj(
 
     regexpPtr = objPtr->internalRep.twoPtrValue.ptr1;
 
+    /* XXX Need to have case where -type classic isn't ignored in regexp/sub */
+    if ((interp != NULL) && (((Interp *)interp)->flags & INTERP_PCRE)) {
+	flags |= TCL_REG_PCRE;
+    }
     if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
 	pattern = TclGetStringFromObj(objPtr, &length);
 
@@ -906,38 +1048,126 @@ CompileRegexp(
      */
 
     regexpPtr = ckalloc(sizeof(TclRegexp));
-    regexpPtr->objPtr = NULL;
-    regexpPtr->string = NULL;
+    memset(regexpPtr, 0, sizeof(TclRegexp));
+
+    regexpPtr->flags = flags;
     regexpPtr->details.rm_extend.rm_so = -1;
     regexpPtr->details.rm_extend.rm_eo = -1;
 
-    /*
-     * Get the up-to-date string representation and map to unicode.
-     */
+    if (flags & TCL_REG_PCRE) {
+#ifdef HAVE_PCRE
+	pcre *pcre;
+	char *p, *cstring = (char *) string;
+	const char *errstr;
+	int erroffset, rc, nsubs, pcrecflags;
 
-    Tcl_DStringInit(&stringBuf);
-    uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
-    numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);
-
-    /*
-     * Compile the string and check for errors.
-     */
-
-    regexpPtr->flags = flags;
-    status = TclReComp(&regexpPtr->re, uniString, (size_t) numChars, flags);
-    Tcl_DStringFree(&stringBuf);
-
-    if (status != REG_OKAY) {
 	/*
-	 * Clean up and report errors in the interpreter, if possible.
+	 * Convert from Tcl classic to PCRE cflags
 	 */
 
-	ckfree(regexpPtr);
-	if (interp) {
-	    TclRegError(interp,
-		    "couldn't compile regular expression pattern: ", status);
+	/* XXX Should enable PCRE_UTF8 selectively on non-ByteArray Tcl_Obj */
+	pcrecflags = PCRE_NO_UTF8_CHECK | PCRE_DOLLAR_ENDONLY | PCRE_DOTALL;
+	for (i = 0, p = cstring; i < length; i++) {
+	    if (UCHAR(*p++) > 0x80) {
+		pcrecflags |= PCRE_UTF8;
+		break;
+	    }
 	}
+	if (flags & TCL_REG_NOCASE) {
+	    pcrecflags |= PCRE_CASELESS;
+	}
+	if (flags & TCL_REG_EXPANDED) {
+	    pcrecflags |= PCRE_EXTENDED;
+	}
+	/* TCL_REG_NLSTOP|TCL_REG_NLANCH == TCL_REG_NEWLINE */
+	if (flags & TCL_REG_NLSTOP) {
+	    pcrecflags &= ~(PCRE_DOTALL);
+	}
+	if (flags & TCL_REG_NLANCH) {
+	    pcrecflags |= PCRE_MULTILINE;
+	    pcrecflags &= ~(PCRE_DOLLAR_ENDONLY);
+	}
+
+	if (cstring[length] != 0) {
+	    cstring = (char *) ckalloc(length + 1);
+	    memcpy(cstring, string, length);
+	    cstring[length] = 0;
+	}
+	pcre = pcre_compile(cstring, pcrecflags, &errstr, &erroffset, NULL);
+	regexpPtr->pcre = pcre;
+	if (cstring != (char *) string) {
+	    ckfree(cstring);
+	}
+
+	if (pcre == NULL) {
+	    ckfree((char *)regexpPtr);
+	    Tcl_AppendResult(interp,
+		    "couldn't compile pcre pattern: ", errstr, NULL);
+	    return NULL;
+	}
+
+	regexpPtr->study = pcre_study(pcre, 0, &errstr);
+	if (errstr != NULL) {
+	    pcre_free(pcre);
+	    ckfree((char *)regexpPtr);
+	    Tcl_AppendResult(interp,
+		    "error studying pcre pattern: ", errstr, NULL);
+	    return NULL;
+	}
+
+	/*
+	 * Allocate enough space for all of the subexpressions, plus one extra
+	 * for the entire pattern.
+	 */
+
+	rc = pcre_fullinfo(pcre, NULL, PCRE_INFO_CAPTURECOUNT, &nsubs);
+	if (rc == 0) {
+	    regexpPtr->re.re_nsub = nsubs;
+	    regexpPtr->matches = (regmatch_t *)
+		ckalloc(sizeof(int) * (nsubs+1)*3);
+	}
+#else
+	Tcl_AppendResult(interp,
+		"couldn't compile pcre pattern: pcre unavailabe", NULL);
 	return NULL;
+#endif
+    } else {
+	/*
+	 * Get the up-to-date string representation and map to unicode.
+	 */
+
+	Tcl_DStringInit(&stringBuf);
+	uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
+	numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);
+
+	/*
+	 * Compile the string and check for errors.
+	 */
+
+	status = TclReComp(&regexpPtr->re, uniString, (size_t) numChars, flags);
+	Tcl_DStringFree(&stringBuf);
+
+	if (status != REG_OKAY) {
+	    /*
+	     * Clean up and report errors in the interpreter, if possible.
+	     */
+
+	    ckfree((char *)regexpPtr);
+	    if (interp) {
+		TclRegError(interp,
+			"couldn't compile regular expression pattern: ",
+			status);
+	    }
+	    return NULL;
+	}
+
+	/*
+	 * Allocate enough space for all of the subexpressions, plus one extra
+	 * for the entire pattern.
+	 */
+
+	regexpPtr->matches = (regmatch_t *) ckalloc(
+	    sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
     }
 
     /*
@@ -954,14 +1184,6 @@ CompileRegexp(
 	regexpPtr->globObjPtr = NULL;
     }
 
-    /*
-     * Allocate enough space for all of the subexpressions, plus one extra for
-     * the entire pattern.
-     */
-
-    regexpPtr->matches =
-	    ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
-
     /*
      * Initialize the refcount to one initially, since it is in the cache.
      */
@@ -1014,6 +1236,14 @@ static void
 FreeRegexp(
     TclRegexp *regexpPtr)	/* Compiled regular expression to free. */
 {
+#ifdef HAVE_PCRE
+    if (regexpPtr->flags & TCL_REG_PCRE) {
+	pcre_free(regexpPtr->pcre);
+	if (regexpPtr->study) {
+	    pcre_free(regexpPtr->study);
+	}
+    } else
+#endif
     TclReFree(&regexpPtr->re);
     if (regexpPtr->globObjPtr) {
 	TclDecrRefCount(regexpPtr->globObjPtr);
@@ -1057,6 +1287,11 @@ FinalizeRegexp(
 	tsdPtr->patterns[i] = NULL;
     }
 
+#ifdef HAVE_PCRE
+    if (tsdPtr->matches != NULL) {
+	ckfree((char *) tsdPtr->matches);
+    }
+#endif
     /*
      * We may find ourselves reinitialized if another finalization routine
      * invokes regexps.
@@ -1065,6 +1300,448 @@ FinalizeRegexp(
     tsdPtr->initialized = 0;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRegexpClassic --
+ *
+ *	This procedure processes a classic "regexp".
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclRegexpClassic(
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *CONST objv[],	/* Argument objects. */
+    Tcl_RegExp regExpr,
+    int all,
+    int indices,
+    int doinline,
+    int offset)
+{
+    int i, match, numMatchesSaved, matchLength;
+    int eflags, stringLength;
+    Tcl_Obj *objPtr, *resultPtr = NULL;
+    Tcl_RegExpInfo info;
+
+    objPtr = objv[1];
+    stringLength = Tcl_GetCharLength(objPtr);
+
+    objc -= 2;
+    objv += 2;
+
+    if (doinline) {
+	/*
+	 * Save all the subexpressions, as we will return them as a list
+	 */
+
+	numMatchesSaved = -1;
+    } else {
+	/*
+	 * Save only enough subexpressions for matches we want to keep, expect
+	 * in the case of -all, where we need to keep at least one to know
+	 * where to move the offset.
+	 */
+
+	numMatchesSaved = (objc == 0) ? all : objc;
+    }
+
+    /*
+     * The following loop is to handle multiple matches within the same source
+     * string; each iteration handles one match. If "-all" hasn't been
+     * specified then the loop body only gets executed once. We terminate the
+     * loop when the starting offset is past the end of the string.
+     */
+
+    while (1) {
+	/*
+	 * Pass either 0 or TCL_REG_NOTBOL in the eflags. Passing
+	 * TCL_REG_NOTBOL indicates that the character at offset should not be
+	 * considered the start of the line. If for example the pattern {^} is
+	 * passed and -start is positive, then the pattern will not match the
+	 * start of the string unless the previous character is a newline.
+	 */
+
+	if (offset == 0) {
+	    eflags = 0;
+	} else if (offset > stringLength) {
+	    eflags = TCL_REG_NOTBOL;
+	} else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') {
+	    eflags = 0;
+	} else {
+	    eflags = TCL_REG_NOTBOL;
+	}
+
+	match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
+		numMatchesSaved, eflags);
+	if (match < 0) {
+	    return TCL_ERROR;
+	}
+
+	if (match == 0) {
+	    /*
+	     * We want to set the value of the intepreter result only when
+	     * this is the first time through the loop.
+	     */
+
+	    if (all <= 1) {
+		/*
+		 * If inlining, the interpreter's object result remains an
+		 * empty list, otherwise set it to an integer object w/ value
+		 * 0.
+		 */
+
+		if (!doinline) {
+		    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+		}
+		return TCL_OK;
+	    }
+	    break;
+	}
+
+	/*
+	 * If additional variable names have been specified, return index
+	 * information in those variables.
+	 */
+
+	Tcl_RegExpGetInfo(regExpr, &info);
+	if (doinline) {
+	    /*
+	     * It's the number of substitutions, plus one for the matchVar at
+	     * index 0
+	     */
+
+	    objc = info.nsubs + 1;
+	    if (all <= 1) {
+		resultPtr = Tcl_NewObj();
+	    }
+	}
+	for (i = 0; i < objc; i++) {
+	    Tcl_Obj *newPtr;
+
+	    if (indices) {
+		int start, end;
+		Tcl_Obj *objs[2];
+
+		/*
+		 * Only adjust the match area if there was a match for that
+		 * area. (Scriptics Bug 4391/SF Bug #219232)
+		 */
+
+		if (i <= info.nsubs && info.matches[i].start >= 0) {
+		    start = offset + info.matches[i].start;
+		    end = offset + info.matches[i].end;
+
+		    /*
+		     * Adjust index so it refers to the last character in the
+		     * match instead of the first character after the match.
+		     */
+
+		    if (end >= offset) {
+			end--;
+		    }
+		} else {
+		    start = -1;
+		    end = -1;
+		}
+
+		objs[0] = Tcl_NewLongObj(start);
+		objs[1] = Tcl_NewLongObj(end);
+
+		newPtr = Tcl_NewListObj(2, objs);
+	    } else {
+		if (i <= info.nsubs) {
+		    newPtr = Tcl_GetRange(objPtr,
+			    offset + info.matches[i].start,
+			    offset + info.matches[i].end - 1);
+		} else {
+		    newPtr = Tcl_NewObj();
+		}
+	    }
+	    if (doinline) {
+		if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
+			!= TCL_OK) {
+		    Tcl_DecrRefCount(newPtr);
+		    Tcl_DecrRefCount(resultPtr);
+		    return TCL_ERROR;
+		}
+	    } else {
+		if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr,
+			TCL_LEAVE_ERR_MSG) == NULL) {
+		    return TCL_ERROR;
+		}
+	    }
+	}
+
+	if (all == 0) {
+	    break;
+	}
+
+	/*
+	 * Adjust the offset to the character just after the last one in the
+	 * matchVar and increment all to count how many times we are making a
+	 * match. We always increment the offset by at least one to prevent
+	 * endless looping (as in the case: regexp -all {a*} a). Otherwise,
+	 * when we match the NULL string at the end of the input string, we
+	 * will loop indefinately (because the length of the match is 0, so
+	 * offset never changes).
+	 */
+
+	matchLength = (info.matches[0].end - info.matches[0].start);
+
+	offset += info.matches[0].end;
+
+	/*
+	 * A match of length zero could happen for {^} {$} or {.*} and in
+	 * these cases we always want to bump the index up one.
+	 */
+
+	if (matchLength == 0) {
+	    offset++;
+	}
+	offset += info.matches[0].end;
+	all++;
+	eflags |= TCL_REG_NOTBOL;
+	if (offset >= stringLength) {
+	    break;
+	}
+    }
+
+    /*
+     * Set the interpreter's object result to an integer object with value 1
+     * if -all wasn't specified, otherwise it's all-1 (the number of times
+     * through the while - 1).
+     */
+
+    if (doinline) {
+	Tcl_SetObjResult(interp, resultPtr);
+    } else {
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1));
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRegexpPCRE --
+ *
+ *	This procedure processes a PCRE "regexp".
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclRegexpPCRE(
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *CONST objv[],	/* Argument objects. */
+    Tcl_RegExp regExpr,
+    int all,
+    int indices,
+    int doinline,
+    int offset)
+{
+#ifdef HAVE_PCRE
+    int i, match, eflags, stringLength, matchelems, *matches;
+    Tcl_Obj *objPtr, *resultPtr = NULL;
+    const char *matchstr;
+    pcre *re;
+    pcre_extra *study;
+    TclRegexp *regexpPtr = (TclRegexp *) regExpr;
+
+    objPtr = objv[1];
+    if (objPtr->typePtr == &tclByteArrayType) {
+	matchstr = (const char*)Tcl_GetByteArrayFromObj(objPtr, &stringLength);
+    } else {
+	matchstr = (const char*)Tcl_GetStringFromObj(objPtr, &stringLength);
+    }
+
+    eflags = PCRE_NO_UTF8_CHECK;
+    if (offset > 0) {
+	/*
+	 * Translate offset into correct placement for utf-8 chars.
+	 * Add flag if using offset (string is part of a larger string), so
+	 * that "^" won't match.
+	 */
+
+	if (objPtr->typePtr != &tclByteArrayType) {
+	    /* XXX: probably needs length restriction */
+	    offset = Tcl_UtfAtIndex(matchstr, offset) - matchstr;
+	}
+	eflags |= PCRE_NOTBOL;
+    }
+
+    objc -= 2;
+    objv += 2;
+
+    /*
+     * The following loop is to handle multiple matches within the same source
+     * string; each iteration handles one match. If "-all" hasn't been
+     * specified then the loop body only gets executed once. We terminate the
+     * loop when the starting offset is past the end of the string.
+     */
+
+    re = regexpPtr->pcre;
+    study = regexpPtr->study;
+    matches = (int *) regexpPtr->matches;
+    matchelems = (int) (regexpPtr->re.re_nsub + 1) * 3;
+    while (1) {
+	match = pcre_exec(re, study, matchstr, stringLength,
+		offset, eflags, matches, matchelems);
+
+	if (match < -1) {
+	    char buf[32 + TCL_INTEGER_SPACE];
+	    sprintf(buf, "pcre_exec returned error code %d", match);
+	    Tcl_AppendResult(interp, buf, NULL);
+	    return TCL_ERROR;
+	}
+
+	if (match == 0) {
+	    Tcl_AppendResult(interp,
+		    "pcre_exec had insufficient capture space", NULL);
+	    return TCL_ERROR;
+	}
+
+	if (match == PCRE_ERROR_NOMATCH) {
+	    /*
+	     * We want to set the value of the intepreter result only when
+	     * this is the first time through the loop.
+	     */
+
+	    if (all <= 1) {
+		/*
+		 * If inlining, the interpreter's object result remains an
+		 * empty list, otherwise set it to an integer object w/ value
+		 * 0.
+		 */
+
+		if (!doinline) {
+		    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
+		}
+		return TCL_OK;
+	    }
+	    break;
+	}
+
+	/*
+	 * If additional variable names have been specified, return index
+	 * information in those variables.
+	 */
+
+	if (doinline) {
+	    /*
+	     * It's the number of substitutions, plus one for the matchVar at
+	     * index 0
+	     */
+
+	    objc = match;
+	    if (all <= 1) {
+		resultPtr = Tcl_NewObj();
+	    }
+	}
+	for (i = 0; i < objc; i++) {
+	    Tcl_Obj *newPtr;
+	    int start, end;
+
+	    if (i < match) {
+		start = matches[i*2];
+		end = matches[i*2 + 1];
+	    } else {
+		start = -1;
+		end = -1;
+	    }
+	    if (indices) {
+		Tcl_Obj *objs[2];
+
+		objs[0] = Tcl_NewLongObj(start);
+		objs[1] = Tcl_NewLongObj((end < 0) ? end : end - 1);
+
+		newPtr = Tcl_NewListObj(2, objs);
+	    } else {
+		if (i < match) {
+		    newPtr = Tcl_NewStringObj(matchstr + start, end - start);
+		} else {
+		    newPtr = Tcl_NewObj();
+		}
+	    }
+	    if (doinline) {
+		if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
+			!= TCL_OK) {
+		    Tcl_DecrRefCount(newPtr);
+		    Tcl_DecrRefCount(resultPtr);
+		    return TCL_ERROR;
+		}
+	    } else {
+		Tcl_Obj *valuePtr;
+		valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
+		if (valuePtr == NULL) {
+		    Tcl_AppendResult(interp, "couldn't set variable \"",
+			    TclGetString(objv[i]), "\"", NULL);
+		    return TCL_ERROR;
+		}
+	    }
+	}
+
+	if (all == 0) {
+	    break;
+	}
+
+	/*
+	 * Adjust the offset to the character just after the last one in the
+	 * matchVar and increment all to count how many times we are making a
+	 * match. We always increment the offset by at least one to prevent
+	 * endless looping (as in the case: regexp -all {a*} a). Otherwise,
+	 * when we match the NULL string at the end of the input string, we
+	 * will loop indefinately (because the length of the match is 0, so
+	 * offset never changes).
+	 * matches[1] is the match end point of the full RE match.
+	 */
+
+	if (matches[0] == matches[1]) {
+	    offset++;
+	} else {
+	    offset = matches[1];
+	}
+	all++;
+	eflags |= PCRE_NOTBOL;
+	if (offset >= stringLength) {
+	    break;
+	}
+    }
+
+    /*
+     * Set the interpreter's object result to an integer object with value 1
+     * if -all wasn't specified, otherwise it's all-1 (the number of times
+     * through the while - 1).
+     */
+
+    if (doinline) {
+	Tcl_SetObjResult(interp, resultPtr);
+    } else {
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1));
+    }
+    return TCL_OK;
+#else /* !HAVE_PCRE */
+    Tcl_AppendResult(interp, "PCRE not available", NULL);
+    return TCL_ERROR;
+#endif
+}
+
 /*
  * Local Variables:
  * mode: c

generic/tclRegexp.h

@@ -16,6 +16,10 @@
 
 #include "regex.h"
 
+#ifdef HAVE_PCRE
+#include <pcre.h>
+#endif
+
 /*
  * The TclRegexp structure encapsulates a compiled regex_t, the flags that
  * were used to compile it, and an array of pointers that are used to indicate
@@ -28,6 +32,10 @@ typedef struct TclRegexp {
     int flags;			/* Regexp compile flags. */
     regex_t re;			/* Compiled re, includes number of
 				 * subexpressions. */
+#ifdef HAVE_PCRE
+    pcre *pcre;			/* PCRE compile re */
+    pcre_extra *study;		/* study of PCRE */
+#endif
     const char *string;		/* Last string passed to Tcl_RegExpExec. */
     Tcl_Obj *objPtr;		/* Last object passed to Tcl_RegExpExecObj. */
     Tcl_Obj *globObjPtr;	/* Glob pattern rep of RE or NULL if none. */

library/Lver.tcl

@@ -0,0 +1 @@
+proc Lver {} { return "1.0" }

library/http/http.tcl

@@ -548,10 +548,11 @@ proc http::geturl {url args} {
     # If a timeout is specified we set up the after event and arrange for an
     # asynchronous socket connection.
 
-    set sockopts [list -async]
+    set sockopts [list]
     if {$state(-timeout) > 0} {
 	set state(after) [after $state(-timeout) \
 		[list http::reset $token timeout]]
+	lappend sockopts -async
     }
 
     # If we are using the proxy, we must pass in the full URL that includes

library/init.tcl

@@ -7,6 +7,7 @@
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
 # Copyright (c) 1998-1999 Scriptics Corporation.
 # Copyright (c) 2004 by Kevin B. Kenny.  All rights reserved.
+# Copyright (c) 2007 BitMover, Inc.
 #
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -816,3 +817,5 @@ proc tcl::CopyDirectory {action src dest} {
     }
     return
 }
+
+source [file join $::tcl_library libl.tcl]

library/tcltest/tcltest.tcl

@@ -661,7 +661,8 @@ namespace eval tcltest {
     } AcceptPattern matchFiles
 
     # By default, skip files that appear to be SCCS lock files.
-    Option -notfile l.*.test {
+    # XXX - busted.
+    Option -notfile SCCS/l.*.test {
 	Skip all test files that match the glob pattern given.
     } AcceptPattern skipFiles
 
@@ -888,8 +889,8 @@ proc tcltest::DebugPArray {level arrayvar} {
 # defined in ::tcltest.  NOTE: Ought to construct with [info args] and
 # [info default], but can't be bothered now.  If [parray] changes, then
 # this will need changing too.
-auto_load ::parray
-proc tcltest::parray {a {pattern *}} [info body ::parray]
+#auto_load ::parray
+#proc tcltest::parray {a {pattern *}} [info body ::parray]
 
 # tcltest::DebugDo --
 #
@@ -2694,6 +2695,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
 #
 # Arguments:
 #	shell being tested
+#	arguments to pass to shell
 #
 # Results:
 #	None.
@@ -2701,7 +2703,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
 # Side effects:
 #	None.
 
-proc tcltest::runAllTests { {shell ""} } {
+proc tcltest::runAllTests { {shell ""} {shellArgs ""} } {
     variable testSingleFile
     variable numTestFiles
     variable numTests
@@ -2754,6 +2756,7 @@ proc tcltest::runAllTests { {shell ""} } {
 
     set timeCmd {clock format [clock seconds]}
     puts [outputChannel] "Tests began at [eval $timeCmd]"
+    set exit_status 0
 
     # Run each of the specified tests
     foreach file [lsort [GetMatchingFiles]] {
@@ -2778,7 +2781,7 @@ proc tcltest::runAllTests { {shell ""} } {
 		}
 		lappend childargv $opt $value
 	    }
-	    set cmd [linsert $childargv 0 | $shell $file]
+	    set cmd [linsert $childargv 0 | $shell {*}$shellArgs $file]
 	    if {[catch {
 		incr numTestFiles
 		set pipeFd [open $cmd "r"]
@@ -2796,6 +2799,7 @@ proc tcltest::runAllTests { {shell ""} } {
 			}
 			if {$Failed > 0} {
 			    lappend failFiles $testFile
+			    set exit_status 1
 			}
 		    } elseif {[regexp [join {
 			    {^Number of tests skipped }
@@ -2823,6 +2827,7 @@ proc tcltest::runAllTests { {shell ""} } {
     puts [outputChannel] "\nTests ended at [eval $timeCmd]"
     cleanupTests 1
     if {[info exists testFileFailures]} {
+	set exit_status 1
 	puts [outputChannel] "\nTest files exiting with errors:  \n"
 	foreach file $testFileFailures {
 	    puts [outputChannel] "  [file tail $file]\n"
@@ -2842,7 +2847,7 @@ proc tcltest::runAllTests { {shell ""} } {
 	puts [outputChannel] ""
 	puts [outputChannel] [string repeat ~ 44]
     }
-    return
+    return $exit_status
 }
 
 #####################################################################

library/tm.tcl

@@ -49,7 +49,7 @@ namespace eval ::tcl::tm {
 
     # The regex pattern a file name has to match to make it a Tcl Module.
 
-    set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}
+    set pkgpattern {^([_[:alpha:]][\:_[:alnum:]]*)-([[:digit:]].*)[.]tm$}
 
     # Export the public API
 

license.terms

@@ -1,7 +1,7 @@
 This software is copyrighted by the Regents of the University of
 California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
-Corporation and other parties.  The following terms apply to all files
-associated with the software unless explicitly disclaimed in
+Corporation, BitMover Inc, and other parties.  The following terms apply
+to all files associated with the software unless explicitly disclaimed in
 individual files.
 
 The authors hereby grant permission to use, copy, modify, distribute,

tests/all.tcl

@@ -18,5 +18,9 @@ configure {*}$argv -testdir [file dir [info script]]
 if {[singleProcess]} {
     interp debug {} -frame 1
 }
-runAllTests
+if {[info exists ::env(TCLTEST_SHELL_OPTIONS)]} {
+    exit [runAllTests [interpreter] $::env(TCLTEST_SHELL_OPTIONS)]
+} else {
+    exit [runAllTests]
+}
 proc exit args {}

tests/interp.test

@@ -32,7 +32,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body {
 } -result {wrong # args: should be "interp cmd ?arg ...?"}
 test interp-1.2 {options for interp command} -returnCodes error -body {
     interp frobox
-} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, regexp, slaves, share, target, or transfer}
 test interp-1.3 {options for interp command} {
     interp delete
 } ""
@@ -50,13 +50,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body {
 } -result {wrong # args: should be "interp slaves ?path?"}
 test interp-1.7 {options for interp command} -returnCodes error -body {
     interp hello
-} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, regexp, slaves, share, target, or transfer}
 test interp-1.8 {options for interp command} -returnCodes error -body {
     interp -froboz
-} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}
+} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, regexp, slaves, share, target, or transfer}
 test interp-1.9 {options for interp command} -returnCodes error -body {
     interp -froboz -safe
-} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} 
+} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, regexp, slaves, share, target, or transfer} 
 test interp-1.10 {options for interp command} -returnCodes error -body {
     interp target
 } -result {wrong # args: should be "interp target path alias"}
@@ -3576,6 +3576,31 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup {
     unset -nocomplain result
     interp delete slave
 } -result foo
+test interp-37.1 {interp regexp} {
+    list [catch {interp regexp} msg] $msg
+} {1 {wrong # args: should be "interp regexp path ?type?"}}
+test interp-37.2 {interp regexp} {
+    list [catch {interp regexp {} invalid} msg] $msg
+} {1 {bad type "invalid": must be classic or pcre}}
+test interp-37.3 {interp regexp} {
+    list [catch {interp regexp {} classic bogus} msg] $msg
+} {1 {wrong # args: should be "interp regexp path ?type?"}}
+test interp-37.4 {interp regexp} -setup {
+    unset -nocomplain ::env(TCL_REGEXP_PCRE)
+    interp create slave
+} -body {
+    slave eval {interp regexp {}}
+} -cleanup {
+    interp delete slave
+} -result {classic}
+test interp-37.5 {interp regexp} -setup {
+    unset -nocomplain ::env(TCL_REGEXP_PCRE)
+    interp create slave
+} -body {
+    slave eval {interp regexp {} pcre}
+} -cleanup {
+    interp delete slave
+} -result {pcre}
 
 test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup {
     catch {interp delete a}

tests/l-leak.test

@@ -0,0 +1,686 @@
+# Test the L language.
+# Copyright (c) 2007 BitMover, Inc.
+
+#
+# Tests in this file look for leaks in L core; they are only functional in
+# builds with -DTCL_MEM_DEBUG (--enable-symbols=mem or all)
+#
+
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest 2
+    namespace import -force ::tcltest::*
+    testConstraint exec [llength [info commands exec]]
+}
+
+set haveMem [llength [info commands memory]]
+testConstraint memory $haveMem
+
+#lang L
+int getbytes()
+{
+	return ((int)(split(split(/\n/, Memory_info())[3])[3]));
+}
+#lang tcl
+
+# This causes L to keep running L code even after a compile error.
+set ::env(_L_TEST) 1
+
+# This tells L to run in a backwards compatibility mode for
+# the old eq/ne/le/lt/ge/gt string-comparison operators.
+set ::env(_L_ALLOW_EQ_OPS) 1
+
+test leak-1.1 {leaks in a simple L-loop} -body {
+#lang L --line=1
+    void leak_1_1() {
+	int tmp, end, i, j;
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j=i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_1_1();
+} -constraints memory -output "0 4\n"
+
+test leak-1.2 {leaks in L-func called in a loop} -body {
+#lang L --line=1
+    int leak_1_2_foo (int v) {
+	int k;
+	k = v;
+	return k;
+    }
+    void leak_1_2() {
+	int tmp, end, i, j;
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j=leak_1_2_foo(i);
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_1_2();
+} -constraints memory -output "0 4\n"
+
+test leak-1.3 {leaks in L-func called in a tcl-loop} -body {
+#lang L --line=1
+    int leak_1_3_foo (int v) {
+	int k;
+	k = v;
+	return k;
+    }
+#lang tcl
+    set end [getbytes]
+    for {set i 0} {$i < 5} {incr i} {
+	set j [leak_1_3_foo $i]
+	set tmp $end
+	set end [getbytes]
+    }
+    puts [list [expr {$end - $tmp}] $j]
+} -constraints memory -output "0 4\n"
+
+test leak-2.0 {leaks in array reading} -body {
+#lang L --line=1
+    void leak_2_0() {
+	int tmp, end, i, j[2], k, l;
+	j[0]=1;
+	j[1]=2;
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    k = j[0];
+	    l = j[1];
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(end-tmp);
+    }
+    leak_2_0();
+} -constraints memory -output "0\n"
+
+test leak-2.1 {leaks in array initializers} -body {
+#lang L --line=1
+    void leak_2_1() {
+	int tmp, end, i, k[2];
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    int j[2];
+	    k = j;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(end-tmp);
+    }
+    leak_2_1();
+} -constraints memory -output "0\n"
+
+test leak-2.2.0 {leaks in arrays} -body {
+#lang L --line=1
+    void leak_2_2_0() {
+	int tmp, end, i, j[2] = {0,0};
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j[0]=i;
+	    j[1]=2*j[0]+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_2_2_0();
+} -constraints memory -output "0 {4 12}\n"
+
+test leak-2.2.1 {leaks in arrays} -body {
+#lang L --line=1
+    void leak_2_2_1() {
+	int tmp, end, i, k[2], j[2];
+	j=k;
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j[0]=i;
+	    j[1]=2*j[0]+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_2_2_1();
+} -constraints memory -output "0 {4 12}\n"
+
+test leak-2.3 {leaks in arrays} -body {
+#lang L --line=1
+    int leak_2_3_foo (int v) {
+	int k[2];
+	k[0] = v;
+	k[1] = 2*k[0]+v;
+	return k[1];
+    }
+    void leak_2_3() {
+	int tmp, end, i, j;
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j=leak_2_3_foo(i);
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_2_3();
+} -constraints memory -output "0 12\n"
+
+test leak-2.4 {leaks in arrays} -body {
+#lang L --line=1
+    void leak_2_4() {
+	int tmp, end, i, j[2][2];
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j[0][0]=i;
+	    j[0][1]=2*j[0][0]+i;
+	    j[1][0]=j[0][0]+j[0][1];
+	    j[1][1]=2*j[1][0]+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_2_4();
+} -constraints memory -output "0 {{4 12} {16 36}}\n"
+
+test leak-2.5 {leaks in arrays} -body {
+#lang L --line=1
+    void leak_2_5() {
+	int tmp, end, i, t, j[2][2][2];
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    for (t=0; t < 2; t++) {
+		j[0][i%2][t]=i+t;
+		j[1][i%2][t]=i*i+t;
+	    }
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_2_5();
+} -constraints memory -output "0 {{{4 5} {3 4}} {{16 17} {9 10}}}\n"
+
+test leak-3.0 {leaks in hash initializers} -body {
+#lang L --line=1
+    void leak_3_0() {
+	int tmp, end, i;
+	hash k = {"1" => "foo"};
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    hash j = {"1" => "moo"};
+	    k = j;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, k));
+    }
+    leak_3_0();
+} -constraints memory -output "0 {1 moo}\n"
+
+test leak-3.1.0 {leaks in hashes} -body {
+#lang L --line=1
+    void leak_3_1_0() {
+	int tmp, end, i;
+	hash j;
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j{"0"}=i;
+	    j{"1"}=2*(int)j{"0"}+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j{"1"}));
+    }
+    leak_3_1_0();
+} -constraints memory -output "0 12\n"
+
+test leak-3.1.1 {leaks in hashes} -body {
+#lang L --line=1
+    void leak_3_1_1() {
+	int tmp, end, i;
+	hash j = {"u" => 0};
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j{"0"}=i;
+	    j{"1"}=2*(int)j{"0"}+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j{"1"}));
+    }
+    leak_3_1_1();
+} -constraints memory -output "0 12\n"
+
+test leak-3.1.2 {leaks in hashes} -body {
+#lang L --line=1
+    void leak_3_1_2() {
+	int tmp, end, i;
+	hash j, k = {"u" => 0};
+
+	j = k;
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j{"0"}=i;
+	    j{"1"}=2*(int)j{"0"}+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j{"1"}));
+    }
+    leak_3_1_2();
+} -constraints memory -output "0 12\n"
+
+test leak-3.2.0 {leaks in hashes} -body {
+#lang L --line=1
+    hash leak_3_2_0_foo (int v) {
+	hash k;
+	k{"0"} = v;
+	k{"1"} = 2*(int)k{"0"}+v;
+	return k;
+    }
+    void leak_3_2_0() {
+	int tmp, end, i;
+	hash j;
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j=leak_3_2_0_foo(i);
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j{"1"}));
+    }
+    leak_3_2_0();
+} -constraints memory -output "0 12\n"
+
+test leak-3.2.1 {leaks in hashes} -body {
+#lang L --line=1
+    hash leak_3_2_1_foo (int v) {
+	hash k = {"a" => "b"};
+	k{"0"} = v;
+	k{"1"} = 2*(int)k{"0"}+v;
+	return k;
+    }
+    void leak_3_2_1() {
+	int tmp, end, i;
+	hash j;
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j=leak_3_2_1_foo(i);
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j{"1"}));
+    }
+    leak_3_2_1();
+} -constraints memory -output "0 12\n"
+
+test leak-3.3 {leaks in nested hashes} -body {
+#lang L --line=1
+    void leak_3_3() {
+	int tmp, end, i;
+	int j{string}{string};
+
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j{"0"}{"0"}=i;
+	    j{"0"}{"1"}=2*(int)j{"0"}{"0"}+i;
+	    j{"1"}{"0"}=2*i + 1 + (int)j{"0"}{"1"};
+	    j{"1"}{"1"}=2*(int)j{"1"}{"0"}+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j{"1"}{"1"}));
+    }
+    leak_3_3();
+} -constraints memory -output "0 46\n"
+
+test leak-4.1 {leaks in structs} -body {
+#lang L --line=1
+    struct leak_4_1_js {int x, y;};
+    void leak_4_1() {
+	int tmp, end, i;
+	struct leak_4_1_js j;
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j.x=i;
+	    j.y=2*j.x+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_4_1();
+} -constraints memory -output "0 {4 12}\n"
+
+test leak-4.2 {leaks in structs} -body {
+#lang L --line=1
+    struct leak_4_2_js {int x, y[2];};
+    void leak_4_2() {
+	int tmp, end, i;
+	struct leak_4_2_js j;
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j.x=i;
+	    j.y[0]=2*j.x+i;
+	    j.y[1]=2*j.y[0]+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_4_2();
+} -constraints memory -output "0 {4 {12 28}}\n"
+
+test leak-4.3 {leaks in structs} -body {
+#lang L --line=1
+    struct leak_4_3_js {int x, y;};
+    void leak_4_3() {
+	int tmp, end, i;
+	struct leak_4_3_js j[2];
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j[0].x=i;
+	    j[0].y=2*j[0].x+i;
+	    j[1].x=j[0].x+j[0].y;
+	    j[1].y=2*j[1].x+i;
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_4_3();
+} -constraints memory -output "0 {{4 12} {16 36}}\n"
+
+test leak-5.1 {leaks in deep diving} -body {
+#lang L --line=1
+    struct leak_5_1_js {string h{string}; poly a[2];};
+    struct leak_5_1_js leak_5_1_j[2];
+    string leak_5_1_h{string};
+    void leak_5_1() {
+	int tmp, end, i;
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    leak_5_1_j[0].h{"foo"}= leak_5_1_j[1].a[1];
+	    leak_5_1_j[1].h{"foo"}= "moo";
+	    leak_5_1_j[0].a[0]=leak_5_1_j[1].h;
+	    leak_5_1_j[0].a[1]=leak_5_1_j[0].h{"foo"};
+	    leak_5_1_j[1].a[0]=leak_5_1_j[0].h{"foo"};
+	    leak_5_1_j[1].a[1]=leak_5_1_j[1].a[0];
+	    tmp=end;
+	    end = getbytes();
+	}
+	leak_5_1_h = (hash)leak_5_1_j[0].a[0];
+	puts(list(end-tmp, leak_5_1_h{"foo"}, leak_5_1_j[1].h{"foo"}));
+    }
+    leak_5_1();
+} -constraints memory -output "0 moo moo\n"
+
+test leak-5.2 {leaks in deep diving} -body {
+#lang L --line=1
+    void leak_5_2() {
+	int tmp, end, i, j;
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j = {1,2,3}[1];
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_5_2();
+} -constraints memory -output "0 2\n"
+
+test leak-5.3 {leaks in deep diving} -body {
+#lang L --line=1
+    void leak_5_3() {
+	int tmp, end, i, j;
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j = {{1,2},{3,4},{4,5}}[1][0];
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_5_3();
+} -constraints memory -output "0 3\n"
+
+test leak-5.4 {leaks in deep diving} -body {
+#lang L --line=1
+    void leak_5_4() {
+	int tmp, end, i, j;
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    j = { {{1,2},{3,4}}, {{4,5},{5,6}}, {{7,8},{9,10}} }[1][1][0];
+	    { {0,0} }[END][0];
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, j));
+    }
+    leak_5_4();
+} -constraints memory -output "0 5\n"
+
+test leak-5.5 {leaks in deep diving} -body {
+#lang L --line=1
+void leak_5_5()
+{
+	int	n = 1000;
+	int	i, start, end, types{string}[];
+
+	/*
+	 * Push onto a hash element that's an array element while
+	 * check memory usage. Allow 1 kB/element. Any more than that
+	 * must be a memory leak.
+	 */
+	start = getbytes();
+	for (i = 0; i < n; ++i) {
+		push(&types{"foo"}, i);
+	}
+	end = getbytes();
+	if ((end - start) > (1000*n)) {
+		puts("took ${(end-start)/n} bytes per elt");
+	}
+}
+leak_5_5();
+} -constraints memory -output {}
+
+test leak-6.1 {leaks in string indexing} -body {
+#lang L --line=1
+    void leak_6_1() {
+	int	end, i, tmp;
+	string	a[], s1, s2;
+
+	a[0] = "zero";
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    s1 = a[0];
+	    s2 = {"zero"}[0];
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, s1, s2));
+    }
+    leak_6_1();
+} -constraints memory -output "0 zero zero\n"
+
+test leak-6.2 {leaks in string indexing} -body {
+#lang L --line=1
+    void leak_6_2() {
+	int	end, i, tmp;
+	string	a[][], s1, s2;
+
+	a[0][0] = "zero";
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    s1 = a[0][0];
+	    s2 = { {"zero"} }[0][0];
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, s1, s2));
+    }
+    leak_6_2();
+} -constraints memory -output "0 zero zero\n"
+
+test leak-6.3 {leaks in string indexing} -body {
+#lang L --line=1
+    void leak_6_3() {
+	int	end, i, tmp;
+	string	a[][][], s1, s2;
+
+	a[0][0][0] = "zero";
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    s1 = a[0][0][0];
+	    s2 = { { {"zero"} } }[0][0][0];
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(list(end-tmp, s1, s2));
+    }
+    leak_6_3();
+} -constraints memory -output "0 zero zero\n"
+
+test leak-6.4 {leaks in string indexing} -body {
+#lang L --line=1
+    void leak_6_4() {
+	int	end, i, tmp;
+	string	s;
+
+	s = "abcd";
+	end = getbytes();
+	for(i=0; i<5;i++) {
+	    s[0] = "w";
+	    s[1] = "x";
+	    s[2] = "y";
+	    s[3] = "z";
+	    s[0] = "123";
+	    s[1] = "456";
+	    s[2] = "789";
+	    s[3] = "0yz";
+	    s[0] = "";
+	    s[1] = "";
+	    s[2] = "";
+	    s[3] = "";
+	    s[4] = "";
+	    s[5] = "";
+	    s[0] = "";
+	    s[0] = "";
+	    tmp=end;
+	    end = getbytes();
+	}
+	puts(end-tmp);
+    }
+    leak_6_4();
+} -constraints memory -output "0\n"
+
+test leak-7.1 {leaks in classes} -body {
+#lang L --line=1
+class leak_7_1
+{
+	public	int v1;
+	instance {
+		 public	int v2;
+	}
+	constructor leak_7_1_init() {}
+	destructor leak_7_1_free(leak_7_1 self) {}
+}
+void leak_7_1_main()
+{
+	int		end, i, tmp;
+	leak_7_1	o;
+
+	end = getbytes();
+	for (i = 0; i < 5; ++i) {
+		o = leak_7_1_init();
+		leak_7_1_free(o);
+		tmp = end;
+		end = getbytes();
+	}
+	puts(end - tmp);
+}
+leak_7_1_main();
+} -constraints memory -output "0\n"
+
+test leak-8.1 {leaks with undef() on hashes} -body {
+#lang L --line=1
+void leak_8_1_main()
+{
+	int		end, i, tmp;
+
+	end = getbytes();
+	for (i = 0; i < 5; ++i) {
+		string	h{string} = { "1"=>"1", "2"=>"2", "3"=>"3", "4"=>"4" };
+		undef(h{"1"});
+		undef(h{"2"});
+		undef(h{"3"});
+		undef(h{"4"});
+		tmp = end;
+		end = getbytes();
+	}
+	puts(end - tmp);
+}
+leak_8_1_main();
+} -constraints memory -output "0\n"
+
+test leak-8.2 {leaks with undef() on arrays} -body {
+#lang L --line=1
+void leak_8_2_main()
+{
+	int		end, i, tmp;
+
+	end = getbytes();
+	for (i = 0; i < 5; ++i) {
+		int	a[] = { 1, 2, 3, 4 };
+		undef(a[0]);
+		undef(a[0]);
+		undef(a[0]);
+		undef(a[0]);
+		tmp = end;
+		end = getbytes();
+	}
+	puts(end - tmp);
+}
+leak_8_2_main();
+} -constraints memory -output "0\n"
+
+# Disable the leak-9 test for now. L leaks memory when freeing
+# a Tcl interp. Usually, L code is run all within one interp so
+# this usually isn't a big deal. Some day we'll come back to this.
+::tcltest::cleanupTests
+return
+
+test leak-9 {per-interp L state leak} -body {
+    set end [getbytes]
+    for {set i 0} {$i < 5} {incr i} {
+	interp create slave
+	slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13
+	interp delete slave
+	set tmp $end
+	set end [getbytes]
+    }
+    puts [expr {$end - $tmp}]
+} -constraints memory -output "0\n"
+
+# cleanup
+::tcltest::cleanupTests
+return

tests/l-regression.test

@@ -0,0 +1,381 @@
+# Test to make sure that bugs don't creep back into L
+# Copyright (c) 2007 BitMover, Inc.
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest 2
+    namespace import -force ::tcltest::*
+}
+
+# This causes L to keep running L code even after a compile error.
+set ::env(_L_TEST) 1
+
+# This tells L to run in a backwards compatibility mode for
+# the old eq/ne/le/lt/ge/gt string-comparison operators.
+set ::env(_L_ALLOW_EQ_OPS) 1
+
+test empty-1.0 {empty code blocks} -body {
+#lang L --line=1
+void empty_1_0() {
+} 
+#lang tcl
+empty_1_0
+} 
+
+test empty-1.1 {empty code blocks with some control flow} -body {
+#lang L --line=1
+void empty_1_1() {
+        /* note that none of these conditions is true, 
+           so no code is executed */
+        unless(1) {
+                puts("1 broken");
+        } else if (0) {
+                puts("1.1 broken");
+        } else unless(1) {
+                puts("1 working");
+        }
+} 
+#lang tcl
+empty_1_1
+} 
+
+test values-1.0 {the values of struct increment and assignment} -body {
+#lang L --line=1
+struct values_1_0 {
+  int clicks;
+  string value;
+};
+
+void values_1_0() {
+  struct values_1_0 main_entry;
+  puts(main_entry.clicks = 0);
+  puts(++main_entry.clicks);
+}
+#lang tcl
+values_1_0
+} -output "0\n1\n"
+
+
+test multi-dimensional-1.0 {move[state][read_symbol] was being evaluated as
+move[state][state[read_symbol]][read_symbol], or thereabouts, because the AST
+was built in an ambiguous way.} -body {
+#lang L --line=1
+string dump_tape(int tape[]);
+void turing(int step, int state, int tape[], int pos) {
+    int write_symbol[5][2], move[5][2], new_state[5][2], read_symbol;
+
+    write_symbol[0][1] = 0;  move[0][1] = 1;  new_state[0][1] = 1;
+    write_symbol[1][1] = 1;  move[1][1] = 1;  new_state[1][1] = 1;
+    write_symbol[1][0] = 0;  move[1][0] = 1;  new_state[1][0] = 2;
+    write_symbol[2][0] = 1;  move[2][0] = 0;  new_state[2][0] = 3;
+    write_symbol[2][1] = 1;  move[2][1] = 1;  new_state[2][1] = 2;
+    write_symbol[3][1] = 1;  move[3][1] = 0;  new_state[3][1] = 3;
+    write_symbol[3][0] = 0;  move[3][0] = 0;  new_state[3][0] = 4;
+    write_symbol[4][1] = 1;  move[4][1] = 0;  new_state[4][1] = 4;
+    write_symbol[4][0] = 1;  move[4][0] = 1;  new_state[4][0] = 0;
+
+    read_symbol = tape[pos];
+    puts(append("", "  ", step, "\ts", state + 1, "\t", dump_tape(tape)));
+
+    // state 0 and symbol 0 means to halt
+    if (read_symbol + state) {
+        tape[pos] = write_symbol[state][read_symbol];
+        if (move[state][read_symbol]) {
+            pos++;
+        } else {
+            pos--;
+        }
+        turing(step + 1, new_state[state][read_symbol], tape, pos);
+    } else {
+        puts("-- halt --");
+    }
+}
+
+/* dump the tape to a string */
+string
+dump_tape(int tape[]) {
+    return format("%d %d %d %d %d",
+                  tape[0],  tape[1], tape[2], tape[3], tape[4]);
+}
+
+void multi_dimensional_1_0() {
+    int tape[5];
+
+    tape[0] = 1; tape[1] = 1; tape[2] = 0; tape[3] = 0; tape[4] = 0;
+    puts("Step\tState\tTape");
+    puts("- - - - - - - - - -");
+    turing(1, 0, tape, 0);
+}
+#lang tcl
+multi_dimensional_1_0
+} -output {Step	State	Tape
+- - - - - - - - - -
+  1	s1	1 1 0 0 0
+  2	s2	0 1 0 0 0
+  3	s2	0 1 0 0 0
+  4	s3	0 1 0 0 0
+  5	s4	0 1 0 1 0
+  6	s5	0 1 0 1 0
+  7	s5	0 1 0 1 0
+  8	s1	1 1 0 1 0
+  9	s2	1 0 0 1 0
+  10	s3	1 0 0 1 0
+  11	s3	1 0 0 1 0
+  12	s4	1 0 0 1 1
+  13	s4	1 0 0 1 1
+  14	s5	1 0 0 1 1
+  15	s1	1 1 0 1 1
+-- halt --
+}
+
+test initializers-1.0 {initialize a whole array at once} -body {
+#lang L --line=1
+void initializers_1_1() {
+  string foo[] = initializers_1_1_returnarray();
+
+  printf("foo[0] is %s\n", foo[0]);
+  printf("foo[1] is %s\n", foo[1]);
+}
+
+poly initializers_1_1_returnarray() {
+  return "foo bar";
+}
+#lang tcl
+initializers_1_1
+} -output "foo\[0\] is foo\nfoo\[1\] is bar\n"
+
+test cast-1.0 {don't segfault when casting to a string} -body {
+#lang L --line=1
+void cast_1_0() {
+	puts((string)"asdf");
+}
+#lang tcl
+cast_1_0
+} -output "asdf\n"
+
+
+test typecheck-1.0 {typechecker segfaults on unop check that must be queued} -body {
+#lang L --line=1
+int typecheck_1_0_bar() {
+	return 22;
+}
+string typecheck_1_0_foo(string foo) {
+	return foo;
+}
+void typecheck_1_0() {
+	// note the -
+	typecheck_1_0_foo(-typecheck_1_0_bar());
+}
+#lang tcl
+typecheck_1_0
+} -returnCodes {error} -match glob -result \
+    "*:9: L Error: parameter 1 has incompatible type\n"
+
+test decl-1.0 {don't drop array dimensions from typedef when declaring multiple variables} -body {
+#lang L --line=1
+typedef int atype[2];
+void decl_1_0() {
+	atype foo[3], bar;
+	foo[2][1] = 0;
+	bar[1] = 0;
+	puts(foo);
+	puts(bar);
+}
+#lang tcl
+decl_1_0
+} -output "{} {} {{} 0}\n{} 0\n"
+
+test if-1.0 {jump target is wrong when else block gets too big} -body {
+#lang L --line=1 -nowarn
+void if_1_0() {
+	string w = ".asdf";
+	string btm = "${w}.btm", e = "${w}.e";
+	if (0) {
+		puts("wicky wicky2");
+		wm("withdraw", btm);
+	} else {
+		string width, h, h1, x, y;
+		puts("wicky wicky3");
+		width = winfo("width", e);
+		h = winfo("reqheight", w);
+		h1 = winfo("reqheight", btm);
+		x = winfo("rootx", w);
+		y = winfo("rooty", w);
+		/* XXX, wtf? */
+		puts(width);
+		puts(h1);
+		puts(x);
+	}
+}
+
+string winfo(string a, string b) {return "42";}
+#lang tcl
+if_1_0
+} -output {wicky wicky3
+42
+42
+42
+}
+
+test scope-1.0 {if a global is first used as a reference, it gets erroneously created twice} -body {
+#lang L --line=1
+string avar = "foo";
+void frob(string &str) {
+	str = "bar";
+}
+void scope_1_0() {
+	frob(&avar);
+	puts(avar);
+}
+#lang tcl
+scope_1_0
+} -output "bar\n";
+
+test scope-1.1 {a block introduces a new scope} -body {
+#lang L --line=1
+void scope_1_1() {
+	{
+		int a;
+		a = 5;
+	}
+	puts(a);
+}
+#lang tcl
+scope_1_1
+} -returnCodes {error} -match glob -result "*:6: L Error: undeclared variable: a\n"
+
+test regexp-1.0 {regexps might start with a dash, so call regex/regsub with -- before the regexp} -body {
+#lang L --line=1
+void regexp_1_0() {
+	string v = "a-b-c";
+	v =~ s/-/\–/g;
+	puts(v);
+}
+#lang tcl
+regexp_1_0
+} -output "a–b–c\n"
+
+test errors-1.0 {don't run L code if there were compilation errors} -body {
+#lang L --line=1
+void errors_1_0() {
+	int argc;
+	// we want "this is text" to _not_ print
+	puts("this is text");
+	puts(argc[1]);
+}
+errors_1_0();
+#lang tcl
+} -returnCodes {error} -match glob -result "*:5: L Error: not an array*\n" \
+-output {}
+
+test break-1.0 {breaks break when loop jump instructions grow because the loop body is big} -body {
+#lang L --line=1
+void break_1_0() {
+        int     i;
+
+	for (i = 0; i<10; i++) {
+		printf("${i}");
+		printf("${i}");
+		printf("${i}");
+		printf("${i}");
+		printf("${i}");
+		break;
+	}
+}
+break_1_0();
+#lang tcl
+} -output {00000}
+
+test typedef-1.0 {L redeclaring types is allowed for same types} -body {
+#lang L --line=1
+typedef string typedef_1_0_FOO;
+typedef string typedef_1_0_FOO;
+#lang tcl
+} -output ""
+
+test typedef-1.1 {L redefining types is not allowed} -body {
+#lang L --line=1
+typedef string typedef_1_1_BAR;
+typedef int typedef_1_1_BAR;
+#lang tcl
+} -returnCodes {error} -match glob -result \
+	"*:2: L Error: Cannot redefine type typedef_1_1_BAR*"
+
+test crash-1.1 {crashing in some interim versions} -body {
+#lang L --line=1
+struct c11xy { int x,y; };
+void
+crash_1_1()
+{
+    struct c11xy xys[2];
+    xys[0].x = 1;
+    printf("%s", xys);
+}
+crash_1_1();
+} -output "1"
+
+
+test pattern-1.2 {L widget pattern functions} -body {
+#lang L --line=1
+void pattern_1_2_foo(...args)
+{
+	puts(args);
+}
+
+void pattern_1_2()
+{
+	widget w = "pattern_1_2_foo";
+	Text_insert(w, "end", "FOO");
+}
+pattern_1_2();
+#lang tcl
+} -output "insert end FOO\n"
+
+test empty-stmt {empty stmt crashed in parser} -body {
+#lang L --line=1
+void empty_stmt()
+{
+	printf("Should be OK now.\n");;  // Note the two semicolons.
+}
+#lang tcl
+empty_stmt
+} -output "Should be OK now.\n"
+
+test struct-typedef-1.1 {check struct typedef bug} -body {
+#lang L --line=1
+typedef struct {
+	int x;
+	int y;
+} foo_st_11;
+
+foo_st_11 bars_st_11{string};
+
+void a_st_11(foo_st_11 f)
+{
+	bars_st_11{"FOO"} = f;
+	puts("X = ${f.x}");
+}
+
+void struct_typedef_1_1()
+{
+	foo_st_11 f = {66,63};
+	a_st_11(f);
+	puts(bars_st_11);
+}
+#lang tcl
+struct_typedef_1_1
+} -output "X = 66\nFOO {66 63}\n"
+
+test list-1 {check list creation bug} -body {
+#lang L --line=1
+void list_1()
+{
+	/* This used to trip an assert. */
+	{undeclared_variable};
+}
+list_1();
+} -returnCodes {error} -match regexp -result {.*4: L Error: undeclared variable.*
+}
+
+# cleanup
+::tcltest::cleanupTests
+return

tests/langbench/BEFORE-PERF

@@ -0,0 +1,26 @@
+These are the langbench results from the source base as of early Nov-2007.
+
+lang    cat     grep    hash    loop    proc    fib     sort    wc      
+tcl     2.10    4.10    1.51    0.06    1.27    3.76    5.40    0.97    
+l       2.10    4.21    1.48    0.08    0.51    3.92    5.76    coredump :(
+
+vs now, late Jan-2008
+
+lang    cat     grep    hash    loop    proc    fib     sort    wc      
+tcl     0.81    0.97    1.13    0.05    0.98    3.45    2.85    1.21    
+l       0.82    0.97    1.14    0.05    0.45    3.36    3.11    1.93    
+
+Factor better:
+lang    cat     grep    hash    loop    proc    fib     sort    wc      
+tcl	2.6x	4.2x	1.3x	wash	1.3x	wash	1.9x	.8x (whoops)
+l	2.6x	4.2x	1.3x	wash	wash	1.2x	1.9x	NA
+
+And other languages for comparison:
+lang    cat     grep    hash    loop    proc    fib     sort    wc      
+pl      0.36    0.36    0.61    0.07    0.40    3.68    2.15    1.00    
+py      0.46    1.50    0.48    0.15    0.23    1.27    2.26    0.49    
+rb      0.82    0.73    1.64    0.29    1.13    4.06    4.29    3.09    
+
+Amount slower than perl:
+lang    cat     grep    hash    loop    proc    fib     sort    wc      
+tcl/l	2.3x	2.7x	1.9x	faster	wash	faster	1.4x	1.2x

tests/langbench/BEFORE.pcre

@@ -0,0 +1,8 @@
+langbench version 0.6 results:
+lang    cat     grep    hash    loop    proc    fib     sort    wc      
+tcl     0.54    2.61    0.87    0.05    0.91    2.27    2.38    0.80    
+tcl     0.53    2.59    0.87    0.05    0.92    2.28    2.36    0.79    
+tcl     0.55    2.58    0.87    0.05    0.89    2.32    2.37    0.79    
+l       0.56    1.88    0.84    0.04    0.30    2.14    2.64    1.33    
+l       0.55    1.87    0.86    0.05    0.30    2.14    2.63    1.30    
+l       0.55    1.89    0.85    0.04    0.32    2.15    2.64    1.32    

tests/langbench/ChangeLog

@@ -0,0 +1,10 @@
+0.6
+	- Make the grep expr be [^A-Za-z]fopen\(.*\) since that is not
+	  trivially optimized.
+	- Add fibonacci benchmark.
+	- Make the procedure calls take more arguments.
+	- add a findtclsh so that if you run this in a tcl source tree
+	  under tests/langbench it just works.
+	- Allow setting of each language with RUBY=/build/ruby/ruby
+	  (for testing new versions like the ruby with a byte code
+	  compiler).

tests/langbench/PERF_LOG

@@ -0,0 +1,20 @@
+2.6ghz T61
+
+2008-02-02
+
+lang    cat     grep    hash    loop    proc    fib     sort    wc      
+pl      0.35    0.34    0.62    0.07    0.40    3.65    2.19    1.00    
+py      0.45    1.48    0.49    0.15    0.22    1.21    2.15    0.49    
+rb      0.82    0.73    1.57    0.28    1.12    3.94    4.28    3.10    
+tcl     0.78    0.93    1.11    0.05    0.99    3.54    2.84    1.16    
+l       0.79    0.93    1.13    0.05    0.46    3.42    2.98    1.86    
+
+2008-04-10
+
+lang    cat     grep    hash    loop    proc    fib     sort    wc      
+pl      0.38    0.36    0.64    0.07    0.42    3.90    2.27    1.04    
+py      0.48    1.55    0.51    0.16    0.23    1.26    2.24    0.51    
+rb      0.87    0.76    1.63    0.29    1.18    4.17    4.53    3.23    
+tcl     0.84    1.05    1.19    0.06    1.06    3.75    2.91    1.23    
+l       0.84    1.02    1.22    0.05    0.46    3.66    2.90    1.85    
+

tests/langbench/README

@@ -0,0 +1,56 @@
+langbench is a simplistic set of microbenchmarks designed to see how
+well a scripting language performs at basic operations.  The intent is to
+have a set of tests that encourage each language team to optimize their
+language in a way that would benefit the widest possible set of users.
+The version number of this test suite will be 1.0 when there is widespread
+agreement that these are the "right" set of benchmarks, much like lmbench
+was the "right" set of benchmarks for operating systems.
+
+We (BitKeeper Inc) are using it to benchmark our scripting language, you can
+use it for whatever you like.
+
+You may use for langbench any purpose provided that if you use the
+"langbench" name you report all results for all languages like so:
+
+langbench version 0.5 results:
+lang    cat     grep    hash    loop    proc    sort    split
+pl      0.85    0.85    1.38    0.24    0.68    4.72    5.13    
+py      0.81    2.97    1.03    0.34    0.40    4.37    1.56    
+rb      1.81    1.68    4.18    0.53    1.04    8.00    3.66    
+tcl     2.02    1.45    2.44    0.13    0.72    7.48    3.93    
+l       2.02    1.48    2.43    0.12    0.73    8.11    3.94    
+
+langbench version 0.6 results (faster cpu accounts for some diffs):
+lang    cat     grep    hash    loop    proc    fib     sort    wc
+pl      0.37    0.34    0.62    0.11    0.38    4.35    2.02    1.03    
+py      0.38    1.99    0.46    0.18    0.21    1.08    1.83    0.48    
+rb      0.84    0.81    1.98    0.31    0.59    2.95    3.33    2.33    
+tcl     0.75    2.64    1.09    0.07    0.89    2.65    3.46    0.90    
+l       0.71    2.03    1.14    0.07    0.29    2.49    3.88    1.54    
+
+with the exception that you may leave off the L language until it is
+widely distributed (defined as apt-get install l just works or is 
+included with the tcl package).
+
+Note that for the cat, grep, hash, loop, proc, sort benchmarks the number
+printed is the microseconds for the implied operation, i.e., for cat,
+it is usecs/line, for sort it is the usecs/line to sort and print each
+line, etc.
+
+Test descriptions:
+	cat	copy stdin to stdout
+	grep	match a regular expression against stdin, print each match
+	hash	use each line of stdin as a hash key, value is 1.
+	loop	measure the cost of a loop
+	proc	measure procedure call cost
+	sort	sorts stdin to stdout
+	split	[Not used because the semantics are different across langs]
+
+Input data is a million lines of code generated like this:
+
+	for i in 1 2 3 4 5 6 7 8 9 0
+	do	cat tcl/generic/*.[ch]
+	done | head -1000000 > DATA
+
+This file and tests are at http://www.bitkeeper.com/lm/langbench.shar
+

tests/langbench/RUN

@@ -0,0 +1,58 @@
+test X$LANGBENCH = X && {
+	LANGBENCH=.
+	test -d langbench && LANGBENCH=langbench
+}
+test X$TCLSH = X && {
+	test -x gui/bin/tclsh && TCLSH=gui/bin/tclsh
+	test -x ../gui/bin/tclsh && TCLSH=../gui/bin/tclsh
+}
+test X$TCLSH = X && {
+	echo Please set TCLSH
+	exit 1
+}
+test X$PERL = X && PERL=perl
+test X$PYTHON = X && PYTHON=python
+test X$RUBY = X && RUBY=ruby
+test "X$LANGS" = X && LANGS="pl py rb tcl l"
+test "X$TESTS" = X && TESTS="cat grep hash loop proc fib sort wc"
+export TCL_REGEXP_PCRE=1
+echo "langbench version 0.6 results:"
+echo -n "lang	"
+for i in $TESTS
+do	echo -n "$i	"
+done
+echo ""
+for lang in $LANGS
+do	
+	case $lang in
+	    pl) CMD=$PERL;;
+	    py) CMD=$PYTHON;;
+	    rb) CMD=$RUBY;;
+	    tcl|l) CMD=$TCLSH;;
+	esac
+	N=1
+	test X$RUNS = X || N=$RUNS
+	while (($N > 0)) 
+	do
+		printf "%-8s" $lang
+		for test in $TESTS
+		do	
+			DATA=DATA
+			test $test = wc && DATA=SMALL
+			export LANG_TEST=$test
+			for run in 1 2 3
+			do	time $CMD $LANGBENCH/${test}.${lang} $DATA > /dev/null
+			done 2>&1 |
+			perl -e '$min = 1000000;
+			while (<>) {
+				if (/real.*0m(.*)s/) {
+					$min = $1 if $1 < $min;
+				}
+			}
+			printf "%-8.2f", $min;'
+		done
+		printf "\n"
+		N=`expr $N - 1`
+	done
+done 
+exit 0

tests/langbench/WEIRD

@@ -0,0 +1,9 @@
+If the regexp is ^$ then the python code gets one more match than the others.
+
+python's split gets the word count wrong:
+
+	wc -w:	 3647213 
+	perl:	 3647213
+	ruby:	 3647213
+	tcl:	 3647213
+	python:	 3647250

tests/langbench/cat.l

@@ -0,0 +1,18 @@
+void
+main(int ac, string av[])
+{
+	string	buf;
+	FILE	f;
+	int	i;
+
+	fconfigure("stdout", buffering:"full", translation:"binary");
+	for (i = 1; i < ac; ++i) {
+		unless (f = open(av[i], "rb")) continue;
+		while (gets(f, &buf) >= 0) {
+			// roughly 40% slower than puts
+			// printf("%s\n", buf);
+			puts(buf);
+		}
+		close(f);
+	}
+}

tests/langbench/cat.pl

@@ -0,0 +1,10 @@
+# One could argue this should be
+# while ($foo = <>) { chomp($foo); print $foo . "\n"; }
+# to match what tcl does.
+# That slows it down by a factor of 2.
+foreach $file (@ARGV) {
+	open(FD, $file);
+	while ($buf = <FD>) {
+		print $buf;
+	}
+}

tests/langbench/cat.py

@@ -0,0 +1,16 @@
+#!/usr/bin/python
+import os
+import sys
+   
+def cat(file):
+    f = open(file)
+    for line in f:
+        print line,
+    f.close()
+   
+def main():
+    for a in sys.argv:
+        cat(a)
+   
+if __name__ == "__main__":
+    main()

tests/langbench/cat.rb

@@ -0,0 +1,3 @@
+while line = gets()
+	print line
+end

tests/langbench/cat.tcl

@@ -0,0 +1,9 @@
+proc cat {file} {
+	set f [open $file rb]
+	while {[gets $f buf] >= 0} { puts $buf }
+	close $f
+}
+fconfigure stdout -buffering full -translation binary 
+foreach file $argv {
+	cat $file
+}

tests/langbench/fib.l

@@ -0,0 +1,20 @@
+
+int
+fib(int n)
+{
+	if (n < 2) {
+		return (n);
+	} else {
+		return (fib(n - 1) + fib(n - 2));
+	}
+}
+
+void
+main()
+{
+	int	i;
+
+	for (i = 0; i <= 30; ++i) {
+		printf("n=%d => %d\n", i, fib(i));
+	}
+}

tests/langbench/fib.pl

@@ -0,0 +1,11 @@
+sub fib
+{
+	my($n) = @_[0];
+
+	return $n if $n < 2;
+	return &fib($n - 1) + &fib($n - 2);
+}
+
+for ($i = 0; $i <= 30; ++$i) {
+	printf "n=%d => %d\n", $i, &fib($i);
+}

tests/langbench/fib.py

@@ -0,0 +1,8 @@
+def fib(n):
+   if n < 2:
+      return n
+   else:
+      return fib(n-1) + fib(n-2)
+
+for i in range(30):
+    print "n=%d => %d" % (i, fib(i))

tests/langbench/fib.rb

@@ -0,0 +1,11 @@
+def fib(n)
+    if n < 2
+        n
+    else
+        fib(n-1) + fib(n-2)
+    end
+end
+
+30.times do |i|
+    puts "n=#{i} => #{fib(i)}"
+end

tests/langbench/fib.tcl

@@ -0,0 +1,11 @@
+proc fib {n} {
+	# Very bogus we have to do {$n - 1} to get performance.
+	# But if we don't this takes 35 seconds.  Tcl has issues.
+	expr {$n < 2 ? 1 : [fib [expr {$n -2}]] + [fib [expr {$n -1}]]}
+}
+
+set i 0
+while {$i <= 30} {
+	puts "n=$i => [fib $i]"
+	incr i
+}

tests/langbench/findtcl

@@ -0,0 +1,26 @@
+#!/bin/sh
+
+test X$TCL = X || {
+	echo $TCL
+	exit 0
+}
+
+# If langbench is in the bk source tree, tcl is at ../gui/tcltk/tcl
+test -d ../gui/tcltk/tcl/generic && {
+	echo ../gui/tcltk/tcl
+	exit 0
+}
+
+# If langbench is in the tcl source tree, it is likely at tests/langbench
+# or tests.
+test -d ../tests -a -d ../generic && {
+	echo ..
+	exit 0
+}
+test -d ../../tests -a -d ../../generic && {
+	echo ../..
+	exit 0
+}
+
+echo "Can't find tcl source tree, set a path to one with TCL" 1>&2
+exit 1

tests/langbench/findtclsh

@@ -0,0 +1,35 @@
+#!/bin/sh
+
+test X$TCLSH = X || {
+	echo $TCLSH
+	exit 0
+}
+
+# If langbench is in the bk source tree, tcl is at ../gui/tcltk/tcl
+test -d ../gui/tcltk/tcl/generic && {
+	if [ -d C:/ ]
+	then	echo ../gui/tcltk/tcl/win/tclsh85.exe
+	else	echo ../gui/tcltk/tcl/unix/tclsh
+	fi
+	exit 0
+}
+
+# If langbench is in the tcl source tree, it is likely at tests/langbench
+# or tests.
+test -d ../tests -a -d ../generic && {
+	if [ -d C:/ ]
+	then	echo ../win/tclsh85.exe
+	else	echo ../unix/tclsh
+	fi
+	exit 0
+}
+test -d ../../tests -a -d ../../generic && {
+	if [ -d C:/ ]
+	then	echo ../../win/tclsh85.exe
+	else	echo ../../unix/tclsh
+	fi
+	exit 0
+}
+
+echo "Can't find tclsh, set a path to one with TCLSH" 1>&2
+exit 1

tests/langbench/grep.l

@@ -0,0 +1,15 @@
+void
+main(int ac, string av[])
+{
+	string	buf;
+	int	i;
+	FILE	f;
+
+	for (i = 1; i < ac; ++i) {
+		f = open(av[i], "rb");
+		while (gets(f, &buf) >= 0) {
+			if (buf =~ /[^A-Za-z]fopen\(.*\)/) puts(buf);
+		}
+		close(f);
+	}
+}

tests/langbench/grep.pl

@@ -0,0 +1,3 @@
+while (<>) {
+	print if /[^A-Za-z]fopen\(.*\)/;
+}

tests/langbench/grep.py

@@ -0,0 +1,12 @@
+import os
+import sys
+import re
+
+p = re.compile('[^A-Za-z]fopen\(.*\)')
+for a in sys.argv:
+	f = open(a)
+	for line in f:
+		m = p.search(line)
+		if m:
+			print line,
+	f.close()

tests/langbench/grep.rb

@@ -0,0 +1,4 @@
+re = Regexp.compile("[^A-Za-z]fopen\\(.*\\)")
+while line = gets()
+	print if re =~ line
+end

tests/langbench/grep.tcl

@@ -0,0 +1,12 @@
+proc grep {file} {
+	set f [open $file rb]
+	set buf ""
+	while {[gets $f buf] >= 0} {
+		if {[regexp -- {[^A-Za-z]fopen\(.*\)} $buf]} { puts $buf }
+	}
+	close $f
+}
+fconfigure stdout -translation binary 
+foreach file $argv {
+	grep $file
+}

tests/langbench/hash.l

@@ -0,0 +1,17 @@
+void
+main(int ac, string av[])
+{
+	int	i;
+	string	buf;
+	hash	h;
+	FILE	f;
+
+
+	for (i = 1; i < ac; ++i) {
+		f = open(av[i], "rb");
+		while (gets(f, &buf) >= 0) {
+			h{buf} = 1;
+		}
+		close(f);
+	}
+}

tests/langbench/hash.pl

@@ -0,0 +1,5 @@
+while (<>) {
+	$hash{$_} = 1;
+}
+open(FD, "/proc/$$/status");
+while (<FD>) { print if /^Vm[RD]/; }

tests/langbench/hash.py

@@ -0,0 +1,16 @@
+import os
+import sys
+import re
+
+d = {}
+for a in sys.argv:
+	f = open(a)
+	for line in f:
+		d[line] = 1
+	f.close
+p = re.compile("^Vm[RD]")
+f = open("/proc/%d/status" % os.getpid())
+for line in f:
+	m = p.match(line)
+	if m:
+		print line,

tests/langbench/hash.rb

@@ -0,0 +1,10 @@
+hash = {}
+while line = gets()
+        hash[line] = 1
+end
+   
+fd = File.open("/proc/#{$$}/status")
+while $_ = fd.gets
+        print if $_ =~ /^Vm[RD]/
+end
+fd.close

tests/langbench/hash.tcl

@@ -0,0 +1,17 @@
+proc main {} {
+	global	argv
+
+	set d [dict create]
+	foreach file $argv {
+		set f [open $file rb]
+		while {[gets $f buf] >= 0} {
+			dict set d $buf 1
+		}
+		close $f
+	}
+}
+main
+set f [open "/proc/[pid]/status"]
+while {[gets $f buf] >= 0} {
+	if {[regexp {^Vm[RD]} $buf]} { puts $buf }
+}

tests/langbench/loop.l

@@ -0,0 +1,11 @@
+void
+doit(int n)
+{
+	while (n-- > 0);
+}
+
+void
+main()
+{
+	doit(1000000);
+}

tests/langbench/loop.pl

@@ -0,0 +1,2 @@
+$n = 1000000;
+while ($n > 0) { $n--; }

tests/langbench/loop.py

@@ -0,0 +1,3 @@
+n = 1000000
+while n > 0:
+	n = n - 1

tests/langbench/loop.rb

@@ -0,0 +1,4 @@
+n = 1000000
+while n > 0
+	n -= 1
+end