Mac-build provoked warning fixes.

git-svn-id: svn://10.0.0.236/branches/JS2_DIKDIK_BRANCH@100423 18797224-902f-48f8-a5cc-f745e15eee43

mozilla/build/mac/IDE_Options.h

@@ -1,132 +0,0 @@
-/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 2 -*- */
-/* ***** BEGIN LICENSE BLOCK *****
- * Version: NPL 1.1/GPL 2.0/LGPL 2.1
- *
- * The contents of this file are subject to the Netscape Public License
- * Version 1.1 (the "License"); you may not use this file except in
- * compliance with the License. You may obtain a copy of the License at
- * http://www.mozilla.org/NPL/
- *
- * Software distributed under the License is distributed on an "AS IS" basis,
- * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
- * for the specific language governing rights and limitations under the
- * License.
- *
- * The Original Code is mozilla.org code.
- *
- * The Initial Developer of the Original Code is 
- * Netscape Communications Corporation.
- * Portions created by the Initial Developer are Copyright (C) 1998
- * the Initial Developer. All Rights Reserved.
- *
- * Contributor(s):
- *
- *
- * Alternatively, the contents of this file may be used under the terms of
- * either the GNU General Public License Version 2 or later (the "GPL"), or
- * the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
- * in which case the provisions of the GPL or the LGPL are applicable instead
- * of those above. If you wish to allow use of your version of this file only
- * under the terms of either the GPL or the LGPL, and not to allow others to
- * use your version of this file under the terms of the NPL, indicate your
- * decision by deleting the provisions above and replace them with the notice
- * and other provisions required by the GPL or the LGPL. If you do not delete
- * the provisions above, a recipient may use your version of this file under
- * the terms of any one of the NPL, the GPL or the LGPL.
- *
- * ***** END LICENSE BLOCK ***** */
-/*
-
-	This file overrides all option settings in the IDE.  It is an attempt to allow all builds
-	to have the same options.
-
-	Note: We can't use ConditionalMacros.h in this file because it will conflict with 
-	the PowerPlant precompiled headers.
-
-*/
-
-	/* warning pragmas */
-#pragma warn_hidevirtual 		on
-#pragma warn_emptydecl 			on
-#pragma warn_unusedvar 			on
-#pragma warn_extracomma 		on
-#pragma warn_illpragma 			on
-#pragma warn_possunwant 		on
-#pragma warn_unusedarg 			off		/* turned off to reduce warnings */
-
-#pragma check_header_flags 		on
-
-	/* Language features that must be the same across libraries... */
-#pragma enumsalwaysint			on
-#pragma unsigned_char			off
-#pragma exceptions				on
-#pragma bool 					on
-#pragma wchar_type              on
-#pragma RTTI                    on
-
-
-	/* Save as much space as possible with strings... */
-#pragma pool_strings				on
-#pragma dont_reuse_strings			off
-
-#pragma options align=native
-#pragma sym 						on				/* Takes no memory.  OK in non-debug. */
-
-
-
-#ifdef powerc /* ...generating PowerPC */
-	#pragma toc_data 				on
-	#pragma fp_contract 			on
-	#pragma readonly_strings 		on
-
-	#ifdef DEBUG
-		#pragma profile 		off							/* Turn this on to profile the application. */
-																				/* Look for more details about profiling in nsMacMessagePump.cpp.  */
-		#pragma traceback 			on
-		#pragma global_optimizer 	off
-		#pragma scheduling 			off
-		#pragma peephole 			off
-		#pragma optimize_for_size 	off
-	#else
-		
-		#if TARGET_CARBON
-			#pragma traceback		on					/* should always be ON for Carbon builds */
-		#else
-			#pragma traceback		off					/* leave on until the final release, so MacsBug logs are interpretable */
-		#endif
-		
-		#pragma global_optimizer 	on
-		#pragma optimization_level 	4
-		#pragma scheduling 			603
-		#pragma peephole 			on
-		#pragma optimize_for_size	on
-
-    #pragma opt_strength_reduction on
-    #pragma opt_propagation on
-    #pragma opt_loop_invariants on
-    #pragma opt_lifetimes on
-    #pragma opt_dead_code on
-    #pragma opt_dead_assignments on
-    #pragma opt_common_subs on
-	#endif
-
-#else /* ...generating 68k */
-	#pragma code68020 			on
-	#pragma code68881 			off
-
-		/* Far everything... */
-	#pragma far_code
-	#pragma far_data 			on
-	#pragma far_strings 		on
-	#pragma far_vtables 		on
-
-	#pragma fourbyteints		on	/* 4-byte ints */
-	#pragma IEEEdoubles			on	/* 8-byte doubles (as required by Java and NSPR) */
-
-	#ifdef DEBUG
-		#pragma macsbug 		on
-		#pragma oldstyle_symbols off
-	#else
-		#pragma macsbug 		off
-	#endif
-#endif

mozilla/build/mac/MANIFEST

@@ -1,5 +0,0 @@
-#
-# This is a list of local files which get copied to the mozilla:dist directory
-#
-
-IDE_Options.h

mozilla/build/mac/NSCrossProductDefines.h

@@ -1,59 +0,0 @@
-/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 2 -*- */
-/* ***** BEGIN LICENSE BLOCK *****
- * Version: NPL 1.1/GPL 2.0/LGPL 2.1
- *
- * The contents of this file are subject to the Netscape Public License
- * Version 1.1 (the "License"); you may not use this file except in
- * compliance with the License. You may obtain a copy of the License at
- * http://www.mozilla.org/NPL/
- *
- * Software distributed under the License is distributed on an "AS IS" basis,
- * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
- * for the specific language governing rights and limitations under the
- * License.
- *
- * The Original Code is mozilla.org code.
- *
- * The Initial Developer of the Original Code is 
- * Netscape Communications Corporation.
- * Portions created by the Initial Developer are Copyright (C) 1998
- * the Initial Developer. All Rights Reserved.
- *
- * Contributor(s):
- *
- *
- * Alternatively, the contents of this file may be used under the terms of
- * either the GNU General Public License Version 2 or later (the "GPL"), or
- * the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
- * in which case the provisions of the GPL or the LGPL are applicable instead
- * of those above. If you wish to allow use of your version of this file only
- * under the terms of either the GPL or the LGPL, and not to allow others to
- * use your version of this file under the terms of the NPL, indicate your
- * decision by deleting the provisions above and replace them with the notice
- * and other provisions required by the GPL or the LGPL. If you do not delete
- * the provisions above, a recipient may use your version of this file under
- * the terms of any one of the NPL, the GPL or the LGPL.
- *
- * ***** END LICENSE BLOCK ***** */
-
-#error "DonÕt use me!"
-
-#define OLDROUTINELOCATIONS 0
-#define XP_MAC 1
-#define NSPR20 1
-#define _NO_FAST_STRING_INLINES_ 1
-#define HAVE_BOOLEAN 1
-#define NETSCAPE 1
-#define OTUNIXERRORS 1		/* We want OpenTransport error codes */
-
-#define OJI 1
-
-/*
-	This compiles in heap dumping utilities and other good stuff
- for developers -- maybe we only want it in for a special SDK
- nspr/java runtime(?):
-*/
-#define DEVELOPER_DEBUG 1
-
-#define	MAX(_a,_b)	((_a) < (_b) ? (_b) : (_a))
-#define	MIN(_a,_b)	((_a) < (_b) ? (_a) : (_b))

mozilla/build/mac/build_scripts/BuildMozilla.pl

@@ -1,80 +0,0 @@
-#!perl
-
-#
-# The contents of this file are subject to the Netscape Public
-# License Version 1.1 (the "License"); you may not use this file
-# except in compliance with the License. You may obtain a copy of
-# the License at http://www.mozilla.org/NPL/
-#
-# Software distributed under the License is distributed on an "AS
-# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
-# implied. See the License for the specific language governing
-# rights and limitations under the License.
-#
-# The Original Code is mozilla.org code.
-#
-# The Initial Developer of the Original Code is Netscape
-# Communications Corporation.  Portions created by Netscape are
-# Copyright (C) 1998 Netscape Communications Corporation. All
-# Rights Reserved.
-#
-# Contributor(s): 
-#   Simon Fraser <sfraser@netscape.com>
-#
-
-require 5.004;
-
-use strict;
-
-use Cwd;
-use Moz::BuildUtils;
-use Moz::BuildCore;
-
-#-------------------------------------------------------------
-# Where have the build options gone?
-# 
-# The various build flags have been centralized into one place. 
-# The master list of options is in MozBuildFlags.txt. However, 
-# you should never need to edit that file, or this one.
-# 
-# To customize what gets built, or where to start the build, 
-# edit the $prefs_file_name file in
-# System Folder:Preferences:Mozilla build prefs:
-# Documentation is provided in that file.
-#-------------------------------------------------------------
-
-my($prefs_file_name) = "Mozilla opt build prefs";
-my($config_header_file_name) = ":mozilla:config:mac:DefinesOptions.h";
-
-#-------------------------------------------------------------
-# hashes to hold build options
-#-------------------------------------------------------------
-my(%build);
-my(%options);
-my(%filepaths);
-my(%optiondefines);
-
-# Hash of input files for this build. Eventually, there will be
-# input files for manifests, and projects too.
-my(%inputfiles) = (
-  "buildflags",     "MozillaBuildFlags.txt",
-  "checkoutdata",   "MozillaCheckoutList.txt",
-  "buildprogress",  "¥ Mozilla opt progress",
-  "buildmodule",    "MozillaBuildList.pm",
-  "checkouttime",   "Mozilla last checkout"
-);
-#-------------------------------------------------------------
-# end build hashes
-#-------------------------------------------------------------
-
-# set the build root directory, which is the the dir above mozilla
-SetupBuildRootDir(":mozilla:build:mac:build_scripts");
-
-# Set up all the flags on $main::, like DEBUG, CARBON etc.
-# Override the defaults using the preferences files.
-SetupDefaultBuildOptions(0, ":mozilla:dist:viewer:", $config_header_file_name);
-
-my($do_checkout)    = 0;
-my($do_build)       = 1;
-
-RunBuild($do_checkout, $do_build, \%inputfiles, $prefs_file_name);

mozilla/build/mac/build_scripts/BuildMozillaDebug.pl

@@ -1,80 +0,0 @@
-#!perl
-
-#
-# The contents of this file are subject to the Netscape Public
-# License Version 1.1 (the "License"); you may not use this file
-# except in compliance with the License. You may obtain a copy of
-# the License at http://www.mozilla.org/NPL/
-#
-# Software distributed under the License is distributed on an "AS
-# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
-# implied. See the License for the specific language governing
-# rights and limitations under the License.
-#
-# The Original Code is mozilla.org code.
-#
-# The Initial Developer of the Original Code is Netscape
-# Communications Corporation.  Portions created by Netscape are
-# Copyright (C) 1998 Netscape Communications Corporation. All
-# Rights Reserved.
-#
-# Contributor(s): 
-#   Simon Fraser <sfraser@netscape.com>
-#
-
-require 5.004;
-
-use strict;
-
-use Cwd;
-use Moz::BuildUtils;
-use Moz::BuildCore;
-
-#-------------------------------------------------------------
-# Where have the build options gone?
-# 
-# The various build flags have been centralized into one place. 
-# The master list of options is in MozBuildFlags.txt. However, 
-# you should never need to edit that file, or this one.
-# 
-# To customize what gets built, or where to start the build, 
-# edit the $prefs_file_name file in
-# System Folder:Preferences:Mozilla build prefs:
-# Documentation is provided in that file.
-#-------------------------------------------------------------
-
-my($prefs_file_name) = "Mozilla debug build prefs";
-my($config_header_file_name) = ":mozilla:config:mac:DefinesOptionsDebug.h";
-
-#-------------------------------------------------------------
-# hashes to hold build options
-#-------------------------------------------------------------
-my(%build);
-my(%options);
-my(%filepaths);
-my(%optiondefines);
-
-# Hash of input files for this build. Eventually, there will be
-# input files for manifests, and projects too.
-my(%inputfiles) = (
-  "buildflags",     "MozillaBuildFlags.txt",
-  "checkoutdata",   "MozillaCheckoutList.txt",
-  "buildprogress",  "¥ Mozilla debug progress",
-  "buildmodule",    "MozillaBuildList.pm",
-  "checkouttime",   "Mozilla last checkout"
-);
-#-------------------------------------------------------------
-# end build hashes
-#-------------------------------------------------------------
-
-# set the build root directory, which is the the dir above mozilla
-SetupBuildRootDir(":mozilla:build:mac:build_scripts");
-
-# Set up all the flags on $main::, like DEBUG, CARBON etc.
-# Override the defaults using the preferences files.
-SetupDefaultBuildOptions(1, ":mozilla:dist:viewer_debug:", $config_header_file_name);
-
-my($do_pull)        = 0;    # overridden by flags and prefs
-my($do_build)       = 1;
-
-RunBuild($do_pull, $do_build, \%inputfiles, $prefs_file_name);

mozilla/build/mac/build_scripts/Moz/BuildCore.pm

@@ -1,595 +0,0 @@
-#!perl -w
-package Moz::BuildCore;
-
-require 5.004;
-require Exporter;
-
-use strict;
-use vars qw( @ISA @EXPORT );
-
-# perl includes
-use Cwd;
-use POSIX;
-use Time::Local;
-use File::Basename;
-use LWP::Simple;
-
-# homegrown
-use Moz::Moz;
-use Moz::Jar;
-use Moz::BuildFlags;
-use Moz::BuildUtils;
-use Moz::CodeWarriorLib;
-
-# use MozillaBuildList;   # eventually, this should go away, and be replaced by data input
-
-
-@ISA        = qw(Exporter);
-@EXPORT     = qw(
-                    RunBuild
-                );
-
-
-#//--------------------------------------------------------------------------------------------------
-#// DoPrebuildCheck
-#//
-#// Check the build tools etc before running the build.
-#//--------------------------------------------------------------------------------------------------
-sub DoPrebuildCheck()
-{
-    SanityCheckBuildOptions();
-
-    # launch codewarrior and persist its location. Have to call this before first
-    # call to getCodeWarriorPath().
-    my($ide_path_file) = $main::filepaths{"idepath"};
-    $ide_path_file = full_path_to($ide_path_file);
-    LaunchCodeWarrior($ide_path_file);
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// SanityCheckBuildOptions
-#//--------------------------------------------------------------------------------------------------
-sub SanityCheckBuildOptions()
-{
-    my($bad_options) = 0;
-
-    # Jar options
-    if (!$main::options{chrome_jars} && !$main::options{chrome_files})
-    {
-        print "Warning: Both \$options{chrome_jars} and \$options{chrome_files} are off. You won't get any chrome.\n";
-        $bad_options = 1;
-    }
-
-    if (!$main::options{chrome_jars} && $main::options{use_jars})
-    {
-        print "Warning: \$options{chrome_jars} is off but \$options{use_jars} is on. Your build won't run (expects jars, got files).\n";
-        $bad_options = 1;
-    }
-
-    if (!$main::options{chrome_files} && !$main::options{use_jars})
-    {
-        print "Warning: \$options{chrome_jars} is off but \$options{chrome_files} is on. Your build won't run (expects files, got jars).\n";
-        $bad_options = 1;
-    }
-
-    if ($main::options{ldap_experimental} && !$main::options{ldap})
-    {
-        print "Warning: \$options{ldap_experimental} is on but \$options{ldap} is off. LDAP experimental features will not be built.\n";
-        $bad_options = 1;
-    }
-
-    if ($main::options{wsp} && !$main::options{xmlextras})
-    {
-        print "Warning: \$options{wsp} is on but \$options{xmlextras} is off. wsp will not be built.\n";
-        $bad_options = 1;
-    }
-
-    if ($bad_options) {
-        print "Build will start in 5 seconds. Press command-. to stop\n";
-        
-        DelayFor(5);
-    }
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// GenBuildSystemInfo
-#//--------------------------------------------------------------------------------------------------
-
-sub GenBuildSystemInfo()
-{
-    # always rebuild the configuration program.
-    BuildProjectClean(":mozilla:build:mac:tools:BuildSystemInfo:BuildSystemInfo.mcp", "BuildSystemInfo");
-
-    # delete the configuration file.
-    unlink(":mozilla:build:mac:BuildSystemInfo.pm");
-    
-    # run the program.
-    system(":mozilla:build:mac:BuildSystemInfo");
-
-    # wait for the file to be created.
-    while (!(-e ":mozilla:build:mac:BuildSystemInfo.pm")) { WaitNextEvent(); }
-    
-    # wait for BuildSystemInfo to finish, so that we see correct results.
-    while (IsProcessRunning("BuildSystemInfo")) { WaitNextEvent(); }
-
-    # now, evaluate the contents of the file.
-    open(F, ":mozilla:build:mac:BuildSystemInfo.pm");
-    while (<F>) { eval; }
-    close(F);
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// Make library aliases
-#//--------------------------------------------------------------------------------------------------
-
-sub MakeLibAliases()
-{
-    my($dist_dir) = GetBinDirectory();
-
-    #// ProfilerLib
-    if ($main::PROFILE)
-    {
-        my($profilerlibpath) = Moz::CodeWarriorLib::getCodeWarriorPath("MacOS Support:Profiler:Profiler Common:ProfilerLib");
-        MakeAlias("$profilerlibpath", "$dist_dir"."Essential Files:");
-    }
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// ConfigureBuildSystem
-#//
-#// defines some build-system configuration variables.
-#//--------------------------------------------------------------------------------------------------
-sub ConfigureBuildSystem()
-{
-    #// In the future, we may want to do configurations based on the actual build system itself.
-    #// GenBuildSystemInfo();
-        
-    #// For now, if we discover a newer header file than existed in Universal Interfaces 3.2,
-    #// we'll assume that 3.3 or later is in use.
-    my($universal_interfaces) = Moz::CodeWarriorLib::getCodeWarriorPath("MacOS Support:Universal:Interfaces:CIncludes:");
-    if (-e ($universal_interfaces . "ControlDefinitions.h")) {
-        $main::UNIVERSAL_INTERFACES_VERSION = 0x0330;
-    }
-
-    #// Rename IC SDK folder in the Mac OS Support folder
-    my($ic_sdk_folder) = Moz::CodeWarriorLib::getCodeWarriorPath("MacOS Support:ICProgKit2.0.2");
-    if( -e $ic_sdk_folder)
-    {
-        my($new_ic_folder_name) = Moz::CodeWarriorLib::getCodeWarriorPath("MacOS Support:(ICProgKit2.0.2)");
-        rename ($ic_sdk_folder, $new_ic_folder_name);
-        # note that CodeWarrior doesn't descend into folders with () the name
-        print "Mozilla no longer needs the Internet Config SDK to build:\n  Renaming the 'ICProgKit2.0.2' folder to '(ICProgKit2.0.2)'\n";
-    }
-
-    printf("UNIVERSAL_INTERFACES_VERSION = 0x%04X\n", $main::UNIVERSAL_INTERFACES_VERSION);
-
-    # alias required CodeWarrior libs into the Essential Files folder (only the Profiler lib now)
-    MakeLibAliases();
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// CheckOutModule. Takes variable number of args; first two are required
-#//--------------------------------------------------------------------------------------------------
-sub CheckOutModule($$$$)
-{
-    my($session, $module, $revision, $date) = @_;
-
-    my($result) = $session->checkout($module, $revision, $date);
-    
-    # result of 1 is success
-    if ($result) { return; }
-    
-    my($checkout_err) = $session->getLastError();
-    if ($checkout_err == 708) {
-        die "Error: Checkout was cancelled.\n";
-    } elsif ($checkout_err == 911) {
-        die "Error: CVS session settings are incorrect. Check your password, and the CVS root settings.\n";
-    } elsif ($checkout_err == 703) {
-        die "Error: CVS checkout failed. Unknown module, unknown tag, bad username, or other CVS error.\n";
-    } elsif ($checkout_err == 711) {
-        print "Checkout of '$module' failed.\n";
-    }
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// getScriptFolder
-#//--------------------------------------------------------------------------------------------------
-sub getScriptFolder()
-{
-    return dirname($0);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// getScriptFolder
-#//--------------------------------------------------------------------------------------------------
-sub get_url_contents($)
-{
-    my($url) = @_;
-
-    my($url_contents) = LWP::Simple::get($url);
-    $url_contents =~ s/\r\n/\n/g;     # normalize linebreaks
-    $url_contents =~ s/\r/\n/g;       # normalize linebreaks
-    return $url_contents;
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// get_files_from_content
-#//--------------------------------------------------------------------------------------------------
-sub uniq
-{
-    my $lastval;
-    grep(($_ ne $lastval, $lastval = $_)[$[], @_);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// get_files_from_content
-#//--------------------------------------------------------------------------------------------------
-sub get_files_from_content($)
-{
-    my($content) = @_;
-  
-    my(@jscalls) = grep (/return js_file_menu[^{]*/, split(/\n/, $content));
-    my $i;
-  
-    for ($i = 0; $i < @jscalls ; $i++)
-    {
-        $jscalls[$i] =~ s/.*\(|\).*//g;
-        my(@callparams) = split(/,/, $jscalls[$i]);
-        my ($repos, $dir, $file, $rev) = grep(s/['\s]//g, @callparams);
-        $jscalls[$i] = "$dir/$file";
-    }
-
-  &uniq(sort(@jscalls));
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// getLastUpdateTime
-#// 
-#// Get the last time we updated. Return 0 on failure
-#//--------------------------------------------------------------------------------------------------
-sub getLastUpdateTime($)
-{
-    my($timestamp_file) = @_;
- 
-    my($time_string);
-    
-    local(*TIMESTAMP_FILE);  
-    unless (open(TIMESTAMP_FILE, "< $timestamp_file")) { return 0; }
-
-    while (<TIMESTAMP_FILE>)
-    {
-        my($line) = $_;
-        chomp($line);
-
-        # ignore comments and empty lines
-        if ($line =~ /^\#/ || $line =~ /^\s*$/) {
-            next;
-        }
-        
-        $time_string = $line;
-    }
-
-    # get the epoch seconds
-    my($last_update_secs) = $time_string;
-    $last_update_secs =~ s/\s#.+$//;
-    
-    print "FAST_UPDATE found that you last updated at ".localtime($last_update_secs)."\n";
-    
-    # how long ago was this, in hours?
-    my($gm_now) = time();
-    my($update_hours) = 1 + ceil(($gm_now - $last_update_secs) / (60 * 60));
-    
-    return $update_hours;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// saveCheckoutTimestamp
-#// 
-#// Create a file on disk containing the current time. Param is time(), which is an Epoch seconds
-#// (and therefore in GMT).
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub saveCheckoutTimestamp($$)
-{
-    my($gm_secs, $timestamp_file) = @_;
-        
-    local(*TIMESTAMP_FILE);
-    open(TIMESTAMP_FILE, ">$timestamp_file") || die "Failed to open $timestamp_file\n";
-    print(TIMESTAMP_FILE "# time of last checkout or update, in GMT. Used by FAST_UPDATE\n");
-    print(TIMESTAMP_FILE "$gm_secs \# around ".localtime()." local time\n");
-    close(TIMESTAMP_FILE);
-
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// FastUpdate
-#// 
-#// Use Bonsai url data to update only those dirs which have new files
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub FastUpdate($$)
-{
-    my($modules, $timestamp_file) = @_;          # list of modules to check out
-
-    my($num_hours) = getLastUpdateTime($timestamp_file);
-    if ($num_hours == 0 || $num_hours > 170) {
-        print "Can't fast_update; last update was too long ago, or never. Doing normal checkout.\n";
-        return 0;
-    }
-
-    print "Doing fast update, pulling files changed in the last $num_hours hours\n";
-
-    my($cvsfile) = AskAndPersistFile($main::filepaths{"sessionpath"});
-    my($session) = Moz::MacCVS->new( $cvsfile );
-    unless (defined($session)) { die "Error: Checkout aborted. Cannot create session file: $session" }
-
-    # activate MacCVS
-    ActivateApplication('Mcvs');
-    
-    my($checkout_start_time) = time();
-
-    #print "Time now is $checkout_start_time ($checkout_start_time + 0)\n";
-    
-    my($this_co);
-    foreach $this_co (@$modules)
-    {
-        my($module, $revision, $date) = ($this_co->[0], $this_co->[1], $this_co->[2]);        
-        
-        # assume that things pulled by date wont change
-        if ($date ne "") {
-            print "$module is pulled by date, so ignoring in FastUpdate.\n";
-            next;
-        }
-
-        my($search_type) = "hours";
-        my($min_date) = "";
-        my($max_date) = "";
-        my($url) = "http://bonsai.mozilla.org/cvsquery.cgi?treeid=default&module=${module}&branch=${revision}&branchtype=match&dir=&file=&filetype=match&who=&whotype=match&sortby=Date&hours=${num_hours}&date=${search_type}&mindate=${min_date}&maxdate=${max_date}&cvsroot=%2Fcvsroot";
-
-        if ($revision eq "") {
-            print "Getting list of checkins to $module from Bonsai...\n";
-        } else {
-            print "Getting list of checkins to $module on branch $revision from Bonsai...\n";
-        }
-        my(@files) = &get_files_from_content(&get_url_contents($url));
-
-        if ($#files > 0)
-        {
-           my(@cvs_co_list);
-        
-           my($co_file);
-           foreach $co_file (@files)
-           {
-               print "Updating $co_file\n";
-               push(@cvs_co_list, $co_file);
-           }
-
-            my($result) = $session->update($revision, \@cvs_co_list);
-            # result of 1 is success
-            if (!$result) { die "Error: Fast update failed\n"; }
-        } else {
-            print "No files in this module changed\n";        
-        }
-    }
-    
-    saveCheckoutTimestamp($checkout_start_time, $timestamp_file);
-    return 1;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// Checkout
-#//--------------------------------------------------------------------------------------------------
-sub CheckoutModules($$$)
-{
-    my($modules, $pull_date, $timestamp_file) = @_;          # list of modules to check out
-
-    my($start_time) = TimeStart();
-
-#    assertRightDirectory();
-    my($cvsfile) = AskAndPersistFile($main::filepaths{"sessionpath"});
-    my($session) = Moz::MacCVS->new( $cvsfile );
-    unless (defined($session)) { die "Error: Checkout aborted. Cannot create session file: $session" }
-
-    my($checkout_start_time) = time();
-    
-    # activate MacCVS
-    ActivateApplication('Mcvs');
-
-    my($this_co);
-    foreach $this_co (@$modules)
-    {
-        my($module, $revision, $date) = ($this_co->[0], $this_co->[1], $this_co->[2]);
-        if ($date eq "") {
-            $date = $pull_date;
-        }
-        CheckOutModule($session, $module, $revision, $date);
-        # print "Checking out $module with ref $revision, date $date\n";
-    }
-
-    saveCheckoutTimestamp($checkout_start_time, $timestamp_file);
-    TimeEnd($start_time, "Checkout");
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// ReadCheckoutModulesFile
-#//--------------------------------------------------------------------------------------------------
-sub ReadCheckoutModulesFile($$)
-{
-    my($modules_file, $co_list) = @_;
-
-    my($checkout_file) = getScriptFolder().":".$modules_file;
-    local(*CHECKOUT_FILE);  
-    open(CHECKOUT_FILE, "< $checkout_file") || die "Error: failed to open checkout list $checkout_file\n";
-    while (<CHECKOUT_FILE>)
-    {
-        my($line) = $_;
-        chomp($line);
-    
-        # ignore comments and empty lines
-        if ($line =~ /^\#/ || $line =~ /^\s*$/) {
-            next;
-        }
-    
-        my(@cvs_co) = ["", "", ""];
-        
-        my($module, $revision, $date) = (0, 1, 2);
-        
-        if ($line =~ /\s*([^#,\s]+)\s*\,\s*([^#,\s]+)\s*\,\s*([^#]+)/)
-        {
-            @cvs_co[$module] = $1;
-            @cvs_co[$revision] = $2;
-            @cvs_co[$date] = $3;
-        }
-        elsif ($line =~ /\s*([^#,\s]+)\s*\,\s*([^#,\s]+)\s*(#.+)?/)
-        {
-            @cvs_co[$module] = $1;
-            @cvs_co[$revision] = $2;
-        }
-        elsif ($line =~ /\s*([^#,\s]+)\s*\,\s*,\s*([^#,]+)/)       
-        {
-            @cvs_co[$module] = $1;
-            @cvs_co[$date] = $2;
-        }
-        elsif ($line =~ /\s*([^#,\s]+)/)
-        {
-            @cvs_co[$module] = $1;
-        }
-        else
-        {
-            die "Error: unrecognized line '$line' in $modules_file\n";
-        }
-        
-        # strip surrounding space from date
-        @cvs_co[$date] =~ s/^\s*|\s*$//g;
-        
-        # print "Going to check out '@cvs_co[$module]', '@cvs_co[$revision]', '@cvs_co[$date]'\n";
-        push(@$co_list, \@cvs_co);
-    }
-
-    close(CHECKOUT_FILE);
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// PullFromCVS
-#//--------------------------------------------------------------------------------------------------
-sub PullFromCVS($$)
-{
-    unless ( $main::build{pull} ) { return; }
-    
-    my($modules_file, $timestamp_file) = @_;
-
-    StartBuildModule("pull");
-    
-    my(@cvs_co_list);
-    ReadCheckoutModulesFile($modules_file, \@cvs_co_list);
-
-    if ($main::FAST_UPDATE && $main::options{pull_by_date})
-    {
-        die "Error: you can't use FAST_UPDATE if you are pulling by date.\n";
-    }
-
-    my($did_fast_update) = $main::FAST_UPDATE && FastUpdate(\@cvs_co_list, $timestamp_file);
-    if (!$did_fast_update)
-    {
-        my($pull_date) = "";
-        if ($main::options{pull_by_date})
-        {
-            # acceptable CVS date formats are (in local time):
-            # ISO8601 (e.g. "1972-09-24 20:05") and Internet (e.g. "24 Sep 1972 20:05").
-            # Perl's localtime() string format also seems to work.
-            $pull_date = localtime().""; # force string interp.
-            print "Pulling by date $pull_date\n";
-        }
-
-        CheckoutModules(\@cvs_co_list, $pull_date, $timestamp_file);
-    }
-
-    EndBuildModule("pull");
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// RunBuild
-#//--------------------------------------------------------------------------------------------------
-sub RunBuild($$$$)
-{
-    my($do_pull, $do_build, $input_files, $build_prefs) = @_;
-
-    InitBuildProgress($input_files->{"buildprogress"});
-    
-    # if we are pulling, we probably want to do a full build, so clear the build progress
-    if ($do_pull) {
-        ClearBuildProgress();    
-    }
-    
-    # read local prefs, and the build progress file, and set flags to say what to build
-    SetupBuildParams(\%main::build,
-                     \%main::options,
-                     \%main::optiondefines,
-                     \%main::filepaths,
-                     $input_files->{"buildflags"},
-                     $build_prefs);
-    
-    # If we were told to pull, make sure we do, overriding prefs etc.
-    if ($do_pull)
-    {
-        $main::build{"pull"} = 1;
-    }
-    
-    # transfer this flag
-    $CodeWarriorLib::CLOSE_PROJECTS_FIRST = $main::CLOSE_PROJECTS_FIRST;
-    
-    # setup the build log
-    SetupBuildLog($main::filepaths{"buildlogfilepath"}, $main::USE_TIMESTAMPED_LOGS);
-    StopForErrors();
-    
-    if ($main::LOG_TO_FILE) {
-        RedirectOutputToFile($main::filepaths{"scriptlogfilepath"});
-    }
-        
-    # run a pre-build check to see that the tools etc are in order
-    DoPrebuildCheck();
-    
-    # do the pull
-    PullFromCVS($input_files->{"checkoutdata"}, $input_files->{"checkouttime"});
-    
-    unless ($do_build) { return; }
-
-    my($build_start) = TimeStart();
-
-    # check the build environment
-    ConfigureBuildSystem();
-
-    # here we load and call methods in the build module indirectly.
-    # we have to use indirection because the build module can be named
-    # differently for different builds.
-    chdir(dirname($0));     # change to the script dir
-    my($build_module) = $input_files->{"buildmodule"};
-    # load the build module
-    require $build_module;
-    {   # scope for no strict 'refs'
-        no strict 'refs';
-        
-        my($package_name) = $build_module;
-        $package_name =~ s/\.pm$//;
-        
-        chdir($main::MOZ_SRC);
-        &{$package_name."::BuildDist"}();
-        
-        chdir($main::MOZ_SRC);
-        &{$package_name."::BuildProjects"}();
-    }
-    
-    # the build finished, so clear the build progress state
-    ClearBuildProgress();
-    
-    TimeEnd($build_start, "Build");
-    print "Build complete\n";
-}
-
-1;

mozilla/build/mac/build_scripts/Moz/BuildFlags.pm

@@ -1,425 +0,0 @@
-#!perl -w
-package Moz::BuildFlags;
-
-require 5.004;
-require Exporter;
-
-# Package that attempts to read a file from the Preferences folder,
-# and get build settings out of it
-
-use strict;
-use Exporter;
-
-use Cwd;
-use File::Basename;
-
-use Moz::Moz;
-use Moz::Prefs;
-
-use vars qw(@ISA @EXPORT);
-
-@ISA      = qw(Exporter);
-@EXPORT   = qw(
-                SetupBuildParams
-                InitBuildProgress
-                WriteBuildProgress
-                ClearBuildProgress
-                ReadBuildProgress
-              );
-
-
-my(@build_flags);
-my(@options_flags);
-my(@filepath_flags);
-
-my(%arrays_list) = (
-  "build_flags",    \@build_flags,
-  "options_flags",  \@options_flags,
-  "filepath_flags", \@filepath_flags
-);
-
-my($progress_file) = "¥ÊBuild progress";
-
-#-------------------------------------------------------------------------------
-# appendArrayFlag
-# 
-# Set a flag in the array
-#-------------------------------------------------------------------------------
-sub appendArrayFlag(@)
-{
-  my($array_name) = shift;
-  my($setting) = shift;
-  my($value) = shift;
-  
-  my(@optional_values);
-  foreach (@_) {
-    push(@optional_values, $_);
-  }
-
-  my(@this_flag) = [$setting, $value, @optional_values];
-  my($flags_array) = $arrays_list{$array_name};
-  if ($flags_array)
-  {
-    push(@{$flags_array}, @this_flag) || die "Failed to append\n";
-  }
-  else
-  {
-    die "Error: unknown build flags array $array_name\n";
-  }
-}
-
-#-------------------------------------------------------------------------------
-# readFlagsFile
-# 
-# Read the file of build flags from disk. File path is relative to the
-# script directory.
-#-------------------------------------------------------------------------------
-sub readFlagsFile($)
-{
-  my($flags_file) = @_;
-
-  my($file_path) = $0;
-  $file_path =~ s/[^:]+$/$flags_file/;
-  
-  print "Reading build flags from '$file_path'\n";
-
-  local(*FLAGS_FILE);
-  open(FLAGS_FILE, "< $file_path") || die "Error: failed to open flags file $file_path\n";
-
-  my($cur_array) = "";
-  
-  while(<FLAGS_FILE>)
-  {
-      my($line) = $_;
-      chomp($line);
-      
-      # ignore comments and empty lines  
-      if ($line =~ /^\#/ || $line =~ /^\s*$/) {
-        next;
-      }
-
-      # 1-word line, probably array name
-      if ($line =~ /^([^#\s]+)\s*$/)
-      {
-        $cur_array = $1;
-        next;  
-      }
-      elsif ($line =~ /^([^#\s]+)\s+\"(.+)\"(\s+#.+)?$/)    # quoted option, possible comment
-      {
-        my($flag) = $1;
-        my($setting) = $2;
-        
-        appendArrayFlag($cur_array, $flag, $setting);
-      }
-      elsif ($line =~ /^([^#\s]+)((\s+[^#\s]+)+)(\s+#.+)?$/)  # multiple word line, possible comment
-      {
-        my($flag) = $1;
-        
-        appendArrayFlag($cur_array, $flag, split(' ', $2));
-      }
-      else
-      {
-        die "Error: unknown build flag at '$line'\n";
-      }
-  
-  }
-  
-  close(FLAGS_FILE);
-}
-
-
-
-#-------------------------------------------------------------------------------
-# flagsArrayToHash
-# 
-# Utility routine to migrate flag from a 2D array to a hash, where
-# item[n][0] is the hash entry name, and item[n][1] is the hash entry value.
-#-------------------------------------------------------------------------------
-
-sub flagsArrayToHash($$)
-{
-  my($src_array, $dest_hash) = @_;
-  
-  my($item);
-  foreach $item (@$src_array)
-  {
-    $dest_hash->{$item->[0]} = $item->[1];
-  }
-}
-
-#-----------------------------------------------
-# printHash
-#
-# Utility routine to print a hash
-#-----------------------------------------------
-sub printHash($)
-{
-  my($hash_ref) = @_;
- 
-  print "Printing hash:\n";
-  
-  my($key, $value);
-  
-  while (($key, $value) = each (%$hash_ref))
-  {
-    print "  $key $value\n";
-  }
-}
-
-
-#-----------------------------------------------
-# printBuildArray
-#
-# Utility routine to print a 2D array
-#-----------------------------------------------
-sub printBuildArray($)
-{
-  my($build_array) = @_;
-  
-  my($entry);
-  foreach $entry (@$build_array)
-  {  
-    print "$entry->[0] = $entry->[1]\n";
-  }
-
-}
-
-#-------------------------------------------------------------------------------
-# SetBuildFlags
-#-------------------------------------------------------------------------------
-sub SetBuildFlags($)
-{
-  my($build) = @_;
-
-  flagsArrayToHash(\@build_flags, $build);
-}
-
-#-------------------------------------------------------------------------------
-# SetBuildOptions
-#-------------------------------------------------------------------------------
-sub SetBuildOptions($)
-{
-  my($options) = @_;
-
-  flagsArrayToHash(\@options_flags, $options);
-}
-
-#-------------------------------------------------------------------------------
-# SetFilepathFlags
-#-------------------------------------------------------------------------------
-sub SetFilepathFlags($)
-{
-  my($filepath) = @_;
-
-  flagsArrayToHash(\@filepath_flags, $filepath);
-}
-
-#-------------------------------------------------------------------------------
-# SetOptionDefines
-#-------------------------------------------------------------------------------
-sub SetOptionDefines($)
-{
-  my($optiondefines) = @_;
-
-  foreach my $entry (@options_flags)
-  {
-    if (defined($entry->[2])) {
-      $optiondefines->{$entry->[0]}{$entry->[2]} = 1;
-    }
-  }
-}
-
-
-#-------------------------------------------------------------------------------
-# PropagateAllFlags
-#-------------------------------------------------------------------------------
-sub PropagateAllFlags($)
-{
-  my($build_array) = @_;
-  
-  # if "all" is set, set all the flags to 1
-  unless ($build_array->[0][0] eq "all") { die "Error: 'all' must come first in the flags array\n"; }
-  
-  if ($build_array->[0][1] == 1)
-  {
-    my($index);
-    foreach $index (@$build_array)
-    {
-      $index->[1] = 1;
-    }
-  }
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// _getBuildProgressFile
-#//--------------------------------------------------------------------------------------------------
-sub _getBuildProgressFile()
-{
-  return $progress_file;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// setBuildProgressStart
-#// 
-#// This automagically sets $build{"all"} to 0
-#//--------------------------------------------------------------------------------------------------
-sub setBuildProgressStart($$)
-{
-  my($build_array, $name) = @_;
-
-  my($index);
-  foreach $index (@$build_array)
-  {
-    $index->[1] = 0;
-    if ($index->[0] eq $name) {
-      last;
-    }    
-  }
-
-  print "Building from module after $name, as specified by build progress\n";
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// InitBuildProgress
-#//--------------------------------------------------------------------------------------------------
-sub InitBuildProgress($)
-{
-  my($prog_file) = @_;
-  if ($prog_file ne "") {
-    $progress_file = full_path_to($prog_file);
-    print "Writing build progress to $progress_file\n";
-  }
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// WriteBuildProgress
-#//--------------------------------------------------------------------------------------------------
-sub WriteBuildProgress($)
-{
-  my($module_built) = @_;
-
-  my($progress_file) = _getBuildProgressFile();
-  
-  if ($progress_file ne "")
-  {
-    open(PROGRESS_FILE, ">>$progress_file") || die "Failed to open $progress_file\n";
-    print(PROGRESS_FILE "$module_built\n");
-    close(PROGRESS_FILE);
-  }
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// ClearBuildProgress
-#//--------------------------------------------------------------------------------------------------
-sub ClearBuildProgress()
-{
-  my($progress_file) = _getBuildProgressFile();
-  if ($progress_file ne "") {
-    unlink $progress_file;
-  }
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// WipeBuildProgress
-#//--------------------------------------------------------------------------------------------------
-sub WipeBuildProgress()
-{
-  print "Ignoring build progress\n";
-  ClearBuildProgress();
-  $progress_file = "";
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// ReadBuildProgress
-#//--------------------------------------------------------------------------------------------------
-sub ReadBuildProgress($)
-{
-  my($build_array) = @_;
-  my($progress_file) = _getBuildProgressFile();
-
-  my($last_module);
-  
-  if (open(PROGRESS_FILE, "< $progress_file"))
-  {
-    print "Getting build progress from $progress_file\n";
-    
-    while (<PROGRESS_FILE>)
-    {
-      my($line) = $_;
-      chomp($line);
-      $last_module = $line;
-    }
-    
-    close(PROGRESS_FILE);
-  }
-  
-  if ($last_module)
-  {
-    setBuildProgressStart($build_array, $last_module);
-  }
-}
-
-#-------------------------------------------------------------------------------
-# clearOldBuildSettings
-#-------------------------------------------------------------------------------
-sub clearOldBuildSettings($$$$)
-{
-  my($build, $options, $optiondefines, $filepaths) = @_;
-
-  # empty the arrays in case we're being called twice
-  @build_flags = ();
-  @options_flags = ();
-  @filepath_flags = ();
-  
-  # and empty the hashes
-  %$build = ();
-  %$options = ();
-  %$optiondefines = ();
-  %$filepaths = ();
-}
-
-#-------------------------------------------------------------------------------
-# SetupBuildParams
-#-------------------------------------------------------------------------------
-sub SetupBuildParams($$$$$$)
-{
-  my($build, $options, $optiondefines, $filepaths, $flags_file, $prefs_file) = @_;
-  
-  # Empty the hashes and arrays, to wipe out any stale data.
-  # Needed because these structures persist across two build scripts
-  # called using 'do' from a parent script.
-  clearOldBuildSettings($build, $options, $optiondefines, $filepaths);
-  
-  # Read from the flags file, which sets up the various arrays
-  readFlagsFile($flags_file);
-  
-  # If 'all' is set in the build array, propagate that to all entries
-  PropagateAllFlags(\@build_flags);
-  
-  # read the user pref file, that can change values in the array
-  ReadMozUserPrefs($prefs_file, \@build_flags, \@options_flags, \@filepath_flags);
-
-  # If build progress exists, this clears flags in the array up to a certain point
-  if ($main::USE_BUILD_PROGRESS) {
-    ReadBuildProgress(\@build_flags);
-  } else {
-    WipeBuildProgress();
-  }
-  
-#  printBuildArray(\@build_flags);
-#  printBuildArray(\@options_flags);
-  
-  SetBuildFlags($build);
-  SetBuildOptions($options);
-  SetOptionDefines($optiondefines);
-  SetFilepathFlags($filepaths);
-  
-#  printHash($build);
-#  printHash($options);
-}
-
-
-1;

mozilla/build/mac/build_scripts/Moz/BuildUtils.pm

@@ -1,786 +0,0 @@
-
-package Moz::BuildUtils;
-
-require 5.004;
-require Exporter;
-
-# Package that contains build util functions specific to the Mozilla build
-# process.
-
-use strict;
-use Exporter;
-
-use Cwd;
-use File::Path;
-use File::Basename;
-
-use Mac::Events;
-use Mac::StandardFile;
-
-use Moz::Moz;
-use Moz::BuildFlags;
-use Moz::MacCVS;
-#use Moz::ProjectXML;  #optional; required for static build only
-
-use vars qw(@ISA @EXPORT);
-
-@ISA      = qw(Exporter);
-@EXPORT   = qw(
-                SetupDefaultBuildOptions
-                SetupBuildRootDir
-                StartBuildModule
-                EndBuildModule
-                GetBinDirectory
-                BuildOneProjectWithOutput
-                BuildOneProject
-                BuildProject
-                BuildProjectClean
-                BuildIDLProject
-                BuildFolderResourceAliases
-                AskAndPersistFile
-                DelayFor
-                TimeStart
-                TimeEnd
-                EmptyTree
-                SetupBuildLog
-                SetBuildNumber
-                SetTimeBomb
-                UpdateConfigHeader
-              );
-
-#//--------------------------------------------------------------------------------------------------
-#// SetupDefaultBuildOptions
-#//--------------------------------------------------------------------------------------------------
-sub SetupDefaultBuildOptions($$$)
-{
-    my($debug, $bin_dir, $config_header_file_name) = @_;
-
-    # Here we set up defaults for the various build flags.
-    # If you want to override any of these, it's best to do
-    # so via the relevant preferences file, which lives in
-    # System Folder:Preferences:Mozilla build prefs:{build prefs file}.
-    # For the name of the prefs file, see the .pl script that you
-    # run to start this build. The prefs files are created when
-    # you run the build, and contain some documentation.
-    
-    #-------------------------------------------------------------
-    # configuration variables that globally affect what is built
-    #-------------------------------------------------------------
-    $main::DEBUG                  = $debug;
-    $main::PROFILE                = 0;
-    $main::RUNTIME                = 0;    # turn on to just build runtime support and NSPR projects
-    $main::GC_LEAK_DETECTOR       = 0;    # turn on to use GC leak detection
-    $main::MOZILLA_OFFICIAL       = 0;    # generate build number
-    $main::LOG_TO_FILE            = 0;    # write perl output to a file
-    
-    #-------------------------------------------------------------
-    # configuration variables that affect the manner of building, 
-    # but possibly affecting the outcome.
-    #-------------------------------------------------------------    
-    $main::ALIAS_SYM_FILES        = $main::DEBUG;
-    $main::CLOBBER_LIBS           = 1;      # turn on to clobber existing libs and .xSYM files before
-                                            # building each project                         
-    # The following two options will delete all dist files (if you have $main::build{dist} turned on),
-    # but leave the directory structure intact.
-    $main::CLOBBER_DIST_ALL       = 1;    # turn on to clobber all aliases/files inside dist (headers/xsym/libs)
-    $main::CLOBBER_DIST_LIBS      = 0;    # turn on to clobber only aliases/files for libraries/sym files in dist
-    $main::CLOBBER_IDL_PROJECTS   = 0;    # turn on to clobber all IDL projects.
-    $main::CLOBBER_PROJECTS       = 0;    # turn on to remove object code from each project before building it
-    
-    $main::UNIVERSAL_INTERFACES_VERSION = 0x0320;
-    
-    #-------------------------------------------------------------
-    # configuration variables that are preferences for the build,
-    # style and do not affect what is built.
-    #-------------------------------------------------------------
-    $main::CLOSE_PROJECTS_FIRST   = 0;
-                                    # 1 = close then make (for development),
-                                    # 0 = make then close (for tinderbox).
-    $main::USE_TIMESTAMPED_LOGS   = 0;
-    $main::USE_BUILD_PROGRESS     = 1;    # track build progress for restartable builds
-    #-------------------------------------------------------------
-    # END OF CONFIG SWITCHES
-    #-------------------------------------------------------------
-    
-    $main::BIN_DIRECTORY = $bin_dir;
-    $main::DEFINESOPTIONS_FILE = $config_header_file_name;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// SetupBuildRootDir
-#//--------------------------------------------------------------------------------------------------
-sub SetupBuildRootDir($)
-{
-    my($rel_path_to_script) = @_;
-
-    my($cur_dir) = cwd();
-    $cur_dir =~ s/$rel_path_to_script$//;
-    chdir($cur_dir) || die "Error: failed to set build root directory to '$cur_dir'.\nYou probably need to put 'mozilla' one level down (in a folder).\n";
-    $main::MOZ_SRC = cwd();
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// StartBuildModule
-#//--------------------------------------------------------------------------------------------------
-sub StartBuildModule($)
-{
-    my($module) = @_;
-
-    print("---- Start of $module ----\n");
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// EndBuildModule
-#//--------------------------------------------------------------------------------------------------
-sub EndBuildModule($)
-{
-    my($module) = @_;
-    WriteBuildProgress($module);
-    print("---- End of $module ----\n");
-}
-
-#--------------------------------------------------------------------------------------------------
-# GetBinDirectory
-#--------------------------------------------------------------------------------------------------
-sub GetBinDirectory()
-{
-    if ($main::BIN_DIRECTORY eq "") { die "Dist directory not set\n"; }
-    return $main::BIN_DIRECTORY;
-}
-
-#--------------------------------------------------------------------------------------------------
-# AskAndPersistFile stores the information about the user pick inside
-# the file $session_storage
-#--------------------------------------------------------------------------------------------------
-sub AskAndPersistFile($)
-{
-    my ($sessionStorage) = @_;
-    my $cvsfile;
-
-    if (( -e $sessionStorage) &&
-        open( SESSIONFILE, $sessionStorage ))
-    {
-    # Read in the path if available
-        $cvsfile = <SESSIONFILE>;
-        chomp $cvsfile;
-        close SESSIONFILE;
-        if ( ! -e $cvsfile )
-        {
-            print STDERR "$cvsfile has disappeared\n";
-            undef $cvsfile;
-        }
-    }
-    unless (defined ($cvsfile))
-    {
-        # make sure that MacPerl is a front process
-        ActivateApplication('McPL');
-        MacPerl::Answer("Could not find your MacCVS session file. Please choose one", "OK");
-        
-        # prompt user for the file name, and store it
-        my $macFile = StandardGetFile( 0, "McvD");  
-        if ( $macFile->sfGood() )
-        {
-            $cvsfile = $macFile->sfFile();
-            # save the choice if we can
-            if ( open (SESSIONFILE, ">" . $sessionStorage))
-            {
-                printf SESSIONFILE $cvsfile, "\n";
-                close SESSIONFILE;
-            }
-            else
-            {
-                print STDERR "Could not open storage file $sessionStorage for saving $cvsfile\n";
-            }
-        }
-    }
-    return $cvsfile;
-}
-
-
-#--------------------------------------------------------------------------------------------------
-# BuildIDLProject
-#
-#--------------------------------------------------------------------------------------------------
-
-sub BuildIDLProject($$)
-{
-    my ($project_path, $module_name) = @_;
-
-    if ($main::CLOBBER_IDL_PROJECTS)
-    {
-        my (@suffix_list) = (".mcp", ".xml");
-        my ($project_name, $project_dir, $suffix) = fileparse($project_path, @suffix_list);
-        if ($suffix eq "") { die "Error: Project, $project_path must end in .xml or .mcp\n"; }
-
-        my($datafolder_path);
-        if ($suffix eq ".xml")
-        {
-            $datafolder_path = $project_dir . "_" . $project_name . " Data:";
-        }
-        else {
-            $datafolder_path = $project_dir . $project_name . " Data:";
-        }
-
-        print STDERR "Deleting IDL data folder: $datafolder_path\n";
-        EmptyTree($datafolder_path);
-    }
-
-    BuildOneProject($project_path,  "headers", 0, 0, 0);
-    BuildOneProject($project_path,  $module_name.".xpt", 1, 0, 1);
-}
-
-
-#--------------------------------------------------------------------------------------------------
-# CreateStaticLibTargets
-#
-#--------------------------------------------------------------------------------------------------
-sub CreateXMLStaticLibTargets($)
-{
-    my($xml_path) = @_;
-
-    my (@suffix_list) = (".xml");
-    my ($project_name, $project_dir, $suffix) = fileparse($xml_path, @suffix_list);
-    if ($suffix eq "") { die "XML munging: $xml_path must end in .xml\n"; }
-
-    #sniff the file to see if we need to fix up broken Pro5-exported XML
-    print "Parsing $xml_path\n";
-    
-    my $ide_version = Moz::ProjectXML::SniffProjectXMLIDEVersion($xml_path);
-    if ($ide_version eq "4.0")
-    {
-        my $new_file = $project_dir.$project_name."2.xml";
-        
-        print "Cleaning up Pro 5 xml to $new_file\n";
-        
-        Moz::ProjectXML::CleanupPro5XML($xml_path, $new_file);
-
-        unlink $xml_path;
-        rename ($new_file, $xml_path);
-    }
-    
-    my $doc = Moz::ProjectXML::ParseXMLDocument($xml_path);
-    my @target_list = Moz::ProjectXML::GetTargetsList($doc);
-    my $target;
-    
-    my %target_hash;    # for easy lookups below
-    foreach $target (@target_list) { $target_hash{$target} = 1; }
-    
-    foreach $target (@target_list)
-    {
-        if ($target =~ /(.+).shlb$/)        # if this is a shared lib target
-        {
-            my $target_base = $1;
-            my $static_target = $target_base.".o";
-            
-            # ensure that this does not exist already
-            if ($target_hash{$static_target}) {
-                print "Static target $static_target already exists in project. Not making\n";
-                next;
-            }
-            
-            print "Making static target '$static_target' from target '$target'\n";
-
-            Moz::ProjectXML::CloneTarget($doc, $target, $static_target);
-            Moz::ProjectXML::SetAsStaticLibraryTarget($doc, $static_target, $static_target);
-        }
-    }
-    
-    print "Writing XML file to $xml_path\n";
-    my $temp_path = $project_dir."_".$project_name.".xml";
-    Moz::ProjectXML::WriteXMLDocument($doc, $temp_path, $ide_version);
-    Moz::ProjectXML::DisposeXMLDocument($doc);
-    
-    if (-e $temp_path)
-    {
-        unlink $xml_path;
-        rename ($temp_path, $xml_path);
-    }
-    else
-    {
-        die "Error: Failed to add new targets to XML project\n";
-    }
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// ProcessProjectXML
-#// 
-#// Helper routine to allow for XML pre-processing. This should read in the XML, process it,
-#// and replace the original file with the processed version.
-#//--------------------------------------------------------------------------------------------------
-sub ProcessProjectXML($)
-{
-    my($xml_path) = @_;
-  
-    # we need to manually load Moz::ProjectXML, becaues not everyone will have the
-    # required perl modules in their distro.
-    my($cur_dir) = cwd();
-    
-    chdir(dirname($0));     # change to the script dir
-    eval "require Moz::ProjectXML";
-    if ($@) { die "Error: could not do Project XML munging because you do not have the correct XML modules installed. Error is:\n################\n $@################"; }
-    
-    chdir($cur_dir);
-    
-    CreateXMLStaticLibTargets($xml_path);
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// Build one project, and make the alias. Parameters are project path, target name, shared  library
-#// name, make shlb alias (boolean), make xSYM alias (boolean), and is component (boolean).
-#//--------------------------------------------------------------------------------------------------
-
-sub BuildOneProjectWithOutput($$$$$$)
-{
-    my ($project_path, $target_name, $output_name, $alias_lib, $alias_xSYM, $component) = @_;
-
-    unless ($project_path =~ m/^$main::BUILD_ROOT.+/) { return; }
-
-    my (@suffix_list) = (".mcp", ".xml");
-    my ($project_name, $project_dir, $suffix) = fileparse($project_path, @suffix_list);
-    if ($suffix eq "") { die "Error: Project, $project_path must end in .xml or .mcp\n"; }
-    
-    my($dist_dir) = GetBinDirectory();
-    
-    # Put libraries in "Essential Files" folder, Components in "Components" folder
-    my($output_dir)  = $component ? "Components:" : "Essential Files:";
-    my($output_path) = $dist_dir.$output_dir;
-
-    if ($main::options{static_build})
-    {      
-      if ($output_name =~ /\.o$/ || $output_name =~ /\.[Ll]ib$/)
-      {
-        $alias_xSYM = 0;
-        $alias_lib  = 1;
-        $output_path = $main::DEBUG ? ":mozilla:dist:static_libs_debug:" : ":mozilla:dist:static_libs:";
-      }
-    }
-
-    # if the flag is on to export projects to XML, export and munge them
-    if ($main::EXPORT_PROJECTS && !($project_path =~ /IDL\.mcp$/))
-    {
-        my $xml_out_path = $project_path;
-
-        $xml_out_path =~ s/\.mcp$/\.xml/;
-
-        # only do this if project is newer?
-        if (! -e $xml_out_path)
-        {
-          ExportProjectToXML(full_path_to($project_path), full_path_to($xml_out_path));
-          ProcessProjectXML($xml_out_path);
-        }
-    }
-        
-    # if the flag is set to use XML projects, default to XML if the file 
-    # is present.
-    if ($main::USE_XML_PROJECTS && !($project_path =~ /IDL\.mcp$/))
-    {
-      my $xml_project_path = $project_dir.$project_name.".xml";
-      if (-e $xml_project_path)
-      {
-        $project_path = $xml_project_path;
-        $suffix = ".xml";
-      }
-    }
-    
-    if ($suffix eq ".xml")
-    {
-        my($xml_path) = $project_path;
-        # Prepend an "_" onto the name of the generated project file so it doesn't conflict
-        $project_path = $project_dir . "_" . $project_name . ".mcp";
-        my($project_modtime) = (-e $project_path ? GetFileModDate($project_path) : 0);
-        my($xml_modtime) = (-e $xml_path ? GetFileModDate($xml_path) : 0);
-
-        if ($xml_modtime > $project_modtime)
-        {
-            print("Importing $project_path from $project_name.xml.\n");
-            unlink($project_path);
-            # Might want to delete the "xxx.mcp Data" dir ???
-            ImportXMLProject(full_path_to($xml_path), full_path_to($project_path));
-        }
-    }
-
-
-    if ($main::CLOBBER_LIBS)
-    {
-        unlink "$project_dir$output_name";              # it's OK if these fail
-        unlink "$project_dir$output_name.xSYM";
-    }
-    
-    DoBuildProject($project_path, $target_name, $main::CLOBBER_PROJECTS);
-    
-    $alias_lib  ? MakeAlias("$project_dir$output_name",      "$output_path") : 0;
-    $alias_xSYM ? MakeAlias("$project_dir$output_name.xSYM", "$output_path") : 0;
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// For compatiblity with existing scripts, BuildOneProject now just calls
-#// BuildOneProjectWithOutput, with the output name and target name identical.
-#// Note that this routine assumes that the target name and the shared libary name
-#// are the same.
-#//--------------------------------------------------------------------------------------------------
-
-sub BuildOneProject($$$$$)
-{
-    my ($project_path, $target_name, $alias_lib, $alias_xSYM, $component) = @_;
-    
-	BuildOneProjectWithOutput($project_path, $target_name, $target_name,
-							  $alias_lib, $alias_xSYM, $component);
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// For compatiblity with existing scripts, BuildProject now just calls
-#// BuildOneProjectWithOutput, with the output name and target name identical.
-#// Note that this routine assumes that the target name and the shared libary name
-#// are the same. No aliases of the output are made.
-#//--------------------------------------------------------------------------------------------------
-
-sub BuildProject($$)
-{
-    my ($project_path, $target_name) = @_;
-    
-	BuildOneProjectWithOutput($project_path, $target_name, $target_name, 0, 0, 0);
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// Identical to BuildProject but clobbers the project before building it.
-#//--------------------------------------------------------------------------------------------------
-
-sub BuildProjectClean($$)
-{
-    my ($project_path, $target_name) = @_;
-    my ($save_clobber_flag) = $main::CLOBBER_PROJECTS;
-    $main::CLOBBER_PROJECTS = 1;
-	BuildOneProjectWithOutput($project_path, $target_name, $target_name, 0, 0, 0);
-	$main::CLOBBER_PROJECTS = $save_clobber_flag;
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// Make resource aliases for one directory
-#//--------------------------------------------------------------------------------------------------
-
-sub BuildFolderResourceAliases($$)
-{
-    my($src_dir, $dest_dir) = @_;
-        
-    # get a list of all the resource files
-    opendir(SRCDIR, $src_dir) || die("can't open $src_dir");
-    my(@resource_files) = readdir(SRCDIR);
-    closedir(SRCDIR);
-    
-    # make aliases for each one into the dest directory
-    print("Placing aliases to all files from $src_dir in $dest_dir\n");
-    for ( @resource_files )
-    {
-        next if $_ eq "CVS";
-        #print("    Doing $_\n");
-        if (-l $src_dir.$_)
-        {
-            print("     $_ is an alias\n");
-            next;
-        }
-        my($file_name) = $src_dir . $_; 
-        MakeAlias($file_name, $dest_dir);
-    }
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// DelayFor
-#//
-#// Delay for the given number of seconds, allowing the script to be cancelled
-#//--------------------------------------------------------------------------------------------------
-
-sub DelayFor($)
-{
-  my($delay_secs) = @_;
-  
-  STDOUT->autoflush(1);
-  
-  my($end_time) = time() + $delay_secs;
-    
-  my($last_time) = 0;
-  my($cur_time) = time();
-  
-  while ($cur_time < $end_time)
-  {
-    $cur_time = time();
-    if ($cur_time > $last_time)
-    {
-      print ".";
-      $last_time = $cur_time;
-    }
-    
-    WaitNextEvent();
-  }
-
-  print "\n";
-  STDOUT->autoflush(0);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// TimeStart
-#//--------------------------------------------------------------------------------------------------
-sub TimeStart()
-{
-    return time();
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// TimeEnd
-#//--------------------------------------------------------------------------------------------------
-sub TimeEnd($$)
-{
-    use integer;
-    
-    my($start_time, $operation_name) = @_;
-    my($end_time) = time();
-    
-    my($tot_sec) = $end_time - $start_time;
-    
-    my($seconds) = $tot_sec;
-    
-    my($hours) = $seconds / (60 * 60);
-    $seconds -= $hours * (60 * 60);
-    
-    my($minutes) = $seconds / 60;
-    $seconds -= $minutes * 60;
-        
-    print "$operation_name took $hours hours $minutes minutes and $seconds seconds\n";
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// Remove all files from a tree, leaving directories intact (except "CVS").
-#//--------------------------------------------------------------------------------------------------
-
-sub EmptyTree($)
-{
-    my ($root) = @_; 
-    #print "EmptyTree($root)\n";
-    opendir(DIR, $root);
-    my $sub;
-    foreach $sub (readdir(DIR))
-    {
-        my $fullpathname = $root.$sub; # -f, -d only work on full paths
-
-        # Don't call empty tree for the alias of a directory.
-        # -d returns true for the alias of a directory, false for a broken alias)
-
-        if (-d $fullpathname)
-        {
-            if (-l $fullpathname)   # delete aliases
-            {
-                unlink $fullpathname;
-                next;
-            }
-            EmptyTree($fullpathname.":");
-            if ($sub eq "CVS")
-            {
-                #print "rmdir $fullpathname\n";
-                rmdir $fullpathname;
-            }
-        }
-        else
-        {
-            unless (unlink $fullpathname) { die "Failed to delete $fullpathname\n"; }
-        }
-    }
-    closedir(DIR);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// Recurse through a directory hierarchy, looking for MANIFEST files.
-#// Currently unused.
-#//--------------------------------------------------------------------------------------------------
-
-sub ScanForManifestFiles($$$$)
-{
-    my($dir, $theme_root, $theme_name, $dist_dir) = @_;
-
-    opendir(DIR, $dir) or die "Cannot open dir $dir\n";
-    my @files = readdir(DIR);
-    closedir DIR;
-
-    my $file;
-
-    foreach $file (@files)
-    {    
-        my $filepath = $dir.":".$file;
-
-        if (-d $filepath)
-        {
-            # print "Looking for MANIFEST files in $filepath\n";        
-            ScanForManifestFiles($filepath, $theme_root, $theme_name, $dist_dir);
-        }
-        elsif ($file eq "MANIFEST")
-        {
-            # print "Doing manifest file $filepath\n";
-
-            # Get the dest path from the first line of the file
-
-            open(MANIFEST, $filepath) || die "Could not open file $file";
-            # Read in the path if available
-            my($dest_line) = <MANIFEST>;
-            chomp $dest_line;
-            close MANIFEST;
-
-            $dest_line =~ s|^#!dest[\t ]+|| || die "No destination line found in $filepath\n";
-
-            my($dest_path) = $dist_dir."chrome:skins:$theme_name:$dest_line";
-            # print " Destination is $dest_path\n";
-
-            InstallResources($filepath, "$dest_path", 0);
-        }
-    }
-}
-
-
-#-----------------------------------------------
-# SetupBuildLog
-#-----------------------------------------------
-sub SetupBuildLog($$)
-{
-    my($logfile_path, $timestamped_log) = @_;
-    
-    my($logdir) = "";
-    my($logfile) = $logfile_path;
-    
-    if ($logfile_path =~ /(.+?:)([^:]+)$/)       # ? for non-greedy match
-    {
-        $logdir = $1;
-        $logfile = $2;
-        
-        mkpath($logdir);
-    }
-    
-    if ($timestamped_log)
-    {
-        #Use time-stamped names so that you don't clobber your previous log file!
-        my $now = localtime();
-        while ($now =~ s@:@.@) {} # replace all colons by periods
-        OpenErrorLog("${logdir}${now}");
-    }
-    else
-    {
-        OpenErrorLog("${logdir}${logfile}");
-    }
-}
-
-#-----------------------------------------------
-# SetBuildNumber
-#-----------------------------------------------
-sub SetBuildNumber($$)
-{
-    my($build_num_file, $files_to_touch) = @_;
-
-    # Make sure we add the config dir to search, to pick up mozBDate.pm
-    # Need to do this dynamically, because this module can be used before
-    # mozilla/config has been checked out.
-    
-    my ($inc_path) = $0;        # $0 is the path to the parent script
-    $inc_path =~ s/:build:mac:build_scripts:.+$/:config/;
-    push(@INC, $inc_path);
-
-    require mozBDate;
-    
-    mozBDate::UpdateBuildNumber($build_num_file, $main::MOZILLA_OFFICIAL);
-   
-    my($file);
-    foreach $file (@$files_to_touch)
-    {
-        print "Writing build number to $file from ${file}.in\n";
-        mozBDate::SubstituteBuildNumber($file, $build_num_file, "${file}.in");
-    }
-}
-
-#-----------------------------------------------
-# SetTimeBomb
-#-----------------------------------------------
-sub SetTimeBomb($$)		
-{
-  my ($warn_days, $bomb_days) = @_;
-  
-  system("perl :mozilla:config:mac-set-timebomb.pl $warn_days $bomb_days");
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// Regenerate a configuration header file if necessary
-#//--------------------------------------------------------------------------------------------------
-sub UpdateConfigHeader($)
-{
-    my($config_path) = @_;
-    
-    my($config, $oldconfig) = ("", "");
-    my($define, $definevalue, $defines);
-    my($k, $l,);
-
-    foreach $k (keys(%main::options))
-    {
-        if ($main::options{$k})
-        {
-            foreach $l (keys(%{$main::optiondefines{$k}}))
-            {
-                $my::defines{$l} = $main::optiondefines{$k}{$l};
-                print "Setting up my::defines{$l}\n";
-            }
-        }
-    }
-
-    my $config_headerfile = current_directory().$config_path;
-    if (-e $config_headerfile)
-    {
-        open(CONFIG_HEADER, "< $config_headerfile") || die "$config_headerfile: $!\n";
-        my($line);
-        while ($line = <CONFIG_HEADER>)
-        {
-            if ($line =~ m/#define\s+([^\s]*)\s+([^\s]*)\s*\n/)
-            {
-                $define = $1;
-                $definevalue = $2;
-                
-                #canonicalize so that whitespace changes are not significant
-                my $canon_value = "#define " . $define . " " . $definevalue . "\n";
-                $oldconfig .= $canon_value;
-                
-                if (exists ($my::defines{$define}) and ($my::defines{$define} == $definevalue))
-                {
-                    delete $my::defines{$define};
-                    $config .= $canon_value;
-                }
-            }
-        }
-        close(CONFIG_HEADER);
-    }
-
-    if (%my::defines)
-    {
-        foreach $k (keys(%my::defines))
-        {
-            $config .= "#define " . $k . " " . $my::defines{$k} . "\n";
-        }
-    }
-
-    my $file_name = basename($config_headerfile);
-    if (($config ne $oldconfig) || (!-e $config_headerfile))
-    {
-        printf("Writing new configuration header $file_name\n");
-        open(CONFIG_HEADER, "> $config_headerfile") || die "$config_headerfile: $!\n";
-        print(CONFIG_HEADER "/* This file is auto-generated based on build options. Do not edit. */\n");
-        print CONFIG_HEADER ($config);
-        close(CONFIG_HEADER);
-
-        MacPerl::SetFileInfo("CWIE", "TEXT", $config_headerfile);
-    }
-    else
-    {
-        printf("Configuration header $file_name is up-to-date\n");
-    }
-}
-
-
-1;
-

mozilla/build/mac/build_scripts/Moz/CodeWarriorLib.pm

@@ -1,660 +0,0 @@
-#!perl
-package Moz::CodeWarriorLib;
-
-=pod
-
-=head1 NAME
-
-CodeWarriorLib - supply interface to CodeWarrior
-
-=head1 SYNOPSIS
-
-	#!perl
-	use CodeWarriorLib;
-	CodeWarriorLib::activate();
-	$had_errors = CodeWarriorLib::build_project(
-		$project_path, $target_name, $recent_errors_file, $clean_build
-	);
-
-=head1 DESCRIPTION
-
-Replaces the AppleScript library I<CodeWarriorLib>.
-
-=over 4
-
-=cut
-
-use strict;
-
-use Cwd;
-use File::Basename;
-
-use Mac::Types;
-use Mac::Events;
-use Mac::AppleEvents;
-use Mac::AppleEvents::Simple;
-use Mac::Processes;
-use Mac::MoreFiles;
-use Mac::StandardFile;
-
-
-use vars qw($VERSION);
-$VERSION = '1.02';
-
-my($app)  = 'CWIE';
-my($scriptDir) = cwd();         # could use $0 for this
-my($ide_loc_file) = "";
-
-# 0 == don't switch CWIE to front app in do_event(), 1 == do switch
-# note: activate() still switches when called
-$Mac::AppleEvents::Simple::SWITCH = 0;
-# $Mac::AppleEvents::Simple::WARN = 1;
-
-# supply your own path to the source here
-#_test('PowerPudgeIV:mozilla:mozilla:');
-
-# If you want to understand the gobbldeygook that's used to build Apple Events,
-# you should start by reading the AEGizmos documentation.
-
-=pod
-
-=item _get_project($full_path)
-
-A private routine returning a reference to the open project with the given name,
-or else the empty string (when that project is not open)
-
-full_path is a string identifying the project to be built and is of the form, 
-e.g., "HD:ProjectFolder:MyProject.mcp".  It must be supplied.
-
-=cut
-
-sub _get_project ($) {
-	my(
-		$full_path, $candidate_projects
-	) = @_;
-	$candidate_projects = _doc_named(basename($full_path, '*'));
-	if ($candidate_projects) {
-		my($cps) = _get_dobj($candidate_projects);
-		my($num) = AECountItems($cps);
-		if ($num) {  # is a list
-			foreach (1 .. AECountItems($cps)) {
-				my($cp) = AEGetNthDesc($cps, $_);
-				if (lc $full_path eq lc _full_path($cp)) {
-					return($cp);
-				}
-			}
-		} else {     # is only one, not a list
-			if (lc $full_path eq lc _full_path($cps)) {
-				return($cps);
-			}
-		}
-	}
-	return;
-}
-
-=pod
-
-=item build_project
-
-Build a selected target of a project, saving any errors to a file, if supplied.
-	
-full_path is a string identifying the project to be built and is of the form, 
-e.g., "HD:ProjectFolder:MyProject.mcp".  It must be supplied.
-
-If target_name is the empty string, the current target of the selected project 
-will be built, else, target_name should be a string matching a target name in 
-the selected project.
-	
-If error_path is the empty string, errors will not be saved to a file,
-else, error_path should be the full path of a file to save error messages into.
-
-=cut
-
-$CodeWarriorLib::CLOSE_PROJECTS_FIRST = 0; # If true we close then make. If false, make then close.
-my $last_project_built = "";
-my $last_project_was_closed = 0;
-
-sub build_project ($;$$$) {
-	my(
-		$full_path, $target_name, $error_path,
-		$remove_object, $p, $project_was_closed, $had_errors
-	) = @_;
-	_close_errors_window();
-
-	if ($CodeWarriorLib::CLOSE_PROJECTS_FIRST && ($last_project_built ne $full_path))
-	{
-		# If we're in "close first" mode, we don't close if the current project
-		# is the same as the previous one.
-		if ($last_project_was_closed) {
-			$p = _get_project($last_project_built);
-			_close($p);
-		}
-		$last_project_built = $full_path;
-		$last_project_was_closed = 0; # now refers to the new project
-	}
-	$project_was_closed = 0;
-	while (1) {
-		$p = _get_project($full_path);
-		if (!$p) {
-			if ($project_was_closed) {
-				print "### Error - request for project document failed after opening\n";
-				die "### possibly CW Pro 4 bug: be sure to close your Find window\n";
-			}
-			$project_was_closed = 1;
-			$last_project_was_closed = 1;
-			_open_file($full_path);
-		} else {
-			last;
-		}
-	}
-
-	$had_errors = 0;
-	if ($target_name eq '') {
-		if ($remove_object) {_remove_object($p)}
-		_build($p);
-	} else {
-		if ($remove_object) {_remove_object($p, $target_name)}
-		_build($p, $target_name);
-	}
-
-	if ($error_path ne '') {
-		_save_errors_window($error_path);
-	}
-	$had_errors = _close_errors_window();
-
-	if (!$CodeWarriorLib::CLOSE_PROJECTS_FIRST)
-	{
-		if ($project_was_closed) {
-			$p = _get_project($full_path);
-			_close($p);
-		}
-	}
-
-	return($had_errors);
-}
-
-=pod
-
-=item appIsRunning()
-
-=cut
-sub _appIsRunning($)
-{
-	my ($appSignature) = @_;
-	my ($psi);
-	my ($found) = 0;
-	my ($appPSN);
-
-	foreach $psi (values(%Process))
-	{
-		if ($psi->processSignature() eq $appSignature)
-		{
-			$appPSN = $psi->processNumber();
-			$found = 1;
-            last;
-		}
-	}
-	
-	return $found;
-}
-
-=pod
-
-=item appIsFrontmost()
-
-=cut
-sub _appIsFrontmost($)
-{
-	my ($appSignature) = @_;
-	my ($psi);
-	my ($found) = 0;
-	my ($appPSN);
-
-	foreach $psi (values(%Process))
-	{
-		if ($psi->processSignature() eq $appSignature)
-		{
-			$appPSN = $psi->processNumber();
-			$found = 1;
-            last;
-		}
-	}
-	
-	return (GetFrontProcess() == $appPSN);
-}
-
-
-=pod
-
-=item activate()
-
-Launches CodeWarrior and brings it to the front.
-
-Once found, path will be saved in $idepath_file for future reference.
-Edit or delete this file to change the location of the IDE.  If app is
-moved, C<activate()> will prompt for a new location.
-
-First looks for an open CodeWarrior app.  Second, tries to open previously
-saved location in ':idepath.txt'.  Third, tries to find it and allow user
-to choose it with Navigation Services (if present).  Fourth, uses good old
-GUSI routines built-in to MacPerl for a Choose Directory dialog box.
-
-=cut
-
-sub activate ($) {
-
-    $ide_loc_file = $_[0];     # save in global
-        
-	my($filepath, $appath, $psi) = ($ide_loc_file);
-
-	foreach $psi (values(%Process)) {
-		if ($psi->processSignature() eq $app) {
-			$appath = $psi->processAppSpec();
-			_save_appath($filepath, $appath);
-			last;
-		}
-	}
-
-	if (!$appath || !-x $appath) {
-		$appath = _read_appath($filepath);
-	}
-	
-	if (!$appath || ! -x $appath)
-	{
-		# make sure that MacPerl is a front process
-		#ActivateApplication('McPL');
-		MacPerl::Answer("Please locate the CodeWarrior application.", "OK");
-		
-		# prompt user for the file name, and store it
-		my $macFile = StandardGetFile( 0, "APPL");
-		if ( $macFile->sfGood() )
-		{
-			$appath = $macFile->sfFile();
-		}
-		else
-		{
-			die "Operation canceled\n";
-		}
-	
-#		if (eval {require Mac::Navigation}) {
-#			my($options, $nav);
-#			Mac::Navigation->import();
-#			$options = NavGetDefaultDialogOptions();
-#			$options->message('Where is CodeWarrior IDE?');
-#			$options->windowTitle('Find CodeWarrior IDE');
-#			$nav = NavChooseObject($Application{$app}, $options);
-#			die "CodeWarrior IDE not found.\n" if (!$nav || !$nav->file(1));
-#			$appath = $nav->file(1);
-#		} else {
-#			local(*D);
-#			my $cwd = `pwd`;
-#			$appath = _get_folder(
-#                               'Where is the CW IDE folder?',
-#				dirname($Application{$app})
-#			);
-#			die "CodeWarrior IDE not found.\n" if !$appath;
-#			opendir(D, $appath) or die $!;
-#			chdir($appath);
-#			foreach my $file (sort readdir (D)) {
-#				my(@app) = MacPerl::GetFileInfo($file);
-#				if ($app[0] && $app[1] &&
-#					$app[1] eq 'APPL' && $app[0] eq $app
-#				) {
-#					$appath .= $file;
-#					last;
-#				}
-#			}
-#			chomp($cwd);
-#			chdir($cwd);
-#		}
-		_save_appath($filepath, $appath);
-	}
-
-	my($lp) = LaunchParam->new(
-		launchAppSpec => $appath,
-		launchControlFlags => launchContinue() + launchNoFileFlags()
-	);
-	
-	unless (LaunchApplication($lp)) {
-		unlink($filepath);
-		die $^E;
-	}
-	
-	# wait for CodeWarrior to show up in the list of processes
-	while (!_appIsRunning('CWIE'))
-	{
-		WaitNextEvent();
-	}
-
-	# wait for CodeWarrior to come to the front
-	while (!_appIsFrontmost('CWIE'))
-	{
-		WaitNextEvent();
-	}
-}
-
-=pod
-
-=item getCodeWarriorPath()
-
-Returns a file path relative to the CodeWarrior folder
-
-=cut
-
-sub getCodeWarriorPath($)
-{
-    my($subfolder)=@_;
-    
-    my($app_path) = _read_appath($ide_loc_file);
-    if ($app_path eq "") { die "Error: Failed to get CodeWarrior IDE path\n"; }
-    
-    my($codewarrior_root) = $app_path;
-    $codewarrior_root =~ s/[^:]*$//;
-    return ($codewarrior_root . $subfolder);
-}
-
-
-=pod
-
-=item getCodeWarriorIDEName()
-
-Returns the name of the CodeWarrior application
-
-=cut
-
-sub getCodeWarriorIDEName()
-{
-    my($subfolder)=@_;
-
-    my($app_path) = _read_appath($ide_loc_file);
-    if ($app_path eq "") { die "Error: Failed to get CodeWarrior IDE path\n"; }
-
-    my(@codewarrior_path) = split(/:/, $app_path);
-    return pop(@codewarrior_path);
-}
-
-
-=pod
-
-=item quit()
-
-Quits CodeWarrior.
-
-=cut
-
-sub quit() {
-
-	$last_project_built = "";
-	$last_project_was_closed = 0;
-
-	my($evt) = do_event(qw/aevt quit/, $app);
-}
-
-
-sub _build ($;$) {
-	my($evt);
-	if ($_[1]) {
-		my($prm) =
-			q"'----':obj {form:name, want:type(TRGT), seld:TEXT(@), from:" .
-			AEPrint($_[0]) . '}';
-		$evt = do_event(qw/CWIE MAKE/, $app, $prm, $_[1]);
-	} else {
-		my($prm) = q"'----':" . AEPrint($_[0]);
-		$evt = do_event(qw/CWIE MAKE/, $app, $prm);
-	}
-}
-
-sub _remove_object ($;$) {
-	my($evt);
-	if ($_[1]) {
-		my($prm) =
-			q"'----':obj {form:name, want:type(TRGT), seld:TEXT(@), from:" .
-			AEPrint($_[0]) . '}';
-		$evt = do_event(qw/CWIE RMOB/, $app, $prm, $_[1]);
-	} else {
-		my($prm) = q"'----':" . AEPrint($_[0]);
-		$evt = do_event(qw/CWIE RMOB/, $app, $prm);
-	}
-}
-
-sub _open_file ($) {
-	my($prm) =
-		q"'----':obj {form:name, want:type(alis), " .
-		q"seld:TEXT(@), from:'null'()}";
-
-	do_event(qw/aevt odoc/, $app, $prm, $_[0]);
-}
-
-sub import_project ($$) {
-	my($xml_file, $project_path) = @_;
-	
-	my($prm) = "kocl:type(PRJD), rtyp:TEXT(@), data:TEXT(@), &subj:'null'()";
-	
-	my($evt) = do_event(qw/core crel/, $app, $prm, $project_path, $xml_file);    
-	my($result) = _get_event_result($evt);
-	
-	if ($result eq "") {
-		_close(_get_project($project_path));
-	}
-	return $result;
-}
-
-sub export_project ($$) {
-	my($project_path, $xml_out_path) = @_;
-	my($p, $project_was_closed);
-	
-	$project_was_closed = 0;
-	while (1) {
-		$p = _get_project($project_path);
-		if (!$p) {
-			if ($project_was_closed) {
-				print "### Error - request for project document failed after opening\n";
-				die "### possibly CW bug: be sure to close your Find window\n";
-}
-			$project_was_closed = 1;
-			_open_file($project_path);
-		} else {
-			last;
-		}
-	}
-
-    # avoid problems with the Project Messages window
-    _close_named_window("Project Messages");
-    
-	my($prm) =
-		q"'----':obj {form:indx, want:type(PRJD), " .
-		q"seld:1, from:'null'()}, kfil:TEXT(@)";
-
-	my($evt) = do_event(qw/CWIE EXPT/, $app, $prm, $xml_out_path);    
-	
-	if ($project_was_closed) {
-		$p = _get_project($project_path);
-		_close($p);
-	}
-	
-	return _get_event_result($evt);
-}
-
-sub _doc_named ($) {
-	my($prm) =
-		q"'----':obj {form:test, want:type(docu), from:'null'(), " .
-		q"seld:cmpd{relo:'=   ', 'obj1':obj {form:prop, want:type" .
-		q"(prop), seld:type(pnam), from:'exmn'()}, 'obj2':TEXT(@)}}";
-
-	my($evt) = do_event(qw/core getd/, $app, $prm, $_[0]);
-	return($evt->{REPLY} eq 'aevt\ansr{}' ? undef : $evt);
-}
-
-sub _full_path ($) {
-	my($obj) = $_[0];
-	my($prm) =
-		q"'----':obj {form:prop, want:type(prop), seld:type(FILE), " .
-		q"from:" . AEPrint($_[0]) . q"}, rtyp:type(TEXT)";
-	my($evt) = do_event(qw/core getd/, $app, $prm);
-
-	return MacPerl::MakePath(
-		MacUnpack('fss ', (
-			AEGetParamDesc($evt->{REP}, keyDirectObject()))->data()->get()
-		)
-	);
-}
-
-sub _save_errors_window ($) {
-	my($prm) = 
-		q"'----':obj {form:name, want:type(alis), seld:TEXT(@), from:'null'()}";
-	do_event(qw/MMPR SvMs/, $app, $prm, $_[0]);
-}
-
-
-sub _close_errors_window () {
-    return _close_named_window('Errors & Warnings');
-}
-
-
-sub _close_named_window ($) {
-    my($window_name) = @_;
-    
-	my($prm) =
-		q"'----':obj {form:name, want:type(cwin), " .
-		q"seld:TEXT(@), from:'null'()}";
-
-	my($evt) = do_event(qw/core clos/, $app, $prm, $window_name);
-	return($evt->{REPLY} eq 'aevt\ansr{}' ? 1 : 0);
-}
-
-sub _close () {
-	my($prm) = q"'----':" . AEPrint($_[0]);
-	do_event(qw/core clos/, $app, $prm);
-}
-
-sub _get_dobj ($) {
-	return(AEGetParamDesc($_[0]->{REP}, keyDirectObject()));
-}
-
-sub _get_folder ($$) {
-    require 'GUSI.ph';
-    my($prompt, $default) = @_;
-    MacPerl::Choose(
-        GUSI::AF_FILE(), 0, $prompt, '',
-        GUSI::CHOOSE_DIR() + ($default ? &GUSI::CHOOSE_DEFAULT : 0),
-        $default
-    );
-}
-
-sub _get_event_result ($)
-{
-    my($evt) = @_;
-
-    my($result) = $evt->{ERROR};
-    
-    if ( $result eq "" && $evt->{ERRNO} != 0 )
-    {
-        $result = "unknown error (".$evt->{ERRNO}.")";
-    }
-    
-    return $result;
-}
-
-
-sub _save_appath ($$) {
-
-	my($cwd) = cwd();	# remember the current working dir
-	chdir($scriptDir);	# change dir to the script dir
-
-	local(*F);
-	open(F, '>' . $_[0]) or die $!;
-	print F $_[1];
-	close(F);
-		
-	chdir($cwd);		# restore the cwd
-}
-
-sub _read_appath ($) {
-
-	my($filepath) = @_;
-
-	my($cwd) = cwd();	# remember the current working dir
-	chdir($scriptDir);	# change dir to the script dir
-	
-	if (! -e $filepath) {
-		return "";
-	}
-
-	local(*F);
-	open(F, $filepath);
-	my($appath) = <F>;
-	close(F);
-		
-	chdir($cwd);		# restore the cwd
-	return($appath);
-}
-
-
-sub _test ($) {
-	activate($ide_loc_file);
-	my($path) = $_[0];
-	build_project(
-	  "${path}modules:xml:macbuild:XML.mcp", '',
-	  "${path}build:mac:Mozilla.BuildLog.part"
-	);
-}
-
-1;
-
-=pod
-
-=back
-
-=head1 HISTORY
-
-=over 4
-
-=item v1.02, September 23, 1998
-
-Made fixes in finding and saving location of CodeWarrior IDE.
-
-=item v1.01, June 1, 1998
-
-Made fixes to C<chdir()> in C<activate()>, made C<activate()> more robust 
-in finding CodeWarrior IDE, added global variable to NOT switch to IDE
-for each sent event, a few other fixes.
-
-=item v1.00, May 30, 1998
-
-First shot
-
-=back
-
-
-=head1 AUTHORS
-
-Chris Nandor F<E<lt>pudge@pobox.comE<gt>>, and the author of the
-original I<CodeWarriorLib>, Scott Collins F<E<lt>scc@netscape.comE<gt>>.
-
-=head1 SEE ALSO
-
-BuildProject L<Moz>.
-
-=head1 COPYRIGHT
-
-The contents of this file are subject to the Netscape Public
-License Version 1.1 (the "License"); you may not use this file
-except in compliance with the License. You may obtain a copy of
-the License at http://www.mozilla.org/NPL/
-
-Software distributed under the License is distributed on an "AS
-IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
-implied. See the License for the specific language governing
-rights and limitations under the License.
-
-The Original Code is Mozilla Communicator client code, released
-March 31, 1998.
-
-The Initial Developer of the Original Code is Netscape
-Communications Corporation. Portions created by Netscape are
-Copyright (C) 1998-1999 Netscape Communications Corporation. All
-Rights Reserved.
-
-Contributor(s): 
-
-=cut

mozilla/build/mac/build_scripts/Moz/Jar.pm

@@ -1,576 +0,0 @@
-#!perl -w
-package Moz::Jar;
-
-#
-# Module for creating jar files, either using a jar manifest, or
-# simply jarring up folders on disk.
-#
-
-require 5.004;
-require Exporter;
-
-use strict;
-use Archive::Zip;
-use File::Path;
-
-use Mac::Files;
-
-use Moz::Moz;
-
-use vars qw( @ISA @EXPORT );
-
-@ISA        = qw(Exporter);
-@EXPORT     = qw(
-                    CreateJarFileFromDirectory
-                    CreateJarFromManifest
-                    WriteOutJarFiles
-                    SanityCheckJarOptions
-                );
-
-
-#-------------------------------------------------------------------------------
-# Add the contents of a directory to the zip file
-#
-#-------------------------------------------------------------------------------
-sub _addDirToJar($$$$)
-{
-    my($dir, $jar_root, $zip, $compress) = @_;
-
-    opendir(DIR, $dir) or die "Error: Cannot open dir $dir\n";
-    my @files = readdir(DIR);
-    closedir DIR;
-    
-    my $unix_jar_root = $jar_root;
-    $unix_jar_root =~ s|:|/|g;       # colon to slash conversion
-    
-    my $file;
-    
-    foreach $file (@files)
-    {        
-        my $filepath = $dir.":".$file;
-        
-        if (-d $filepath)
-        {
-            print "Adding files to jar from $filepath\n";            
-            _addDirToJar($filepath, $jar_root, $zip, $compress);
-        }
-        else
-        {
-            my $member = Archive::Zip::Member->newFromFile($filepath);
-            die "Error: Failed to create zip file member $filepath\n" unless $member;
-            
-            my $unixName = $filepath;
-            $unixName =~ s|:|/|g;               # colon to slash conversion
-            $unixName =~ s|^$unix_jar_root||;   # relativise
-            
-            $member->fileName($unixName);
-            
-            # print "Adding $file as $unixName\n";
-            
-            if ($compress) {
-                $member->desiredCompressionMethod(Archive::Zip::COMPRESSION_DEFLATED);            
-            } else {
-                $member->desiredCompressionMethod(Archive::Zip::COMPRESSION_STORED);
-            }
-            
-            $zip->addMember($member);
-        }
-    }
-}
-
-#-------------------------------------------------------------------------------
-# Add the contents of a directory to the zip file
-#
-#-------------------------------------------------------------------------------
-
-sub CreateJarFileFromDirectory($$$)
-{
-    my($srcdir, $jarpath, $compress) = @_;
-
-    my $zip = Archive::Zip->new();
-
-    _addDirToJar($srcdir, $srcdir, $zip, $compress);
-
-    print "Saving zip file...\n";
-    my $status = $zip->writeToFileNamed($jarpath);
-    if ($status == 0) {
-        print "Zipping completed successfully\n";
-    } else {
-        print "Error saving zip file\n";
-    }
-    
-    # set the file type/creator to something reasonable
-    MacPerl::SetFileInfo("ZIP ", "ZIP ", $jarpath);
-}
-
-
-#-------------------------------------------------------------------------------
-# printZipContents
-# 
-#-------------------------------------------------------------------------------
-sub printZipContents($)
-{
-    my($zip) = @_;
-
-    my(@members) = $zip->memberNames();
-    
-    print "Zip contains:\n";
-    
-    my($member);
-    foreach $member (@members)
-    {
-        print "  $member\n";
-    }
-}
-
-
-#-------------------------------------------------------------------------------
-# safeSaveJarFile
-# 
-# Archive::Zip has a problem where you cannot save a zip file on top of
-# an existing zip file that it has open, because it holds references
-# into that zip. So we have to save to a temp file, then do a swap.
-# 
-# Note that the zip will become invalid after this operation.
-# If you want to do further operations on it, you'll have to reread it.
-#-------------------------------------------------------------------------------
-sub safeSaveJarFile($$)
-{
-    my($zip, $full_dest_path) = @_;
-    
-    my($temp_file_name) = $full_dest_path."_temp";
-
-    ($zip->writeToFileNamed($temp_file_name) == Archive::Zip::AZ_OK) || die "Error: died writing jar to temp file $temp_file_name\n";
-    
-    unlink $full_dest_path;
-    
-    (rename $temp_file_name, $full_dest_path) || die "Error: Failed to rename $temp_file_name\n";
-    
-    MacPerl::SetFileInfo("ZIP ", "ZIP ", $full_dest_path);
-}
-
-
-#-------------------------------------------------------------------------------
-# addToJarFile
-# 
-# Add a file to a jar file
-#
-# Parameters:
-#   1. Jar ID. Unix path of jar file inside chrome.
-#   2. Abs path to jar.mn file (i.e. source)    (mac breaks)
-#   3. File source, relative to jar.mn path     (mac breaks)
-#   4. Abs path to the resulting .jar file      (mac breaks)
-#   5. Relative file path within the jar        (unix breaks)
-#   6. Reference to hash of jar files
-#
-#-------------------------------------------------------------------------------
-
-sub addToJarFile($$$$$$$)
-{
-    my($jar_id, $jar_man_dir, $file_src, $jar_path, $file_jar_path, $override, $jars) = @_;
-
-    # print "addToJarFile with:\n  $jar_man_dir\n  $file_src\n  $jar_path\n  $file_jar_path\n";
-
-    unless ($jar_path =~ m/(.+:)([^:]+)$/) { die "Error: Bad jar path $jar_path\n"; }
-    
-    my($target_dir) = $1;
-    my($jar_name) = $2;
-
-    $target_dir =~ s/[^:]+$//;
-    
-    # print "¥ $target_dir $jar_name\n";
-
-    # find the source file
-    my($src) = $jar_man_dir.":".$file_src;
-    if ((!-e $src) && ($file_src =~ m/.+:([^:]+)$/))    # src does not exist. Fall back to looking for src in jar.mn dir
-    {
-        $file_src = $1;
-        $src = $jar_man_dir.":".$file_src;
-        
-        if (!-e $src) {
-            die "Error: Can't find chrome file $src\n";
-        }
-    }
-    
-    if ($main::options{chrome_jars})
-    {
-        my($zip) = $jars->{$jar_id};
-        unless ($zip) { die "Error: Can't find Zip entry for $jar_id\n"; }
-        
-        # print "Adding $file_src to jar file $jar_path at $file_jar_path\n";
-        my($member) = Archive::Zip::Member->newFromFile($src);
-        unless ($member) { die "Error: Failed to create zip file member $src\n"; }
-
-        $member->fileName($file_jar_path);    
-    
-        my($compress) = 1;
-        if ($compress) {
-            $member->desiredCompressionMethod(Archive::Zip::COMPRESSION_DEFLATED);            
-            $member->desiredCompressionLevel(Archive::Zip::COMPRESSION_LEVEL_DEFAULT);   # defaults to 6
-        } else {
-            $member->desiredCompressionMethod(Archive::Zip::COMPRESSION_STORED);
-        }
-
-        my($old_member) = $zip->memberNamed($file_jar_path);
-        
-        if ($override)
-        {
-            if ($old_member)
-            {
-                # print "Overriding $file_jar_path in jar file $jar_id\n";
-                # need to compare mod dates or use the + here
-                $zip->removeMember($old_member);
-            }
-        
-            $zip->addMember($member);
-        }
-        else
-        {
-            if ($old_member)
-            {
-                #compare dates here
-                my($member_moddate) = $old_member->lastModTime();
-                my($file_moddate) = GetFileModDate($src);
-            
-                if ($file_moddate > $member_moddate)
-                {
-                    print "Updating older file $file_jar_path in $jar_id\n";
-                    $zip->removeMember($old_member);
-                    $zip->addMember($member);
-                }
-                else
-                {
-                    print "File $file_jar_path in $jar_id is more recent. Not updating.\n";
-                }
-            }
-            else
-            {
-                $zip->addMember($member);
-            }
-        }
-    }
-    
-    if ($main::options{chrome_files})  # we install raw files too
-    {
-        my($rel_path) = $file_jar_path;
-        $rel_path =~ s|/|:|g;       # slash to colons
-        
-        my($dir_name) = $jar_name;
-        $dir_name =~ s/\.jar$//;
-        
-        my($dst) = $target_dir.$dir_name.":".$rel_path;
-                
-        # print "Aliassing $src\n to\n$dst\n";        
-        if ($override)
-        {
-            unlink $dst;
-        MakeAlias($src, $dst);      # don't check errors, otherwise we fail on replacement
-    }
-        else
-        {
-            if (-e $dst)
-            {
-                #compare dates here
-                my($dst_moddate) = GetFileModDate($dst);
-                my($file_moddate) = GetFileModDate($src);
-            
-                if ($file_moddate > $dst_moddate)
-                {
-                    print "Updating older file $rel_path in $dir_name\n";
-                    unlink $dst;
-                    MakeAlias($src, $dst);
-                }
-                else
-                {
-                    print "File $file_jar_path in $jar_id is more recent. Not updating.\n";
-                }
-            
-            }
-            else
-            {
-                MakeAlias($src, $dst);
-            }
-        }
-        
-    }
-}
-
-
-#-------------------------------------------------------------------------------
-# setupJarFile
-# 
-# setup a zip for writing
-#-------------------------------------------------------------------------------
-
-sub setupJarFile($$$)
-{
-    my($jar_id, $dest_path, $jar_hash) = @_;
-
-    # print "Creating jar file $jar_id at $jar_path\n";
-    
-    my($jar_file) = $jar_id;
-    $jar_file =~ s|/|:|g;           # slash to colons
-    my($full_jar_path) = full_path_to($dest_path.":".$jar_file);
-
-    if ($main::options{chrome_jars})
-    {
-        my($zip) = $jar_hash->{$jar_id};
-        if (!$zip)      # if we haven't made it already, do so
-        {
-	        my($zip) = Archive::Zip->new();
-	        $jar_hash->{$jar_id} = $zip;
-
-            # does the jar file exist already? If so, read it in
-            if (-e $full_jar_path)
-            {
-                print "Reading in jar file $jar_id\n";
-                if ($zip->read($full_jar_path) != Archive::Zip::AZ_OK) { die "Error: Failed to re-read $full_jar_path\n"; }
-                
-                # printZipContents($zip);
-            }
-
-        }
-    }
-    else
-    {
-        # installing files.
-        # nothing to do. MakeAlias creates dirs as needed.
-
-	    # add this jar to the list
-	    $jar_hash->{$jar_id} = 1;
-    }
-}
-
-
-#-------------------------------------------------------------------------------
-# closeJarFile
-# 
-# We're done with this jar file _for this jar.mn_. We may add more entries
-# to it later, so keep it open in the hash.
-#-------------------------------------------------------------------------------
-sub closeJarFile($$)
-{
-    my($jar_path, $jar_hash) = @_;
-
-    # print "Closing jar file $jar_path\n";
-
-    if ($main::options{chrome_jars})
-    {
-    
-    }
-    else
-    {
-        # installing files.
-        # nothing to do
-    }
-}
-
-
-#-------------------------------------------------------------------------------
-# WriteOutJarFiles
-# 
-# Now we dump out the jars
-#-------------------------------------------------------------------------------
-sub WriteOutJarFiles($$)
-{
-    my($chrome_dir, $jars) = @_;
-
-    unless ($main::options{chrome_jars}) { return; }
-    
-    my($full_chrome_path) = full_path_to($chrome_dir);
-
-    my($key);
-    foreach $key (keys %$jars)
-    {
-        my($zip) = $jars->{$key};
-        
-        my($rel_path) = $key;
-        $rel_path =~ s/\//:/g;
-        
-        my($output_path) = $full_chrome_path.":".$rel_path;
-        
-        print "Writing zip file $key to $output_path\n";
-
-        # ensure the target dirs exist
-        my($path) = $output_path;
-        $path =~ s/[^:]+$//;
-        mkpath($path);
-        
-        # unlink $output_path;        # remove any existing jar
-        safeSaveJarFile($zip, $output_path);
-        # $zip is invalid after this operation, so nuke it here
-        $jars->{$key} = 0;
-    }
-}
-
-
-#-------------------------------------------------------------------------------
-# registerChromePackage
-# 
-# Enter a chrome package into the installed-chrome.txt file
-#-------------------------------------------------------------------------------
-sub registerChromePackage($$$$$$)
-{
-    my($jar_file, $file_path, $chrome_dir, $jar_hash, $chrome_type, $pkg_name) = @_;
-
-    my($manifest_subdir) = $jar_file;
-    $manifest_subdir =~ s/:/\//g;
-    
-    if (index($manifest_subdir, "-unix") == -1 && index($manifest_subdir, "-win") == -1) {
-
-    my($chrome_entry);
-    
-    if ($main::options{use_jars}) {
-        $chrome_entry = "$chrome_type,install,url,jar:resource:/chrome/$manifest_subdir!/$chrome_type/$pkg_name";
-    } else {
-        $manifest_subdir =~ s/\.jar$//;
-        $chrome_entry = "$chrome_type,install,url,resource:/chrome/$manifest_subdir/$chrome_type/$pkg_name";
-    }
-
-    # print "Entering $chrome_entry in installed-chrome.txt\n";
-    
-    # ensure chrome_dir exists
-    mkpath($chrome_dir);
-    
-    my($inst_chrome) = ${chrome_dir}.":installed-chrome.txt";
-    
-    if (open(CHROMEFILE, "<$inst_chrome")) {
-        while (<CHROMEFILE>) {
-            chomp;
-            if ($_ eq $chrome_entry) {
-                # $chrome_entry already appears in installed-chrome.txt file
-                # just update the mod date
-                my $now = time;
-                utime($now, $now, $inst_chrome) || die "Error: Couldn't touch $inst_chrome";
-                print "+++ updating chrome $inst_chrome\n+++\t\t$chrome_entry\n";
-                close(CHROMEFILE) || die "Error: can't close $inst_chrome: $!";
-                return 0;
-            }
-        }
-        close(CHROMEFILE) || die "Error: can't close $inst_chrome: $!";
-    }
-    open(CHROMEFILE, ">>${inst_chrome}") || die "Error: Failed to open $inst_chrome\n";
-    print(CHROMEFILE "${chrome_entry}\n");
-    close(CHROMEFILE) || die "Error: Failed to close $inst_chrome\n";
-    print "+++ adding chrome $inst_chrome\n+++\t\t$chrome_entry\n";
-  }
-}
-
-#-------------------------------------------------------------------------------
-# Create or add to a jar file from a jar.mn file.
-# Both arguments are relative to the mozilla root dir.
-#
-#
-#-------------------------------------------------------------------------------
-sub CreateJarFromManifest($$$)
-{
-    my($jar_man_path, $dest_path, $jars) = @_;
-    
-    if ($main::options{chrome_jars}) {
-        print "Jarring from $jar_man_path\n";
-    }
-    if ($main::options{chrome_files}) {
-        print "Installing files from $jar_man_path\n";
-    }
-
-    $jar_man_path = full_path_to($jar_man_path);
-    $dest_path = full_path_to($dest_path);
-
-    # if the jars hash is empty, nuke installed-chrome.txt
-    if (! scalar(%$jars))
-    {
-        print "Nuking installed-chrome.txt\n";
-	    my($installed_chrome) = $dest_path.":installed-chrome.txt";
-	    # unlink $installed_chrome;
-    }
-    
-    my $jar_man_dir = "";
-    my $jar_man_file = "";
-    
-    if ($jar_man_path =~ /(.+):([^:]+)$/)
-    {
-        $jar_man_dir = $1;      # no trailing :
-        $jar_man_file = $2;
-    }
-
-    # Keep a hash of jar files, keyed on relative jar path (e.g. "packages/core.jar")
-    # Entries are open Archive::Zips (if zipping), and installed-chrome entries.
-    
-    my($jar_id) = "";       # Current foo/bar.jar from jar.mn file
-    my($jar_file) = "";     # relative path to jar file (from $dest_path), with mac separators
-    my($full_jar_path);
-    
-    open(FILE, "<$jar_man_path") || die "Error: could not open \"$jar_man_path\": $!";
-    while (<FILE>)
-    {
-        my($line) = $_;
-        chomp($line);
-        
-        # print "$line\n";
-        
-        if ($line =~ /^\s*\#.*$/) {     # skip comments
-            next;
-        }
-        
-        if ($line =~/^([\w\d.\-\_\\\/]+)\:\s*$/)                                  # line start jar file entries
-        {
-            $jar_id = $1;
-            $jar_file = $jar_id;
-            $jar_file =~ s|/|:|g;           # slash to colons
-            $full_jar_path = $dest_path.":".$jar_file;
-                        
-            setupJarFile($jar_id, $dest_path, $jars);
-
-        }
-        elsif ($line =~ /^(\+?)\s+([\w\d.\-\_\\\/]+)\s*(\([\w\d.\-\_\\\/]+\))?$\s*/)     # jar file entry
-        {
-            my($override) = ($1 eq "+");
-            my($file_dest) = $2;
-            my($file_src) = $3;
- 
-            if ($file_src) {  
-                $file_src = substr($file_src, 1, -1);      #strip the ()
-            } else {
-                $file_src = $file_dest;
-            }
-            
-            $file_src =~ s|/|:|g;
-            
-            if ($jar_file ne "")    # if jar is open, add to jar
-            {
-                if ($file_dest =~ /([\w\d.\-\_]+)\/([\w\d.\-\_\\\/]+)contents.rdf/)
-                {
-                    my $chrome_type = $1;
-                    my $pkg_name = $2;
-                    registerChromePackage($jar_file, $file_dest, $dest_path, $jars, $chrome_type, $pkg_name);
-                }
-                
-                addToJarFile($jar_id, $jar_man_dir, $file_src, $full_jar_path, $file_dest, $override, $jars);
-            }
-            else
-            {
-                die "Error: bad jar.mn format at $line\n";
-            }
-        }
-        elsif ($line =~ /^\s*$/ )                                               # blank line
-        {
-            if ($jar_file ne "")    #if a jar file is open, close it
-            {
-                closeJarFile($full_jar_path, $jars);
-                
-                $jar_file = "";
-                $full_jar_path = "";
-            }
-        }
-    }
-    
-    close(FILE);
-
-    if ($jar_file ne "")    #if a jar file is open, close it
-    {
-        closeJarFile($full_jar_path, $jars);
-    }
-
-}
-
-1;

mozilla/build/mac/build_scripts/Moz/MacCVS.pm

@@ -1,228 +0,0 @@
-#!perl -w
-package Moz::MacCVS;
-
-# package Mac::Apps::MacCVS; this should really be the name of the package
-# but due to our directory hierarchy in mozilla, I am not doing it
-
-require 5.004;
-require Exporter;
-
-use strict;
-use Exporter;
-
-use vars qw($VERSION @ISA @EXPORT);
-
-use Cwd;
-
-use File::Basename;
-
-use Mac::StandardFile;
-use Mac::AppleEvents;
-use Mac::AppleEvents::Simple;
-
-@ISA        = qw(Exporter);
-@EXPORT     = qw(new describe checkout update);
-$VERSION = "1.00";
-
-# If you want to understand the gobbldeygook that's used to build Apple Events,
-# you should start by reading the AEGizmos documentation.
-
-
-# Architecture:
-# cvs session object:
-# name - session name
-# session_file - session file
-# 
-# 
-
-my($last_error) = 0;
-my($gAppSig)    = 'Mcvs';   # MacCVS Pro
-
-#
-# utility routines
-#
-
-
-sub _checkForEventError($)
-{
-  my($evt) = @_;
-
-  if ($evt->{ERRNO} != 0)
-  {
-    print STDERR "Error. Script returned '$evt->{ERROR} (error $evt->{ERRNO})\n";
-    $last_error = $evt->{ERRNO};
-    return 0;
-  }
-  
-  return 1; # success
-}
-
-
-#
-# Session object methods
-#
-
-sub new
-{
-  my ( $proto, $session_file) = @_;
-  my $class = ref($proto) || $proto;
-  my $self = {};
-
-  if ( defined($session_file) && ( -e $session_file) )
-  {
-    $self->{"name"} = basename( $session_file );
-    $self->{"session_file"} = $session_file;
-    bless $self, $class;
-    return $self;
-  }
-  else
-  {
-    print STDERR "MacCVS->new cvs file < $session_file > does not exist\n";
-    return;
-  }
-}
-
-# makes sure that the session is open
-# assertSessionOpen()
-# returns 1 on success
-sub assertSessionOpen()
-{
-  my ($self) = shift;
-
-  $last_error = 0;
-
-  my($prm) =
-    q"'----':obj {form:name, want:type(alis), seld:TEXT(@), from:'null'()}";
-
-  my($evt) = do_event(qw/aevt odoc/, $gAppSig, $prm, $self->{session_file});
-  return _checkForEventError($evt);
-}
-
-# prints the cvs object, used mostly for debugging
-sub describe
-{
-  my($self) = shift;
-  $last_error = 0;
-  print "MacCVS:: name: ", $self->{name}, " session file: ", $self->{session_file}, "\n";
-}
-
-# checkout( self, module, revision, date)
-# MacCVS checkout command
-# returns 1 on success.
-sub checkout()
-{
-  my($self, $module, $revision, $date ) = @_;
-  unless( defined ($module) ) { $module = ""; } # get rid of the pesky undefined warnings
-  unless( defined ($revision) ) { $revision = ""; }
-  unless( defined ($date) ) { $date = ""; }
-
-  $last_error = 0;
-    
-  $self->assertSessionOpen() || die "Error: failed to open MacCVS session file at $self->{session_file}\n";
-  
-  my($revstring) = ($revision ne "") ? $revision : "(none)";
-  my($datestring) = ($date ne "") ? $date : "(none)";
-  
-  print "Checking out $module with revision $revstring, date $datestring\n";
-
-  my($prm) =
-    q"'----':obj {form:name, want:type(docu), seld:TEXT(@), from:'null'()}, ".
-    q"modl:'TEXT'(@), tagr:'TEXT'(@), tagd:'TEXT'(@) ";
-  
-  my($evt) = do_event(qw/MCvs cout/, $gAppSig, $prm, $self->{name}, $module, $revision, $date);
-  return _checkForEventError($evt);
-}
-
-
-# update( self, branch tag, list of paths)
-# MacCVS udate command
-# returns 1 on success.
-# NOTE: MacCVS Pro does not correctly support this stuff yet (as of version 2.7d5).
-sub update()
-{
-  my($self, $branch, $paths ) = @_;
-
-  $last_error = 0;
-    
-  $self->assertSessionOpen() || die "Error: failed to open MacCVS session file at $self->{session_file}\n";
-
-  if ($branch eq "HEAD") {
-    $branch = "";
-  }
-  
-  my($paths_list) = "";
-  
-  my($path);
-  foreach $path (@$paths)
-  {
-    if ($paths_list ne "") {
-      $paths_list = $paths_list.", ";
-    }
-    
-    $paths_list = $paths_list."Ò".$path."Ó";
-  }
-    
-  my($prm) =
-    q"'----':obj {form:name, want:type(docu), seld:TEXT(@), from:'null'()}, ".
-    q"tagr:'TEXT'(@), tFls:[";
-
-  $prm = $prm.$paths_list."]";
-    
-  my($evt) = do_event(qw/MCvs updt/, $gAppSig, $prm, $self->{name}, $branch);
-  return _checkForEventError($evt);
-};
-
-
-sub getLastError()
-{
-  return $last_error;
-}
-
-1;
-=pod
-
-=head1 NAME
-
-MacCVS - Interface to MacCVS
-
-=head1 SYNOPSIS
-
-  use MacCVS;
-  $session = MacCVS->new( <session_file_path>) || die "cannot create session";
-  $session->checkout([module] [revision] [date]) || die "Could not check out";
-    
-=head1 DESCRIPTION
-
-This is a MacCVS interface for talking to MacCVS Pro client.
-MacCVSSession is the class used to manipulate the session
-
-=item new
-  MacCVS->new( <cvs session file path>);
-  
-  Creates a new session. Returns undef on failure.
-
-=item checkout( <module> [revision] [date] )
-
-  cvs checkout command. Revision and date are optional
-  returns 0 on failure
-  
-=cut
-
-=head1 SEE ALSO
-
-=over
-
-=item MacCVS Home Page
-
-http://www.maccvs.org/
-
-=back 
-
-=head1 AUTHORS
-
-Aleks Totic atotic@netscape.com
-Simon Fraser sfraser@netscape.com
-
-=cut
-
-__END__

mozilla/build/mac/build_scripts/Moz/Moz.pm

@@ -1,603 +0,0 @@
-=head1 NAME
-
-B<Moz> - routines for automating CodeWarrior builds, and some extra-curricular
-activities related to building Mozilla
-
-=head1 SYNOPSIS
-
-    use Moz;
-
-    OpenErrorLog(":::BuildLog");
-    StopForErrors();
-
-		$Moz::QUIET = 1;
-		InstallFromManifest(":projects:MANIFEST", $dist_dir);
-
-    BuildProjectClean(":projects:SomeProject.mcp", "SomeTarget");
-    MakeAlias(":projects:SomeProject.shlb", $dist_dir);
-
-    DontStopForErrors();
-
-    BuildProject(":projects:SomeOtherProject.mcp", "SomeTarget");
-
-=head1 DESCRIPTION
-
-B<Moz> comprises the routines needed to slap CodeWarrior around, force it
-to build a sequence of projects, report the results, and a few other things.
-This module should only contain functions that are generic to any build,
-not just the Mozilla build.
-
-=cut
-
-
-package			Moz::Moz;
-require			Exporter;
-
-use Cwd;
-
-use File::Copy;
-use File::Path;
-use File::Basename;
-
-use Mac::Types;
-use Mac::Events;
-use Mac::Processes;
-
-use ExtUtils::Manifest 'maniread';
-
-use Moz::CodeWarriorLib;
-
-@ISA				= qw(Exporter);
-
-@EXPORT			= qw( LaunchCodeWarrior
-                  GetCodeWarriorRelativePath
-                  current_directory
-                  full_path_to
-                  DoBuildProject
-                  ImportXMLProject
-                  ExportProjectToXML
-                  OpenErrorLog
-                  MakeAlias
-                  GetFileModDate
-                  StopForErrors
-                  DontStopForErrors
-                  InstallFromManifest
-                  InstallResources
-                  RedirectOutputToFile
-                  Delay
-                  ActivateApplication
-                  IsProcessRunning);
-
-@EXPORT_OK	= qw(CloseErrorLog QUIET);
-
-
-sub current_directory()
-	{
-		my $current_directory = cwd();
-		chop($current_directory) if ( $current_directory =~ m/:$/ );
-		return $current_directory;
-	}
-
-sub full_path_to($)
-	{
-		my ($path) = @_;
-		if ( $path =~ m/^[^:]+$/ )
-			{
-				$path = ":" . $path;
-			}
-
-		if ( $path =~ m/^:/ )
-			{
-				$path = current_directory() . $path;
-			}
-
-		return $path;
-	}
-
-$logging								= 0;
-$recent_errors_file			= "";
-$stop_on_1st_error			= 1;
-$QUIET									= 0;
-
-
-
-=head2 Logging all the errors and warnings - C<OpenErrorLog($log_file)>, C<CloseErrorLog()>
-
-The warnings and errors generated in the course of building projects can be logged to a file.
-Tinderbox uses this facility to show why a remote build failed.
-
-Logging is off by default.
-  Start logging at any point in your build process with C<OpenErrorLog($log_file)>.
-  Stop with C<CloseErrorLog()>.
-  You never need to close the log explicitly, unless you want to just log a couple of projects in the middle of a big list.
-  C<CloseErrorLog()> is not exported by default. 
-
-=cut
-
-sub CloseErrorLog()
-	{
-		if ( $logging )
-			{
-				close(ERROR_LOG);
-				$logging = 0;
-				StopForErrors() if $stop_on_1st_error;
-			}
-	}
-
-
-
-sub OpenErrorLog($)
-	{
-		my ($log_file) = @_;
-
-		CloseErrorLog();
-		if ( $log_file )
-			{
-				$log_file = full_path_to($log_file);
- 
-				open(ERROR_LOG, ">$log_file") || die "Error: Can't open $log_file\n";
-				MacPerl::SetFileInfo("CWIE", "TEXT", $log_file);
-
-				$log_file =~ m/.+:(.+)/;
-				$recent_errors_file = full_path_to("$1.part");
-				$logging = 1;
-			}
-	}
-
-
-=head2 Stopping before it's too late - C<StopForErrors()>, C<DontStopForErrors()>
-
-When building a long list of projects, you decide whether to continue building subsequent projects when one fails.
-  By default, your build script will C<die> after the first project that generates an error while building.
-  Change this behavior with C<DontStopForErrors()>.
-  Re-enable it with C<StopForErrors()>.
-
-=cut
-
-sub StopForErrors()
-	{
-		$stop_on_1st_error = 1;
-		
-			# Can't stop for errors unless we notice them.
-			# Can't notice them unless we are logging.
-			# If the user didn't explicitly request logging, log to a temporary file.
-
-		if ( ! $recent_errors_file )
-			{
-				OpenErrorLog("${TMPDIR}BuildResults");
-			}
-	}
-
-sub DontStopForErrors()
-	{
-		$stop_on_1st_error = 0;		
-	}
-
-sub log_message($)
-	{
-		if ( $logging )
-			{
-				my ($message) = @_;
-				print ERROR_LOG $message;
-			}
-	}
-
-sub log_message_with_time($)
-	{
-		if ( $logging )
-			{
-				my ($message) = @_;
-				my $time_stamp = localtime();
-				log_message("$message ($time_stamp)\n");
-			}
-	}
-
-sub log_recent_errors($)
-	{
-		my ($project_name) = @_;
-		my $found_errors = 0;
-	
-		if ( $logging )
-			{
-				open(RECENT_ERRORS, "<$recent_errors_file");
-
-				while( <RECENT_ERRORS> )
-					{
-						if ( /^Error/ || /^CouldnÕt find project file/ || /^Link Error/ )
-							{
-#								if (!$found_errors)
-#									print $_;
-								$found_errors = 1;
-							}
-						print ERROR_LOG $_;
-					}
-
-				close(RECENT_ERRORS);
-				unlink("$recent_errors_file");
-			}
-		
-		if ( $stop_on_1st_error && $found_errors )
-			{
-				print ERROR_LOG "### Build failed.\n";
-				die "### Errors encountered building \"$project_name\".\n";
-			}
-	}
-	
-sub DoBuildProject($$$)
-	{
-		my ($project_path, $target_name, $clean_build) = @_;
-		$project_path = full_path_to($project_path);
-
-#		$project_path =~ m/.+:(.+)/;
-#		my $project_name = $1;
-
-		log_message_with_time("### Building \"$project_path\"");
-
-			# Check that the given project exists
-		if (! -e $project_path)
-			{
-				print ERROR_LOG "### Build failed.\n";
-				die "### Can't find project file \"$project_path\".\n";
-			}
-		
-		print "Building \"$project_path\[$target_name\]\"\n";
-		
-		$had_errors = Moz::CodeWarriorLib::build_project(
-			$project_path, $target_name, $recent_errors_file, $clean_build
-		);
-		WaitNextEvent();
-
-#		$had_errors =
-#MacPerl::DoAppleScript(<<END_OF_APPLESCRIPT);
-#	tell (load script file "$CodeWarriorLib") to BuildProject("$project_path", "$project_name", "$target_name", "$recent_errors_file", $clean_build)
-#END_OF_APPLESCRIPT
-
-			# Append any errors to the globally accumulated log file
-#		if ( $had_errors ) # Removed this test, because we want warnings, too.  -- jrm
-			{
-				log_recent_errors($project_path);
-			}
-	}
-
-
-sub ImportXMLProject($$)
-{
-    my ($xml_path, $project_path) = @_;
-
-#    my ($codewarrior_ide_name) = Moz::CodeWarriorLib::getCodeWarriorIDEName();
-#    my $ascript = <<EOS;
-#      tell application "$codewarrior_ide_name"
-#        make new (project document) as ("$project_path") with data ("$xml_path")
-#      end tell
-#EOS
-#    print $ascript."\n";
-#    my($result) = MacPerl::DoAppleScript($ascript);
-#    unless ($result) { die "Error: ImportXMLProject AppleScript failed $^E $result\n";  }
-#    
-
-    my($import_error) = Moz::CodeWarriorLib::import_project($xml_path, $project_path);
-    if ($import_error ne "") {
-      die "Error: ImportXMLProject failed with error $import_error\n";
-    }
-}
-
-sub ExportProjectToXML($$)
-{
-    my ($project_path, $xml_path) = @_;
-
-    my (@suffix_list) = (".mcp");
-    my ($project_name, $project_dir, $suffix) = fileparse($project_path, @suffix_list);
-    if ($suffix eq "") { die "Project: $project_path doesn't look like a project file.\n"; }
-    
-    if (-e $xml_path) {
-        print "$xml_path exists - not exporting $project_path\n";
-    }
-    else {
-        print "Exporting $project_path to $xml_path\n";
-        my($export_error) = Moz::CodeWarriorLib::export_project($project_path, $xml_path);
-        if ($export_error ne "") {
-            die "Error: export_project failed with error '$export_error'\n";
-        }
-        
-        if (! -e $xml_path) {
-          die "Error: XML export to $xml_path failed\n";
-        }
-    }
-}
-
-
-=head2 Miscellaneous
-
-C<MakeAlias($old_file, $new_file)> functions like C<symlink()>, except with better argument defaulting and more explicit error messages.
-
-=cut
-
-sub MakeAlias($$)
-	{
-		my ($old_file, $new_file) = @_;
-
-			# if the directory to hold $new_file doesn't exist, create it
-		if ( ($new_file =~ m/(.+:)/) && !-d $1 )
-			{
-				mkpath($1);
-			}
-
-			# if a leaf name wasn't specified for $new_file, use the leaf from $old_file
-		if ( ($new_file =~ m/:$/) && ($old_file =~ m/.+:(.+)/) )
-			{
-				$new_file .= $1;
-			}
-
-		my $message = "Can't create a Finder alias (at \"$new_file\")\n for \"$old_file\"; because ";
-
-		die "Error: $message \"$old_file\" doesn't exist.\n" unless -e $old_file;
-		die "Error: $message I won't replace an existing (non-alias) file with an alias.\n" if ( -e $new_file && ! -l $new_file );
-
-			# now: $old_file exists; $new_file doesn't (or else, is an alias already)
-
-		if ( -l $new_file )
-			{
-					# ...then see if it already points to $old_file
-				my $current_target	= full_path_to(readlink($new_file));
-				my $new_target			= full_path_to($old_file);
-
-				return if ( $current_target eq $new_target );
-					# if the desired alias already exists and points to the right thing, then we're done
-				
-				unlink $new_file;
-			}
-		
-		symlink($old_file, $new_file) || die "Error: $message symlink returned an unexpected error.\n";
-	}
-	
-	
-=pod
-
-C<InstallFromManifest()>
-
-=cut
-
-sub InstallFromManifest($;$$)
-	{
-		my ($manifest_file, $dest_dir, $flat) = @_;
-		
-		$flat = 0 unless defined($flat); # if $flat, all rel. paths in MANIFEST get aliased to the root of $dest_dir
-
-		$dest_dir ||= ":";
-
-		$manifest_file =~ m/(.+):/;
-		my $source_dir =  $1;
-
-		chop($dest_dir) if $dest_dir =~ m/:$/;
-
-		#Mac::Events->import();
-		WaitNextEvent();
-		if ($flat)
-		{
-			print "Doing manifest on \"$manifest_file\" FLAT\n" unless $QUIET;
-		}
-		else
-		{
-			print "Doing manifest on \"$manifest_file\"\n" unless $QUIET;
-		}
-		
-		my $read = maniread(full_path_to($manifest_file));
-		foreach $file (keys %$read)
-			{
-				next unless $file;
-
-				$subdir = ":";
-				if (!$flat && ($file =~ /:.+:/ ))
-					{
-						$subdir = $&;
-					}
-
-				$file = ":$file" unless $file =~ m/^:/;
-				MakeAlias("$source_dir$file", "$dest_dir$subdir");
-			}
-	}
-
-
-=pod
-
-C<InstallResources()>
-
-=cut
-
-# parameters are path to MANIFEST file, destination dir, true (to make copies) or false (to make aliases)
-sub InstallResources($;$;$)
-	{
-		my ($manifest_file, $dest_dir, $copy_files) = @_;
-
-		$dest_dir ||= ":";
-		mkpath($dest_dir) if !-d $dest_dir;
-
-		$manifest_file =~ m/(.+):/;
-		my $source_dir =  $1;
-
-		chop($dest_dir) if $dest_dir =~ m/:$/;
-
-		WaitNextEvent();
-		print "Installing resources from \"$manifest_file\"\n" unless $QUIET;
-		
-		my $read = maniread(full_path_to($manifest_file));
-		foreach $file (keys %$read)
-			{
-				next unless $file;
-				
-				if ($copy_files)
-					{
-						copy("$source_dir:$file", "$dest_dir:$file");
-					}
-				else
-					{
-						MakeAlias("$source_dir:$file", "$dest_dir:$file");
-					}
-			}
-	}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// Delay
-#//--------------------------------------------------------------------------------------------------
-sub Delay($)		
-{
-  my ($delay_seconds) = @_;
-
-  $now = time;
-  
-  $exit_time = $now + $delay_seconds;
-
-  while ($exit_time > $now) {
-     $now = time;
-  }
-	
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// GetFileModDate
-#//--------------------------------------------------------------------------------------------------
-sub GetFileModDate($)
-{
-    my($filePath)=@_;
-    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
-        $atime,$mtime,$ctime,$blksize,$blocks) = stat($filePath);
-    return $mtime;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// LaunchCodeWarrior
-#//--------------------------------------------------------------------------------------------------
-sub LaunchCodeWarrior($)
-{
-  my($idepath_file) = @_;   # full path to IDE location file
-  my($cur_dir) = cwd();
-  
-  # this both launches and writes the IDE path file
-  Moz::CodeWarriorLib::activate($idepath_file);
-  
-  chdir($cur_dir);
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// GetCodeWarriorRelativePath
-#//--------------------------------------------------------------------------------------------------
-sub GetCodeWarriorRelativePath($)
-{
-  my($rel_path) = @_;
-  return Moz::CodeWarriorLib::getCodeWarriorPath($rel_path);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// RedirectOutputToFile
-#//--------------------------------------------------------------------------------------------------
-sub RedirectOutputToFile($)
-{
-    my($log_file) = @_;
-    
-    # ensure that folders in the path exist
-    my($logdir) = "";
-    my($logfile) = $log_file;
-    
-    if ($log_file =~ /(.+?:)([^:]+)$/)       # ? for non-greedy match
-    {
-        $logdir = $1;
-        $logfile = $2;
-        
-        mkpath($logdir);
-    }
-
-    print "Output is now being redirected to the file '$log_file'\n";
-    
-    open(STDOUT, "> $log_file") || die "Can't redirect stdout";
-    open(STDERR, ">&STDOUT") || die "Can't dup stdout";
-    select(STDERR); $| = 1;     # make unbuffered
-    select(STDOUT); $| = 1;     # make unbuffered
-    
-    MacPerl::SetFileInfo("CWIE", "TEXT", $log_file);
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// ActivateApplication
-#//--------------------------------------------------------------------------------------------------
-
-sub ActivateApplication($)
-{
-	my ($appSignature) = @_;
-	my ($psi, $found);
-	my ($appPSN);
-	
-	$found = 0;
-		
-	foreach $psi (values(%Process))
-	{
-		if ($psi->processSignature() eq $appSignature)
-		{
-			$appPSN = $psi->processNumber();
-			$found = 1;
-            last;
-		}
-	}
-
-	if ($found == 0 || SameProcess($appPSN, GetFrontProcess()))
-	{
-		return;
-	}
-
-	SetFrontProcess($appPSN);
-
-	while (GetFrontProcess() != $appPSN)
-	{
-		WaitNextEvent();
-	}
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// IsProcessRunning
-#//--------------------------------------------------------------------------------------------------
-
-sub IsProcessRunning($)
-{
-    my($processName, $psn, $psi) = @_;
-    while ( ($psn, $psi) = each(%Process) ) {
-     if ($psi->processName eq $processName) { return 1; }
-    }
-    return 0;
-}
-
-
-1;
-
-=head1 AUTHORS
-
-Scott Collins <scc@netscape.com>, Simon Fraser <sfraser@netscape.com>, Chris Yeh <cyeh@netscape.com>
-
-=head1 SEE ALSO
-
-BuildMozillaDebug.pl (et al), BuildList.pm, CodeWarriorLib (an AppleScript library)
-
-=head1 COPYRIGHT
-
-The contents of this file are subject to the Netscape Public
-License Version 1.1 (the "License"); you may not use this file
-except in compliance with the License. You may obtain a copy of
-the License at http://www.mozilla.org/NPL/
-
-Software distributed under the License is distributed on an "AS
-IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
-implied. See the License for the specific language governing
-rights and limitations under the License.
-
-The Original Code is Mozilla Communicator client code, released
-March 31, 1998.
-
-The Initial Developer of the Original Code is Netscape
-Communications Corporation. Portions created by Netscape are
-Copyright (C) 1998-1999 Netscape Communications Corporation. All
-Rights Reserved.
-
-Contributor(s): 
-
-=cut

mozilla/build/mac/build_scripts/Moz/Prefs.pm

@@ -1,272 +0,0 @@
-
-package Moz::Prefs;
-
-require 5.004;
-require Exporter;
-
-# Package that attempts to read a file from the Preferences folder,
-# and get build settings out of it
-
-use strict;
-
-use Exporter;
-use File::Path;
-
-use Mac::Files;
-
-use vars qw(@ISA @EXPORT);
-
-@ISA		  = qw(Exporter);
-@EXPORT 	= qw(ReadMozUserPrefs);
-
-
-#-------------------------------------------------------------------------------
-#
-# GetPrefsFolder
-#
-#-------------------------------------------------------------------------------
-
-sub GetPrefsFolder()
-{
-  my($prefs_folder) = FindFolder(kOnSystemDisk, kPreferencesFolderType, 1);
-  return $prefs_folder.":Mozilla build prefs";
-}
-
-
-#-------------------------------------------------------------------------------
-#
-# SetArrayValue
-#
-#-------------------------------------------------------------------------------
-sub SetArrayValue($$$)
-{
-  my($array_ref, $index1, $index2) = @_;
-
-  my($index);
-  foreach $index (@$array_ref)
-  {
-    if ($index->[0] eq $index1)
-    {
-      $index->[1] = $index2;
-      return 1;
-    }
-  }
-  
-  return 0;
-}
-
-
-#-------------------------------------------------------------------------------
-#
-# WriteDefaultPrefsFile
-#
-#-------------------------------------------------------------------------------
-
-sub WriteDefaultPrefsFile($)
-{
-  my($file_path) = @_;
-
-  my($file_contents);
-  $file_contents = <<'EOS';
-% You can use this file to customize the Mozilla build system.
-% The following kinds of lines are allowable:
-%   Comment lines, which start with a '%' in the first column
-%   Lines which modify the default build settings. For the list of flags,
-%   see MozBuildFlags.pm. Examples are:
-%
-%    build       pull            0                    % don't pull
-%    options     mng             1                    % turn mng on
-%   
-%   Line containing the special 'buildfrom' flag, which specifies
-%   where to start the build. Example:
-%   
-%    buildfrom   nglayout                % where to start the build
-%
-%   Lines which specify the location of the files used to store paths
-%   to the CodeWarrior IDE, and the MacCVS Pro session file. Note quoting
-%   of paths containing whitespace. Examples:
-%
-%    filepath   idepath         ::codewarrior.txt
-%    filepath   sessionpath     ":Some folder:MacCVS session path.txt"
-%
-%   Lines which modify the build settings like %main::DEBUG.
-%   Any lines which do not match either of the above are assumed
-%   to set variables on $main::. Examples:
-%   
-%    MOZILLA_OFFICIAL    1
-%
-EOS
-
-  $file_contents =~ s/%/#/g;
-   
-  local(*PREFS_FILE);
-
-  open(PREFS_FILE, "> $file_path") || die "Could not write default prefs file\n";
-  print PREFS_FILE ($file_contents);
-  close(PREFS_FILE);
-
-  MacPerl::SetFileInfo("McPL", "TEXT", $file_path);
-}
-
-
-#-------------------------------------------------------------------------------
-#
-# HandlePrefSet
-#
-#-------------------------------------------------------------------------------
-sub HandlePrefSet($$$$)
-{
-  my($flags, $name, $value, $desc) = @_;
-
-  if (SetArrayValue($flags, $name, $value)) {
-    print "Prefs set $desc flag '$name' to '$value'\n";
-  } else {
-    die "$desc setting '$name' is not a valid option\n";
-  }
-
-}
-
-
-#-------------------------------------------------------------------------------
-#
-# HandleBuildFromPref
-#
-#-------------------------------------------------------------------------------
-sub HandleBuildFromPref($$)
-{
-  my($build_array, $name) = @_;
-
-  my($setting) = 0;
-  my($index);
-  foreach $index (@$build_array)
-  {
-    if ($index->[0] eq $name) {
-      $setting = 1;
-    }
-    
-    $index->[1] = $setting;    
-  }
-
-  if ($setting == 1) {
-    print "Building from $name onwards, as specified by prefs\n";
-  } else {
-    printf "Failed to find buildfrom setting '$name'\n";
-  }
-}
-
-
-#-------------------------------------------------------------------------------
-#
-# ReadPrefsFile
-#
-#-------------------------------------------------------------------------------
-
-sub ReadPrefsFile($$$$$)
-{
-  my($file_path, $build_flags, $options_flags, $filepath_flags, $create_if_missing) = @_;
-  
-  local(*PREFS_FILE);
-  
-  if (open(PREFS_FILE, "< $file_path"))
-  {
-    print "Reading build prefs from '$file_path'\n";
-  
-    while (<PREFS_FILE>)
-    {
-      my($line) = $_;
-      chomp($line);
-      
-      if ($line =~ /^\#/ || $line =~ /^\s*$/) {    # ignore comments and empty lines
-        next;
-      }
-            
-      if (($line =~ /^\s*([^#\s]+)\s+([^#\s]+)\s+\"(.+)\"(\s+#.+)?/) ||
-          ($line =~ /^\s*([^#\s]+)\s+([^#\s]+)\s+\'(.+)\'(\s+#.+)?/) ||
-          ($line =~ /^\s*([^#\s]+)\s+([^#\s]+)\s+([^#\s]+)(\s+#.+)?/))
-      {
-        my($array_name) = $1;      
-        my($option_name) = $2;
-        my($option_value) = $3;      
-      
-        # print "Read '$array_name' '$option_name' '$option_value'\n";
-        
-        if ($array_name eq "build")
-        {
-          HandlePrefSet($build_flags, $option_name, $option_value, "Build");
-        }
-        elsif ($array_name eq "options")
-        {
-          HandlePrefSet($options_flags, $option_name, $option_value, "Options");
-        }
-        elsif ($array_name eq "filepath" && $option_name && $option_value)
-        {
-          HandlePrefSet($filepath_flags, $option_name, $option_value, "Filepath");
-        }
-        else
-        {
-          print "Unknown pref option at $line\n";
-        }
-      }
-      elsif ($line =~ /^\s*buildfrom\s+([^#\s]+)(\s+#.+)?/)
-      {
-        my($build_start) = $1;
-        HandleBuildFromPref($build_flags, $build_start);
-      }
-      elsif ($line =~ /^\s*([^#\s]+)\s+([^#\s]+)(\s+#.+)?/)
-      {
-        my($build_var) = $1;
-        my($var_setting) = $2;
-        
-        print "Setting \$main::$build_var to $var_setting\n";
-        eval "\$main::$build_var = \"$var_setting\"";
-      }
-      else
-      {
-        print "Unrecognized input line at $line\n";
-      }
-      
-    }
-    
-    close(PREFS_FILE);  
-  }
-  elsif ($create_if_missing)
-  {
-    print "No prefs file found at $file_path; using defaults\n";
-    
-    my($folder_path) = $file_path;
-    $folder_path =~ s/[^:]+$//;
-    mkpath($folder_path);
-    WriteDefaultPrefsFile($file_path);
-  }
-}
-
-
-#-------------------------------------------------------------------------------
-#
-# ReadMozUserPrefs
-#
-#-------------------------------------------------------------------------------
-
-sub ReadMozUserPrefs($$$$)
-{
-  my($prefs_file_name, $build_flags, $options_flags, $filepath_flags) = @_;
-  
-  if ($prefs_file_name eq "") { return; }
-  
-  # if local prefs exist, just use those. Othewise, look in the prefs folder
-  if (-e $prefs_file_name)
-  {
-    # read local prefs
-    ReadPrefsFile($prefs_file_name, $build_flags, $options_flags, $filepath_flags, 0);
-  }
-  else
-  {
-    # first read prefs folder prefs
-    my($prefs_path) = GetPrefsFolder();
-    $prefs_path .= ":$prefs_file_name";
-
-    ReadPrefsFile($prefs_path, $build_flags, $options_flags, $filepath_flags, 1);
-  }
-}
-
-1;

mozilla/build/mac/build_scripts/Moz/ProjectXML.pm

@@ -1,932 +0,0 @@
-#!/usr/bin/perl
-
-#
-# The contents of this file are subject to the Netscape Public
-# License Version 1.1 (the "License"); you may not use this file
-# except in compliance with the License. You may obtain a copy of
-# the License at http://www.mozilla.org/NPL/
-#
-# Software distributed under the License is distributed on an "AS
-# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
-# implied. See the License for the specific language governing
-# rights and limitations under the License.
-#
-# The Original Code is mozilla.org code.
-#
-# The Initial Developer of the Original Code is Netscape
-# Communications Corporation.  Portions created by Netscape are
-# Copyright (C) 1998 Netscape Communications Corporation. All
-# Rights Reserved.
-#
-# Contributor(s): 
-#   Simon Fraser <sfraser@netscape.com>
-#
-
-package Moz::ProjectXML;
-
-require 5.004;
-require Exporter;
-
-use strict;
-use Exporter;
-
-use Cwd;
-use XML::DOM;
-
-use vars qw(@ISA @EXPORT);
-
-@ISA      = qw(Exporter);
-@EXPORT   = qw(
-                ParseXMLDocument
-                DisposeXMLDocument
-                WriteXMLDocument
-                CleanupPro5XML
-                GetTargetsList
-                CloneTarget
-                SetAsSharedLibraryTarget
-                SetAsStaticLibraryTarget
-                AddTarget
-                RemoveTarget
-                GetTargetSetting
-                SetTargetSetting
-                getChildElementTextContents
-              );
-
-
-#--------------------------------------------------------------------------------------------------
-# A module for reading, manipulating, and writing XML-format CodeWarrior project files.
-# 
-# Sample usage:
-# 
-# use ProjectXML;
-# 
-# my $doc = ProjectXML::ParseXMLDocument("Test.mcp.xml");
-# ProjectXML::CloneTarget($doc, "Test.shlb", "Test.lib");
-# ProjectXML::SetAsStaticLibraryTarget($doc, "Test.lib", "TestOutput.lib");
-# ProjectXML::WriteXMLDocument($doc, "Test_out.xml");
-# ProjectXML::DisposeXMLDocument($doc);
-# 
-#--------------------------------------------------------------------------------------------------
-
-
-#//--------------------------------------------------------------------------------------------------
-#// ParseXMLDocument
-#// Note that the caller must call DisposeXMLDocument on the returned doc
-#//--------------------------------------------------------------------------------------------------
-sub ParseXMLDocument($)
-{
-  my($doc_path) = @_;
-
-  my $parser = new XML::DOM::Parser(ErrorContext => 2);
-  my $doc = $parser->parsefile($doc_path);
-
-  return $doc;
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// DisposeXMLDocument
-#// Needed to avoid memory leaks - cleanup circular references for garbage collection
-#//--------------------------------------------------------------------------------------------------
-sub DisposeXMLDocument($)
-{
-  my($doc) = @_;
-  
-  $doc->dispose();
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// WriteXMLDocument
-#//--------------------------------------------------------------------------------------------------
-
-sub _pro5_tag_compression($$)
-{
-   return 1;    # Pro 5 is broken and can't import XML with <foo/> style tags
-}
-
-sub _pro6plus_tag_compression($$)
-{
-   return 0;    # Pro 6 can deal with empty XML tags like <foo/>
-}
-
-sub WriteXMLDocument($$$)
-{
-  my($doc, $file_path, $ide_version) = @_;
-
-  if ($ide_version eq "4.0")
-  {
-    XML::DOM::setTagCompression(\&_pro5_tag_compression);
-  }
-  else
-  {
-    XML::DOM::setTagCompression(\&_pro6plus_tag_compression);
-  }
-
-  $doc->printToFile($file_path);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// CleanupPro5XML
-#// XML Projects exported by Pro 5 contain garbage data under the MWMerge_MacOS_skipResources
-#// setting. This routine cleans this up, saving the result to a new file
-#//--------------------------------------------------------------------------------------------------
-sub CleanupPro5XML($$)
-{
-  my($xml_path, $out_path) = @_;
-  
-  local(*XML_FILE);
-  open(XML_FILE, "< $xml_path") || die "Error: failed to open file $xml_path\n";
-  
-  local(*CLEANED_FILE);
-  open(CLEANED_FILE, "> $out_path") || die "Error: failed to open file $out_path for writing\n";
-  
-  my $in_skip_resources_settings = 0;
-  
-  while(<XML_FILE>)
-  {
-      my($line) = $_;
-
-      if ($line =~ /^<\?codewarrior/)    # is processing inst line
-      {
-        my $test_line = $line;
-        chomp($test_line);
-  
-        my $out_line = $test_line;
-        if ($test_line =~ /^<\?codewarrior\s+exportversion=\"(.+)\"\s+ideversion=\"(.+)\"\s*\?>$/)
-        {
-          my $export_version = $1;
-          my $ide_version    = $2;
-
-          $ide_version = "4.0_mozilla";   # pseudo IDE version so we know we touched it
-          $out_line = "<?codewarrior exportversion=\"".$export_version."\" ideversion=\"".$ide_version."\"?>";
-        }
-
-        print CLEANED_FILE "$out_line\n";
-        next;
-      }
-      
-      if ($line =~ /MWMerge_MacOS_skipResources/)
-      {
-        $in_skip_resources_settings = 1;
-        print CLEANED_FILE "$line";
-      }
-      elsif($in_skip_resources_settings && $line =~ /<!-- Settings for/)
-      {
-        # leaving bad settings lines. Write closing tag
-        print CLEANED_FILE "                    <!-- Corrupted setting entries removed by script -->\n";
-        print CLEANED_FILE "                </SETTING>\n\n";
-        
-        print CLEANED_FILE "$line";
-
-        $in_skip_resources_settings = 0;
-      }
-      elsif (!$in_skip_resources_settings)
-      {      
-        print CLEANED_FILE "$line";
-      }
-  }
-  
-  close(XML_FILE);
-  close(CLEANED_FILE);
-
-}
-
-#--------------------------------------------------------------------------------------------------
-# SniffProjectXMLIDEVersion
-#
-#--------------------------------------------------------------------------------------------------
-sub SniffProjectXMLIDEVersion($)
-{
-  my($xml_path) = @_;
-  
-  my $found_version = "";
-  
-  local(*XML_FILE);
-  open(XML_FILE, "< $xml_path") || die "Error: failed to open file $xml_path\n";
-  
-  while(<XML_FILE>)
-  {
-      my($line) = $_;
-      chomp($line);
-      
-      if ($line =~ /^<\?codewarrior/)    # is processing inst line
-      {
-        unless ($line =~ /^<\?codewarrior\s+exportversion=\"(.+)\"\s+ideversion=\"(.+)\"\s*\?>$/)
-        {
-          die "Error: Failed to find ideversion in $xml_path in line $line\n";
-        }
-        
-        my $export_version = $1;
-        my $ide_version    = $2;
-
-        $found_version = $ide_version;         
-        last;
-      }
-  }
-  
-  close(XML_FILE);
-
-  return $found_version;
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// GetTargetsList
-#// Returns an array of target names
-#//--------------------------------------------------------------------------------------------------
-sub GetTargetsList($)
-{
-  my($doc) = @_;
-
-  my $nodes = $doc->getElementsByTagName("TARGET");
-  my $n = $nodes->getLength;
-  
-  my @target_names;
-  
-  for (my $i = 0; $i < $n; $i++)
-  {
-    my ($node) = $nodes->item($i);   
-   
-    my($target_name) = getChildElementTextContents($node, "NAME");
-    push(@target_names, $target_name);
-  }
-
-  return @target_names;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// CloneTarget
-#// Clone the named target, renaming it to 'new_name'
-#//--------------------------------------------------------------------------------------------------
-sub CloneTarget($$$)
-{
-  my($doc, $target_name, $new_name) = @_;
-
-  my $target_node   = getTargetNode($doc, $target_name);
-
-  # clone here
-  my $target_clone  = $target_node->cloneNode(1);   # deep clone
-  
-  # -- munge target settings --
-
-  # set the target name field
-  setChildElementTextContents($doc, $target_clone, "NAME", $new_name);
-  
-  # set the targetname pref
-  setTargetNodeSetting($doc, $target_clone, "Targetname", $new_name);
-
-  # -- insert new target subtree --
-  
-  my $target_list   = $target_node->getParentNode();
-  $target_list->appendChild($target_clone);
-  
-  # -- now add to targetorder --
-  my (@target_order_nodes) = getChildOfDocument($doc, "TARGETORDER");
-  
-  my $target_order = @target_order_nodes[0];
-  
-  my $new_order     = $doc->createElement("ORDEREDTARGET");
-  my $order_name    = $doc->createElement("NAME");
-  
-  $new_order->appendChild($order_name);
-
-  setChildElementTextContents($doc, $new_order, "NAME", $new_name);
-  $target_order->appendChild($new_order);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// SetAsSharedLibraryTarget
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub SetAsSharedLibraryTarget($$$)
-{
-  my($doc, $target_name, $output_name) = @_;
-
-  my $target_node = getTargetNode($doc, $target_name);
-
-  setTargetNodeSetting($doc, $target_node, "MWProject_PPC_type", "SharedLibrary");
-  setTargetNodeSetting($doc, $target_node, "MWProject_PPC_filetype", "1936223330"); #'shlb'
-  setTargetNodeSetting($doc, $target_node, "MWProject_PPC_outfile", $output_name);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// AddFileToTarget
-#// 
-#// Add a file to the specified target(s).
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub AddFileToTarget($$$)
-{
-  my($doc, $target_list, $file_name) = @_;
-
-  # the file must be added in 3 places:
-  # 1. in <TARGET><FILELIST><FILE> (with linkage flags if necessary)
-  # 2. in <TARGET><LINKORDER><FILEREF>
-  # 3. in <GROUPLIST><GROUP><FILEREF>
-  die "Write me\n";
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// RemoveFileFromTarget
-#// 
-#// Remove a file from the specified target, removing it from the entire project
-#// if no other targets reference it.
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub RemoveFileFromTarget($$$)
-{
-  my($doc, $target_node, $file_name) = @_;
-  
-  # the file must be removed in 3 places:
-  # 1. in <TARGET><FILELIST><FILE>
-  # 2. in <TARGET><LINKORDER><FILEREF>
-  # 3. in <GROUPLIST><GROUP><FILEREF>
-  
-  # first, remove from <FILELIST>
-  my $filelist_node = getFirstChildElement($target_node, "FILELIST");
-  unless ($filelist_node) { die "Error: failed to find FILELIST node\n"; }
-  
-  my $file_node = getChildNodeByGrandchildContents($doc, $filelist_node, "FILE", "PATH", $file_name);
-  unless ($file_node) { return; }
-
-  $filelist_node->removeChild($file_node);
-  
-  # next, remove from <LINKORDER>
-  my $linkorder_node = getFirstChildElement($target_node, "LINKORDER");
-  unless ($linkorder_node) { die "Error: failed to find LINKORDER node\n"; }
-  
-  my $fileref_node = getChildNodeByGrandchildContents($doc, $linkorder_node, "FILEREF", "PATH", $file_name);
-  unless ($fileref_node) { die "Error: link order node for file $file_name not found\n"; }
-
-  $linkorder_node->removeChild($fileref_node);
-  
-  # last, remove from <GROUPLIST>
-  # <GROUPLIST> is cross-target, so we have to be careful here.
-  my $grouplist_node = getChildOfDocument($doc, "GROUPLIST");
-  unless ($grouplist_node) { die "Error: failed to find GROUPLIST node\n"; }
-
-  # if the file isn't in any other targets, remove it from the groups
-  if (!GetFileInUse($doc, $file_name))
-  {
-    print "File $file_name is in no other targest. Removing from project\n";
-
-    my @group_nodes;
-    getChildElementsOfType($doc, $grouplist_node, "GROUP", \@group_nodes);
-    my $group_node;
-    foreach $group_node (@group_nodes)
-    {
-      my @fileref_nodes;
-      getChildElementsOfType($doc, $group_node, "FILEREF", \@fileref_nodes);
-  
-      my $fileref_node;
-      foreach $fileref_node (@fileref_nodes)
-      {
-        my $path_name = getChildElementTextContents($fileref_node, "PATH");
-        if ($path_name eq $file_name)
-        {
-          print "Removing $file_name from project group list\n";
-          $group_node->removeChild($fileref_node);
-          last;
-        }
-      }
-      
-      # can a file appear in more than one group?
-    }
-  }
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// SetAsStaticLibraryTarget
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub SetAsStaticLibraryTarget($$$)
-{
-  my($doc, $target_name, $output_name) = @_;
-
-  my $target_node = getTargetNode($doc, $target_name);
-
-  setTargetNodeSetting($doc, $target_node, "MWProject_PPC_type", "Library");
-  setTargetNodeSetting($doc, $target_node, "MWProject_PPC_filetype", "1061109567"); #'????'
-  setTargetNodeSetting($doc, $target_node, "MWProject_PPC_outfile", $output_name);
-
-  # static targets don't need any library linkage, so we can remove linkage
-  # with all .shlb and .Lib files.
-  
-  my(@obsolete_files) = ("NSStdLibStubs", "InterfacesStubs", "InterfaceLib", "InternetConfigLib");
-
-  print " Removing libraries etc. from target\n";
-
-  # get all files in target
-  my @target_files = GetTargetFilesList($doc, $target_name);
-  my $target_file;
-  foreach $target_file (@target_files)
-  {
-    if ($target_file =~ /(\.shlb|\.lib|\.Lib|\.o|\.exp)$/)
-    {
-      RemoveFileFromTarget($doc, $target_node, $target_file);
-    }
-  }
-  
-  print " Removing stub libraries from target\n";
-  
-  # then remove files with known names
-  my $obs_file;
-  foreach $obs_file (@obsolete_files)
-  {
-    RemoveFileFromTarget($doc, $target_node, $obs_file);
-  }
-
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// AddTarget
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub AddTarget($$)
-{
-  my($doc, $target_name) = @_;
-
-  die "Write me\n";
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// RemoveTarget
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub RemoveTarget($$)
-{
-  my($doc, $target_name) = @_;
-
-  die "Write me\n";
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// GetTargetSetting
-#// Get the value for the specified setting in the specified target
-#//--------------------------------------------------------------------------------------------------
-sub GetTargetSetting($$$)
-{
-  my($doc, $target_name, $setting_name) = @_;
-
-  my $target_node   = getTargetNode($doc, $target_name);
-  return getTargetNodeSetting($target_node, "VALUE");
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// SetTargetSetting
-#// Set the value for the specified setting in the specified target
-#//--------------------------------------------------------------------------------------------------
-sub SetTargetSetting($$$$)
-{
-  my($doc, $target_name, $setting_name, $new_value) = @_;
-
-  my $target_node   = getTargetNode($doc, $target_name);
-  setTargetNodeSetting($doc, $target_node, "VALUE", $new_value);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// GetTargetFilesList
-#// Return an array of the files in the target (in filelist order)
-#//--------------------------------------------------------------------------------------------------
-sub GetTargetFilesList($$)
-{
-  my($doc, $target_name) = @_;
-
-  my $target_node = getTargetNode($doc, $target_name);
-
-  my @files_list;
-    
-  my $filelist_node = getFirstChildElement($target_node, "FILELIST");
-  unless ($filelist_node) { die "Error: failed to find FILELIST node\n"; }
-
-  my @file_nodes;
-  getChildElementsOfType($doc, $filelist_node, "FILE", \@file_nodes);
-  
-  my $node;
-  foreach $node (@file_nodes)
-  {
-    my $file_name = getChildElementTextContents($node, "PATH");
-    push(@files_list, $file_name);
-  }
-  
-  return @files_list;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// FileIsInTarget
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub FileIsInTarget($$$)
-{
-  my($doc, $file_name, $target_name) = @_;
-
-  my $target_node = getTargetNode($doc, $target_name);
-  unless ($target_node) { die "Error: no target found called $target_name\n"; }
-
-  my $file_node = GetTargetFileNode($doc, $target_node, $file_name);
-  if ($file_node) {
-    return 1;
-  }
-  
-  return 0;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// GetFileTargetsList
-#// Return an array of the targets that a file is in (expensive)
-#//--------------------------------------------------------------------------------------------------
-sub GetFileTargetsList($$)
-{
-  my ($doc, $file_name) = @_;
-
-  my @target_list;
-
-  my @targets = GetTargetsList($doc);
-  my $target;
-  
-  foreach $target (@targets)
-  {
-    if (FileIsInTarget($doc, $file_name, $target))
-    {
-      push(@target_list, $target);
-    }
-  }
-  
-  return @target_list;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// GetTargetFileNode
-#// 
-#//--------------------------------------------------------------------------------------------------
-sub GetTargetFileNode($$$)
-{
-  my($doc, $target_node, $file_name) = @_;
-
-  my $filelist_node = getFirstChildElement($target_node, "FILELIST");
-  unless ($filelist_node) { die "Error: failed to find FILELIST node\n"; }
-  
-  my $file_node = getChildNodeByGrandchildContents($doc, $filelist_node, "FILE", "PATH", $file_name);
-
-  return $file_node;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// GetFileInUse
-#// Return true if the file is used by any target
-#//--------------------------------------------------------------------------------------------------
-sub GetFileInUse($$)
-{
-  my($doc, $file_name) = @_;
-
-  my $targetlist_node = getChildOfDocument($doc, "TARGETLIST");
-
-  my $target_node = $targetlist_node->getFirstChild();
- 
-  while ($target_node)
-  {
-    if ($target_node->getNodeTypeName eq "ELEMENT_NODE" &&
-        $target_node->getTagName() eq "TARGET")
-    {
-      # if this is a target node
-      my $file_node = GetTargetFileNode($doc, $target_node, $file_name);
-      if ($file_node) {
-        return 1;   # found it
-      }      
-    }
-
-    $target_node = $target_node->getNextSibling();
-  }
-  
-  # not found
-  return 0;
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// getChildOfDocument
-#//--------------------------------------------------------------------------------------------------
-sub getChildOfDocument($$)
-{
-  my($doc, $child_type) = @_;
-
-  return getFirstChildElement($doc->getDocumentElement(), $child_type);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// getFirstChildElement
-#//--------------------------------------------------------------------------------------------------
-sub getFirstChildElement($$)
-{
-  my($node, $element_name) = @_;
-
-  my $found_node;
-  
-  unless ($node) { die "getFirstChildElement called with empty node\n"; }
-  
-  #look for the first "element_name" child
-
-  my $child_node = $node->getFirstChild();
- 
-  while ($child_node)
-  {
-    if ($child_node->getNodeTypeName eq "ELEMENT_NODE" &&
-        $child_node->getTagName() eq $element_name)
-    {
-      $found_node = $child_node;
-      last;
-    }
-
-    $child_node = $child_node->getNextSibling();
-  }
-   
-  return $found_node;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// getChildElementsOfType
-#// 
-#// Return an array of refs to child nodes of the given type
-#//--------------------------------------------------------------------------------------------------
-sub getChildElementsOfType($$$$)
-{
-  my($doc, $node, $child_type, $array_ref) = @_;
-
-  my $child_node = $node->getFirstChild();
- 
-  while ($child_node)
-  {
-    if ($child_node->getNodeTypeName eq "ELEMENT_NODE" &&
-        $child_node->getTagName() eq $child_type)
-    {
-      push(@$array_ref, $child_node);
-    }
-
-    $child_node = $child_node->getNextSibling();
-  }
-
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// getChildElementTextContents
-#//--------------------------------------------------------------------------------------------------
-#
-# Given <FOOPY><NERD>Hi!</NERD></FOOPY>, where $node is <FOOPY>,
-# returns "Hi!". If > 1 <NERD> node, returns the contents of the first.
-#
-sub getChildElementTextContents($$)
-{
-  my($node, $tag_name) = @_;
-
-  my $first_element = getFirstChildElement($node, $tag_name);  
-  my $text_node     = $first_element->getFirstChild();
-  
-  my $text_contents = "";
-  
-  # concat adjacent text nodes
-  while ($text_node)
-  {
-    if ($text_node->getNodeTypeName() ne "TEXT_NODE")
-    {
-      last;
-    }
-
-    $text_contents = $text_contents.$text_node->getData();
-    $text_node = $text_node->getNextSibling();
-  }
-
-  return $text_contents;
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// setChildElementTextContents
-#//--------------------------------------------------------------------------------------------------
-sub setChildElementTextContents($$$$)
-{
-  my($doc, $node, $tag_name, $contents_text) = @_;
-  
-  my $first_element = getFirstChildElement($node, $tag_name);  
-  my $new_text_node = $doc->createTextNode($contents_text);
-  
-  # replace all child elements with a text element
-  removeAllChildren($first_element);
-  
-  $first_element->appendChild($new_text_node);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// getChildNodeByContents
-#// 
-#// Consider <foo><bar><baz>Foopy</baz></bar><bar><baz>Loopy</baz></bar></foo>
-#// This function, when called with getChildNodeByContents($foonode, "bar", "baz", "Loopy")
-#// returns the second <bar> node.
-#//--------------------------------------------------------------------------------------------------
-sub getChildNodeByGrandchildContents($$$$$)
-{
-  my($doc, $node, $child_type, $gc_type, $gc_contents) = @_;    # gc = grandchild
-
-  my $found_node;
-  my $child_node = $node->getFirstChild();
-  while ($child_node)
-  {
-    if ($child_node->getNodeTypeName eq "ELEMENT_NODE" &&
-        $child_node->getTagName() eq $child_type)
-    {
-      # check for a child of this node of type 
-      my $child_contents = getChildElementTextContents($child_node, $gc_type);
-
-      if ($child_contents eq $gc_contents)
-      {
-        $found_node = $child_node;
-        last;
-      }
-    }
-
-    $child_node = $child_node->getNextSibling();
-  }
-
-  return $found_node;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// getTargetNode
-#//--------------------------------------------------------------------------------------------------
-sub getTargetNode($$)
-{
-  my($doc, $target_name) = @_;
-
-  my $targetlist_node = getChildOfDocument($doc, "TARGETLIST");
-  return getChildNodeByGrandchildContents($doc, $targetlist_node, "TARGET", "NAME", $target_name);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// getTargetNamedSettingNode
-#//--------------------------------------------------------------------------------------------------
-sub getTargetNamedSettingNode($$)
-{
-  my($target_node, $setting_name) = @_;
-
-  my $setting_node;
-
-  my $settinglist_node = getFirstChildElement($target_node, "SETTINGLIST");
-  my $child_node = $settinglist_node->getFirstChild();
- 
-  while ($child_node)
-  {
-    if ($child_node->getNodeTypeName ne "ELEMENT_NODE")
-    {
-      $child_node = $child_node->getNextSibling();
-      next;
-    }
-    
-    if ($child_node->getTagName() eq "SETTING")
-    {
-      my $set_name = getChildElementTextContents($child_node, "NAME");
-
-      if ($set_name eq $setting_name)
-      {
-        $setting_node = $child_node;
-        last;
-      }
-    }
-
-    $child_node = $child_node->getNextSibling();
-  }
-
-  return $setting_node;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// getTargetNodeSetting
-#//--------------------------------------------------------------------------------------------------
-sub getTargetNodeSetting($$)
-{
-  my($target_node, $setting_name) = @_;
-  
-  my $setting_node  = getTargetNamedSettingNode($target_node, $setting_name);
-  return getChildElementTextContents($setting_node, "VALUE");
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// setTargetNodeSetting
-#//--------------------------------------------------------------------------------------------------
-sub setTargetNodeSetting($$$$)
-{
-  my($doc, $target_node, $setting_name, $new_value) = @_;
-
-  my $setting_node  = getTargetNamedSettingNode($target_node, $setting_name);
-
-  setChildElementTextContents($doc, $setting_node, "VALUE", $new_value);
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// elementInArray
-#//--------------------------------------------------------------------------------------------------
-sub elementInArray($$)
-{
-  my($element, $array) = @_;
-  my $test;
-  foreach $test (@$array)
-  {
-    if ($test eq $element) {
-      return 1;
-    }
-  }
-  return 0;
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// removeAllChildren
-#//--------------------------------------------------------------------------------------------------
-sub removeAllChildren($)
-{
-  my($node) = @_;
-  
-  my $child_node = $node->getFirstChild();
-  
-  while ($child_node)
-  {
-    $node->removeChild($child_node);
-    $child_node = $node->getFirstChild();
-  }
-}
-
-
-#//--------------------------------------------------------------------------------------------------
-#// dumpNodeData
-#//--------------------------------------------------------------------------------------------------
-sub dumpNodeData($)
-{
-  my($node) = @_;
-  
-  unless ($node) { die "Null node passed to dumpNodeData\n"; }
-  
-  print "Dumping node $node\n";
-  
-  my($node_type) = $node->getNodeTypeName();
-  
-  if ($node_type eq "ELEMENT_NODE")
-  {
-    my($node_name) = $node->getTagName();
-    print "Element $node_name\n";
-  }
-  elsif ($node_type eq "TEXT_NODE")
-  {
-    my($node_data) = $node->getData;
-    # my(@node_vals) = unpack("C*", $node_data);
-    print "Text '$node_data'\n";    # may contain LF chars
-  }
-  else
-  {
-    print "Node $node_type\n";
-  }
-
-}
-
-#//--------------------------------------------------------------------------------------------------
-#// dumpNodeTree
-#//--------------------------------------------------------------------------------------------------
-sub dumpNodeTree($)
-{
-  my($node) = @_;
-  
-  my($child_node) = $node->getFirstChild();
-  
-  unless ($child_node) { return; }
-
-  # recurse
-  dumpNodeData($child_node);
-  
-  # then go through child nodes
-  while ($child_node)
-  {
-    dumpNodeTree($child_node);
-  
-    $child_node = $child_node->getNextSibling();
-  }
-}
-
-
-
-
-1;
-

mozilla/build/mac/build_scripts/MozillaBuildFlags.txt

@@ -1,90 +0,0 @@
-#-------------------------------------------------------------------------------
-# These 3 lists are the 'master lists' to control what gets built.
-# 
-# Ordering in these arrays is important; it has to reflect the order in
-# which the build occurs.
-#
-# Setting containing spaces must be quoted with double quotes.
-#-------------------------------------------------------------------------------
-
-build_flags
-all             1
-pull            0
-dist            0
-config          0
-xpidl           0
-idl             0
-stubs           0
-runtime         0
-common          0
-imglib          0
-libimg2         0
-necko           0
-security        0
-browserutils    0
-intl            0
-nglayout        0
-accessiblity    0
-editor          0
-embedding       0
-viewer          0
-xpapp           0
-extensions      0
-plugins         0
-mailnews        0
-apprunner       0
-resources       0
-
-options_flags
-pull_by_date    0
-chrome_jars     1
-chrome_files    0
-use_jars        1
-transformiix    1
-mathml          0      MOZ_MATHML
-svg             0      MOZ_SVG
-# svg requires libart, which is an lgpl library. You need to pull it 
-# explicitly.
-libart_lgpl     0
-mng             1
-ldap            1      MOZ_LDAP_XPCOM
-ldap_experimental 0    MOZ_LDAP_XPCOM_EXPERIMENTAL
-xmlextras       1
-wsp             0      MOZ_WSP
-inspector       1
-mailextras      1
-xptlink         0
-psm             0      MOZ_PSM
-embedding_test  1
-embedding_chrome 0
-embedding_xulprefs 0
-embedding_xulsecurity 0
-carbon          0      TARGET_CARBON
-useimg2         1      USE_IMG2
-lowmem          0      MOZ_MAC_LOWMEM
-accessible      1      ACCESSIBILITY
-bidi            1      IBMBIDI
-p3p             0
-jsd             1
-venkman         1
-moz_logging     1      MOZ_LOGGING
-chatzilla       1
-content_packs   1
-xml_rpc         1
-cview           1
-help            1
-timeline        0      MOZ_TIMELINE
-static_build    0      MOZ_STATIC_COMPONENT_LIBS
-string_debug    0      DEBUG_STRING
-string_stats    0      DEBUG_STRING_STATS
-xpctools        0      XPC_TOOLS_SUPPORT
-smime           1
-mdn             1
-print_preview   1      NS_PRINT_PREVIEW
-moz_xul         1      MOZ_XUL
-
-filepath_flags
-idepath             ":CodeWarrior IDE Path.txt"
-sessionpath         ":Mozilla session path.txt"
-buildlogfilepath    ":Build Logs:Mozilla build log.txt"   # this is a path
-scriptlogfilepath   ":Build Logs:Mozilla script log.txt"

mozilla/build/mac/build_scripts/MozillaCheckoutList.txt

@@ -1,22 +0,0 @@
-# List of modules to check out. Format is
-#   module, (tag), (date)
-# where tag and date are optional (non-trailing commas are required)
-#
-# Examples:
-#   mozilla/nsprpub, NSPRPUB_CLIENT_TAG
-#   mozilla/gc, , 10/25/2000 12:00:00
-#
-
-mozilla/nsprpub,        	NETSCAPE_7_02_RELEASE
-mozilla/security/nss,   	NETSCAPE_7_02_RELEASE
-mozilla/security/manager,	NETSCAPE_7_02_RELEASE
-mozilla/accessible,			NETSCAPE_7_02_RELEASE
-mozilla/directory/c-sdk,	NETSCAPE_7_02_RELEASE
-mozilla/lib/mac/Instrumentation, 	NETSCAPE_7_02_RELEASE
-mozilla/gfx2, 				NETSCAPE_7_02_RELEASE
-mozilla/modules/libpr0n,	NETSCAPE_7_02_RELEASE
-SeaMonkeyAll, 				NETSCAPE_7_02_RELEASE
-
-## You need this if you want to be able to use SVG
-## Note that this library is under the LGPL, not the MPL
-#mozilla/other-licenses/libart_lgpl

mozilla/build/mac/build_scripts/PullMozilla.pl

@@ -1,79 +0,0 @@
-#!perl
-
-#
-# The contents of this file are subject to the Netscape Public
-# License Version 1.1 (the "License"); you may not use this file
-# except in compliance with the License. You may obtain a copy of
-# the License at http://www.mozilla.org/NPL/
-#
-# Software distributed under the License is distributed on an "AS
-# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
-# implied. See the License for the specific language governing
-# rights and limitations under the License.
-#
-# The Original Code is mozilla.org code.
-#
-# The Initial Developer of the Original Code is Netscape
-# Communications Corporation.  Portions created by Netscape are
-# Copyright (C) 1998 Netscape Communications Corporation. All
-# Rights Reserved.
-#
-# Contributor(s): 
-#   Simon Fraser <sfraser@netscape.com>
-#
-
-require 5.004;
-
-use strict;
-
-use Cwd;
-use Moz::BuildUtils;
-use Moz::BuildCore;
-
-#-------------------------------------------------------------
-# Where have the build options gone?
-# 
-# The various build flags have been centralized into one place. 
-# The master list of options is in MozBuildFlags.txt. However, 
-# you should never need to edit that file, or this one.
-# 
-# To customize what gets built, or where to start the build, 
-# edit the $prefs_file_name file in
-# System Folder:Preferences:Mozilla build prefs:
-# Documentation is provided in that file.
-#-------------------------------------------------------------
-
-my($prefs_file_name) = "Mozilla pull prefs";
-
-#-------------------------------------------------------------
-# hashes to hold build options
-#-------------------------------------------------------------
-my(%build);
-my(%options);
-my(%filepaths);
-my(%optiondefines);
-
-# Hash of input files for this build. Eventually, there will be
-# input files for manifests, and projects too.
-my(%inputfiles) = (
-  "buildflags",     "MozillaBuildFlags.txt",
-  "checkoutdata",   "MozillaCheckoutList.txt",
-  "buildprogress",  "",
-  "buildmodule",    "MozillaBuildList.pm",
-  "checkouttime",   "Mozilla last checkout"
-);
-#-------------------------------------------------------------
-# end build hashes
-#-------------------------------------------------------------
-
-# set the build root directory, which is the the dir above mozilla
-SetupBuildRootDir(":mozilla:build:mac:build_scripts");
-
-# Set up all the flags on $main::, like DEBUG, CARBON etc.
-# Override the defaults using the preferences files.
-SetupDefaultBuildOptions(0, ":mozilla:dist:viewer:", "");
-
-my($do_checkout)    = 1;
-my($do_build)       = 0;
-
-RunBuild($do_checkout, $do_build, \%inputfiles, $prefs_file_name);

mozilla/build/mac/test/README

@@ -1,4 +0,0 @@
-This directory is merely here to test the project editor server. It will go away after
-it is validated. For more information, see http://camelot.
-
-Testing watchers.

mozilla/build/mac/test/test1.cpp

@@ -1 +0,0 @@
-// test1.cpp

mozilla/build/mac/test/test2.cpp

@@ -1 +0,0 @@
-// test2.cpp

mozilla/build/mac/test/test3.cpp

@@ -1 +0,0 @@
-// test2.cpp

mozilla/build/mac/test/test5.cpp

@@ -1,4 +0,0 @@
-// test2.cpp
-
-as
-dfasdf

mozilla/build/mac/tools/BuildSystemInfo/BuildSystemInfo.cpp

@@ -1,12 +0,0 @@
-#include <stdio.h>
-
-#include <ConditionalMacros.h>
-
-int main(int argc, char* argv[])
-{
-    FILE* file = fopen("BuildSystemInfo.pm", "w");
-    if (file != NULL) {
-        fprintf(file, "$UNIVERSAL_INTERFACES_VERSION=0x%04X;\n", UNIVERSAL_INTERFACES_VERSION);
-        fclose(file);
-    }
-}

mozilla/client.mk

@@ -1,650 +0,0 @@
-# The contents of this file are subject to the Netscape Public
-# License Version 1.1 (the "License"); you may not use this file
-# except in compliance with the License. You may obtain a copy of
-# the License at http://www.mozilla.org/NPL/
-#
-# Software distributed under the License is distributed on an "AS
-# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
-# implied. See the License for the specific language governing
-# rights and limitations under the License.
-#
-# The Original Code is mozilla.org code.
-#
-# The Initial Developer of the Original Code is Netscape
-# Communications Corporation.  Portions created by Netscape are
-# Copyright (C) 1998 Netscape Communications Corporation. All
-# Rights Reserved.
-#
-# Contributor(s): Stephen Lamm
-
-# Build the Mozilla client.
-#
-# This needs CVSROOT set to work, e.g.,
-#   setenv CVSROOT :pserver:anonymous@cvs-mirror.mozilla.org:/cvsroot
-# or
-#   setenv CVSROOT :pserver:username%somedomain.org@cvs.mozilla.org:/cvsroot
-# 
-# To checkout and build a tree,
-#    1. cvs co mozilla/client.mk
-#    2. cd mozilla
-#    3. gmake -f client.mk
-#
-# Other targets (gmake -f client.mk [targets...]),
-#    checkout
-#    build
-#    clean (realclean is now the same as clean)
-#    distclean
-#
-# See http://www.mozilla.org/build/unix.html for more information.
-#
-# Options:
-#   MOZ_OBJDIR           - Destination object directory
-#   MOZ_CO_DATE          - Date tag to use for checkout (default: none)
-#   MOZ_CO_MODULE        - Module to checkout (default: SeaMonkeyAll)
-#   MOZ_CVS_FLAGS        - Flags to pass cvs (default: -q -z3)
-#   MOZ_CO_FLAGS         - Flags to pass after 'cvs co' (default: -P)
-#   MOZ_MAKE_FLAGS       - Flags to pass to $(MAKE)
-#   MOZ_CO_BRANCH        - Branch tag (Deprecated. Use MOZ_CO_TAG below.)
-#
-
-#######################################################################
-# Checkout Tags
-#
-# For branches, uncomment the MOZ_CO_TAG line with the proper tag,
-# and commit this file on that tag.
-MOZ_CO_TAG = NETSCAPE_7_02_RELEASE
-NSPR_CO_TAG = NETSCAPE_7_02_RELEASE
-PSM_CO_TAG = NETSCAPE_7_02_RELEASE
-NSS_CO_TAG = NETSCAPE_7_02_RELEASE
-LDAPCSDK_CO_TAG = NETSCAPE_7_02_RELEASE
-ACCESSIBLE_CO_TAG = NETSCAPE_7_02_RELEASE
-GFX2_CO_TAG = NETSCAPE_7_02_RELEASE
-IMGLIB2_CO_TAG = NETSCAPE_7_02_RELEASE
-BUILD_MODULES = all
-
-#######################################################################
-# Defines
-#
-CVS = cvs
-
-CWD := $(shell pwd)
-
-ifeq "$(CWD)" "/"
-CWD   := /.
-endif
-
-ifneq (, $(wildcard client.mk))
-# Ran from mozilla directory
-ROOTDIR   := $(shell dirname $(CWD))
-TOPSRCDIR := $(CWD)
-else
-# Ran from mozilla/.. directory (?)
-ROOTDIR   := $(CWD)
-TOPSRCDIR := $(CWD)/mozilla
-endif
-
-# on os2, TOPSRCDIR may have two forward slashes in a row, which doesn't
-#  work;  replace first instance with one forward slash
-TOPSRCDIR := $(shell echo "$(TOPSRCDIR)" | sed -e 's%//%/%')
-
-ifndef TOPSRCDIR_MOZ
-TOPSRCDIR_MOZ=$(TOPSRCDIR)
-endif
-
-# if ROOTDIR equals only drive letter (i.e. "C:"), set to "/"
-DIRNAME := $(shell echo "$(ROOTDIR)" | sed -e 's/^.://')
-ifeq ($(DIRNAME),)
-ROOTDIR := /.
-endif
-
-AUTOCONF := autoconf
-MKDIR := mkdir
-SH := /bin/sh
-ifndef MAKE
-MAKE := gmake
-endif
-
-CONFIG_GUESS_SCRIPT := $(wildcard $(TOPSRCDIR)/build/autoconf/config.guess)
-ifdef CONFIG_GUESS_SCRIPT
-  CONFIG_GUESS = $(shell $(CONFIG_GUESS_SCRIPT))
-else
-  _IS_FIRST_CHECKOUT := 1
-endif
-
-####################################
-# CVS
-
-# Add the CVS root to CVS_FLAGS if needed
-CVS_ROOT_IN_TREE := $(shell cat $(TOPSRCDIR)/CVS/Root 2>/dev/null)
-ifneq ($(CVS_ROOT_IN_TREE),)
-ifneq ($(CVS_ROOT_IN_TREE),$(CVSROOT))
-  CVS_FLAGS := -d $(CVS_ROOT_IN_TREE)
-endif
-endif
-
-CVSCO = $(strip $(CVS) $(CVS_FLAGS) co $(CVS_CO_FLAGS))
-CVSCO_LOGFILE := $(ROOTDIR)/cvsco.log
-CVSCO_LOGFILE := $(shell echo $(CVSCO_LOGFILE) | sed s%//%/%)
-
-ifdef MOZ_CO_TAG
-  CVS_CO_FLAGS := -r $(MOZ_CO_TAG)
-endif
-
-####################################
-# Load mozconfig Options
-
-# See build pages, http://www.mozilla.org/build/unix.html, 
-# for how to set up mozconfig.
-MOZCONFIG_LOADER := mozilla/build/autoconf/mozconfig2client-mk
-MOZCONFIG_FINDER := mozilla/build/autoconf/mozconfig-find 
-MOZCONFIG_MODULES := mozilla/build/unix/modules.mk
-run_for_side_effects := \
-  $(shell cd $(ROOTDIR); \
-     if test "$(_IS_FIRST_CHECKOUT)"; then \
-        $(CVSCO) $(MOZCONFIG_FINDER) $(MOZCONFIG_LOADER) $(MOZCONFIG_MODULES); \
-     else true; \
-     fi; \
-     $(MOZCONFIG_LOADER) $(TOPSRCDIR) mozilla/.mozconfig.mk > mozilla/.mozconfig.out)
-include $(TOPSRCDIR)/.mozconfig.mk
-include $(TOPSRCDIR)/build/unix/modules.mk
-
-####################################
-# Options that may come from mozconfig
-
-# Change CVS flags if anonymous root is requested
-ifdef MOZ_CO_USE_MIRROR
-  CVS_FLAGS := -d :pserver:anonymous@cvs-mirror.mozilla.org:/cvsroot
-endif
-
-# MOZ_CVS_FLAGS - Basic CVS flags
-ifeq "$(origin MOZ_CVS_FLAGS)" "undefined"
-  CVS_FLAGS := $(CVS_FLAGS) -q -z 3 
-else
-  CVS_FLAGS := $(MOZ_CVS_FLAGS)
-endif
-
-# This option is deprecated. The best way to have client.mk pull a tag
-# is to set MOZ_CO_TAG (see above) and commit that change on the tag.
-ifdef MOZ_CO_BRANCH
-  $(warning Use MOZ_CO_TAG instead of MOZ_CO_BRANCH)
-  CVS_CO_FLAGS := -r $(MOZ_CO_BRANCH)
-endif
-
-# MOZ_CO_FLAGS - Anything that we should use on all checkouts
-ifeq "$(origin MOZ_CO_FLAGS)" "undefined"
-  CVS_CO_FLAGS := $(CVS_CO_FLAGS) -P
-else
-  CVS_CO_FLAGS := $(CVS_CO_FLAGS) $(MOZ_CO_FLAGS)
-endif
-
-ifdef MOZ_CO_DATE
-  CVS_CO_DATE_FLAGS := -D "$(MOZ_CO_DATE)"
-endif
-
-ifdef MOZ_OBJDIR
-  OBJDIR := $(MOZ_OBJDIR)
-  MOZ_MAKE := $(MAKE) $(MOZ_MAKE_FLAGS) -C $(OBJDIR)
-else
-  OBJDIR := $(TOPSRCDIR)
-  MOZ_MAKE := $(MAKE) $(MOZ_MAKE_FLAGS)
-endif
-
-####################################
-# CVS defines for PSM
-#
-PSM_CO_MODULE= mozilla/security/manager
-PSM_CO_FLAGS := -P -A
-ifdef MOZ_CO_FLAGS
-  PSM_CO_FLAGS := $(MOZ_CO_FLAGS)
-endif
-ifdef PSM_CO_TAG
-  PSM_CO_FLAGS := $(PSM_CO_FLAGS) -r $(PSM_CO_TAG)
-endif
-CVSCO_PSM = $(CVS) $(CVS_FLAGS) co $(PSM_CO_FLAGS) $(CVS_CO_DATE_FLAGS) $(PSM_CO_MODULE)
-
-####################################
-# CVS defines for NSS
-#
-NSS_CO_MODULE = mozilla/security/nss \
-		mozilla/security/coreconf \
-		$(NULL)
-
-NSS_CO_FLAGS := -P
-ifdef MOZ_CO_FLAGS
-  NSS_CO_FLAGS := $(MOZ_CO_FLAGS)
-endif
-ifdef NSS_CO_TAG
-   NSS_CO_FLAGS := $(NSS_CO_FLAGS) -r $(NSS_CO_TAG)
-endif
-# Cannot pull static tags by date
-ifeq ($(NSS_CO_TAG),NSS_CLIENT_TAG)
-CVSCO_NSS = $(CVS) $(CVS_FLAGS) co $(NSS_CO_FLAGS) $(NSS_CO_MODULE)
-else
-CVSCO_NSS = $(CVS) $(CVS_FLAGS) co $(NSS_CO_FLAGS) $(CVS_CO_DATE_FLAGS) $(NSS_CO_MODULE)
-endif
-
-####################################
-# CVS defines for NSPR
-#
-NSPR_CO_MODULE = mozilla/nsprpub
-NSPR_CO_FLAGS := -P
-ifdef MOZ_CO_FLAGS
-  NSPR_CO_FLAGS := $(MOZ_CO_FLAGS)
-endif
-ifdef NSPR_CO_TAG
-  NSPR_CO_FLAGS := $(NSPR_CO_FLAGS) -r $(NSPR_CO_TAG)
-endif
-# Cannot pull static tags by date
-ifeq ($(NSPR_CO_TAG),NSPRPUB_CLIENT_TAG)
-CVSCO_NSPR = $(CVS) $(CVS_FLAGS) co $(NSPR_CO_FLAGS) $(NSPR_CO_MODULE)
-else
-CVSCO_NSPR = $(CVS) $(CVS_FLAGS) co $(NSPR_CO_FLAGS) $(CVS_CO_DATE_FLAGS) $(NSPR_CO_MODULE)
-endif
-
-####################################
-# CVS defines for the C LDAP SDK
-#
-LDAPCSDK_CO_MODULE = mozilla/directory/c-sdk
-LDAPCSDK_CO_FLAGS := -P
-ifdef MOZ_CO_FLAGS
-  LDAPCSDK_CO_FLAGS := $(MOZ_CO_FLAGS)
-endif
-ifdef LDAPCSDK_CO_TAG
-  LDAPCSDK_CO_FLAGS := $(LDAPCSDK_CO_FLAGS) -r $(LDAPCSDK_CO_TAG)
-endif
-CVSCO_LDAPCSDK = $(CVS) $(CVS_FLAGS) co $(LDAPCSDK_CO_FLAGS) $(CVS_CO_DATE_FLAGS) $(LDAPCSDK_CO_MODULE)
-
-####################################
-# CVS defines for the C LDAP SDK
-#
-ACCESSIBLE_CO_MODULE = mozilla/accessible
-ACCESSIBLE_CO_FLAGS := -P
-ifdef MOZ_CO_FLAGS
-  ACCESSIBLE_CO_FLAGS := $(MOZ_CO_FLAGS)
-endif
-ifdef ACCESSIBLE_CO_TAG
-  ACCESSIBLE_CO_FLAGS := $(ACCESSIBLE_CO_FLAGS) -r $(ACCESSIBLE_CO_TAG)
-endif
-CVSCO_ACCESSIBLE = $(CVS) $(CVS_FLAGS) co $(ACCESSIBLE_CO_FLAGS) $(CVS_CO_DATE_FLAGS) $(ACCESSIBLE_CO_MODULE)
-
-####################################
-# CVS defines for gfx2
-#
-GFX2_CO_MODULE = mozilla/gfx2
-GFX2_CO_FLAGS := -P
-ifdef MOZ_CO_FLAGS
-  GFX2_CO_FLAGS := $(MOZ_CO_FLAGS)
-endif
-ifdef GFX2_CO_TAG
-  GFX2_CO_FLAGS := $(GFX2_CO_FLAGS) -r $(GFX2_CO_TAG)
-endif
-CVSCO_GFX2 = $(CVS) $(CVS_FLAGS) co $(GFX2_CO_FLAGS) $(CVS_CO_DATE_FLAGS) $(GFX2_CO_MODULE)
-
-####################################
-# CVS defines for new image library
-#
-IMGLIB2_CO_MODULE = mozilla/modules/libpr0n
-IMGLIB2_CO_FLAGS := -P
-ifdef MOZ_CO_FLAGS
-  IMGLIB2_CO_FLAGS := $(MOZ_CO_FLAGS)
-endif
-ifdef IMGLIB2_CO_TAG
-  IMGLIB2_CO_FLAGS := $(IMGLIB2_CO_FLAGS) -r $(IMGLIB2_CO_TAG)
-endif
-CVSCO_IMGLIB2 = $(CVS) $(CVS_FLAGS) co $(IMGLIB2_CO_FLAGS) $(CVS_CO_DATE_FLAGS) $(IMGLIB2_CO_MODULE)
-
-####################################
-# CVS defines for standalone modules
-#
-ifneq ($(BUILD_MODULES),all)
-  MOZ_CO_MODULE := $(filter-out $(NSPRPUB_DIR) security directory/c-sdk, $(BUILD_MODULE_CVS))
-  MOZ_CO_MODULE += allmakefiles.sh client.mk aclocal.m4 configure configure.in
-  MOZ_CO_MODULE += Makefile.in
-  MOZ_CO_MODULE := $(addprefix mozilla/, $(MOZ_CO_MODULE))
-
-  NOSUBDIRS_MODULE := $(addprefix mozilla/, $(BUILD_MODULE_CVS_NS))
-ifneq ($(NOSUBDIRS_MODULE),)
-  CVSCO_NOSUBDIRS := $(CVSCO) -l $(CVS_CO_DATE_FLAGS) $(NOSUBDIRS_MODULE)
-endif
-
-ifeq (,$(filter $(NSPRPUB_DIR), $(BUILD_MODULE_CVS)))
-  CVSCO_NSPR :=
-endif
-ifeq (,$(filter security security/manager, $(BUILD_MODULE_CVS)))
-  CVSCO_PSM :=
-  CVSCO_NSS :=
-endif
-ifeq (,$(filter directory/c-sdk, $(BUILD_MODULE_CVS)))
-  CVSCO_LDAPCSDK :=
-endif
-ifeq (,$(filter accessible, $(BUILD_MODULE_CVS)))
-  CVSCO_ACCESSIBLE :=
-endif
-ifeq (,$(filter gfx2, $(BUILD_MODULE_CVS)))
-  CVSCO_GFX2 :=
-endif
-ifeq (,$(filter modules/libpr0n, $(BUILD_MODULE_CVS)))
-  CVSCO_IMGLIB2 :=
-endif
-endif
-
-####################################
-# CVS defines for SeaMonkey
-#
-ifeq ($(MOZ_CO_MODULE),)
-  MOZ_CO_MODULE := SeaMonkeyAll
-endif
-CVSCO_SEAMONKEY := $(CVSCO) $(CVS_CO_DATE_FLAGS) $(MOZ_CO_MODULE)
-
-####################################
-# CVS defined for libart (pulled and built if MOZ_INTERNAL_LIBART_LGPL is set)
-#
-CVSCO_LIBART := $(CVSCO) $(CVS_CO_DATE_FLAGS) mozilla/other-licenses/libart_lgpl
-
-ifdef MOZ_INTERNAL_LIBART_LGPL
-FASTUPDATE_LIBART := fast_update $(CVSCO_LIBART)
-CHECKOUT_LIBART := cvs_co $(CVSCO_LIBART)
-else
-CHECKOUT_LIBART := true
-FASTUPDATE_LIBART := true
-endif
-
-####################################
-# CVS defines for Calendar (pulled and built if MOZ_CALENDAR is set)
-#
-CVSCO_CALENDAR := $(CVSCO) $(CVS_CO_DATE_FLAGS) mozilla/calendar
-
-ifdef MOZ_CALENDAR
-FASTUPDATE_CALENDAR := fast_update $(CVSCO_CALENDAR)
-CHECKOUT_CALENDAR := cvs_co $(CVSCO_CALENDAR)
-else
-CHECKOUT_CALENDAR := true
-FASTUPDATE_CALENDAR := true
-endif
-
-
-# because some cygwin tools can't handle native dos-drive paths & vice-versa
-# force configure to use a relative path for --srcdir
-# need a better check for win32
-# and we need to get OBJDIR earlier
-ifdef MOZ_TOOLS
-_tmpobjdir := $(shell cygpath -u $(OBJDIR))
-_abs2rel := $(shell cygpath -w $(TOPSRCDIR)/build/unix/abs2rel.pl | sed -e 's|\\|/|g')
-_OBJ2SRCPATH := $(shell $(_abs2rel) $(TOPSRCDIR) $(_tmpobjdir))
-endif 
-
-#######################################################################
-# Rules
-# 
-
-# Print out any options loaded from mozconfig.
-all build checkout clean depend distclean export libs install realclean::
-	@if test -f .mozconfig.out; then \
-	  cat .mozconfig.out; \
-	  rm -f .mozconfig.out; \
-	else true; \
-	fi
-
-ifdef _IS_FIRST_CHECKOUT
-all:: checkout build
-else
-all:: checkout alldep
-endif
-
-# Windows equivalents
-pull_all: checkout
-build_all: build
-build_all_dep: alldep
-build_all_depend: alldep
-clobber clobber_all: clean
-pull_and_build_all: checkout alldep
-
-# Do everything from scratch
-everything: checkout clean build
-
-####################################
-# CVS checkout
-#
-checkout::
-#	@: Backup the last checkout log.
-	@if test -f $(CVSCO_LOGFILE) ; then \
-	  mv $(CVSCO_LOGFILE) $(CVSCO_LOGFILE).old; \
-	else true; \
-	fi
-ifdef RUN_AUTOCONF_LOCALLY
-	@echo "Removing local configures" ; \
-	cd $(ROOTDIR) && \
-	$(RM) -f mozilla/configure mozilla/nsprpub/configure \
-		mozilla/directory/c-sdk/configure
-endif
-	@echo "checkout start: "`date` | tee $(CVSCO_LOGFILE)
-	@echo '$(CVSCO) mozilla/client.mk mozilla/build/unix/modules.mk'; \
-        cd $(ROOTDIR) && \
-	$(CVSCO) mozilla/client.mk mozilla/build/unix/modules.mk
-	@cd $(ROOTDIR) && $(MAKE) -f mozilla/client.mk real_checkout
-
-real_checkout:
-#	@: Start the checkout. Split the output to the tty and a log file. \
-#	 : If it fails, touch an error file because "tee" hides the error.
-	@failed=.cvs-failed.tmp; rm -f $$failed*; \
-	cvs_co() { echo "$$@" ; \
-	  ("$$@" || touch $$failed) 2>&1 | tee -a $(CVSCO_LOGFILE) && \
-	  if test -f $$failed; then false; else true; fi; }; \
-	cvs_co $(CVSCO_NSPR) && \
-	cvs_co $(CVSCO_NSS) && \
-	cvs_co $(CVSCO_PSM) && \
-        cvs_co $(CVSCO_LDAPCSDK) && \
-        cvs_co $(CVSCO_ACCESSIBLE) && \
-        cvs_co $(CVSCO_GFX2) && \
-        cvs_co $(CVSCO_IMGLIB2) && \
-	$(CHECKOUT_CALENDAR) && \
-	$(CHECKOUT_LIBART) && \
-	cvs_co $(CVSCO_SEAMONKEY) && \
-	cvs_co $(CVSCO_NOSUBDIRS)
-	@echo "checkout finish: "`date` | tee -a $(CVSCO_LOGFILE)
-#	@: Check the log for conflicts. ;
-	@conflicts=`egrep "^C " $(CVSCO_LOGFILE)` ;\
-	if test "$$conflicts" ; then \
-	  echo "$(MAKE): *** Conflicts during checkout." ;\
-	  echo "$$conflicts" ;\
-	  echo "$(MAKE): Refer to $(CVSCO_LOGFILE) for full log." ;\
-	  false; \
-	else true; \
-	fi
-ifdef RUN_AUTOCONF_LOCALLY
-	@echo Generating configures using $(AUTOCONF) ; \
-	cd $(TOPSRCDIR) && $(AUTOCONF) && \
-	cd $(TOPSRCDIR)/nsprpub && $(AUTOCONF) && \
-	cd $(TOPSRCDIR)/directory/c-sdk && $(AUTOCONF)
-endif
-
-fast-update:
-#	@: Backup the last checkout log.
-	@if test -f $(CVSCO_LOGFILE) ; then \
-	  mv $(CVSCO_LOGFILE) $(CVSCO_LOGFILE).old; \
-	else true; \
-	fi
-ifdef RUN_AUTOCONF_LOCALLY
-	@echo "Removing local configures" ; \
-	cd $(ROOTDIR) && \
-	$(RM) -f mozilla/configure mozilla/nsprpub/configure \
-		mozilla/directory/c-sdk/configure
-endif
-	@echo "checkout start: "`date` | tee $(CVSCO_LOGFILE)
-	@echo '$(CVSCO) mozilla/client.mk mozilla/build/unix/modules.mk'; \
-        cd $(ROOTDIR) && \
-	$(CVSCO) mozilla/client.mk mozilla/build/unix/modules.mk
-	@cd $(TOPSRCDIR) && \
-	$(MAKE) -f client.mk real_fast-update
-
-real_fast-update:
-#	@: Start the update. Split the output to the tty and a log file. \
-#	 : If it fails, touch an error file because "tee" hides the error.
-	@failed=.fast_update-failed.tmp; rm -f $$failed*; \
-	fast_update() { (config/cvsco-fast-update.pl $$@ || touch $$failed) 2>&1 | tee -a $(CVSCO_LOGFILE) && \
-	  if test -f $$failed; then false; else true; fi; }; \
-	cvs_co() { echo "$$@" ; \
-	  ("$$@" || touch $$failed) 2>&1 | tee -a $(CVSCO_LOGFILE) && \
-	  if test -f $$failed; then false; else true; fi; }; \
-	fast_update $(CVSCO_NSPR) && \
-	cd $(ROOTDIR) && \
-	failed=mozilla/.fast_update-failed.tmp && \
-	cvs_co $(CVSCO_NSS) && \
-	failed=.fast_update-failed.tmp && \
-	cd mozilla && \
-	fast_update $(CVSCO_PSM) && \
-	fast_update $(CVSCO_LDAPCSDK) && \
-	fast_update $(CVSCO_ACCESSIBLE) && \
-	fast_update $(CVSCO_GFX2) && \
-	fast_update $(CVSCO_IMGLIB2) && \
-	$(FASTUPDATE_CALENDAR) && \
-	$(FASTUPDATE_LIBART) && \
-	fast_update $(CVSCO_SEAMONKEY) && \
-	fast_update $(CVSCO_NOSUBDIRS)
-	@echo "fast_update finish: "`date` | tee -a $(CVSCO_LOGFILE)
-#	@: Check the log for conflicts. ;
-	@conflicts=`egrep "^C " $(CVSCO_LOGFILE)` ;\
-	if test "$$conflicts" ; then \
-	  echo "$(MAKE): *** Conflicts during fast-update." ;\
-	  echo "$$conflicts" ;\
-	  echo "$(MAKE): Refer to $(CVSCO_LOGFILE) for full log." ;\
-	  false; \
-	else true; \
-	fi
-ifdef RUN_AUTOCONF_LOCALLY
-	@echo Generating configures using $(AUTOCONF) ; \
-	cd $(TOPSRCDIR) && $(AUTOCONF) && \
-	cd $(TOPSRCDIR)/nsprpub && $(AUTOCONF) && \
-	cd $(TOPSRCDIR)/directory/c-sdk && $(AUTOCONF)
-endif
-
-####################################
-# Web configure
-
-WEBCONFIG_FILE  := $(HOME)/.mozconfig
-
-MOZCONFIG2CONFIGURATOR := build/autoconf/mozconfig2configurator
-webconfig:
-	@cd $(TOPSRCDIR); \
-	url=`$(MOZCONFIG2CONFIGURATOR) $(TOPSRCDIR)`; \
-	echo Running mozilla with the following url: ;\
-	echo ;\
-	echo $$url ;\
-	mozilla -remote "openURL($$url)" || \
-	netscape -remote "openURL($$url)" || \
-	mozilla $$url || \
-	netscape $$url ;\
-	echo ;\
-	echo   1. Fill out the form on the browser. ;\
-	echo   2. Save the results to $(WEBCONFIG_FILE)
-
-#####################################################
-# First Checkout
-
-ifdef _IS_FIRST_CHECKOUT
-# First time, do build target in a new process to pick up new files.
-build::
-	$(MAKE) -f $(TOPSRCDIR)/client.mk build
-else
-
-#####################################################
-# After First Checkout
-
-
-####################################
-# Configure
-
-CONFIG_STATUS := $(wildcard $(OBJDIR)/config.status)
-CONFIG_CACHE  := $(wildcard $(OBJDIR)/config.cache)
-
-ifdef RUN_AUTOCONF_LOCALLY
-EXTRA_CONFIG_DEPS := \
-	$(TOPSRCDIR)/aclocal.m4 \
-	$(wildcard $(TOPSRCDIR)/build/autoconf/*.m4) \
-	$(NULL)
-
-$(TOPSRCDIR)/configure: $(TOPSRCDIR)/configure.in $(EXTRA_CONFIG_DEPS)
-	@echo Generating $@ using autoconf
-	cd $(TOPSRCDIR); $(AUTOCONF)
-endif
-
-CONFIG_STATUS_DEPS_L10N := $(wildcard $(TOPSRCDIR)/l10n/makefiles.all)
-
-CONFIG_STATUS_DEPS := \
-	$(TOPSRCDIR)/configure \
-	$(TOPSRCDIR)/allmakefiles.sh \
-	$(TOPSRCDIR)/.mozconfig.mk \
-	$(wildcard $(TOPSRCDIR)/nsprpub/configure) \
-	$(wildcard $(TOPSRCDIR)/directory/c-sdk/configure) \
-	$(wildcard $(TOPSRCDIR)/mailnews/makefiles) \
-	$(CONFIG_STATUS_DEPS_L10N) \
-	$(wildcard $(TOPSRCDIR)/themes/makefiles) \
-	$(NULL)
-
-# configure uses the program name to determine @srcdir@. Calling it without
-#   $(TOPSRCDIR) will set @srcdir@ to "."; otherwise, it is set to the full
-#   path of $(TOPSRCDIR).
-ifeq ($(TOPSRCDIR),$(OBJDIR))
-  CONFIGURE := ./configure
-else
-  CONFIGURE := $(TOPSRCDIR)/configure
-endif
-
-ifdef _OBJ2SRCPATH
-CONFIGURE_ARGS := --srcdir=$(_OBJ2SRCPATH) $(CONFIGURE_ARGS)
-endif
-
-$(OBJDIR)/Makefile $(OBJDIR)/config.status: $(CONFIG_STATUS_DEPS)
-	@if test ! -d $(OBJDIR); then $(MKDIR) $(OBJDIR); else true; fi
-	@echo cd $(OBJDIR);
-	@echo $(CONFIGURE) $(CONFIGURE_ARGS)
-	@cd $(OBJDIR) && $(CONFIGURE_ENV_ARGS) $(CONFIGURE) $(CONFIGURE_ARGS) \
-	  || ( echo "*** Fix above errors and then restart with\
-               \"$(MAKE) -f client.mk build\"" && exit 1 )
-	@touch $(OBJDIR)/Makefile
-
-ifdef CONFIG_STATUS
-$(OBJDIR)/config/autoconf.mk: $(TOPSRCDIR)/config/autoconf.mk.in
-	cd $(OBJDIR); \
-	  CONFIG_FILES=config/autoconf.mk ./config.status
-endif
-
-
-####################################
-# Depend
-
-depend:: $(OBJDIR)/Makefile $(OBJDIR)/config.status
-	$(MOZ_MAKE) export && $(MOZ_MAKE) depend
-
-####################################
-# Build it
-
-build::  $(OBJDIR)/Makefile $(OBJDIR)/config.status
-	$(MOZ_MAKE)
-
-####################################
-# Other targets
-
-# Pass these target onto the real build system
-install export libs clean realclean distclean alldep:: $(OBJDIR)/Makefile $(OBJDIR)/config.status
-	$(MOZ_MAKE) $@
-
-cleansrcdir:
-	@cd $(TOPSRCDIR); \
-        if [ -f webshell/embed/gtk/Makefile ]; then \
-          $(MAKE) -C webshell/embed/gtk distclean; \
-        fi; \
-	if [ -f Makefile ]; then \
-	  $(MAKE) distclean ; \
-	else \
-	  echo "Removing object files from srcdir..."; \
-	  rm -fr `find . -type d \( -name .deps -print -o -name CVS \
-	          -o -exec test ! -d {}/CVS \; \) -prune \
-	          -o \( -name '*.[ao]' -o -name '*.so' \) -type f -print`; \
-	   build/autoconf/clean-config.sh; \
-	fi;
-
-# (! IS_FIRST_CHECKOUT)
-endif
-
-.PHONY: checkout real_checkout depend build export libs alldep install clean realclean distclean cleansrcdir pull_all build_all clobber clobber_all pull_and_build_all everything

mozilla/js2/AUTHORS

@@ -0,0 +1 @@
+

mozilla/js2/COPYING

@@ -0,0 +1,29 @@
+The contents of this file are subject to the Netscape Public
+License Version 1.1 (the "License"); you may not use this file
+except in compliance with the License. You may obtain a copy of
+the License at http://www.mozilla.org/NPL/
+
+Software distributed under the License is distributed on an "AS
+IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+implied. See the License for the specific language governing
+rights and limitations under the License.
+
+The Original Code is the JavaScript 2 Prototype.
+
+The Initial Developer of the Original Code is Netscape
+Communications Corporation.  Portions created by Netscape are
+Copyright (C) 1998 Netscape Communications Corporation. All
+Rights Reserved.
+
+Alternatively, the contents of this file may be used under the
+terms of the GNU Public License (the "GPL"), in which case the
+provisions of the GPL are applicable instead of those above.
+If you wish to allow use of your version of this file only
+under the terms of the GPL and not to allow others to use your
+version of this file under the NPL, indicate your decision by
+deleting the provisions above and replace them with the notice
+and other provisions required by the GPL.  If you do not delete
+the provisions above, a recipient may use your version of this
+file under either the NPL or the GPL.
+
+

mozilla/js2/ChangeLog

@@ -0,0 +1,14 @@
+2001-01-30    <rginda@netscape.com>
+
+	* broke apart some classes contained parser.* and utilities.* into
+	  seperate files.
+	  parser.* begat lexer.*, token.*, reader.*
+	  utilities.* begat mem.*, stlcfg.h, ds.h, strings.*, exception.*,
+	  formatter.*, and algo.h
+	* parser reorg compile time data:
+
+	  new layout: 0:48.01elapsed 86%CPU
+	  old layout: 0:55.85elapsed 57%CPU
+
+	  (old layout includes only hash numerics utilities parser world object
+	  files)

mozilla/js2/INSTALL

@@ -0,0 +1 @@
+

mozilla/js2/Makefile.am

@@ -0,0 +1,2 @@
+
+SUBDIRS = src tests

mozilla/js2/NEWS

@@ -0,0 +1 @@
+

mozilla/js2/README

@@ -0,0 +1,98 @@
+parse functions
+    parseIdentifierQualifiers(ExprNode *e, bool &foundQualifiers,
+    parseParenthesesAndIdentifierQualifiers(const Token &tParen,
+    parseQualifiedIdentifier(const Token &t, bool preferRegExp)
+    parseArrayLiteral(const Token &initialToken)
+    parseObjectLiteral(const Token &initialToken)
+    parsePrimaryExpression()
+    parseMember(ExprNode *target, const Token &tOperator,
+    parseInvoke(ExprNode *target, uint32 pos,
+    parsePostfixExpression(bool newExpression)
+    parseUnaryExpression()
+    parseExpression(bool noIn, bool noAssignment, bool noComma)
+    parseParenthesizedExpression()
+    parseTypeExpression(bool noIn)
+    parseTypedIdentifier(ExprNode *&type)
+    parseTypeBinding(Token::Kind kind, bool noIn)
+    parseTypeListBinding(Token::Kind kind)
+    parseVariableBinding(bool noQualifiers, bool noIn)
+    parseFunctionName(FunctionName &fn)
+    parseFunctionSignature(FunctionDefinition &fd)
+    parseBlock(bool inSwitch, bool noCloseBrace)
+    parseBody(SemicolonState *semicolonState)
+    parseAttributeStatement(uint32 pos, IdentifierList *attributes,
+    parseAttributesAndStatement(const Token *t, AttributeStatement as,
+    parseAnnotatedBlock()
+    parseFor(uint32 pos, SemicolonState &semicolonState)
+    parseTry(uint32 pos)
+    parseStatement(bool /*topLevel*/, bool inSwitch,
+    parseStatementAndSemicolon(SemicolonState &semicolonState)
+    parseIdentifier()
+    parseLiteralField()
+    parseFieldName()
+    parseArgumentList(NodeQueue<ExprPairList> &args)
+    parseArgumentListPrime(NodeQueue<ExprPairList> &args)
+    parseNamedArgumentListPrime(NodeQueue<ExprPairList> &args)
+    parseAllParameters(FunctionDefinition &fd,
+    parseOptionalNamedRestParameters (FunctionDefinition &fd,
+    parseNamedRestParameters(FunctionDefinition &fd,
+    parseNamedParameters(FunctionDefinition &fd,
+    parseRestParameter()
+    parseParameter()
+    parseOptionalParameter()
+    parseOptionalParameterPrime(VariableBinding *first)
+    parseNamedParameter(NodeQueue<IdentifierList> &aliases)
+    parseResultSignature()
+
+
+1/28/01
+
+Files:
+
+cpucfg.h
+
+formatter.cpp formatter.h
+"Formatter" class, iostream like wrapper around stdio.
+
+gc_allocator.h, gc_container.h
+boehm gc stuff.
+
+hash.cpp hash.h
+a hash
+
+lexer.cpp lexer.h
+main lexer.
+
+mem.cpp mem.h
+zone, arena, and pool classes for memory management.
+
+nodefactory.h
+parse node factory.
+
+numerics.cpp numerics.h
+numbers and stuff.
+
+parser.cpp parser.h
+main parser source.
+tables in parser.h: 
+    enum ExprNode::Kind; types of expressions
+    enum StmtNode::Kind; types of statements
+
+
+reader.cpp reader.h
+"Reader" class, feeds source to the parser/lexer.
+
+stlcfg.h
+stupid stl tricks
+.
+systemtypes.h
+basic typedefs.
+
+token.cpp token.h
+token class.
+
+utilities.cpp utilities.h
+random things.
+
+world.cpp world.h
+the whole world.

mozilla/js2/TODO

@@ -0,0 +1,26 @@
+redo parseAllPArameters code
+
+
+move js/js2 to js2/src
+move js/semantics to js2/semantics
+
+compile on mac and windows
+
+parser:
+
+1. Parser is out of date (by 10%?)
+    a. rework parser to reflect grammer productions.
+    b. functional attrs.
+    c. parser node struct changes.
+
+2. Parser Restructuring (2 weeks.)
+
+3. Common lisp generator running?
+
+4. const-ness
+    a. compile time detection.
+    b. read before assign.
+    c. runtime assignment prevention.
+    d. class/ function/ const equivalence.
+
+export, namespace, import, package ?

mozilla/js2/aclocal.m4

@@ -0,0 +1,140 @@
+dnl aclocal.m4 generated automatically by aclocal 1.4
+
+dnl Copyright (C) 1994, 1995-8, 1999 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl This program is distributed in the hope that it will be useful,
+dnl but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+dnl even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+dnl PARTICULAR PURPOSE.
+
+# Do all the work for Automake.  This macro actually does too much --
+# some checks are only needed if your package does certain things.
+# But this isn't really a big deal.
+
+# serial 1
+
+dnl Usage:
+dnl AM_INIT_AUTOMAKE(package,version, [no-define])
+
+AC_DEFUN(AM_INIT_AUTOMAKE,
+[AC_REQUIRE([AC_PROG_INSTALL])
+PACKAGE=[$1]
+AC_SUBST(PACKAGE)
+VERSION=[$2]
+AC_SUBST(VERSION)
+dnl test to see if srcdir already configured
+if test "`cd $srcdir && pwd`" != "`pwd`" && test -f $srcdir/config.status; then
+  AC_MSG_ERROR([source directory already configured; run "make distclean" there first])
+fi
+ifelse([$3],,
+AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE", [Name of package])
+AC_DEFINE_UNQUOTED(VERSION, "$VERSION", [Version number of package]))
+AC_REQUIRE([AM_SANITY_CHECK])
+AC_REQUIRE([AC_ARG_PROGRAM])
+dnl FIXME This is truly gross.
+missing_dir=`cd $ac_aux_dir && pwd`
+AM_MISSING_PROG(ACLOCAL, aclocal, $missing_dir)
+AM_MISSING_PROG(AUTOCONF, autoconf, $missing_dir)
+AM_MISSING_PROG(AUTOMAKE, automake, $missing_dir)
+AM_MISSING_PROG(AUTOHEADER, autoheader, $missing_dir)
+AM_MISSING_PROG(MAKEINFO, makeinfo, $missing_dir)
+AC_REQUIRE([AC_PROG_MAKE_SET])])
+
+#
+# Check to make sure that the build environment is sane.
+#
+
+AC_DEFUN(AM_SANITY_CHECK,
+[AC_MSG_CHECKING([whether build environment is sane])
+# Just in case
+sleep 1
+echo timestamp > conftestfile
+# Do `set' in a subshell so we don't clobber the current shell's
+# arguments.  Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+   set X `ls -Lt $srcdir/configure conftestfile 2> /dev/null`
+   if test "[$]*" = "X"; then
+      # -L didn't work.
+      set X `ls -t $srcdir/configure conftestfile`
+   fi
+   if test "[$]*" != "X $srcdir/configure conftestfile" \
+      && test "[$]*" != "X conftestfile $srcdir/configure"; then
+
+      # If neither matched, then we have a broken ls.  This can happen
+      # if, for instance, CONFIG_SHELL is bash and it inherits a
+      # broken ls alias from the environment.  This has actually
+      # happened.  Such a system could not be considered "sane".
+      AC_MSG_ERROR([ls -t appears to fail.  Make sure there is not a broken
+alias in your environment])
+   fi
+
+   test "[$]2" = conftestfile
+   )
+then
+   # Ok.
+   :
+else
+   AC_MSG_ERROR([newly created file is older than distributed files!
+Check your system clock])
+fi
+rm -f conftest*
+AC_MSG_RESULT(yes)])
+
+dnl AM_MISSING_PROG(NAME, PROGRAM, DIRECTORY)
+dnl The program must properly implement --version.
+AC_DEFUN(AM_MISSING_PROG,
+[AC_MSG_CHECKING(for working $2)
+# Run test in a subshell; some versions of sh will print an error if
+# an executable is not found, even if stderr is redirected.
+# Redirect stdin to placate older versions of autoconf.  Sigh.
+if ($2 --version) < /dev/null > /dev/null 2>&1; then
+   $1=$2
+   AC_MSG_RESULT(found)
+else
+   $1="$3/missing $2"
+   AC_MSG_RESULT(missing)
+fi
+AC_SUBST($1)])
+
+# Define a conditional.
+
+AC_DEFUN(AM_CONDITIONAL,
+[AC_SUBST($1_TRUE)
+AC_SUBST($1_FALSE)
+if $2; then
+  $1_TRUE=
+  $1_FALSE='#'
+else
+  $1_TRUE='#'
+  $1_FALSE=
+fi])
+
+# Like AC_CONFIG_HEADER, but automatically create stamp file.
+
+AC_DEFUN(AM_CONFIG_HEADER,
+[AC_PREREQ([2.12])
+AC_CONFIG_HEADER([$1])
+dnl When config.status generates a header, we must update the stamp-h file.
+dnl This file resides in the same directory as the config header
+dnl that is generated.  We must strip everything past the first ":",
+dnl and everything past the last "/".
+AC_OUTPUT_COMMANDS(changequote(<<,>>)dnl
+ifelse(patsubst(<<$1>>, <<[^ ]>>, <<>>), <<>>,
+<<test -z "<<$>>CONFIG_HEADERS" || echo timestamp > patsubst(<<$1>>, <<^\([^:]*/\)?.*>>, <<\1>>)stamp-h<<>>dnl>>,
+<<am_indx=1
+for am_file in <<$1>>; do
+  case " <<$>>CONFIG_HEADERS " in
+  *" <<$>>am_file "*<<)>>
+    echo timestamp > `echo <<$>>am_file | sed -e 's%:.*%%' -e 's%[^/]*$%%'`stamp-h$am_indx
+    ;;
+  esac
+  am_indx=`expr "<<$>>am_indx" + 1`
+done<<>>dnl>>)
+changequote([,]))])
+

mozilla/js2/common.mk

@@ -0,0 +1,20 @@
+
+BOEHM_DIR = $(top_srcdir)/../gc/boehm/
+LIBBOEHM = $(BOEHM_DIR)/gc.a
+
+JS2_DIR = $(top_srcdir)/src/
+LIBJS2 = $(JS2_DIR)/libjs2.a
+
+WFLAGS = -Wmissing-prototypes -Wstrict-prototypes -Wunused \
+         -Wswitch -Wall -Wconversion
+
+if DEBUG
+CXXFLAGS = -DXP_UNIX -g -DDEBUG $(WFLAGS)
+JS1x_BINDIR = Linux_All_DBG.OBJ
+else
+CXXFLAGS = -DXP_UNIX -O2 -Wuninitialized $(WFLAGS)
+JS1x_BINDIR = Linux_All_OPT.OBJ
+endif
+
+FDLIBM_DIR = $(top_srcdir)/../js/src/fdlibm/$(JS1x_BINDIR)
+LIBFDLIBM = $(FDLIBM_DIR)/libfdm.a

mozilla/js2/config.h.in

@@ -0,0 +1,42 @@
+/* config.h.in.  Generated automatically from configure.in by autoheader.  */
+
+/* Define if using alloca.c.  */
+#undef C_ALLOCA
+
+/* Define to one of _getb67, GETB67, getb67 for Cray-2 and Cray-YMP systems.
+   This function is required for alloca.c support on those systems.  */
+#undef CRAY_STACKSEG_END
+
+/* Define if you have alloca, as a function or macro.  */
+#undef HAVE_ALLOCA
+
+/* Define if you have <alloca.h> and it should be used (not on Ultrix).  */
+#undef HAVE_ALLOCA_H
+
+/* Define if you have a working `mmap' system call.  */
+#undef HAVE_MMAP
+
+/* If using the C implementation of alloca, define if you know the
+   direction of stack growth for your system; otherwise it will be
+   automatically deduced at run-time.
+ STACK_DIRECTION > 0 => grows toward higher addresses
+ STACK_DIRECTION < 0 => grows toward lower addresses
+ STACK_DIRECTION = 0 => direction of growth unknown
+ */
+#undef STACK_DIRECTION
+
+/* Define if you have the ANSI C header files.  */
+#undef STDC_HEADERS
+
+/* Define if you have the getpagesize function.  */
+#undef HAVE_GETPAGESIZE
+
+/* Define if you have the <unistd.h> header file.  */
+#undef HAVE_UNISTD_H
+
+/* Name of package */
+#undef PACKAGE
+
+/* Version number of package */
+#undef VERSION
+

mozilla/js2/configure.in

@@ -0,0 +1,57 @@
+dnl Process this file with autoconf to produce a configure script.
+
+PACKAGE=JavaScript2
+VERSION=0.1
+AC_INIT(src/parser.h)
+AM_INIT_AUTOMAKE(JavaScript2, 0.1)
+
+AC_ARG_ENABLE(debug,
+[  --enable-debug    Turn on debugging],
+[case "${enableval}" in
+  yes) debug=true ;;
+  no)  debug=false ;;
+  *) AC_MSG_ERROR(bad value ${enableval} for --enable-debug) ;;
+esac],[debug=false])
+AM_CONDITIONAL(DEBUG, test x$debug = xtrue)
+
+AM_CONFIG_HEADER(config.h)
+dnl Checks for programs.
+AC_PROG_CXX
+AC_PROG_AWK
+AC_PROG_CC
+AC_PROG_INSTALL
+AC_PROG_LN_S
+AC_PROG_MAKE_SET
+AC_PROG_RANLIB
+dnl AM_PATH_GTK(1.2.0, ,
+dnl            AC_MSG_ERROR(Cannot find GTK: Is gtk-config in path?))
+
+dnl Checks for libraries.
+dnl Replace `main' with a function in -ldl:
+dnl AC_CHECK_LIB(dl, main)
+dnl Replace `main' with a function in -lgdk:
+dnl AC_CHECK_LIB(gdk, main)
+dnl Replace `main' with a function in -lglib:
+dnl AC_CHECK_LIB(glib, main)
+dnl Replace `main' with a function in -lgmodule:
+dnl AC_CHECK_LIB(gmodule, main)
+dnl Replace `main' with a function in -lgtk:
+dnl AC_CHECK_LIB(gtk, main)
+dnl Replace `main' with a function in -lm:
+dnl AC_CHECK_LIB(m, main)
+
+dnl Checks for header files.
+AC_HEADER_STDC
+dnl AC_CHECK_HEADERS(fcntl.h limits.h malloc.h strings.h unistd.h)
+
+dnl Checks for typedefs, structures, and compiler characteristics.
+dnl AC_C_CONST
+dnl AC_C_INLINE
+dnl AC_TYPE_SIZE_T
+
+dnl Checks for library functions.
+AC_FUNC_ALLOCA
+AC_FUNC_MMAP
+dnl AC_CHECK_FUNCS(getcwd getwd putenv strdup strerror tcgetattr)
+
+AC_OUTPUT(./Makefile src/Makefile tests/Makefile tests/cpp/Makefile tests/js/Makefile)

mozilla/js2/install-sh

@@ -0,0 +1,251 @@
+#!/bin/sh
+#
+# install - install a program, script, or datafile
+# This comes from X11R5 (mit/util/scripts/install.sh).
+#
+# Copyright 1991 by the Massachusetts Institute of Technology
+#
+# Permission to use, copy, modify, distribute, and sell this software and its
+# documentation for any purpose is hereby granted without fee, provided that
+# the above copyright notice appear in all copies and that both that
+# copyright notice and this permission notice appear in supporting
+# documentation, and that the name of M.I.T. not be used in advertising or
+# publicity pertaining to distribution of the software without specific,
+# written prior permission.  M.I.T. makes no representations about the
+# suitability of this software for any purpose.  It is provided "as is"
+# without express or implied warranty.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# `make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch.  It can only install one file at a time, a restriction
+# shared with many OS's install programs.
+
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit="${DOITPROG-}"
+
+
+# put in absolute paths if you don't have them in your path; or use env. vars.
+
+mvprog="${MVPROG-mv}"
+cpprog="${CPPROG-cp}"
+chmodprog="${CHMODPROG-chmod}"
+chownprog="${CHOWNPROG-chown}"
+chgrpprog="${CHGRPPROG-chgrp}"
+stripprog="${STRIPPROG-strip}"
+rmprog="${RMPROG-rm}"
+mkdirprog="${MKDIRPROG-mkdir}"
+
+transformbasename=""
+transform_arg=""
+instcmd="$mvprog"
+chmodcmd="$chmodprog 0755"
+chowncmd=""
+chgrpcmd=""
+stripcmd=""
+rmcmd="$rmprog -f"
+mvcmd="$mvprog"
+src=""
+dst=""
+dir_arg=""
+
+while [ x"$1" != x ]; do
+    case $1 in
+	-c) instcmd="$cpprog"
+	    shift
+	    continue;;
+
+	-d) dir_arg=true
+	    shift
+	    continue;;
+
+	-m) chmodcmd="$chmodprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-o) chowncmd="$chownprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-g) chgrpcmd="$chgrpprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-s) stripcmd="$stripprog"
+	    shift
+	    continue;;
+
+	-t=*) transformarg=`echo $1 | sed 's/-t=//'`
+	    shift
+	    continue;;
+
+	-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
+	    shift
+	    continue;;
+
+	*)  if [ x"$src" = x ]
+	    then
+		src=$1
+	    else
+		# this colon is to work around a 386BSD /bin/sh bug
+		:
+		dst=$1
+	    fi
+	    shift
+	    continue;;
+    esac
+done
+
+if [ x"$src" = x ]
+then
+	echo "install:	no input file specified"
+	exit 1
+else
+	true
+fi
+
+if [ x"$dir_arg" != x ]; then
+	dst=$src
+	src=""
+	
+	if [ -d $dst ]; then
+		instcmd=:
+		chmodcmd=""
+	else
+		instcmd=mkdir
+	fi
+else
+
+# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
+# might cause directories to be created, which would be especially bad 
+# if $src (and thus $dsttmp) contains '*'.
+
+	if [ -f $src -o -d $src ]
+	then
+		true
+	else
+		echo "install:  $src does not exist"
+		exit 1
+	fi
+	
+	if [ x"$dst" = x ]
+	then
+		echo "install:	no destination specified"
+		exit 1
+	else
+		true
+	fi
+
+# If destination is a directory, append the input filename; if your system
+# does not like double slashes in filenames, you may need to add some logic
+
+	if [ -d $dst ]
+	then
+		dst="$dst"/`basename $src`
+	else
+		true
+	fi
+fi
+
+## this sed command emulates the dirname command
+dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
+
+# Make sure that the destination directory exists.
+#  this part is taken from Noah Friedman's mkinstalldirs script
+
+# Skip lots of stat calls in the usual case.
+if [ ! -d "$dstdir" ]; then
+defaultIFS='	
+'
+IFS="${IFS-${defaultIFS}}"
+
+oIFS="${IFS}"
+# Some sh's can't handle IFS=/ for some reason.
+IFS='%'
+set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
+IFS="${oIFS}"
+
+pathcomp=''
+
+while [ $# -ne 0 ] ; do
+	pathcomp="${pathcomp}${1}"
+	shift
+
+	if [ ! -d "${pathcomp}" ] ;
+        then
+		$mkdirprog "${pathcomp}"
+	else
+		true
+	fi
+
+	pathcomp="${pathcomp}/"
+done
+fi
+
+if [ x"$dir_arg" != x ]
+then
+	$doit $instcmd $dst &&
+
+	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
+	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
+	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
+	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
+else
+
+# If we're going to rename the final executable, determine the name now.
+
+	if [ x"$transformarg" = x ] 
+	then
+		dstfile=`basename $dst`
+	else
+		dstfile=`basename $dst $transformbasename | 
+			sed $transformarg`$transformbasename
+	fi
+
+# don't allow the sed command to completely eliminate the filename
+
+	if [ x"$dstfile" = x ] 
+	then
+		dstfile=`basename $dst`
+	else
+		true
+	fi
+
+# Make a temp file name in the proper directory.
+
+	dsttmp=$dstdir/#inst.$$#
+
+# Move or copy the file name to the temp name
+
+	$doit $instcmd $src $dsttmp &&
+
+	trap "rm -f ${dsttmp}" 0 &&
+
+# and set any options; do chmod last to preserve setuid bits
+
+# If any of these fail, we abort the whole thing.  If we want to
+# ignore errors from any of these, just make sure not to ignore
+# errors from the above "$doit $instcmd $src $dsttmp" command.
+
+	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
+	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
+	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
+	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
+
+# Now rename the file to the real destination.
+
+	$doit $rmcmd -f $dstdir/$dstfile &&
+	$doit $mvcmd $dsttmp $dstdir/$dstfile 
+
+fi &&
+
+
+exit 0

mozilla/js2/missing

@@ -0,0 +1,190 @@
+#! /bin/sh
+# Common stub for a few missing GNU programs while installing.
+# Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+# Franc,ois Pinard <pinard@iro.umontreal.ca>, 1996.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+if test $# -eq 0; then
+  echo 1>&2 "Try \`$0 --help' for more information"
+  exit 1
+fi
+
+case "$1" in
+
+  -h|--h|--he|--hel|--help)
+    echo "\
+$0 [OPTION]... PROGRAM [ARGUMENT]...
+
+Handle \`PROGRAM [ARGUMENT]...' for when PROGRAM is missing, or return an
+error status if there is no known handling for PROGRAM.
+
+Options:
+  -h, --help      display this help and exit
+  -v, --version   output version information and exit
+
+Supported PROGRAM values:
+  aclocal      touch file \`aclocal.m4'
+  autoconf     touch file \`configure'
+  autoheader   touch file \`config.h.in'
+  automake     touch all \`Makefile.in' files
+  bison        create \`y.tab.[ch]', if possible, from existing .[ch]
+  flex         create \`lex.yy.c', if possible, from existing .c
+  lex          create \`lex.yy.c', if possible, from existing .c
+  makeinfo     touch the output file
+  yacc         create \`y.tab.[ch]', if possible, from existing .[ch]"
+    ;;
+
+  -v|--v|--ve|--ver|--vers|--versi|--versio|--version)
+    echo "missing - GNU libit 0.0"
+    ;;
+
+  -*)
+    echo 1>&2 "$0: Unknown \`$1' option"
+    echo 1>&2 "Try \`$0 --help' for more information"
+    exit 1
+    ;;
+
+  aclocal)
+    echo 1>&2 "\
+WARNING: \`$1' is missing on your system.  You should only need it if
+         you modified \`acinclude.m4' or \`configure.in'.  You might want
+         to install the \`Automake' and \`Perl' packages.  Grab them from
+         any GNU archive site."
+    touch aclocal.m4
+    ;;
+
+  autoconf)
+    echo 1>&2 "\
+WARNING: \`$1' is missing on your system.  You should only need it if
+         you modified \`configure.in'.  You might want to install the
+         \`Autoconf' and \`GNU m4' packages.  Grab them from any GNU
+         archive site."
+    touch configure
+    ;;
+
+  autoheader)
+    echo 1>&2 "\
+WARNING: \`$1' is missing on your system.  You should only need it if
+         you modified \`acconfig.h' or \`configure.in'.  You might want
+         to install the \`Autoconf' and \`GNU m4' packages.  Grab them
+         from any GNU archive site."
+    files=`sed -n 's/^[ ]*A[CM]_CONFIG_HEADER(\([^)]*\)).*/\1/p' configure.in`
+    test -z "$files" && files="config.h"
+    touch_files=
+    for f in $files; do
+      case "$f" in
+      *:*) touch_files="$touch_files "`echo "$f" |
+				       sed -e 's/^[^:]*://' -e 's/:.*//'`;;
+      *) touch_files="$touch_files $f.in";;
+      esac
+    done
+    touch $touch_files
+    ;;
+
+  automake)
+    echo 1>&2 "\
+WARNING: \`$1' is missing on your system.  You should only need it if
+         you modified \`Makefile.am', \`acinclude.m4' or \`configure.in'.
+         You might want to install the \`Automake' and \`Perl' packages.
+         Grab them from any GNU archive site."
+    find . -type f -name Makefile.am -print |
+	   sed 's/\.am$/.in/' |
+	   while read f; do touch "$f"; done
+    ;;
+
+  bison|yacc)
+    echo 1>&2 "\
+WARNING: \`$1' is missing on your system.  You should only need it if
+         you modified a \`.y' file.  You may need the \`Bison' package
+         in order for those modifications to take effect.  You can get
+         \`Bison' from any GNU archive site."
+    rm -f y.tab.c y.tab.h
+    if [ $# -ne 1 ]; then
+        eval LASTARG="\${$#}"
+	case "$LASTARG" in
+	*.y)
+	    SRCFILE=`echo "$LASTARG" | sed 's/y$/c/'`
+	    if [ -f "$SRCFILE" ]; then
+	         cp "$SRCFILE" y.tab.c
+	    fi
+	    SRCFILE=`echo "$LASTARG" | sed 's/y$/h/'`
+	    if [ -f "$SRCFILE" ]; then
+	         cp "$SRCFILE" y.tab.h
+	    fi
+	  ;;
+	esac
+    fi
+    if [ ! -f y.tab.h ]; then
+	echo >y.tab.h
+    fi
+    if [ ! -f y.tab.c ]; then
+	echo 'main() { return 0; }' >y.tab.c
+    fi
+    ;;
+
+  lex|flex)
+    echo 1>&2 "\
+WARNING: \`$1' is missing on your system.  You should only need it if
+         you modified a \`.l' file.  You may need the \`Flex' package
+         in order for those modifications to take effect.  You can get
+         \`Flex' from any GNU archive site."
+    rm -f lex.yy.c
+    if [ $# -ne 1 ]; then
+        eval LASTARG="\${$#}"
+	case "$LASTARG" in
+	*.l)
+	    SRCFILE=`echo "$LASTARG" | sed 's/l$/c/'`
+	    if [ -f "$SRCFILE" ]; then
+	         cp "$SRCFILE" lex.yy.c
+	    fi
+	  ;;
+	esac
+    fi
+    if [ ! -f lex.yy.c ]; then
+	echo 'main() { return 0; }' >lex.yy.c
+    fi
+    ;;
+
+  makeinfo)
+    echo 1>&2 "\
+WARNING: \`$1' is missing on your system.  You should only need it if
+         you modified a \`.texi' or \`.texinfo' file, or any other file
+         indirectly affecting the aspect of the manual.  The spurious
+         call might also be the consequence of using a buggy \`make' (AIX,
+         DU, IRIX).  You might want to install the \`Texinfo' package or
+         the \`GNU make' package.  Grab either from any GNU archive site."
+    file=`echo "$*" | sed -n 's/.*-o \([^ ]*\).*/\1/p'`
+    if test -z "$file"; then
+      file=`echo "$*" | sed 's/.* \([^ ]*\) *$/\1/'`
+      file=`sed -n '/^@setfilename/ { s/.* \([^ ]*\) *$/\1/; p; q; }' $file`
+    fi
+    touch $file
+    ;;
+
+  *)
+    echo 1>&2 "\
+WARNING: \`$1' is needed, and you do not seem to have it handy on your
+         system.  You might have modified some files without having the
+         proper tools for further handling them.  Check the \`README' file,
+         it often tells you about the needed prerequirements for installing
+         this package.  You may also peek at any GNU archive site, in case
+         some other package would contain this missing \`$1' program."
+    exit 1
+    ;;
+esac
+
+exit 0

mozilla/js2/mkinstalldirs

@@ -0,0 +1,40 @@
+#! /bin/sh
+# mkinstalldirs --- make directory hierarchy
+# Author: Noah Friedman <friedman@prep.ai.mit.edu>
+# Created: 1993-05-16
+# Public domain
+
+# $Id: mkinstalldirs,v 1.1 2001-02-07 21:20:46 rginda%netscape.com Exp $
+
+errstatus=0
+
+for file
+do
+   set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'`
+   shift
+
+   pathcomp=
+   for d
+   do
+     pathcomp="$pathcomp$d"
+     case "$pathcomp" in
+       -* ) pathcomp=./$pathcomp ;;
+     esac
+
+     if test ! -d "$pathcomp"; then
+        echo "mkdir $pathcomp"
+
+        mkdir "$pathcomp" || lasterr=$?
+
+        if test ! -d "$pathcomp"; then
+  	  errstatus=$lasterr
+        fi
+     fi
+
+     pathcomp="$pathcomp/"
+   done
+done
+
+exit $errstatus
+
+# mkinstalldirs ends here

mozilla/js2/semantics/GrammarSymbol.lisp

@@ -0,0 +1,550 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; LALR(1) and LR(1) parametrized grammar utilities
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; UTILITIES
+
+(declaim (inline identifier?))
+(defun identifier? (form)
+  (and form (symbolp form) (not (keywordp form))))
+
+(deftype identifier () '(satisfies identifier?))
+
+
+; Make sure that form is one of the following:
+;   A symbol
+;   An integer
+;   A float
+;   A character
+;   A string
+;   A list of zero or more forms that also satisfy ensure-proper-form;
+;     the list cannot be dotted.
+; Return the form.
+(defun ensure-proper-form (form)
+  (labels
+    ((ensure-list-form (form)
+       (or (null form)
+           (and (consp form)
+                (progn
+                  (ensure-proper-form (car form))
+                  (ensure-list-form (cdr form)))))))
+    (unless
+      (or (symbolp form)
+          (integerp form)
+          (floatp form)
+          (characterp form)
+          (stringp form)
+          (ensure-list-form form))
+      (error "Bad form: ~S" form))
+    form))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; TERMINALS
+
+; A terminal is any of the following:
+;   A symbol that is neither nil nor a keyword
+;   A string;
+;   A character;
+;   An integer.
+(defun terminal? (x)
+  (and x
+       (or (and (symbolp x) (not (keywordp x)))
+           (stringp x)
+           (characterp x)
+           (integerp x))))
+
+; The following terminals are reserved and may not be used in user input:
+;   $$   Marker for end of token stream
+(defconstant *end-marker* '$$)
+(defconstant *end-marker-terminal-number* 0)
+
+(deftype terminal () '(satisfies terminal?))
+(deftype user-terminal () `(and terminal (not (eql ,*end-marker*))))
+
+
+; Emit markup for a terminal.  subscript is an optional integer.
+(defun depict-terminal (markup-stream terminal &optional subscript)
+  (cond
+   ((characterp terminal)
+    (depict-char-style (markup-stream ':character-literal)
+      (depict-character markup-stream terminal)
+      (when subscript
+        (depict-char-style (markup-stream ':plain-subscript)
+          (depict-integer markup-stream subscript)))))
+   ((and terminal (symbolp terminal))
+    (let ((name (symbol-name terminal)))
+      (if (and (> (length name) 0) (char= (char name 0) #\$))
+        (depict-char-style (markup-stream ':terminal)
+          (depict markup-stream (subseq (symbol-upper-mixed-case-name terminal) 1))
+          (when subscript
+            (depict-char-style (markup-stream ':plain-subscript)
+              (depict-integer markup-stream subscript))))
+        (progn
+          (depict-char-style (markup-stream ':terminal-keyword)
+            (depict markup-stream (string-downcase name)))
+          (when subscript
+            (depict-char-style (markup-stream ':terminal)
+              (depict-char-style (markup-stream ':plain-subscript)
+                (depict-integer markup-stream subscript))))))))
+   (t (error "Don't know how to emit markup for terminal ~S" terminal))))
+
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; NONTERMINAL PARAMETERS
+
+(declaim (inline nonterminal-parameter?))
+(defun nonterminal-parameter? (x)
+  (symbolp x))
+(deftype nonterminal-parameter () 'symbol)
+
+
+; Return true if this nonterminal parameter is a constant.
+(declaim (inline nonterminal-attribute?))
+(defun nonterminal-attribute? (parameter)
+  (and (symbolp parameter) (not (keywordp parameter))))
+(deftype nonterminal-attribute () '(and symbol (not keyword)))
+
+
+(defun depict-nonterminal-attribute (markup-stream attribute)
+  (depict-char-style (markup-stream ':nonterminal)
+    (depict-char-style (markup-stream ':nonterminal-attribute)
+      (depict markup-stream (symbol-lower-mixed-case-name attribute)))))
+
+
+; Return true if this nonterminal parameter is a variable.
+(declaim (inline nonterminal-argument?))
+(defun nonterminal-argument? (parameter)
+  (keywordp parameter))
+(deftype nonterminal-argument () 'keyword)
+
+
+(defparameter *special-nonterminal-arguments*
+  '(:alpha :beta :gamma :delta :epsilon :zeta :eta :theta :iota :kappa :lambda :mu :nu
+    :xi :omicron :pi :rho :sigma :tau :upsilon :phi :chi :psi :omega))
+
+(defun depict-nonterminal-argument-symbol (markup-stream argument)
+  (depict-char-style (markup-stream ':nonterminal-argument)
+    (let ((argument (symbol-abbreviation argument)))
+      (depict markup-stream
+              (if (member argument *special-nonterminal-arguments*)
+                argument
+                (symbol-upper-mixed-case-name argument))))))
+
+(defun depict-nonterminal-argument (markup-stream argument)
+  (depict-char-style (markup-stream ':nonterminal)
+    (depict-nonterminal-argument-symbol markup-stream argument)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; ATTRIBUTED NONTERMINALS
+
+; An attributed-nonterminal is a specific instantiation of a generic-nonterminal.
+(defstruct (attributed-nonterminal (:constructor allocate-attributed-nonterminal (symbol attributes))
+                                   (:copier nil)
+                                   (:predicate attributed-nonterminal?))
+  (symbol nil :type keyword :read-only t)    ;The name of the attributed nonterminal
+  (attributes nil :type list :read-only t))  ;Ordered list of nonterminal attributes
+
+
+; Make an attributed nonterminal with the given symbol and attributes.  If there
+; are no attributes, return the symbol as a plain nonterminal.
+; Nonterminals are eq whenever they have identical symbols and attribute lists.
+(defun make-attributed-nonterminal (symbol attributes)
+  (assert-type symbol keyword)
+  (assert-type attributes (list nonterminal-attribute))
+  (if attributes
+    (let ((generic-nonterminals (get symbol 'generic-nonterminals)))
+      (or (cdr (assoc attributes generic-nonterminals :test #'equal))
+          (let ((attributed-nonterminal (allocate-attributed-nonterminal symbol attributes)))
+            (setf (get symbol 'generic-nonterminals)
+                  (acons attributes attributed-nonterminal generic-nonterminals))
+            attributed-nonterminal)))
+    symbol))
+
+
+(defmethod print-object ((attributed-nonterminal attributed-nonterminal) stream)
+  (print-unreadable-object (attributed-nonterminal stream)
+    (format stream "a ~@_~W~{ ~:_~W~}"
+            (attributed-nonterminal-symbol attributed-nonterminal)
+            (attributed-nonterminal-attributes attributed-nonterminal))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; GENERIC NONTERMINALS
+
+; A generic-nonterminal is a parametrized nonterminal that can expand into two or more
+; attributed-nonterminals.
+(defstruct (generic-nonterminal (:constructor allocate-generic-nonterminal (symbol parameters))
+                                (:copier nil)
+                                (:predicate generic-nonterminal?))
+  (symbol nil :type keyword :read-only t)    ;The name of the generic nonterminal
+  (parameters nil :type list :read-only t))  ;Ordered list of nonterminal attributes or arguments
+
+
+; Make a generic nonterminal with the given symbol and parameters.  If none of
+; the parameters is an argument, make an attributed nonterminal instead.  If there
+; are no parameters, return the symbol as a plain nonterminal.
+; Nonterminals are eq whenever they have identical symbols and parameter lists.
+(defun make-generic-nonterminal (symbol parameters)
+  (assert-type symbol keyword)
+  (if parameters
+    (let ((generic-nonterminals (get symbol 'generic-nonterminals)))
+      (or (cdr (assoc parameters generic-nonterminals :test #'equal))
+          (progn
+            (assert-type parameters (list nonterminal-parameter))
+            (let ((generic-nonterminal (if (every #'nonterminal-attribute? parameters)
+                                         (allocate-attributed-nonterminal symbol parameters)
+                                         (allocate-generic-nonterminal symbol parameters))))
+              (setf (get symbol 'generic-nonterminals)
+                    (acons parameters generic-nonterminal generic-nonterminals))
+              generic-nonterminal))))
+    symbol))
+
+
+(defmethod print-object ((generic-nonterminal generic-nonterminal) stream)
+  (print-unreadable-object (generic-nonterminal stream)
+    (format stream "g ~@_~W~{ ~:_~W~}"
+            (generic-nonterminal-symbol generic-nonterminal)
+            (generic-nonterminal-parameters generic-nonterminal))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; NONTERMINALS
+
+;;; A nonterminal is a keyword or an attributed-nonterminal.
+(declaim (inline nonterminal?))
+(defun nonterminal? (x)
+  (or (keywordp x) (attributed-nonterminal? x)))
+
+; The following nonterminals are reserved and may not be used in user input:
+;   :%   Nonterminal that expands to the start nonterminal
+
+(defconstant *start-nonterminal* :%)
+
+(deftype nonterminal () '(or keyword attributed-nonterminal))
+(deftype user-nonterminal () `(and nonterminal (not (eql ,*start-nonterminal*))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; GENERAL NONTERMINALS
+
+;;; A general-nonterminal is a nonterminal or a generic-nonterminal.
+(declaim (inline general-nonterminal?))
+(defun general-nonterminal? (x)
+  (or (nonterminal? x) (generic-nonterminal? x)))
+
+(deftype general-nonterminal () '(or nonterminal generic-nonterminal))
+
+
+; Return the list of parameters in the general-nonterminal.  The list is empty if the
+; general-nonterminal is a plain nonterminal.
+(defun general-nonterminal-parameters (general-nonterminal)
+  (cond
+   ((attributed-nonterminal? general-nonterminal) (attributed-nonterminal-attributes general-nonterminal))
+   ((generic-nonterminal? general-nonterminal) (generic-nonterminal-parameters general-nonterminal))
+   (t (progn
+        (assert-true (keywordp general-nonterminal))
+        nil))))
+
+
+; Emit markup for a general-nonterminal.  subscript is an optional integer.
+; link should be one of:
+;   :reference   if this is a reference of this general-nonterminal;
+;   :external    if this is an external reference of this general-nonterminal;
+;   :definition  if this is a definition of this general-nonterminal;
+;   nil          if this use of the general-nonterminal should not be cross-referenced.
+(defun depict-general-nonterminal (markup-stream general-nonterminal link &optional subscript)
+  (labels
+    ((depict-nonterminal-name (markup-stream symbol)
+       (let ((name (symbol-upper-mixed-case-name symbol)))
+         (depict-link (markup-stream link "N-" name t)
+           (depict markup-stream name))))
+     
+     (depict-nonterminal-parameter (markup-stream parameter)
+       (if (nonterminal-attribute? parameter)
+         (depict-char-style (markup-stream ':nonterminal-attribute)
+           (depict markup-stream (symbol-lower-mixed-case-name parameter)))
+         (depict-nonterminal-argument-symbol markup-stream parameter)))
+     
+     (depict-parametrized-nonterminal (markup-stream symbol parameters)
+       (depict-nonterminal-name markup-stream symbol)
+       (depict-char-style (markup-stream ':superscript)
+         (depict-list markup-stream #'depict-nonterminal-parameter parameters
+                      :separator ",")))
+     
+     (depict-general (markup-stream)      
+       (depict-char-style (markup-stream ':nonterminal)
+         (cond
+          ((keywordp general-nonterminal)
+           (depict-nonterminal-name markup-stream general-nonterminal))
+          ((attributed-nonterminal? general-nonterminal)
+           (depict-parametrized-nonterminal markup-stream
+                                            (attributed-nonterminal-symbol general-nonterminal)
+                                            (attributed-nonterminal-attributes general-nonterminal)))
+          ((generic-nonterminal? general-nonterminal)
+           (depict-parametrized-nonterminal markup-stream
+                                            (generic-nonterminal-symbol general-nonterminal)
+                                            (generic-nonterminal-parameters general-nonterminal)))
+          (t (error "Bad nonterminal ~S" general-nonterminal)))
+         (when subscript
+           (depict-char-style (markup-stream ':plain-subscript)
+             (depict-integer markup-stream subscript))))))
+    
+    (if (or (eq link :definition)
+            (and (or (eq link :reference) (eq link :external))
+                 (keywordp general-nonterminal)
+                 (null subscript)))
+      (depict-link (markup-stream link "N-" (symbol-upper-mixed-case-name (general-grammar-symbol-symbol general-nonterminal)) t)
+        (setq link nil)
+        (depict-general markup-stream))
+      (depict-general markup-stream))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; GRAMMAR SYMBOLS
+
+;;; A grammar-symbol is either a terminal or a nonterminal.
+(deftype grammar-symbol () '(or terminal nonterminal))
+(deftype user-grammar-symbol () '(or user-terminal user-nonterminal))
+
+;;; A general-grammar-symbol is either a terminal or a general-nonterminal.
+(deftype general-grammar-symbol () '(or terminal general-nonterminal))
+
+; Return true if x is a general-grammar-symbol.  x can be any object.
+(defun general-grammar-symbol? (x)
+  (or (terminal? x) (general-nonterminal? x)))
+
+
+; Return true if the two grammar symbols are the same symbol.
+(declaim (inline grammar-symbol-=))
+(defun grammar-symbol-= (grammar-symbol1 grammar-symbol2)
+  (eql grammar-symbol1 grammar-symbol2))
+; A version of grammar-symbol-= suitable for being the test function for hash tables.
+(defparameter *grammar-symbol-=* #'eql)
+
+
+; Return the general-grammar-symbol's symbol.  Return it unchanged if it is not
+; an attributed or generic nonterminal.
+(defun general-grammar-symbol-symbol (general-grammar-symbol)
+  (cond
+   ((attributed-nonterminal? general-grammar-symbol) (attributed-nonterminal-symbol general-grammar-symbol))
+   ((generic-nonterminal? general-grammar-symbol) (generic-nonterminal-symbol general-grammar-symbol))
+   (t (assert-type general-grammar-symbol (or keyword terminal)))))
+
+
+; Return the list of arguments in the general-grammar-symbol.  The list is empty if the
+; general-grammar-symbol is not a generic nonterminal.
+(defun general-grammar-symbol-arguments (general-grammar-symbol)
+  (and (generic-nonterminal? general-grammar-symbol)
+       (remove-if (complement #'nonterminal-argument?) (generic-nonterminal-parameters general-grammar-symbol))))
+
+
+; Return the general-grammar-symbol expanded into source form that can be interned to yield the same
+; general-grammar-symbol.
+(defun general-grammar-symbol-source (general-grammar-symbol)
+  (cond
+   ((attributed-nonterminal? general-grammar-symbol)
+    (cons (attributed-nonterminal-symbol general-grammar-symbol) (attributed-nonterminal-attributes general-grammar-symbol)))
+   ((generic-nonterminal? general-grammar-symbol)
+    (cons (generic-nonterminal-symbol general-grammar-symbol) (generic-nonterminal-parameters general-grammar-symbol)))
+   (t (assert-type general-grammar-symbol (or keyword terminal)))))
+
+
+; Emit markup for a general-grammar-symbol.  subscript is an optional integer.
+; link should be one of:
+;   :reference   if this is a reference of this general-grammar-symbol;
+;   :external    if this is an external reference of this general-grammar-symbol;
+;   :definition  if this is a definition of this general-grammar-symbol;
+;   nil          if this use of the general-grammar-symbol should not be cross-referenced.
+(defun depict-general-grammar-symbol (markup-stream general-grammar-symbol link &optional subscript)
+  (if (general-nonterminal? general-grammar-symbol)
+    (depict-general-nonterminal markup-stream general-grammar-symbol link subscript)
+    (depict-terminal markup-stream general-grammar-symbol subscript)))
+
+
+; Styled text can include (:grammar-symbol <grammar-symbol-source> [<subscript>]) as long as
+; *styled-text-grammar-parametrization* is bound around the call to depict-styled-text.
+(defvar *styled-text-grammar-parametrization*)
+
+(defun depict-grammar-symbol-styled-text (markup-stream grammar-symbol-source &optional subscript)
+  (depict-general-grammar-symbol markup-stream
+                                 (grammar-parametrization-intern *styled-text-grammar-parametrization* grammar-symbol-source)
+                                 :reference
+                                 subscript))
+
+(setf (styled-text-depictor :grammar-symbol) #'depict-grammar-symbol-styled-text)
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; GRAMMAR PARAMETRIZATIONS
+
+; A grammar parametrization holds the rules for converting nonterminal arguments into nonterminal attributes.
+(defstruct (grammar-parametrization (:constructor allocate-grammar-parametrization (argument-attributes))
+                                    (:predicate grammar-parametrization?))
+  (argument-attributes nil :type hash-table :read-only t))   ;Hash table of nonterminal-argument -> list of nonterminal-attributes
+
+
+(defun make-grammar-parametrization ()
+  (allocate-grammar-parametrization (make-hash-table :test #'eq)))
+
+
+; Return true if the two grammar-parametrizations are the same.
+(defun grammar-parametrization-= (grammar-parametrization1 grammar-parametrization2)
+  (hash-table-= (grammar-parametrization-argument-attributes grammar-parametrization1)
+                (grammar-parametrization-argument-attributes grammar-parametrization2)
+                :test #'equal))
+
+
+; Declare that nonterminal arguments with the given name can hold any of the
+; given nonterminal attributes given.  At least one attribute must be provided.
+(defun grammar-parametrization-declare-argument (grammar-parametrization argument attributes)
+  (assert-type argument nonterminal-argument)
+  (assert-type attributes (list nonterminal-attribute))
+  (assert-true attributes)
+  (when (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))
+    (error "Duplicate parametrized grammar argument ~S" argument))
+  (setf (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization)) attributes))
+
+
+; Return the attributes to which the given argument may expand.
+(defun grammar-parametrization-lookup-argument (grammar-parametrization argument)
+  (assert-non-null (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))))
+
+
+; Create a plain, attributed, or generic grammar symbol from the specification in grammar-symbol-source.
+; If grammar-symbol-source is not a cons, it is a plain grammar symbol.  If it is a list, its first element
+; must be a keyword that is a nonterminal's symbol and the other elements must be nonterminal
+; parameters.
+; Return two values:
+;   the grammar symbol
+;   a list of arguments used in the grammar symbol.
+; If allowed-arguments is given, check that each argument is in the allowed-arguments list;
+; if not, allow any arguments declared in grammar-parametrization but do not allow duplicates.
+(defun grammar-parametrization-intern (grammar-parametrization grammar-symbol-source &optional (allowed-arguments nil allow-duplicates))
+  (if (consp grammar-symbol-source)
+    (progn
+      (assert-type grammar-symbol-source (cons keyword (list nonterminal-parameter)))
+      (let* ((symbol (car grammar-symbol-source))
+             (parameters (cdr grammar-symbol-source))
+             (arguments (remove-if (complement #'nonterminal-argument?) parameters)))
+        (mapl #'(lambda (arguments)
+                  (let ((argument (car arguments)))
+                    (if allow-duplicates
+                      (unless (member argument allowed-arguments :test #'eq)
+                        (error "Undefined nonterminal argument ~S" argument))
+                      (progn
+                        (unless (gethash argument (grammar-parametrization-argument-attributes grammar-parametrization))
+                          (error "Undeclared nonterminal argument ~S" argument))
+                        (when (member argument (cdr arguments) :test #'eq)
+                          (error "Duplicate nonterminal argument ~S" argument))))))
+              arguments)
+        (values (make-generic-nonterminal symbol parameters) arguments)))
+    (values (assert-type grammar-symbol-source (or keyword terminal)) nil)))
+
+
+; Call f on each possible binding permutation of the given arguments concatenated with the bindings in
+; bound-argument-alist.  f takes one argument, an association list that maps arguments to attributes.
+(defun grammar-parametrization-each-permutation (grammar-parametrization f arguments &optional bound-argument-alist)
+  (if arguments
+    (let ((argument (car arguments))
+          (rest-arguments (cdr arguments)))
+      (dolist (attribute (grammar-parametrization-lookup-argument grammar-parametrization argument))
+        (grammar-parametrization-each-permutation grammar-parametrization f rest-arguments (acons argument attribute bound-argument-alist))))
+    (funcall f bound-argument-alist)))
+
+
+; If general-grammar-symbol is a generic-nonterminal, return one possible binding permutation of its arguments;
+; otherwise return nil.
+(defun nonterminal-sample-bound-argument-alist (grammar-parametrization general-grammar-symbol)
+  (when (generic-nonterminal? general-grammar-symbol)
+    (grammar-parametrization-each-permutation
+     grammar-parametrization
+     #'(lambda (bound-argument-alist) (return-from nonterminal-sample-bound-argument-alist bound-argument-alist))
+     (general-grammar-symbol-arguments general-grammar-symbol))))
+
+
+; If the grammar symbol is a generic nonterminal, convert it into an attributed nonterminal
+; by instantiating its arguments with the corresponding attributes from the bound-argument-alist.
+; If the grammar symbol is already an attributed or plain nonterminal, return it unchanged.
+(defun instantiate-general-grammar-symbol (bound-argument-alist general-grammar-symbol)
+  (if (generic-nonterminal? general-grammar-symbol)
+    (make-attributed-nonterminal
+     (generic-nonterminal-symbol general-grammar-symbol)
+     (mapcar #'(lambda (parameter)
+                 (if (nonterminal-argument? parameter)
+                   (let ((binding (assoc parameter bound-argument-alist :test #'eq)))
+                     (if binding
+                       (cdr binding)
+                       (error "Unbound nonterminal argument ~S" parameter)))
+                   parameter))
+             (generic-nonterminal-parameters general-grammar-symbol)))
+    (assert-type general-grammar-symbol grammar-symbol)))
+
+
+; If the grammar symbol is a generic nonterminal parametrized on argument, substitute
+; attribute for argument in it and return the modified grammar symbol.  Otherwise, return it unchanged.
+(defun general-grammar-symbol-substitute (attribute argument general-grammar-symbol)
+  (assert-type attribute nonterminal-attribute)
+  (assert-type argument nonterminal-argument)
+  (if (and (generic-nonterminal? general-grammar-symbol)
+           (member argument (generic-nonterminal-parameters general-grammar-symbol) :test #'eq))
+    (make-generic-nonterminal
+     (generic-nonterminal-symbol general-grammar-symbol)
+     (substitute attribute argument (generic-nonterminal-parameters general-grammar-symbol) :test #'eq))
+    (assert-type general-grammar-symbol general-grammar-symbol)))
+
+
+; If the general grammar symbol is a generic nonterminal, return a list of all possible attributed nonterminals
+; that can be instantiated from it; otherwise, return a one-element list containing the given general grammar symbol.
+(defun general-grammar-symbol-instances (grammar-parametrization general-grammar-symbol)
+  (if (generic-nonterminal? general-grammar-symbol)
+    (let ((instances nil))
+      (grammar-parametrization-each-permutation
+       grammar-parametrization
+       #'(lambda (bound-argument-alist)
+           (push (instantiate-general-grammar-symbol bound-argument-alist general-grammar-symbol) instances))
+       (general-grammar-symbol-arguments general-grammar-symbol))
+      (nreverse instances))
+    (list (assert-type general-grammar-symbol grammar-symbol))))
+
+
+; Return true if grammar-symbol can be obtained by calling instantiate-general-grammar-symbol on
+; general-grammar-symbol.
+(defun general-nonterminal-is-instance? (grammar-parametrization general-grammar-symbol grammar-symbol)
+  (or (grammar-symbol-= general-grammar-symbol grammar-symbol)
+      (and (generic-nonterminal? general-grammar-symbol)
+           (attributed-nonterminal? grammar-symbol)
+           (let ((parameters (generic-nonterminal-parameters general-grammar-symbol))
+                 (attributes (attributed-nonterminal-attributes grammar-symbol)))
+             (and (= (length parameters) (length attributes))
+                  (every #'(lambda (parameter attribute)
+                             (or (eq parameter attribute)
+                                 (and (nonterminal-argument? parameter)
+                                      (member attribute (grammar-parametrization-lookup-argument grammar-parametrization parameter) :test #'eq))))
+                         parameters
+                         attributes))))))

mozilla/js2/semantics/HTML-To-RTF/Convert.lisp

@@ -0,0 +1,485 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Custom HTML-to-RTF Converter
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+(defconstant *missing-marker* "*****")
+
+
+; Return the html-name-token of the tag of the given html element.
+(defun tag-name (element)
+  (html-parser:name (instance-of element)))
+
+
+(defun match-tag-name (element tag-name)
+  (eq (tag-name element) tag-name))
+
+
+; Return the value of the given attribute in <element> or nil if not found.
+(defun attribute-value (element attribute-name)
+  (cdr (assoc attribute-name (attr-values element) :key #'html-parser:name)))
+
+
+; Return true if the element has the given given <tag-name>, all of required-attributes, and perhaps
+; the optional-attributes.
+(defun match-element (element tag-name required-attributes optional-attributes)
+  (and (match-tag-name element tag-name)
+       (let ((attribute-values (attr-values element)))
+         (and
+          (every #'(lambda (required-attribute)
+                     (assoc required-attribute attribute-values :key #'html-parser:name))
+                 required-attributes)
+          (every #'(lambda (attribute-value)
+                     (let ((attribute (html-parser:name (car attribute-value))))
+                       (or (member attribute required-attributes)
+                           (member attribute optional-attributes))))
+                 attribute-values)))))
+
+
+; Ensure that <element> has the given given <tag-name>, all of required-attributes, and perhaps
+; the optional-attributes.
+(defun ensure-element (element tag-name required-attributes optional-attributes)
+  (unless (match-element element tag-name required-attributes optional-attributes)
+    (error "Tag ~S ~S ~S expected; got ~S" tag-name required-attributes optional-attributes element)))
+
+
+; Return the children of <element> that have the given <tag-name>, all of required-attributes, and perhaps
+; the optional-attributes.
+(defun matching-parts (element tag-name required-attributes optional-attributes)
+  (remove-if-not #'(lambda (child) (match-element child tag-name required-attributes optional-attributes))
+                 (parts element)))
+
+
+; Return the unique child of <element> that has the given <tag-name>, all of required-attributes, and perhaps
+; the optional-attributes.
+(defun matching-part (element tag-name required-attributes optional-attributes)
+  (let ((parts (matching-parts element tag-name required-attributes optional-attributes)))
+    (unless (and parts (endp (cdr parts)))
+      (error "Element ~S should have only one ~S child" element tag-name))
+    (car parts)))
+
+
+; Convert control characters in the given string into spaces.
+(defun normalize (string)
+  (let ((l nil))
+    (dotimes (i (length string))
+      (let ((ch (char string i)))
+        (if (<= (char-code ch) 32)
+          (unless (eql (car l) #\Space)
+            (push #\Space l))
+          (push ch l))))
+    (coerce (nreverse l) 'string)))
+
+
+(defun normalize-preformatted (string)
+  (map 'list #'(lambda (ch)
+                 (if (< (char-code ch) 32)
+                   'line
+                   (string ch)))
+       string))
+
+
+(defvar *preformatted* nil)
+
+(defun emit-string (markup-stream string)
+  (if *preformatted*
+    (dolist (segment (normalize-preformatted string))
+      (depict markup-stream segment))
+    (depict markup-stream (normalize string))))
+
+
+(defparameter *special-char-code-map*
+  '((#x0097 . endash)
+    (#x00AB . :left-angle-quote)
+    (#x00BB . :right-angle-quote)
+    (#x2018 . :left-single-quote)
+    (#x2019 . :right-single-quote)
+    (#x201C . :left-double-quote)
+    (#x201D . :right-double-quote)))
+
+
+(defun emit-special-character (markup-stream char-num)
+  (let ((code (cdr (assoc char-num *special-char-code-map*))))
+    (if code
+      (depict markup-stream code)
+      (progn
+        (depict markup-stream *missing-marker*)
+        (format *terminal-io* "Ignoring character code ~S~%" char-num)))))
+
+
+(defparameter *character-style-map*
+  '(("control" . :character-literal-control)
+    ("terminal" . :terminal)
+    ("terminal-keyword" . :terminal-keyword)
+    ("nonterminal" . :nonterminal)
+    ("nonterminal-attribute" . :nonterminal-attribute)
+    ("nonterminal-argument" . :nonterminal-argument)
+    ("semantic-keyword" . :semantic-keyword)
+    ("type-expression" . :type-expression)
+    ("type-name" . :type-name)
+    ("field-name" . :field-name)
+    ("id-name" . :id-name)
+    ("global-variable" . :global-variable)
+    ("local-variable" . :local-variable)
+    ("action-name" . :action-name)
+    ("sub" . sub)
+    ("sub-num" . :plain-subscript)))
+
+
+(defun class-to-character-style (element)
+  (let ((class (attribute-value element '#t"CLASS")))
+    (if (null class)
+      nil
+      (let ((style (cdr (assoc class *character-style-map* :test #'equal))))
+        (unless style
+          (format *terminal-io* "Ignoring character style ~S~%" class))
+        style))))
+
+
+(defparameter *u-styles*
+  '(("U_bull" . :bullet)
+    ("U_ne" . :not-equal)
+    ("U_le" . :less-or-equal)
+    ("U_ge" . :greater-or-equal)
+    ("U_infin" . :infinity)
+    ("U_perp" . :bottom-10)
+    ("U_larr" . :vector-assign-10)
+    ("U_uarr" . :up-arrow-10)
+    ("U_rarr" . :function-arrow-10)
+    ("U_times" . :cartesian-product-10)
+    ("U_equiv" . :identical-10)
+    ("U_oplus" . :circle-plus-10)
+    ("U_empty" . :empty-10)
+    ("U_cap" . :intersection-10)
+    ("U_cup" . :union-10)
+    ("U_isin" . :member-10)
+    ("U_notin" . :not-member-10)
+    ("U_rArr" . :derives-10)
+    ("U_lang" . :left-triangle-bracket-10)
+    ("U_rang" . :right-triangle-bracket-10)
+    
+    ("U_alpha" . :alpha)
+    ("U_beta" . :beta)
+    ("U_chi" . :chi)
+    ("U_delta" . :delta)
+    ("U_epsilon" . :epsilon)
+    ("U_phi" . :phi)
+    ("U_gamma" . :gamma)
+    ("U_eta" . :eta)
+    ("U_iota" . :iota)
+    ("U_kappa" . :kappa)
+    ("U_lambda" . :lambda)
+    ("U_mu" . :mu)
+    ("U_nu" . :nu)
+    ("U_omicron" . :omicron)
+    ("U_pi" . :pi)
+    ("U_theta" . :theta)
+    ("U_rho" . :rho)
+    ("U_sigma" . :sigma)
+    ("U_tau" . :tau)
+    ("U_upsilon" . :upsilon)
+    ("U_omega" . :omega)
+    ("U_xi" . :xi)
+    ("U_psi" . :psi)
+    ("U_zeta" . :zeta)
+    
+    ("U_Omega" . :capital-omega)))
+
+(defun emit-script-element (markup-stream element)
+  (let* ((children (parts element))
+         (child (first children)))
+    (if (and
+         (= (length children) 1)
+         (stringp child)
+         (> (length child) 16)
+         (equal (subseq child 0 15) "document.write(")
+         (eql (char child (1- (length child))) #\)))
+      (let* ((u-name (subseq child 15 (1- (length child))))
+             (u-style (cdr (assoc u-name *u-styles* :test #'equal))))
+        (if u-style
+          (depict markup-stream u-style)
+          (progn
+            (depict markup-stream *missing-marker*)
+            (format *terminal-io* "Ignoring SCRIPT element ~S ~S~%" element child))))
+      (progn
+        (depict markup-stream *missing-marker*)
+        (format *terminal-io* "Ignoring SCRIPT element ~S ~S~%" element children)))))
+
+
+(defparameter *entity-map*
+  '((#e"nbsp" . ~)
+    (#e"lt" . "<")
+    (#e"gt" . ">")
+    (#e"amp" . "&")
+    (#e"quot" . "\"")))
+
+(defun emit-entity (markup-stream entity)
+  (let ((rtf (cdr (assoc entity *entity-map*))))
+    (if rtf
+      (depict markup-stream rtf)
+      (progn
+        (depict markup-stream "*****[" (html-parser:token-name entity) "]")
+        (format *terminal-io* "Ignoring entity ~S~%" entity)))))
+
+
+(defparameter *inline-element-map*
+  '((#t"VAR" . :variable)
+    (#t"B" . b)
+    (#t"I" . i)
+    (#t"TT" . :courier)
+    (#t"SUB" . sub)))
+
+(defun emit-inline-element (markup-stream element)
+  (cond
+   ((stringp element)
+    (emit-string markup-stream element))
+   ((integerp element)
+    (emit-special-character markup-stream element))
+   ((typep element 'html-entity-token)
+    (emit-entity markup-stream element))
+   ((match-element element '#t"SCRIPT" '(#t"TYPE") nil)
+    (emit-script-element markup-stream element))
+   ((or
+     (match-element element '#t"A" nil '(#t"CLASS" #t"HREF" #t"NAME"))
+     (match-element element '#t"SPAN" nil '(#t"CLASS"))
+     (match-element element '#t"VAR" '(#t"CLASS") nil))
+    (depict-char-style (markup-stream (class-to-character-style element))
+      (emit-inline-parts markup-stream element)))
+   ((match-element element '#t"CODE" nil '(#t"CLASS"))
+    (let ((class (attribute-value element '#t"CLASS")))
+      (if (equal class "terminal-keyword")
+        (depict-char-style (markup-stream (class-to-character-style element))
+          (emit-inline-parts markup-stream element))
+        (progn
+          (when class
+            (format *terminal-io* "Ignoring CODE character style ~S~%" class))
+          (depict-char-style (markup-stream :character-literal)
+            (emit-inline-parts markup-stream element))))))
+   ((match-element element '#t"SUP" nil '(#t"CLASS"))
+    (depict-char-style (markup-stream 'super)
+      (depict-char-style (markup-stream (class-to-character-style element))
+        (emit-inline-parts markup-stream element))))
+   ((match-element element '#t"BR" nil nil)
+    (depict markup-stream :new-line))
+   (t (let ((inline-style (cdr (assoc (tag-name element) *inline-element-map*))))
+        (if (and inline-style (endp (attr-values element)))
+          (depict-char-style (markup-stream inline-style)
+            (emit-inline-parts markup-stream element))
+          (progn
+            (depict markup-stream *missing-marker*)
+            (format *terminal-io* "Ignoring inline element ~S~%" element)))))))
+
+
+; Emit the children of the given element as inline elements.
+(defun emit-inline-parts (markup-stream element)
+  (dolist (child (parts element))
+    (emit-inline-element markup-stream child)))
+
+
+; Emit the children of the given element as inline elements in a paragraph of the given style.
+; However, if some children are paragraph-level elements, emit them as separate paragraphs.
+(defun emit-inline-or-paragraph-parts (markup-stream element paragraph-style)
+  (emit-inline-or-paragraph-elements markup-stream (parts element) paragraph-style ))
+
+(defparameter *paragraph-elements*
+  '(#t"P" #t"TH" #t"TD" #t"PRE" #t"UL" #t"OL" #t"DIV" #t"HR" #t"TABLE" #t"H1" #t"H2" #t"H3" #t"H4"))
+
+(defun paragraph-element? (element)
+  (and (typep element 'html-tag-instance)
+       (member (tag-name element) *paragraph-elements*)))
+
+(defun emit-inline-or-paragraph-elements (markup-stream elements paragraph-style)
+  (let* ((paragraph-element (member-if #'paragraph-element? elements))
+         (inline-parts (ldiff elements paragraph-element)))
+    (when inline-parts
+      (depict-paragraph (markup-stream paragraph-style)
+        (dolist (child inline-parts)
+          (emit-inline-element markup-stream child))))
+    (when paragraph-element
+      (emit-paragraph-element markup-stream (car paragraph-element))
+      (emit-inline-or-paragraph-elements markup-stream (cdr paragraph-element) paragraph-style))))
+
+
+(defparameter *class-paragraph-styles*
+  '(("mod-date" . :mod-date)
+    ("grammar-argument" . :grammar-argument)
+    ("indent" . :body-text)
+    ("operator-heading" . :heading4)
+    ("semantics" . :semantics)
+    ("semantics-next" . :semantics-next)))
+
+
+(defun class-to-paragraph-style (element)
+  (let ((class (attribute-value element '#t"CLASS")))
+    (if class
+      (let ((style (cdr (assoc class *class-paragraph-styles* :test #'equal))))
+        (or style
+            (progn
+              (format *terminal-io* "Ignoring paragraph style ~S~%" class)
+              :body-text)))
+      :body-text)))
+
+
+(defun grammar-rule-child-style (element last)
+  (and
+   (match-element element '#t"DIV" '(#t"CLASS") nil)
+   (let ((class (attribute-value element '#t"CLASS")))
+     (cond
+      ((equal class "grammar-lhs")
+       (if last :grammar-lhs-last :grammar-lhs))
+      ((equal class "grammar-rhs")
+       (if last :grammar-rhs-last :grammar-rhs))
+      (t nil)))))
+
+
+(defparameter *divs-containing-divs*
+  '("indent"))
+
+(defun emit-div (markup-stream element class)
+  (cond
+   ((equal class "grammar-rule")
+    (let ((children (parts element)))
+      (do ()
+          ((endp children))
+        (let* ((child (pop children))
+               (style (grammar-rule-child-style child (endp children))))
+          (unless style
+            (format *terminal-io* "Bad grammar-rule child ~S~%" child)
+            (setq style :body-text))
+          (depict-paragraph (markup-stream style)
+            (emit-inline-parts markup-stream child))))))
+   ((member class *divs-containing-divs* :test #'equal)
+    (depict-paragraph (markup-stream :body-text)
+      (depict markup-stream "***** BEGIN DIV" class))
+    (emit-paragraph-elements markup-stream element)
+    (depict-paragraph (markup-stream :body-text)
+      (depict markup-stream "***** END DIV" class)))
+   (t (emit-inline-or-paragraph-parts markup-stream element (class-to-paragraph-style element)))))
+
+
+(defparameter *paragraph-element-map*
+  '((#t"H1" . :heading1)
+    (#t"H2" . :heading2)
+    (#t"H3" . :heading3)
+    (#t"H4" . :heading4)))
+
+
+; Emit the paragraph-level element.
+(defun emit-paragraph-element (markup-stream element)
+  (cond
+   ((or
+     (match-element element '#t"P" nil '(#t"CLASS"))
+     (match-element element '#t"TH" nil '(#t"CLASS" #t"COLSPAN" #t"ROWSPAN" #t"NOWRAP" #t"VALIGN" #t"ALIGN"))
+     (match-element element '#t"TD" nil '(#t"CLASS" #t"COLSPAN" #t"ROWSPAN" #t"NOWRAP" #t"VALIGN" #t"ALIGN")))
+    (emit-inline-or-paragraph-parts markup-stream element (class-to-paragraph-style element)))
+   ((match-element element '#t"PRE" nil nil)
+    (depict-paragraph (markup-stream :sample-code)
+      (let ((*preformatted* t))
+        (emit-inline-parts markup-stream element))))
+   ((or (match-element element '#t"UL" nil nil)
+        (match-element element '#t"OL" nil nil))
+    (depict-paragraph (markup-stream :body-text)
+      (depict markup-stream "***** BEGIN LIST"))
+    (dolist (child (parts element))
+      (ensure-element child '#t"LI" nil nil)
+      (emit-inline-or-paragraph-parts markup-stream child :body-text))
+    (depict-paragraph (markup-stream :body-text)
+      (depict markup-stream "***** END LIST")))
+   ((match-element element '#t"DIV" nil '(#t"CLASS"))
+    (let ((class (attribute-value element '#t"CLASS")))
+      (if class
+        (emit-div markup-stream element class)
+        (emit-paragraph-elements markup-stream element))))
+   ((match-element element '#t"HR" nil nil))
+   ((match-element element '#t"TABLE" nil '(#t"BORDER" #t"CELLSPACING" #t"CELLPADDING"))
+    (depict-paragraph (markup-stream :body-text)
+      (depict markup-stream "***** BEGIN TABLE"))
+    (emit-paragraph-elements markup-stream element)
+    (depict-paragraph (markup-stream :body-text)
+      (depict markup-stream "***** END TABLE")))
+   ((match-element element '#t"THEAD" nil nil)
+    (emit-paragraph-elements markup-stream element))
+   ((match-element element '#t"TR" nil nil)
+    (emit-paragraph-elements markup-stream element))
+   (t (let ((paragraph-style (cdr (assoc (tag-name element) *paragraph-element-map*))))
+        (if (and paragraph-style (endp (attr-values element)))
+          (emit-inline-or-paragraph-parts markup-stream element paragraph-style)
+          (progn
+            (depict-paragraph (markup-stream :body-text)
+              (depict markup-stream *missing-marker*))
+            (format *terminal-io* "Ignoring paragraph element ~S~%" element)))))))
+
+
+; Emit the children of the given element as paragraph-level elements.
+(defun emit-paragraph-elements (markup-stream element)
+  (dolist (child (parts element))
+    (emit-paragraph-element markup-stream child)))
+
+
+(defun emit-html-file (markup-stream element)
+  (ensure-element element '#t"HTML" nil nil)
+  (let* ((body (matching-part element '#t"BODY" nil nil))
+         (body-elements (parts body)))
+    (when (and body-elements (match-tag-name (first body-elements) '#t"TABLE"))
+      (setq body-elements (rest body-elements)))
+    (when (and body-elements (match-tag-name (car (last body-elements)) '#t"TABLE"))
+      (setq body-elements (butlast body-elements)))
+    (dolist (body-element body-elements)
+      (emit-paragraph-element markup-stream body-element))))
+
+
+(defun translate-html-to-rtf (html-file-name rtf-path title)
+  (let* ((source-text (file->string html-file-name))
+         (element (html-parser::simple-parser source-text)))
+    (depict-rtf-to-local-file
+     rtf-path
+     title
+     #'(lambda (markup-stream)
+         (emit-html-file markup-stream element))
+     *html-to-rtf-definitions*)))
+
+#|
+(setq s (html-parser:file->string "Huit:Mozilla:Docs:mozilla-org:html:js:language:js20:formal:index.html"))
+(setq p (html-parser::simple-parser s))
+
+(depict-rtf-to-local-file
+ "HTML-To-RTF/Test.rtf"
+ "Test"
+ #'(lambda (markup-stream)
+     (emit-html-file markup-stream p))
+ *html-to-rtf-definitions*)
+
+(translate-html-to-rtf "Huit:Mozilla:Docs:mozilla-org:html:js:language:js20:formal:index.html" "HTML-To-RTF/Test.rtf" "Test")
+(translate-html-to-rtf "Huit:Mozilla:Docs:mozilla-org:html:js:language:js20:introduction:notation.html"
+                       "HTML-To-RTF/Notation.rtf" "Notation")
+(translate-html-to-rtf "Huit:Mozilla:Docs:mozilla-org:html:js:language:es4:core:expressions.html"
+                       "HTML-To-RTF/Expressions.rtf" "Expressions")
+(translate-html-to-rtf "Huit:Mozilla:Moz:mozilla:js2:semantics:HTML-To-RTF:Expressions.html"
+                       "HTML-To-RTF/Expressions.rtf" "Expressions")
+
+(translate-html-to-rtf "Huit:Mozilla:Docs:mozilla-org:html:js:language:js20:formal:stages.html"
+                       "HTML-To-RTF/Stages.rtf" "Stages")
+(translate-html-to-rtf "Huit:Mozilla:Docs:mozilla-org:html:js:language:js20:formal:notation.html"
+                       "HTML-To-RTF/FormalNotation.rtf" "Formal Notation")
+|#

mozilla/js2/semantics/HTML-To-RTF/Main.lisp

@@ -0,0 +1,96 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Custom HTML-to-RTF Converter
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+(defparameter *html-to-rtf-filenames*
+  '("../Utilities" "../Markup" "../RTF" "Convert"))
+
+(defparameter *html-to-rtf-directory*
+  (make-pathname
+   #+lispworks :host #+lispworks (pathname-host *load-truename*)
+   :directory (pathname-directory #-mcl *load-truename*
+                                  #+mcl (truename *loading-file-source-file*))))
+
+(defparameter *semantic-engine-directory*
+  (merge-pathnames (make-pathname :directory '(:relative :up)) *html-to-rtf-directory*))
+
+
+; Convert a filename string possibly containing slashes into a Lisp relative pathname.
+(defun filename-to-relative-pathname (filename)
+  (let ((directories nil))
+    (loop
+      (let ((slash (position #\/ filename)))
+        (if slash
+          (let ((dir-name (subseq filename 0 slash)))
+            (push (if (equal dir-name "..") :up dir-name) directories)
+            (setq filename (subseq filename (1+ slash))))
+          (return (if directories
+                    (make-pathname :directory (cons ':relative (nreverse directories)) :name filename #+lispworks :type #+lispworks "lisp")
+                    #-lispworks filename
+                    #+lispworks (make-pathname :name filename :type "lisp"))))))))
+
+
+; Convert a filename string possibly containing slashes relative to *html-to-rtf-directory*
+; into a Lisp absolute pathname.
+(defun filename-to-html-to-rtf-pathname (filename)
+  (merge-pathnames (filename-to-relative-pathname filename) *html-to-rtf-directory*))
+
+
+; Convert a filename string possibly containing slashes relative to *semantic-engine-directory*
+; into a Lisp absolute pathname.
+(defun filename-to-semantic-engine-pathname (filename)
+  (merge-pathnames (filename-to-relative-pathname filename) *semantic-engine-directory*))
+
+
+(defun operate-on-files (f files &rest options)
+  (with-compilation-unit ()
+    (dolist (filename files)
+      (apply f (filename-to-html-to-rtf-pathname filename) :verbose t options))))
+
+(defun compile-html-to-rtf ()
+  (operate-on-files #'compile-file *html-to-rtf-filenames* :load t))
+
+(defun load-html-to-rtf ()
+  (operate-on-files #-allegro #'load #+allegro #'load-compiled *html-to-rtf-filenames*))
+
+
+(defmacro with-local-output ((stream filename) &body body)
+  `(with-open-file (,stream (filename-to-html-to-rtf-pathname ,filename)
+                            :direction :output
+                            :if-exists :supersede)
+     ,@body))
+
+
+(load (filename-to-html-to-rtf-pathname "../HTML-Parser/mac-sysdcl"))
+(html-parser:initialize-parser)
+(import '(html-parser:file->string
+          html-parser:instance-of
+          html-parser:parts
+          html-parser:part-of
+          html-parser:attr-values
+          html-parser:html-entity-token
+          html-parser:html-tag-instance))
+
+(load-html-to-rtf)

mozilla/js2/semantics/HTML.lisp

@@ -0,0 +1,696 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; HTML output generator
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; ELEMENTS
+
+(defstruct (html-element (:constructor make-html-element (name self-closing indent
+                                                               newlines-before newlines-begin newlines-end newlines-after))
+                         (:predicate html-element?))
+  (name nil :type symbol :read-only t)               ;Name of the tag
+  (self-closing nil :type bool :read-only t)         ;True if the closing tag should be omitted
+  (indent nil :type integer :read-only t)            ;Number of spaces by which to indent this tag's contents in HTML source
+  (newlines-before nil :type integer :read-only t)   ;Number of HTML source newlines preceding the opening tag
+  (newlines-begin nil :type integer :read-only t)    ;Number of HTML source newlines immediately following the opening tag
+  (newlines-end nil :type integer :read-only t)      ;Number of HTML source newlines immediately preceding the closing tag
+  (newlines-after nil :type integer :read-only t))   ;Number of HTML source newlines following the closing tag
+
+
+; Define symbol to refer to the given html-element.
+(defun define-html (symbol newlines-before newlines-begin newlines-end newlines-after &key self-closing (indent 0))
+  (setf (get symbol 'html-element) (make-html-element symbol self-closing indent
+                                                      newlines-before newlines-begin newlines-end newlines-after)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; ELEMENT DEFINITIONS
+
+(define-html 'a 0 0 0 0)
+(define-html 'b 0 0 0 0)
+(define-html 'blockquote 1 0 0 1 :indent 2)
+(define-html 'body 1 1 1 1)
+(define-html 'br 0 0 0 1 :self-closing t)
+(define-html 'code 0 0 0 0)
+(define-html 'dd 1 0 0 1 :indent 2)
+(define-html 'del 0 0 0 0)
+(define-html 'div 1 0 0 1 :indent 2)
+(define-html 'dl 1 0 0 2 :indent 2)
+(define-html 'dt 1 0 0 1 :indent 2)
+(define-html 'em 0 0 0 0)
+(define-html 'h1 2 0 0 2 :indent 2)
+(define-html 'h2 2 0 0 2 :indent 2)
+(define-html 'h3 2 0 0 2 :indent 2)
+(define-html 'h4 1 0 0 2 :indent 2)
+(define-html 'h5 1 0 0 2 :indent 2)
+(define-html 'h6 1 0 0 2 :indent 2)
+(define-html 'head 1 1 1 2)
+(define-html 'hr 1 0 0 1 :self-closing t)
+(define-html 'html 0 1 1 1)
+(define-html 'i 0 0 0 0)
+(define-html 'li 1 0 0 1 :indent 2)
+(define-html 'link 1 0 0 1 :self-closing t)
+(define-html 'ol 1 1 1 2 :indent 2)
+(define-html 'p 1 0 0 2)
+(define-html 'script 0 0 0 0)
+(define-html 'span 0 0 0 0)
+(define-html 'strong 0 0 0 0)
+(define-html 'sub 0 0 0 0)
+(define-html 'sup 0 0 0 0)
+(define-html 'table 1 1 1 2)
+(define-html 'td 1 0 0 1 :indent 2)
+(define-html 'th 1 0 0 1 :indent 2)
+(define-html 'title 1 0 0 1)
+(define-html 'tr 1 0 0 1 :indent 2)
+(define-html 'u 0 0 0 0)
+(define-html 'ul 1 1 1 2 :indent 2)
+(define-html 'var 0 0 0 0)
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; ATTRIBUTES
+
+;;; The following element attributes require their values to always be in quotes.
+(dolist (attribute '(alt href name))
+  (setf (get attribute 'quoted-attribute) t))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; ENTITIES
+
+(defvar *html-entities-list*
+  '((#\& . "amp")
+    (#\" . "quot")
+    (#\< . "lt")
+    (#\> . "gt")
+    (nbsp . "nbsp")))
+
+(defvar *html-entities-hash* (make-hash-table))
+
+(dolist (entity-binding *html-entities-list*)
+  (setf (gethash (first entity-binding) *html-entities-hash*) (rest entity-binding)))
+
+
+; Return a freshly consed list of <html-source> that represent the characters in the string except that
+; '&', '<', and '>' are replaced by their entities and spaces are replaced by the entity
+; given by the space parameter (which should be either 'space or 'nbsp).
+(defun escape-html-characters (string space)
+  (let ((html-sources nil))
+    (labels
+      ((escape-remainder (start)
+         (let ((i (position-if #'(lambda (char) (member char '(#\& #\< #\> #\space))) string :start start)))
+           (if i
+             (let ((char (char string i)))
+               (unless (= i start)
+                 (push (subseq string start i) html-sources))
+               (push (if (eql char #\space) space char) html-sources)
+               (escape-remainder (1+ i)))
+             (push (if (zerop start) string (subseq string start)) html-sources)))))
+      (unless (zerop (length string))
+        (escape-remainder 0))
+      (nreverse html-sources))))
+
+
+; Escape all content strings in the html-source, while interpreting :nowrap, :wrap, and :none pseudo-tags.
+; Return a freshly consed list of html-sources.
+(defun escape-html-source (html-source space)
+  (cond
+   ((stringp html-source)
+    (escape-html-characters html-source space))
+   ((or (characterp html-source) (symbolp html-source) (integerp html-source))
+    (list html-source))
+   ((consp html-source)
+    (let ((tag (first html-source))
+          (contents (rest html-source)))
+      (case tag
+        (:none (mapcan #'(lambda (html-source) (escape-html-source html-source space)) contents))
+        (:nowrap (mapcan #'(lambda (html-source) (escape-html-source html-source 'nbsp)) contents))
+        (:wrap (mapcan #'(lambda (html-source) (escape-html-source html-source 'space)) contents))
+        (t (list (cons tag
+                       (mapcan #'(lambda (html-source) (escape-html-source html-source space)) contents)))))))
+   (t (error "Bad html-source: ~S" html-source))))
+
+
+; Escape all content strings in the html-source, while interpreting :nowrap, :wrap, and :none pseudo-tags.
+(defun escape-html (html-source)
+  (let ((results (escape-html-source html-source 'space)))
+    (assert-true (= (length results) 1))
+    (first results)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; HTML WRITER
+
+;; <html-source> has one of the following formats:
+;;   <string>                                                  ;String to be printed literally
+;;   <symbol>                                                  ;Named entity
+;;   <integer>                                                 ;Numbered entity
+;;   space                                                     ;Space or newline
+;;   (<tag> <html-source> ... <html-source>)                   ;Tag and its contents
+;;   ((:nest <tag> ... <tag>) <html-source> ... <html-source>) ;Equivalent to (<tag> (... (<tag> <html-source> ... <html-source>)))
+;;
+;; <tag> has one of the following formats:
+;;   <symbol>                                                  ;Tag with no attributes
+;;   (<symbol> <attribute> ... <attribute>)                    ;Tag with attributes
+;;   :nowrap                                                   ;Pseudo-tag indicating that spaces in contents should be non-breaking
+;;   :wrap                                                     ;Pseudo-tag indicating that spaces in contents should be breaking
+;;   :none                                                     ;Pseudo-tag indicating no tag -- the contents should be inlined
+;;
+;; <attribute> has one of the following formats:
+;;   (<symbol> <string>)                                       ;Attribute name and value
+;;   (<symbol>)                                                ;Attribute name with omitted value
+
+
+(defparameter *html-right-margin* 120)
+(defparameter *allow-line-breaks-in-tags* nil) ;Allow line breaks in tags between attributes?
+
+(defvar *current-html-pos*)          ;Number of characters written to the current line of the stream; nil if *current-html-newlines* is nonzero
+(defvar *current-html-pending*)      ;String following a space or newline pending to be printed on the current line or nil if none
+(defvar *current-html-indent*)       ;Indent to use for emit-html-newlines-and-indent calls
+(defvar *current-html-newlines*)     ;Number of consecutive newlines just written to the stream; zero if last character wasn't a newline
+
+
+; Flush *current-html-pending* onto the stream.
+(defun flush-current-html-pending (stream)
+  (when *current-html-pending*
+    (unless (zerop (length *current-html-pending*))
+      (write-char #\space stream)
+      (write-string *current-html-pending* stream)
+      (incf *current-html-pos* (1+ (length *current-html-pending*))))
+    (setq *current-html-pending* nil)))
+
+
+; Emit n-newlines onto the stream and indent the next line by *current-html-indent* spaces.
+(defun emit-html-newlines-and-indent (stream n-newlines)
+  (decf n-newlines *current-html-newlines*)
+  (when (plusp n-newlines)
+    (flush-current-html-pending stream)
+    (dotimes (i n-newlines)
+      (write-char #\newline stream))
+    (incf *current-html-newlines* n-newlines)
+    (setq *current-html-pos* nil)))
+
+
+; Write the string to the stream, observing *current-html-pending* and *current-html-pos*.
+(defun write-html-string (stream html-string)
+  (unless (zerop (length html-string))
+    (unless *current-html-pos*
+      (setq *current-html-newlines* 0)
+      (write-string (make-string *current-html-indent* :initial-element #\space) stream)
+      (setq *current-html-pos* *current-html-indent*))
+    (if *current-html-pending*
+      (progn
+        (setq *current-html-pending* (if (zerop (length *current-html-pending*))
+                                       html-string
+                                       (concatenate 'string *current-html-pending* html-string)))
+        (when (>= (+ *current-html-pos* (length *current-html-pending*)) *html-right-margin*)
+          (write-char #\newline stream)
+          (write-string *current-html-pending* stream)
+          (setq *current-html-pos* (length *current-html-pending*))
+          (setq *current-html-pending* nil)))
+      (progn
+        (write-string html-string stream)
+        (incf *current-html-pos* (length html-string))))))
+
+
+; Return true if the value string contains a character that would require an attribute to be quoted.
+; For convenience, this returns true if value contains a period, even though strictly speaking periods do
+; not force quoting.
+(defun attribute-value-needs-quotes (value)
+  (dotimes (i (length value) nil)
+    (let ((ch (char value i)))
+      (unless (or (char<= #\0 ch #\9) (char<= #\A ch #\Z) (char<= #\a ch #\z) (char= ch #\-))
+        (return t)))))
+
+
+; Emit the html tag with the given tag-symbol (name), attributes, and contents.
+(defun write-html-tag (stream tag-symbol attributes contents)
+  (let ((element (assert-non-null (get tag-symbol 'html-element))))
+    (emit-html-newlines-and-indent stream (html-element-newlines-before element))
+    (write-html-string stream (format nil "<~A" (html-element-name element)))
+    (let ((*current-html-indent* (+ *current-html-indent* (html-element-indent element))))
+      (dolist (attribute attributes)
+        (let ((name (first attribute))
+              (value (second attribute)))
+          (write-html-source stream (if *allow-line-breaks-in-tags* 'space #\space))
+          (write-html-string stream (string-downcase (symbol-name name)))
+          (when value
+            (write-html-string
+             stream
+             (format nil
+                     (if (or (attribute-value-needs-quotes value)
+                             (get name 'quoted-attribute))
+                       "=\"~A\""
+                       "=~A")
+                     value)))))
+      (write-html-string stream ">")
+      (emit-html-newlines-and-indent stream (html-element-newlines-begin element))
+      (dolist (html-source contents)
+        (write-html-source stream html-source)))
+    (unless (html-element-self-closing element)
+      (emit-html-newlines-and-indent stream (html-element-newlines-end element))
+      (write-html-string stream (format nil "</~A>" (html-element-name element))))
+    (emit-html-newlines-and-indent stream (html-element-newlines-after element))))
+
+
+; Write html-source to the character stream.
+(defun write-html-source (stream html-source)
+  (cond
+   ((stringp html-source)
+    (write-html-string stream html-source))
+   ((eq html-source 'space)
+    (when (zerop *current-html-newlines*)
+      (flush-current-html-pending stream)
+      (setq *current-html-pending* "")))
+   ((or (characterp html-source) (symbolp html-source))
+    (let ((entity-name (gethash html-source *html-entities-hash*)))
+      (cond
+       (entity-name
+        (write-html-string stream (format nil "&~A;" entity-name)))
+       ((characterp html-source)
+        (write-html-string stream (string html-source)))
+       (t (error "Bad html-source ~S" html-source)))))
+   ((integerp html-source)
+    (assert-true (and (>= html-source 0) (< html-source 65536)))
+    (write-html-string stream (format nil "&#~D;" html-source)))
+   ((consp html-source)
+    (let ((tag (first html-source))
+          (contents (rest html-source)))
+      (if (consp tag)
+        (write-html-tag stream (first tag) (rest tag) contents)
+        (write-html-tag stream tag nil contents))))
+   (t (error "Bad html-source: ~S" html-source))))
+
+
+; Write the top-level html-source to the character stream.
+(defun write-html (html-source &optional (stream t))
+  (with-standard-io-syntax
+    (let ((*print-readably* nil)
+          (*print-escape* nil)
+          (*print-case* :upcase)
+          (*current-html-pos* nil)
+          (*current-html-pending* nil)
+          (*current-html-indent* 0)
+          (*current-html-newlines* 9999))
+      (write-string "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">" stream)
+      (write-char #\newline stream)
+      (write-html-source stream (escape-html html-source)))))
+
+
+; Write html to the text file with the given name (relative to the
+; local directory).
+(defun write-html-to-local-file (filename html)
+  (with-open-file (stream (filename-to-semantic-engine-pathname filename)
+                          :direction :output
+                          :if-exists :supersede
+                          #+mcl :mac-file-creator #+mcl "MOSS")
+    (write-html html stream)))
+
+
+; Expand the :nest constructs inside html-source.
+(defun unnest-html-source (html-source)
+  (labels
+    ((unnest-tags (tags contents)
+       (assert-true tags)
+       (cons (first tags)
+             (if (endp (rest tags))
+               contents
+               (list (unnest-tags (rest tags) contents))))))
+    (if (consp html-source)
+      (let ((tag (first html-source))
+            (contents (rest html-source)))
+        (if (and (consp tag) (eq (first tag) ':nest))
+          (unnest-html-source (unnest-tags (rest tag) contents))
+          (cons tag (mapcar #'unnest-html-source contents))))
+      html-source)))
+
+
+; Coalesce an A element immediately containing or contained in a SPAN element into one if their attributes
+; are disjoint.  Also coalesce SUB and SUP elements immediately containing SPAN elements into one.
+(defun coalesce-elements (html-source)
+  (if (consp html-source)
+    (let ((tag (first html-source))
+          (contents (mapcar #'coalesce-elements (rest html-source))))
+      (cond
+       ((and (consp tag)
+             (member (first tag) '(a span))
+             contents
+             (null (cdr contents))
+             (consp (car contents))
+             (let ((tag2 (caar contents)))
+               (and (consp tag2)
+                    (member (first tag2) '(a span))
+                    (not (eq tag tag2))
+                    (null (intersection (rest tag) (rest tag2) :key #'car)))))
+        (cons
+         (cons 'a
+               (if (eq (first tag) 'a)
+                 (append (rest tag) (rest (caar contents)))
+                 (append (rest (caar contents)) (rest tag))))
+         (cdar contents)))
+       ((and (member tag '(sub sup))
+             contents
+             (null (cdr contents))
+             (consp (car contents))
+             (consp (caar contents))
+             (eq (caaar contents) 'span))
+        (cons
+         (cons tag (rest (caar contents)))
+         (cdar contents)))
+       (t (cons tag contents))))
+    html-source))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; HTML MAPPINGS
+
+(defparameter *html-definitions*
+  '(((:new-line t) (br))
+    
+    ;Misc.
+    (:spc nbsp)
+    (:tab2 nbsp nbsp)
+    (:tab3 nbsp nbsp nbsp)
+    (:nbhy "-")             ;Non-breaking hyphen
+    
+    ;Symbols (-10 suffix means 10-point, etc.)
+    ((:bullet 1) (:script "document.write(U_bull)"))                    ;#x2022
+    ((:minus 1) "-")
+    ((:not-equal 1) (:script "document.write(U_ne)"))                   ;#x2260
+    ((:less-or-equal 1) (:script "document.write(U_le)"))               ;#x2264
+    ((:greater-or-equal 1) (:script "document.write(U_ge)"))            ;#x2265
+    ((:infinity 1) (:script "document.write(U_infin)"))                 ;#x221E
+    ((:left-single-quote 1) #x2018)
+    ((:right-single-quote 1) #x2019)
+    ((:left-double-quote 1) #x201C)
+    ((:right-double-quote 1) #x201D)
+    ((:left-angle-quote 1) #x00AB)
+    ((:right-angle-quote 1) #x00BB)
+    ((:bottom-10 1) (:script "document.write(U_perp)"))                 ;#x22A5
+    ((:vector-assign-10 1) (:script "document.write(U_larr)"))          ;#x2190
+    ((:up-arrow-10 1) (:script "document.write(U_uarr)"))               ;#x2191
+    ((:function-arrow-10 2) (:script "document.write(U_rarr)"))         ;#x2192
+    ((:cartesian-product-10 2) (:script "document.write(U_times)"))     ;#x00D7
+    ((:identical-10 2) (:script "document.write(U_equiv)"))             ;#x2261
+    ((:circle-plus-10 2) (:script "document.write(U_oplus)"))           ;#x2295
+    ((:empty-10 2) (:script "document.write(U_empty)"))                 ;#x2205
+    ((:intersection-10 1) (:script "document.write(U_cap)"))            ;#x2229
+    ((:union-10 1) (:script "document.write(U_cup)"))                   ;#x222A
+    ((:member-10 2) (:script "document.write(U_isin)"))                 ;#x2208
+    ((:not-member-10 2) (:script "document.write(U_notin)"))            ;#x2209
+    ((:derives-10 2) (:script "document.write(U_rArr)"))                ;#x21D2
+    ((:left-triangle-bracket-10 1) (:script "document.write(U_lang)"))  ;#x2329
+    ((:right-triangle-bracket-10 1) (:script "document.write(U_rang)")) ;#x232A
+    
+    ((:alpha 1) (:script "document.write(U_alpha)"))
+    ((:beta 1) (:script "document.write(U_beta)"))
+    ((:chi 1) (:script "document.write(U_chi)"))
+    ((:delta 1) (:script "document.write(U_delta)"))
+    ((:epsilon 1) (:script "document.write(U_epsilon)"))
+    ((:phi 1) (:script "document.write(U_phi)"))
+    ((:gamma 1) (:script "document.write(U_gamma)"))
+    ((:eta 1) (:script "document.write(U_eta)"))
+    ((:iota 1) (:script "document.write(U_iota)"))
+    ((:kappa 1) (:script "document.write(U_kappa)"))
+    ((:lambda 1) (:script "document.write(U_lambda)"))
+    ((:mu 1) (:script "document.write(U_mu)"))
+    ((:nu 1) (:script "document.write(U_nu)"))
+    ((:omicron 1) (:script "document.write(U_omicron)"))
+    ((:pi 1) (:script "document.write(U_pi)"))
+    ((:theta 1) (:script "document.write(U_theta)"))
+    ((:rho 1) (:script "document.write(U_rho)"))
+    ((:sigma 1) (:script "document.write(U_sigma)"))
+    ((:tau 1) (:script "document.write(U_tau)"))
+    ((:upsilon 1) (:script "document.write(U_upsilon)"))
+    ((:omega 1) (:script "document.write(U_omega)"))
+    ((:xi 1) (:script "document.write(U_xi)"))
+    ((:psi 1) (:script "document.write(U_psi)"))
+    ((:zeta 1) (:script "document.write(U_zeta)"))
+    
+    ;Block Styles
+    (:js2 (div (class "js2")))
+    (:es4 (div (class "es4")))
+    (:body-text p)
+    (:section-heading h2)
+    (:subsection-heading h3)
+    (:grammar-header h4)
+    (:grammar-rule (:nest :nowrap (div (class "grammar-rule"))))
+    (:grammar-lhs (:nest :nowrap (div (class "grammar-lhs"))))
+    (:grammar-lhs-last :grammar-lhs)
+    (:grammar-rhs (:nest :nowrap (div (class "grammar-rhs"))))
+    (:grammar-rhs-last :grammar-rhs)
+    (:grammar-argument (:nest :nowrap (div (class "grammar-argument"))))
+    (:semantics (:nest :nowrap (div (class "semantics"))))
+    (:semantics-next (:nest :nowrap (div (class "semantics-next"))))
+    (:semantic-comment (div (class "semantic-comment")))
+    
+    ;Inline Styles
+    (:script (script (type "text/javascript")))
+    (:symbol (span (class "symbol")))
+    (:character-literal code)
+    (:character-literal-control (span (class "control")))
+    (:terminal (span (class "terminal")))
+    (:terminal-keyword (code (class "terminal-keyword")))
+    (:nonterminal (span (class "nonterminal")))
+    (:nonterminal-attribute (span (class "nonterminal-attribute")))
+    (:nonterminal-argument (span (class "nonterminal-argument")))
+    (:semantic-keyword (span (class "semantic-keyword")))
+    (:type-expression (span (class "type-expression")))
+    (:type-name (span (class "type-name")))
+    (:field-name (span (class "field-name")))
+    (:global-variable (span (class "global-variable")))
+    (:local-variable (span (class "local-variable")))
+    (:action-name (span (class "action-name")))
+    (:text :wrap)
+    
+    ;Specials
+    (:invisible del)
+    ((:but-not 6) (b "except"))
+    ((:begin-negative-lookahead 13) "[lookahead" :not-member-10 "{")
+    ((:end-negative-lookahead 2) "}]")
+    ((:line-break 12) "[line" nbsp "break]")
+    ((:no-line-break 15) "[no" nbsp "line" nbsp "break]")
+    (:subscript sub)
+    (:superscript sup)
+    (:plain-subscript :subscript)
+    ((:action-begin 1) "[")
+    ((:action-end 1) "]")
+    ((:vector-begin 1) (b "["))
+    ((:vector-end 1) (b "]"))
+    ((:empty-vector 2) (b "[]"))
+    ((:vector-construct 1) (b "|"))
+    ((:vector-append 2) :circle-plus-10)
+    ((:tuple-begin 1) (b :left-triangle-bracket-10))
+    ((:tuple-end 1) (b :right-triangle-bracket-10))
+    ((:true 4) (:global-variable "true"))
+    ((:false 5) (:global-variable "false"))
+    ((:unique 6) (:semantic-keyword "unique"))
+    ))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; HTML STREAMS
+
+(defstruct (html-stream (:include markup-stream)
+                        (:constructor allocate-html-stream (env head tail level logical-position enclosing-styles anchors))
+                        (:copier nil)
+                        (:predicate html-stream?))
+  (enclosing-styles nil :type list :read-only t) ;A list of enclosing styles
+  (anchors nil :type list :read-only t))  ;A mutable cons cell for accumulating anchors at the beginning of a paragraph
+;                                         ;or nil if not inside a paragraph.
+
+
+(defmethod print-object ((html-stream html-stream) stream)
+  (print-unreadable-object (html-stream stream :identity t)
+    (write-string "html-stream" stream)))
+
+
+; Make a new, empty, open html-stream with the given definitions for its markup-env.
+(defun make-html-stream (markup-env level logical-position enclosing-styles anchors)
+  (let ((head (list nil)))
+    (allocate-html-stream markup-env head head level logical-position enclosing-styles anchors)))
+
+
+; Make a new, empty, open, top-level html-stream with the given definitions
+; for its markup-env.  If links is true, allow links.
+(defun make-top-level-html-stream (html-definitions links)
+  (let ((head (list nil))
+        (markup-env (make-markup-env links)))
+    (markup-env-define-alist markup-env html-definitions)
+    (allocate-html-stream markup-env head head *markup-stream-top-level* nil nil nil)))
+
+
+; Return the approximate width of the html item; return t if it is a line break.
+; Also allow html tags as long as they do not contain line breaks.
+(defmethod markup-group-width ((html-stream html-stream) item)
+  (if (consp item)
+    (reduce #'+ (rest item) :key #'(lambda (subitem) (markup-group-width html-stream subitem)))
+    (markup-width html-stream item)))
+
+
+; Create a top-level html-stream and call emitter to emit its contents.
+; emitter takes one argument -- an html-stream to which it should emit paragraphs.
+; Return the top-level html-stream.  If links is true, allow links.
+(defun depict-html-top-level (title links emitter)
+  (let ((html-stream (make-top-level-html-stream *html-definitions* links)))
+    (markup-stream-append1 html-stream 'html)
+    (depict-block-style (html-stream 'head)
+      (depict-block-style (html-stream 'title)
+        (markup-stream-append1 html-stream title))
+      (markup-stream-append1 html-stream '((link (rel "stylesheet") (href "../styles.css"))))
+      (markup-stream-append1 html-stream '((script (type "text/javascript") (language "JavaScript1.2") (src "../unicodeCompatibility.js")))))
+    (depict-block-style (html-stream 'body)
+      (funcall emitter html-stream))
+    (let ((links (markup-env-links (html-stream-env html-stream))))
+      (warn-missing-links links))
+    html-stream))
+
+
+; Create a top-level html-stream and call emitter to emit its contents.
+; emitter takes one argument -- an html-stream to which it should emit paragraphs.
+; Write the resulting html to the text file with the given name (relative to the
+; local directory).
+; If links is true, allow links.  If external-link-base is also provided, emit links for
+; predefined items and assume that they are located on the page specified by the
+; external-link-base string.
+(defun depict-html-to-local-file (filename title links emitter &key external-link-base)
+  (let* ((*external-link-base* external-link-base)
+         (top-html-stream (depict-html-top-level title links emitter)))
+    (write-html-to-local-file filename (markup-stream-output top-html-stream)))
+  filename)
+
+
+; Return the markup accumulated in the markup-stream after expanding all of its macros.
+; The markup-stream is closed after this function is called.
+(defmethod markup-stream-output ((html-stream html-stream))
+  (coalesce-elements
+   (unnest-html-source
+    (markup-env-expand (markup-stream-env html-stream) (markup-stream-unexpanded-output html-stream) '(:none :nowrap :wrap :nest)))))
+
+
+
+(defmethod depict-block-style-f ((html-stream html-stream) block-style flatten emitter)
+  (assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
+  (assert-true (symbolp block-style))
+  (if (or (null block-style)
+          (and flatten (member block-style (html-stream-enclosing-styles html-stream))))
+    (funcall emitter html-stream)
+    (let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
+                                               *markup-stream-paragraph-level*
+                                               nil
+                                               (cons block-style (html-stream-enclosing-styles html-stream))
+                                               nil)))
+      (markup-stream-append1 inner-html-stream block-style)
+      (prog1
+        (funcall emitter inner-html-stream)
+        (let ((inner-output (markup-stream-unexpanded-output inner-html-stream)))
+          (when (or (not flatten) (cdr inner-output))
+            (markup-stream-append1 html-stream inner-output)))))))
+
+
+(defmethod depict-paragraph-f ((html-stream html-stream) paragraph-style emitter)
+  (assert-true (= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
+  (assert-true (and paragraph-style (symbolp paragraph-style)))
+  (let* ((anchors (list 'anchors))
+         (inner-html-stream (make-html-stream (markup-stream-env html-stream)
+                                              *markup-stream-content-level*
+                                              (make-logical-position)
+                                              (cons paragraph-style (html-stream-enclosing-styles html-stream))
+                                              anchors)))
+    (prog1
+      (funcall emitter inner-html-stream)
+      (markup-stream-append1 html-stream (cons paragraph-style
+                                               (nreconc (cdr anchors)
+                                                        (markup-stream-unexpanded-output inner-html-stream)))))))
+
+
+(defmethod depict-char-style-f ((html-stream html-stream) char-style emitter)
+  (assert-true (>= (markup-stream-level html-stream) *markup-stream-content-level*))
+  (if char-style
+    (progn
+      (assert-true (symbolp char-style))
+      (let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
+                                                 *markup-stream-content-level*
+                                                 (markup-stream-logical-position html-stream)
+                                                 (cons char-style (html-stream-enclosing-styles html-stream))
+                                                 (html-stream-anchors html-stream))))
+        (markup-stream-append1 inner-html-stream char-style)
+        (prog1
+          (funcall emitter inner-html-stream)
+          (markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream)))))
+    (funcall emitter html-stream)))
+
+
+(defmethod ensure-no-enclosing-style ((html-stream html-stream) style)
+  (when (member style (html-stream-enclosing-styles html-stream))
+    (cerror "Ignore" "Style ~S should not be in effect" style)))
+
+
+(defmethod save-block-style ((html-stream html-stream))
+  (reverse (html-stream-enclosing-styles html-stream)))
+
+
+(defmethod with-saved-block-style-f ((html-stream html-stream) saved-block-style flatten emitter)
+  (assert-true (<= (markup-stream-level html-stream) *markup-stream-paragraph-level*))
+  (if (endp saved-block-style)
+    (funcall emitter html-stream)
+    (depict-block-style-f html-stream (first saved-block-style) flatten
+                          #'(lambda (html-stream)
+                              (with-saved-block-style-f html-stream (rest saved-block-style) flatten emitter)))))
+
+
+(defmethod depict-anchor ((html-stream html-stream) link-prefix link-name duplicate)
+  (assert-true (= (markup-stream-level html-stream) *markup-stream-content-level*))
+  (let* ((links (markup-env-links (html-stream-env html-stream)))
+         (name (record-link-definition links link-prefix link-name duplicate)))
+    (when name
+      (push (list (list 'a (list 'name name))) (cdr (html-stream-anchors html-stream))))))
+
+
+(defmethod depict-link-reference-f ((html-stream html-stream) link-prefix link-name external emitter)
+  (assert-true (= (markup-stream-level html-stream) *markup-stream-content-level*))
+  (let* ((links (markup-env-links (html-stream-env html-stream)))
+         (href (record-link-reference links link-prefix link-name external)))
+    (if href
+      (let ((inner-html-stream (make-html-stream (markup-stream-env html-stream)
+                                                 *markup-stream-content-level*
+                                                 (markup-stream-logical-position html-stream)
+                                                 (html-stream-enclosing-styles html-stream)
+                                                 (html-stream-anchors html-stream))))
+        (markup-stream-append1 inner-html-stream (list 'a (list 'href href)))
+        (prog1
+          (funcall emitter inner-html-stream)
+          (markup-stream-append1 html-stream (markup-stream-unexpanded-output inner-html-stream))))
+      (funcall emitter html-stream))))
+
+
+#|
+(write-html
+ '(html
+   (head
+    (:nowrap (title "This is my title!<>")))
+   ((body (atr1 "abc") (beta) (qq))
+    "My page this  is  " (br) (p))))
+|#

mozilla/js2/semantics/JS14/Parser.lisp

@@ -0,0 +1,400 @@
+;;;
+;;; Sample JavaScript 1.x grammar
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+(declaim (optimize (debug 3)))
+
+(progn
+  (defparameter *jw*
+    (generate-world
+     "J"
+     '((grammar code-grammar :lr-1 :program)
+       
+       (%section "Expressions")
+       (grammar-argument :alpha normal initial)
+       (grammar-argument :beta allow-in no-in)
+       
+       (%subsection "Primary Expressions")
+       (production (:primary-expression :alpha) (:simple-expression) primary-expression-simple-expression)
+       (production (:primary-expression normal) (:function-expression) primary-expression-function-expression)
+       (production (:primary-expression normal) (:object-literal) primary-expression-object-literal)
+       
+       (production :simple-expression (this) simple-expression-this)
+       (production :simple-expression (null) simple-expression-null)
+       (production :simple-expression (true) simple-expression-true)
+       (production :simple-expression (false) simple-expression-false)
+       (production :simple-expression ($number) simple-expression-number)
+       (production :simple-expression ($string) simple-expression-string)
+       (production :simple-expression ($identifier) simple-expression-identifier)
+       (production :simple-expression ($regular-expression) simple-expression-regular-expression)
+       (production :simple-expression (:parenthesized-expression) simple-expression-parenthesized-expression)
+       (production :simple-expression (:array-literal) simple-expression-array-literal)
+       
+       (production :parenthesized-expression (\( (:expression normal allow-in) \)) parenthesized-expression-expression)
+       
+       
+       (%subsection "Function Expressions")
+       (production :function-expression (:anonymous-function) function-expression-anonymous-function)
+       (production :function-expression (:named-function) function-expression-named-function)
+       
+       
+       (%subsection "Object Literals")
+       (production :object-literal (\{ \}) object-literal-empty)
+       (production :object-literal (\{ :field-list \}) object-literal-list)
+       
+       (production :field-list (:literal-field) field-list-one)
+       (production :field-list (:field-list \, :literal-field) field-list-more)
+       
+       (production :literal-field ($identifier \: (:assignment-expression normal allow-in)) literal-field-assignment-expression)
+       
+       
+       (%subsection "Array Literals")
+       (production :array-literal ([ ]) array-literal-empty)
+       (production :array-literal ([ :element-list ]) array-literal-list)
+       
+       (production :element-list (:literal-element) element-list-one)
+       (production :element-list (:element-list \, :literal-element) element-list-more)
+       
+       (production :literal-element ((:assignment-expression normal allow-in)) literal-element-assignment-expression)
+       
+       
+       (%subsection "Left-Side Expressions")
+       (production (:left-side-expression :alpha) ((:call-expression :alpha)) left-side-expression-call-expression)
+       (production (:left-side-expression :alpha) (:short-new-expression) left-side-expression-short-new-expression)
+       
+       (production (:call-expression :alpha) ((:primary-expression :alpha)) call-expression-primary-expression)
+       (production (:call-expression :alpha) (:full-new-expression) call-expression-full-new-expression)
+       (production (:call-expression :alpha) ((:call-expression :alpha) :member-operator) call-expression-member-operator)
+       (production (:call-expression :alpha) ((:call-expression :alpha) :arguments) call-expression-call)
+       
+       (production :full-new-expression (new :full-new-subexpression :arguments) full-new-expression-new)
+       
+       (production :short-new-expression (new :short-new-subexpression) short-new-expression-new)
+       
+       (production :full-new-subexpression ((:primary-expression normal)) full-new-subexpression-primary-expression)
+       (production :full-new-subexpression (:full-new-expression) full-new-subexpression-full-new-expression)
+       (production :full-new-subexpression (:full-new-subexpression :member-operator) full-new-subexpression-member-operator)
+       
+       (production :short-new-subexpression (:full-new-subexpression) short-new-subexpression-new-full)
+       (production :short-new-subexpression (:short-new-expression) short-new-subexpression-new-short)
+       
+       (production :member-operator ([ (:expression normal allow-in) ]) member-operator-array)
+       (production :member-operator (\. $identifier) member-operator-property)
+       
+       (production :arguments (\( \)) arguments-empty)
+       (production :arguments (\( :argument-list \)) arguments-list)
+       
+       (production :argument-list ((:assignment-expression normal allow-in)) argument-list-one)
+       (production :argument-list (:argument-list \, (:assignment-expression normal allow-in)) argument-list-more)
+       
+       
+       (%subsection "Postfix Operators")
+       (production (:postfix-expression :alpha) ((:left-side-expression :alpha)) postfix-expression-left-side-expression)
+       (production (:postfix-expression :alpha) ((:left-side-expression :alpha) ++) postfix-expression-increment)
+       (production (:postfix-expression :alpha) ((:left-side-expression :alpha) --) postfix-expression-decrement)
+       
+       
+       (%subsection "Unary Operators")
+       (production (:unary-expression :alpha) ((:postfix-expression :alpha)) unary-expression-postfix)
+       (production (:unary-expression :alpha) (delete (:left-side-expression normal)) unary-expression-delete)
+       (production (:unary-expression :alpha) (void (:unary-expression normal)) unary-expression-void)
+       (production (:unary-expression :alpha) (typeof (:unary-expression normal)) unary-expression-typeof)
+       (production (:unary-expression :alpha) (++ (:left-side-expression normal)) unary-expression-increment)
+       (production (:unary-expression :alpha) (-- (:left-side-expression normal)) unary-expression-decrement)
+       (production (:unary-expression :alpha) (+ (:unary-expression normal)) unary-expression-plus)
+       (production (:unary-expression :alpha) (- (:unary-expression normal)) unary-expression-minus)
+       (production (:unary-expression :alpha) (~ (:unary-expression normal)) unary-expression-bitwise-not)
+       (production (:unary-expression :alpha) (! (:unary-expression normal)) unary-expression-logical-not)
+       
+       
+       (%subsection "Multiplicative Operators")
+       (production (:multiplicative-expression :alpha) ((:unary-expression :alpha)) multiplicative-expression-unary)
+       (production (:multiplicative-expression :alpha) ((:multiplicative-expression :alpha) * (:unary-expression normal)) multiplicative-expression-multiply)
+       (production (:multiplicative-expression :alpha) ((:multiplicative-expression :alpha) / (:unary-expression normal)) multiplicative-expression-divide)
+       (production (:multiplicative-expression :alpha) ((:multiplicative-expression :alpha) % (:unary-expression normal)) multiplicative-expression-remainder)
+       
+       
+       (%subsection "Additive Operators")
+       (production (:additive-expression :alpha) ((:multiplicative-expression :alpha)) additive-expression-multiplicative)
+       (production (:additive-expression :alpha) ((:additive-expression :alpha) + (:multiplicative-expression normal)) additive-expression-add)
+       (production (:additive-expression :alpha) ((:additive-expression :alpha) - (:multiplicative-expression normal)) additive-expression-subtract)
+       
+       
+       (%subsection "Bitwise Shift Operators")
+       (production (:shift-expression :alpha) ((:additive-expression :alpha)) shift-expression-additive)
+       (production (:shift-expression :alpha) ((:shift-expression :alpha) << (:additive-expression normal)) shift-expression-left)
+       (production (:shift-expression :alpha) ((:shift-expression :alpha) >> (:additive-expression normal)) shift-expression-right-signed)
+       (production (:shift-expression :alpha) ((:shift-expression :alpha) >>> (:additive-expression normal)) shift-expression-right-unsigned)
+       
+       
+       (%subsection "Relational Operators")
+       (exclude (:relational-expression initial no-in))
+       (production (:relational-expression :alpha :beta) ((:shift-expression :alpha)) relational-expression-shift)
+       (production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) < (:shift-expression normal)) relational-expression-less)
+       (production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) > (:shift-expression normal)) relational-expression-greater)
+       (production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) <= (:shift-expression normal)) relational-expression-less-or-equal)
+       (production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) >= (:shift-expression normal)) relational-expression-greater-or-equal)
+       (production (:relational-expression :alpha :beta) ((:relational-expression :alpha :beta) instanceof (:shift-expression normal)) relational-expression-instanceof)
+       (production (:relational-expression :alpha allow-in) ((:relational-expression :alpha allow-in) in (:shift-expression normal)) relational-expression-in)
+       
+       
+       (%subsection "Equality Operators")
+       (exclude (:equality-expression initial no-in))
+       (production (:equality-expression :alpha :beta) ((:relational-expression :alpha :beta)) equality-expression-relational)
+       (production (:equality-expression :alpha :beta) ((:equality-expression :alpha :beta) == (:relational-expression normal :beta)) equality-expression-equal)
+       (production (:equality-expression :alpha :beta) ((:equality-expression :alpha :beta) != (:relational-expression normal :beta)) equality-expression-not-equal)
+       (production (:equality-expression :alpha :beta) ((:equality-expression :alpha :beta) === (:relational-expression normal :beta)) equality-expression-strict-equal)
+       (production (:equality-expression :alpha :beta) ((:equality-expression :alpha :beta) !== (:relational-expression normal :beta)) equality-expression-strict-not-equal)
+       
+       
+       (%subsection "Binary Bitwise Operators")
+       (exclude (:bitwise-and-expression initial no-in))
+       (production (:bitwise-and-expression :alpha :beta) ((:equality-expression :alpha :beta)) bitwise-and-expression-equality)
+       (production (:bitwise-and-expression :alpha :beta) ((:bitwise-and-expression :alpha :beta) & (:equality-expression normal :beta)) bitwise-and-expression-and)
+       
+       (exclude (:bitwise-xor-expression initial no-in))
+       (production (:bitwise-xor-expression :alpha :beta) ((:bitwise-and-expression :alpha :beta)) bitwise-xor-expression-bitwise-and)
+       (production (:bitwise-xor-expression :alpha :beta) ((:bitwise-xor-expression :alpha :beta) ^ (:bitwise-and-expression normal :beta)) bitwise-xor-expression-xor)
+       
+       (exclude (:bitwise-or-expression initial no-in))
+       (production (:bitwise-or-expression :alpha :beta) ((:bitwise-xor-expression :alpha :beta)) bitwise-or-expression-bitwise-xor)
+       (production (:bitwise-or-expression :alpha :beta) ((:bitwise-or-expression :alpha :beta) \| (:bitwise-xor-expression normal :beta)) bitwise-or-expression-or)
+       
+       
+       (%subsection "Binary Logical Operators")
+       (exclude (:logical-and-expression initial no-in))
+       (production (:logical-and-expression :alpha :beta) ((:bitwise-or-expression :alpha :beta)) logical-and-expression-bitwise-or)
+       (production (:logical-and-expression :alpha :beta) ((:logical-and-expression :alpha :beta) && (:bitwise-or-expression normal :beta)) logical-and-expression-and)
+       
+       (exclude (:logical-or-expression initial no-in))
+       (production (:logical-or-expression :alpha :beta) ((:logical-and-expression :alpha :beta)) logical-or-expression-logical-and)
+       (production (:logical-or-expression :alpha :beta) ((:logical-or-expression :alpha :beta) \|\| (:logical-and-expression normal :beta)) logical-or-expression-or)
+       
+       
+       (%subsection "Conditional Operator")
+       (exclude (:conditional-expression initial no-in))
+       (production (:conditional-expression :alpha :beta) ((:logical-or-expression :alpha :beta)) conditional-expression-logical-or)
+       (production (:conditional-expression :alpha :beta) ((:logical-or-expression :alpha :beta) ? (:assignment-expression normal :beta) \: (:assignment-expression normal :beta)) conditional-expression-conditional)
+       
+       
+       (%subsection "Assignment Operators")
+       (exclude (:assignment-expression initial no-in))
+       (production (:assignment-expression :alpha :beta) ((:conditional-expression :alpha :beta)) assignment-expression-conditional)
+       (production (:assignment-expression :alpha :beta) ((:left-side-expression :alpha) = (:assignment-expression normal :beta)) assignment-expression-assignment)
+       (production (:assignment-expression :alpha :beta) ((:left-side-expression :alpha) :compound-assignment (:assignment-expression normal :beta)) assignment-expression-compound)
+       
+       (production :compound-assignment (*=) compound-assignment-multiply)
+       (production :compound-assignment (/=) compound-assignment-divide)
+       (production :compound-assignment (%=) compound-assignment-remainder)
+       (production :compound-assignment (+=) compound-assignment-add)
+       (production :compound-assignment (-=) compound-assignment-subtract)
+       (production :compound-assignment (<<=) compound-assignment-shift-left)
+       (production :compound-assignment (>>=) compound-assignment-shift-right)
+       (production :compound-assignment (>>>=) compound-assignment-shift-right-unsigned)
+       (production :compound-assignment (&=) compound-assignment-and)
+       (production :compound-assignment (^=) compound-assignment-or)
+       (production :compound-assignment (\|=) compound-assignment-xor)
+       
+       
+       (%subsection "Expressions")
+       (exclude (:expression initial no-in))
+       (production (:expression :alpha :beta) ((:assignment-expression :alpha :beta)) expression-assignment)
+       (production (:expression :alpha :beta) ((:expression :alpha :beta) \, (:assignment-expression normal :beta)) expression-comma)
+       
+       (production :optional-expression ((:expression normal allow-in)) optional-expression-expression)
+       (production :optional-expression () optional-expression-empty)
+       
+       
+       (%section "Statements")
+       
+       (grammar-argument :omega
+                         no-short-if ;optional semicolon, but statement must not end with an if without an else
+                         full) ;semicolon required at the end
+       
+       (production (:statement :omega) (:empty-statement) statement-empty-statement)
+       (production (:statement :omega) (:expression-statement :optional-semicolon) statement-expression-statement)
+       (production (:statement :omega) (:variable-definition :optional-semicolon) statement-variable-definition)
+       (production (:statement :omega) (:block) statement-block)
+       (production (:statement :omega) ((:labeled-statement :omega)) statement-labeled-statement)
+       (production (:statement :omega) ((:if-statement :omega)) statement-if-statement)
+       (production (:statement :omega) (:switch-statement) statement-switch-statement)
+       (production (:statement :omega) (:do-statement :optional-semicolon) statement-do-statement)
+       (production (:statement :omega) ((:while-statement :omega)) statement-while-statement)
+       (production (:statement :omega) ((:for-statement :omega)) statement-for-statement)
+       (production (:statement :omega) ((:with-statement :omega)) statement-with-statement)
+       (production (:statement :omega) (:continue-statement :optional-semicolon) statement-continue-statement)
+       (production (:statement :omega) (:break-statement :optional-semicolon) statement-break-statement)
+       (production (:statement :omega) (:return-statement :optional-semicolon) statement-return-statement)
+       (production (:statement :omega) (:throw-statement :optional-semicolon) statement-throw-statement)
+       (production (:statement :omega) (:try-statement) statement-try-statement)
+       
+       (production :optional-semicolon (\;) optional-semicolon-semicolon)
+       
+       
+       (%subsection "Empty Statement")
+       (production :empty-statement (\;) empty-statement-semicolon)
+       
+       
+       (%subsection "Expression Statement")
+       (production :expression-statement ((:expression initial allow-in)) expression-statement-expression)
+       
+       
+       (%subsection "Variable Definition")
+       (production :variable-definition (var (:variable-declaration-list allow-in)) variable-definition-declaration)
+       
+       (production (:variable-declaration-list :beta) ((:variable-declaration :beta)) variable-declaration-list-one)
+       (production (:variable-declaration-list :beta) ((:variable-declaration-list :beta) \, (:variable-declaration :beta)) variable-declaration-list-more)
+       
+       (production (:variable-declaration :beta) ($identifier (:variable-initializer :beta)) variable-declaration-initializer)
+       
+       (production (:variable-initializer :beta) () variable-initializer-empty)
+       (production (:variable-initializer :beta) (= (:assignment-expression normal :beta)) variable-initializer-assignment-expression)
+       
+       
+       (%subsection "Block")
+       (production :block ({ :block-statements }) block-block-statements)
+       
+       (production :block-statements () block-statements-one)
+       (production :block-statements (:block-statements-prefix) block-statements-more)
+       
+       (production :block-statements-prefix ((:statement full)) block-statements-prefix-one)
+       (production :block-statements-prefix (:block-statements-prefix (:statement full)) block-statements-prefix-more)
+       
+       
+       (%subsection "Labeled Statements")
+       (production (:labeled-statement :omega) ($identifier \: (:statement :omega)) labeled-statement-label)
+       
+       
+       (%subsection "If Statement")
+       (production (:if-statement full) (if :parenthesized-expression (:statement full)) if-statement-if-then-full)
+       (production (:if-statement :omega) (if :parenthesized-expression (:statement no-short-if)
+                                              else (:statement :omega)) if-statement-if-then-else)
+       
+       
+       (%subsection "Switch Statement")
+       (production :switch-statement (switch :parenthesized-expression { }) switch-statement-empty)
+       (production :switch-statement (switch :parenthesized-expression { :case-groups :last-case-group }) switch-statement-cases)
+       
+       (production :case-groups () case-groups-empty)
+       (production :case-groups (:case-groups :case-group) case-groups-more)
+       
+       (production :case-group (:case-guards :block-statements-prefix) case-group-block-statements-prefix)
+       
+       (production :last-case-group (:case-guards :block-statements) last-case-group-block-statements)
+       
+       (production :case-guards (:case-guard) case-guards-one)
+       (production :case-guards (:case-guards :case-guard) case-guards-more)
+       
+       (production :case-guard (case (:expression normal allow-in) \:) case-guard-case)
+       (production :case-guard (default \:) case-guard-default)
+       
+       
+       (%subsection "Do-While Statement")
+       (production :do-statement (do (:statement full) while :parenthesized-expression) do-statement-do-while)
+       
+       
+       (%subsection "While Statement")
+       (production (:while-statement :omega) (while :parenthesized-expression (:statement :omega)) while-statement-while)
+       
+       
+       (%subsection "For Statements")
+       (production (:for-statement :omega) (for \( :for-initializer \; :optional-expression \; :optional-expression \)
+                                                (:statement :omega)) for-statement-c-style)
+       (production (:for-statement :omega) (for \( :for-in-binding in (:expression normal allow-in) \) (:statement :omega)) for-statement-in)
+       
+       (production :for-initializer () for-initializer-empty)
+       (production :for-initializer ((:expression normal no-in)) for-initializer-expression)
+       (production :for-initializer (var (:variable-declaration-list no-in)) for-initializer-variable-declaration)
+       
+       (production :for-in-binding ((:left-side-expression normal)) for-in-binding-expression)
+       (production :for-in-binding (var (:variable-declaration no-in)) for-in-binding-variable-declaration)
+       
+       
+       (%subsection "With Statement")
+       (production (:with-statement :omega) (with :parenthesized-expression (:statement :omega)) with-statement-with)
+       
+       
+       (%subsection "Continue and Break Statements")
+       (production :continue-statement (continue :optional-label) continue-statement-optional-label)
+       
+       (production :break-statement (break :optional-label) break-statement-optional-label)
+       
+       (production :optional-label () optional-label-default)
+       (production :optional-label ($identifier) optional-label-identifier)
+       
+       
+       (%subsection "Return Statement")
+       (production :return-statement (return :optional-expression) return-statement-optional-expression)
+       
+       
+       (%subsection "Throw Statement")
+       (production :throw-statement (throw (:expression normal allow-in)) throw-statement-throw)
+       
+       
+       (%subsection "Try Statement")
+       (production :try-statement (try :block :catch-clauses) try-statement-catch-clauses)
+       (production :try-statement (try :block :finally-clause) try-statement-finally-clause)
+       (production :try-statement (try :block :catch-clauses :finally-clause) try-statement-catch-clauses-finally-clause)
+       
+       (production :catch-clauses (:catch-clause) catch-clauses-one)
+       (production :catch-clauses (:catch-clauses :catch-clause) catch-clauses-more)
+       
+       (production :catch-clause (catch \( $identifier \) :block) catch-clause-block)
+       
+       (production :finally-clause (finally :block) finally-clause-block)
+       
+       
+       (%subsection "Function Definition")
+       (production :function-definition (:named-function) function-definition-named-function)
+       
+       (production :anonymous-function (function :formal-parameters-and-body) anonymous-function-formal-parameters-and-body)
+       
+       (production :named-function (function $identifier :formal-parameters-and-body) named-function-formal-parameters-and-body)
+       
+       (production :formal-parameters-and-body (\( :formal-parameters \) { :top-statements }) formal-parameters-and-body)
+       
+       (production :formal-parameters () formal-parameters-none)
+       (production :formal-parameters (:formal-parameters-prefix) formal-parameters-some)
+       
+       (production :formal-parameters-prefix (:formal-parameter) formal-parameters-prefix-one)
+       (production :formal-parameters-prefix (:formal-parameters-prefix \, :formal-parameter) formal-parameters-prefix-more)
+       
+       (production :formal-parameter ($identifier) formal-parameter-identifier)
+       
+       
+       (%section "Programs")
+       
+       (production :program (:top-statements) program)
+       
+       (production :top-statements () top-statements-one)
+       (production :top-statements (:top-statements-prefix) top-statements-more)
+       
+       (production :top-statements-prefix (:top-statement) top-statements-prefix-one)
+       (production :top-statements-prefix (:top-statements-prefix :top-statement) top-statements-prefix-more)
+       
+       (production :top-statement ((:statement full)) top-statement-statement)
+       (production :top-statement (:function-definition) top-statement-function-definition)
+       )))
+  
+  (defparameter *jg* (world-grammar *jw* 'code-grammar))
+  (length (grammar-states *jg*)))
+
+
+#|
+(depict-rtf-to-local-file
+ "JS14/ParserGrammar.rtf"
+ "JavaScript 1.4 Parser Grammar"
+ #'(lambda (markup-stream)
+     (depict-world-commands markup-stream *jw* :visible-semantics nil)))
+
+(depict-html-to-local-file
+ "JS14/ParserGrammar.html"
+ "JavaScript 1.4 Parser Grammar"
+ t
+ #'(lambda (markup-stream)
+     (depict-world-commands markup-stream *jw* :visible-semantics nil)))
+
+(with-local-output (s "JS14/ParserGrammar.txt") (print-grammar *jg* s))
+|#

mozilla/js2/semantics/JS20/Kernel.lisp

@@ -0,0 +1,179 @@
+
+(defun js-state-transition (action-results)
+  (assert-type action-results (tuple t bool))
+  (values action-results (if (second action-results) '($re) '($non-re))))
+
+(defun js-metaparse (string &key trace)
+  (lexer-metaparse *ll* string :initial-state '($re) :state-transition #'js-state-transition :trace trace))
+
+(defun js-pmetaparse (string &key (stream t) trace)
+  (lexer-pmetaparse *ll* string :initial-state '($re) :state-transition #'js-state-transition :stream stream :trace trace))
+
+
+; Convert the results of the lexer's actions into a token suitable for the parser.
+(defun js-lexer-results-to-token (token-value line-break)
+  (multiple-value-bind (token token-arg)
+                       (ecase (car token-value)
+                         (identifier (values '$identifier (cdr token-value)))
+                         ((keyword punctuator) (values (intern (string-upcase (cdr token-value))) nil))
+                         (number (values '$number (cdr token-value)))
+                         (string (values '$string (cdr token-value)))
+                         (regular-expression (values '$regular-expression (cdr token-value)))
+                         (end (setq line-break nil) *end-marker*))
+    (when line-break
+      (setq token (terminal-lf-terminal token)))
+    (values token token-arg)))
+
+
+; Lex and parse the input-string of tokens to produce a list of action results.
+; If trace is:
+;   nil,         don't print trace information
+;   :code,       print trace information, including action code
+;   :lexer,      print lexer trace information
+;   :lexer-code  print lexer trace information, including action code
+;   other        print trace information
+; Return three values:
+;   the list of action results;
+;   the list of action results' types;
+;   the list of processed tokens.
+(defun js-parse (input-string &key (lexer *ll*) (grammar *jg*) trace)
+  (let ((lexer-classifier (lexer-classifier lexer))
+        (lexer-metagrammar (lexer-metagrammar lexer))
+        (lexer-trace (cdr (assoc trace '((:lexer t) (:lexer-code :code)))))
+        (state-stack (list (grammar-start-state grammar)))
+        (value-stack nil)
+        (type-stack nil)
+        (prev-number-token nil)
+        (input (append (coerce input-string 'list) '($end)))
+        (token nil)
+        (token-arg nil)
+        (token2 nil)
+        (token2-arg nil)
+        (token-history nil))
+    (flet
+      ((get-next-token-value (lexer-state)
+         (multiple-value-bind (results in-rest)
+                              (action-metaparse lexer-metagrammar lexer-classifier (cons lexer-state input) :trace lexer-trace)
+           (assert-true (null (cdr results)))
+           (setq input in-rest)
+           (car results))))
+      
+      (loop
+        (let* ((state (car state-stack))
+               (transition (state-only-transition state)))
+          (unless transition
+            (unless token
+              (if token2
+                (setq token token2
+                      token-arg token2-arg
+                      token2 nil
+                      token2-arg nil)
+                (let* ((lexer-state (cond
+                                     (prev-number-token '$unit)
+                                     ((or (state-transition state '/) (state-transition state '/=)) '$non-re)
+                                     (t '$re)))
+                       (token-value (get-next-token-value lexer-state))
+                       (line-break nil))
+                  (when (eq (car token-value) 'line-break)
+                    (when (eq lexer-state '$unit)
+                      (setq lexer-state '$non-re))
+                    (setq token-value (get-next-token-value lexer-state))
+                    (setq line-break t))
+                  (setq prev-number-token (eq (car token-value) 'number))
+                  (multiple-value-setq (token token-arg) (js-lexer-results-to-token token-value line-break)))))
+            (setq transition (state-transition state token))
+            (unless transition
+              (when (lf-terminal? token)
+                (setq transition (state-transition state '$virtual-semicolon)))
+              (if transition
+                (progn
+                  (when trace
+                    (format *trace-output* "Inserted virtual semicolon~@:_"))
+                  (setq token2 token
+                        token2-arg token-arg
+                        token '$virtual-semicolon
+                        token-arg nil))
+                (error "Parse error on ~S followed by ~S ..." token (coerce (butlast (ldiff input (nthcdr 31 input))) 'string)))))
+          
+          (when trace
+            (format *trace-output* "S~D: ~@_" (state-number state))
+            (print-values (reverse value-stack) (reverse type-stack) *trace-output*)
+            (pprint-newline :mandatory *trace-output*))
+          
+          (ecase (transition-kind transition)
+            (:shift
+             (push (if token-arg (cons token token-arg) token) token-history)
+             (when trace
+               (format *trace-output* "  shift ~W ~W~:@_" token token-arg)
+               (dolist (action-signature (grammar-symbol-signature grammar token))
+                 (push (cdr action-signature) type-stack)))
+             (dolist (action-function-binding (gethash token (grammar-terminal-actions grammar)))
+               (push (funcall (cdr action-function-binding) token-arg) value-stack))
+             (push (transition-state transition) state-stack)
+             (setq token nil))
+            
+            (:reduce
+             (let ((production (transition-production transition)))
+               (when trace
+                 (write-string "  reduce " *trace-output*)
+                 (if (eq trace :code)
+                   (write production :stream *trace-output* :pretty t)
+                   (print-production production *trace-output*))
+                 (pprint-newline :mandatory *trace-output*))
+               (setq state-stack (nthcdr (production-rhs-length production) state-stack)
+                     state (assert-non-null
+                            (cdr (assoc (production-lhs production) (state-gotos (car state-stack)) :test *grammar-symbol-=*)))
+                     value-stack (funcall (production-evaluator production) value-stack))
+               (push state state-stack)
+               (when trace
+                 (setq type-stack (nthcdr (production-n-action-args production) type-stack))
+                 (dolist (action-signature (grammar-symbol-signature grammar (production-lhs production)))
+                   (push (cdr action-signature) type-stack)))))
+            
+            (:accept
+             (when trace
+               (format *trace-output* "  accept~:@_"))
+             (return (values
+                      (nreverse value-stack)
+                      (if trace
+                        (nreverse type-stack)
+                        (grammar-user-start-action-types grammar))
+                      (nreverse token-history)))))
+          (when trace
+            (format *trace-output* "!")))))))
+
+
+; Simple JS2 read-eval-print loop.
+(defun rep ()
+  (loop
+    (let ((s (read-line *terminal-io* t)))
+      (format *terminal-io* "<~S>~%" s)
+      (dolist (r (multiple-value-list (js-parse s)))
+        (write r :stream *terminal-io* :pretty t)
+        (terpri *terminal-io*)))))
+
+
+#|
+(js-parse "1+2*/4*/
+32")
+(js-parse "32+abc//23e-a4*7e-2 3 id4 4ef;")
+
+(js-parse "0x20")
+(js-parse "2b")
+(js-parse " 3.75" :trace t)
+(js-parse "25" :trace :code)
+(js-parse "32+abc//23e-a4*7e-2 3 id4 4ef;")
+(js-parse "32+abc//23e-a4*7e-2 3 id4 4ef;
+")
+(js-parse "32+abc/ /23e-a4*7e-2 3 /*id4 4*-/ef;
+
+fjds*/y//z")
+(js-parse "3a+in'a+b\\147\"de'\"'\"")
+(js-parse "3*/regexp*///x")
+(js-parse "/regexp*///x")
+(js-parse "if \\x69f \\u0069f")
+(js-parse "if \\x69f z\\x20z")
+(js-parse "3lbs,3in,3 in 3_in,3_lbs")
+(js-parse "3a+b in'a+b\\040\\077\\700\\150\\15A\\69\"de'\"'\"")
+|#
+

mozilla/js2/semantics/JS20/Lexer.lisp

@@ -0,0 +1,567 @@
+;;;
+;;; JavaScript 2.0 lexer
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+(progn
+  (defparameter *lw*
+    (generate-world
+     "L"
+     '((lexer code-lexer
+              :lalr-1
+              :$next-input-element
+              ((:unicode-character (% every (:text "Any Unicode character")) () t)
+               (:unicode-initial-alphabetic
+                (% initial-alpha (:text "Any Unicode initial alphabetic character (includes ASCII "
+                                        (:character-literal #\A) :nbhy (:character-literal #\Z) " and "
+                                        (:character-literal #\a) :nbhy (:character-literal #\z) ")"))
+                () t)
+               (:unicode-alphanumeric
+                (% alphanumeric (:text "Any Unicode alphabetic or decimal digit character (includes ASCII "
+                                       (:character-literal #\0) :nbhy (:character-literal #\9) ", "
+                                       (:character-literal #\A) :nbhy (:character-literal #\Z) ", and "
+                                       (:character-literal #\a) :nbhy (:character-literal #\z) ")"))
+                () t)
+               (:white-space-character (++ (#?0009 #?000B #?000C #\space #?00A0)
+                                           (#?2000 #?2001 #?2002 #?2003 #?2004 #?2005 #?2006 #?2007)
+                                           (#?2008 #?2009 #?200A #?200B)
+                                           (#?3000)) ())
+               (:line-terminator (#?000A #?000D #?2028 #?2029) ())
+               (:non-terminator (- :unicode-character :line-terminator)
+                                (($default-action $default-action)))
+               (:non-terminator-or-slash (- :non-terminator (#\/)) ())
+               (:non-terminator-or-asterisk-or-slash (- :non-terminator (#\* #\/)) ())
+               (:initial-identifier-character (+ :unicode-initial-alphabetic (#\$ #\_))
+                                              (($default-action $default-action)))
+               (:continuing-identifier-character (+ :unicode-alphanumeric (#\$ #\_))
+                                                 (($default-action $default-action)))
+               (:a-s-c-i-i-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                                 (($default-action $default-action)
+                                  (decimal-value $digit-value)))
+               (:non-zero-digit (#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                                ((decimal-value $digit-value)))
+               (:hex-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f)
+                           ((hex-value $digit-value)))
+               (:letter-e (#\E #\e) (($default-action $default-action)))
+               (:letter-x (#\X #\x) (($default-action $default-action)))
+               ((:literal-string-char single) (- :unicode-character (+ (#\' #\\) :line-terminator))
+                (($default-action $default-action)))
+               ((:literal-string-char double) (- :unicode-character (+ (#\" #\\) :line-terminator))
+                (($default-action $default-action)))
+               (:identity-escape (- :non-terminator (+ (#\_) :unicode-alphanumeric))
+                                 (($default-action $default-action)))
+               (:ordinary-reg-exp-char (- :non-terminator (#\\ #\/))
+                                       (($default-action $default-action))))
+              (($default-action character nil identity)
+               ($digit-value integer digit-value digit-char-36)))
+       
+       (rule :$next-input-element
+             ((input-element input-element))
+         (production :$next-input-element ($unit (:next-input-element unit)) $next-input-element-unit
+           (input-element (input-element :next-input-element)))
+         (production :$next-input-element ($re (:next-input-element re)) $next-input-element-re
+           (input-element (input-element :next-input-element)))
+         (production :$next-input-element ($non-re (:next-input-element div)) $next-input-element-non-re
+           (input-element (input-element :next-input-element))))
+       
+       (%text nil "The start symbols are: "
+              (:grammar-symbol (:next-input-element unit)) " if the previous input element was a number; "
+              (:grammar-symbol (:next-input-element re)) " if the previous input-element was not a number and a "
+              (:character-literal #\/) " should be interpreted as a regular expression; and "
+              (:grammar-symbol (:next-input-element div)) " if the previous input-element was not a number and a "
+              (:character-literal #\/) " should be interpreted as a division or division-assignment operator.")
+       
+       (deftype semantic-exception (oneof syntax-error))
+       
+       (%section "Unicode Character Classes")
+       (%charclass :unicode-character)
+       (%charclass :unicode-initial-alphabetic)
+       (%charclass :unicode-alphanumeric)
+       (%charclass :white-space-character)
+       (%charclass :line-terminator)
+       (%charclass :a-s-c-i-i-digit)
+       (%print-actions)
+       
+       (%section "Comments")
+       (production :line-comment (#\/ #\/ :line-comment-characters) line-comment)
+       
+       (production :line-comment-characters () line-comment-characters-empty)
+       (production :line-comment-characters (:line-comment-characters :non-terminator) line-comment-characters-chars)
+       
+       (%charclass :non-terminator)
+       
+       (production :single-line-block-comment (#\/ #\* :block-comment-characters #\* #\/) single-line-block-comment)
+       
+       (production :block-comment-characters () block-comment-characters-empty)
+       (production :block-comment-characters (:block-comment-characters :non-terminator-or-slash) block-comment-characters-chars)
+       (production :block-comment-characters (:pre-slash-characters #\/) block-comment-characters-slash)
+       
+       (production :pre-slash-characters () pre-slash-characters-empty)
+       (production :pre-slash-characters (:block-comment-characters :non-terminator-or-asterisk-or-slash) pre-slash-characters-chars)
+       (production :pre-slash-characters (:pre-slash-characters #\/) pre-slash-characters-slash)
+       
+       (%charclass :non-terminator-or-slash)
+       (%charclass :non-terminator-or-asterisk-or-slash)
+       
+       (production :multi-line-block-comment (#\/ #\* :multi-line-block-comment-characters :block-comment-characters #\* #\/) multi-line-block-comment)
+       
+       (production :multi-line-block-comment-characters (:block-comment-characters :line-terminator) multi-line-block-comment-characters-first)
+       (production :multi-line-block-comment-characters (:multi-line-block-comment-characters :block-comment-characters :line-terminator)
+                   multi-line-block-comment-characters-rest)
+       (%print-actions)
+       
+       (%section "White space")
+       
+       (production :white-space () white-space-empty)
+       (production :white-space (:white-space :white-space-character) white-space-character)
+       (production :white-space (:white-space :single-line-block-comment) white-space-single-line-block-comment)
+       
+       (%section "Line breaks")
+       
+       (production :line-break (:line-terminator) line-break-line-terminator)
+       (production :line-break (:line-comment :line-terminator) line-break-line-comment)
+       (production :line-break (:multi-line-block-comment) line-break-multi-line-block-comment)
+       
+       (production :line-breaks (:line-break) line-breaks-first)
+       (production :line-breaks (:line-breaks :white-space :line-break) line-breaks-rest)
+       
+       (%section "Input elements")
+       
+       (grammar-argument :nu re div unit)
+       (grammar-argument :nu_2 re div)
+       
+       (rule (:next-input-element :nu)
+             ((input-element input-element))
+         (production (:next-input-element re) (:white-space (:input-element re)) next-input-element-re
+           (input-element (input-element :input-element)))
+         (production (:next-input-element div) (:white-space (:input-element div)) next-input-element-div
+           (input-element (input-element :input-element)))
+         (production (:next-input-element unit) ((:- :continuing-identifier-character #\\) :white-space (:input-element div)) next-input-element-unit-normal
+           (input-element (input-element :input-element)))
+         (production (:next-input-element unit) ((:- #\_) :identifier-name) next-input-element-unit-name
+           (input-element (oneof string (name :identifier-name))))
+         (production (:next-input-element unit) (#\_ :identifier-name) next-input-element-unit-underscore-name
+           (input-element (oneof string (name :identifier-name)))))
+       
+       (%print-actions)
+       
+       (rule (:input-element :nu_2)
+             ((input-element input-element))
+         (production (:input-element :nu_2) (:line-breaks) input-element-line-breaks
+           (input-element (oneof line-break)))
+         (production (:input-element :nu_2) (:identifier-or-keyword) input-element-identifier-or-keyword
+           (input-element (input-element :identifier-or-keyword)))
+         (production (:input-element :nu_2) (:punctuator) input-element-punctuator
+           (input-element (oneof punctuator (punctuator :punctuator))))
+         (production (:input-element div) (:division-punctuator) input-element-division-punctuator
+           (input-element (oneof punctuator (punctuator :division-punctuator))))
+         (production (:input-element :nu_2) (:numeric-literal) input-element-numeric-literal
+           (input-element (oneof number (float64-value :numeric-literal))))
+         (production (:input-element :nu_2) (:string-literal) input-element-string-literal
+           (input-element (oneof string (string-value :string-literal))))
+         (production (:input-element re) (:reg-exp-literal) input-element-reg-exp-literal
+           (input-element (oneof regular-expression (r-e-value :reg-exp-literal))))
+         (production (:input-element :nu_2) (:end-of-input) input-element-end
+           (input-element (oneof end))))
+       
+       (production :end-of-input ($end) end-of-input-end)
+       (production :end-of-input (:line-comment $end) end-of-input-line-comment)
+       
+       (deftype reg-exp (tuple (re-body string)
+                          (re-flags string)))
+       
+       (deftype quantity (tuple (amount float64)
+                           (unit string)))
+       
+       (deftype input-element (oneof line-break
+                                     (identifier string)
+                                     (keyword string)
+                                     (punctuator string)
+                                     (number float64)
+                                     (string string)
+                                     (regular-expression reg-exp)
+                                     end))
+       (%print-actions)
+       
+       (%section "Keywords and identifiers")
+       
+       (rule :identifier-name
+             ((name string) (contains-escapes boolean))
+         (production :identifier-name (:initial-identifier-character-or-escape) identifier-name-initial
+           (name (vector (character-value :initial-identifier-character-or-escape)))
+           (contains-escapes (contains-escapes :initial-identifier-character-or-escape)))
+         (production :identifier-name (:null-escapes :initial-identifier-character-or-escape) identifier-name-initial-null-escapes
+           (name (vector (character-value :initial-identifier-character-or-escape)))
+           (contains-escapes true))
+         (production :identifier-name (:identifier-name :continuing-identifier-character-or-escape) identifier-name-continuing
+           (name (append (name :identifier-name) (vector (character-value :continuing-identifier-character-or-escape))))
+           (contains-escapes (or (contains-escapes :identifier-name)
+                                 (contains-escapes :continuing-identifier-character-or-escape))))
+         (production :identifier-name (:identifier-name :null-escape) identifier-name-null-escape
+           (name (name :identifier-name))
+           (contains-escapes true)))
+       
+       (production :null-escapes (:null-escape) null-escapes-one)
+       (production :null-escapes (:null-escapes :null-escape) null-escapes-more)
+       
+       (production :null-escape (#\\ #\_) null-escape-underscore)
+       
+       (rule :initial-identifier-character-or-escape
+             ((character-value character) (contains-escapes boolean))
+         (production :initial-identifier-character-or-escape (:initial-identifier-character) initial-identifier-character-or-escape-ordinary
+           (character-value ($default-action :initial-identifier-character))
+           (contains-escapes false))
+         (production :initial-identifier-character-or-escape (#\\ :hex-escape) initial-identifier-character-or-escape-escape
+           (character-value (if (is-initial-identifier-character (character-value :hex-escape))
+                              (character-value :hex-escape)
+                              (throw (oneof syntax-error))))
+           (contains-escapes true)))
+       
+       (%charclass :initial-identifier-character)
+       
+       (rule :continuing-identifier-character-or-escape
+             ((character-value character) (contains-escapes boolean))
+         (production :continuing-identifier-character-or-escape (:continuing-identifier-character) continuing-identifier-character-or-escape-ordinary
+           (character-value ($default-action :continuing-identifier-character))
+           (contains-escapes false))
+         (production :continuing-identifier-character-or-escape (#\\ :hex-escape) continuing-identifier-character-or-escape-escape
+           (character-value (if (is-continuing-identifier-character (character-value :hex-escape))
+                              (character-value :hex-escape)
+                              (throw (oneof syntax-error))))
+           (contains-escapes true)))
+       
+       (%charclass :continuing-identifier-character)
+       (%print-actions)
+       
+       (define reserved-words (vector string)
+         (vector "abstract" "break" "case" "catch" "class" "const" "continue" "debugger" "default" "delete" "do" "else" "enum"
+                 "export" "extends" "false" "final" "finally" "for" "function" "goto" "if" "implements" "import" "in"
+                 "instanceof" "interface" "namespace" "native" "new" "null" "package" "private" "protected" "public" "return" "static" "super"
+                 "switch" "synchronized" "this" "throw" "throws" "transient" "true" "try" "typeof" "use" "var" "volatile" "while" "with"))
+       (define non-reserved-words (vector string)
+         (vector "exclude" "get" "include" "set"))
+       (define keywords (vector string)
+         (append reserved-words non-reserved-words))
+       
+       (define (member (id string) (list (vector string))) boolean
+         (if (empty list)
+           false
+           (if (string= id (nth list 0))
+             true
+             (member id (subseq list 1)))))
+       
+       (rule :identifier-or-keyword
+             ((input-element input-element))
+         (production :identifier-or-keyword (:identifier-name) identifier-or-keyword-identifier-name
+           (input-element (let ((id string (name :identifier-name)))
+                            (if (and (member id keywords) (not (contains-escapes :identifier-name)))
+                              (oneof keyword id)
+                              (oneof identifier id))))))
+       (%print-actions)
+       
+       (%section "Punctuators")
+       
+       (rule :punctuator ((punctuator string))
+         (production :punctuator (#\!) punctuator-not (punctuator "!"))
+         (production :punctuator (#\! #\=) punctuator-not-equal (punctuator "!="))
+         (production :punctuator (#\! #\= #\=) punctuator-not-identical (punctuator "!=="))
+         (production :punctuator (#\#) punctuator-hash (punctuator "#"))
+         (production :punctuator (#\%) punctuator-modulo (punctuator "%"))
+         (production :punctuator (#\% #\=) punctuator-modulo-equals (punctuator "%="))
+         (production :punctuator (#\&) punctuator-and (punctuator "&"))
+         (production :punctuator (#\& #\&) punctuator-logical-and (punctuator "&&"))
+         (production :punctuator (#\& #\& #\=) punctuator-logical-and-equals (punctuator "&&="))
+         (production :punctuator (#\& #\=) punctuator-and-equals (punctuator "&="))
+         (production :punctuator (#\() punctuator-open-parenthesis (punctuator "("))
+         (production :punctuator (#\)) punctuator-close-parenthesis (punctuator ")"))
+         (production :punctuator (#\*) punctuator-times (punctuator "*"))
+         (production :punctuator (#\* #\=) punctuator-times-equals (punctuator "*="))
+         (production :punctuator (#\+) punctuator-plus (punctuator "+"))
+         (production :punctuator (#\+ #\+) punctuator-increment (punctuator "++"))
+         (production :punctuator (#\+ #\=) punctuator-plus-equals (punctuator "+="))
+         (production :punctuator (#\,) punctuator-comma (punctuator ","))
+         (production :punctuator (#\-) punctuator-minus (punctuator "-"))
+         (production :punctuator (#\- #\-) punctuator-decrement (punctuator "--"))
+         (production :punctuator (#\- #\=) punctuator-minus-equals (punctuator "-="))
+         (production :punctuator (#\- #\>) punctuator-arrow (punctuator "->"))
+         (production :punctuator (#\.) punctuator-dot (punctuator "."))
+         (production :punctuator (#\. #\.) punctuator-double-dot (punctuator ".."))
+         (production :punctuator (#\. #\. #\.) punctuator-triple-dot (punctuator "..."))
+         (production :punctuator (#\:) punctuator-colon (punctuator ":"))
+         (production :punctuator (#\: #\:) punctuator-namespace (punctuator "::"))
+         (production :punctuator (#\;) punctuator-semicolon (punctuator ";"))
+         (production :punctuator (#\<) punctuator-less-than (punctuator "<"))
+         (production :punctuator (#\< #\<) punctuator-left-shift (punctuator "<<"))
+         (production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (punctuator "<<="))
+         (production :punctuator (#\< #\=) punctuator-less-than-or-equal (punctuator "<="))
+         (production :punctuator (#\=) punctuator-assignment (punctuator "="))
+         (production :punctuator (#\= #\=) punctuator-equal (punctuator "=="))
+         (production :punctuator (#\= #\= #\=) punctuator-identical (punctuator "==="))
+         (production :punctuator (#\>) punctuator-greater-than (punctuator ">"))
+         (production :punctuator (#\> #\=) punctuator-greater-than-or-equal (punctuator ">="))
+         (production :punctuator (#\> #\>) punctuator-right-shift (punctuator ">>"))
+         (production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (punctuator ">>="))
+         (production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (punctuator ">>>"))
+         (production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (punctuator ">>>="))
+         (production :punctuator (#\?) punctuator-question (punctuator "?"))
+         (production :punctuator (#\@) punctuator-at (punctuator "@"))
+         (production :punctuator (#\[) punctuator-open-bracket (punctuator "["))
+         (production :punctuator (#\]) punctuator-close-bracket (punctuator "]"))
+         (production :punctuator (#\^) punctuator-xor (punctuator "^"))
+         (production :punctuator (#\^ #\=) punctuator-xor-equals (punctuator "^="))
+         (production :punctuator (#\^ #\^) punctuator-logical-xor (punctuator "^^"))
+         (production :punctuator (#\^ #\^ #\=) punctuator-logical-xor-equals (punctuator "^^="))
+         (production :punctuator (#\{) punctuator-open-brace (punctuator "{"))
+         (production :punctuator (#\|) punctuator-or (punctuator "|"))
+         (production :punctuator (#\| #\=) punctuator-or-equals (punctuator "|="))
+         (production :punctuator (#\| #\|) punctuator-logical-or (punctuator "||"))
+         (production :punctuator (#\| #\| #\=) punctuator-logical-or-equals (punctuator "||="))
+         (production :punctuator (#\}) punctuator-close-brace (punctuator "}"))
+         (production :punctuator (#\~) punctuator-complement (punctuator "~")))
+       
+       (rule :division-punctuator ((punctuator string))
+         (production :division-punctuator (#\/ (:- #\/ #\*)) punctuator-divide (punctuator "/"))
+         (production :division-punctuator (#\/ #\=) punctuator-divide-equals (punctuator "/=")))
+       (%print-actions)
+       
+       (%section "Numeric literals")
+       
+       (rule :numeric-literal ((float64-value float64))
+         (production :numeric-literal (:decimal-literal) numeric-literal-decimal
+           (float64-value (rational-to-float64 (rational-value :decimal-literal))))
+         (production :numeric-literal (:hex-integer-literal (:- :hex-digit)) numeric-literal-hex
+           (float64-value (rational-to-float64 (integer-value :hex-integer-literal)))))
+       (%print-actions)
+       
+       (define (expt (base rational) (exponent integer)) rational
+         (if (= exponent 0)
+           1
+           (if (< exponent 0)
+             (rational/ 1 (expt base (neg exponent)))
+             (rational* base (expt base (- exponent 1))))))
+       
+       (rule :decimal-literal ((rational-value rational))
+         (production :decimal-literal (:mantissa) decimal-literal
+           (rational-value (rational-value :mantissa)))
+         (production :decimal-literal (:mantissa :letter-e :signed-integer) decimal-literal-exponent
+           (rational-value (rational* (rational-value :mantissa) (expt 10 (integer-value :signed-integer))))))
+       
+       (%charclass :letter-e)
+       
+       (rule :mantissa ((rational-value rational))
+         (production :mantissa (:decimal-integer-literal) mantissa-integer
+           (rational-value (integer-value :decimal-integer-literal)))
+         (production :mantissa (:decimal-integer-literal #\.) mantissa-integer-dot
+           (rational-value (integer-value :decimal-integer-literal)))
+         (production :mantissa (:decimal-integer-literal #\. :fraction) mantissa-integer-dot-fraction
+           (rational-value (rational+ (integer-value :decimal-integer-literal)
+                                      (rational-value :fraction))))
+         (production :mantissa (#\. :fraction) mantissa-dot-fraction
+           (rational-value (rational-value :fraction))))
+       
+       (rule :decimal-integer-literal ((integer-value integer))
+         (production :decimal-integer-literal (#\0) decimal-integer-literal-0
+           (integer-value 0))
+         (production :decimal-integer-literal (:non-zero-decimal-digits) decimal-integer-literal-nonzero
+           (integer-value (integer-value :non-zero-decimal-digits))))
+       
+       (rule :non-zero-decimal-digits ((integer-value integer))
+         (production :non-zero-decimal-digits (:non-zero-digit) non-zero-decimal-digits-first
+           (integer-value (decimal-value :non-zero-digit)))
+         (production :non-zero-decimal-digits (:non-zero-decimal-digits :a-s-c-i-i-digit) non-zero-decimal-digits-rest
+           (integer-value (+ (* 10 (integer-value :non-zero-decimal-digits)) (decimal-value :a-s-c-i-i-digit)))))
+       
+       (%charclass :non-zero-digit)
+       
+       (rule :fraction ((rational-value rational))
+         (production :fraction (:decimal-digits) fraction-decimal-digits
+           (rational-value (rational/ (integer-value :decimal-digits)
+                                      (expt 10 (n-digits :decimal-digits))))))
+       (%print-actions)
+       
+       (rule :signed-integer ((integer-value integer))
+         (production :signed-integer (:decimal-digits) signed-integer-no-sign
+           (integer-value (integer-value :decimal-digits)))
+         (production :signed-integer (#\+ :decimal-digits) signed-integer-plus
+           (integer-value (integer-value :decimal-digits)))
+         (production :signed-integer (#\- :decimal-digits) signed-integer-minus
+           (integer-value (neg (integer-value :decimal-digits)))))
+       (%print-actions)
+       
+       (rule :decimal-digits
+             ((integer-value integer) (n-digits integer))
+         (production :decimal-digits (:a-s-c-i-i-digit) decimal-digits-first
+           (integer-value (decimal-value :a-s-c-i-i-digit))
+           (n-digits 1))
+         (production :decimal-digits (:decimal-digits :a-s-c-i-i-digit) decimal-digits-rest
+           (integer-value (+ (* 10 (integer-value :decimal-digits)) (decimal-value :a-s-c-i-i-digit)))
+           (n-digits (+ (n-digits :decimal-digits) 1))))
+       (%print-actions)
+       
+       (rule :hex-integer-literal ((integer-value integer))
+         (production :hex-integer-literal (#\0 :letter-x :hex-digit) hex-integer-literal-first
+           (integer-value (hex-value :hex-digit)))
+         (production :hex-integer-literal (:hex-integer-literal :hex-digit) hex-integer-literal-rest
+           (integer-value (+ (* 16 (integer-value :hex-integer-literal)) (hex-value :hex-digit)))))
+       (%charclass :letter-x)
+       (%charclass :hex-digit)
+       (%print-actions)
+       
+       (%section "String literals")
+       
+       (grammar-argument :theta single double)
+       (rule :string-literal ((string-value string))
+         (production :string-literal (#\' (:string-chars single) #\') string-literal-single
+           (string-value (string-value :string-chars)))
+         (production :string-literal (#\" (:string-chars double) #\") string-literal-double
+           (string-value (string-value :string-chars))))
+       (%print-actions)
+       
+       (rule (:string-chars :theta) ((string-value string))
+         (production (:string-chars :theta) () string-chars-none
+           (string-value ""))
+         (production (:string-chars :theta) ((:string-chars :theta) (:string-char :theta)) string-chars-some
+           (string-value (append (string-value :string-chars)
+                                 (vector (character-value :string-char)))))
+         (production (:string-chars :theta) ((:string-chars :theta) :null-escape) string-chars-null-escape
+           (string-value (string-value :string-chars))))
+       
+       (rule (:string-char :theta) ((character-value character))
+         (production (:string-char :theta) ((:literal-string-char :theta)) string-char-literal
+           (character-value ($default-action :literal-string-char)))
+         (production (:string-char :theta) (#\\ :string-escape) string-char-escape
+           (character-value (character-value :string-escape))))
+       
+       (%charclass (:literal-string-char single))
+       (%charclass (:literal-string-char double))
+       (%print-actions)
+       
+       (rule :string-escape ((character-value character))
+         (production :string-escape (:control-escape) string-escape-control
+           (character-value (character-value :control-escape)))
+         (production :string-escape (:zero-escape) string-escape-zero
+           (character-value (character-value :zero-escape)))
+         (production :string-escape (:hex-escape) string-escape-hex
+           (character-value (character-value :hex-escape)))
+         (production :string-escape (:identity-escape) string-escape-non-escape
+           (character-value ($default-action :identity-escape))))
+       (%charclass :identity-escape)
+       (%print-actions)
+       
+       (rule :control-escape ((character-value character))
+         (production :control-escape (#\b) control-escape-backspace (character-value #?0008))
+         (production :control-escape (#\f) control-escape-form-feed (character-value #?000C))
+         (production :control-escape (#\n) control-escape-new-line (character-value #?000A))
+         (production :control-escape (#\r) control-escape-return (character-value #?000D))
+         (production :control-escape (#\t) control-escape-tab (character-value #?0009))
+         (production :control-escape (#\v) control-escape-vertical-tab (character-value #?000B)))
+       (%print-actions)
+       
+       (rule :zero-escape ((character-value character))
+         (production :zero-escape (#\0 (:- :a-s-c-i-i-digit)) zero-escape-zero
+           (character-value #?0000)))
+       (%print-actions)
+       
+       (rule :hex-escape ((character-value character))
+         (production :hex-escape (#\x :hex-digit :hex-digit) hex-escape-2
+           (character-value (code-to-character (+ (* 16 (hex-value :hex-digit 1))
+                                                  (hex-value :hex-digit 2)))))
+         (production :hex-escape (#\u :hex-digit :hex-digit :hex-digit :hex-digit) hex-escape-4
+           (character-value (code-to-character (+ (+ (+ (* 4096 (hex-value :hex-digit 1))
+                                                        (* 256 (hex-value :hex-digit 2)))
+                                                     (* 16 (hex-value :hex-digit 3)))
+                                                  (hex-value :hex-digit 4))))))
+       
+       (%print-actions)
+       
+       (%section "Regular expression literals")
+       
+       (rule :reg-exp-literal ((r-e-value reg-exp))
+         (production :reg-exp-literal (:reg-exp-body :reg-exp-flags) reg-exp-literal
+           (r-e-value (tuple reg-exp (r-e-body :reg-exp-body) (r-e-flags :reg-exp-flags)))))
+       
+       (rule :reg-exp-flags ((r-e-flags string))
+         (production :reg-exp-flags () reg-exp-flags-none
+           (r-e-flags ""))
+         (production :reg-exp-flags (:reg-exp-flags :continuing-identifier-character-or-escape) reg-exp-flags-more
+           (r-e-flags (append (r-e-flags :reg-exp-flags) (vector (character-value :continuing-identifier-character-or-escape)))))
+         (production :reg-exp-flags (:reg-exp-flags :null-escape) reg-exp-flags-null-escape
+           (r-e-flags (r-e-flags :reg-exp-flags))))
+       
+       (rule :reg-exp-body ((r-e-body string))
+         (production :reg-exp-body (#\/ (:- #\*) :reg-exp-chars #\/) reg-exp-body
+           (r-e-body (r-e-body :reg-exp-chars))))
+       
+       (rule :reg-exp-chars ((r-e-body string))
+         (production :reg-exp-chars (:reg-exp-char) reg-exp-chars-one
+           (r-e-body (r-e-body :reg-exp-char)))
+         (production :reg-exp-chars (:reg-exp-chars :reg-exp-char) reg-exp-chars-more
+           (r-e-body (append (r-e-body :reg-exp-chars)
+                             (r-e-body :reg-exp-char)))))
+       
+       (rule :reg-exp-char ((r-e-body string))
+         (production :reg-exp-char (:ordinary-reg-exp-char) reg-exp-char-ordinary
+           (r-e-body (vector ($default-action :ordinary-reg-exp-char))))
+         (production :reg-exp-char (#\\ :non-terminator) reg-exp-char-escape
+           (r-e-body (vector #\\ ($default-action :non-terminator)))))
+       
+       (%charclass :ordinary-reg-exp-char)
+       )))
+  
+  (defparameter *ll* (world-lexer *lw* 'code-lexer))
+  (defparameter *lg* (lexer-grammar *ll*))
+  (set-up-lexer-metagrammar *ll*)
+  (defparameter *lm* (lexer-metagrammar *ll*)))
+
+
+#|
+(depict-rtf-to-local-file
+ "JS20/LexerCharClasses.rtf"
+ "JavaScript 2 Lexical Character Classes"
+ #'(lambda (rtf-stream)
+     (depict-paragraph (rtf-stream ':grammar-header)
+       (depict rtf-stream "Character Classes"))
+     (dolist (charclass (lexer-charclasses *ll*))
+       (depict-charclass rtf-stream charclass))
+     (depict-paragraph (rtf-stream ':grammar-header)
+       (depict rtf-stream "Grammar"))
+     (depict-grammar rtf-stream *lg*)))
+
+(values
+  (depict-rtf-to-local-file
+   "JS20/LexerGrammar.rtf"
+   "JavaScript 2 Lexical Grammar"
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *lw* :visible-semantics nil)))
+  (depict-rtf-to-local-file
+   "JS20/LexerSemantics.rtf"
+   "JavaScript 2 Lexical Semantics"
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *lw*))))
+
+(values
+  (depict-html-to-local-file
+   "JS20/LexerGrammar.html"
+   "JavaScript 2 Lexical Grammar"
+   t
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *lw* :visible-semantics nil))
+   :external-link-base "notation.html")
+  (depict-html-to-local-file
+   "JS20/LexerSemantics.html"
+   "JavaScript 2 Lexical Semantics"
+   t
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *lw*))
+   :external-link-base "notation.html"))
+
+(with-local-output (s "JS20/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
+
+(print-illegal-strings m)
+|#
+
+
+#+allegro (clean-grammar *lg*) ;Remove this line if you wish to print the grammar's state tables.
+(length (grammar-states *lg*))

mozilla/js2/semantics/JS20/RegExp.lisp

@@ -0,0 +1,655 @@
+;;;
+;;; JavaScript 2.0 regular expression parser
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+(progn
+  (defparameter *rw*
+    (generate-world
+     "R"
+     '((lexer regexp-lexer
+              :lr-1
+              :regular-expression-pattern
+              ((:unicode-character (% every (:text "Any Unicode character")) () t)
+               (:unicode-alphanumeric
+                (% alphanumeric (:text "Any Unicode alphabetic or decimal digit character (includes ASCII "
+                                       (:character-literal #\0) :nbhy (:character-literal #\9) ", "
+                                       (:character-literal #\A) :nbhy (:character-literal #\Z) ", and "
+                                       (:character-literal #\a) :nbhy (:character-literal #\z) ")"))
+                () t)
+               (:line-terminator (#?000A #?000D #?2028 #?2029) () t)
+               (:decimal-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                               (($default-action $default-action)
+                                (decimal-value $digit-value)))
+               (:non-zero-digit (#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                                ((decimal-value $digit-value)))
+               (:hex-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f)
+                           ((hex-value $digit-value)))
+               (:control-letter (++ (#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
+                                    (#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))
+                                (($default-action $default-action)))
+               (:pattern-character (- :unicode-character (#\^ #\$ #\\ #\. #\* #\+ #\? #\( #\) #\[ #\] #\{ #\} #\|))
+                                   (($default-action $default-action)))
+               ((:class-character dash) (- :unicode-character (#\\ #\]))
+                (($default-action $default-action)))
+               ((:class-character no-dash) (- (:class-character dash) (#\-))
+                (($default-action $default-action)))
+               (:identity-escape (- :unicode-character (+ (#\_) :unicode-alphanumeric))
+                                 (($default-action $default-action))))
+              (($default-action character nil identity)
+               ($digit-value integer digit-value digit-char-36)))
+       
+       (deftype semantic-exception (oneof syntax-error))
+       
+       (%section "Unicode Character Classes")
+       (%charclass :unicode-character)
+       (%charclass :unicode-alphanumeric)
+       (%charclass :line-terminator)
+       
+       (define line-terminators (set character) (set-of character #?000A #?000D #?2028 #?2029))
+       (define re-whitespaces (set character) (set-of character #?000C #?000A #?000D #?0009 #?000B #\space))
+       (define re-digits (set character) (set-of-ranges character #\0 #\9))
+       (define re-word-characters (set character) (set-of-ranges character #\0 #\9 #\A #\Z #\a #\z #\_ nil))
+       (%print-actions)
+       
+       
+       (%section "Regular Expression Definitions")
+       (deftype r-e-input (tuple (str string) (ignore-case boolean) (multiline boolean) (span boolean)))
+       (%text :semantics
+         "Field " (:field str r-e-input) " is the input string. "
+         (:field ignore-case r-e-input) ", "
+         (:field multiline r-e-input) ", and "
+         (:field span r-e-input) " are the corresponding regular expression flags.")
+       
+       (deftype r-e-result (oneof (success r-e-match) failure))
+       (deftype r-e-match (tuple (end-index integer)
+                            (captures (vector capture))))
+       (%text :semantics
+         "A " (:type r-e-match) " holds an intermediate state during the pattern-matching process. "
+         (:field end-index r-e-match)
+         " is the index of the next input character to be matched by the next component in a regular expression pattern. "
+         "If we are at the end of the pattern, " (:field end-index r-e-match)
+         " is one plus the index of the last matched input character. "
+         (:field captures r-e-match)
+         " is a zero-based array of the strings captured so far by capturing parentheses.")
+       
+       (deftype capture (oneof (present string)
+                               absent))
+       (deftype continuation (-> (r-e-match) r-e-result))
+       (%text :semantics
+         "A " (:type continuation)
+         " is a function that attempts to match the remaining portion of the pattern against the input string, "
+         "starting at the intermediate state given by its " (:type r-e-match) " argument. "
+         "If a match is possible, it returns a " (:field success r-e-result) " result that contains the final "
+         (:type r-e-match) " state; if no match is possible, it returns a " (:field failure r-e-result) " result.")
+       
+       (deftype matcher (-> (r-e-input r-e-match continuation) r-e-result))
+       (%text :semantics
+         "A " (:type matcher)
+         " is a function that attempts to match a middle portion of the pattern against the input string, "
+         "starting at the intermediate state given by its " (:type r-e-match) " argument. "
+         "Since the remainder of the pattern heavily influences whether (and how) a middle portion will match, we "
+         "must pass in a " (:type continuation) " function that checks whether the rest of the pattern matched. "
+         "If the continuation returns " (:field failure r-e-result) ", the matcher function may call it repeatedly, "
+         "trying various alternatives at pattern choice points.")
+       (%text :semantics
+         "The " (:type r-e-input) " parameter contains the input string and is merely passed down to subroutines.")
+       
+       (deftype matcher-generator (-> (integer) matcher))
+       (%text :semantics
+         "A " (:type matcher-generator)
+         " is a function executed at the time the regular expression is compiled that returns a " (:type matcher) " for a part "
+         "of the pattern. The " (:type integer) " parameter contains the number of capturing left parentheses seen so far in the "
+         "pattern and is used to assign static, consecutive numbers to capturing parentheses.")
+       
+       (define (character-set-matcher (acceptance-set (set character)) (invert boolean)) matcher   ;*********ignore case?
+         (function ((t r-e-input) (x r-e-match) (c continuation))
+           (let ((i integer (& end-index x))
+                 (s string (& str t)))
+             (if (= i (length s))
+               (oneof failure)
+               (if (xor (character-set-member (nth s i) acceptance-set) invert)
+                 (c (tuple r-e-match (+ i 1) (& captures x)))
+                 (oneof failure))))))
+       (%text :semantics
+         (:global character-set-matcher) " returns a " (:type matcher)
+         " that matches a single input string character. If "
+         (:local invert) " is false, the match succeeds if the character is a member of the "
+         (:local acceptance-set) " set of characters (possibly ignoring case). If "
+         (:local invert) " is true, the match succeeds if the character is not a member of the "
+         (:local acceptance-set) " set of characters (possibly ignoring case).")
+       
+       (define (character-matcher (ch character)) matcher
+         (character-set-matcher (set-of character ch) false))
+       (%text :semantics
+         (:global character-matcher) " returns a " (:type matcher)
+         " that matches a single input string character. The match succeeds if the character is the same as "
+         (:local ch) " (possibly ignoring case).")
+       
+       (%print-actions)
+       
+       
+       (%section "Regular Expression Patterns")
+       
+       (rule :regular-expression-pattern ((exec (-> (r-e-input integer) r-e-result)))
+         (production :regular-expression-pattern (:disjunction) regular-expression-pattern-disjunction
+           (exec
+            (let ((match matcher ((gen-matcher :disjunction) 0)))
+              (function ((t r-e-input) (index integer))
+                (match
+                 t
+                 (tuple r-e-match index (fill-capture (count-parens :disjunction)))
+                 success-continuation))))))
+       
+       (%print-actions)
+       (define (success-continuation (x r-e-match)) r-e-result
+         (oneof success x))
+       (define (fill-capture (i integer)) (vector capture)
+         (if (= i 0)
+           (vector-of capture)
+           (append (fill-capture (- i 1)) (vector (oneof absent)))))
+       
+       
+       (%subsection "Disjunctions")
+       
+       (rule :disjunction ((gen-matcher matcher-generator) (count-parens integer))
+         (production :disjunction (:alternative) disjunction-one
+           (gen-matcher (gen-matcher :alternative))
+           (count-parens (count-parens :alternative)))
+         (production :disjunction (:alternative #\| :disjunction) disjunction-more
+           ((gen-matcher (paren-index integer))
+            (let ((match1 matcher ((gen-matcher :alternative) paren-index))
+                  (match2 matcher ((gen-matcher :disjunction) (+ paren-index (count-parens :alternative)))))
+              (function ((t r-e-input) (x r-e-match) (c continuation))
+                (case (match1 t x c)
+                  ((success y r-e-match) (oneof success y))
+                  (failure (match2 t x c))))))
+           (count-parens (+ (count-parens :alternative) (count-parens :disjunction)))))
+       
+       (%print-actions)
+       
+       
+       (%subsection "Alternatives")
+       
+       (rule :alternative ((gen-matcher matcher-generator) (count-parens integer))
+         (production :alternative () alternative-none
+           ((gen-matcher (paren-index integer :unused))
+            (function ((t r-e-input :unused) (x r-e-match) (c continuation))
+              (c x)))
+           (count-parens 0))
+         (production :alternative (:alternative :term) alternative-some
+           ((gen-matcher (paren-index integer))
+            (let ((match1 matcher ((gen-matcher :alternative) paren-index))
+                  (match2 matcher ((gen-matcher :term) (+ paren-index (count-parens :alternative)))))
+              (function ((t r-e-input) (x r-e-match) (c continuation))
+                (let ((d continuation (function ((y r-e-match))
+                                        (match2 t y c))))
+                  (match1 t x d)))))
+           (count-parens (+ (count-parens :alternative) (count-parens :term)))))
+       
+       (%print-actions)
+       
+       
+       (%subsection "Terms")
+       
+       (rule :term ((gen-matcher matcher-generator) (count-parens integer))
+         (production :term (:assertion) term-assertion
+           ((gen-matcher (paren-index integer :unused))
+            (function ((t r-e-input) (x r-e-match) (c continuation))
+              (if ((test-assertion :assertion) t x)
+                (c x)
+                (oneof failure))))
+           (count-parens 0))
+         (production :term (:atom) term-atom
+           (gen-matcher (gen-matcher :atom))
+           (count-parens (count-parens :atom)))
+         (production :term (:atom :quantifier) term-quantified-atom
+           ((gen-matcher (paren-index integer))
+            (let ((match matcher ((gen-matcher :atom) paren-index))
+                  (min integer (minimum :quantifier))
+                  (max limit (maximum :quantifier))
+                  (greedy boolean (greedy :quantifier)))
+              (if (case max
+                    ((finite m integer) (< m min))
+                    (infinite false))
+                (throw (oneof syntax-error))
+                (repeat-matcher match min max greedy paren-index (count-parens :atom)))))
+           (count-parens (count-parens :atom))))
+       
+       (%print-actions)
+       
+       
+       (rule :quantifier ((minimum integer) (maximum limit) (greedy boolean))
+         (production :quantifier (:quantifier-prefix) quantifier-eager
+           (minimum (minimum :quantifier-prefix))
+           (maximum (maximum :quantifier-prefix))
+           (greedy true))
+         (production :quantifier (:quantifier-prefix #\?) quantifier-greedy
+           (minimum (minimum :quantifier-prefix))
+           (maximum (maximum :quantifier-prefix))
+           (greedy false)))
+       
+       (rule :quantifier-prefix ((minimum integer) (maximum limit))
+         (production :quantifier-prefix (#\*) quantifier-prefix-zero-or-more
+           (minimum 0)
+           (maximum (oneof infinite)))
+         (production :quantifier-prefix (#\+) quantifier-prefix-one-or-more
+           (minimum 1)
+           (maximum (oneof infinite)))
+         (production :quantifier-prefix (#\?) quantifier-prefix-zero-or-one
+           (minimum 0)
+           (maximum (oneof finite 1)))
+         (production :quantifier-prefix (#\{ :decimal-digits #\}) quantifier-prefix-repeat
+           (minimum (integer-value :decimal-digits))
+           (maximum (oneof finite (integer-value :decimal-digits))))
+         (production :quantifier-prefix (#\{ :decimal-digits #\, #\}) quantifier-prefix-repeat-or-more
+           (minimum (integer-value :decimal-digits))
+           (maximum (oneof infinite)))
+         (production :quantifier-prefix (#\{ :decimal-digits #\, :decimal-digits #\}) quantifier-prefix-repeat-range
+           (minimum (integer-value :decimal-digits 1))
+           (maximum (oneof finite (integer-value :decimal-digits 2)))))
+       
+       (rule :decimal-digits ((integer-value integer))
+         (production :decimal-digits (:decimal-digit) decimal-digits-first
+           (integer-value (decimal-value :decimal-digit)))
+         (production :decimal-digits (:decimal-digits :decimal-digit) decimal-digits-rest
+           (integer-value (+ (* 10 (integer-value :decimal-digits)) (decimal-value :decimal-digit)))))
+       (%charclass :decimal-digit)
+       
+       
+       (deftype limit (oneof (finite integer) infinite))
+       
+       (define (reset-parens (x r-e-match) (p integer) (n-parens integer)) r-e-match
+         (if (= n-parens 0)
+           x
+           (let ((y r-e-match (tuple r-e-match (& end-index x)
+                                     (set-nth (& captures x) p (oneof absent)))))
+             (reset-parens y (+ p 1) (- n-parens 1)))))
+       
+       (define (repeat-matcher (body matcher) (min integer) (max limit) (greedy boolean) (paren-index integer) (n-body-parens integer)) matcher
+         (function ((t r-e-input) (x r-e-match) (c continuation))
+           (if (case max
+                 ((finite m integer) (= m 0))
+                 (infinite false))
+             (c x)
+             (let ((d continuation (function ((y r-e-match))
+                                     (if (and (= min 0)
+                                              (= (& end-index y) (& end-index x)))
+                                       (oneof failure)
+                                       (let ((new-min integer (if (= min 0) 0 (- min 1)))
+                                             (new-max limit (case max
+                                                              ((finite m integer) (oneof finite (- m 1)))
+                                                              (infinite (oneof infinite)))))
+                                         ((repeat-matcher body new-min new-max greedy paren-index n-body-parens) t y c)))))
+                   (xr r-e-match (reset-parens x paren-index n-body-parens)))
+               (if (/= min 0)
+                 (body t xr d)
+                 (if greedy
+                   (case (body t xr d)
+                     ((success z r-e-match) (oneof success z))
+                     (failure (c x)))
+                   (case (c x)
+                     ((success z r-e-match) (oneof success z))
+                     (failure (body t xr d)))))))))
+       
+       (%print-actions)
+       
+       
+       (%subsection "Assertions")
+       
+       (rule :assertion ((test-assertion (-> (r-e-input r-e-match) boolean)))
+         (production :assertion (#\^) assertion-beginning
+           ((test-assertion (t r-e-input) (x r-e-match))
+            (if (= (& end-index x) 0)
+              true
+              (and (& multiline t)
+                   (character-set-member (nth (& str t) (- (& end-index x) 1)) line-terminators)))))
+         (production :assertion (#\$) assertion-end
+           ((test-assertion (t r-e-input) (x r-e-match))
+            (if (= (& end-index x) (length (& str t)))
+              true
+              (and (& multiline t)
+                   (character-set-member (nth (& str t) (& end-index x)) line-terminators)))))
+         (production :assertion (#\\ #\b) assertion-word-boundary
+           ((test-assertion (t r-e-input) (x r-e-match))
+            (at-word-boundary (& end-index x) (& str t))))
+         (production :assertion (#\\ #\B) assertion-non-word-boundary
+           ((test-assertion (t r-e-input) (x r-e-match))
+            (not (at-word-boundary (& end-index x) (& str t))))))
+       
+       (%print-actions)
+       
+       (define (at-word-boundary (i integer) (s string)) boolean
+         (xor (in-word (- i 1) s) (in-word i s)))
+       
+       (define (in-word (i integer) (s string)) boolean
+         (if (or (= i -1) (= i (length s)))
+           false
+           (character-set-member (nth s i) re-word-characters)))
+       
+       
+       (%section "Atoms")
+       
+       (rule :atom ((gen-matcher matcher-generator) (count-parens integer))
+         (production :atom (:pattern-character) atom-pattern-character
+           ((gen-matcher (paren-index integer :unused))
+            (character-matcher ($default-action :pattern-character)))
+           (count-parens 0))
+         (production :atom (#\.) atom-dot
+           ((gen-matcher (paren-index integer :unused))
+            (function ((t r-e-input) (x r-e-match) (c continuation))
+              ((character-set-matcher (if (& span t) (set-of character) line-terminators) true) t x c)))
+           (count-parens 0))
+         (production :atom (:null-escape) atom-null-escape
+           ((gen-matcher (paren-index integer :unused))
+            (function ((t r-e-input :unused) (x r-e-match) (c continuation))
+              (c x)))
+           (count-parens 0))
+         (production :atom (#\\ :atom-escape) atom-atom-escape
+           (gen-matcher (gen-matcher :atom-escape))
+           (count-parens 0))
+         (production :atom (:character-class) atom-character-class
+           ((gen-matcher (paren-index integer :unused))
+            (let ((a (set character) (acceptance-set :character-class)))
+              (character-set-matcher a (invert :character-class))))
+           (count-parens 0))
+         (production :atom (#\( :disjunction #\)) atom-parentheses
+           ((gen-matcher (paren-index integer))
+            (let ((match matcher ((gen-matcher :disjunction) (+ paren-index 1))))
+              (function ((t r-e-input) (x r-e-match) (c continuation))
+                (let ((d continuation
+                         (function ((y r-e-match))
+                           (let ((updated-captures (vector capture)
+                                                   (set-nth (& captures y) paren-index
+                                                            (oneof present (subseq (& str t) (& end-index x) (- (& end-index y) 1))))))
+                             (c (tuple r-e-match (& end-index y) updated-captures))))))
+                  (match t x d)))))
+           (count-parens (+ (count-parens :disjunction) 1)))
+         (production :atom (#\( #\? #\: :disjunction #\)) atom-non-capturing-parentheses
+           (gen-matcher (gen-matcher :disjunction))
+           (count-parens (count-parens :disjunction)))
+         (production :atom (#\( #\? #\= :disjunction #\)) atom-positive-lookahead
+           ((gen-matcher (paren-index integer))
+            (let ((match matcher ((gen-matcher :disjunction) paren-index)))
+              (function ((t r-e-input) (x r-e-match) (c continuation))
+                ;(let ((d continuation
+                ;         (function ((y r-e-match))
+                ;           (c (tuple r-e-match (& end-index x) (& captures y))))))
+                ;  (match t x d)))))
+                (case (match t x success-continuation)
+                  ((success y r-e-match)
+                   (c (tuple r-e-match (& end-index x) (& captures y))))
+                  (failure (oneof failure))))))
+           (count-parens (count-parens :disjunction)))
+         (production :atom (#\( #\? #\! :disjunction #\)) atom-negative-lookahead
+           ((gen-matcher (paren-index integer))
+            (let ((match matcher ((gen-matcher :disjunction) paren-index)))
+              (function ((t r-e-input) (x r-e-match) (c continuation))
+                (case (match t x success-continuation)
+                  ((success y r-e-match :unused) (oneof failure))
+                  (failure (c x))))))
+           (count-parens (count-parens :disjunction))))
+       
+       (%charclass :pattern-character)
+       (%print-actions)
+       
+       
+       (%section "Escapes")
+       
+       (production :null-escape (#\\ #\_) null-escape-underscore)
+       
+       (rule :atom-escape ((gen-matcher matcher-generator))
+         (production :atom-escape (:decimal-escape) atom-escape-decimal
+           ((gen-matcher (paren-index integer))
+            (let ((n integer (escape-value :decimal-escape)))
+              (if (= n 0)
+                (character-matcher #?0000)
+                (if (> n paren-index)
+                  (throw (oneof syntax-error))
+                  (backreference-matcher n))))))
+         (production :atom-escape (:character-escape) atom-escape-character
+           ((gen-matcher (paren-index integer :unused))
+            (character-matcher (character-value :character-escape))))
+         (production :atom-escape (:character-class-escape) atom-escape-character-class
+           ((gen-matcher (paren-index integer :unused))
+            (character-set-matcher (acceptance-set :character-class-escape) false))))
+       (%print-actions)
+       
+       (define (backreference-matcher (n integer)) matcher
+         (function ((t r-e-input) (x r-e-match) (c continuation))
+           (case (nth-backreference x n)
+             ((present ref string)
+              (let ((i integer (& end-index x))
+                    (s string (& str t)))
+                (let ((j integer (+ i (length ref))))
+                  (if (> j (length s))
+                    (oneof failure)
+                    (if (string= (subseq s i (- j 1)) ref)   ;*********ignore case?
+                      (c (tuple r-e-match j (& captures x)))
+                      (oneof failure))))))
+             (absent (c x)))))
+       
+       (define (nth-backreference (x r-e-match) (n integer)) capture
+         (nth (& captures x) (- n 1)))
+       
+       
+       (rule :character-escape ((character-value character))
+         (production :character-escape (:control-escape) character-escape-control
+           (character-value (character-value :control-escape)))
+         (production :character-escape (#\c :control-letter) character-escape-control-letter
+           (character-value (code-to-character (bitwise-and (character-to-code ($default-action :control-letter)) 31))))
+         (production :character-escape (:hex-escape) character-escape-hex
+           (character-value (character-value :hex-escape)))
+         (production :character-escape (:identity-escape) character-escape-identity
+           (character-value ($default-action :identity-escape))))
+       
+       (%charclass :control-letter)
+       (%charclass :identity-escape)
+       
+       (rule :control-escape ((character-value character))
+         (production :control-escape (#\f) control-escape-form-feed (character-value #?000C))
+         (production :control-escape (#\n) control-escape-new-line (character-value #?000A))
+         (production :control-escape (#\r) control-escape-return (character-value #?000D))
+         (production :control-escape (#\t) control-escape-tab (character-value #?0009))
+         (production :control-escape (#\v) control-escape-vertical-tab (character-value #?000B)))
+       (%print-actions)
+       
+       
+       (%subsection "Decimal Escapes")
+       
+       (rule :decimal-escape ((escape-value integer))
+         (production :decimal-escape (:decimal-integer-literal (:- :decimal-digit)) decimal-escape-integer
+           (escape-value (integer-value :decimal-integer-literal))))
+       
+       (rule :decimal-integer-literal ((integer-value integer))
+         (production :decimal-integer-literal (#\0) decimal-integer-literal-0
+           (integer-value 0))
+         (production :decimal-integer-literal (:non-zero-decimal-digits) decimal-integer-literal-nonzero
+           (integer-value (integer-value :non-zero-decimal-digits))))
+       
+       (rule :non-zero-decimal-digits ((integer-value integer))
+         (production :non-zero-decimal-digits (:non-zero-digit) non-zero-decimal-digits-first
+           (integer-value (decimal-value :non-zero-digit)))
+         (production :non-zero-decimal-digits (:non-zero-decimal-digits :decimal-digit) non-zero-decimal-digits-rest
+           (integer-value (+ (* 10 (integer-value :non-zero-decimal-digits)) (decimal-value :decimal-digit)))))
+       
+       (%charclass :non-zero-digit)
+       (%print-actions)
+       
+       
+       (%subsection "Hexadecimal Escapes")
+       
+       (rule :hex-escape ((character-value character))
+         (production :hex-escape (#\x :hex-digit :hex-digit) hex-escape-2
+           (character-value (code-to-character (+ (* 16 (hex-value :hex-digit 1))
+                                                  (hex-value :hex-digit 2)))))
+         (production :hex-escape (#\u :hex-digit :hex-digit :hex-digit :hex-digit) hex-escape-4
+           (character-value (code-to-character (+ (+ (+ (* 4096 (hex-value :hex-digit 1))
+                                                        (* 256 (hex-value :hex-digit 2)))
+                                                     (* 16 (hex-value :hex-digit 3)))
+                                                  (hex-value :hex-digit 4))))))
+       (%charclass :hex-digit)
+       (%print-actions)
+       
+       
+       (%subsection "Character Class Escapes")
+       
+       (rule :character-class-escape ((acceptance-set (set character)))
+         (production :character-class-escape (#\s) character-class-escape-whitespace
+           (acceptance-set re-whitespaces))
+         (production :character-class-escape (#\S) character-class-escape-non-whitespace
+           (acceptance-set (character-set-difference (set-of-ranges character #?0000 #?FFFF) re-whitespaces)))
+         (production :character-class-escape (#\d) character-class-escape-digit
+           (acceptance-set re-digits))
+         (production :character-class-escape (#\D) character-class-escape-non-digit
+           (acceptance-set (character-set-difference (set-of-ranges character #?0000 #?FFFF) re-digits)))
+         (production :character-class-escape (#\w) character-class-escape-word
+           (acceptance-set re-word-characters))
+         (production :character-class-escape (#\W) character-class-escape-non-word
+           (acceptance-set (character-set-difference (set-of-ranges character #?0000 #?FFFF) re-word-characters))))
+       (%print-actions)
+       
+       
+       (%section "User-Specified Character Classes")
+       
+       (rule :character-class ((acceptance-set (set character)) (invert boolean))
+         (production :character-class (#\[ (:- #\^) :class-ranges #\]) character-class-positive
+           (acceptance-set (acceptance-set :class-ranges))
+           (invert false))
+         (production :character-class (#\[ #\^ :class-ranges #\]) character-class-negative
+           (acceptance-set (acceptance-set :class-ranges))
+           (invert true)))
+       
+       (rule :class-ranges ((acceptance-set (set character)))
+         (production :class-ranges () class-ranges-none
+           (acceptance-set (set-of character)))
+         (production :class-ranges ((:nonempty-class-ranges dash)) class-ranges-some
+           (acceptance-set (acceptance-set :nonempty-class-ranges))))
+       
+       (grammar-argument :delta dash no-dash)
+       
+       (rule (:nonempty-class-ranges :delta) ((acceptance-set (set character)))
+         (production (:nonempty-class-ranges :delta) ((:class-atom dash)) nonempty-class-ranges-final
+           (acceptance-set (acceptance-set :class-atom)))
+         (production (:nonempty-class-ranges :delta) ((:class-atom :delta) (:nonempty-class-ranges no-dash)) nonempty-class-ranges-non-final
+           (acceptance-set
+            (character-set-union (acceptance-set :class-atom)
+                                 (acceptance-set :nonempty-class-ranges))))
+         (production (:nonempty-class-ranges :delta) ((:class-atom :delta) #\- (:class-atom dash) :class-ranges) nonempty-class-ranges-range
+           (acceptance-set
+            (let ((range (set character) (character-range (acceptance-set :class-atom 1)
+                                                          (acceptance-set :class-atom 2))))
+              (character-set-union range (acceptance-set :class-ranges)))))
+         (production (:nonempty-class-ranges :delta) (:null-escape :class-ranges) nonempty-class-ranges-null-escape
+           (acceptance-set (acceptance-set :class-ranges))))
+       (%print-actions)
+       
+       (define (character-range (low (set character)) (high (set character))) (set character)
+         (if (or (/= (character-set-length low) 1) (/= (character-set-length high) 1))
+           (throw (oneof syntax-error))
+           (let ((l character (character-set-min low))
+                 (h character (character-set-min high)))
+             (if (char<= l h)
+               (set-of-ranges character l h)
+               (throw (oneof syntax-error))))))
+       
+       
+       (%subsection "Character Class Range Atoms")
+       
+       (rule (:class-atom :delta) ((acceptance-set (set character)))
+         (production (:class-atom :delta) ((:class-character :delta)) class-atom-character
+           (acceptance-set (set-of character ($default-action :class-character))))
+         (production (:class-atom :delta) (#\\ :class-escape) class-atom-escape
+           (acceptance-set (acceptance-set :class-escape))))
+       
+       (%charclass (:class-character dash))
+       (%charclass (:class-character no-dash))
+       
+       (rule :class-escape ((acceptance-set (set character)))
+         (production :class-escape (:decimal-escape) class-escape-decimal
+           (acceptance-set
+            (if (= (escape-value :decimal-escape) 0)
+              (set-of character #?0000)
+              (throw (oneof syntax-error)))))
+         (production :class-escape (#\b) class-escape-backspace
+           (acceptance-set (set-of character #?0008)))
+         (production :class-escape (:character-escape) class-escape-character-escape
+           (acceptance-set (set-of character (character-value :character-escape))))
+         (production :class-escape (:character-class-escape) class-escape-character-class-escape
+           (acceptance-set (acceptance-set :character-class-escape))))
+       (%print-actions)
+       )))
+  
+  (defparameter *rl* (world-lexer *rw* 'regexp-lexer))
+  (defparameter *rg* (lexer-grammar *rl*)))
+
+
+(defun run-regexp (regexp input &key ignore-case multiline span)
+  (let ((exec (first (lexer-parse *rl* regexp))))
+    (dotimes (i (length input) '(failure))
+      (let ((result (funcall exec (list input ignore-case multiline span) i)))
+        (ecase (first result)
+          (success
+           (return (list* i (subseq input i (second result)) (cddr result))))
+          (failure))))))
+
+#|
+(values
+  (depict-rtf-to-local-file
+   "JS20/RegExpGrammar.rtf"
+   "Regular Expression Grammar"
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *rw* :visible-semantics nil)))
+  (depict-rtf-to-local-file
+   "JS20/RegExpSemantics.rtf"
+   "Regular Expression Semantics"
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *rw*))))
+
+(values
+  (depict-html-to-local-file
+   "JS20/RegExpGrammar.html"
+   "Regular Expression Grammar"
+   t
+   #'(lambda (html-stream)
+       (depict-world-commands html-stream *rw* :visible-semantics nil))
+   :external-link-base "notation.html")
+  (depict-html-to-local-file
+   "JS20/RegExpSemantics.html"
+   "Regular Expression Semantics"
+   t
+   #'(lambda (html-stream)
+       (depict-world-commands html-stream *rw*))
+   :external-link-base "notation.html"))
+
+(with-local-output (s "JS20/RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
+
+(lexer-pparse *rl* "a+" :trace t)
+(lexer-pparse *rl* "[]+" :trace t)
+(run-regexp "(0x|0)2" "0x20")
+(run-regexp "(a*)b\\1+c" "aabaaaac")
+(run-regexp "(a*)b\\1+" "baaaac")
+(run-regexp "b(a+)(a+)?(a+)c" "baaaac")
+(run-regexp "(((a+)?(b+)?c)*)" "aacbbbcac")
+(run-regexp "(\\s\\S\\s)" "aac xa d fds  fds sac")
+(run-regexp "(\\s)" "aac xa deac")
+(run-regexp "[01234]+aa+" "93-43aabbc")
+(run-regexp "[\\101A-ae-]+" "93ABC-@ezy43abc")
+(run-regexp "[\\181A-ae-]+" "93ABC-@ezy43abc")
+(run-regexp "b[ace]+" "baaaacecfe")
+(run-regexp "b[^a]+" "baaaabc")
+(run-regexp "(?=(a+))a*b\\1" "baaabac")
+(run-regexp "(?=(a+))" "baaabac")
+(run-regexp "(.*?)a(?!(a+)b\\2c)\\2(.*)" "baaabaac")
+(run-regexp "(aa|aabaac|ba|b|c)*" "aabaac")
+(run-regexp "[\\_^01234]+\\_aa+" "93-43aabbc")
+(run-regexp "a." "AAab")
+(run-regexp "a." "AAab" :ignore-case t)
+(run-regexp "a.." (concatenate 'string "a" (string #\newline) "bacd"))
+(run-regexp "a.." (concatenate 'string "a" (string #\newline) "bacd") :span t)
+|#
+
+#+allegro (clean-grammar *rg*) ;Remove this line if you wish to print the grammar's state tables.
+(length (grammar-states *rg*))

mozilla/js2/semantics/JS20/Units.lisp

@@ -0,0 +1,192 @@
+;;;
+;;; JavaScript 2.0 lexer
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+(progn
+  (defparameter *uw*
+    (generate-world
+     "U"
+     '((lexer unit-lexer
+              :lalr-1
+              :unit-pattern
+              ((:unicode-initial-alphabetic
+                (% initial-alpha (:text "Any Unicode initial alphabetic character (includes ASCII "
+                                        (:character-literal #\A) :nbhy (:character-literal #\Z) " and "
+                                        (:character-literal #\a) :nbhy (:character-literal #\z) ")"))
+                () t)
+               (:unicode-alphanumeric
+                (% alphanumeric (:text "Any Unicode alphabetic or decimal digit character (includes ASCII "
+                                       (:character-literal #\0) :nbhy (:character-literal #\9) ", "
+                                       (:character-literal #\A) :nbhy (:character-literal #\Z) ", and "
+                                       (:character-literal #\a) :nbhy (:character-literal #\z) ")"))
+                () t)
+               (:white-space-character (++ (#?0009 #?000B #?000C #\space #?00A0)
+                                           (#?2000 #?2001 #?2002 #?2003 #?2004 #?2005 #?2006 #?2007)
+                                           (#?2008 #?2009 #?200A #?200B)
+                                           (#?3000)) ())
+               (:line-terminator (#?000A #?000D #?2028 #?2029) ())
+               (:initial-identifier-character (+ :unicode-initial-alphabetic (#\$ #\_))
+                                              (($default-action $default-action)))
+               (:continuing-identifier-character (+ :unicode-alphanumeric (#\$ #\_))
+                                                 (($default-action $default-action)))
+               (:a-s-c-i-i-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                                 (($default-action $default-action)
+                                  (decimal-value $digit-value))))
+              (($default-action character nil identity)
+               ($digit-value integer digit-value digit-char-36)))
+       
+       
+       (%text nil "The start nonterminal is " (:grammar-symbol :unit-pattern) ".")
+       
+       (deftype semantic-exception (oneof syntax-error))
+       (%print-actions)
+       
+       
+       (%section "White Space")
+       
+       (grammar-argument :sigma wsopt wsreq)
+
+       (%charclass :white-space-character)
+       (%charclass :line-terminator)
+
+       (production :required-white-space (:white-space-character) required-white-space-character)
+       (production :required-white-space (:line-terminator) required-white-space-line-terminator)
+       (production :required-white-space (:required-white-space :white-space-character) required-white-space-more-character)
+       (production :required-white-space (:required-white-space :line-terminator) required-white-space-more-line-terminator)
+
+       (production (:white-space :sigma) (:required-white-space) white-space-required-white-space)
+       (production (:white-space wsopt) () white-space-empty)
+
+       (%section "Unit Patterns")
+
+       (rule :unit-pattern ((value unit-list))
+         (production :unit-pattern ((:white-space wsopt) :unit-quotient) unit-pattern-quotient
+           (value (value :unit-quotient))))
+       
+       (rule :unit-quotient ((value unit-list))
+         (production :unit-quotient ((:unit-product wsopt)) unit-quotient-product
+           (value (value :unit-product)))
+         (production :unit-quotient ((:unit-product wsopt) #\/ (:white-space wsopt) (:unit-product wsopt)) unit-quotient-quotient
+           (value (append (value :unit-product 1) (unit-reciprocal (value :unit-product 2))))))
+       
+       (rule (:unit-product :sigma) ((value unit-list))
+         (production (:unit-product :sigma) ((:unit-factor :sigma)) unit-product-factor
+           (value (value :unit-factor)))
+         (production (:unit-product :sigma) ((:unit-product wsopt) #\* (:white-space wsopt) (:unit-factor :sigma)) unit-product-product
+           (value (append (value :unit-product) (value :unit-factor))))
+         (production (:unit-product :sigma) ((:unit-product wsreq) (:unit-factor :sigma)) unit-product-implied-product
+           (value (append (value :unit-product) (value :unit-factor)))))
+       
+       (rule (:unit-factor :sigma) ((value unit-list))
+         (production (:unit-factor :sigma) (#\1 (:white-space :sigma)) unit-factor-one
+           (value (vector-of unit-factor)))
+         (production (:unit-factor :sigma) (#\1 (:white-space wsopt) #\^ (:white-space wsopt) :signed-integer (:white-space :sigma)) unit-factor-one-exponent
+           (value (vector-of unit-factor)))
+         (production (:unit-factor :sigma) (:identifier (:white-space :sigma)) unit-factor-identifier
+           (value (vector (tuple unit-factor (name :identifier) 1))))
+         (production (:unit-factor :sigma) (:identifier (:white-space wsopt) #\^ (:white-space wsopt) :signed-integer (:white-space :sigma)) unit-factor-identifier-exponent
+           (value (vector (tuple unit-factor (name :identifier) (integer-value :signed-integer))))))
+       
+       (deftype unit-list (vector unit-factor))
+       (deftype unit-factor (tuple (identifier string) (exponent integer)))
+       
+       (define (unit-reciprocal (u unit-list)) unit-list
+         (if (empty u)
+           (vector-of unit-factor)
+           (let ((f unit-factor (nth u 0)))
+             (append (vector (tuple unit-factor (& identifier f) (neg (& exponent f)))) (subseq u 1)))))
+       
+       (%print-actions)
+       
+       
+       (%section "Signed Integers")
+       (rule :signed-integer ((integer-value integer))
+         (production :signed-integer (:decimal-digits) signed-integer-no-sign
+           (integer-value (integer-value :decimal-digits)))
+         (production :signed-integer (#\+ :decimal-digits) signed-integer-plus
+           (integer-value (integer-value :decimal-digits)))
+         (production :signed-integer (#\- :decimal-digits) signed-integer-minus
+           (integer-value (neg (integer-value :decimal-digits)))))
+       
+       (rule :decimal-digits ((integer-value integer))
+         (production :decimal-digits (:a-s-c-i-i-digit) decimal-digits-first
+           (integer-value (decimal-value :a-s-c-i-i-digit)))
+         (production :decimal-digits (:decimal-digits :a-s-c-i-i-digit) decimal-digits-rest
+           (integer-value (+ (* 10 (integer-value :decimal-digits)) (decimal-value :a-s-c-i-i-digit)))))
+       
+       (%charclass :a-s-c-i-i-digit)
+       (%print-actions)
+       
+       
+       (%section "Identifiers")
+       (rule :identifier ((name string))
+         (production :identifier (:initial-identifier-character) identifier-initial
+           (name (vector ($default-action :initial-identifier-character))))
+         (production :identifier (:identifier :continuing-identifier-character) identifier-continuing
+           (name (append (name :identifier) (vector ($default-action :continuing-identifier-character))))))
+       
+       (%charclass :initial-identifier-character)
+       (%charclass :continuing-identifier-character)
+       (%charclass :unicode-initial-alphabetic)
+       (%charclass :unicode-alphanumeric)
+       (%print-actions)
+       )))
+  
+  (defparameter *ul* (world-lexer *uw* 'unit-lexer))
+  (defparameter *ug* (lexer-grammar *ul*))
+  (set-up-lexer-metagrammar *ul*)
+  (defparameter *um* (lexer-metagrammar *ul*)))
+
+
+#|
+(depict-rtf-to-local-file
+ "JS20/UnitCharClasses.rtf"
+ "JavaScript 2 Unit Character Classes"
+ #'(lambda (rtf-stream)
+     (depict-paragraph (rtf-stream ':grammar-header)
+       (depict rtf-stream "Character Classes"))
+     (dolist (charclass (lexer-charclasses *ul*))
+       (depict-charclass rtf-stream charclass))
+     (depict-paragraph (rtf-stream ':grammar-header)
+       (depict rtf-stream "Grammar"))
+     (depict-grammar rtf-stream *ug*)))
+
+(values
+  (depict-rtf-to-local-file
+   "JS20/UnitGrammar.rtf"
+   "JavaScript 2 Unit Grammar"
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *uw* :visible-semantics nil)))
+  (depict-rtf-to-local-file
+   "JS20/UnitSemantics.rtf"
+   "JavaScript 2 Unit Semantics"
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *uw*))))
+
+(values
+  (depict-html-to-local-file
+   "JS20/UnitGrammar.html"
+   "JavaScript 2 Unit Grammar"
+   t
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *uw* :visible-semantics nil))
+   :external-link-base "notation.html")
+  (depict-html-to-local-file
+   "JS20/UnitSemantics.html"
+   "JavaScript 2 Unit Semantics"
+   t
+   #'(lambda (rtf-stream)
+       (depict-world-commands rtf-stream *uw*))
+   :external-link-base "notation.html"))
+
+(with-local-output (s "JS20/UnitGrammar.txt") (print-lexer *ul* s) (print-grammar *ug* s))
+
+(print-illegal-strings m)
+|#
+
+
+#+allegro (clean-grammar *ug*) ;Remove this line if you wish to print the grammar's state tables.
+(length (grammar-states *ug*))

mozilla/js2/semantics/JSECMA/Lexer.lisp

@@ -0,0 +1,492 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; ECMAScript sample lexer
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+(progn
+  (defparameter *lw*
+    (generate-world
+     "L"
+     '((lexer code-lexer
+              :lalr-1
+              :next-token
+              ((:unicode-character (% every (:text "Any Unicode character")) () t)
+               (:white-space-character (#?0009 #?000B #?000C #\space) ())
+               (:line-terminator (#?000A #?000D) ())
+               (:non-terminator (- :unicode-character :line-terminator) ())
+               (:non-terminator-or-slash (- :non-terminator (#\/)) ())
+               (:non-terminator-or-asterisk-or-slash (- :non-terminator (#\* #\/)) ())
+               (:identifier-letter (++ (#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
+                                       (#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)
+                                       (#\$ #\_))
+                                   ((character-value character-value)))
+               (:decimal-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                               ((character-value character-value)
+                                (decimal-value $digit-value)))
+               (:non-zero-digit (#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                                ((decimal-value $digit-value)))
+               (:octal-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
+                             ((character-value character-value)
+                              (octal-value $digit-value)))
+               (:zero-to-three (#\0 #\1 #\2 #\3)
+                               ((octal-value $digit-value)))
+               (:four-to-seven (#\4 #\5 #\6 #\7)
+                               ((octal-value $digit-value)))
+               (:hex-digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F #\a #\b #\c #\d #\e #\f)
+                           ((hex-value $digit-value)))
+               (:exponent-indicator (#\E #\e) ())
+               (:hex-indicator (#\X #\x) ())
+               (:plain-string-char (- :unicode-character (+ (#\' #\" #\\) :octal-digit :line-terminator))
+                                   ((character-value character-value)))
+               (:string-non-escape (- :non-terminator (+ :octal-digit (#\x #\u #\' #\" #\\ #\b #\f #\n #\r #\t #\v)))
+                                   ((character-value character-value))))
+              ((character-value character nil identity)
+               ($digit-value integer digit-value digit-char-36)))
+       
+       (%section "Comments")
+       (production :line-comment (#\/ #\/ :line-comment-characters) line-comment)
+       
+       (production :line-comment-characters () line-comment-characters-empty)
+       (production :line-comment-characters (:line-comment-characters :non-terminator) line-comment-characters-chars)
+       (%charclass :unicode-character)
+       (%charclass :non-terminator)
+       
+       (production :single-line-block-comment (#\/ #\* :block-comment-characters #\* #\/) single-line-block-comment)
+       
+       (production :block-comment-characters () block-comment-characters-empty)
+       (production :block-comment-characters (:block-comment-characters :non-terminator-or-slash) block-comment-characters-chars)
+       (production :block-comment-characters (:pre-slash-characters #\/) block-comment-characters-slash)
+       
+       (production :pre-slash-characters () pre-slash-characters-empty)
+       (production :pre-slash-characters (:block-comment-characters :non-terminator-or-asterisk-or-slash) pre-slash-characters-chars)
+       (production :pre-slash-characters (:pre-slash-characters #\/) pre-slash-characters-slash)
+       
+       (%charclass :non-terminator-or-slash)
+       (%charclass :non-terminator-or-asterisk-or-slash)
+       
+       (production :multi-line-block-comment (#\/ #\* :multi-line-block-comment-characters :block-comment-characters #\* #\/) multi-line-block-comment)
+       
+       (production :multi-line-block-comment-characters (:block-comment-characters :line-terminator) multi-line-block-comment-characters-first)
+       (production :multi-line-block-comment-characters (:multi-line-block-comment-characters :block-comment-characters :line-terminator)
+                   multi-line-block-comment-characters-rest)
+       
+       (%section "White space")
+       
+       (production :white-space () white-space-empty)
+       (production :white-space (:white-space :white-space-character) white-space-character)
+       (production :white-space (:white-space :single-line-block-comment) white-space-single-line-block-comment)
+       (%charclass :white-space-character)
+       
+       (%section "Line breaks")
+       
+       (production :line-break (:line-terminator) line-break-line-terminator)
+       (production :line-break (:line-comment :line-terminator) line-break-line-comment)
+       (production :line-break (:multi-line-block-comment) line-break-multi-line-block-comment)
+       (%charclass :line-terminator)
+       
+       (production :line-breaks (:line-break) line-breaks-first)
+       (production :line-breaks (:line-breaks :white-space :line-break) line-breaks-rest)
+       
+       (%section "Tokens")
+       
+       (declare-action token :next-token token)
+       (production :next-token (:white-space :token) next-token
+         (token (token :token)))
+       
+       (declare-action token :token token)
+       (production :token (:line-breaks) token-line-breaks
+         (token (oneof line-breaks)))
+       (production :token (:identifier-or-reserved-word) token-identifier-or-reserved-word
+         (token (token :identifier-or-reserved-word)))
+       (production :token (:punctuator) token-punctuator
+         (token (oneof punctuator (punctuator :punctuator))))
+       (production :token (:numeric-literal) token-numeric-literal
+         (token (oneof number (float64-value :numeric-literal))))
+       (production :token (:string-literal) token-string-literal
+         (token (oneof string (string-value :string-literal))))
+       (production :token (:end-of-input) token-end
+         (token (oneof end)))
+       
+       (production :end-of-input ($end) end-of-input-end)
+       (production :end-of-input (:line-comment $end) end-of-input-line-comment)
+       
+       (deftype token (oneof (identifier string) (reserved-word string) (punctuator string) (number float64) (string string) line-breaks end))
+       (%print-actions)
+       
+       (%section "Keywords")
+       
+       (declare-action name :identifier-name string)
+       (production :identifier-name (:identifier-letter) identifier-name-letter
+         (name (vector (character-value :identifier-letter))))
+       (production :identifier-name (:identifier-name :identifier-letter) identifier-name-next-letter
+         (name (append (name :identifier-name) (vector (character-value :identifier-letter)))))
+       (production :identifier-name (:identifier-name :decimal-digit) identifier-name-next-digit
+         (name (append (name :identifier-name) (vector (character-value :decimal-digit)))))
+       (%charclass :identifier-letter)
+       (%charclass :decimal-digit)
+       (%print-actions)
+       
+       (define keywords (vector string)
+         (vector "break" "case" "catch" "continue" "default" "delete" "do" "else" "finally" "for" "function" "if" "in"
+                 "new" "return" "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"))
+       (define future-reserved-words (vector string)
+         (vector "class" "const" "debugger" "enum" "export" "extends" "import" "super"))
+       (define literals (vector string)
+         (vector "null" "true" "false"))
+       (define reserved-words (vector string)
+         (append keywords (append future-reserved-words literals)))
+       
+       (define (member (id string) (list (vector string))) boolean
+         (if (empty list)
+           false
+           (let ((s string (nth list 0)))
+             (if (string= id s)
+               true
+               (member id (subseq list 1))))))
+       
+       (declare-action token :identifier-or-reserved-word token)
+       (production :identifier-or-reserved-word (:identifier-name) identifier-or-reserved-word-identifier-name
+         (token (let ((id string (name :identifier-name)))
+                  (if (member id reserved-words)
+                    (oneof reserved-word id)
+                    (oneof identifier id)))))
+       (%print-actions)
+       
+       (%section "Punctuators")
+       
+       (declare-action punctuator :punctuator string)
+       (production :punctuator (#\=) punctuator-assignment (punctuator "="))
+       (production :punctuator (#\>) punctuator-greater-than (punctuator ">"))
+       (production :punctuator (#\<) punctuator-less-than (punctuator "<"))
+       (production :punctuator (#\= #\=) punctuator-equal (punctuator "=="))
+       (production :punctuator (#\= #\= #\=) punctuator-identical (punctuator "==="))
+       (production :punctuator (#\< #\=) punctuator-less-than-or-equal (punctuator "<="))
+       (production :punctuator (#\> #\=) punctuator-greater-than-or-equal (punctuator ">="))
+       (production :punctuator (#\! #\=) punctuator-not-equal (punctuator "!="))
+       (production :punctuator (#\! #\= #\=) punctuator-not-identical (punctuator "!=="))
+       (production :punctuator (#\,) punctuator-comma (punctuator ","))
+       (production :punctuator (#\!) punctuator-not (punctuator "!"))
+       (production :punctuator (#\~) punctuator-complement (punctuator "~"))
+       (production :punctuator (#\?) punctuator-question (punctuator "?"))
+       (production :punctuator (#\:) punctuator-colon (punctuator ":"))
+       (production :punctuator (#\.) punctuator-period (punctuator "."))
+       (production :punctuator (#\& #\&) punctuator-logical-and (punctuator "&&"))
+       (production :punctuator (#\| #\|) punctuator-logical-or (punctuator "||"))
+       (production :punctuator (#\+ #\+) punctuator-increment (punctuator "++"))
+       (production :punctuator (#\- #\-) punctuator-decrement (punctuator "--"))
+       (production :punctuator (#\+) punctuator-plus (punctuator "+"))
+       (production :punctuator (#\-) punctuator-minus (punctuator "-"))
+       (production :punctuator (#\*) punctuator-times (punctuator "*"))
+       (production :punctuator (#\/) punctuator-divide (punctuator "/"))
+       (production :punctuator (#\&) punctuator-and (punctuator "&"))
+       (production :punctuator (#\|) punctuator-or (punctuator "|"))
+       (production :punctuator (#\^) punctuator-xor (punctuator "^"))
+       (production :punctuator (#\%) punctuator-modulo (punctuator "%"))
+       (production :punctuator (#\< #\<) punctuator-left-shift (punctuator "<<"))
+       (production :punctuator (#\> #\>) punctuator-right-shift (punctuator ">>"))
+       (production :punctuator (#\> #\> #\>) punctuator-logical-right-shift (punctuator ">>>"))
+       (production :punctuator (#\+ #\=) punctuator-plus-equals (punctuator "+="))
+       (production :punctuator (#\- #\=) punctuator-minus-equals (punctuator "-="))
+       (production :punctuator (#\* #\=) punctuator-times-equals (punctuator "*="))
+       (production :punctuator (#\/ #\=) punctuator-divide-equals (punctuator "/="))
+       (production :punctuator (#\& #\=) punctuator-and-equals (punctuator "&="))
+       (production :punctuator (#\| #\=) punctuator-or-equals (punctuator "|="))
+       (production :punctuator (#\^ #\=) punctuator-xor-equals (punctuator "^="))
+       (production :punctuator (#\% #\=) punctuator-modulo-equals (punctuator "%="))
+       (production :punctuator (#\< #\< #\=) punctuator-left-shift-equals (punctuator "<<="))
+       (production :punctuator (#\> #\> #\=) punctuator-right-shift-equals (punctuator ">>="))
+       (production :punctuator (#\> #\> #\> #\=) punctuator-logical-right-shift-equals (punctuator ">>>="))
+       (production :punctuator (#\() punctuator-open-parenthesis (punctuator "("))
+       (production :punctuator (#\)) punctuator-close-parenthesis (punctuator ")"))
+       (production :punctuator (#\{) punctuator-open-brace (punctuator "{"))
+       (production :punctuator (#\}) punctuator-close-brace (punctuator "}"))
+       (production :punctuator (#\[) punctuator-open-bracket (punctuator "["))
+       (production :punctuator (#\]) punctuator-close-bracket (punctuator "]"))
+       (production :punctuator (#\;) punctuator-semicolon (punctuator ";"))
+       (%print-actions)
+       
+       (%section "Numeric literals")
+       
+       (declare-action float64-value :numeric-literal float64)
+       (production :numeric-literal (:decimal-literal) numeric-literal-decimal
+         (float64-value (rational-to-float64 (rational-value :decimal-literal))))
+       (production :numeric-literal (:hex-integer-literal) numeric-literal-hex
+         (float64-value (rational-to-float64 (integer-value :hex-integer-literal))))
+       (production :numeric-literal (:octal-integer-literal) numeric-literal-octal
+         (float64-value (rational-to-float64 (integer-value :octal-integer-literal))))
+       (%print-actions)
+       
+       (define (expt (base rational) (exponent integer)) rational
+         (if (= exponent 0)
+           1
+           (if (< exponent 0)
+             (rational/ 1 (expt base (neg exponent)))
+             (rational* base (expt base (- exponent 1))))))
+       
+       (declare-action rational-value :decimal-literal rational)
+       (production :decimal-literal (:mantissa :exponent) decimal-literal
+         (rational-value (rational* (rational-value :mantissa) (expt 10 (integer-value :exponent)))))
+       
+       (declare-action rational-value :mantissa rational)
+       (production :mantissa (:decimal-integer-literal) mantissa-integer
+         (rational-value (integer-value :decimal-integer-literal)))
+       (production :mantissa (:decimal-integer-literal #\.) mantissa-integer-dot
+         (rational-value (integer-value :decimal-integer-literal)))
+       (production :mantissa (:decimal-integer-literal #\. :fraction) mantissa-integer-dot-fraction
+         (rational-value (rational+ (integer-value :decimal-integer-literal)
+                                    (rational-value :fraction))))
+       (production :mantissa (#\. :fraction) mantissa-dot-fraction
+         (rational-value (rational-value :fraction)))
+       
+       (declare-action integer-value :decimal-integer-literal integer)
+       (production :decimal-integer-literal (#\0) decimal-integer-literal-0
+         (integer-value 0))
+       (production :decimal-integer-literal (:non-zero-decimal-digits) decimal-integer-literal-nonzero
+         (integer-value (integer-value :non-zero-decimal-digits)))
+       
+       (declare-action integer-value :non-zero-decimal-digits integer)
+       (production :non-zero-decimal-digits (:non-zero-digit) non-zero-decimal-digits-first
+         (integer-value (decimal-value :non-zero-digit)))
+       (production :non-zero-decimal-digits (:non-zero-decimal-digits :decimal-digit) non-zero-decimal-digits-rest
+         (integer-value (+ (* 10 (integer-value :non-zero-decimal-digits)) (decimal-value :decimal-digit))))
+       
+       (%charclass :non-zero-digit)
+       
+       (declare-action rational-value :fraction rational)
+       (production :fraction (:decimal-digits) fraction-decimal-digits
+         (rational-value (rational/ (integer-value :decimal-digits)
+                                    (expt 10 (n-digits :decimal-digits)))))
+       (%print-actions)
+       
+       (declare-action integer-value :exponent integer)
+       (production :exponent () exponent-none
+         (integer-value 0))
+       (production :exponent (:exponent-indicator :signed-integer) exponent-integer
+         (integer-value (integer-value :signed-integer)))
+       (%charclass :exponent-indicator)
+       
+       (declare-action integer-value :signed-integer integer)
+       (production :signed-integer (:decimal-digits) signed-integer-no-sign
+         (integer-value (integer-value :decimal-digits)))
+       (production :signed-integer (#\+ :decimal-digits) signed-integer-plus
+         (integer-value (integer-value :decimal-digits)))
+       (production :signed-integer (#\- :decimal-digits) signed-integer-minus
+         (integer-value (neg (integer-value :decimal-digits))))
+       (%print-actions)
+       
+       (declare-action integer-value :decimal-digits integer)
+       (declare-action n-digits :decimal-digits integer)
+       (production :decimal-digits (:decimal-digit) decimal-digits-first
+         (integer-value (decimal-value :decimal-digit))
+         (n-digits 1))
+       (production :decimal-digits (:decimal-digits :decimal-digit) decimal-digits-rest
+         (integer-value (+ (* 10 (integer-value :decimal-digits)) (decimal-value :decimal-digit)))
+         (n-digits (+ (n-digits :decimal-digits) 1)))
+       (%print-actions)
+       
+       (declare-action integer-value :hex-integer-literal integer)
+       (production :hex-integer-literal (#\0 :hex-indicator :hex-digit) hex-integer-literal-first
+         (integer-value (hex-value :hex-digit)))
+       (production :hex-integer-literal (:hex-integer-literal :hex-digit) hex-integer-literal-rest
+         (integer-value (+ (* 16 (integer-value :hex-integer-literal)) (hex-value :hex-digit))))
+       (%charclass :hex-indicator)
+       (%charclass :hex-digit)
+       
+       (declare-action integer-value :octal-integer-literal integer)
+       (production :octal-integer-literal (#\0 :octal-digit) octal-integer-literal-first
+         (integer-value (octal-value :octal-digit)))
+       (production :octal-integer-literal (:octal-integer-literal :octal-digit) octal-integer-literal-rest
+         (integer-value (+ (* 8 (integer-value :octal-integer-literal)) (octal-value :octal-digit))))
+       (%charclass :octal-digit)
+       (%print-actions)
+       
+       (%section "String literals")
+       
+       (grammar-argument :quote single double)
+       (declare-action string-value :string-literal string)
+       (production :string-literal (#\' (:string-chars single) #\') string-literal-single
+         (string-value (string-value :string-chars)))
+       (production :string-literal (#\" (:string-chars double) #\") string-literal-double
+         (string-value (string-value :string-chars)))
+       (%print-actions)
+       
+       (declare-action string-value (:string-chars :quote) string)
+       (production (:string-chars :quote) ((:ordinary-string-chars :quote)) string-chars-ordinary
+         (string-value (string-value :ordinary-string-chars)))
+       (production (:string-chars :quote) ((:string-chars :quote) #\\ :short-octal-escape) string-chars-short-escape
+         (string-value (append (string-value :string-chars)
+                               (vector (character-value :short-octal-escape)))))
+       
+       (declare-action string-value (:ordinary-string-chars :quote) string)
+       (production (:ordinary-string-chars :quote) () ordinary-string-chars-empty
+         (string-value ""))
+       (production (:ordinary-string-chars :quote) ((:string-chars :quote) :plain-string-char) ordinary-string-chars-char
+         (string-value (append (string-value :string-chars)
+                               (vector (character-value :plain-string-char)))))
+       (production (:ordinary-string-chars :quote) ((:string-chars :quote) (:plain-string-quote :quote)) ordinary-string-chars-quote
+         (string-value (append (string-value :string-chars)
+                               (vector (character-value :plain-string-quote)))))
+       (production (:ordinary-string-chars :quote) ((:ordinary-string-chars :quote) :octal-digit) ordinary-string-chars-octal
+         (string-value (append (string-value :ordinary-string-chars)
+                               (vector (character-value :octal-digit)))))
+       (production (:ordinary-string-chars :quote) ((:string-chars :quote) #\\ :ordinary-escape) ordinary-string-chars-escape
+         (string-value (append (string-value :string-chars)
+                               (vector (character-value :ordinary-escape)))))
+       
+       (%charclass :plain-string-char)
+       
+       (declare-action character-value (:plain-string-quote :quote) character)
+       (production (:plain-string-quote single) (#\") plain-string-quote-single
+         (character-value #\"))
+       (production (:plain-string-quote double) (#\') plain-string-quote-double
+         (character-value #\'))
+       (%print-actions)
+       
+       (declare-action character-value :ordinary-escape character)
+       (production :ordinary-escape (:string-char-escape) ordinary-escape-character
+         (character-value (character-value :string-char-escape)))
+       (production :ordinary-escape (:full-octal-escape) ordinary-escape-full-octal
+         (character-value (character-value :full-octal-escape)))
+       (production :ordinary-escape (:hex-escape) ordinary-escape-hex
+         (character-value (character-value :hex-escape)))
+       (production :ordinary-escape (:unicode-escape) ordinary-escape-unicode
+         (character-value (character-value :unicode-escape)))
+       (production :ordinary-escape (:string-non-escape) ordinary-escape-non-escape
+         (character-value (character-value :string-non-escape)))
+       (%charclass :string-non-escape)
+       (%print-actions)
+       
+       (declare-action character-value :string-char-escape character)
+       (production :string-char-escape (#\') string-char-escape-single-quote (character-value #\'))
+       (production :string-char-escape (#\") string-char-escape-double-quote (character-value #\"))
+       (production :string-char-escape (#\\) string-char-escape-backslash (character-value #\\))
+       (production :string-char-escape (#\b) string-char-escape-backspace (character-value #?0008))
+       (production :string-char-escape (#\f) string-char-escape-form-feed (character-value #?000C))
+       (production :string-char-escape (#\n) string-char-escape-new-line (character-value #?000A))
+       (production :string-char-escape (#\r) string-char-escape-return (character-value #?000D))
+       (production :string-char-escape (#\t) string-char-escape-tab (character-value #?0009))
+       (production :string-char-escape (#\v) string-char-escape-vertical-tab (character-value #?000B))
+       (%print-actions)
+       
+       (declare-action character-value :short-octal-escape character)
+       (production :short-octal-escape (:octal-digit) short-octal-escape-1
+         (character-value (code-to-character (octal-value :octal-digit))))
+       (production :short-octal-escape (:zero-to-three :octal-digit) short-octal-escape-2
+         (character-value (code-to-character (+ (* 8 (octal-value :zero-to-three))
+                                                (octal-value :octal-digit)))))
+       
+       (declare-action character-value :full-octal-escape character)
+       (production :full-octal-escape (:four-to-seven :octal-digit) full-octal-escape-2
+         (character-value (code-to-character (+ (* 8 (octal-value :four-to-seven))
+                                                (octal-value :octal-digit)))))
+       (production :full-octal-escape (:zero-to-three :octal-digit :octal-digit) full-octal-escape-3
+         (character-value (code-to-character (+ (+ (* 64 (octal-value :zero-to-three))
+                                                   (* 8 (octal-value :octal-digit 1)))
+                                                (octal-value :octal-digit 2)))))
+       (%charclass :zero-to-three)
+       (%charclass :four-to-seven)
+       
+       (declare-action character-value :hex-escape character)
+       (production :hex-escape (#\x :hex-digit :hex-digit) hex-escape-2
+         (character-value (code-to-character (+ (* 16 (hex-value :hex-digit 1))
+                                                (hex-value :hex-digit 2)))))
+       
+       (declare-action character-value :unicode-escape character)
+       (production :unicode-escape (#\u :hex-digit :hex-digit :hex-digit :hex-digit) unicode-escape-4
+         (character-value (code-to-character (+ (+ (+ (* 4096 (hex-value :hex-digit 1))
+                                                      (* 256 (hex-value :hex-digit 2)))
+                                                   (* 16 (hex-value :hex-digit 3)))
+                                                (hex-value :hex-digit 4)))))
+       (%print-actions)
+       
+       )))
+  
+  (defparameter *ll* (world-lexer *lw* 'code-lexer))
+  (defparameter *lg* (lexer-grammar *ll*))
+  (set-up-lexer-metagrammar *ll*)
+  (defparameter *lm* (lexer-metagrammar *ll*)))
+
+#|
+(depict-rtf-to-local-file
+ "JSECMA/LexerCharClasses.rtf"
+ "ECMAScript 1 Lexer Character Classes"
+ #'(lambda (rtf-stream)
+     (depict-paragraph (rtf-stream ':grammar-header)
+       (depict rtf-stream "Character Classes"))
+     (dolist (charclass (lexer-charclasses *ll*))
+       (depict-charclass rtf-stream charclass))
+     (depict-paragraph (rtf-stream ':grammar-header)
+       (depict rtf-stream "Grammar"))
+     (depict-grammar rtf-stream *lg*)))
+
+(depict-rtf-to-local-file
+ "JSECMA/LexerSemantics.rtf"
+ "ECMAScript 1 Lexer Semantics"
+ #'(lambda (rtf-stream)
+     (depict-world-commands rtf-stream *lw*)))
+
+(depict-html-to-local-file
+ "JSECMA/LexerSemantics.html"
+ "ECMAScript 1 Lexer Semantics"
+ t
+ #'(lambda (rtf-stream)
+     (depict-world-commands rtf-stream *lw*)))
+
+(with-local-output (s "JSECMA/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
+
+(print-illegal-strings m)
+
+(lexer-pparse *ll* "0x20")
+(lexer-pparse *ll* "2b")
+(lexer-pparse *ll* " 3.75" :trace t)
+(lexer-pparse *ll* "25" :trace :code)
+(lexer-pmetaparse *ll* "32+abc//23e-a4*7e-2 3 id4 4ef;")
+(lexer-pmetaparse *ll* "32+abc//23e-a4*7e-2 3 id4 4ef;
+")
+(lexer-pmetaparse *ll* "32+abc/ /23e-a4*7e-2 3 /*id4 4*-/ef;
+
+fjds*/y//z")
+(lexer-pmetaparse *ll* "3a+in'a+b\\147\"de'\"'\"")
+|#
+
+
+; Return the ECMAScript input string as a list of tokens like:
+;   (($number . 3.0) + - ++ else ($string . "a+bgde") ($end))
+; Line breaks are removed.
+(defun tokenize (string)
+  (delete
+   '($line-breaks)
+   (mapcar
+    #'(lambda (token-value)
+        (let ((token-value (car token-value)))
+          (ecase (car token-value)
+            (identifier (cons '$identifier (cdr token-value)))
+            ((reserved-word punctuator) (intern (string-upcase (cdr token-value))))
+            (number (cons '$number (cdr token-value)))
+            (string (cons '$string (cdr token-value)))
+            (line-breaks '($line-breaks))
+            (end '($end)))))
+    (lexer-metaparse *ll* string))
+   :test #'equal))
+
+

mozilla/js2/semantics/JSECMA/Parser.lisp

@@ -0,0 +1,863 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; ECMAScript sample grammar portions
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+(declaim (optimize (debug 3)))
+
+(progn
+  (defparameter *gw*
+    (generate-world
+     "G"
+     '((grammar code-grammar :lr-1 :program)
+       
+       (%section "Types")
+       
+       (deftype value (oneof undefined-value
+                             null-value
+                             (boolean-value boolean)
+                             (number-value float64)
+                             (string-value string)
+                             (object-value object)))
+       (deftype object-or-null (oneof null-object-or-null (object-object-or-null object)))
+       (deftype object (tuple (properties (address (vector property)))
+                         (typeof-name string)
+                         (prototype object-or-null)
+                         (get (-> (prop-name) value-or-exception))
+                         (put (-> (prop-name value) void-or-exception))
+                         (delete (-> (prop-name) boolean-or-exception))
+                         (call (-> (object-or-null (vector value)) reference-or-exception))
+                         (construct (-> ((vector value)) object-or-exception))
+                         (default-value (-> (default-value-hint) value-or-exception))))
+       (deftype default-value-hint (oneof no-hint number-hint string-hint))
+       (deftype property (tuple (name string) (read-only boolean) (enumerable boolean) (permanent boolean) (value (address value))))
+       
+       (deftype prop-name string)
+       (deftype place (tuple (base object) (property prop-name)))
+       (deftype reference (oneof (value-reference value) (place-reference place) (virtual-reference prop-name)))
+       
+       
+       (deftype integer-or-exception (oneof (normal integer) (abrupt exception)))
+       (deftype void-or-exception (oneof normal (abrupt exception)))
+       (deftype boolean-or-exception (oneof (normal boolean) (abrupt exception)))
+       (deftype float64-or-exception (oneof (normal float64) (abrupt exception)))
+       (deftype string-or-exception (oneof (normal string) (abrupt exception)))
+       (deftype object-or-exception (oneof (normal object) (abrupt exception)))
+       (deftype value-or-exception (oneof (normal value) (abrupt exception)))
+       (deftype reference-or-exception (oneof (normal reference) (abrupt exception)))
+       (deftype value-list-or-exception (oneof (normal (vector value)) (abrupt exception)))
+       
+       (%section "Helper Functions")
+       
+       (define (object-or-null-to-value (o object-or-null)) value
+         (case o
+           (null-object-or-null (oneof null-value))
+           ((object-object-or-null obj object) (oneof object-value obj))))
+       
+       (define undefined-result value-or-exception
+         (oneof normal (oneof undefined-value)))
+       (define null-result value-or-exception
+         (oneof normal (oneof null-value)))
+       (define (boolean-result (b boolean)) value-or-exception
+         (oneof normal (oneof boolean-value b)))
+       (define (float64-result (d float64)) value-or-exception
+         (oneof normal (oneof number-value d)))
+       (define (integer-result (i integer)) value-or-exception
+         (float64-result (rational-to-float64 i)))
+       (define (string-result (s string)) value-or-exception
+         (oneof normal (oneof string-value s)))
+       (define (object-result (o object)) value-or-exception
+         (oneof normal (oneof object-value o)))
+       
+       (%section "Exceptions")
+       
+       (deftype exception (oneof (exception value) (error error)))
+       (deftype error (oneof coerce-to-primitive-error
+                             coerce-to-object-error
+                             get-value-error
+                             put-value-error
+                             delete-error))
+       
+       (define (make-error (err error)) exception
+         (oneof error err))
+       
+       (%section "Objects")
+       
+       
+       (%section "Conversions")
+       
+       (define (reference-get-value (rv reference)) value-or-exception
+         (case rv
+           ((value-reference v value) (oneof normal v))
+           ((place-reference r place) ((& get (& base r)) (& property r)))
+           (virtual-reference (typed-oneof value-or-exception abrupt (make-error (oneof get-value-error))))))
+       
+       (define (reference-put-value (rv reference) (v value)) void-or-exception
+         (case rv
+           (value-reference (typed-oneof void-or-exception abrupt (make-error (oneof put-value-error))))
+           ((place-reference r place) ((& put (& base r)) (& property r) v))
+           (virtual-reference (bottom))))
+       
+       (%section "Coercions")
+       
+       (define (coerce-to-boolean (v value)) boolean
+         (case v
+           (((undefined-value null-value)) false)
+           ((boolean-value b boolean) b)
+           ((number-value d float64) (not (or (float64-is-zero d) (float64-is-na-n d))))
+           ((string-value s string) (/= (length s) 0))
+           (object-value true)))
+       
+       (define (coerce-boolean-to-float64 (b boolean)) float64
+         (if b 1.0 0.0))
+       
+       (define (coerce-to-float64 (v value)) float64-or-exception
+         (case v
+           (undefined-value (oneof normal nan))
+           (null-value (oneof normal 0.0))
+           ((boolean-value b boolean) (oneof normal (coerce-boolean-to-float64 b)))
+           ((number-value d float64) (oneof normal d))
+           (string-value (bottom))
+           (object-value (bottom))))
+       
+       (define (float64-to-uint32 (x float64)) integer
+         (if (or (float64-is-na-n x) (float64-is-infinite x))
+           0
+           (mod (truncate-float64 x) #x100000000)))
+       
+       (define (coerce-to-uint32 (v value)) integer-or-exception
+         (letexc (d float64 (coerce-to-float64 v))
+           (oneof normal (float64-to-uint32 d))))
+       
+       (define (coerce-to-int32 (v value)) integer-or-exception
+         (letexc (d float64 (coerce-to-float64 v))
+           (oneof normal (uint32-to-int32 (float64-to-uint32 d)))))
+       
+       (define (uint32-to-int32 (ui integer)) integer
+         (if (< ui #x80000000)
+           ui
+           (- ui #x100000000)))
+       
+       (define (coerce-to-string (v value)) string-or-exception
+         (case v
+           (undefined-value (oneof normal "undefined"))
+           (null-value (oneof normal "null"))
+           ((boolean-value b boolean) (if b (oneof normal "true") (oneof normal "false")))
+           (number-value (bottom))
+           ((string-value s string) (oneof normal s))
+           (object-value (bottom))))
+       
+       (define (coerce-to-primitive (v value) (hint default-value-hint)) value-or-exception
+         (case v
+           (((undefined-value null-value boolean-value number-value string-value)) (oneof normal v))
+           ((object-value o object)
+            (letexc (pv value ((& default-value o) hint))
+              (case pv
+                (((undefined-value null-value boolean-value number-value string-value)) (oneof normal pv))
+                (object-value (typed-oneof value-or-exception abrupt (make-error (oneof coerce-to-primitive-error)))))))))
+       
+       (define (coerce-to-object (v value)) object-or-exception
+         (case v
+           (((undefined-value null-value)) (typed-oneof object-or-exception abrupt (make-error (oneof coerce-to-object-error))))
+           (boolean-value (bottom))
+           (number-value (bottom))
+           (string-value (bottom))
+           ((object-value o object) (oneof normal o))))
+       
+       (%section "Environments")
+       
+       (deftype env (tuple (this object-or-null)))
+       (define (lookup-identifier (e env :unused) (id string :unused)) reference-or-exception
+         (bottom))
+       
+       (%section "Terminal Actions")
+       
+       (declare-action eval-identifier $identifier string)
+       (declare-action eval-number $number float64)
+       (declare-action eval-string $string string)
+       
+       (terminal-action eval-identifier $identifier cdr)
+       (terminal-action eval-number $number cdr)
+       (terminal-action eval-string $string cdr)
+       (%print-actions)
+       
+       (%section "Primary Expressions")
+       
+       (declare-action eval :primary-rvalue (-> (env) value-or-exception))
+       (production :primary-rvalue (this) primary-rvalue-this
+         ((eval (e env))
+          (oneof normal (object-or-null-to-value (& this e)))))
+       (production :primary-rvalue (null) primary-rvalue-null
+         ((eval (e env :unused))
+          null-result))
+       (production :primary-rvalue (true) primary-rvalue-true
+         ((eval (e env :unused))
+          (boolean-result true)))
+       (production :primary-rvalue (false) primary-rvalue-false
+         ((eval (e env :unused))
+          (boolean-result false)))
+       (production :primary-rvalue ($number) primary-rvalue-number
+         ((eval (e env :unused))
+          (float64-result (eval-number $number))))
+       (production :primary-rvalue ($string) primary-rvalue-string
+         ((eval (e env :unused))
+          (string-result (eval-string $string))))
+       (production :primary-rvalue (\( (:comma-expression no-l-value) \)) primary-rvalue-parentheses
+         (eval (eval :comma-expression)))
+       
+       (declare-action eval :primary-lvalue (-> (env) reference-or-exception))
+       (production :primary-lvalue ($identifier) primary-lvalue-identifier
+         ((eval (e env))
+          (lookup-identifier e (eval-identifier $identifier))))
+       (production :primary-lvalue (\( :lvalue \)) primary-lvalue-parentheses
+         (eval (eval :lvalue)))
+       (%print-actions)
+       
+       (%section "Left-Side Expressions")
+       
+       (grammar-argument :expr-kind any-value no-l-value)
+       (grammar-argument :member-expr-kind call no-call)
+       
+       (declare-action eval (:member-lvalue :member-expr-kind) (-> (env) reference-or-exception))
+       (production (:member-lvalue no-call) (:primary-lvalue) member-lvalue-primary-lvalue
+         (eval (eval :primary-lvalue)))
+       (production (:member-lvalue call) (:lvalue :arguments) member-lvalue-call-member-lvalue
+         ((eval (e env))
+          (letexc (f-reference reference ((eval :lvalue) e))
+            (letexc (f value (reference-get-value f-reference))
+              (letexc (arguments (vector value) ((eval :arguments) e))
+                (let ((this object-or-null
+                            (case f-reference
+                              (((value-reference virtual-reference)) (oneof null-object-or-null))
+                              ((place-reference p place) (oneof object-object-or-null (& base p))))))
+                  (call-object f this arguments)))))))
+       (production (:member-lvalue call) ((:member-expression no-call no-l-value) :arguments) member-lvalue-call-member-expression-no-call
+         ((eval (e env))
+          (letexc (f value ((eval :member-expression) e))
+            (letexc (arguments (vector value) ((eval :arguments) e))
+              (call-object f (oneof null-object-or-null) arguments)))))
+       (production (:member-lvalue :member-expr-kind) ((:member-expression :member-expr-kind any-value) \[ :expression \]) member-lvalue-array
+         ((eval (e env))
+          (letexc (container value ((eval :member-expression) e))
+            (letexc (property value ((eval :expression) e))
+              (read-property container property)))))
+       (production (:member-lvalue :member-expr-kind) ((:member-expression :member-expr-kind any-value) \. $identifier) member-lvalue-property
+         ((eval (e env))
+          (letexc (container value ((eval :member-expression) e))
+            (read-property container (oneof string-value (eval-identifier $identifier))))))
+       
+       (declare-action eval (:member-expression :member-expr-kind :expr-kind) (-> (env) value-or-exception))
+       (%rule (:member-expression no-call no-l-value))
+       (%rule (:member-expression no-call any-value))
+       (%rule (:member-expression call any-value))
+       (production (:member-expression no-call :expr-kind) (:primary-rvalue) member-expression-primary-rvalue
+         (eval (eval :primary-rvalue)))
+       (production (:member-expression :member-expr-kind any-value) ((:member-lvalue :member-expr-kind)) member-expression-member-lvalue
+         ((eval (e env))
+          (letexc (ref reference ((eval :member-lvalue) e))
+            (reference-get-value ref))))
+       (production (:member-expression no-call :expr-kind) (new (:member-expression no-call any-value) :arguments) member-expression-new
+         ((eval (e env))
+          (letexc (constructor value ((eval :member-expression) e))
+            (letexc (arguments (vector value) ((eval :arguments) e))
+              (construct-object constructor arguments)))))
+       
+       (declare-action eval (:new-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:new-expression :expr-kind) ((:member-expression no-call :expr-kind)) new-expression-member-expression
+         (eval (eval :member-expression)))
+       (production (:new-expression :expr-kind) (new (:new-expression any-value)) new-expression-new
+         ((eval (e env))
+          (letexc (constructor value ((eval :new-expression) e))
+            (construct-object constructor (vector-of value)))))
+       
+       (declare-action eval :arguments (-> (env) value-list-or-exception))
+       (production :arguments (\( \)) arguments-empty
+         ((eval (e env :unused))
+          (oneof normal (vector-of value))))
+       (production :arguments (\( :argument-list \)) arguments-list
+         (eval (eval :argument-list)))
+       
+       (declare-action eval :argument-list (-> (env) value-list-or-exception))
+       (production :argument-list ((:assignment-expression any-value)) argument-list-one
+         ((eval (e env))
+          (letexc (arg value ((eval :assignment-expression) e))
+            (oneof normal (vector arg)))))
+       (production :argument-list (:argument-list \, (:assignment-expression any-value)) argument-list-more
+         ((eval (e env))
+          (letexc (args (vector value) ((eval :argument-list) e))
+            (letexc (arg value ((eval :assignment-expression) e))
+              (oneof normal (append args (vector arg)))))))
+       
+       (declare-action eval :lvalue (-> (env) reference-or-exception))
+       (production :lvalue ((:member-lvalue call)) lvalue-member-lvalue-call
+         (eval (eval :member-lvalue)))
+       (production :lvalue ((:member-lvalue no-call)) lvalue-member-lvalue-no-call
+         (eval (eval :member-lvalue)))
+       (%print-actions)
+       
+       (define (read-property (container value) (property value)) reference-or-exception
+         (letexc (obj object (coerce-to-object container))
+           (letexc (name prop-name (coerce-to-string property))
+             (oneof normal (oneof place-reference (tuple place obj name))))))
+       
+       (define (call-object (f value) (this object-or-null) (arguments (vector value))) reference-or-exception
+         (case f
+           (((undefined-value null-value boolean-value number-value string-value))
+            (typed-oneof reference-or-exception abrupt (make-error (oneof coerce-to-object-error))))
+           ((object-value o object)
+            ((& call o) this arguments))))
+       
+       (define (construct-object (constructor value) (arguments (vector value))) value-or-exception
+         (case constructor
+           (((undefined-value null-value boolean-value number-value string-value))
+            (typed-oneof value-or-exception abrupt (make-error (oneof coerce-to-object-error))))
+           ((object-value o object)
+            (letexc (res object ((& construct o) arguments))
+              (object-result res)))))
+       
+       (%section "Postfix Expressions")
+       
+       (declare-action eval (:postfix-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:postfix-expression :expr-kind) ((:new-expression :expr-kind)) postfix-expression-new
+         (eval (eval :new-expression)))
+       (production (:postfix-expression any-value) ((:member-expression call any-value)) postfix-expression-member-expression-call
+         (eval (eval :member-expression)))
+       (production (:postfix-expression :expr-kind) (:lvalue ++) postfix-expression-increment
+         ((eval (e env))
+          (letexc (operand-reference reference ((eval :lvalue) e))
+            (letexc (operand-value value (reference-get-value operand-reference))
+              (letexc (operand float64 (coerce-to-float64 operand-value))
+                (letexc (u void (reference-put-value operand-reference (oneof number-value (float64-add operand 1.0)))
+                           :unused)
+                  (float64-result operand)))))))
+       (production (:postfix-expression :expr-kind) (:lvalue --) postfix-expression-decrement
+         ((eval (e env))
+          (letexc (operand-reference reference ((eval :lvalue) e))
+            (letexc (operand-value value (reference-get-value operand-reference))
+              (letexc (operand float64 (coerce-to-float64 operand-value))
+                (letexc (u void (reference-put-value operand-reference (oneof number-value (float64-subtract operand 1.0)))
+                           :unused)
+                  (float64-result operand)))))))
+       (%print-actions)
+       
+       (%section "Unary Operators")
+       
+       (declare-action eval (:unary-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:unary-expression :expr-kind) ((:postfix-expression :expr-kind)) unary-expression-postfix
+         (eval (eval :postfix-expression)))
+       (production (:unary-expression :expr-kind) (delete :lvalue) unary-expression-delete
+         ((eval (e env))
+          (letexc (rv reference ((eval :lvalue) e))
+            (case rv
+              (value-reference (typed-oneof value-or-exception abrupt (make-error (oneof delete-error))))
+              ((place-reference r place)
+               (letexc (b boolean ((& delete (& base r)) (& property r)))
+                 (boolean-result b)))
+              (virtual-reference (boolean-result true))))))
+       (production (:unary-expression :expr-kind) (void (:unary-expression any-value)) unary-expression-void
+         ((eval (e env))
+          (letexc (operand value ((eval :unary-expression) e) :unused)
+            undefined-result)))
+       (production (:unary-expression :expr-kind) (typeof :lvalue) unary-expression-typeof-lvalue
+         ((eval (e env))
+          (letexc (rv reference ((eval :lvalue) e))
+            (case rv
+              ((value-reference v value) (string-result (value-typeof v)))
+              ((place-reference r place)
+               (letexc (v value ((& get (& base r)) (& property r)))
+                 (string-result (value-typeof v))))
+              (virtual-reference (string-result "undefined"))))))
+       (production (:unary-expression :expr-kind) (typeof (:unary-expression no-l-value)) unary-expression-typeof-expression
+         ((eval (e env))
+          (letexc (v value ((eval :unary-expression) e))
+            (string-result (value-typeof v)))))
+       (production (:unary-expression :expr-kind) (++ :lvalue) unary-expression-increment
+         ((eval (e env))
+          (letexc (operand-reference reference ((eval :lvalue) e))
+            (letexc (operand-value value (reference-get-value operand-reference))
+              (letexc (operand float64 (coerce-to-float64 operand-value))
+                (let ((res float64 (float64-add operand 1.0)))
+                  (letexc (u void (reference-put-value operand-reference (oneof number-value res)) :unused)
+                    (float64-result res))))))))
+       (production (:unary-expression :expr-kind) (-- :lvalue) unary-expression-decrement
+         ((eval (e env))
+          (letexc (operand-reference reference ((eval :lvalue) e))
+            (letexc (operand-value value (reference-get-value operand-reference))
+              (letexc (operand float64 (coerce-to-float64 operand-value))
+                (let ((res float64 (float64-subtract operand 1.0)))
+                  (letexc (u void (reference-put-value operand-reference (oneof number-value res)) :unused)
+                    (float64-result res))))))))
+       (production (:unary-expression :expr-kind) (+ (:unary-expression any-value)) unary-expression-plus
+         ((eval (e env))
+          (letexc (operand-value value ((eval :unary-expression) e))
+            (letexc (operand float64 (coerce-to-float64 operand-value))
+              (float64-result operand)))))
+       (production (:unary-expression :expr-kind) (- (:unary-expression any-value)) unary-expression-minus
+         ((eval (e env))
+          (letexc (operand-value value ((eval :unary-expression) e))
+            (letexc (operand float64 (coerce-to-float64 operand-value))
+              (float64-result (float64-negate operand))))))
+       (production (:unary-expression :expr-kind) (~ (:unary-expression any-value)) unary-expression-bitwise-not
+         ((eval (e env))
+          (letexc (operand-value value ((eval :unary-expression) e))
+            (letexc (operand integer (coerce-to-int32 operand-value))
+              (integer-result (bitwise-xor operand -1))))))
+       (production (:unary-expression :expr-kind) (! (:unary-expression any-value)) unary-expression-logical-not
+         ((eval (e env))
+          (letexc (operand-value value ((eval :unary-expression) e))
+            (boolean-result (not (coerce-to-boolean operand-value))))))
+       (%print-actions)
+       
+       (define (value-typeof (v value)) string
+         (case v
+           (undefined-value "undefined")
+           (null-value "object")
+           (boolean-value "boolean")
+           (number-value "number")
+           (string-value "string")
+           ((object-value o object) (& typeof-name o))))
+       
+       (%section "Multiplicative Operators")
+       
+       (declare-action eval (:multiplicative-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:multiplicative-expression :expr-kind) ((:unary-expression :expr-kind)) multiplicative-expression-unary
+         (eval (eval :unary-expression)))
+       (production (:multiplicative-expression :expr-kind) ((:multiplicative-expression any-value) * (:unary-expression any-value)) multiplicative-expression-multiply
+         ((eval (e env))
+          (letexc (left-value value ((eval :multiplicative-expression) e))
+            (letexc (right-value value ((eval :unary-expression) e))
+              (apply-binary-float64-operator float64-multiply left-value right-value)))))
+       (production (:multiplicative-expression :expr-kind) ((:multiplicative-expression any-value) / (:unary-expression any-value)) multiplicative-expression-divide
+         ((eval (e env))
+          (letexc (left-value value ((eval :multiplicative-expression) e))
+            (letexc (right-value value ((eval :unary-expression) e))
+              (apply-binary-float64-operator float64-divide left-value right-value)))))
+       (production (:multiplicative-expression :expr-kind) ((:multiplicative-expression any-value) % (:unary-expression any-value)) multiplicative-expression-remainder
+         ((eval (e env))
+          (letexc (left-value value ((eval :multiplicative-expression) e))
+            (letexc (right-value value ((eval :unary-expression) e))
+              (apply-binary-float64-operator float64-remainder left-value right-value)))))
+       (%print-actions)
+       
+       (define (apply-binary-float64-operator (operator (-> (float64 float64) float64)) (left-value value) (right-value value)) value-or-exception
+         (letexc (left-number float64 (coerce-to-float64 left-value))
+           (letexc (right-number float64 (coerce-to-float64 right-value))
+             (float64-result (operator left-number right-number)))))
+       
+       (%section "Additive Operators")
+       
+       (declare-action eval (:additive-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:additive-expression :expr-kind) ((:multiplicative-expression :expr-kind)) additive-expression-multiplicative
+         (eval (eval :multiplicative-expression)))
+       (production (:additive-expression :expr-kind) ((:additive-expression any-value) + (:multiplicative-expression any-value)) additive-expression-add
+         ((eval (e env))
+          (letexc (left-value value ((eval :additive-expression) e))
+            (letexc (right-value value ((eval :multiplicative-expression) e))
+              (letexc (left-primitive value (coerce-to-primitive left-value (oneof no-hint)))
+                (letexc (right-primitive value (coerce-to-primitive right-value (oneof no-hint)))
+                  (if (or (is string-value left-primitive) (is string-value right-primitive))
+                    (letexc (left-string string (coerce-to-string left-primitive))
+                      (letexc (right-string string (coerce-to-string right-primitive))
+                        (string-result (append left-string right-string))))
+                    (apply-binary-float64-operator float64-add left-primitive right-primitive))))))))
+       (production (:additive-expression :expr-kind) ((:additive-expression any-value) - (:multiplicative-expression any-value)) additive-expression-subtract
+         ((eval (e env))
+          (letexc (left-value value ((eval :additive-expression) e))
+            (letexc (right-value value ((eval :multiplicative-expression) e))
+              (apply-binary-float64-operator float64-subtract left-value right-value)))))
+       (%print-actions)
+       
+       (%section "Bitwise Shift Operators")
+       
+       (declare-action eval (:shift-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:shift-expression :expr-kind) ((:additive-expression :expr-kind)) shift-expression-additive
+         (eval (eval :additive-expression)))
+       (production (:shift-expression :expr-kind) ((:shift-expression any-value) << (:additive-expression any-value)) shift-expression-left
+         ((eval (e env))
+          (letexc (bitmap-value value ((eval :shift-expression) e))
+            (letexc (count-value value ((eval :additive-expression) e))
+              (letexc (bitmap integer (coerce-to-uint32 bitmap-value))
+                (letexc (count integer (coerce-to-uint32 count-value))
+                  (integer-result (uint32-to-int32 (bitwise-and (bitwise-shift bitmap (bitwise-and count #x1F))
+                                                                #xFFFFFFFF)))))))))
+       (production (:shift-expression :expr-kind) ((:shift-expression any-value) >> (:additive-expression any-value)) shift-expression-right-signed
+         ((eval (e env))
+          (letexc (bitmap-value value ((eval :shift-expression) e))
+            (letexc (count-value value ((eval :additive-expression) e))
+              (letexc (bitmap integer (coerce-to-int32 bitmap-value))
+                (letexc (count integer (coerce-to-uint32 count-value))
+                  (integer-result (bitwise-shift bitmap (neg (bitwise-and count #x1F))))))))))
+       (production (:shift-expression :expr-kind) ((:shift-expression any-value) >>> (:additive-expression any-value)) shift-expression-right-unsigned
+         ((eval (e env))
+          (letexc (bitmap-value value ((eval :shift-expression) e))
+            (letexc (count-value value ((eval :additive-expression) e))
+              (letexc (bitmap integer (coerce-to-uint32 bitmap-value))
+                (letexc (count integer (coerce-to-uint32 count-value))
+                  (integer-result (bitwise-shift bitmap (neg (bitwise-and count #x1F))))))))))
+       (%print-actions)
+       
+       (%section "Relational Operators")
+       
+       (declare-action eval (:relational-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:relational-expression :expr-kind) ((:shift-expression :expr-kind)) relational-expression-shift
+         (eval (eval :shift-expression)))
+       (production (:relational-expression :expr-kind) ((:relational-expression any-value) < (:shift-expression any-value)) relational-expression-less
+         ((eval (e env))
+          (letexc (left-value value ((eval :relational-expression) e))
+            (letexc (right-value value ((eval :shift-expression) e))
+              (order-values left-value right-value true false)))))
+       (production (:relational-expression :expr-kind) ((:relational-expression any-value) > (:shift-expression any-value)) relational-expression-greater
+         ((eval (e env))
+          (letexc (left-value value ((eval :relational-expression) e))
+            (letexc (right-value value ((eval :shift-expression) e))
+              (order-values right-value left-value true false)))))
+       (production (:relational-expression :expr-kind) ((:relational-expression any-value) <= (:shift-expression any-value)) relational-expression-less-or-equal
+         ((eval (e env))
+          (letexc (left-value value ((eval :relational-expression) e))
+            (letexc (right-value value ((eval :shift-expression) e))
+              (order-values right-value left-value false true)))))
+       (production (:relational-expression :expr-kind) ((:relational-expression any-value) >= (:shift-expression any-value)) relational-expression-greater-or-equal
+         ((eval (e env))
+          (letexc (left-value value ((eval :relational-expression) e))
+            (letexc (right-value value ((eval :shift-expression) e))
+              (order-values left-value right-value false true)))))
+       (%print-actions)
+       
+       (define (order-values (left-value value) (right-value value) (less boolean) (greater-or-equal boolean)) value-or-exception
+         (letexc (left-primitive value (coerce-to-primitive left-value (oneof number-hint)))
+           (letexc (right-primitive value (coerce-to-primitive right-value (oneof number-hint)))
+             (if (and (is string-value left-primitive) (is string-value right-primitive))
+               (boolean-result
+                (compare-strings (select string-value left-primitive) (select string-value right-primitive) less greater-or-equal greater-or-equal))
+               (letexc (left-number float64 (coerce-to-float64 left-primitive))
+                 (letexc (right-number float64 (coerce-to-float64 right-primitive))
+                   (boolean-result (float64-compare left-number right-number less greater-or-equal greater-or-equal false))))))))
+       
+       (define (compare-strings (left string) (right string) (less boolean) (equal boolean) (greater boolean)) boolean
+         (if (and (empty left) (empty right))
+           equal
+           (if (empty left)
+             less
+             (if (empty right)
+               greater
+               (let ((left-char-code integer (character-to-code (nth left 0)))
+                     (right-char-code integer (character-to-code (nth right 0))))
+                 (if (< left-char-code right-char-code)
+                   less
+                   (if (> left-char-code right-char-code)
+                     greater
+                     (compare-strings (subseq left 1) (subseq right 1) less equal greater))))))))
+       
+       (%section "Equality Operators")
+       
+       (declare-action eval (:equality-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:equality-expression :expr-kind) ((:relational-expression :expr-kind)) equality-expression-relational
+         (eval (eval :relational-expression)))
+       (production (:equality-expression :expr-kind) ((:equality-expression any-value) == (:relational-expression any-value)) equality-expression-equal
+         ((eval (e env))
+          (letexc (left-value value ((eval :equality-expression) e))
+            (letexc (right-value value ((eval :relational-expression) e))
+              (letexc (eq boolean (compare-values left-value right-value))
+                (boolean-result eq))))))
+       (production (:equality-expression :expr-kind) ((:equality-expression any-value) != (:relational-expression any-value)) equality-expression-not-equal
+         ((eval (e env))
+          (letexc (left-value value ((eval :equality-expression) e))
+            (letexc (right-value value ((eval :relational-expression) e))
+              (letexc (eq boolean (compare-values left-value right-value))
+                (boolean-result (not eq)))))))
+       (production (:equality-expression :expr-kind) ((:equality-expression any-value) === (:relational-expression any-value)) equality-expression-strict-equal
+         ((eval (e env))
+          (letexc (left-value value ((eval :equality-expression) e))
+            (letexc (right-value value ((eval :relational-expression) e))
+              (boolean-result (strict-compare-values left-value right-value))))))
+       (production (:equality-expression :expr-kind) ((:equality-expression any-value) !== (:relational-expression any-value)) equality-expression-strict-not-equal
+         ((eval (e env))
+          (letexc (left-value value ((eval :equality-expression) e))
+            (letexc (right-value value ((eval :relational-expression) e))
+              (boolean-result (not (strict-compare-values left-value right-value)))))))
+       (%print-actions)
+       
+       (define (compare-values (left-value value) (right-value value)) boolean-or-exception
+         (case left-value
+           (((undefined-value null-value))
+            (case right-value
+              (((undefined-value null-value)) (oneof normal true))
+              (((boolean-value number-value string-value object-value)) (oneof normal false))))
+           ((boolean-value left-bool boolean)
+            (case right-value
+              (((undefined-value null-value)) (oneof normal false))
+              ((boolean-value right-bool boolean) (oneof normal (not (xor left-bool right-bool))))
+              (((number-value string-value object-value))
+               (compare-float64-to-value (coerce-boolean-to-float64 left-bool) right-value))))
+           ((number-value left-number float64)
+            (compare-float64-to-value left-number right-value))
+           ((string-value left-str string)
+            (case right-value
+              (((undefined-value null-value)) (oneof normal false))
+              ((boolean-value right-bool boolean)
+               (letexc (left-number float64 (coerce-to-float64 left-value))
+                 (oneof normal (float64-equal left-number (coerce-boolean-to-float64 right-bool)))))
+              ((number-value right-number float64)
+               (letexc (left-number float64 (coerce-to-float64 left-value))
+                 (oneof normal (float64-equal left-number right-number))))
+              ((string-value right-str string)
+               (oneof normal (compare-strings left-str right-str false true false)))
+              (object-value
+               (letexc (right-primitive value (coerce-to-primitive right-value (oneof no-hint)))
+                 (compare-values left-value right-primitive)))))
+           ((object-value left-obj object)
+            (case right-value
+              (((undefined-value null-value)) (oneof normal false))
+              ((boolean-value right-bool boolean)
+               (letexc (left-primitive value (coerce-to-primitive left-value (oneof no-hint)))
+                 (compare-values left-primitive (oneof number-value (coerce-boolean-to-float64 right-bool)))))
+              (((number-value string-value))
+               (letexc (left-primitive value (coerce-to-primitive left-value (oneof no-hint)))
+                 (compare-values left-primitive right-value)))
+              ((object-value right-obj object)
+               (oneof normal (address-equal (& properties left-obj) (& properties right-obj))))))))
+       
+       (define (compare-float64-to-value (left-number float64) (right-value value)) boolean-or-exception
+         (case right-value
+           (((undefined-value null-value)) (oneof normal false))
+           (((boolean-value number-value string-value))
+            (letexc (right-number float64 (coerce-to-float64 right-value))
+              (oneof normal (float64-equal left-number right-number))))
+           (object-value
+            (letexc (right-primitive value (coerce-to-primitive right-value (oneof no-hint)))
+              (compare-float64-to-value left-number right-primitive)))))
+       
+       (define (float64-equal (x float64) (y float64)) boolean
+         (float64-compare x y false true false false))
+       
+       (define (strict-compare-values (left-value value) (right-value value)) boolean
+         (case left-value
+           (undefined-value
+            (is undefined-value right-value))
+           (null-value
+            (is null-value right-value))
+           ((boolean-value left-bool boolean)
+            (case right-value
+              ((boolean-value right-bool boolean) (not (xor left-bool right-bool)))
+              (((undefined-value null-value number-value string-value object-value)) false)))
+           ((number-value left-number float64)
+            (case right-value
+              ((number-value right-number float64) (float64-equal left-number right-number))
+              (((undefined-value null-value boolean-value string-value object-value)) false)))
+           ((string-value left-str string)
+            (case right-value
+              ((string-value right-str string)
+               (compare-strings left-str right-str false true false))
+              (((undefined-value null-value boolean-value number-value object-value)) false)))
+           ((object-value left-obj object)
+            (case right-value
+              ((object-value right-obj object)
+               (address-equal (& properties left-obj) (& properties right-obj)))
+              (((undefined-value null-value boolean-value number-value string-value)) false)))))
+       
+       (%section "Binary Bitwise Operators")
+       
+       (declare-action eval (:bitwise-and-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:bitwise-and-expression :expr-kind) ((:equality-expression :expr-kind)) bitwise-and-expression-equality
+         (eval (eval :equality-expression)))
+       (production (:bitwise-and-expression :expr-kind) ((:bitwise-and-expression any-value) & (:equality-expression any-value)) bitwise-and-expression-and
+         ((eval (e env))
+          (letexc (left-value value ((eval :bitwise-and-expression) e))
+            (letexc (right-value value ((eval :equality-expression) e))
+              (apply-binary-bitwise-operator bitwise-and left-value right-value)))))
+       
+       (declare-action eval (:bitwise-xor-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:bitwise-xor-expression :expr-kind) ((:bitwise-and-expression :expr-kind)) bitwise-xor-expression-bitwise-and
+         (eval (eval :bitwise-and-expression)))
+       (production (:bitwise-xor-expression :expr-kind) ((:bitwise-xor-expression any-value) ^ (:bitwise-and-expression any-value)) bitwise-xor-expression-xor
+         ((eval (e env))
+          (letexc (left-value value ((eval :bitwise-xor-expression) e))
+            (letexc (right-value value ((eval :bitwise-and-expression) e))
+              (apply-binary-bitwise-operator bitwise-xor left-value right-value)))))
+       
+       (declare-action eval (:bitwise-or-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:bitwise-or-expression :expr-kind) ((:bitwise-xor-expression :expr-kind)) bitwise-or-expression-bitwise-xor
+         (eval (eval :bitwise-xor-expression)))
+       (production (:bitwise-or-expression :expr-kind) ((:bitwise-or-expression any-value) \| (:bitwise-xor-expression any-value)) bitwise-or-expression-or
+         ((eval (e env))
+          (letexc (left-value value ((eval :bitwise-or-expression) e))
+            (letexc (right-value value ((eval :bitwise-xor-expression) e))
+              (apply-binary-bitwise-operator bitwise-or left-value right-value)))))
+       (%print-actions)
+       
+       (define (apply-binary-bitwise-operator (operator (-> (integer integer) integer)) (left-value value) (right-value value)) value-or-exception
+         (letexc (left-int integer (coerce-to-int32 left-value))
+           (letexc (right-int integer (coerce-to-int32 right-value))
+             (integer-result (operator left-int right-int)))))
+       
+       (%section "Binary Logical Operators")
+       
+       (declare-action eval (:logical-and-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:logical-and-expression :expr-kind) ((:bitwise-or-expression :expr-kind)) logical-and-expression-bitwise-or
+         (eval (eval :bitwise-or-expression)))
+       (production (:logical-and-expression :expr-kind) ((:logical-and-expression any-value) && (:bitwise-or-expression any-value)) logical-and-expression-and
+         ((eval (e env))
+          (letexc (left-value value ((eval :logical-and-expression) e))
+            (if (coerce-to-boolean left-value)
+              ((eval :bitwise-or-expression) e)
+              (oneof normal left-value)))))
+       
+       (declare-action eval (:logical-or-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:logical-or-expression :expr-kind) ((:logical-and-expression :expr-kind)) logical-or-expression-logical-and
+         (eval (eval :logical-and-expression)))
+       (production (:logical-or-expression :expr-kind) ((:logical-or-expression any-value) \|\| (:logical-and-expression any-value)) logical-or-expression-or
+         ((eval (e env))
+          (letexc (left-value value ((eval :logical-or-expression) e))
+            (if (coerce-to-boolean left-value)
+              (oneof normal left-value)
+              ((eval :logical-and-expression) e)))))
+       (%print-actions)
+       
+       (%section "Conditional Operator")
+       
+       (declare-action eval (:conditional-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:conditional-expression :expr-kind) ((:logical-or-expression :expr-kind)) conditional-expression-logical-or
+         (eval (eval :logical-or-expression)))
+       (production (:conditional-expression :expr-kind) ((:logical-or-expression any-value) ? (:assignment-expression any-value) \: (:assignment-expression any-value)) conditional-expression-conditional
+         ((eval (e env))
+          (letexc (condition value ((eval :logical-or-expression) e))
+            (if (coerce-to-boolean condition)
+              ((eval :assignment-expression 1) e)
+              ((eval :assignment-expression 2) e)))))
+       (%print-actions)
+       
+       (%section "Assignment Operators")
+       
+       (declare-action eval (:assignment-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:assignment-expression :expr-kind) ((:conditional-expression :expr-kind)) assignment-expression-conditional
+         (eval (eval :conditional-expression)))
+       (production (:assignment-expression :expr-kind) (:lvalue = (:assignment-expression any-value)) assignment-expression-assignment
+         ((eval (e env))
+          (letexc (left-reference reference ((eval :lvalue) e))
+            (letexc (right-value value ((eval :assignment-expression) e))
+              (letexc (u void (reference-put-value left-reference right-value) :unused)
+                (oneof normal right-value))))))
+       #|
+       (production (:assignment-expression :expr-kind) (:lvalue :compound-assignment (:assignment-expression any-value)) assignment-expression-compound-assignment
+         ((eval (e env))
+          (letexc (left-reference reference ((eval :lvalue) e))
+            (letexc (left-value value (reference-get-value left-reference))
+              (letexc (right-value value ((eval :assignment-expression) e))
+                (letexc (res-value ((compound-operator :compound-assignment) left-value right-value))
+                  (letexc (u void (reference-put-value left-reference res-value) :unused)
+                    (oneof normal res-value))))))))
+       
+       (declare-action compound-operator :compound-assignment (-> (value value) value-or-exception))
+       (production :compound-assignment (*=) compound-assignment-multiply
+         (compound-operator (binary-float64-compound-operator float64-multiply)))
+       (production :compound-assignment (/=) compound-assignment-divide
+         (compound-operator (binary-float64-compound-operator float64-divide)))
+       (production :compound-assignment (%=) compound-assignment-remainder
+         (compound-operator (binary-float64-compound-operator float64-remainder)))
+       (production :compound-assignment (+=) compound-assignment-add
+         (compound-operator (binary-float64-compound-operator float64-remainder)))
+       (production :compound-assignment (-=) compound-assignment-subtract
+         (compound-operator (binary-float64-compound-operator float64-subtract)))
+       (%print-actions)
+       
+       (define (binary-float64-compound-operator (operator (-> (float64 float64) float64))) (-> (value value) value-or-exception)
+         (function ((left-value value) (right-value value))
+           (letexc (left-number float64 (coerce-to-float64 left-value))
+             (letexc (right-number float64 (coerce-to-float64 right-value))
+               (oneof normal (oneof number-value (operator left-number right-number)))))))
+       |#
+       (%section "Expressions")
+       
+       (declare-action eval (:comma-expression :expr-kind) (-> (env) value-or-exception))
+       (production (:comma-expression :expr-kind) ((:assignment-expression :expr-kind)) comma-expression-assignment
+         (eval (eval :assignment-expression)))
+       (%print-actions)
+       
+       (declare-action eval :expression (-> (env) value-or-exception))
+       (production :expression ((:comma-expression any-value)) expression-comma-expression
+         (eval (eval :comma-expression)))
+       (%print-actions)
+       
+       (%section "Programs")
+       
+       (declare-action eval :program value-or-exception)
+       (production :program (:expression $end) program
+         (eval ((eval :expression) (tuple env (oneof null-object-or-null)))))
+       )))
+  
+  (defparameter *gg* (world-grammar *gw* 'code-grammar)))
+
+
+(defun token-terminal (token)
+  (if (symbolp token)
+    token
+    (car token)))
+
+(defun ecma-parse-tokens (tokens &key trace)
+  (action-parse *gg* #'token-terminal tokens :trace trace))
+
+
+(defun ecma-parse (string &key trace)
+  (let ((tokens (tokenize string)))
+    (when trace
+      (format *trace-output* "~S~%" tokens))
+    (action-parse *gg* #'token-terminal tokens :trace trace)))
+
+
+; Same as ecma-parse except that also print the action results nicely.
+(defun ecma-pparse (string &key (stream t) trace)
+  (multiple-value-bind (results types) (ecma-parse string :trace trace)
+    (print-values results types stream)
+    (terpri stream)
+    (values results types)))
+
+
+#|
+(depict-rtf-to-local-file
+ "JSECMA/ParserSemantics.rtf"
+ "ECMAScript 1 Parser Semantics"
+ #'(lambda (rtf-stream)
+     (depict-world-commands rtf-stream *gw*)))
+
+(depict-html-to-local-file
+ "JSECMA/ParserSemantics.html"
+ "ECMAScript 1 Parser Semantics"
+ t
+ #'(lambda (rtf-stream)
+     (depict-world-commands rtf-stream *gw*)))
+
+(with-local-output (s "JSECMA/ParserGrammar.txt") (print-grammar *gg* s))
+
+
+(ecma-pparse "('abc')")
+(ecma-pparse "!~ 352")
+(ecma-pparse "1e308%.125")
+(ecma-pparse "-3>>>10-6")
+(ecma-pparse "-3>>0")
+(ecma-pparse "1+2*3|16")
+(ecma-pparse "1==true")
+(ecma-pparse "1=true")
+(ecma-pparse "x=true")
+(ecma-pparse "2*4+17+0x32")
+(ecma-pparse "+'ab'+'de'")
+|#

mozilla/js2/semantics/Lexer.lisp

@@ -0,0 +1,779 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Lexer grammar generator
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+;;; A lexer grammar is an extension of a standard grammar that combines both parsing and combining
+;;; characters into character classes.
+;;;
+;;; A lexer grammar is comprised of the following:
+;;;   a start nonterminal;
+;;;   a list of grammar productions, in which each terminal must be a character;
+;;;   a list of character classes, where each class is a list of:
+;;;     a nonterminal C;
+;;;     an expression <set-expr> that denotes the set of characters in character class C;
+;;;     a list of bindings, each containing:
+;;;       an action name;
+;;;       a lexer-action name;
+;;;   a list of lexer-action bindings, each containing:
+;;;     a lexer-action name;
+;;;     the type of this lexer-action's value;
+;;;     the name of a lisp function (char -> value) that performs the lexer-action on a character.
+;;;
+;;; Grammar productions may refer to character classes C as nonterminals.
+;;;
+;;; An expression <set-expr> can be any of the following:
+;;;   C                                   The name of a previously defined character class.
+;;;   (char1 char2 ... charn)             The set of characters {char1, char2, ..., charn}
+;;;   (+ <set-expr1> ... <set-exprn>)     The set union of <set-expr1>, ..., <set-exprn>,
+;;;                                       which should be disjoint.
+;;;   (++ <set-expr1> ... <set-exprn>)    Same as +, but printed on separate lines.
+;;;   (- <set-expr1> <set-expr2>)         The set of characters in <set-expr1> but not <set-expr2>;
+;;;                                       <set-expr2> should be a subset of <set-expr1>.
+;;;   (% <builtin-class> . <description>) A predefined set of characters.  <description> is suitable for
+;;;                                       depicting.
+;;;
+;;; <builtin-class> can be one of the following:
+;;;   every                    The set of all characters
+;;;   initial-alpha            The set of characters suitable for the beginning of a Unicode identifier
+;;;   alphanumeric             The set of Unicode identifier continuation characters
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; SETS OF CHARACTERS
+
+;;; A character set is represented by an integer.
+;;; The set may be infinite as long as its complement is finite.
+;;; Bit n is set if the character with code n is a member of the set.
+;;; The integer is negative if the set is infinite.
+
+
+; Print the charset
+(defun print-charset (charset &optional (stream t))
+  (pprint-logical-block (stream (bitmap-to-ranges charset) :prefix "{" :suffix "}")
+    (pprint-exit-if-list-exhausted)
+    (loop
+      (flet
+        ((int-to-char (i)
+           (if (or (eq i :infinity) (= i char-code-limit))
+             :infinity
+             (code-char i))))
+        (let* ((range (pprint-pop))
+               (lo (int-to-char (car range)))
+               (hi (int-to-char (cdr range))))
+          (write (if (eql lo hi) lo (list lo hi)) :stream stream :pretty t)
+          (pprint-exit-if-list-exhausted)
+          (format stream " ~:_"))))))
+
+
+(defconstant *empty-charset* 0)
+
+
+; Return the character set consisting of the single character char.
+(declaim (inline char-charset))
+(defun char-charset (char)
+  (ash 1 (char-code char)))
+
+
+; Return the character set consisting of adding char to the given charset.
+(defun charset-add-char (charset char)
+  (let ((i (char-code char)))
+    (if (logbitp i charset)
+      charset
+      (logior charset (ash 1 i)))))
+
+
+; Return the character set consisting of adding the character range to the given charset.
+(defun charset-add-range (charset low-char high-char)
+  (let ((low (char-code low-char))
+        (high (char-code high-char)))
+    (assert-true (>= high low))
+    (dpb -1 (byte (1+ (- high low)) low) charset)))
+
+
+; Return the union of the two character sets, which should be disjoint.
+(defun charset-union (charset1 charset2)
+  (unless (zerop (logand charset1 charset2))
+    (error "Union of overlapping character sets"))
+  (logior charset1 charset2))
+
+
+; Return the difference of the two character sets, the second of which should be
+; a subset of the first.
+(defun charset-difference (charset1 charset2)
+  (unless (zerop (logandc1 charset1 charset2))
+    (error "Difference of non-subset character sets"))
+  (logandc2 charset1 charset2))
+
+
+; Return true if the character set is empty.
+(declaim (inline charset-empty?))
+(defun charset-empty? (charset)
+  (zerop charset))
+
+
+; Return true if the character set is infinite.
+(declaim (inline charset-infinite?))
+(defun charset-infinite? (charset)
+  (minusp charset))
+
+
+; Return true if the character set contains the given character.
+(declaim (inline char-in-charset?))
+(defun char-in-charset? (charset char)
+  (logbitp (char-code char) charset))
+
+
+; If the character set contains exactly one character, return that character;
+; otherwise, return nil.
+(defun charset-char (charset)
+  (let ((hi (1- (integer-length charset))))
+    (and (plusp charset) (= charset (ash 1 hi)) (code-char hi))))
+
+
+; Return the highest character in the character set, which must be finite and nonempty.
+(declaim (inline charset-highest-char))
+(defun charset-highest-char (charset)
+  (assert-true (plusp charset))
+  (code-char (1- (integer-length charset))))
+
+
+; Given a list of charsets, return a list of the largest possible
+; charsets (called partitions) such that:
+;   for any input charset C and partition P, either P is entirely contained in C or it is disjoint from C;
+;   all partitions are mutually disjoint;
+;   the union of all partitions is the infinite set of all characters.
+(defun compute-partitions (charsets)
+  (labels
+    ((split-partitions (partitions charset)
+       (mapcan #'(lambda (partition)
+                   (remove-if #'zerop (list (logand partition charset) (logandc2 partition charset))))
+               partitions))
+     (partition< (partition1 partition2)
+       (cond
+        ((minusp partition1) nil)
+        ((minusp partition2) t)
+        (t (< partition1 partition2)))))
+    (sort (reduce #'split-partitions charsets :initial-value '(-1))
+          #'partition<)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; PREDEFINED SETS OF CHARACTERS
+
+(defmacro predefined-character-set (symbol)
+  `(get ,symbol 'predefined-character-set))
+
+
+; Predefine a character set with the given name.  The set is specified by char-ranges, which is a
+; list of single characters or two-elements (low-char high-char) lists; both low-char and high-char
+; are inclusive.
+
+(defun define-character-set (symbol char-ranges)
+  (let ((charset *empty-charset*))
+    (dolist (char-range char-ranges)
+      (setq charset 
+            (if (characterp char-range)
+              (charset-add-char charset char-range)
+              (charset-add-range charset (first char-range) (second char-range)))))
+    (setf (predefined-character-set symbol) charset)))
+
+
+(setf (predefined-character-set 'every) -1)
+(define-character-set 'initial-alpha '((#\A #\Z) (#\a #\z)))
+(define-character-set 'alphanumeric '((#\0 #\9) (#\A #\Z) (#\a #\z)))
+
+(define-character-set '*initial-identifier-character* '(#\$ #\_ (#\A #\Z) (#\a #\z)))
+(define-character-set '*continuing-identifier-character* '(#\$ #\_ (#\0 #\9) (#\A #\Z) (#\a #\z)))
+
+(defun initial-identifier-character? (char)
+  (char-in-charset? (predefined-character-set '*initial-identifier-character*) char))
+
+(defun continuing-identifier-character? (char)
+  (char-in-charset? (predefined-character-set '*continuing-identifier-character*) char))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; LEXER-ACTIONS
+
+(defstruct (lexer-action (:constructor make-lexer-action (name number type-expr function-name function))
+                         (:copier nil)
+                         (:predicate lexer-action?))
+  (name nil :type identifier :read-only t)             ;The action name to use for this lexer-action
+  (number nil :type integer :read-only t)              ;Serial number of this lexer-action
+  (type-expr nil :read-only t)                         ;A type expression that specifies the result type of function
+  (function-name nil :type (or null identifier) :read-only t) ;Name of external function to use when depicting this lexer-action
+  (function nil :type identifier :read-only t))        ;A lisp function (char -> value) that performs the lexer-action on a character
+
+
+(defun print-lexer-action (lexer-action &optional (stream t))
+  (format stream "~@<~A ~@_~:I: ~<<<~;~W~;>>~:> ~_= ~<<~;#'~W~;>~:>~:>"
+          (lexer-action-name lexer-action)
+          (list (lexer-action-type-expr lexer-action))
+          (list (lexer-action-function lexer-action))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; CHARCLASSES
+
+(defstruct (charclass (:constructor make-charclass (nonterminal charset-source charset actions hidden))
+                      (:predicate charclass?))
+  (nonterminal nil :type nonterminal :read-only t)    ;The nonterminal on the left-hand side of this production
+  (charset-source nil :read-only t)                   ;The source expression for the charset
+  (charset nil :type integer :read-only t)            ;The set of characters in this class
+  (actions nil :type list :read-only t)               ;List of (action-name . lexer-action)
+  (hidden nil :type bool :read-only t))               ;True if this charclass should not be in the grammar
+
+
+; Return a copy of the charset expr with all parametrized nonterminals interned.
+(defun intern-charset-expr (parametrization expr)
+  (cond
+   ((or (not (consp expr)) (eq (first expr) '%)) expr)
+   ((keywordp (first expr)) (assert-type (grammar-parametrization-intern parametrization expr) nonterminal))
+   (t (mapcar #'(lambda (subexpr)
+                  (intern-charset-expr parametrization subexpr))
+              expr))))
+
+
+; Evaluate a <set-expr> whose syntax is given at the top of this file.
+; Return the charset.
+; charclasses-hash is a hash table of nonterminal -> charclass.
+(defun eval-charset-expr (charclasses-hash expr)
+  (cond
+   ((null expr) 0)
+   ((nonterminal? expr)
+    (charclass-charset
+     (or (gethash expr charclasses-hash)
+         (error "Character class ~S not defined" expr))))
+   ((consp expr)
+    (labels
+      ((recursive-eval (expr)
+         (eval-charset-expr charclasses-hash expr)))
+      (case (first expr)
+        ((+ ++) (reduce #'charset-union (rest expr) :initial-value 0 :key #'recursive-eval))
+        (- (unless (rest expr)
+             (error "Bad character set expression ~S" expr))
+           (reduce #'charset-difference (rest expr) :key #'recursive-eval))
+        (% (assert-non-null (predefined-character-set (second expr))))
+        (t (reduce #'charset-union expr :key #'char-charset)))))
+   (t (error "Bad character set expression ~S" expr))))
+
+
+(defun print-charclass (charclass &optional (stream t))
+  (pprint-logical-block (stream nil)
+    (format stream "~W -> ~@_~:I" (charclass-nonterminal charclass))
+    (print-charset (charclass-charset charclass) stream)
+    (format stream " ~_")
+    (pprint-fill stream (mapcar #'car (charclass-actions charclass)))
+    (when (charclass-hidden charclass)
+      (format stream " ~_hidden"))))
+
+
+; Emit markup for the lexer charset expression.
+(defun depict-charset-source (markup-stream expr)
+  (cond
+   ((null expr) (error "Can't emit null charset expression"))
+   ((nonterminal? expr) (depict-general-nonterminal markup-stream expr :reference))
+   ((consp expr)
+    (case (first expr)
+      ((+ ++) (depict-list markup-stream #'depict-charset-source (rest expr) :separator " | "))
+      (- (depict-charset-source markup-stream (second expr))
+         (depict markup-stream " " :but-not " ")
+         (depict-list markup-stream #'depict-charset-source (cddr expr) :separator " | "))
+      (% (depict-styled-text markup-stream (cddr expr)))
+      (t (depict-list markup-stream #'depict-terminal expr :separator " | "))))
+   (t (error "Bad character set expression ~S" expr))))
+
+
+; Emit markup paragraphs for the lexer charclass.
+(defun depict-charclass (markup-stream charclass)
+  (depict-block-style (markup-stream ':grammar-rule)
+    (let ((nonterminal (charclass-nonterminal charclass))
+          (expr (charclass-charset-source charclass)))
+      (if (and (consp expr) (eq (first expr) '++))
+        (let* ((subexprs (rest expr))
+               (length (length subexprs)))
+          (depict-paragraph (markup-stream ':grammar-lhs)
+            (depict-general-nonterminal markup-stream nonterminal :definition)
+            (depict markup-stream " " ':derives-10))
+          (dotimes (i length)
+            (depict-paragraph (markup-stream (if (= i (1- length)) ':grammar-rhs-last ':grammar-rhs))
+              (if (zerop i)
+                (depict markup-stream ':tab3)
+                (depict markup-stream "|" ':tab2))
+              (depict-charset-source markup-stream (nth i subexprs)))))
+        (depict-paragraph (markup-stream ':grammar-lhs-last)
+          (depict-general-nonterminal markup-stream (charclass-nonterminal charclass) :definition)
+          (depict markup-stream " " ':derives-10 " ")
+          (depict-charset-source markup-stream expr))))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; PARTITIONS
+
+(defstruct (partition (:constructor make-partition (charset lexer-actions))
+                      (:predicate partition?))
+  (charset nil :type integer :read-only t)            ;The set of characters in this partition
+  (lexer-actions nil :type list :read-only t))        ;List of lexer-actions needed on characters in this partition
+
+(defconstant *default-partition-name* '$_other_) ;partition-name to use for characters not found in lexer-char-tokens
+
+
+(defun print-partition (partition-name partition &optional (stream t))
+  (pprint-logical-block (stream nil)
+    (format stream "~W -> ~@_~:I" partition-name)
+    (print-charset (partition-charset partition) stream)
+    (format stream " ~_")
+    (pprint-fill stream (mapcar #'lexer-action-name (partition-lexer-actions partition)))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; LEXER
+
+
+(defstruct (lexer (:constructor allocate-lexer)
+                  (:copier nil)
+                  (:predicate lexer?))
+  (lexer-actions nil :type hash-table :read-only t)    ;Hash table of lexer-action-name -> lexer-action
+  (charclasses nil :type list :read-only t)            ;List of charclasses in the order in which they were given
+  (charclasses-hash nil :type hash-table :read-only t) ;Hash table of nonterminal -> charclass
+  (char-tokens nil :type hash-table :read-only t)      ;Hash table of character -> (character or partition-name)
+  (partition-names nil :type list :read-only t)        ;List of partition names in the order in which they were created
+  (partitions nil :type hash-table :read-only t)       ;Hash table of partition-name -> partition
+  (grammar nil :type (or null grammar))                ;Grammar that accepts exactly one lexer token
+  (metagrammar nil :type (or null metagrammar)))       ;Grammar that accepts the longest input sequence that forms a token
+
+
+; Return a function (character -> terminal) that classifies an input character
+; as either itself or a partition-name.
+; If the returned function is called on a non-character, it returns its input unchanged.
+(defun lexer-classifier (lexer)
+  (let ((char-tokens (lexer-char-tokens lexer)))
+    #'(lambda (char)
+        (if (characterp char)
+          (gethash char char-tokens *default-partition-name*)
+          char))))
+
+
+; Return the charclass that defines the given lexer nonterminal or nil if none.
+(defun lexer-charclass (lexer nonterminal)
+  (gethash nonterminal (lexer-charclasses-hash lexer)))
+
+
+; Return the charset of all characters that appear as terminals in grammar-source.
+(defun grammar-singletons (grammar-source)
+  (assert-type grammar-source (list (tuple t (list t) identifier t)))
+  (let ((singletons 0))
+    (labels
+      ((scan-for-singletons (list)
+         (dolist (element list)
+           (cond
+            ((characterp element)
+             (setq singletons (charset-add-char singletons element)))
+            ((consp element)
+             (case (first element)
+               (:- (scan-for-singletons (rest element)))
+               (:-- (scan-for-singletons (cddr element)))))))))
+      
+      (dolist (production-source grammar-source)
+        (scan-for-singletons (second production-source))))
+    singletons))
+
+
+; Return the list of all lexer-action-names that appear in at least one charclass of which this
+; partition is a subset.
+(defun collect-lexer-action-names (charclasses partition)
+  (let ((lexer-action-names nil))
+    (dolist (charclass charclasses)
+      (unless (zerop (logand (charclass-charset charclass) partition))
+        (dolist (action (charclass-actions charclass))
+          (pushnew (cdr action) lexer-action-names))))
+    (sort lexer-action-names #'< :key #'lexer-action-number)))
+
+
+; Make a lexer structure corresponding to a grammar with the given source.
+; charclasses-source is a list of character classes, where each class is a list of:
+;     a nonterminal C (may be a list to specify an attributed-nonterminal);
+;     an expression <set-expr> that denotes the set of characters in character class C;
+;     a list of bindings, each containing:
+;       an action name;
+;       a lexer-action name;
+;     an optional flag that indicatest that the character class should not be in the grammar.
+; lexer-actions-source is a list of lexer-action bindings, each containing:
+;     a lexer-action name;
+;     the type of this lexer-action's value;
+;     the name of a primitive to use when depicting this lexer-action's definition;
+;     the name of a lisp function (char -> value) that performs the lexer-action on a character.
+; This does not make the lexer's grammar; use make-lexer-and-grammar for that.
+(defun make-lexer (parametrization charclasses-source lexer-actions-source grammar-source)
+  (assert-type charclasses-source (list (cons t (cons t (cons (list (tuple identifier identifier)) t)))))
+  (assert-type lexer-actions-source (list (tuple identifier t (or null identifier) identifier)))
+  (let ((lexer-actions (make-hash-table :test #'eq))
+        (charclasses nil)
+        (charclasses-hash (make-hash-table :test *grammar-symbol-=*))
+        (charsets nil)
+        (singletons (grammar-singletons grammar-source)))
+    (let ((lexer-action-number 0))
+      (dolist (lexer-action-source lexer-actions-source)
+        (let ((name (first lexer-action-source))
+              (type-expr (second lexer-action-source))
+              (function-name (third lexer-action-source))
+              (function (fourth lexer-action-source)))
+          (when (gethash name lexer-actions)
+            (error "Attempt to redefine lexer action ~S" name))
+          (setf (gethash name lexer-actions)
+                (make-lexer-action name (incf lexer-action-number) type-expr function-name function)))))
+    
+    (dolist (charclass-source charclasses-source)
+      (let* ((nonterminal (assert-type (grammar-parametrization-intern parametrization (first charclass-source)) nonterminal))
+             (charset-source (intern-charset-expr parametrization (ensure-proper-form (second charclass-source))))
+             (charset (eval-charset-expr charclasses-hash charset-source))
+             (actions 
+              (mapcar #'(lambda (action-source)
+                          (let* ((lexer-action-name (second action-source))
+                                 (lexer-action (gethash lexer-action-name lexer-actions)))
+                            (unless lexer-action
+                              (error "Unknown lexer-action ~S" lexer-action-name))
+                            (cons (first action-source) lexer-action)))
+                      (third charclass-source))))
+        (when (gethash nonterminal charclasses-hash)
+          (error "Attempt to redefine character class ~S" nonterminal))
+        (when (charset-empty? charset)
+          (error "Empty character class ~S" nonterminal))
+        (let ((charclass (make-charclass nonterminal charset-source charset actions (fourth charclass-source))))
+          (push charclass charclasses)
+          (setf (gethash nonterminal charclasses-hash) charclass)
+          (push charset charsets))))
+    (setq charclasses (nreverse charclasses))
+    (bitmap-each-bit #'(lambda (i) (push (ash 1 i) charsets))
+                     singletons)
+    (let ((char-tokens (make-hash-table :test #'eql))
+          (partition-names nil)
+          (partitions (make-hash-table :test #'eq))
+          (current-partition-number 0))
+      (dolist (partition (compute-partitions charsets))
+        (let ((singleton (charset-char partition)))
+          (cond
+           (singleton (setf (gethash singleton char-tokens) singleton))
+           ((charset-infinite? partition)
+            (push *default-partition-name* partition-names)
+            (setf (gethash *default-partition-name* partitions)
+                  (make-partition partition (collect-lexer-action-names charclasses partition))))
+           (t (let ((token (intern (format nil "$_CHARS~D_" (incf current-partition-number)))))
+                (bitmap-each-bit #'(lambda (i)
+                                     (setf (gethash (code-char i) char-tokens) token))
+                                 partition)
+                (push token partition-names)
+                (setf (gethash token partitions)
+                      (make-partition partition (collect-lexer-action-names charclasses partition))))))))
+      (allocate-lexer
+       :lexer-actions lexer-actions
+       :charclasses charclasses
+       :charclasses-hash charclasses-hash
+       :char-tokens char-tokens
+       :partition-names (nreverse partition-names)
+       :partitions partitions))))
+
+
+(defun print-lexer (lexer &optional (stream t))
+  (let* ((lexer-actions (lexer-lexer-actions lexer))
+         (lexer-action-names (sort (hash-table-keys lexer-actions) #'<
+                                   :key #'(lambda (lexer-action-name)
+                                            (lexer-action-number (gethash lexer-action-name lexer-actions)))))
+         (charclasses (lexer-charclasses lexer))
+         (partition-names (lexer-partition-names lexer))
+         (partitions (lexer-partitions lexer))
+         (singletons nil))
+    
+    (when lexer-action-names
+      (pprint-logical-block (stream lexer-action-names)
+        (format stream "Lexer Actions:~2I")
+        (loop
+          (pprint-newline :mandatory stream)
+          (let ((lexer-action (gethash (pprint-pop) lexer-actions)))
+            (print-lexer-action lexer-action stream))
+          (pprint-exit-if-list-exhausted)))
+      (pprint-newline :mandatory stream)
+      (pprint-newline :mandatory stream))
+    
+    (when charclasses
+      (pprint-logical-block (stream charclasses)
+        (format stream "Charclasses:~2I")
+        (loop
+          (pprint-newline :mandatory stream)
+          (let ((charclass (pprint-pop)))
+            (print-charclass charclass stream))
+          (pprint-exit-if-list-exhausted)))
+      (pprint-newline :mandatory stream)
+      (pprint-newline :mandatory stream))
+    
+    (when partition-names
+      (pprint-logical-block (stream partition-names)
+        (format stream "Partitions:~2I")
+        (loop
+          (pprint-newline :mandatory stream)
+          (let ((partition-name (pprint-pop)))
+            (print-partition partition-name (gethash partition-name partitions) stream))
+          (pprint-exit-if-list-exhausted)))
+      (pprint-newline :mandatory stream)
+      (pprint-newline :mandatory stream))
+    
+    (maphash
+     #'(lambda (char char-or-partition)
+         (if (eql char char-or-partition)
+           (push char singletons)
+           (assert-type char-or-partition identifier)))
+     (lexer-char-tokens lexer))
+    (setq singletons (sort singletons #'char<))
+    (when singletons
+      (format stream "Singletons: ~@_~<~@{~W ~:_~}~:>~:@_~:@_" singletons))))
+    
+
+(defmethod print-object ((lexer lexer) stream)
+  (print-unreadable-object (lexer stream :identity t)
+    (write-string "lexer" stream)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+
+
+; Return a freshly consed list of partitions for the given charclass.
+(defun charclass-partitions (lexer charclass)
+  (do ((partitions nil)
+       (charset (charclass-charset charclass)))
+      ((charset-empty? charset) partitions)
+    (let* ((partition-name (if (charset-infinite? charset)
+                             *default-partition-name*
+                             (gethash (charset-highest-char charset) (lexer-char-tokens lexer))))
+           (partition-charset (if (characterp partition-name)
+                                (char-charset partition-name)
+                                (partition-charset (gethash partition-name (lexer-partitions lexer))))))
+      (push partition-name partitions)
+      (setq charset (charset-difference charset partition-charset)))))
+
+
+; Return an updated grammar-source whose character class nonterminals are replaced with sets of
+; terminals inside :- and :-- constraints.
+(defun update-constraint-nonterminals (lexer grammar-source)
+  (mapcar
+   #'(lambda (production-source)
+       (let ((rhs (second production-source)))
+         (if (some #'(lambda (rhs-component)
+                       (and (consp rhs-component)
+                            (member (first rhs-component) '(:- :--))))
+                   rhs)
+           (list*
+            (first production-source)
+            (mapcar
+             #'(lambda (component)
+                 (when (consp component)
+                   (let ((tag (first component)))
+                     (when (eq tag ':-)
+                       (setq component (list* ':-- (rest component) (rest component)))
+                       (setq tag ':--))
+                     (when (eq tag ':--)
+                       (setq component
+                             (list* tag
+                                    (second component)
+                                    (mapcan #'(lambda (grammar-symbol)
+                                                (if (nonterminal? grammar-symbol)
+                                                  (charclass-partitions lexer (assert-non-null (lexer-charclass lexer grammar-symbol)))
+                                                  (list grammar-symbol)))
+                                            (cddr component)))))))
+                 component)
+             rhs)
+            (cddr production-source))
+           production-source)))
+   grammar-source))
+
+
+; Return two values:
+;   An updated grammar-source that includes:
+;     grammar productions that define the character class nonterminals out of characters and tokens;
+;     character class nonterminals replaced with sets of terminals inside :- and :-- constraints.
+;   Extra commands that:
+;     define the partitions used in this lexer;
+;     define the actions of these productions.
+(defun lexer-grammar-and-commands (lexer grammar-source)
+  (labels
+    ((component-partitions (charset partitions)
+       (if (charset-empty? charset)
+         partitions
+         (let* ((partition-name (if (charset-infinite? charset)
+                                  *default-partition-name*
+                                  (gethash (charset-highest-char charset) (lexer-char-tokens lexer))))
+                (partition (gethash partition-name (lexer-partitions lexer))))
+           (component-partitions (charset-difference charset (partition-charset partition))
+                                 (cons partition partitions))))))
+    (let ((productions nil)
+          (commands nil))
+      (dolist (charclass (lexer-charclasses lexer))
+        (unless (charclass-hidden charclass)
+          (let* ((nonterminal (charclass-nonterminal charclass))
+                 (nonterminal-source (general-grammar-symbol-source nonterminal))
+                 (production-prefix (if (consp nonterminal-source)
+                                      (format nil "~{~A~^-~}" nonterminal-source)
+                                      nonterminal-source))
+                 (production-number 0))
+            (dolist (action (charclass-actions charclass))
+              (let ((lexer-action (cdr action)))
+                (push (list 'declare-action (car action) nonterminal-source (lexer-action-type-expr lexer-action)) commands)))
+            (do ((charset (charclass-charset charclass)))
+                ((charset-empty? charset))
+              (let* ((partition-name (if (charset-infinite? charset)
+                                       *default-partition-name*
+                                       (gethash (charset-highest-char charset) (lexer-char-tokens lexer))))
+                     (partition-charset (if (characterp partition-name)
+                                          (char-charset partition-name)
+                                          (partition-charset (gethash partition-name (lexer-partitions lexer)))))
+                     (production-name (intern (format nil "~A-~D" production-prefix (incf production-number)))))
+                (push (list nonterminal-source (list partition-name) production-name nil) productions)
+                (dolist (action (charclass-actions charclass))
+                  (let* ((lexer-action (cdr action))
+                         (body (if (characterp partition-name)
+                                 (let* ((lexer-action-function (lexer-action-function lexer-action))
+                                        (result (funcall lexer-action-function partition-name)))
+                                   (typecase result
+                                     (integer result)
+                                     (character result)
+                                     ((eql nil) 'false)
+                                     ((eql t) 'true)
+                                     (t (error "Cannot infer the type of ~S's result ~S" lexer-action-function result))))
+                                 (list (lexer-action-name lexer-action) partition-name))))
+                    (push (list 'action (car action) production-name body nil) commands)))
+                (setq charset (charset-difference charset partition-charset)))))))
+      
+      (let ((partition-commands
+             (mapcan
+              #'(lambda (partition-name)
+                  (mapcan #'(lambda (lexer-action)
+                              (let ((lexer-action-name (lexer-action-name lexer-action)))
+                                (list
+                                 (list 'declare-action lexer-action-name partition-name (lexer-action-type-expr lexer-action))
+                                 (list 'terminal-action lexer-action-name partition-name (lexer-action-function lexer-action)))))
+                          (partition-lexer-actions (gethash partition-name (lexer-partitions lexer)))))
+              (lexer-partition-names lexer))))
+        (values
+         (nreconc productions (update-constraint-nonterminals lexer grammar-source))
+         (nconc partition-commands (nreverse commands)))))))
+
+
+; Make a lexer and grammar from the given source.
+; kind should be :lalr-1, :lr-1, or :canonical-lr-1.
+; charclasses-source is a list of character classes, and
+; lexer-actions-source is a list of lexer-action bindings; see make-lexer.
+; start-symbol is the grammar's start symbol, and grammar-source is its source.
+; Return two values:
+;   the lexer (including the grammar in its grammar field);
+;   list of extra commands that:
+;     define the partitions used in this lexer;
+;     define the actions of these productions.
+(defun make-lexer-and-grammar (kind charclasses-source lexer-actions-source parametrization start-symbol grammar-source &rest grammar-options)
+  (let ((lexer (make-lexer parametrization charclasses-source lexer-actions-source grammar-source)))
+    (multiple-value-bind (lexer-grammar-source extra-commands) (lexer-grammar-and-commands lexer grammar-source)
+      (let ((grammar (apply #'make-and-compile-grammar kind parametrization start-symbol lexer-grammar-source grammar-options)))
+        (setf (lexer-grammar lexer) grammar)
+        (values lexer extra-commands)))))
+
+
+; Parse the input string to produce a list of action results.
+; If trace is:
+;   nil,     don't print trace information
+;   :code,   print trace information, including action code
+;   other    print trace information
+; Return two values:
+;   the list of action results;
+;   the list of action results' types.
+(defun lexer-parse (lexer string &key trace)
+  (let ((in (coerce string 'list)))
+    (action-parse (lexer-grammar lexer) (lexer-classifier lexer) in :trace trace)))
+
+
+; Same as lexer-parse except that also print the action results nicely.
+(defun lexer-pparse (lexer string &key (stream t) trace)
+  (multiple-value-bind (results types) (lexer-parse lexer string :trace trace)
+    (print-values results types stream)
+    (terpri stream)
+    (values results types)))
+
+
+; Compute the lexer grammar's metagrammar.
+(defun set-up-lexer-metagrammar (lexer)
+  (setf (lexer-metagrammar lexer) (make-metagrammar (lexer-grammar lexer))))
+
+
+
+; Parse the input string into elements, where each element is the longest
+; possible string of input characters that is accepted by the grammar.
+; The grammar's terminals are all characters that may appear in the input
+; string plus the symbol $END which is inserted after the last character of
+; the string.
+; Return the list of lists of action results of the elements.
+;
+; If initial-state and state-transition are non-nil, the parser has state.
+; initial-state is a list of input symbols to be prepended to the input string
+; before the first element is parsed.  state-transition is a function that
+; takes the result of each successful action and produces two values:
+;   a modified result of that action;
+;   a list of input symbols to be prepended to the input string before the next
+;     element is parsed.
+;
+; If trace is:
+;   nil,     don't print trace information
+;   :code,   print trace information, including action code
+;   other    print trace information
+;
+; Return three values:
+;   the list of lists of action results;
+;   the list of action results' types.  Each of the lists of action results has
+;     this type signature.
+;   the last state
+(defun lexer-metaparse (lexer string &key initial-state state-transition trace)
+  (let ((metagrammar (lexer-metagrammar lexer)))
+    (do ((in (append (coerce string 'list) '($end)))
+         (results-lists nil))
+        ((endp in) (values (nreverse results-lists)
+                           (grammar-user-start-action-types (metagrammar-grammar metagrammar))
+                           initial-state))
+      (multiple-value-bind (results in-rest)
+                           (action-metaparse metagrammar (lexer-classifier lexer) (append initial-state in) :trace trace)
+        (when state-transition
+          (multiple-value-setq (results initial-state) (funcall state-transition results)))
+        (setq in in-rest)
+        (push results results-lists)))))
+
+
+; Same as lexer-metaparse except that also print the action results nicely.
+(defun lexer-pmetaparse (lexer string &key initial-state state-transition (stream t) trace)
+  (multiple-value-bind (results-lists types final-state)
+                       (lexer-metaparse lexer string :initial-state initial-state :state-transition state-transition :trace trace)
+    (pprint-logical-block (stream results-lists)
+      (pprint-exit-if-list-exhausted)
+      (loop
+        (print-values (pprint-pop) types stream :prefix "(" :suffix ")")
+        (pprint-exit-if-list-exhausted)
+        (format stream " ~_")))
+    (terpri stream)
+    (values results-lists types final-state)))
+

mozilla/js2/semantics/Main.lisp

@@ -0,0 +1,89 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; ECMAScript semantic loader
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+#+allegro (shadow 'state)
+#+allegro (shadow 'type)
+#+lispworks (shadow 'define-action)
+#+lispworks (shadow 'type)
+
+(defparameter *semantic-engine-filenames*
+  '("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"))
+
+(defparameter *semantics-filenames*
+  '("JS20/Parser" "JS20/Lexer" "JS20/Units" "JS20/RegExp" "JS20/Kernel"))
+
+(defparameter *semantic-engine-directory*
+  (make-pathname
+   #+lispworks :host #+lispworks (pathname-host *load-truename*)
+   :directory (pathname-directory #-mcl *load-truename*
+                                  #+mcl (truename *loading-file-source-file*))))
+
+
+; Convert a filename string possibly containing slashes into a Lisp relative pathname.
+(defun filename-to-relative-pathname (filename)
+  (let ((directories nil))
+    (loop
+      (let ((slash (position #\/ filename)))
+        (if slash
+          (let ((dir-name (subseq filename 0 slash)))
+            (push (if (equal dir-name "..") :up dir-name) directories)
+            (setq filename (subseq filename (1+ slash))))
+          (return (if directories
+                    (make-pathname :directory (cons ':relative (nreverse directories)) :name filename #+lispworks :type #+lispworks "lisp")
+                    #-lispworks filename
+                    #+lispworks (make-pathname :name filename :type "lisp"))))))))
+
+
+; Convert a filename string possibly containing slashes relative to *semantic-engine-directory*
+; into a Lisp absolute pathname.
+(defun filename-to-semantic-engine-pathname (filename)
+  (merge-pathnames (filename-to-relative-pathname filename) *semantic-engine-directory*))
+
+
+(defun operate-on-files (f files &rest options)
+  (with-compilation-unit ()
+    (dolist (filename files)
+      (apply f (filename-to-semantic-engine-pathname filename) :verbose t options))))
+
+(defun compile-semantic-engine ()
+  (operate-on-files #'compile-file *semantic-engine-filenames* :load t))
+
+(defun load-semantic-engine ()
+  (operate-on-files #-allegro #'load #+allegro #'load-compiled *semantic-engine-filenames*))
+
+(defun load-semantics ()
+  (operate-on-files #-allegro #'load #+allegro #'load-compiled *semantics-filenames*))
+
+
+(defmacro with-local-output ((stream filename) &body body)
+  `(with-open-file (,stream (filename-to-semantic-engine-pathname ,filename)
+                            :direction :output
+                            :if-exists :supersede)
+     ,@body))
+
+
+(load-semantic-engine)
+(load-semantics)

mozilla/js2/semantics/Markup.lisp

@@ -0,0 +1,700 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Common RTF and HTML writing utilities
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+(defvar *trace-logical-blocks* nil)     ;Emit logical blocks to *trace-output* while processing
+(defvar *show-logical-blocks* nil)      ;Emit logical block boundaries as hidden rtf text
+
+(defvar *markup-logical-line-width* 90) ;Approximate maximum number of characters to display on a single logical line
+(defvar *average-space-width* 2/3)      ;Width of a space as a percentage of average character width when calculating logical line widths
+
+(defvar *external-link-base* nil)       ;URL prefix for referring to a page with external links or nil if none
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; LINK TABLES
+
+; Return a table for recording defined, referenced, and external links.
+; External links include a # character; locally defined and referenced ones do not.
+(declaim (inline make-link-table))
+(defun make-link-table ()
+  (make-hash-table :test #'equal))
+
+
+; The concatenation of link-prefix and link-name is the name of a link.  Mark the link defined.
+; Return the full name if links are allowed and this is the first definition of that name.
+; If duplicate is false, don't allow multiple definitions of the same link name.
+(defun record-link-definition (links link-prefix link-name duplicate)
+  (assert-type link-prefix string)
+  (assert-type link-name string)
+  (and links
+       (let ((name (concatenate 'string link-prefix link-name)))
+         (cond
+          ((not (eq (gethash name links) :defined))
+           (setf (gethash name links) :defined)
+           name)
+          (duplicate nil)
+          (t (warn "Duplicate link definition ~S" name)
+             name)))))
+
+
+; The concatenation of link-prefix and link-name is the name of a link.  Mark the link referenced.
+; If external is true, the link refers to the page given by *external-link-base*; if *external-link-base*
+; is null and external is true, no link gets made.
+; Return the full href if links are allowed or nil if not.
+(defun record-link-reference (links link-prefix link-name external)
+  (assert-type link-prefix string)
+  (assert-type link-name string)
+  (and links
+       (if external
+         (and *external-link-base*
+              (let ((href (concatenate 'string *external-link-base* "#" link-prefix link-name)))
+                (setf (gethash href links) :external)
+                href))
+         (let ((name (concatenate 'string link-prefix link-name)))
+           (unless (eq (gethash name links) :defined)
+             (setf (gethash name links) :referenced))
+           (concatenate 'string "#" name)))))
+
+
+; Warn about all referenced but not defined links.
+(defun warn-missing-links (links)
+  (when links
+    (let ((missing-links nil)
+          (external-links nil))
+      (maphash #'(lambda (name link-state)
+                   (case link-state
+                     (:referenced (push name missing-links))
+                     (:external (push name external-links))))
+               links)
+      (setq missing-links (sort missing-links #'string<))
+      (setq external-links (sort external-links #'string<))
+      (when missing-links
+        (warn "The following links have been referenced but not defined: ~S" missing-links))
+      (when external-links
+        (format *error-output* "External links:~%~{  ~A~%~}" external-links)))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; MARKUP ENVIRONMENTS
+
+
+(defstruct (markup-env (:constructor allocate-markup-env (macros widths)))
+  (macros nil :type hash-table :read-only t)     ;Hash table of keyword -> expansion list
+  (widths nil :type hash-table :read-only t)     ;Hash table of keyword -> estimated width of macro expansion;
+;                                                ;  zero-width entries can be omitted; multiline entries have t for a width.
+  (links nil :type (or null hash-table)))        ;Hash table of string -> either :referenced or :defined;
+;                                                ;  nil if links not supported
+
+
+; Make a markup-env.  If links is true, allow links.
+(defun make-markup-env (links)
+  (let ((markup-env (allocate-markup-env (make-hash-table :test #'eq) (make-hash-table :test #'eq))))
+    (when links
+      (setf (markup-env-links markup-env) (make-link-table)))
+    markup-env))
+
+
+; Recursively expand all keywords in markup-tree, producing a freshly consed expansion tree.
+; Allow keywords in the permitted-keywords list to be present in the output without generating an error.
+(defun markup-env-expand (markup-env markup-tree permitted-keywords)
+  (mapcan
+   #'(lambda (markup-element)
+       (cond
+        ((keywordp markup-element)
+         (let ((expansion (gethash markup-element (markup-env-macros markup-env) *get2-nonce*)))
+           (if (eq expansion *get2-nonce*)
+             (if (member markup-element permitted-keywords :test #'eq)
+               (list markup-element)
+               (error "Unknown markup macro ~S" markup-element))
+             (markup-env-expand markup-env expansion permitted-keywords))))
+        ((listp markup-element)
+         (list (markup-env-expand markup-env markup-element permitted-keywords)))
+        (t (list markup-element))))
+   markup-tree))
+
+
+(defun markup-env-define (markup-env keyword expansion &optional width)
+  (assert-type keyword keyword)
+  (assert-type expansion (list t))
+  (assert-type width (or null integer (eql t)))
+  (when (gethash keyword (markup-env-macros markup-env))
+    (warn "Redefining markup macro ~S" keyword))
+  (setf (gethash keyword (markup-env-macros markup-env)) expansion)
+  (if width
+    (setf (gethash keyword (markup-env-widths markup-env)) width)
+    (remhash keyword (markup-env-widths markup-env))))
+
+
+(defun markup-env-append (markup-env keyword expansion)
+  (assert-type keyword keyword)
+  (assert-type expansion (list t))
+  (setf (gethash keyword (markup-env-macros markup-env))
+        (append (gethash keyword (markup-env-macros markup-env)) expansion)))
+
+
+(defun markup-env-define-alist (markup-env keywords-and-expansions)
+  (dolist (keyword-and-expansion keywords-and-expansions)
+    (let ((keyword (car keyword-and-expansion))
+          (expansion (cdr keyword-and-expansion)))
+      (cond
+       ((not (consp keyword))
+        (markup-env-define markup-env keyword expansion))
+       ((eq (first keyword) '+)
+        (markup-env-append markup-env (second keyword) expansion))
+       (t (markup-env-define markup-env (first keyword) expansion (second keyword)))))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; LOGICAL POSITIONS
+
+(defstruct logical-position
+  (n-hard-breaks 0 :type integer)             ;Number of :new-line's in the current paragraph or logical block
+  (position 0 :type integer)                  ;Current character position.  If n-hard-breaks is zero, only includes characters written into this logical block
+  ;                                           ;  plus the minimal position from the enclosing block.  If n-hard-breaks is nonzero, includes indent and characters
+  ;                                           ;  written since the last hard break.
+  (surplus 0 :type integer)                   ;Value to subtract from position if soft breaks were hard breaks in this logical block
+  (n-soft-breaks nil :type (or null integer)) ;Number of soft-breaks in the current paragraph or nil if not inside a depict-logical-block
+  (indent 0 :type (or null integer)))         ;Indent for next line
+
+
+; Return the value the position would have if soft breaks became hard breaks in this logical block.
+(declaim (inline logical-position-minimal-position))
+(defun logical-position-minimal-position (logical-position)
+  (- (logical-position-position logical-position) (logical-position-surplus logical-position)))
+
+
+; Advance the logical position by width characters.  If width is t,
+; advance to the next line.
+(defun logical-position-advance (logical-position width)
+  (if (eq width t)
+    (progn
+      (incf (logical-position-n-hard-breaks logical-position))
+      (setf (logical-position-position logical-position) 0)
+      (setf (logical-position-surplus logical-position) 0))
+    (incf (logical-position-position logical-position) width)))
+
+
+(defstruct (soft-break (:constructor make-soft-break (width)))
+  (width 0 :type integer))     ;Number of spaces by which to replace this soft break if it doesn't turn into a hard break; t if unconditional
+
+
+; Destructively replace any soft-break that appears in a car position in the tree with
+; the spliced result of calling f on that soft-break.  f should return a non-null list that can
+; be nconc'd.
+(defun substitute-soft-breaks (tree f)
+  (do ((subtree tree next-subtree)
+       (next-subtree (cdr tree) (cdr next-subtree)))
+      ((endp subtree))
+    (let ((item (car subtree)))
+      (cond
+       ((soft-break-p item)
+        (let* ((splice (assert-non-null (funcall f item)))
+               (splice-rest (cdr splice)))
+          (setf (car subtree) (car splice))
+          (setf (cdr subtree) (nconc splice-rest next-subtree))))
+       ((consp item) (substitute-soft-breaks item f)))))
+  tree)
+
+
+; Destructively replace any soft-break that appears in a car position in the tree
+; with width spaces, where width is the soft-break's width.
+(defun remove-soft-breaks (tree)
+  (substitute-soft-breaks
+   tree
+   #'(lambda (soft-break)
+       (list (make-string (soft-break-width soft-break) :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character)))))
+
+
+; Return a freshly consed markup list for a hard line break followed by indent spaces.
+(defun hard-break-markup (indent)
+  (if (zerop indent)
+    (list ':new-line)
+    (list ':new-line (make-string indent :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character))))
+
+
+; Destructively replace any soft-break that appears in a car position in the tree
+; with a line break followed by indent spaces.
+(defun expand-soft-breaks (tree indent)
+  (substitute-soft-breaks
+   tree
+   #'(lambda (soft-break)
+       (declare (ignore soft-break))
+       (hard-break-markup indent))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; MARKUP STREAMS
+
+(defstruct (markup-stream (:copier nil) (:predicate markup-stream?))
+  (env nil :type markup-env :read-only t)
+  (level nil :type integer)           ;0 for emitting top-level group; 1 for emitting sections; 2 for emitting paragraphs; 3 for emitting paragraph contents
+  (head nil :type list)               ;Pointer to a dummy cons-cell whose cdr is the output markup list.
+  ;                                   ; A markup-stream may destructively modify any sublists of head that contain a soft-break.
+  (tail nil :type list)               ;Last cons cell of the output list; new cells are added in place to this cell's cdr; nil after markup-stream is closed.
+  (pretail nil :type list)            ;Tail's predecessor if tail's car is a block that can be inlined at the end of the output list; nil otherwise.
+  (logical-position nil :type logical-position)) ;Information about the current logical lines or nil if not emitting paragraph contents
+
+;                                                ;RTF                     ;HTML
+(defconstant *markup-stream-top-level* 0)        ;Top-level group         ;Top level
+(defconstant *markup-stream-section-level* 1)    ;Sections                ;(not used)
+(defconstant *markup-stream-paragraph-level* 2)  ;Paragraphs              ;Block tags
+(defconstant *markup-stream-content-level* 3)    ;Paragraph contents      ;Inline tags
+
+
+; Return the markup accumulated in the markup-stream.
+; The markup-stream is closed after this function is called.
+(defun markup-stream-unexpanded-output (markup-stream)
+  (when (markup-stream-pretail markup-stream)
+    ;Inline the last block at the end of the markup-stream.
+    (setf (cdr (markup-stream-pretail markup-stream)) (car (markup-stream-tail markup-stream)))
+    (setf (markup-stream-pretail markup-stream) nil))
+  (setf (markup-stream-tail markup-stream) nil) ;Close the stream.
+  (cdr (assert-non-null (markup-stream-head markup-stream))))
+
+
+; Return the markup accumulated in the markup-stream after expanding all of its macros.
+; The markup-stream is closed after this function is called.
+(defgeneric markup-stream-output (markup-stream))
+
+
+; Append one item to the end of the markup-stream.
+(defun markup-stream-append1 (markup-stream item)
+  (setf (markup-stream-pretail markup-stream) nil)
+  (let ((item-cons (list item)))
+    (setf (cdr (markup-stream-tail markup-stream)) item-cons)
+    (setf (markup-stream-tail markup-stream) item-cons)))
+
+
+; Return the approximate width of the markup item; return t if it is a line break.
+(defun markup-width (markup-stream item)
+  (cond
+   ((stringp item) (round (- (length item) (* (count #\space item) (- 1 *average-space-width*)))))
+   ((keywordp item) (gethash item (markup-env-widths (markup-stream-env markup-stream)) 0))
+   ((and item (symbolp item)) 0)
+   (t (error "Bad item in markup-width" item))))
+
+
+; Return the approximate width of the markup item; return t if it is a line break.
+; Also allow markup groups as long as they do not contain line breaks.
+(defgeneric markup-group-width (markup-stream item))
+
+
+; Append zero or more markup items to the end of the markup-stream.
+; The items must be either keywords, symbols, or strings.
+(defun depict (markup-stream &rest markup-list)
+  (assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
+  (dolist (markup markup-list)
+    (markup-stream-append1 markup-stream markup)
+    (logical-position-advance (markup-stream-logical-position markup-stream) (markup-width markup-stream markup))))
+
+
+; Same as depict except that the items may be groups as well.
+(defun depict-group (markup-stream &rest markup-list)
+  (assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
+  (dolist (markup markup-list)
+    (markup-stream-append1 markup-stream markup)
+    (logical-position-advance (markup-stream-logical-position markup-stream) (markup-group-width markup-stream markup))))
+
+
+; If markup-item-or-list is a list, emit its contents via depict.
+; If markup-item-or-list is not a list, emit it via depict.
+(defun depict-item-or-list (markup-stream markup-item-or-list)
+  (if (listp markup-item-or-list)
+    (apply #'depict markup-stream markup-item-or-list)
+    (depict markup-stream markup-item-or-list)))
+
+
+; If markup-item-or-list is a list, emit its contents via depict-group.
+; If markup-item-or-list is not a list, emit it via depict.
+(defun depict-item-or-group-list (markup-stream markup-item-or-list)
+  (if (listp markup-item-or-list)
+    (apply #'depict-group markup-stream markup-item-or-list)
+    (depict markup-stream markup-item-or-list)))
+
+
+; markup-stream must be a variable that names a markup-stream that is currently
+; accepting paragraphs.  Execute body with markup-stream bound to a markup-stream
+; to which the body can emit contents.  If non-null, the given block-style is applied to all
+; paragraphs emitted by body (in the HTML emitter only; RTF has no block styles).
+; If flatten is true, do not emit the style if it is already in effect from a surrounding block
+; or if its contents are empty.
+; Return the result value of body.
+(defmacro depict-block-style ((markup-stream block-style &optional flatten) &body body)
+  `(depict-block-style-f ,markup-stream ,block-style ,flatten
+                         #'(lambda (,markup-stream) ,@body)))
+
+(defgeneric depict-block-style-f (markup-stream block-style flatten emitter))
+
+
+; markup-stream must be a variable that names a markup-stream that is currently
+; accepting paragraphs.  Emit a paragraph with the given paragraph-style (which
+; must be a symbol) whose contents are emitted by body.  When executing body,
+; markup-stream is bound to a markup-stream to which body should emit the paragraph's contents.
+; Return the result value of body.
+(defmacro depict-paragraph ((markup-stream paragraph-style) &body body)
+  `(depict-paragraph-f ,markup-stream ,paragraph-style
+                       #'(lambda (,markup-stream) ,@body)))
+
+(defgeneric depict-paragraph-f (markup-stream paragraph-style emitter))
+
+
+; markup-stream must be a variable that names a markup-stream that is currently
+; accepting paragraph contents.  Execute body with markup-stream bound to a markup-stream
+; to which the body can emit contents.  If non-null, the given char-style is applied to all such
+; contents emitted by body.
+; Return the result value of body.
+(defmacro depict-char-style ((markup-stream char-style) &body body)
+  `(depict-char-style-f ,markup-stream ,char-style
+                        #'(lambda (,markup-stream) ,@body)))
+
+(defgeneric depict-char-style-f (markup-stream char-style emitter))
+
+
+; Ensure that the given style is not currently in effect in the markup-stream.
+; RTF streams don't currently keep track of styles, so this function does nothing for RTF streams.
+(defgeneric ensure-no-enclosing-style (markup-stream style))
+
+
+; Return a value that captures the current sequence of enclosing block styles.
+(defgeneric save-block-style (markup-stream))
+
+; markup-stream must be a variable that names a markup-stream that is currently
+; accepting paragraphs.  Execute body with markup-stream bound to a markup-stream
+; to which the body can emit contents.  The given saved-block-style is applied to all
+; paragraphs emitted by body (in the HTML emitter only; RTF has no block styles).
+; saved-block-style should have been obtained from a past call to save-block-style.
+; If flatten is true, do not emit the style if it is already in effect from a surrounding block
+; or if its contents are empty.
+; Return the result value of body.
+(defmacro with-saved-block-style ((markup-stream saved-block-style &optional flatten) &body body)
+  `(with-saved-block-style-f ,markup-stream ,saved-block-style ,flatten
+     #'(lambda (,markup-stream) ,@body)))
+
+(defgeneric with-saved-block-style-f (markup-stream saved-block-style flatten emitter))
+
+
+; Depict an anchor.  The concatenation of link-prefix and link-name must be a string
+; suitable for an anchor name.
+; If duplicate is true, allow duplicate calls for the same link-name, in which case only
+; the first one takes effect.
+(defgeneric depict-anchor (markup-stream link-prefix link-name duplicate))
+
+
+; markup-stream must be a variable that names a markup-stream that is currently
+; accepting paragraph contents.  Execute body with markup-stream bound to a markup-stream
+; to which the body can emit contents.  The given link name is the destination of a local
+; link for which body is the contents.  The concatenation of link-prefix and link-name
+; must be a string suitable for an anchor name.
+; Return the result value of body.
+(defmacro depict-link-reference ((markup-stream link-prefix link-name external) &body body)
+  `(depict-link-reference-f ,markup-stream ,link-prefix ,link-name ,external
+                            #'(lambda (,markup-stream) ,@body)))
+
+(defgeneric depict-link-reference-f (markup-stream link-prefix link-name external emitter))
+
+
+; markup-stream must be a variable that names a markup-stream that is currently
+; accepting paragraph contents.  Execute body with markup-stream bound to a markup-stream
+; to which the body can emit contents.  Depending on link, do one of the following:
+;   :reference   Emit a reference to the link with the given body of the reference;
+;   :external    Emit an external reference to the link with the given body of the reference;
+;   :definition  Emit the link as an anchor, followed by the body;
+;   nil          Emit the body only.
+; If duplicate is true, allow duplicate anchors, in which case only the first one takes effect.
+; Return the result value of body.
+(defmacro depict-link ((markup-stream link link-prefix link-name duplicate) &body body)
+  `(depict-link-f ,markup-stream ,link ,link-prefix ,link-name ,duplicate
+                  #'(lambda (,markup-stream) ,@body)))
+
+(defun depict-link-f (markup-stream link link-prefix link-name duplicate emitter)
+  (ecase link
+    (:reference (depict-link-reference-f markup-stream link-prefix link-name nil emitter))
+    (:external (depict-link-reference-f markup-stream link-prefix link-name t emitter))
+    (:definition
+      (depict-anchor markup-stream link-prefix link-name duplicate)
+      (funcall emitter markup-stream))
+    ((nil) (funcall emitter markup-stream))))
+
+
+(defun depict-logical-block-f (markup-stream indent emitter)
+  (assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
+  (if indent
+    (let* ((logical-position (markup-stream-logical-position markup-stream))
+           (cumulative-indent (+ (logical-position-indent logical-position) indent))
+           (minimal-position (logical-position-minimal-position logical-position))
+           (inner-logical-position (make-logical-position :position minimal-position
+                                                          :n-soft-breaks 0
+                                                          :indent cumulative-indent))
+           (old-tail (markup-stream-tail markup-stream)))
+      (setf (markup-stream-logical-position markup-stream) inner-logical-position)
+      (when *show-logical-blocks*
+        (markup-stream-append1 markup-stream (list ':invisible (format nil "<~D" indent))))
+      (prog1
+        (funcall emitter markup-stream)
+        (when *show-logical-blocks*
+          (markup-stream-append1 markup-stream '(:invisible ">")))
+        (assert-true (eq (markup-stream-logical-position markup-stream) inner-logical-position))
+        (let* ((tree (cdr old-tail))
+               (inner-position (logical-position-position inner-logical-position))
+               (inner-count (- inner-position minimal-position))
+               (inner-n-hard-breaks (logical-position-n-hard-breaks inner-logical-position))
+               (inner-n-soft-breaks (logical-position-n-soft-breaks inner-logical-position)))
+          (when *trace-logical-blocks*
+            (format *trace-output* "Block ~:W:~%position ~D,  count ~D,  n-hard-breaks ~D,  n-soft-breaks ~D~%~%"
+                    tree inner-position inner-count inner-n-hard-breaks inner-n-soft-breaks))
+          (cond
+           ((zerop inner-n-soft-breaks)
+            (assert-true (zerop (logical-position-surplus inner-logical-position)))
+            (if (zerop inner-n-hard-breaks)
+              (incf (logical-position-position logical-position) inner-count)
+              (progn
+                (incf (logical-position-n-hard-breaks logical-position) inner-n-hard-breaks)
+                (setf (logical-position-position logical-position) inner-position)
+                (setf (logical-position-surplus logical-position) 0))))
+           ((and (zerop inner-n-hard-breaks) (<= inner-position *markup-logical-line-width*))
+            (assert-true tree)
+            (remove-soft-breaks tree)
+            (incf (logical-position-position logical-position) inner-count))
+           (t
+            (assert-true tree)
+            (expand-soft-breaks tree cumulative-indent)
+            (incf (logical-position-n-hard-breaks logical-position) (+ inner-n-hard-breaks inner-n-soft-breaks))
+            (setf (logical-position-position logical-position) (logical-position-minimal-position inner-logical-position))
+            (setf (logical-position-surplus logical-position) 0))))
+        (setf (markup-stream-logical-position markup-stream) logical-position)))
+    (funcall emitter markup-stream)))
+
+
+; markup-stream must be a variable that names a markup-stream that is currently
+; accepting paragraph contents.  Execute body with markup-stream bound to a markup-stream
+; to which the body can emit contents.  body can call depict-break, which will either
+; all expand to the widths given to the depict-break calls or all expand to line breaks
+; followed by indents to the current indent level plus the given indent.
+; If indent is nil, don't create the logical block and just evaluate body.
+; Return the result value of body.
+(defmacro depict-logical-block ((markup-stream indent) &body body)
+  `(depict-logical-block-f ,markup-stream ,indent
+                           #'(lambda (,markup-stream) ,@body)))
+
+
+; Emit a conditional line break.  If the line break is not needed, emit width spaces instead.
+; If width is t or omitted, the line break is unconditional.
+; If width is nil, do nothing.
+; If the line break is needed, the new line is indented to the current indent level.
+; Must be called from the dynamic scope of a depict-logical-block.
+(defun depict-break (markup-stream &optional (width t))
+  (assert-true (>= (markup-stream-level markup-stream) *markup-stream-content-level*))
+  (when width
+    (let* ((logical-position (markup-stream-logical-position markup-stream))
+           (indent (logical-position-indent logical-position)))
+      (if (eq width t)
+        (depict-item-or-list markup-stream (hard-break-markup indent))
+        (progn
+          (incf (logical-position-n-soft-breaks logical-position))
+          (incf (logical-position-position logical-position) width)
+          (let ((surplus (- (logical-position-position logical-position) (round (* indent *average-space-width*)))))
+            (when (< surplus 0)
+              (setq surplus 0))
+            (setf (logical-position-surplus logical-position) surplus))
+          (when *show-logical-blocks*
+            (markup-stream-append1 markup-stream '(:invisible :bullet)))
+          (markup-stream-append1 markup-stream (make-soft-break width)))))))
+
+
+; Call emitter to emit each element of the given list onto the markup-stream.
+; emitter takes two arguments -- the markup-stream and the element of list to be emitted.
+; Emit prefix before the list and suffix after the list.  If prefix-break is supplied, call
+; depict-break with it as the argument after the prefix.
+; If indent is non-nil, enclose the list elements in a logical block with the given indent.
+; Emit separator between any two emitted elements.  If break is supplied, call
+; depict-break with it as the argument after each separator.
+; If the list is empty, emit empty unless it is :error, in which case signal an error.
+;
+; prefix, suffix, separator, and empty should be lists of markup elements appropriate for depict.
+; If any of these lists has only one element that is not itself a list, then that list can be
+; abbreviated to just that element (as in depict-item-or-list).
+;
+(defun depict-list (markup-stream emitter list &key indent prefix prefix-break suffix separator break (empty :error))
+  (assert-true (or indent (not (or prefix-break break))))
+  (labels
+    ((emit-element (markup-stream list)
+       (funcall emitter markup-stream (first list))
+       (let ((rest (rest list)))
+         (when rest
+           (depict-item-or-list markup-stream separator)
+           (depict-break markup-stream break)
+           (emit-element markup-stream rest)))))
+    
+    (depict-item-or-list markup-stream prefix)
+    (cond
+     (list
+      (depict-logical-block (markup-stream indent)
+        (depict-break markup-stream prefix-break)
+        (emit-element markup-stream list)))
+     ((eq empty ':error) (error "Non-empty list required"))
+     (t (depict-item-or-list markup-stream empty)))
+    (depict-item-or-list markup-stream suffix)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; MARKUP FOR CHARACTERS AND STRINGS
+
+(defparameter *character-names*
+  '((#x00 . "NUL")
+    (#x08 . "BS")
+    (#x09 . "TAB")
+    (#x0A . "LF")
+    (#x0B . "VT")
+    (#x0C . "FF")
+    (#x0D . "CR")
+    (#x20 . "SP")))
+
+; Emit markup for the given character.  The character is emitted without any formatting if it is a
+; printable character and not a member of the escape-list list of characters.  Otherwise the
+; character is emitted with :character-literal-control formatting.
+; The markup-stream should already be set to :character-literal formatting.
+(defun depict-character (markup-stream char &optional (escape-list '(#\space)))
+  (let ((code (char-code char)))
+    (if (and (>= code 32) (< code 127) (not (member char escape-list)))
+      (depict markup-stream (string char))
+      (depict-char-style (markup-stream ':character-literal-control)
+        (let ((name (or (cdr (assoc code *character-names*))
+                        (format nil "u~4,'0X" code))))
+          (depict markup-stream ':left-angle-quote name ':right-angle-quote))))))
+
+
+; Emit markup for the given string, enclosing it in curly double quotes.
+; The markup-stream should be set to normal formatting.
+(defun depict-string (markup-stream string)
+  (depict markup-stream ':left-double-quote)
+  (unless (equal string "")
+    (depict-char-style (markup-stream ':character-literal)
+      (dotimes (i (length string))
+        (depict-character markup-stream (char string i) nil))))
+  (depict markup-stream ':right-double-quote))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; IDENTIFIER ABBREVIATIONS
+
+; Return a symbol with the same package as the given symbol but whose name omits everything
+; after the first underscore, if any, in the given symbol's name.  The returned symbol is eq
+; to the given symbol if its name contains no underscores.
+(defun symbol-to-abbreviation (symbol)
+  (let* ((name (symbol-name symbol))
+         (pos (position #\_ name)))
+    (if pos
+      (intern (subseq name 0 pos) (symbol-package symbol))
+      symbol)))
+
+
+; A caching version of symbol-to-abbreviation.
+(defun symbol-abbreviation (symbol)
+  (or (get symbol :abbreviation)
+      (setf (get symbol :abbreviation) (symbol-to-abbreviation symbol))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; MARKUP FOR IDENTIFIERS
+
+; Return string converted from dash-separated-uppercase-words to mixed case,
+; with the first character capitalized if capitalize is true.
+; The string should contain only letters, dashes, and numbers.
+(defun string-to-mixed-case (string &optional capitalize)
+  (let* ((length (length string))
+         (dst-string (make-array length :element-type #-mcl 'character #+mcl 'base-character :fill-pointer 0)))
+    (dotimes (i length)
+      (let ((char (char string i)))
+        (if (eql char #\-)
+          (if capitalize
+            (error "Double capitalize")
+            (setq capitalize t))
+          (progn
+            (cond
+             ((upper-case-p char)
+              (if capitalize
+                (setq capitalize nil)
+                (setq char (char-downcase char))))
+             ((digit-char-p char))
+             ((member char '(#\$ #\_)))
+             (t (error "Bad string-to-mixed-case character ~A" char)))
+            (vector-push char dst-string)))))
+    dst-string))
+
+
+; Return a string containing the symbol's name in mixed case with the first letter capitalized.
+(defun symbol-upper-mixed-case-name (symbol)
+  (or (get symbol :upper-mixed-case-name)
+      (setf (get symbol :upper-mixed-case-name) (string-to-mixed-case (symbol-name symbol) t))))
+
+
+; Return a string containing the symbol's name in mixed case with the first letter in lower case.
+(defun symbol-lower-mixed-case-name (symbol)
+  (or (get symbol :lower-mixed-case-name)
+      (setf (get symbol :lower-mixed-case-name) (string-to-mixed-case (symbol-name symbol)))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; MISCELLANEOUS MARKUP
+
+
+; Append a space to the end of the markup-stream.
+(defun depict-space (markup-stream)
+  (depict markup-stream " "))
+
+
+; Emit markup for the given integer, displaying it in decimal.
+(defun depict-integer (markup-stream i)
+  (depict markup-stream (format nil "~D" i)))
+
+
+(defmacro styled-text-depictor (symbol)
+  `(get ,symbol 'styled-text-depictor))
+
+
+; Emit markup for the given <text>, which should be a list of:
+;   <string>                display as is
+;   <keyword>               display as is
+;   (<symbol> . <args>)     if <symbol>'s styled-text-depictor property is present, call it giving it <args>
+;                             as arguments; otherwise treat this case as the following:
+;   (<style> . <text>)      display <text> with the given <style> keyword
+;   <character>             display using depict-character
+(defun depict-styled-text (markup-stream text)
+  (dolist (item text)
+    (cond
+     ((or (stringp item) (keywordp item))
+      (depict markup-stream item))
+     ((consp item)
+      (let* ((first (first item))
+             (rest (rest item))
+             (depictor (styled-text-depictor first)))
+        (if depictor
+          (apply depictor markup-stream rest)
+          (depict-char-style (markup-stream first)
+            (depict-styled-text markup-stream rest)))))
+     ((characterp item)
+      (depict-character markup-stream item))
+     (t (error "Bad depict-styled-text item: ~S" item)))))

mozilla/js2/semantics/Metaparser.lisp

@@ -0,0 +1,360 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Finite-state machine generator
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; METATRANSITION
+
+(defstruct (metatransition (:constructor make-metatransition (next-metastate pre-productions post-productions)))
+  (next-metastate nil :read-only t)     ;Next metastate to enter or nil if this is an accept transition
+  (pre-productions nil :read-only t)    ;List of productions reduced by this transition (in order from first to last) before the shift
+  (post-productions nil :read-only t))  ;List of productions reduced by this transition (in order from first to last) after the shift
+
+  
+;;; ------------------------------------------------------------------------------------------------------
+;;; METASTATE
+
+;;; A metastate is a list of states that represents a possible stack that the
+;;; LALR(1) parser may encounter.
+(defstruct (metastate (:constructor make-metastate (stack number transitions)))
+  (stack nil :type list :read-only t)                 ;List of states that comprises a possible stack
+  (number nil :type integer :read-only t)             ;Serial number of this metastate
+  (transitions nil :type simple-vector :read-only t)) ;Array, indexed by terminal numbers, of either nil or metatransition structures
+
+(declaim (inline metastate-transition))
+(defun metastate-transition (metastate terminal-number)
+  (svref (metastate-transitions metastate) terminal-number))
+
+
+(defun print-metastate (metastate metagrammar &optional (stream t))
+  (let ((grammar (metagrammar-grammar metagrammar)))
+    (pprint-logical-block (stream nil)
+      (format stream "M~D:~2I ~@_~<~@{S~D ~:_~}~:>~:@_"
+              (metastate-number metastate)
+              (nreverse (mapcar #'state-number (metastate-stack metastate))))
+      (let ((transitions (metastate-transitions metastate)))
+        (dotimes (terminal-number (length transitions))
+          (let ((transition (svref transitions terminal-number))
+                (terminal (svref (grammar-terminals grammar) terminal-number)))
+            (when transition
+              (let ((next-metastate (metatransition-next-metastate transition)))
+                (pprint-logical-block (stream nil)
+                  (format stream "~W ==> ~@_~:I~:[accept~;M~:*~D~] ~_"
+                          terminal
+                          (and next-metastate (metastate-number next-metastate)))
+                  (pprint-fill stream (mapcar #'production-name (metatransition-pre-productions transition)))
+                  (format stream " ~@_")
+                  (pprint-fill stream (mapcar #'production-name (metatransition-post-productions transition))))
+                (pprint-newline :mandatory stream)))))))))
+
+
+(defmethod print-object ((metastate metastate) stream)
+  (print-unreadable-object (metastate stream)
+    (format stream "metastate S~D" (metastate-number metastate))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; METAGRAMMAR
+
+(defstruct (metagrammar (:constructor allocate-metagrammar))
+  (grammar nil :type grammar :read-only t)          ;The grammar to which this metagrammar corresponds
+  (metastates nil :type list :read-only t)          ;List of metastates ordered by metastate numbers
+  (start nil :type metastate :read-only t))         ;The start metastate
+
+
+(defun make-metagrammar (grammar)
+  (let* ((terminals (grammar-terminals grammar))
+         (n-terminals (length terminals))
+         (metastates-hash (make-hash-table :test #'equal))    ;Hash table of (list of state) -> metastate
+         (metastates nil)
+         (metastate-number -1))
+    (labels
+      (;Return the stack after applying the given reduction production.
+       (apply-reduction-production (stack production)
+         (let* ((stack (nthcdr (production-rhs-length production) stack))
+                (state (first stack))
+                (dst-state (assert-non-null
+                            (cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
+                (dst-stack (cons dst-state stack)))
+           (if (member dst-state stack :test #'eq)
+             (error "This grammar cannot be represented by a FSM.  Stack: ~S" dst-stack)
+             dst-stack)))
+       
+       (get-metatransition (stack terminal productions)
+         (let* ((state (first stack))
+                (transition (cdr (assoc terminal (state-transitions state) :test *grammar-symbol-=*))))
+           (when transition
+             (case (transition-kind transition)
+               (:shift
+                (multiple-value-bind (metastate forwarding-productions) (get-metastate (transition-state transition) stack t)
+                  (make-metatransition metastate (nreverse productions) forwarding-productions)))
+               (:reduce
+                (let ((production (transition-production transition)))
+                  (get-metatransition (apply-reduction-production stack production) terminal (cons production productions))))
+               (:accept (make-metatransition nil (nreverse productions) nil))
+               (t (error "Bad transition: ~S" transition))))))
+       
+       ;Return the metastate corresponding to the state stack (stack-top . stack-rest).  Construct a new
+       ;metastate if necessary.
+       ;If simplify is true and stack-top is a state for which every outgoing transition is the same
+       ;reduction, return two values:
+       ;  the metastate reached by following that reduction (doing it recursively if needed)
+       ;  a list of reduction productions followed this way.
+       (get-metastate (stack-top stack-rest simplify)
+         (let* ((stack (cons stack-top stack-rest))
+                (existing-metastate (gethash stack metastates-hash)))
+           (cond
+            (existing-metastate (values existing-metastate nil))
+            ((member stack-top stack-rest :test #'eq)
+             (error "This grammar cannot be represented by a FSM.  Stack: ~S" stack))
+            (t (let ((forwarding-production (and simplify (forwarding-state-production stack-top))))
+                 (if forwarding-production
+                   (let ((stack (apply-reduction-production stack forwarding-production)))
+                     (multiple-value-bind (metastate forwarding-productions) (get-metastate (car stack) (cdr stack) simplify)
+                       (values metastate (cons forwarding-production forwarding-productions))))
+                   (let* ((transitions (make-array n-terminals :initial-element nil))
+                          (metastate (make-metastate stack (incf metastate-number) transitions)))
+                     (setf (gethash stack metastates-hash) metastate)
+                     (push metastate metastates)
+                     (dotimes (n n-terminals)
+                       (setf (svref transitions n)
+                             (get-metatransition stack (svref terminals n) nil)))
+                     (values metastate nil)))))))))
+      
+      (let ((start-metastate (get-metastate (grammar-start-state grammar) nil nil)))
+        (allocate-metagrammar :grammar grammar
+                              :metastates (nreverse metastates)
+                              :start start-metastate)))))
+
+
+; Print the metagrammar nicely.
+(defun print-metagrammar (metagrammar &optional (stream t) &key (grammar t) (details t))
+  (pprint-logical-block (stream nil)
+    (when grammar
+      (print-grammar (metagrammar-grammar metagrammar) stream :details details))
+    
+    ;Print the metastates.
+    (format stream "Start metastate: ~@_M~D~:@_~:@_" (metastate-number (metagrammar-start metagrammar)))
+    (pprint-logical-block (stream (metagrammar-metastates metagrammar))
+      (pprint-exit-if-list-exhausted)
+      (format stream "Metastates:~2I~:@_")
+      (loop
+        (print-metastate (pprint-pop) metagrammar stream)
+        (pprint-exit-if-list-exhausted)
+        (pprint-newline :mandatory stream))))
+  (pprint-newline :mandatory stream))
+
+
+(defmethod print-object ((metagrammar metagrammar) stream)
+  (print-unreadable-object (metagrammar stream :identity t)
+    (write-string "metagrammar" stream)))
+
+
+; Find the longest possible prefix of the input list of tokens that is accepted by the
+; grammar.  Parse that prefix and return two values:
+;   the list of action results;
+;   the tail of the input list of tokens remaining to be parsed.
+; Signal an error if no prefix of the input list is accepted by the grammar.
+;
+; token-terminal is a function that returns a terminal symbol when given an input token.
+; If trace is:
+;   nil,     don't print trace information
+;   :code,   print trace information, including action code
+;   other    print trace information
+(defun action-metaparse (metagrammar token-terminal input &key trace)
+  (if trace
+    (trace-action-metaparse metagrammar token-terminal input trace)
+    (let ((grammar (metagrammar-grammar metagrammar)))
+      (labels
+        ((transition-value-stack (value-stack productions)
+           (dolist (production productions)
+             (setq value-stack (funcall (production-evaluator production) value-stack)))
+           value-stack)
+         
+         (cut (input good-metastate good-input good-value-stack)
+           (unless good-metastate
+             (error "Parse error on ~S ..." (ldiff input (nthcdr 10 input))))
+           (let ((last-metatransition (metastate-transition good-metastate *end-marker-terminal-number*)))
+             (assert-true (null (metatransition-next-metastate last-metatransition)))
+             (assert-true (null (metatransition-post-productions last-metatransition)))
+             (values
+              (reverse (transition-value-stack good-value-stack (metatransition-pre-productions last-metatransition)))
+              good-input))))
+        
+        (do ((metastate (metagrammar-start metagrammar))
+             (input input (cdr input))
+             (value-stack nil)
+             (last-good-metastate nil)
+             last-good-input
+             last-good-value-stack)
+            (nil)
+          (when (metastate-transition metastate *end-marker-terminal-number*)
+            (setq last-good-metastate metastate)
+            (setq last-good-input input)
+            (setq last-good-value-stack value-stack))
+          (when (endp input)
+            (return (cut input last-good-metastate last-good-input last-good-value-stack)))
+          (let* ((token (first input))
+                 (terminal (funcall token-terminal token))
+                 (terminal-number (terminal-number grammar terminal))
+                 (metatransition (metastate-transition metastate terminal-number)))
+            (unless metatransition
+              (return (cut input last-good-metastate last-good-input last-good-value-stack)))
+            (setq value-stack (transition-value-stack value-stack (metatransition-pre-productions metatransition)))
+            (dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
+              (push (funcall (cdr action-function-binding) token) value-stack))
+            (setq value-stack (transition-value-stack value-stack (metatransition-post-productions metatransition)))
+            (setq metastate (metatransition-next-metastate metatransition))))))))
+
+
+; Same as action-parse, but with tracing information
+; If trace is:
+;   :code,   print trace information, including action code
+;   other    print trace information
+(defun trace-action-metaparse (metagrammar token-terminal input trace)
+  (let
+    ((grammar (metagrammar-grammar metagrammar)))
+    (labels
+      ((print-stacks (value-stack type-stack)
+         (write-string "    " *trace-output*)
+         (if value-stack
+           (print-values (reverse value-stack) (reverse type-stack) *trace-output*)
+           (write-string "empty" *trace-output*))
+         (pprint-newline :mandatory *trace-output*))
+       
+       (transition-value-stack (value-stack type-stack productions)
+         (dolist (production productions)
+           (write-string "  reduce " *trace-output*)
+           (if (eq trace :code)
+             (write production :stream *trace-output* :pretty t)
+             (print-production production *trace-output*))
+           (pprint-newline :mandatory *trace-output*)
+           (setq value-stack (funcall (production-evaluator production) value-stack))
+           (setq type-stack (nthcdr (production-n-action-args production) type-stack))
+           (dolist (action-signature (grammar-symbol-signature grammar (production-lhs production)))
+             (push (cdr action-signature) type-stack))
+           (print-stacks value-stack type-stack))
+         (values value-stack type-stack))
+       
+       (cut (input good-metastate good-input good-value-stack good-type-stack)
+         (unless good-metastate
+           (error "Parse error on ~S ..." (ldiff input (nthcdr 10 input))))
+         (let ((last-metatransition (metastate-transition good-metastate *end-marker-terminal-number*)))
+           (assert-true (null (metatransition-next-metastate last-metatransition)))
+           (assert-true (null (metatransition-post-productions last-metatransition)))
+           (format *trace-output* "cut to M~D~:@_" (metastate-number good-metastate))
+           (print-stacks good-value-stack good-type-stack)
+           (pprint-newline :mandatory *trace-output*)
+           (values
+            (reverse (transition-value-stack good-value-stack good-type-stack (metatransition-pre-productions last-metatransition)))
+            good-input))))
+      
+      (do ((metastate (metagrammar-start metagrammar))
+           (input input (cdr input))
+           (value-stack nil)
+           (type-stack nil)
+           (last-good-metastate nil)
+           last-good-input
+           last-good-value-stack
+           last-good-type-stack)
+          (nil)
+        (format *trace-output* "M~D" (metastate-number metastate))
+        (when (metastate-transition metastate *end-marker-terminal-number*)
+          (write-string " (good)" *trace-output*)
+          (setq last-good-metastate metastate)
+          (setq last-good-input input)
+          (setq last-good-value-stack value-stack)
+          (setq last-good-type-stack type-stack))
+        (write-string ": " *trace-output*)
+        (when (endp input)
+          (return (cut input last-good-metastate last-good-input last-good-value-stack last-good-type-stack)))
+        (let* ((token (first input))
+               (terminal (funcall token-terminal token))
+               (terminal-number (terminal-number grammar terminal))
+               (metatransition (metastate-transition metastate terminal-number)))
+          (unless metatransition
+            (format *trace-output* "shift ~W: " terminal)
+            (return (cut input last-good-metastate last-good-input last-good-value-stack last-good-type-stack)))
+          (format *trace-output* "transition to M~D~:@_" (metastate-number (metatransition-next-metastate metatransition)))
+          (multiple-value-setq (value-stack type-stack)
+            (transition-value-stack value-stack type-stack (metatransition-pre-productions metatransition)))
+          (dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
+            (push (funcall (cdr action-function-binding) token) value-stack))
+          (dolist (action-signature (grammar-symbol-signature grammar terminal))
+            (push (cdr action-signature) type-stack))
+          (format *trace-output* "shift ~W~:@_" terminal)
+          (print-stacks value-stack type-stack)
+          (multiple-value-setq (value-stack type-stack)
+            (transition-value-stack value-stack type-stack (metatransition-post-productions metatransition)))
+          (setq metastate (metatransition-next-metastate metatransition)))))))
+
+
+; Compute all representative strings of terminals such that, for each such string S:
+;   S is rejected by the grammar's language;
+;   all prefixes of S are also rejected by the grammar's language;
+;   for any S and all strings of terminals T, the concatenated string ST is also
+;     rejected by the grammar's language;
+;   no string S1 is a prefix of (or equal to) another string S2.
+; Often there are infinitely many such strings S, so only output one for each illegal
+; metaparser transition.
+; Return a list of S's, where each S is itself a list of terminals.
+(defun compute-illegal-strings (metagrammar)
+  (let* ((grammar (metagrammar-grammar metagrammar))
+         (terminals (grammar-terminals grammar))
+         (n-terminals (length terminals))
+         (metastates (metagrammar-metastates metagrammar))
+         (n-metastates (length metastates))
+         (visited-metastates (make-array n-metastates :element-type 'bit :initial-element 0))
+         (illegal-strings nil))
+    (labels
+      ((visit (metastate reversed-string)
+         (let ((metastate-number (metastate-number metastate)))
+           (when (= (sbit visited-metastates metastate-number) 0)
+             (setf (sbit visited-metastates metastate-number) 1)
+             (let ((metatransitions (metastate-transitions metastate)))
+               ;If there is a transition for the end marker from this state, then string
+               ;is accepted by the language, so cut off the search.
+               (unless (svref metatransitions *end-marker-terminal-number*)
+                 (dotimes (terminal-number n-terminals)
+                   (unless (= terminal-number *end-marker-terminal-number*)
+                     (let ((metatransition (svref metatransitions terminal-number))
+                           (reversed-string (cons (svref terminals terminal-number) reversed-string)))
+                       (if metatransition
+                         (visit (metatransition-next-metastate metatransition) reversed-string)
+                         (push (reverse reversed-string) illegal-strings)))))))))))
+      
+      (visit (metagrammar-start metagrammar) nil)
+      (nreverse illegal-strings))))
+
+
+; Compute and print illegal strings of terminals.  See compute-illegal-strings.
+(defun print-illegal-strings (metagrammar &optional (stream t))
+  (pprint-logical-block (stream (compute-illegal-strings metagrammar))
+    (format stream "Illegal strings:~2I")
+    (loop
+      (pprint-exit-if-list-exhausted)
+      (pprint-newline :mandatory stream)
+      (pprint-fill stream (pprint-pop))))
+  (pprint-newline :mandatory stream))

mozilla/js2/semantics/Parser.lisp

@@ -0,0 +1,837 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; LALR(1) and LR(1) grammar generator
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+;;; ------------------------------------------------------------------------------------------------------
+
+; kernel-item-alist is a list of pairs (item . prev), where item is a kernel item
+; and prev is either nil or a laitem.  kernel is a list of the kernel items in a canonical order.
+; Return a new state with the given list of kernel items and state number.
+; If mode is :lalr-1, for each non-null prev in kernel-item-alist, update
+; (laitem-propagates prev) to include the corresponding laitem in the new state.  Do this anyway
+; for internal lookaheads, regardless of mode.
+;
+; If mode is :canonical-lr-1, kernel-item-alist is a list of pairs (item . lookaheads), where
+; lookaheads is a terminalset of lookaheads for that item.  Use these lookaheads instead of
+; initial-lookaheads.
+(defun make-state (grammar kernel kernel-item-alist mode number initial-lookaheads)
+  (let ((laitems nil)
+        (laitems-hash (make-hash-table :test #'eq))
+        (laitems-maybe-forbidden nil)) ;Association list of:  laitem -> terminalset of potentially forbidden terminals; missing means *empty-terminalset*
+    (labels
+      ;Create a laitem for this item and add the association item->laitem to the laitems-hash
+      ;hash table if it's not there already.  Regardless of whether a new laitem was created,
+      ;update the laitem's lookaheads to also include the given lookaheads.
+      ;forbidden is a terminalset of terminals that must not occur immediately after the dot in this
+      ;laitem.  The forbidden set is inherited from constraints in parent laitems in the same state.
+      ;maybe-forbidden is an upper bounds on the forbidden lookaheads in this laitem.
+      ;If prev is non-null, update (laitem-propagates prev) to include the laitem and the given
+      ;passthrough terminalset if it's not already included there.
+      ;If a new laitem was created and its first symbol after the dot exists and is a
+      ;nonterminal A, recursively close items A->.rhs corresponding to all rhs's in the
+      ;grammar's rule for A.
+      ((close-item (item forbidden maybe-forbidden lookaheads prev passthroughs)
+         (let ((production (item-production item))
+               (dot (item-dot item))
+               (laitem (gethash item laitems-hash)))
+           (let ((extra-forbidden (terminalset-complement (general-production-constraint production dot))))
+             (terminalset-union-f forbidden extra-forbidden)
+             (terminalset-union-f maybe-forbidden extra-forbidden))
+           (unless (terminalset-empty? forbidden)
+             (multiple-value-bind (dot-lookaheads dot-passthroughs)
+                                  (string-initial-terminals grammar (item-unseen item) (production-constraints production) (item-dot item) t)
+               (let ((dot-initial (terminalset-union dot-lookaheads dot-passthroughs)))
+                 ;Check whether any terminal can start this item.  If not, skip this item altogether.
+                 (when (terminalset-empty? (terminalset-difference dot-initial forbidden))
+                   ;Mark skipped items in the laitems-hash table.
+                   (when (and laitem (not (eq laitem 'forbidden)))
+                     (error "Two laitems in the same state differing only in forbidden initial terminal constraints: ~S" laitem))
+                   (setf (gethash item laitems-hash) 'forbidden)
+                   (return-from close-item))
+                 ;Convert forbidden into a canonical format by removing terminals that cannot begin this item's expansion anyway.
+                 (terminalset-intersection-f forbidden dot-initial))))
+           (if laitem
+             (let ((laitem-maybe-forbidden-entry (assoc laitem laitems-maybe-forbidden))
+                   (new-forbidden (terminalset-union forbidden (laitem-forbidden laitem))))
+               (when laitem-maybe-forbidden-entry
+                 (terminalset-intersection-f (cdr laitem-maybe-forbidden-entry) maybe-forbidden))
+               (unless (terminalset-<= new-forbidden (or (cdr laitem-maybe-forbidden-entry) *empty-terminalset*))
+                 (error "Two laitems in the same state differing only in forbidden initial terminal constraints: ~S ~%old forbidden: ~S ~%new forbidden: ~S~%maybe forbidden: ~S"
+                        laitem
+                        (terminalset-list grammar (laitem-forbidden laitem))
+                        (terminalset-list grammar forbidden)
+                        (and laitem-maybe-forbidden-entry (terminalset-list grammar (cdr laitem-maybe-forbidden-entry)))))
+               (setf (laitem-forbidden laitem) new-forbidden)
+               (terminalset-union-f (laitem-lookaheads laitem) lookaheads))
+             (let ((item-next-symbol (item-next-symbol item)))
+               (setq laitem (allocate-laitem grammar item forbidden lookaheads))
+               (push laitem laitems)
+               (setf (gethash item laitems-hash) laitem)
+               (unless (terminalset-empty? maybe-forbidden)
+                 (push (cons laitem maybe-forbidden) laitems-maybe-forbidden))
+               (when (nonterminal? item-next-symbol)
+                 (multiple-value-bind (next-lookaheads next-passthroughs)
+                                      (string-initial-terminals grammar (rest (item-unseen item)) (production-constraints production) (1+ dot) nil)
+                   (let ((next-prev (and (not (terminalset-empty? next-passthroughs)) laitem)))
+                     (dolist (production (rule-productions (grammar-rule grammar item-next-symbol)))
+                       (close-item (make-item grammar production 0) forbidden maybe-forbidden next-lookaheads next-prev next-passthroughs)))))))
+           (when prev
+             (laitem-add-propagation prev laitem passthroughs)))))
+      
+      (dolist (acons kernel-item-alist)
+        (close-item (car acons) 
+                    *empty-terminalset*
+                    *empty-terminalset*
+                    (if (eq mode :canonical-lr-1) (cdr acons) initial-lookaheads)
+                    (and (eq mode :lalr-1) (cdr acons))
+                    *full-terminalset*))
+      (allocate-state number kernel (nreverse laitems)))))
+
+
+; f is a function that takes three arguments:
+;   a grammar symbol;
+;   a list of kernel items in order of increasing item number [list of (item . lookahead) when mode is :canonical-lr-1];
+;   a list of pairs (item . prev), where item is a kernel item and prev is a laitem.
+; For each possible symbol X that can be shifted while in the given state S, call
+; f giving it S and the list of items that constitute the kernel of that shift's destination
+; state.  The prev's are the sources of the corresponding shifted items.
+(defun state-each-shift-item-alist (f state mode)
+  (let ((shift-symbols-hash (make-hash-table :test *grammar-symbol-=*)))
+    (dolist (source-laitem (state-laitems state))
+      (let* ((source-item (laitem-item source-laitem))
+             (shift-symbol (item-next-symbol source-item)))
+        (when shift-symbol
+          (push (cons (item-next source-item) source-laitem)
+                (gethash shift-symbol shift-symbols-hash)))))
+    ;Use dolist/gethash instead of maphash to make state assignments deterministic.
+    (dolist (shift-symbol (sorted-hash-table-keys shift-symbols-hash))
+      (let* ((kernel-item-alist (gethash shift-symbol shift-symbols-hash))
+             (kernel (if (eq mode :canonical-lr-1)
+                       (sort (mapcar #'(lambda (acons)
+                                         (cons (car acons) (laitem-lookaheads (cdr acons))))
+                                     kernel-item-alist)
+                             #'<
+                             :key #'(lambda (acons) (item-number (car acons))))
+                       (sort (mapcar #'car kernel-item-alist) #'< :key #'item-number))))
+        (funcall f shift-symbol kernel kernel-item-alist)))))
+
+
+; f is a function that takes a terminal variant as an argument.
+; For each variant of the given terminal (which, along with kernel-item-alist, was obtained from
+; state-each-shift-item-alist's callback), determine whether that variant can actually occur at the
+; current position or whether it is forbidden by constraints.  If it can occur, call f with that variant.
+; Signal an error if some laitems in kernel-item-alist indicate that a variant can occur while others
+; indicate that the same variant cannot occur.  Also signal an internal error if no variant can occur, as
+; make-state should have filtered such shift items out.
+(defun each-shift-symbol-variant (f grammar terminal kernel-item-alist)
+  (let ((n-applicable-variants 0))
+    (dolist (variant (terminal-variants grammar terminal))
+      (let ((allowed nil)
+            (forbidden nil))
+        (dolist (acons kernel-item-alist)
+          (if (terminal-in-terminalset grammar variant (laitem-forbidden (cdr acons)))
+            (setq forbidden t)
+            (setq allowed t)))
+        (when (eq allowed forbidden)
+          (error "Symbol ~S ~A" variant
+                 (if allowed "both allowed and forbidden" "neither allowed nor forbidden")))
+        (unless forbidden
+          (incf n-applicable-variants)
+          (funcall f variant))))
+    (when (zerop n-applicable-variants)
+      (error "Internal parser error"))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; CANONICAL LR(1)
+;;;
+;;; Canonical LR(1) is accepts the same set of languages as LR(1) except that it produces vastly larger,
+;;; unoptimizied state tables.  The only advantage to using Canonical LR(1) instead of LR(1) is that
+;;; a Canonical LR(1) parser will not make any reductions from an error state, whereas a LR(1) or LALR(1)
+;;; parser might make reductions (but not shifts).  In other words, a Canonical LR(1) parser's shift and
+;;; reduce tables are fully accurate rather than conservative approximations based on merged states.
+
+
+; Make all states in the grammar and return the initial state.
+; Initialize the grammar's list of states.
+; Initialize the states' gotos lists.
+; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
+(defun add-all-canonical-lr-states (grammar)
+  (let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
+         (lr-states-hash (make-hash-table :test #'equal))  ;canonical kernel -> state
+         (initial-kernel (list (cons initial-item (make-terminalset grammar *end-marker*))))
+         (initial-state (make-state grammar initial-kernel initial-kernel :canonical-lr-1 0 nil))
+         (states (list initial-state))
+         (next-state-number 1))
+    (setf (gethash initial-kernel lr-states-hash) initial-state)
+    (do ((source-states (list initial-state)))
+        ((endp source-states))
+      (let ((source-state (pop source-states)))
+        ;Propagate the source state's internal lookaheads and then erase the propagates chains.
+        (propagate-internal-lookaheads source-state)
+        (dolist (laitem (state-laitems source-state))
+          (setf (laitem-propagates laitem) nil))
+        
+        (state-each-shift-item-alist
+         #'(lambda (shift-symbol kernel kernel-item-alist)
+             (let ((destination-state (gethash kernel lr-states-hash)))
+               (unless destination-state
+                 (setq destination-state (make-state grammar kernel kernel :canonical-lr-1 next-state-number nil))
+                 (setf (gethash kernel lr-states-hash) destination-state)
+                 (incf next-state-number)
+                 (push destination-state states)
+                 (push destination-state source-states))
+               (if (nonterminal? shift-symbol)
+                 (push (cons shift-symbol destination-state)
+                       (state-gotos source-state))
+                 (each-shift-symbol-variant
+                  #'(lambda (shift-symbol-variant)
+                      (push (cons shift-symbol-variant (make-shift-transition destination-state))
+                            (state-transitions source-state)))
+                  grammar shift-symbol kernel-item-alist))))
+         source-state :canonical-lr-1)))
+    (setf (grammar-states grammar) (nreverse states))
+    initial-state))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; LR(1)
+
+
+; kernel-item-alist should have the same kernel items as state.
+; Return true if the prev lookaheads in kernel-item-alist are the same as or subsets of
+; the corresponding lookaheads in the state's kernel laitems.
+(defun state-subsumes-lookaheads (state kernel-item-alist)
+  (every
+   #'(lambda (acons)
+       (terminalset-<= (laitem-lookaheads (cdr acons))
+                       (laitem-lookaheads (state-laitem state (car acons)))))
+   kernel-item-alist))
+
+
+; kernel-item-alist should have the same kernel items as state.
+; Return true if the prev lookaheads in kernel-item-alist are weakly compatible
+; with the lookaheads in the state's kernel laitems.
+(defun state-weakly-compatible (state kernel-item-alist)
+  (labels
+    ((lookahead-weakly-compatible (lookahead1a lookahead1b lookahead2a lookahead2b)
+       (or (and (terminalsets-disjoint lookahead1a lookahead2b)
+                (terminalsets-disjoint lookahead1b lookahead2a))
+           (not (terminalsets-disjoint lookahead1a lookahead1b))
+           (not (terminalsets-disjoint lookahead2a lookahead2b))))
+     
+     (lookahead-list-weakly-compatible (lookahead1a lookaheads1 lookahead2a lookaheads2)
+       (or (endp lookaheads1)
+           (and (lookahead-weakly-compatible lookahead1a (first lookaheads1) lookahead2a (first lookaheads2))
+                (lookahead-list-weakly-compatible lookahead1a (rest lookaheads1) lookahead2a (rest lookaheads2)))))
+     
+     (lookahead-lists-weakly-compatible (lookaheads1 lookaheads2)
+       (or (endp lookaheads1)
+           (and (lookahead-list-weakly-compatible (first lookaheads1) (rest lookaheads1) (first lookaheads2) (rest lookaheads2))
+                (lookahead-lists-weakly-compatible (rest lookaheads1) (rest lookaheads2))))))
+    
+    (or (= (length kernel-item-alist) 1)
+        (lookahead-lists-weakly-compatible
+         (mapcar #'(lambda (acons) (laitem-lookaheads (state-laitem state (car acons)))) kernel-item-alist)
+         (mapcar #'(lambda (acons) (laitem-lookaheads (cdr acons))) kernel-item-alist)))))
+
+
+; Propagate all lookaheads in the state.
+(defun propagate-internal-lookaheads (state)
+  (do ((changed t))
+      ((not changed))
+    (setq changed nil)
+    (dolist (src-laitem (state-laitems state))
+      (let ((src-lookaheads (laitem-lookaheads src-laitem)))
+        (dolist (propagation (laitem-propagates src-laitem))
+          (let* ((dst-laitem (car propagation))
+                 (mask (cdr propagation))
+                 (old-dst-lookaheads (laitem-lookaheads dst-laitem))
+                 (new-dst-lookaheads (terminalset-union old-dst-lookaheads (terminalset-intersection src-lookaheads mask))))
+            (setf (laitem-lookaheads dst-laitem) new-dst-lookaheads)
+            (unless (terminalset-= old-dst-lookaheads new-dst-lookaheads)
+              (setq changed t))))))))
+
+
+; Propagate all lookaheads in kernel-item-alist, which must target destination-state.
+; Mark destination-state as dirty in the dirty-states hash table.
+(defun propagate-external-lookaheads (kernel-item-alist destination-state dirty-states)
+  (dolist (acons kernel-item-alist)
+    (let ((dest-laitem (state-laitem destination-state (car acons)))
+          (src-laitem (cdr acons)))
+      (terminalset-union-f (laitem-lookaheads dest-laitem) (laitem-lookaheads src-laitem))))
+  (setf (gethash destination-state dirty-states) t))
+
+
+; Make all states in the grammar and return the initial state.
+; Initialize the grammar's list of states.
+; Initialize the states' gotos lists.
+; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
+(defun add-all-lr-states (grammar)
+  (let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
+         (lr-states-hash (make-hash-table :test #'equal))  ;kernel -> list of states with that kernel
+         (initial-kernel (list initial-item))
+         (initial-state (make-state grammar initial-kernel (list (cons initial-item nil)) :lr-1 0 (make-terminalset grammar *end-marker*)))
+         (states (list initial-state))
+         (next-state-number 1))
+    (setf (gethash initial-kernel lr-states-hash) (list initial-state))
+    (do ((source-states (list initial-state))
+         (dirty-states (make-hash-table :test #'eq)))      ;Set of states whose kernel lookaheads changed and haven't been propagated yet
+        ((and (endp source-states) (zerop (hash-table-count dirty-states))))
+      (labels
+        ((make-destination-state (kernel kernel-item-alist)
+           (let* ((possible-destination-states (gethash kernel lr-states-hash))
+                  (destination-state (find-if #'(lambda (possible-destination-state)
+                                                  (state-subsumes-lookaheads possible-destination-state kernel-item-alist))
+                                              possible-destination-states)))
+             (cond
+              (destination-state)
+              ((setq destination-state (find-if #'(lambda (possible-destination-state)
+                                                    (state-weakly-compatible possible-destination-state kernel-item-alist))
+                                                possible-destination-states))
+               (propagate-external-lookaheads kernel-item-alist destination-state dirty-states))
+              (t
+               (setq destination-state (make-state grammar kernel kernel-item-alist :lr-1 next-state-number *empty-terminalset*))
+               (propagate-external-lookaheads kernel-item-alist destination-state dirty-states)
+               (push destination-state (gethash kernel lr-states-hash))
+               (incf next-state-number)
+               (push destination-state states)
+               (push destination-state source-states)))
+             destination-state))
+         
+         (update-destination-state (destination-state kernel-item-alist)
+           (cond
+            ((state-subsumes-lookaheads destination-state kernel-item-alist)
+             destination-state)
+            ((state-weakly-compatible destination-state kernel-item-alist)
+             (propagate-external-lookaheads kernel-item-alist destination-state dirty-states)
+             destination-state)
+            (t (make-destination-state (state-kernel destination-state) kernel-item-alist)))))
+        
+        (if source-states
+          (let ((source-state (pop source-states)))
+            (remhash source-state dirty-states)
+            (propagate-internal-lookaheads source-state)
+            (state-each-shift-item-alist
+             #'(lambda (shift-symbol kernel kernel-item-alist)
+                 (let ((destination-state (make-destination-state kernel kernel-item-alist)))
+                   (if (nonterminal? shift-symbol)
+                     (push (cons shift-symbol destination-state)
+                           (state-gotos source-state))
+                     (each-shift-symbol-variant
+                      #'(lambda (shift-symbol-variant)
+                          (push (cons shift-symbol-variant (make-shift-transition destination-state))
+                                (state-transitions source-state)))
+                      grammar shift-symbol kernel-item-alist))))
+             source-state :lr-1))
+          (dolist (dirty-state (sort (hash-table-keys dirty-states) #'< :key #'state-number))
+            (when (remhash dirty-state dirty-states)
+              (propagate-internal-lookaheads dirty-state)
+              (state-each-shift-item-alist
+               #'(lambda (shift-symbol kernel kernel-item-alist)
+                   (declare (ignore kernel))
+                   (if (nonterminal? shift-symbol)
+                     (let* ((destination-binding (assoc shift-symbol (state-gotos dirty-state) :test *grammar-symbol-=*))
+                            (destination-state (assert-non-null (cdr destination-binding))))
+                       (setf (cdr destination-binding) (update-destination-state destination-state kernel-item-alist)))
+                     (each-shift-symbol-variant
+                      #'(lambda (shift-symbol-variant)
+                          (let* ((destination-transition (state-transition dirty-state shift-symbol-variant))
+                                 (destination-state (assert-non-null (transition-state destination-transition))))
+                            (setf (transition-state destination-transition)
+                                  (update-destination-state destination-state kernel-item-alist))))
+                      grammar shift-symbol kernel-item-alist)))
+               dirty-state :lr-1))))))
+    (setf (grammar-states grammar) (nreverse states))
+    initial-state))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; LALR(1)
+
+
+; Make all states in the grammar and return the initial state.
+; Initialize the grammar's list of states.
+; Set up the laitems' propagate lists but do not propagate lookaheads yet.
+; Initialize the states' gotos lists.
+; Initialize the states' shift (but not reduce or accept) transitions in the transitions lists.
+(defun add-all-lalr-states (grammar)
+  (let* ((initial-item (make-item grammar (grammar-start-production grammar) 0))
+         (lalr-states-hash (make-hash-table :test #'equal))  ;kernel -> state
+         (initial-kernel (list initial-item))
+         (initial-state (make-state grammar initial-kernel (list (cons initial-item nil)) :lalr-1 0 (make-terminalset grammar *end-marker*)))
+         (states (list initial-state))
+         (next-state-number 1))
+    (setf (gethash initial-kernel lalr-states-hash) initial-state)
+    (do ((source-states (list initial-state)))
+        ((endp source-states))
+      (let ((source-state (pop source-states)))
+        (state-each-shift-item-alist
+         #'(lambda (shift-symbol kernel kernel-item-alist)
+             (let ((destination-state (gethash kernel lalr-states-hash)))
+               (if destination-state
+                 (dolist (acons kernel-item-alist)
+                   (laitem-add-propagation (cdr acons) (state-laitem destination-state (car acons)) *full-terminalset*))
+                 (progn
+                   (setq destination-state (make-state grammar kernel kernel-item-alist :lalr-1 next-state-number *empty-terminalset*))
+                   (setf (gethash kernel lalr-states-hash) destination-state)
+                   (incf next-state-number)
+                   (push destination-state states)
+                   (push destination-state source-states)))
+               (if (nonterminal? shift-symbol)
+                 (push (cons shift-symbol destination-state)
+                       (state-gotos source-state))
+                 (each-shift-symbol-variant
+                  #'(lambda (shift-symbol-variant)
+                      (push (cons shift-symbol-variant (make-shift-transition destination-state))
+                            (state-transitions source-state)))
+                  grammar shift-symbol kernel-item-alist))))
+         source-state :lalr-1)))
+    (setf (grammar-states grammar) (nreverse states))
+    initial-state))
+
+
+; Propagate the lookaheads in the LALR(1) grammar.
+(defun propagate-lalr-lookaheads (grammar)
+  (let ((dirty-laitems (make-hash-table :test #'eq)))
+    (dolist (state (grammar-states grammar))
+      (dolist (laitem (state-laitems state))
+        (when (and (laitem-propagates laitem) (not (terminalset-empty? (laitem-lookaheads laitem))))
+          (setf (gethash laitem dirty-laitems) t))))
+    (do ()
+        ((zerop (hash-table-count dirty-laitems)))
+      (dolist (dirty-laitem (hash-table-keys dirty-laitems))
+        (remhash dirty-laitem dirty-laitems)
+        (let ((src-lookaheads (laitem-lookaheads dirty-laitem)))
+          (dolist (propagation (laitem-propagates dirty-laitem))
+            (let ((dst-laitem (car propagation))
+                  (mask (cdr propagation)))
+              (let* ((old-dst-lookaheads (laitem-lookaheads dst-laitem))
+                     (new-dst-lookaheads (terminalset-union old-dst-lookaheads (terminalset-intersection src-lookaheads mask))))
+                (unless (terminalset-= old-dst-lookaheads new-dst-lookaheads)
+                  (setf (laitem-lookaheads dst-laitem) new-dst-lookaheads)
+                  (setf (gethash dst-laitem dirty-laitems) t))))))))
+    
+    ;Erase the propagates chains in all laitems.
+    (dolist (state (grammar-states grammar))
+      (dolist (laitem (state-laitems state))
+        (setf (laitem-propagates laitem) nil)))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+
+
+; Calculate the reduce and accept transitions in the grammar.
+; Also sort all transitions by their terminal numbers and gotos by their nonterminal numbers.
+; Conflicting transitions are sorted as follows:
+;    shifts come before reduces and accepts
+;    accepts come before reduces
+;    reduces with lower production numbers come before reduces with higher production numbers
+; Disambiguation will choose the first member of a sorted list of conflicting transitions.
+(defun finish-transitions (grammar)
+  (dolist (state (grammar-states grammar))
+    (dolist (laitem (state-laitems state))
+      (let ((item (laitem-item laitem)))
+        (unless (item-next-symbol item)
+          (let ((lookaheads (terminalset-difference
+                             (terminalset-intersection
+                              (laitem-lookaheads laitem)
+                              (general-production-constraint (item-production item) (item-dot item)))
+                             (laitem-forbidden laitem))))
+            (if (grammar-symbol-= (item-lhs item) *start-nonterminal*)
+              (when (terminal-in-terminalset grammar *end-marker* lookaheads)
+                (push (cons *end-marker* (make-accept-transition))
+                      (state-transitions state)))
+              (map-terminalset-reverse
+               #'(lambda (lookahead)
+                   (push (cons lookahead (make-reduce-transition (item-production item)))
+                         (state-transitions state)))
+               grammar
+               lookaheads))))))
+    (setf (state-gotos state)
+          (sort (state-gotos state) #'< :key #'(lambda (goto-cons) (state-number (cdr goto-cons)))))
+    (setf (state-transitions state)
+          (sort (state-transitions state)
+                #'(lambda (transition-cons-1 transition-cons-2)
+                    (let ((terminal-number-1 (terminal-number grammar (car transition-cons-1)))
+                          (terminal-number-2 (terminal-number grammar (car transition-cons-2))))
+                      (cond
+                       ((< terminal-number-1 terminal-number-2) t)
+                       ((> terminal-number-1 terminal-number-2) nil)
+                       (t (let* ((transition1 (cdr transition-cons-1))
+                                 (transition2 (cdr transition-cons-2))
+                                 (transition-kind-1 (transition-kind transition1))
+                                 (transition-kind-2 (transition-kind transition2)))
+                            (cond
+                             ((eq transition-kind-2 :shift) nil)
+                             ((eq transition-kind-1 :shift) t)
+                             ((eq transition-kind-2 :accept) nil)
+                             ((eq transition-kind-1 :accept) t)
+                             (t (let ((production-number-1 (production-number (transition-production transition1)))
+                                      (production-number-2 (production-number (transition-production transition2))))
+                                  (< production-number-1 production-number-2)))))))))))))
+
+
+; Find ambiguities, if any, in the grammar.  Report them on the given stream.
+; Fix all ambiguities in favor of the first transition listed
+; (the transitions were ordered by finish-transitions).
+; Return true if ambiguities were found.
+(defun report-and-fix-ambiguities (grammar stream)
+  (let ((found-ambiguities nil))
+    (dolist (state (grammar-states grammar))
+      (labels
+        
+        ((report-ambiguity (transition-cons other-transition-conses)
+           (unless found-ambiguities
+             (setq found-ambiguities t)
+             (format stream "~&Ambiguities:"))
+           (write-char #\newline stream)
+           (pprint-logical-block (stream nil)
+             (format stream "S~D: ~W => " (state-number state) (car transition-cons))
+             (pprint-logical-block (stream nil)
+               (dolist (a (cons transition-cons other-transition-conses))
+                 (print-transition (cdr a) stream)
+                 (format stream "   ~:_")))))
+         
+         ; Check the list of transition-conses and report ambiguities.
+         ; start is the start of a possibly larger list of transition-conses whose tail
+         ; is the given list.  If ambiguities exist, return a copy of start up to the
+         ; position of list in it followed by list with ambiguities removed.  If not,
+         ; return start unchanged.
+         (check (transition-conses start)
+           (if transition-conses
+             (let* ((transition-cons (first transition-conses))
+                    (transition-terminal (car transition-cons))
+                    (transition-conses-rest (rest transition-conses)))
+               (if transition-conses-rest
+                 (if (grammar-symbol-= transition-terminal (car (first transition-conses-rest)))
+                   (let ((unrelated-transitions
+                          (member-if #'(lambda (a) (not (grammar-symbol-= transition-terminal (car a))))
+                                     transition-conses-rest)))
+                     (report-ambiguity transition-cons (ldiff transition-conses-rest unrelated-transitions))
+                     (check unrelated-transitions (append (ldiff start transition-conses-rest) unrelated-transitions)))
+                   (check transition-conses-rest start))
+                 start))
+             start)))
+        
+        (let ((transition-conses (state-transitions state)))
+          (setf (state-transitions state) (check transition-conses transition-conses)))))
+    (when found-ambiguities
+      (write-char #\newline stream))
+    found-ambiguities))
+
+
+; Remove the temporary item and laitem lists from the grammar's states.  This reduces the grammar's lisp
+; heap usage but prevents it from being printed.
+(defun clean-grammar (grammar)
+  (when (grammar-items-hash grammar)
+    (setf (grammar-items-hash grammar) nil)
+    (dolist (state (grammar-states grammar))
+      (setf (state-kernel state) nil)
+      (setf (state-laitems state) nil))))
+
+
+; Erase the existing parser, if any, for the given grammar.
+(defun clear-parser (grammar)
+  (setf (grammar-items-hash grammar) nil)
+  (setf (grammar-states grammar) nil))
+
+
+; Construct a LR or LALR parser in the given grammar.  kind should be :lalr-1, :lr-1, or :canonical-lr-1.
+; Return true if ambiguities were found.
+(defun compile-parser (grammar kind)
+  (clear-parser grammar)
+  (setf (grammar-items-hash grammar) (make-hash-table :test #'equal))
+  (ecase kind
+    (:lalr-1
+     (add-all-lalr-states grammar)
+     (propagate-lalr-lookaheads grammar))
+    (:lr-1
+     (add-all-lr-states grammar))
+    (:canonical-lr-1
+     (add-all-canonical-lr-states grammar)))
+  (finish-transitions grammar)
+  (report-and-fix-ambiguities grammar *error-output*))
+
+
+
+; (cons (list <kind> <start-symbol> <grammar-source> <grammar-options>) <grammar>)
+(defvar *make-and-compile-grammar-cache* (cons nil nil))
+
+; Make the grammar and compile its parser.  kind should be :lalr-1, :lr-1, or :canonical-lr-1.
+(defun make-and-compile-grammar (kind parametrization start-symbol grammar-source &rest grammar-options)
+  (let ((key (list kind start-symbol grammar-source grammar-options))
+        (cached-grammar (cdr *make-and-compile-grammar-cache*)))
+    (if (and (equal key (car *make-and-compile-grammar-cache*))
+             (grammar-parametrization-= parametrization cached-grammar))
+      (progn
+        (format *trace-output* "Re-using grammar ~S ~S ~S~%" kind start-symbol grammar-options)
+        cached-grammar)
+      (let* ((grammar (apply #'make-grammar parametrization start-symbol grammar-source grammar-options))
+             (found-ambiguities (compile-parser grammar kind)))
+        (setq *make-and-compile-grammar-cache*
+              (if found-ambiguities
+                (cons nil nil)
+                (cons key grammar)))
+        grammar))))
+
+
+; Collapse states that have at most one possible reduction into forwarding states.
+; DON'T DO THIS ON GRAMMARS THAT HAVE CONSTRAINTS AT THE TAIL END OF A PRODUCTION.
+; Return the number of states optimized.
+(defun forward-parser-states (grammar)
+  (let ((n-forwarded-states 0))
+    (dolist (state (grammar-states grammar))
+      (let ((production (forwarding-state-production state)))
+        (when production
+          (setf (state-transitions state) (list (cons nil (make-reduce-transition production))))
+          (incf n-forwarded-states))))
+    n-forwarded-states))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+
+; Parse the input list of tokens to produce a parse tree.
+; token-terminal is a function that returns a terminal symbol when given an input token.
+(defun parse (grammar token-terminal input)
+  (labels
+    (;Continue the parse with the given parser stack and remainder of input.
+     (parse-step (stack input)
+       (if (endp input)
+         (parse-step-1 stack *end-marker* nil nil)
+         (let ((token (first input)))
+           (parse-step-1 stack (funcall token-terminal token) token (rest input)))))
+     
+     ;Same as parse-step except that the next input terminal has been determined already.
+     ;input-rest contains the input tokens after the next token.
+     (parse-step-1 (stack terminal token input-rest)
+       (let* ((state (caar stack))
+              (transition (state-transition state terminal)))
+         (if transition
+           (case (transition-kind transition)
+             (:shift (parse-step (acons (transition-state transition) token stack) input-rest))
+             (:reduce (let ((production (transition-production transition))
+                            (expansion nil))
+                        (dotimes (i (production-rhs-length production))
+                          (push (cdr (pop stack)) expansion))
+                        (let* ((state (caar stack))
+                               (dst-state (assert-non-null
+                                           (cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
+                               (named-expansion (cons (production-name production) expansion)))
+                          (parse-step-1 (acons dst-state named-expansion stack) terminal token input-rest))))
+             (:accept (cdar stack))
+             (t (error "Bad transition: ~S" transition)))
+           (error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
+    
+    (parse-step (list (cons (grammar-start-state grammar) nil)) input)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; ACTIONS
+
+; Initialize the action-signatures hash table, setting each grammar symbol's signature
+; to null for now.  Also clear all production actions in the grammar.
+(defun clear-actions (grammar)
+  (let ((action-signatures (make-hash-table :test *grammar-symbol-=*))
+        (terminals (grammar-terminals grammar))
+        (nonterminals (grammar-nonterminals grammar)))
+    (dotimes (i (length terminals))
+      (setf (gethash (svref terminals i) action-signatures) nil))
+    (dotimes (i (length nonterminals))
+      (setf (gethash (svref nonterminals i) action-signatures) nil))
+    (setf (grammar-action-signatures grammar) action-signatures)
+    (each-grammar-production
+     grammar
+     #'(lambda (production)
+         (setf (production-actions production) nil)
+         (setf (production-n-action-args production) nil)
+         (setf (production-evaluator-code production) nil)
+         (setf (production-evaluator production) nil)))
+    (clrhash (grammar-terminal-actions grammar))))
+
+
+; Declare the type of action action-symbol, when called on general-grammar-symbol, to be type-expr.
+; Signal an error on duplicate actions.
+; It's OK if some of the symbol instances don't exist, as long as at least one does.
+(defun declare-action (grammar general-grammar-symbol action-symbol type-expr)
+  (unless (and action-symbol (symbolp action-symbol))
+    (error "Bad action name ~S" action-symbol))
+  (let ((action-signatures (grammar-action-signatures grammar))
+        (grammar-symbols (general-grammar-symbol-instances grammar general-grammar-symbol))
+        (symbol-exists nil))
+    (dolist (grammar-symbol grammar-symbols)
+      (let ((signature (gethash grammar-symbol action-signatures :undefined)))
+        (unless (eq signature :undefined)
+          (setq symbol-exists t)
+          (when (assoc action-symbol signature :test #'eq)
+            (error "Attempt to redefine the type of action ~S on ~S" action-symbol grammar-symbol))
+          (setf (gethash grammar-symbol action-signatures)
+                (nconc signature (list (cons action-symbol type-expr))))
+          (if (nonterminal? grammar-symbol)
+            (dolist (production (rule-productions (grammar-rule grammar grammar-symbol)))
+              (setf (production-actions production)
+                    (nconc (production-actions production) (list (cons action-symbol nil)))))
+            (let ((terminal-actions (grammar-terminal-actions grammar)))
+              (assert-type grammar-symbol terminal)
+              (setf (gethash grammar-symbol terminal-actions)
+                    (nconc (gethash grammar-symbol terminal-actions) (list (cons action-symbol nil)))))))))
+    (unless symbol-exists
+      (error "Bad action grammar symbol ~S" grammar-symbols))))
+
+
+; Return the list of pairs (action-symbol . type-or-type-expr) for this grammar-symbol.
+; The pairs are in order from oldest to newest action-symbols added to this grammar-symbol.
+(declaim (inline grammar-symbol-signature))
+(defun grammar-symbol-signature (grammar grammar-symbol)
+  (gethash grammar-symbol (grammar-action-signatures grammar)))
+
+
+; Return the list of action types of the grammar's user start-symbol.
+(defun grammar-user-start-action-types (grammar)
+  (mapcar #'cdr (grammar-symbol-signature grammar (gramar-user-start-symbol grammar))))
+
+
+; If action action-symbol is declared on grammar-symbol, return two values:
+;   t, and
+;   the action's type-expr;
+; If not, return nil.
+(defun action-declaration (grammar grammar-symbol action-symbol)
+  (let ((declaration (assoc action-symbol (grammar-symbol-signature grammar grammar-symbol) :test #'eq)))
+    (and declaration
+         (values t (cdr declaration)))))
+
+
+; Call f on every action declaration, passing it two arguments:
+;   the grammar-symbol;
+;   a pair (action-symbol . type-expr).
+; f may modify the action's type-expr.
+(defun each-action-declaration (grammar f)
+  (maphash #'(lambda (grammar-symbol signature)
+               (dolist (action-declaration signature)
+                 (funcall f grammar-symbol action-declaration)))
+           (grammar-action-signatures grammar)))
+
+
+; Define action action-symbol, when called on the production with the given name,
+; to be action-expr.  The action should have been declared already.
+(defun define-action (grammar production-name action-symbol action-expr)
+  (dolist (production (general-production-productions (grammar-general-production grammar production-name)))
+    (let ((definition (assoc action-symbol (production-actions production) :test #'eq)))
+      (cond
+       ((null definition)
+        (error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol production-name))
+       ((cdr definition)
+        (error "Duplicate definition of action ~S on ~S" action-symbol production-name))
+       (t (setf (cdr definition) (make-action action-expr)))))))
+
+
+; Define action action-symbol, when called on the given terminal,
+; to execute the given function, which should take a token as an input and
+; produce a value of the proper type as output.
+; The action should have been declared already.
+(defun define-terminal-action (grammar terminal action-symbol action-function)
+  (assert-type action-function function)
+  (let ((definition (assoc action-symbol (gethash terminal (grammar-terminal-actions grammar)) :test #'eq)))
+    (cond
+     ((null definition)
+      (error "Attempt to define action ~S on ~S, which hasn't been declared yet" action-symbol terminal))
+     ((cdr definition)
+      (error "Duplicate definition of action ~S on ~S" action-symbol terminal))
+     (t (setf (cdr definition) action-function)))))
+
+
+
+; Parse the input list of tokens to produce a list of action results.
+; token-terminal is a function that returns a terminal symbol when given an input token.
+; If trace is:
+;   nil,     don't print trace information
+;   :code,   print trace information, including action code
+;   other    print trace information
+; Return two values:
+;   the list of action results;
+;   the list of action results' types.
+(defun action-parse (grammar token-terminal input &key trace)
+  (labels
+    (;Continue the parse with the given stacks and remainder of input.
+     ;When trace is non-null, type-stack contains the types of corresponding value-stack entries.
+     (parse-step (state-stack value-stack type-stack input)
+       (if (endp input)
+         (parse-step-1 state-stack value-stack type-stack *end-marker* nil nil)
+         (let ((token (first input)))
+           (parse-step-1 state-stack value-stack type-stack (funcall token-terminal token) token (rest input)))))
+     
+     ;Same as parse-step except that the next input terminal has been determined already.
+     ;input-rest contains the input tokens after the next token.
+     (parse-step-1 (state-stack value-stack type-stack terminal token input-rest)
+       (let* ((state (car state-stack))
+              (transition (state-transition state terminal)))
+         (when trace
+           (format *trace-output* "S~D: ~@_" (state-number state))
+           (print-values (reverse value-stack) (reverse type-stack) *trace-output*)
+           (pprint-newline :mandatory *trace-output*))
+         (if transition
+           (case (transition-kind transition)
+             (:shift
+              (when trace
+                (format *trace-output* "  shift ~W~:@_" terminal)
+                (dolist (action-signature (grammar-symbol-signature grammar terminal))
+                  (push (cdr action-signature) type-stack)))
+              (dolist (action-function-binding (gethash terminal (grammar-terminal-actions grammar)))
+                (push (funcall (cdr action-function-binding) token) value-stack))
+              (parse-step (cons (transition-state transition) state-stack) value-stack type-stack input-rest))
+             
+             (:reduce
+              (let ((production (transition-production transition)))
+                (when trace
+                  (write-string "  reduce " *trace-output*)
+                  (if (eq trace :code)
+                    (write production :stream *trace-output* :pretty t)
+                    (print-production production *trace-output*))
+                  (pprint-newline :mandatory *trace-output*))
+                (let* ((state-stack (nthcdr (production-rhs-length production) state-stack))
+                       (state (car state-stack))
+                       (dst-state (assert-non-null
+                                   (cdr (assoc (production-lhs production) (state-gotos state) :test *grammar-symbol-=*))))
+                       (value-stack (funcall (production-evaluator production) value-stack)))
+                  (when trace
+                    (setq type-stack (nthcdr (production-n-action-args production) type-stack))
+                    (dolist (action-signature (grammar-symbol-signature grammar (production-lhs production)))
+                      (push (cdr action-signature) type-stack)))
+                  (parse-step-1 (cons dst-state state-stack) value-stack type-stack terminal token input-rest))))
+             
+             (:accept
+              (when trace
+                (format *trace-output* "  accept~:@_"))
+              (values
+               (nreverse value-stack)
+               (if trace
+                 (nreverse type-stack)
+                 (grammar-user-start-action-types grammar))))
+             
+             (t (error "Bad transition: ~S" transition)))
+           (error "Parse error on ~S followed by ~S ..." token (ldiff input-rest (nthcdr 10 input-rest)))))))
+    
+    (parse-step (list (grammar-start-state grammar)) nil nil input)))
+

mozilla/js2/semantics/README

@@ -0,0 +1,11 @@
+js/semantics contains experimental code used to generate LR(1) and LALR(1)
+grammars for JavaScript as well as compile and check formal semantics for
+JavaScript.  The semantics can be executed directly or printed into either
+HTML or Microsoft Word RTF formats.
+
+This code is written in standard Common Lisp.  It's been used under Macintosh
+Common Lisp 4.0, and Allegro Common Lisp 5.0.1 for Windows, but should also work
+under other Common Lisp implementations.
+
+Contact Waldemar Horwat (waldemar@netscape.com or waldemar@acm.org) for
+more information.

mozilla/js2/semantics/Test/BaseExample.lisp

@@ -0,0 +1,68 @@
+(progn
+  (defparameter *bew*
+    (generate-world
+     "BE"
+     '((lexer base-example-lexer
+              :lalr-1
+              :numeral
+              ((:digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                       ((value $digit-value))))
+              (($digit-value integer digit-value digit-char-36)))
+       
+       (deftype semantic-exception (oneof syntax-error))
+       
+       (%charclass :digit)
+       
+       (rule :digits ((decimal-value integer)
+                      (base-value (-> (integer) integer)))
+         (production :digits (:digit) digits-first
+           (decimal-value (value :digit))
+           ((base-value (base integer))
+            (let ((d integer (value :digit)))
+              (if (< d base) d (throw (oneof syntax-error))))))
+         (production :digits (:digits :digit) digits-rest
+           (decimal-value (+ (* 10 (decimal-value :digits)) (value :digit)))
+           ((base-value (base integer))
+            (let ((d integer (value :digit)))
+              (if (< d base)
+                (+ (* base ((base-value :digits) base)) d)
+                (throw (oneof syntax-error)))))))
+       
+       (rule :numeral ((value integer))
+         (production :numeral (:digits) numeral-digits
+           (value (decimal-value :digits)))
+         (production :numeral (:digits #\# :digits) numeral-digits-and-base
+           (value
+            (let ((base integer (decimal-value :digits 2)))
+              (if (and (>= base 2) (<= base 10))
+                ((base-value :digits 1) base)
+                (throw (oneof syntax-error)))))))
+       (%print-actions)
+       )))
+  
+  (defparameter *bel* (world-lexer *bew* 'base-example-lexer))
+  (defparameter *beg* (lexer-grammar *bel*)))
+
+#|
+(depict-rtf-to-local-file
+ "Test/BaseExampleSemantics.rtf"
+ "Base Example Semantics"
+ #'(lambda (rtf-stream)
+     (depict-world-commands rtf-stream *bew*)))
+
+(depict-html-to-local-file
+ "Test/BaseExampleSemantics.html"
+ "Base Example Semantics"
+ t
+ #'(lambda (html-stream)
+     (depict-world-commands html-stream *bew*))
+ :external-link-base "")
+
+
+(lexer-pparse *bel* "37")
+(lexer-pparse *bel* "33#4")
+(lexer-pparse *bel* "30#2")
+
+|#
+
+(length (grammar-states *beg*))

mozilla/js2/semantics/Test/CanonicalLRTest.lisp

@@ -0,0 +1,66 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Canonical LR(1) test grammar
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+(declaim (optimize (debug 3)))
+
+(progn
+  (defparameter *clrtw*
+    (generate-world
+     "T"
+     '((grammar canonical-lr-test-grammar :canonical-lr-1 :start)
+       
+       (production :start (:expr) start-expr)
+       (production :start (:expr !) start-expr-!)
+       
+       (production :expr (id) expr-id)
+       (production :expr (:expr + id) expr-plus)
+       (production :expr (:expr - id (:- -)) expr-minus)
+       (production :expr (\( :expr \)) expr-parens)
+       )))
+  
+  (defparameter *clrtg* (world-grammar *clrtw* 'canonical-lr-test-grammar)))
+
+
+#|
+(depict-rtf-to-local-file
+ "Test/CanonicalLRTestGrammar.rtf"
+ "Canonical LR(1) Test Grammar"
+ #'(lambda (markup-stream)
+     (depict-world-commands markup-stream *clrtw* :visible-semantics nil)))
+
+(depict-html-to-local-file
+ "Test/CanonicalLRTestGrammar.html"
+ "Canonical LR(1) Test Grammar"
+ t
+ #'(lambda (markup-stream)
+     (depict-world-commands markup-stream *clrtw* :visible-semantics nil)))
+
+(print-grammar *clrtg*)
+(with-local-output (s "Test/CanonicalLRTestGrammar.txt") (print-grammar *clrtg* s))
+
+(pprint (parse *clrtg* #'identity '(begin letter letter letter digit end)))
+|#
+
+(length (grammar-states *clrtg*))

mozilla/js2/semantics/Test/ConstraintTest.lisp

@@ -0,0 +1,71 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Constraint test grammar
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+(declaim (optimize (debug 3)))
+
+(progn
+  (defparameter *ctw*
+    (generate-world
+     "T"
+     '((grammar constraint-test-grammar :lr-1 :start)
+       
+       (production :start (:string) start-string)
+       (production :start ((:- letter digit) :chars) start-escape)
+       (production :start ((:- escape) :char) start-letter-digit)
+       
+       (production :string (begin :chars end) string)
+       
+       (production :chars () chars-none)
+       (production :chars (:chars :char) chars-some)
+       
+       (production :char (letter (:- letter)) char-letter)
+       (production :char (digit) char-digit)
+       (production :char (escape digit (:- digit)) char-escape-1)
+       (production :char (escape digit digit) char-escape-2)
+       )))
+  
+  (defparameter *ctg* (world-grammar *ctw* 'constraint-test-grammar)))
+
+
+#|
+(depict-rtf-to-local-file
+ "Test/ConstraintTestGrammar.rtf"
+ "Constraint Test Grammar"
+ #'(lambda (markup-stream)
+     (depict-world-commands markup-stream *ctw* :visible-semantics nil)))
+
+(depict-html-to-local-file
+ "Test/ConstraintTestGrammar.html"
+ "Constraint Test Grammar"
+ t
+ #'(lambda (markup-stream)
+     (depict-world-commands markup-stream *ctw* :visible-semantics nil)))
+
+(with-local-output (s "Test/ConstraintTestGrammar.txt") (print-grammar *ctg* s))
+
+(pprint (parse *ctg* #'identity '(begin letter letter letter digit end)))
+|#
+
+(length (grammar-states *ctg*))

mozilla/js2/semantics/Test/LineTest.lisp

@@ -0,0 +1,68 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Line-break sensitive test grammar
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+(declaim (optimize (debug 3)))
+
+(progn
+  (defparameter *ltw*
+    (generate-world
+     "T"
+     '((line-grammar line-test-grammar :lalr-1 :start)
+       
+       (production :start (a) start-a)
+       (production :start (b :no-line-break c) start-b-c)
+       (production :start (d :no-line-break :y z) start-d-y-z)
+       (production :start (e :y z) start-e-y-z)
+       (production :start (:q :no-line-break a) start-q-a)
+       (production :start (c :q a) start-c-q-a)
+       (production :y () y-empty)
+       (production :y (x) y-x)
+       (production :q (x x) q-x-x)
+       )))
+  
+  (defparameter *ltg* (world-grammar *ltw* 'line-test-grammar)))
+
+
+#|
+(depict-rtf-to-local-file
+ "Test/LineTestGrammar.rtf"
+ "Line Test Grammar"
+ #'(lambda (markup-stream)
+     (depict-world-commands markup-stream *ltw* :visible-semantics nil)))
+
+(depict-html-to-local-file
+ "Test/LineTestGrammar.html"
+ "Line Test Grammar"
+ t
+ #'(lambda (markup-stream)
+     (depict-world-commands markup-stream *ltw* :visible-semantics nil)))
+
+(print-grammar *ltg*)
+(with-local-output (s "Test/LineTestGrammar.txt") (print-grammar *ltg* s))
+
+;(pprint (parse *ltg* #'identity '(begin letter letter letter digit end)))
+|#
+
+(length (grammar-states *ltg*))

mozilla/js2/semantics/Test/NameResolution.lisp

@@ -0,0 +1,71 @@
+(progn
+  (defparameter *nw*
+    (generate-world
+     "N"
+     '((grammar name-resolution-grammar :lalr-1 :start)
+       
+       (production :start () start-none)
+       
+       (deftype value (oneof null abstract-value))
+       (deftype class (oneof abstract-class))
+       (deftype type (oneof abstract-type))
+       (deftype namespace (oneof abstract-namespace))
+       (deftype scope (oneof abstract-scope))
+
+       (deftype getter (-> (value) value))
+       (deftype setter (-> (value value) value))
+
+       (%section "Namespaces")
+
+       (define (create-namespace (supernamespaces (vector namespace))) namespace
+         (bottom))
+
+       (%section "Classes and Intefaces")
+
+       (define (create-class (interface boolean) (superclasses (vector class)) (implementees (vector class))) class
+         (bottom))
+
+       (define (create-uninitialized-instance-slot (c class) (t type)) (tuple (get getter) (set setter))
+         (bottom))
+
+       (define (create-instance-slot (c class) (t type) (initial-value value)) (tuple (get getter) (set setter))
+         (bottom))
+
+       (define (freeze-instance-slots (c class)) void
+         (bottom))
+
+       (define (create-instance (c class)) value
+         (bottom))
+
+       (%section "Members")
+
+       (define (add-getter-member (visibility scope) (n namespace) (c class) (name string) (g getter)) void
+         (bottom))
+       (define (add-setter-member (visibility scope) (n namespace) (c class) (name string) (s setter)) void
+         (bottom))
+
+       (define (lookup-getter-member (s scope) (n namespace) (v value) (name string)) getter
+         (bottom))
+       (define (lookup-setter-member (s scope) (n namespace) (v value) (name string)) setter
+         (bottom))
+       )))
+  
+  (defparameter *ng* (world-grammar *nw* 'name-resolution-grammar)))
+
+#|
+(depict-rtf-to-local-file
+ "Test/NameResolutionSemantics.rtf"
+ "Name Resolution Semantics"
+ #'(lambda (rtf-stream)
+     (depict-world-commands rtf-stream *nw*)))
+|#
+
+(depict-html-to-local-file
+ "Test/NameResolutionSemantics.html"
+ "Name Resolution Semantics"
+ t
+ #'(lambda (html-stream)
+     (depict-world-commands html-stream *nw*))
+ :external-link-base "")
+
+(length (grammar-states *ng*))

mozilla/js2/semantics/Test/StandardFunction.lisp

@@ -0,0 +1,37 @@
+(progn
+  (defparameter *sfw*
+    (generate-world
+     "SF"
+     '((grammar standard-function-grammar :lalr-1 :start)
+       
+       (production :start () start-none)
+       
+       (define (x-digit-value (c character)) integer
+         (if (character-set-member c (set-of-ranges character #\0 #\9))
+           (- (character-to-code c) (character-to-code #\0))
+           (if (character-set-member c (set-of-ranges character #\A #\Z))
+             (+ (- (character-to-code c) (character-to-code #\A)) 10)
+             (if (character-set-member c (set-of-ranges character #\a #\z))
+               (+ (- (character-to-code c) (character-to-code #\a)) 10)
+               (bottom)))))
+       )))
+  
+  (defparameter *sfg* (world-grammar *sfw* 'standard-function-grammar)))
+
+#|
+(depict-rtf-to-local-file
+ "Test/StandardFunctionSemantics.rtf"
+ "Standard Function Semantics"
+ #'(lambda (rtf-stream)
+     (depict-world-commands rtf-stream *sfw*)))
+
+(depict-html-to-local-file
+ "Test/StandardFunctionSemantics.html"
+ "Standard Function Semantics"
+ t
+ #'(lambda (html-stream)
+     (depict-world-commands html-stream *sfw*))
+ :external-link-base "")
+|#
+
+(length (grammar-states *sfg*))

mozilla/js2/semantics/Test/ThrowCatch.lisp

@@ -0,0 +1,56 @@
+(progn
+  (defparameter *tcw*
+    (generate-world
+     "TC"
+     '((lexer throw-catch-lexer
+              :lalr-1
+              :main
+              ((:digit (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
+                       ((value $digit-value))))
+              (($digit-value integer digit-value digit-char-36)))
+       
+       (%charclass :digit)
+       
+       (deftype semantic-exception integer)
+       
+       (rule :expr ((value (-> () integer)))
+         (production :expr (:digit) expr-digit
+           ((value) (value :digit)))
+         (production :expr (#\t :expr) expr-throw
+           ((value) (throw ((value :expr)))))
+         (production :expr (#\c #\{ :expr #\} :expr) expr-catch
+           ((value) (catch ((value :expr 1))
+                    (e) (+ (* e 10) ((value :expr 2)))))))
+       
+       (rule :main ((value integer))
+         (production :main (:expr) main-expr
+           (value ((value :expr)))))
+       (%print-actions)
+       )))
+  
+  (defparameter *tcl* (world-lexer *tcw* 'throw-catch-lexer))
+  (defparameter *tcg* (lexer-grammar *tcl*)))
+
+#|
+(depict-rtf-to-local-file
+ "Test/ThrowCatchSemantics.rtf"
+ "Base Example Semantics"
+ #'(lambda (rtf-stream)
+     (depict-world-commands rtf-stream *tcw*)))
+
+(depict-html-to-local-file
+ "Test/ThrowCatchSemantics.html"
+ "Base Example Semantics"
+ t
+ #'(lambda (html-stream)
+     (depict-world-commands html-stream *tcw*))
+ :external-link-base "")
+
+
+(lexer-pparse *tcl* "7")
+(lexer-pparse *tcl* "t3")
+(lexer-pparse *tcl* "c{t6}5")
+
+|#
+
+(length (grammar-states *tcg*))

mozilla/js2/semantics/Utilities.lisp

@@ -0,0 +1,736 @@
+;;; The contents of this file are subject to the Mozilla Public
+;;; License Version 1.1 (the "License"); you may not use this file
+;;; except in compliance with the License. You may obtain a copy of
+;;; the License at http://www.mozilla.org/MPL/
+;;; 
+;;; Software distributed under the License is distributed on an "AS
+;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; rights and limitations under the License.
+;;; 
+;;; The Original Code is the Language Design and Prototyping Environment.
+;;; 
+;;; The Initial Developer of the Original Code is Netscape Communications
+;;; Corporation.  Portions created by Netscape Communications Corporation are
+;;; Copyright (C) 1999 Netscape Communications Corporation.  All
+;;; Rights Reserved.
+;;; 
+;;; Contributor(s):   Waldemar Horwat <waldemar@acm.org>
+
+;;;
+;;; Handy lisp utilities
+;;;
+;;; Waldemar Horwat (waldemar@acm.org)
+;;;
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; MCL FIXES
+
+
+(setq *print-right-margin* 150)
+
+;;; Fix name-char and char-name.
+#+mcl
+(locally
+  (declare (optimize (speed 3) (safety 0) (debug 1)))
+  (eval-when (:compile-toplevel :load-toplevel :execute)
+    (setq *warn-if-redefine* nil)
+    (setq *warn-if-redefine-kernel* nil))
+  
+  (defun char-name (c)  
+    (dolist (e ccl::*name-char-alist*)
+      (declare (list e))    
+      (when (eq c (cdr e))
+        (return-from char-name (car e))))
+    (let ((code (char-code c)))
+      (declare (fixnum code))
+      (cond ((< code #x100)
+             (unless (and (>= code 32) (<= code 216) (/= code 127))
+               (format nil "x~2,'0X" code)))
+            (t (format nil "u~4,'0X" code)))))
+  
+  (defun name-char (name)
+    (if (characterp name)
+      name
+      (let* ((name (string name))
+             (namelen (length name)))
+        (declare (fixnum namelen))
+        (or (cdr (assoc name ccl::*name-char-alist* :test #'string-equal))
+            (if (= namelen 1)
+              (char name 0)
+              (when (>= namelen 2)
+                (flet
+                  ((number-char (name base lg-base)
+                     (let ((n 0))
+                       (dotimes (i (length name) (code-char n))
+                         (let ((code (digit-char-p (char name i) base)))
+                           (if code
+                             (setq n (logior code (ash n lg-base)))
+                             (return)))))))
+                  (case (char name 0)
+                    (#\^
+                     (when (= namelen 2)
+                       (code-char (the fixnum (logxor (the fixnum (char-code (char-upcase (char name 1)))) #x40)))))
+                    ((#\x #\X #\u #\U)
+                     (number-char (subseq name 1) 16 4))
+                    ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
+                     (number-char name 8 3))))))))))
+  
+  (eval-when (:compile-toplevel :load-toplevel :execute)
+    (setq *warn-if-redefine* t)
+    (setq *warn-if-redefine-kernel* t)))
+
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; READER SYNTAX
+
+; Define #?num to produce a character with code given by the hexadecimal number num.
+; (This is a portable extension; the #\u syntax installed above does the same thing
+; but is not portable.)
+(set-dispatch-macro-character
+ #\# #\?
+ #'(lambda (stream subchar arg)
+     (declare (ignore subchar arg))
+     (let ((*read-base* 16))
+       (code-char (read stream t nil t)))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; MACROS
+
+; (list*-bind (var1 var2 ... varn) expr body):
+;   evaluates expr to obtain a value v;
+;   binds var1, var2, ..., varn such that (list* var1 var2 ... varn) is equal to v;
+;   evaluates body with these bindings;
+;   returns the result values from the body.
+(defmacro list*-bind ((var1 &rest vars) expr &body body)
+  (labels
+    ((gen-let*-bindings (var1 vars expr)
+       (if vars
+         (let ((expr-var (gensym "REST")))
+           (list*
+            (list expr-var expr)
+            (list var1 (list 'car expr-var))
+            (gen-let*-bindings (car vars) (cdr vars) (list 'cdr expr-var))))
+         (list
+          (list var1 expr)))))
+    (list* 'let* (gen-let*-bindings var1 vars expr) body)))
+
+(set-pprint-dispatch '(cons (member list*-bind))
+                     (pprint-dispatch '(multiple-value-bind () ())))
+
+
+; (multiple-value-map-bind (var1 var2 ... varn) f (src1 src2 ... srcm) body)
+;   evaluates src1, src2, ..., srcm to obtain lists l1, l2, ..., lm;
+;   calls f on corresponding elements of lists l1, ..., lm; each such call should return n values v1 v2 ... vn;
+;   binds var1, var2, ..., varn such var1 is the list of all v1's, var2 is the list of all v2's, etc.;
+;   evaluates body with these bindings;
+;   returns the result values from the body.
+(defmacro multiple-value-map-bind ((&rest vars) f (&rest srcs) &body body)
+  (let ((n (length vars))
+        (m (length srcs))
+        (fun (gensym "F"))
+        (ss nil)
+        (vs nil)
+        (accumulators nil))
+    (dotimes (i n)
+      (push (gensym "V") vs)
+      (push (gensym "ACC") accumulators))
+    (dotimes (i m)
+      (push (gensym "S") ss))
+    `(let ((,fun ,f)
+           ,@(mapcar #'(lambda (acc) (list acc nil)) accumulators))
+       (mapc #'(lambda ,ss
+                 (multiple-value-bind ,vs (funcall ,fun ,@ss)
+                   ,@(mapcar #'(lambda (accumulator v) (list 'push v accumulator))
+                             accumulators vs)))
+             ,@srcs)
+       (let ,(mapcar #'(lambda (var accumulator) (list var (list 'nreverse accumulator)))
+                     vars accumulators)
+         ,@body))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; VALUE ASSERTS
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defconstant *value-asserts* t))
+
+; Assert that (test value) returns non-nil.  Return value.
+(defmacro assert-value (value test &rest format-and-parameters)
+  (if *value-asserts*
+    (let ((v (gensym "VALUE")))
+      `(let ((,v ,value))
+         (unless (,test ,v)
+           ,(if format-and-parameters
+              `(error ,@format-and-parameters)
+              `(error "~S doesn't satisfy ~S" ',value ',test)))
+         ,v))
+    value))
+
+
+; Assert that value is non-nil.  Return value.
+(defmacro assert-non-null (value &rest format-and-parameters)
+  `(assert-value ,value identity .
+                 ,(or format-and-parameters
+                      `("~S is null" ',value))))
+
+
+; Assert that value is non-nil.  Return nil.
+; Do not evaluate value in nondebug versions.
+(defmacro assert-true (value &rest format-and-parameters)
+  (if *value-asserts*
+    `(unless ,value
+       ,(if format-and-parameters
+          `(error ,@format-and-parameters)
+          `(error "~S is false" ',value)))
+    nil))
+
+
+; Assert that expr returns n values.  Return those values.
+(defmacro assert-n-values (n expr)
+  (if *value-asserts*
+    (let ((v (gensym "VALUES")))
+      `(let ((,v (multiple-value-list ,expr)))
+         (unless (= (length ,v) ,n)
+           (error "~S returns ~D values instead of ~D" ',expr (length ,v) ',n))
+         (values-list ,v)))
+    expr))
+
+; Assert that expr returns one value.  Return that value.
+(defmacro assert-one-value (expr)
+  `(assert-n-values 1 ,expr))
+
+; Assert that expr returns two values.  Return those values.
+(defmacro assert-two-values (expr)
+  `(assert-n-values 2 ,expr))
+
+; Assert that expr returns three values.  Return those values.
+(defmacro assert-three-values (expr)
+  `(assert-n-values 3 ,expr))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; STRUCTURED TYPES
+
+(defconstant *type-asserts* t)
+
+(defun tuple? (value structured-types)
+  (if (endp structured-types)
+    (null value)
+    (and (consp value)
+         (structured-type? (car value) (first structured-types))
+         (tuple? (cdr value) (rest structured-types)))))
+
+(defun list-of? (value structured-type)
+  (or
+   (null value)
+   (and (consp value)
+        (structured-type? (car value) structured-type)
+        (list-of? (cdr value) structured-type))))
+
+
+; Return true if value has the given structured-type.
+; A structured-type can be a Common Lisp type or one of the forms below:
+;
+;   (cons t1 t2)  is the type of pairs whose car has structured-type t1 and
+;                 cdr has structured-type t2.
+;
+;   (tuple t1 t2 ... tn) is the type of n-element lists whose first element
+;                 has structured-type t1, second element has structured-type t2, ...,
+;                 and last element has structured-type tn.
+;
+;   (list t)      is the type of lists all of whose elements have structured-type t.
+;
+(defun structured-type? (value structured-type)
+  (cond
+   ((consp structured-type)
+    (case (first structured-type)
+      (cons (and (consp value)
+                 (structured-type? (car value) (second structured-type))
+                 (structured-type? (cdr value) (third structured-type))))
+      (tuple (tuple? value (rest structured-type)))
+      (list (list-of? value (second structured-type)))
+      (t (typep value structured-type))))
+   ((null structured-type) nil)
+   (t (typep value structured-type))))
+
+
+; Ensure that value has type given by typespec
+; (which should not be quoted).  Return the value.
+(defmacro assert-type (value structured-type)
+  (if *type-asserts*
+    (let ((v (gensym "VALUE")))
+      `(let ((,v ,value))
+         (unless (structured-type? ,v ',structured-type)
+           (error "~S should have type ~S" ,v ',structured-type))
+         ,v))
+    value))
+
+(deftype bool () '(member nil t))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; GENERAL UTILITIES
+
+
+; f must be either a function, a symbol, or a list of the form (setf <symbol>).
+; If f is a function or has a function binding, return that function; otherwise return nil.
+(defun callable (f)
+  (cond
+   ((functionp f) f)
+   ((fboundp f) (fdefinition f))
+   (t nil)))
+
+
+; Return the first character of symbol's name or nil if s's name has zero length.
+(defun first-symbol-char (symbol)
+  (let ((name (symbol-name symbol)))
+    (when (> (length name) 0)
+      (char name 0))))
+
+
+(defconstant *get2-nonce* (if (boundp '*get2-nonce*) (symbol-value '*get2-nonce*) (gensym)))
+
+; Perform a get except that return two values:
+;   The value returned from the get or nil if the property is not present
+;   t if the property is present or nil if not.
+(defun get2 (symbol property)
+  (let ((value (get symbol property *get2-nonce*)))
+    (if (eq value *get2-nonce*)
+      (values nil nil)
+      (values value t))))
+
+
+; Return a list of all the keys in the hash table.
+(defun hash-table-keys (hash-table)
+  (let ((keys nil))
+    (maphash #'(lambda (key value)
+                 (declare (ignore value))
+                 (push key keys))
+             hash-table)
+    keys))
+
+
+; Return a list of all the keys in the hash table sorted by their string representations.
+(defun sorted-hash-table-keys (hash-table)
+  (with-standard-io-syntax
+    (let ((*print-readably* nil)
+          (*print-escape* nil))
+      (sort (hash-table-keys hash-table) #'string<
+            :key #'(lambda (item)
+                     (if (symbolp item)
+                       (or (get item :sort-key)
+                           (symbol-name item))
+                       (write-to-string item)))))))
+
+
+; Return an association list of all the entries in the hash table.
+(defun hash-table-entries (hash-table)
+  (let ((entries nil))
+    (maphash #'(lambda (key value)
+                 (push (cons key value) entries))
+             hash-table)
+    entries))
+
+
+; Return true if the two hash tables are equal, using the given equality test for testing their elements.
+(defun hash-table-= (hash-table1 hash-table2 &key (test #'eql))
+  (and (= (hash-table-count hash-table1) (hash-table-count hash-table2))
+       (progn
+         (maphash
+          #'(lambda (key1 value1)
+              (multiple-value-bind (value2 present2) (gethash key1 hash-table2)
+                (unless (and present2 (funcall test value1 value2))
+                  (return-from hash-table-= nil))))
+          hash-table1)
+         t)))
+
+
+; Given an association list ((key1 . data1) (key2 . data2) ... (keyn datan)),
+; produce another association list whose keys are sets of the keys of the original list,
+; where the data elements of each such set are equal according to the given test function.
+; The keys within each set are listed in the same order as in the original list.
+; Set X comes before set Y if X contains a key earlier in the original list than any
+; key in Y.
+(defun collect-equivalences (alist &key (test #'eql))
+  (if (endp alist)
+    nil
+    (let* ((element (car alist))
+           (key (car element))
+           (data (cdr element))
+           (rest (cdr alist)))
+      (if (rassoc data rest :test test)
+        (let ((filtered-rest nil)
+              (additional-keys nil))
+          (dolist (elt rest)
+            (if (funcall test data (cdr elt))
+              (push (car elt) additional-keys)
+              (push elt filtered-rest)))
+          (acons (cons key (nreverse additional-keys)) data
+                 (collect-equivalences (nreverse filtered-rest) :test test)))
+        (acons (list key) data (collect-equivalences rest :test test))))))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; BITMAPS
+
+; Treating integer m as a bitmap, call f on the number of each bit set in m.
+(defun bitmap-each-bit (f m)
+  (assert-true (>= m 0))
+  (dotimes (i (integer-length m))
+    (when (logbitp i m)
+      (funcall f i))))
+
+  
+; Treating integer m as a bitmap, return a sorted list of disjoint, nonadjacent ranges
+; of bits set in m.  Each range is a pair (x . y) and indicates that bits numbered x through
+; y, inclusive, are set in m.  If m is negative, the last range will be a pair (x . :infinity).
+(defun bitmap-to-ranges (m)
+  (labels
+    ((bitmap-to-ranges-sub (m ranges)
+       (if (zerop m)
+         ranges
+         (let* ((hi (integer-length m))
+                (m (- m (ash 1 hi)))
+                (lo (integer-length m))
+                (m (+ m (ash 1 lo))))
+           (bitmap-to-ranges-sub m (acons lo (1- hi) ranges))))))
+    (if (minusp m)
+      (let* ((lo (integer-length m))
+             (m (+ m (ash 1 lo))))
+        (bitmap-to-ranges-sub m (list (cons lo :infinity))))
+      (bitmap-to-ranges-sub m nil))))
+
+
+; Same as bitmap-to-ranges but abbreviate pairs (x . x) by x.
+(defun bitmap-to-abbreviated-ranges (m)
+  (mapcar #'(lambda (range)
+              (if (eql (car range) (cdr range))
+                (car range)
+                range))
+          (bitmap-to-ranges m)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; PACKAGES
+
+; Call f on each external symbol defined in the package.
+(defun each-package-external-symbol (package f)
+  (with-package-iterator (iter package :external)
+    (loop
+      (multiple-value-bind (present symbol) (iter)
+        (unless present
+          (return))
+        (funcall f symbol)))))
+
+
+; Return a list of all external symbols defined in the package.
+(defun package-external-symbols (package)
+  (with-package-iterator (iter package :external)
+    (let ((list nil))
+      (loop
+        (multiple-value-bind (present symbol) (iter)
+          (unless present
+            (return))
+          (push symbol list)))
+      list)))
+
+
+; Return a sorted list of all external symbols defined in the package.
+(defun sorted-package-external-symbols (package)
+  (sort (package-external-symbols package) #'string<))
+
+
+; Call f on each internal symbol defined in the package.
+(defun each-package-internal-symbol (package f)
+  (with-package-iterator (iter package :internal)
+    (loop
+      (multiple-value-bind (present symbol) (iter)
+        (unless present
+          (return))
+        (funcall f symbol)))))
+
+
+; Return a list of all internal symbols defined in the package.
+(defun package-internal-symbols (package)
+  (with-package-iterator (iter package :internal)
+    (let ((list nil))
+      (loop
+        (multiple-value-bind (present symbol) (iter)
+          (unless present
+            (return))
+          (push symbol list)))
+      list)))
+
+
+; Return a sorted list of all internal symbols defined in the package.
+(defun sorted-package-internal-symbols (package)
+  (sort (package-internal-symbols package) #'string<))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; INTSETS
+
+;;; An intset is a finite set of integers, represented as an ordered list of ranges.
+;;; Each range is a cons (low . high), both low and high being inclusive.  Ranges must
+;;; be nonoverlapping, and adjacent ranges must be consolidated.
+
+(defconstant *empty-intset* nil)
+
+; Return true if the intset is valid.
+(defun valid-intset? (intset)
+  (and (structured-type? intset '(list (cons integer integer)))
+       (or (null intset)
+           (let ((prev (- (caar intset) 2)))
+             (dolist (range intset t)
+               (let ((low (car range))
+                     (high (cdr range)))
+                 (unless (and (< prev (1- low)) (<= low high))
+                   (return nil))
+                 (setq prev high)))))))
+
+
+; Return an intset that is the union of the given intset and the intset
+; containg the given values.
+(defun intset-add-value (intset &rest values)
+  (labels
+    ((add-value (intset value)
+       (if (endp intset)
+         (list (cons value value))
+         (let* ((first-range (first intset))
+                (rest (rest intset))
+                (first-low (car first-range))
+                (first-high (cdr first-range)))
+           (cond
+            ((> value first-high)
+             (cond
+              ((/= value (1+ first-high)) (cons first-range (add-value rest value)))
+              ((or (endp rest) (/= (caar rest) (1+ value))) (acons first-low value rest))
+              (t (acons first-low (cdar rest) (rest rest)))))
+            ((< value first-low)
+             (if (/= value (1- first-low))
+               (acons value value intset)
+               (acons value first-high rest)))
+            (t intset))))))
+    
+    (dolist (value values)
+      (assert-true (integerp value))
+      (add-value intset value))))
+
+
+; Return an intset that is the union of the given intset and the intset
+; containg all integers between low and high, inclusive.  low <= high+1 is required.
+(defun intset-add-range (intset low high)
+  (labels
+    ((add-range (intset low high)
+       (if (endp intset)
+         (list (cons low high))
+         (let* ((first-range (first intset))
+                (rest (rest intset))
+                (first-low (car first-range))
+                (first-high (cdr first-range)))
+           (cond
+            ((> low (1+ first-high))
+             (cons first-range (add-range rest low high)))
+            ((< high (1- first-low))
+             (acons low high intset))
+            ((<= high first-high)
+             (if (>= low first-low)
+               intset
+               (acons low first-high rest)))
+            (t (add-range rest (min low first-low) high)))))))
+    
+    (assert-true (and (integerp low) (integerp high) (<= low (1+ high))))
+    (if (= low (1+ high))
+      intset
+      (add-range intset low high))))
+
+
+; Return an intset constructed from a list of ranges.  Each range has two expressions,
+; low and high.  high can be null to indicate a one-element range.
+(defun intset-from-ranges (&rest ranges)
+  (if (endp ranges)
+    *empty-intset*
+    (progn
+      (assert-true (cdr ranges))
+      (intset-add-range (apply #'intset-from-ranges (cddr ranges))
+                        (first ranges)
+                        (or (second ranges) (first ranges))))))
+
+
+
+; Return true if value is a member of the intset.
+(defun intset-member? (intset value)
+  (if (endp intset)
+    nil
+    (let ((first-range (first intset)))
+      (if (> value (cdr first-range))
+        (intset-member? (rest intset) value)
+        (>= value (car first-range))))))
+
+
+; Return the union of the two intsets.
+(defun intset-union (intset1 intset2)
+  (cond
+   ((endp intset1) intset2)
+   ((endp intset2) intset1)
+   (t (let* ((first-range1 (first intset1))
+             (rest1 (rest intset1))
+             (first-low1 (car first-range1))
+             (first-high1 (cdr first-range1))
+             (first-range2 (first intset2))
+             (rest2 (rest intset2))
+             (first-low2 (car first-range2))
+             (first-high2 (cdr first-range2)))
+        (cond
+         ((< first-high1 (1- first-low2))
+          (cons first-range1 (intset-union rest1 intset2)))
+         ((< first-high2 (1- first-low1))
+          (cons first-range2 (intset-union intset1 rest2)))
+         (t (intset-union (intset-add-range intset1 first-low2 first-high2) rest2)))))))
+
+
+; Return the intersection of the two intsets.
+(defun intset-intersection (intset1 intset2)
+  (if (or (endp intset1) (endp intset2))
+    nil
+    (let* ((first-range1 (first intset1))
+           (rest1 (rest intset1))
+           (first-low1 (car first-range1))
+           (first-high1 (cdr first-range1))
+           (first-range2 (first intset2))
+           (rest2 (rest intset2))
+           (first-low2 (car first-range2))
+           (first-high2 (cdr first-range2))
+           (low (max first-low1 first-low2)))
+      (cond
+       ((< first-high1 first-high2)
+        (if (<= low first-high1)
+          (acons low first-high1 (intset-intersection rest1 intset2))
+          (intset-intersection rest1 intset2)))
+       ((> first-high1 first-high2)
+        (if (<= low first-high2)
+          (acons low first-high2 (intset-intersection intset1 rest2))
+          (intset-intersection intset1 rest2)))
+       (t (acons low first-high1 (intset-intersection rest1 rest2)))))))
+
+
+; Return the the intset containing the elements of intset1 that are not in intset2.
+(defun intset-difference (intset1 intset2)
+  (cond
+   ((endp intset1) nil)
+   ((endp intset2) intset1)
+   (t (let* ((first-range1 (first intset1))
+             (rest1 (rest intset1))
+             (first-low1 (car first-range1))
+             (first-high1 (cdr first-range1))
+             (first-range2 (first intset2))
+             (rest2 (rest intset2))
+             (first-low2 (car first-range2))
+             (first-high2 (cdr first-range2)))
+        (cond
+         ((< first-high1 first-low2)
+          (cons first-range1 (intset-difference rest1 intset2)))
+         ((> first-low1 first-high2)
+          (intset-difference intset1 rest2))
+         ((< first-low1 first-low2)
+          (acons first-low1 (1- first-low2) (intset-difference (acons first-low2 first-high1 rest1) intset2)))
+         ((> first-high1 first-high2)
+          (intset-difference (acons (1+ first-high2) first-high1 rest1) rest2))
+         (t (intset-difference rest1 intset2)))))))
+
+
+; Return true if the two intsets are equal.
+(declaim (inline intset=))
+(defun intset= (intset1 intset2)
+  (equal intset1 intset2))
+
+
+; Return the number of elements in the intset.
+(defun intset-length (intset)
+  (if (endp intset)
+    0
+    (+ 1 (- (cdar intset) (caar intset))
+       (intset-length (rest intset)))))
+
+
+; Return the lowest element of the intset or nil if the intset is empty.
+(declaim (inline intset-min))
+(defun intset-min (intset)
+  (caar intset))
+
+
+; Return the highest element of the intset or nil if the intset is empty.
+(defun intset-max (intset)
+  (cdar (last intset)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; PARTIAL ORDERS
+
+(defstruct partial-order
+  (next-number 0 :type integer))  ;Bit number to use for next element
+
+
+(defstruct (partial-order-element (:constructor make-partial-order-element (partial-order number predecessor-bitmap))
+                                  (:copier nil)
+                                  (:predicate partial-order-element?))
+  (partial-order nil :type partial-order)  ;Partial order to which this element belongs
+  (number nil :type integer)               ;Bit number of this element
+  (predecessor-bitmap nil :type integer))  ;Bitmap of elements less than or equal to this one in the partial order
+
+
+; Construct a new unique element in the partial order that is greater than the
+; given predecessors.  Return that element.
+(defun partial-order-add-element (partial-order &rest predecessors)
+  (let* ((number (partial-order-next-number partial-order))
+         (predecessor-bitmap (ash 1 number)))
+    (dolist (predecessor predecessors)
+      (assert-true (eq (partial-order-element-partial-order predecessor) partial-order))
+      (setq predecessor-bitmap (logior predecessor-bitmap (partial-order-element-predecessor-bitmap predecessor))))
+    (incf (partial-order-next-number partial-order))
+    (make-partial-order-element partial-order number predecessor-bitmap)))
+
+
+(defmacro def-partial-order-element (partial-order name &rest predecessors)
+  `(defparameter ,name (partial-order-add-element ,partial-order ,@predecessors)))
+
+
+; Return true if element1 is greater than or equal to element2 in this partial order.
+(defun partial-order->= (element1 element2)
+  (assert-true (eq (partial-order-element-partial-order element1) (partial-order-element-partial-order element2)))
+  (logbitp (partial-order-element-number element2) (partial-order-element-predecessor-bitmap element1)))
+
+
+; Return true if element1 is less than element2 in this partial order.
+(declaim (inline partial-order-<))
+(defun partial-order-< (element1 element2)
+  (not (partial-order->= element1 element2)))
+
+
+;;; ------------------------------------------------------------------------------------------------------
+;;; DEPTH-FIRST SEARCH
+
+; Return a depth-first-ordered list of the nodes in a directed graph.
+; The graph may contain cycles, so a general depth-first search is used.
+; start is the start node.
+; successors is a function that takes a node and returns a list of that
+;   node's successors.
+; test is a function that takes two nodes and returns true if they are
+;   the same node.  test should be either #'eq, #'eql, or #'equal
+;   because it is used as a test function in a hash table.
+(defun depth-first-search (test successors start)
+  (let ((visited-nodes (make-hash-table :test test))
+        (dfs-list nil))
+    (labels
+      ((visit (node)
+         (setf (gethash node visited-nodes) t)
+         (dolist (successor (funcall successors node))
+           (unless (gethash successor visited-nodes)
+             (visit successor)))
+         (push node dfs-list)))
+      (visit start)
+      dfs-list)))

mozilla/js2/semantics/styles.css

@@ -0,0 +1,72 @@
+A:link {color: #0000DD}
+A:visited {color: #551188}
+A:hover {color: #3333FF}
+A:active {color: #FF00FF}
+A * {text-decoration: inherit}
+
+.title1 {font-family: "Times New Roman", Times, serif; font-size: 36pt; font-weight: bold; color: #000000; white-space: nowrap}
+.title2 {font-family: "Times New Roman", Times, serif; font-size: 18pt; font-weight: bold; color: #000000; white-space: nowrap}
+.top-title {color: #009900}
+.es-title {color: #999900}
+.draft-title {color: #FF0000}
+.mod-date {font-size: smaller; font-style: italic; text-align: right}
+.sub {font-size: 70%}
+.sub-num {font-size: 70%; font-style: normal}
+.syntax {margin-left: 0.5in}
+.indent {margin-left: 0.5in}
+.issue {color: #FF0000}
+
+BODY {background-color: #FFFFFF; color: #000000}
+DL {margin-left: 18pt}
+DD {margin-bottom: 6pt}
+DT {font-style: italic; margin-top: 3pt}
+
+.js2 {background-color: #FFFF66; color: #000033}
+.js2-hidden {}
+.es4 {background-color: #FFCCCC; color: #333300; text-decoration: line-through}
+.es4-hidden {}
+
+.grammar-rule {margin-left: 18pt; margin-top: 6pt; margin-bottom: 6pt}
+.grammar-lhs {}
+.grammar-rhs {margin-left: 9pt;}
+.grammar-argument {margin-left: 18pt; margin-top: 6pt; margin-bottom: 6pt}
+.semantics {margin-left: 9pt; margin-top: 6pt; margin-bottom: 3pt}
+.semantics-next {margin-left: 27pt; margin-top: 0pt; margin-bottom: 3pt}
+.semantic-comment {margin-left: 9pt; margin-top: 12pt; margin-bottom: 0pt}
+
+.symbol {font-family: Symbol}
+.unicode {font-family: "Lucida Sans Unicode", serif}
+VAR, VAR A:link, VAR A:visited {font-family: Georgia, Palatino, "Times New Roman", Times, serif; font-weight: normal; font-style: italic; color: #336600}
+A:hover VAR, VAR A:hover {color: #003300}
+A:active VAR, VAR A:active {color: #00FF00}
+CODE, PRE {font-family: "Courier New", Courier, mono; color: #0000FF}
+PRE {margin-left: 0.5in}
+A:hover CODE {color: #3333CC}
+A:active CODE {color: #6666FF}
+.control, A.control:link, A.control:visited {font-family: "Times New Roman", Times, serif; font-weight: normal; color: #000099}
+A.control:hover, A:hover .control {color: #333366}
+A.control:active, A:active .control {color: #3333FF}
+.terminal, A.terminal:link, A.terminal:visited {font-family: Georgia, Palatino, "Times New Roman", Times, serif; font-weight: bold; color: #009999}
+A.terminal:hover, A:hover .terminal {color: #336666}
+A.terminal:active, A:active .terminal {color: #00FFFF}
+.terminal-keyword {font-weight: bold}
+.nonterminal, A.nonterminal:link, A.nonterminal:visited, .nonterminal A:link, .nonterminal A:visited {font-family: Georgia, Palatino, "Times New Roman", Times, serif; font-weight: normal; font-style: italic; color: #009900}
+A.nonterminal:hover, .nonterminal A:hover, A:hover .nonterminal {color: #336633}
+A.nonterminal:active, .nonterminal A:active, A:active .nonterminal {color: #00FF00}
+.nonterminal-attribute, .nonterminal-argument {font-style: normal}
+.semantic-keyword {font-family: "Times New Roman", Times, serif; font-weight: bold}
+.type-expression, A.type-expression:link, A.type-expression:visited, .type-name, A.type-name:link, A.type-name:visited {font-family: "Times New Roman", Times, serif; color: #CC0000}
+A.type-expression:hover, A:hover .type-expression, A.type-name:hover, A:hover .type-name {color: #990000}
+A.type-expression:active, A:active .type-expression, A.type-name:active, A:active .type-name {color: #FF6666}
+.type-name {font-variant: small-caps}
+.id-name {font-family: Arial, Helvetica, sans-serif; font-variant: small-caps}
+.field-name, A.field-name:link, A.field-name:visited {font-family: Arial, Helvetica, sans-serif; color: #FF0000}
+A.field-name:hover, A:hover .field-name {color: #CC3333}
+A.field-name:active, A:active .field-name {color: #FF6666}
+.global-variable, A.global-variable:link, A.global-variable:visited {font-family: "Times New Roman", Times, serif; color: #006600}
+.local-variable, A.local-variable:link, A.local-variable:visited {font-family: "Times New Roman", Times, serif; color: #009900}
+A.global-variable:hover, A:hover .global-variable, A.local-variable:hover, A:hover .local-variable {color: #336633}
+A.global-variable:active, A:active .global-variable, A.local-variable:active, A:active .local-variable {color: #00FF00}
+.action-name, A.action-name:link, A.action-name:visited {font-family: "Zapf Chancery", "Comic Sans MS", Script, serif; color: #660066}
+A.action-name:hover, A:hover .action-name {color: #663366}
+A.action-name:active, A:active .action-name {color: #FF00FF}

mozilla/js2/semantics/unicodeCompatibility.js

@@ -0,0 +1,124 @@
+// Most browsers don't support unicode mathematical symbols yet.
+// As a workaround, this code maps them to the Symbol font using
+// either the ISO-8859-1 or ISO-8859-1-to-MacRoman inverse mapping.
+
+var mapping_Unicode = 0; // Output true unicode
+var mapping_Win = 1;     // Emulate using Windows Symbol font
+var mapping_Mac = 2;     // Emulate using Mac Symbol font
+
+// CSS class names to use depending on the mapping
+var cssClassNames = ["", "symbol", "symbol"];
+
+
+var mapping;
+if (parseFloat(navigator.appVersion) >= 5)
+  mapping = mapping_Unicode;
+else if (navigator.platform.indexOf("Mac") != -1)
+  mapping = mapping_Mac;
+else
+  mapping = mapping_Win;
+
+function defMap(unicode, win, mac) {
+  if (cssClassNames[mapping] == "")
+    return '&#' + arguments[mapping] + ';';
+  else
+    return '<SPAN class="' + cssClassNames[mapping] + '">&#' + arguments[mapping] + ';</SPAN>';
+}
+
+
+var U_times =   defMap(0x00D7, 0xB4, 0xA5);
+
+var U_Alpha =   defMap(0x0391, 0x41, 0x41);
+var U_Beta =    defMap(0x0392, 0x42, 0x42);
+var U_Gamma =   defMap(0x0393, 0x47, 0x47);
+var U_Delta =   defMap(0x0394, 0x44, 0x44);
+var U_Epsilon = defMap(0x0395, 0x45, 0x45);
+var U_Zeta =    defMap(0x0396, 0x5A, 0x5A);
+var U_Eta =     defMap(0x0397, 0x48, 0x48);
+var U_Theta =   defMap(0x0398, 0x51, 0x51);
+var U_Iota =    defMap(0x0399, 0x49, 0x49);
+var U_Kappa =   defMap(0x039A, 0x4B, 0x4B);
+var U_Lambda =  defMap(0x039B, 0x4C, 0x4C);
+var U_Mu =      defMap(0x039C, 0x4D, 0x4D);
+var U_Nu =      defMap(0x039D, 0x4E, 0x4E);
+var U_Xi =      defMap(0x039E, 0x58, 0x58);
+var U_Omicron = defMap(0x039F, 0x4F, 0x4F);
+var U_Pi =      defMap(0x03A0, 0x50, 0x50);
+var U_Rho =     defMap(0x03A1, 0x52, 0x52);
+var U_Sigma =   defMap(0x03A3, 0x53, 0x53);
+var U_Tau =     defMap(0x03A4, 0x54, 0x54);
+var U_Upsilon = defMap(0x03A5, 0x55, 0x55);
+var U_Phi =     defMap(0x03A6, 0x46, 0x46);
+var U_Chi =     defMap(0x03A7, 0x43, 0x43);
+var U_Psi =     defMap(0x03A8, 0x59, 0x59);
+var U_Omega =   defMap(0x03A9, 0x57, 0x57);
+
+var U_alpha =   defMap(0x03B1, 0x61, 0x61);
+var U_beta =    defMap(0x03B2, 0x62, 0x62);
+var U_gamma =   defMap(0x03B3, 0x67, 0x67);
+var U_delta =   defMap(0x03B4, 0x64, 0x64);
+var U_epsilon = defMap(0x03B5, 0x65, 0x65);
+var U_zeta =    defMap(0x03B6, 0x7A, 0x7A);
+var U_eta =     defMap(0x03B7, 0x68, 0x68);
+var U_theta =   defMap(0x03B8, 0x71, 0x71);
+var U_iota =    defMap(0x03B9, 0x69, 0x69);
+var U_kappa =   defMap(0x03BA, 0x6B, 0x6B);
+var U_lambda =  defMap(0x03BB, 0x6C, 0x6C);
+var U_mu =      defMap(0x03BC, 0x6D, 0x6D);
+var U_nu =      defMap(0x03BD, 0x6E, 0x6E);
+var U_xi =      defMap(0x03BE, 0x78, 0x78);
+var U_omicron = defMap(0x03BF, 0x6F, 0x6F);
+var U_pi =      defMap(0x03C0, 0x70, 0x70);
+var U_rho =     defMap(0x03C1, 0x72, 0x72);
+var U_sigma =   defMap(0x03C3, 0x73, 0x73);
+var U_tau =     defMap(0x03C4, 0x74, 0x74);
+var U_upsilon = defMap(0x03C5, 0x75, 0x75);
+var U_phi =     defMap(0x03C6, 0x66, 0x66);
+var U_chi =     defMap(0x03C7, 0x63, 0x63);
+var U_psi =     defMap(0x03C8, 0x79, 0x79);
+var U_omega =   defMap(0x03C9, 0x77, 0x77);
+
+var U_bull =    defMap(0x2022, 0xB7, 0x2211);
+
+var U_larr =    defMap(0x2190, 0xAC, 0xA8);
+var U_uarr =    defMap(0x2191, 0xAD, 0x2260);
+var U_rarr =    defMap(0x2192, 0xAE, 0xC6);
+var U_darr =    defMap(0x2193, 0xAF, 0xD8);
+var U_harr =    defMap(0x2194, 0xAB, 0xB4);
+var U_lArr =    defMap(0x21D0, 0xDC, 0x2039);
+var U_uArr =    defMap(0x21D1, 0xDD, 0x203A);
+var U_rArr =    defMap(0x21D2, 0xDE, 0xFB01);
+var U_dArr =    defMap(0x21D3, 0xDF, 0xFB02);
+var U_hArr =    defMap(0x21D4, 0xDB, 0x20AC);
+
+var U_forall =  defMap(0x2200, 0x22, 0x22);
+var U_exist =   defMap(0x2203, 0x24, 0x24);
+var U_empty =   defMap(0x2205, 0xC6, 0x2206);
+var U_isin =    defMap(0x2208, 0xCE, 0x0152);
+var U_notin =   defMap(0x2209, 0xCF, 0x0153);
+var U_infin =   defMap(0x221E, 0xA5, 0x2022);
+var U_and =     defMap(0x2227, 0xD9, 0x0178);
+var U_or =      defMap(0x2228, 0xDA, 0x2044);
+var U_cap =     defMap(0x2229, 0xC7, 0xAB);
+var U_cup =     defMap(0x222A, 0xC8, 0xBB);
+var U_cong =    defMap(0x2245, 0x40, 0x40);
+var U_asymp =   defMap(0x2248, 0xBB, 0xAA);
+var U_ne =      defMap(0x2260, 0xB9, 0x03C0);
+var U_equiv =   defMap(0x2261, 0xBA, 0x222B);
+var U_le =      defMap(0x2264, 0xA3, 0xA3);
+var U_ge =      defMap(0x2265, 0xB3, 0x2265);
+var U_sub =     defMap(0x2282, 0xCC, 0xC3);
+var U_sup =     defMap(0x2283, 0xC9, 0x2026);
+var U_nsub =    defMap(0x2284, 0xCB, 0xC0);
+var U_sube =    defMap(0x2286, 0xCD, 0xD5);
+var U_supe =    defMap(0x2287, 0xCA, 0xA0); //Mac Navigator confuses it with nbsp
+var U_oplus =   defMap(0x2295, 0xC5, 0x2248);
+var U_otimes =  defMap(0x2297, 0xC4, 0x0192);
+var U_perp =    defMap(0x22A5, 0x5E, 0x5E);
+
+var U_lceil =   defMap(0x2308, 0xE9, 0xC8);
+var U_rceil =   defMap(0x2309, 0xF9, 0x02D8);
+var U_lfloor =  defMap(0x230A, 0xEB, 0xCE);
+var U_rfloor =  defMap(0x230B, 0xFB, 0x02DA);
+var U_lang =    defMap(0x2329, 0xE1, 0xB7);
+var U_rang =    defMap(0x232A, 0xF1, 0xD2);

mozilla/js2/src/JSILGenerator.cpp

@@ -0,0 +1,417 @@
+#pragma warning ( disable : 4786 )
+
+#include "Nodes.h"
+#include "JSILGenerator.h"
+#include "../jsc/src/cpp/parser/NodeFactory.h"
+#include "ReferenceValue.h"
+#include "ConstantEvaluator.h"
+#include "Builder.h"
+#include "GlobalObjectBuilder.h"
+
+namespace esc {
+namespace v1 {
+
+    JavaScript::ICG::ICodeModule* JSILGenerator::emit() {
+        return 0;
+    }
+
+	// Evaluators
+
+    // Base node
+    
+	Value* JSILGenerator::evaluate( Context& cx, Node* node ) { 
+        throw;
+    }
+
+	// Expression evaluators
+
+    Value* JSILGenerator::evaluate( Context& cx, ThisExpressionNode* node ) { 
+		throw;
+    }
+    
+	/*
+	 * Unqualified identifiers evaluate to a ReferenceValue during semantic analysis,
+	 * and so this method is never called.
+	 */
+	
+	Value* JSILGenerator::evaluate( Context& cx, IdentifierNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, QualifiedIdentifierNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, LiteralBooleanNode* node ) { 
+        throw;
+    }
+
+    Value* JSILGenerator::evaluate( Context& cx, LiteralNumberNode* node ) { 
+        throw;
+    }
+
+	/*
+	 * Literal string
+	 */
+	
+	Value* JSILGenerator::evaluate( Context& cx, LiteralStringNode* node ) { 
+        return 0;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, LiteralUndefinedNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, LiteralRegExpNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, UnitExpressionNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, FunctionExpressionNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ParenthesizedExpressionNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ParenthesizedListExpressionNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, LiteralObjectNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, LiteralFieldNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, LiteralArrayNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, PostfixExpressionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, NewExpressionNode* node ) { 
+        throw;
+    }
+    
+	/*
+	 * Indexed member expressions evaluate to a ReferenceValue during semantic analysis,
+	 * and so this method is never called.
+	 */
+
+	Value* JSILGenerator::evaluate( Context& cx, IndexedMemberExpressionNode* node ) {
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ClassofExpressionNode* node ) {
+        throw;
+    }
+    
+	/*
+	 * Member expressions evaluate to a ReferenceValue during semantic analysis,
+	 * and so this method is never called.
+	 */
+
+	Value* JSILGenerator::evaluate( Context& cx, MemberExpressionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, CoersionExpressionNode* node ) { 
+        throw;
+    }
+
+	/*
+	 * CallExpressionNode
+	 *
+	 * Call expressions can be generated as invocations of the function
+	 * object's call method, or as a direct call to a native function.
+	 * If constant evaluation was able to resolve the function reference
+	 * to a built-in native function, then call a direct call is generated.
+	 *
+	 * NOTE: this code is being generated into the start function with
+	 *       parameters (Stack scope, ObjectValue this). These are in
+	 *       local registers (0 and 1).
+	 */
+
+	Value* JSILGenerator::evaluate( Context& cx, CallExpressionNode* node ) { 
+		return 0;
+    }
+    
+	/*
+	 * GetExpressionNode
+	 *
+	 * Get expressions are psuedo syntactic constructs, created when
+	 * a member expression is used in a context where a value is
+	 * expected. In the general case, a get expression is the same as
+	 * a call expression with no arguments. In specfic cases, a get
+	 * expression can be optimized as a direct access of a native 
+	 * field.
+	 */
+
+	/* 
+	 * What do we need to compile a variable reference to a field id?
+	 * the name and the class that defines it. Instance variables would
+	 * be instance fields of the Global prototype object. The runtime
+	 * version of this object would have the native field that implements
+	 * that variable.
+	 *
+	 * get x ();
+	 *
+	 * 1 aload_1							// get the target object value
+	 * 2 getfield #3 <Field int _values_[]>	// get the property values array
+	 * 5 iconst_0							// get the index of value
+	 * 6 iaload								// load the value from values
+	 */
+		
+	Value* JSILGenerator::evaluate( Context& cx, GetExpressionNode* node ) { 
+		return 0;
+    }
+    
+	/*
+	 * SetExpressionNode
+	 *
+	 * Set expressions are psuedo syntactic constructs, created when
+	 * a member expression is used in a context where a storage location
+	 * is expected. In the general case, a set expression is the same as
+	 * a call expression with one argument (the value to be stored.) In 
+	 * specfic cases, a get expression can be optimized as a direct access 
+	 * of a native field.
+	 *
+	 * set x (value);
+     *
+	 * 1 aload_1							// get the target object value
+	 * 2 getfield #3 <Field int values[]>	// get the property values array
+	 * 5 iconst_0							// get the index of the value
+	 * 6 iconst_5							// get the value
+	 * 7 iastore							// store the value in values
+	 */
+
+	Value* JSILGenerator::evaluate( Context& cx, SetExpressionNode* node ) { 
+		return 0;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, UnaryExpressionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, BinaryExpressionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ConditionalExpressionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, AssignmentExpressionNode* node ) { 
+        throw;
+    }
+    
+	/*
+	 * Generate the code for a list (e.g. argument list). The owner of this node
+	 * has already allocated a fixed size array. This function stuffs the list
+	 * values into that array.
+	 */
+	
+	int list_index;
+	int list_array_register;
+
+	Value* JSILGenerator::evaluate( Context& cx, ListNode* node ) { 
+		return 0;
+    }
+
+    // Statements
+
+    Value* JSILGenerator::evaluate( Context& cx, StatementListNode* node ) { 
+		return ObjectValue::undefinedValue;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, EmptyStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ExpressionStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, AnnotatedBlockNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, LabeledStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, IfStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, SwitchStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, CaseLabelNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, DoStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, WhileStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ForInStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ForStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, WithStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ContinueStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, BreakStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ReturnStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ThrowStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, TryStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, CatchClauseNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, FinallyClauseNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, UseStatementNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, IncludeStatementNode* node ) { 
+        throw;
+    }
+
+    // Definitions
+
+    Value* JSILGenerator::evaluate( Context& cx, ImportDefinitionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ImportBindingNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, AnnotatedDefinitionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, AttributeListNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ExportDefinitionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ExportBindingNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, VariableDefinitionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, VariableBindingNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, TypedVariableNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, FunctionDefinitionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, FunctionDeclarationNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, FunctionNameNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, FunctionSignatureNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ParameterNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, OptionalParameterNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ClassDefinitionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, ClassDeclarationNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, InheritanceNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, NamespaceDefinitionNode* node ) { 
+        throw;
+    }
+    
+	Value* JSILGenerator::evaluate( Context& cx, PackageDefinitionNode* node ) { 
+        throw;
+    }
+
+    Value* JSILGenerator::evaluate( Context& cx, ProgramNode* node ) {
+        throw;
+    }
+
+    /*
+     * Test driver
+     */
+
+}
+}
+
+/*
+ * Written by Jeff Dyer
+ * Copyright (c) 1998-2001 by Mountain View Compiler Company
+ * All rights reserved.
+ */

mozilla/js2/src/JSILGenerator.h

@@ -0,0 +1,136 @@
+/*
+ * JSILGenerator
+ */
+
+#ifndef JSILGenerator_h
+#define JSILGenerator_h
+
+#include <vector>
+
+#include "Value.h"
+#include "Context.h"
+#include "Evaluator.h"
+#include "icodegenerator.h"
+//#include "ByteCodeFactory.h"
+//#include "ClassFileConstants.h"
+
+namespace esc {
+namespace v1 {
+
+    class JavaScript::ICG::ICodeModule;
+
+using namespace esc::v1;
+
+class JSILGenerator : public Evaluator /*, private ByteCodeFactory*/ {
+
+public:
+
+	/*
+	 * Test driver
+	 */
+
+    static int main(int argc, char* argv[]);
+
+	/* Create a JSILGenerator object for each ICode module.
+	 */
+
+	JSILGenerator(std::string scriptname) {
+	}
+
+	~JSILGenerator() {
+	}
+
+    JavaScript::ICG::ICodeModule* emit();
+
+	// Base node
+    
+	Value* evaluate( Context& cx, Node* node );
+
+	// 3rd Edition features
+	
+	Value* evaluate( Context& cx, IdentifierNode* node );
+    Value* evaluate( Context& cx, ThisExpressionNode* node );
+    Value* evaluate( Context& cx, LiteralBooleanNode* node );
+    Value* evaluate( Context& cx, LiteralNumberNode* node );
+    Value* evaluate( Context& cx, LiteralStringNode* node );
+    Value* evaluate( Context& cx, LiteralUndefinedNode* node );
+    Value* evaluate( Context& cx, LiteralRegExpNode* node );
+    Value* evaluate( Context& cx, FunctionExpressionNode* node );
+    Value* evaluate( Context& cx, ParenthesizedExpressionNode* node );
+    Value* evaluate( Context& cx, ParenthesizedListExpressionNode* node );
+    Value* evaluate( Context& cx, LiteralObjectNode* node );
+    Value* evaluate( Context& cx, LiteralFieldNode* node );
+    Value* evaluate( Context& cx, LiteralArrayNode* node );
+    Value* evaluate( Context& cx, PostfixExpressionNode* node );
+    Value* evaluate( Context& cx, NewExpressionNode* node );
+    Value* evaluate( Context& cx, IndexedMemberExpressionNode* node );
+    Value* evaluate( Context& cx, MemberExpressionNode* node );
+    Value* evaluate( Context& cx, CallExpressionNode* node );
+    Value* evaluate( Context& cx, GetExpressionNode* node );
+    Value* evaluate( Context& cx, SetExpressionNode* node );
+    Value* evaluate( Context& cx, UnaryExpressionNode* node );
+    Value* evaluate( Context& cx, BinaryExpressionNode* node );
+    Value* evaluate( Context& cx, ConditionalExpressionNode* node );
+    Value* evaluate( Context& cx, AssignmentExpressionNode* node );
+    Value* evaluate( Context& cx, ListNode* node );
+    Value* evaluate( Context& cx, StatementListNode* node );
+    Value* evaluate( Context& cx, EmptyStatementNode* node );
+    Value* evaluate( Context& cx, ExpressionStatementNode* node );
+    Value* evaluate( Context& cx, AnnotatedBlockNode* node );
+    Value* evaluate( Context& cx, LabeledStatementNode* node );
+    Value* evaluate( Context& cx, IfStatementNode* node );
+    Value* evaluate( Context& cx, SwitchStatementNode* node );
+    Value* evaluate( Context& cx, CaseLabelNode* node );
+    Value* evaluate( Context& cx, DoStatementNode* node );
+    Value* evaluate( Context& cx, WhileStatementNode* node );
+    Value* evaluate( Context& cx, ForInStatementNode* node );
+    Value* evaluate( Context& cx, ForStatementNode* node );
+    Value* evaluate( Context& cx, WithStatementNode* node );
+    Value* evaluate( Context& cx, ContinueStatementNode* node );
+    Value* evaluate( Context& cx, BreakStatementNode* node );
+    Value* evaluate( Context& cx, ReturnStatementNode* node );
+    Value* evaluate( Context& cx, ThrowStatementNode* node );
+    Value* evaluate( Context& cx, TryStatementNode* node );
+    Value* evaluate( Context& cx, CatchClauseNode* node );
+    Value* evaluate( Context& cx, FinallyClauseNode* node );
+    Value* evaluate( Context& cx, AnnotatedDefinitionNode* node );
+    Value* evaluate( Context& cx, VariableDefinitionNode* node );
+    Value* evaluate( Context& cx, VariableBindingNode* node );
+    Value* evaluate( Context& cx, FunctionDefinitionNode* node );
+    Value* evaluate( Context& cx, FunctionDeclarationNode* node );
+    Value* evaluate( Context& cx, FunctionNameNode* node );
+    Value* evaluate( Context& cx, FunctionSignatureNode* node );
+    Value* evaluate( Context& cx, ParameterNode* node );
+    Value* evaluate( Context& cx, ProgramNode* node );
+
+	// 4th Edition features
+
+    Value* evaluate( Context& cx, QualifiedIdentifierNode* node );
+    Value* evaluate( Context& cx, UnitExpressionNode* node );
+    Value* evaluate( Context& cx, ClassofExpressionNode* node );
+    Value* evaluate( Context& cx, CoersionExpressionNode* node );
+    Value* evaluate( Context& cx, UseStatementNode* node );
+    Value* evaluate( Context& cx, IncludeStatementNode* node );
+    Value* evaluate( Context& cx, ImportDefinitionNode* node );
+    Value* evaluate( Context& cx, ImportBindingNode* node );
+    Value* evaluate( Context& cx, AttributeListNode* node );
+    Value* evaluate( Context& cx, ExportDefinitionNode* node );
+    Value* evaluate( Context& cx, ExportBindingNode* node );
+    Value* evaluate( Context& cx, TypedVariableNode* node );
+    Value* evaluate( Context& cx, OptionalParameterNode* node );
+    Value* evaluate( Context& cx, ClassDefinitionNode* node );
+    Value* evaluate( Context& cx, ClassDeclarationNode* node );
+    Value* evaluate( Context& cx, InheritanceNode* node );
+    Value* evaluate( Context& cx, NamespaceDefinitionNode* node );
+    Value* evaluate( Context& cx, PackageDefinitionNode* node );
+};
+
+}
+}
+
+#endif // JSILGenerator_h
+
+/*
+ * Copyright (c) 1998-2001 by Mountain View Compiler Company
+ * All rights reserved.
+ */

mozilla/js2/src/Makefile.am

@@ -0,0 +1,28 @@
+include $(top_srcdir)/common.mk
+
+noinst_LIBRARIES = libjs2.a
+
+libjs2_a_DEPENDENCIES = $(LIBFDLIBM)
+
+libjs2_a_SOURCES = \
+	bytecodegen.cpp \
+	collector.cpp \
+	exception.cpp \
+	formatter.cpp \
+	fdlibm_ns.cpp \
+	hash.cpp \
+	js2runtime.cpp \
+	js2execution.cpp \
+	jsarray.cpp \
+	jsmath.cpp \
+	jsstring.cpp \
+	lexer.cpp \
+	mem.cpp \
+	numerics.cpp \
+	parser.cpp \
+	reader.cpp \
+	strings.cpp \
+	tracer.cpp \
+	token.cpp \
+	utilities.cpp \
+	world.cpp

mozilla/js2/src/algo.h

@@ -0,0 +1,65 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#ifndef algo_h___
+#define algo_h___
+
+namespace JavaScript
+{
+//
+// Algorithms
+//
+
+    // Assign zero to every element between first inclusive and last exclusive.
+    // This is equivalent ot fill(first, last, 0) but may be more efficient.
+    template<class ForwardIterator>
+    inline void zero(ForwardIterator first, ForwardIterator last)
+    {
+        while (first != last) {
+            *first = 0;
+            ++first;
+        }
+    }
+
+
+    // Same as find(first, last, value) but may be more efficient because
+    // it doesn't use a reference for value.
+    template<class InputIterator, class T>
+    inline InputIterator findValue(InputIterator first, InputIterator last, T value)
+    {
+        while (first != last && !(*first == value))
+            ++first;
+        return first;
+    }
+}
+#endif /* algo_h___ */

mozilla/js2/src/bytecodegen.h

@@ -0,0 +1,396 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#ifndef bytecodegen_h___
+#define bytecodegen_h___
+
+#ifdef _WIN32
+ // Turn off warnings about identifiers too long in browser information
+#pragma warning(disable: 4786)
+#endif
+
+
+#include <vector>
+#include <map>
+
+#include "systemtypes.h"
+#include "strings.h"
+
+#include "tracer.h"
+
+namespace JavaScript {
+namespace JS2Runtime {
+
+    typedef enum {
+        // 1st 2 bits specify what kind of 'this' exists
+        NoThis = 0x00,
+        Inherent = 0x01,
+        Explicit = 0x02,
+        ThisFlags = 0x03,
+
+        // bit #3 indicates presence of named arguments
+        NamedArguments = 0x04,
+
+        // but #4 is set for the invocation of the super constructor
+        // from inside a constructor
+        SuperInvoke = 0x08
+
+    } CallFlag;
+
+typedef enum {
+
+    LoadConstantUndefinedOp,//                          --> <undefined value object>
+    LoadConstantTrueOp,     //                          --> <true value object>
+    LoadConstantFalseOp,    //                          --> <false value object>
+    LoadConstantNullOp,     //                          --> <null value object>
+    LoadConstantZeroOp,     //                          --> <+0.0 value object>
+    LoadConstantNumberOp,   // <poolindex>              --> <Number value object>
+    LoadConstantStringOp,   // <poolindex>              --> <String value object>
+    LoadThisOp,             //                          --> <this object>      
+    LoadFunctionOp,         // <pointer>        XXX !!! XXX
+    LoadTypeOp,             // <pointer>        XXX !!! XXX
+    InvokeOp,               // <argc> <thisflag>        <function> <args>  --> [<result>]
+    GetTypeOp,              //                          <object> --> <type of object>
+    CastOp,                 //                          <object> <type> --> <object>
+    DoUnaryOp,              // <operation>              <object> --> <result>
+    DoOperatorOp,           // <operation>              <object> <object> --> <result>
+    PushNullOp,             //                          --> <Object(null)>
+    PushIntOp,              // <int>                    --> <Object(int)>
+    PushNumOp,              // <num>                    --> <Object(num)>
+    PushStringOp,           // <poolindex>              --> <Object(index)>
+    PushTypeOp,             // <poolindex>
+    ReturnOp,               //                          <function> <args> <result> --> <result>
+    ReturnVoidOp,           //                          <function> <args> -->
+    GetConstructorOp,       //                          <type> --> <function> 
+    NewObjectOp,            //                          --> <object>
+    NewThisOp,              //                          <type> -->
+    NewInstanceOp,          //  <argc>                  <type> <args> --> <object>
+    DeleteOp,               //  <index>                 <object> --> <boolean>
+    TypeOfOp,               //                          <object> --> <string>
+    InstanceOfOp,           //                          <object> <object> --> <boolean>
+    AsOp,                   //                          <object> <type> --> <object>
+    IsOp,                   //                          <object> <object> --> <boolean>
+    ToBooleanOp,            //                          <object> --> <boolean>
+    JumpFalseOp,            // <target>                 <object> -->
+    JumpTrueOp,             // <target>                 <object> -->
+    JumpOp,                 // <target>            
+    TryOp,                  // <handler> <handler>
+    JsrOp,                  // <target>
+    RtsOp,
+    WithinOp,               //                          <object> -->
+    WithoutOp,              //
+    ThrowOp,                //                          <whatever> <object> --> <object>
+    HandlerOp,
+    LogicalXorOp,           //                          <object> <object> <boolean> <boolean> --> <object> 
+    LogicalNotOp,           //                          <object> --> <object>
+    SwapOp,                 //                          <object1> <object2> --> <object2> <object1>
+    DupOp,                  //                          <object> --> <object> <object>
+    DupInsertOp,            //                          <object1> <object2> --> <object2> <object1> <object2>
+    DupNOp,                 // <N>                      <object> --> <object> { N times }
+    DupInsertNOp,           // <N>                      <object> {xN} <object2> --> <object2> <object> {xN} <object2>
+    PopOp,                  //                          <object> -->   
+    // for instance members
+    GetFieldOp,             // <slot>                   <base> --> <object>
+    SetFieldOp,             // <slot>                   <base> <object> --> <object>
+    // for instance methods
+    GetMethodOp,            // <slot>                   <base> --> <base> <function>
+    GetMethodRefOp,         // <slot>                   <base> --> <bound function> 
+    // for argumentz
+    GetArgOp,               // <index>                  --> <object>
+    SetArgOp,               // <index>                  <object> --> <object>
+    // for local variables in the immediate scope
+    GetLocalVarOp,          // <index>                  --> <object>
+    SetLocalVarOp,          // <index>                  <object> --> <object>
+    // for local variables in the nth closure scope
+    GetClosureVarOp,        // <depth>, <index>         --> <object>
+    SetClosureVarOp,        // <depth>, <index>         <object> --> <object>
+    // for array elements
+    GetElementOp,           //                          <base> <index> --> <object>
+    SetElementOp,           //                          <base> <index> <object> --> <object>
+    // for properties
+    GetPropertyOp,          // <poolindex>              <base> --> <object>
+    GetInvokePropertyOp,    // <poolindex>              <base> --> <base> <object> 
+    SetPropertyOp,          // <poolindex>              <base> <object> --> <object>
+    // for all generic names 
+    GetNameOp,              // <poolindex>              --> <object>
+    GetTypeOfNameOp,        // <poolindex>              --> <object>
+    SetNameOp,              // <poolindex>              <object> --> <object>
+    LoadGlobalObjectOp,     //                          --> <object>
+    PushScopeOp,            // <pointer>        XXX !!! XXX
+    PopScopeOp,             // <pointer>        XXX !!! XXX
+    NewClosureOp,           //                          <function> --> <function>
+    ClassOp,                //                          <object> --> <type>
+    JuxtaposeOp,            //                          <attribute> <attribute> --> <attribute>
+    NamedArgOp,             //                          <object> <string> --> <named arg object>
+
+    OpCodeCount
+
+} ByteCodeOp;
+
+struct ByteCodeData {
+    int8 stackImpact;
+    char *opName;
+};
+extern ByteCodeData gByteCodeData[OpCodeCount];
+
+    typedef std::pair<uint32, size_t> PC_Position;
+
+
+    class ByteCodeModule {
+    public:
+            
+        ByteCodeModule(ByteCodeGen *bcg);
+
+#ifdef DEBUG
+        void* operator new(size_t s)    { void *t = STD::malloc(s); trace_alloc("ByteCodeModule", s, t); return t; }
+        void operator delete(void* t)   { trace_release("ByteCodeModule", t); STD::free(t); }
+#endif
+
+        uint32 getLong(uint32 index) const          { return *((uint32 *)&mCodeBase[index]); }
+        uint16 getShort(uint32 index) const         { return *((uint16 *)&mCodeBase[index]); }
+        int32 getOffset(uint32 index) const         { return *((int32 *)&mCodeBase[index]); }
+        const String *getString(uint32 index) const { return &mStringPoolContents[index]; }
+        float64 getNumber(uint32 index) const       { return mNumberPoolContents[index]; }
+
+        void setSource(const String &source, const String &sourceLocation)
+        {
+            mSource = source;
+            mSourceLocation = sourceLocation;
+        }
+
+        String mSource;
+        String mSourceLocation;
+
+        uint32 mLocalsCount;        // number of local vars to allocate space for
+        uint32 mStackDepth;         // max. depth of execution stack
+        
+        uint8 *mCodeBase;
+        uint32 mLength;
+
+        String *mStringPoolContents;
+        float64 *mNumberPoolContents;
+
+        PC_Position *mCodeMap;
+        uint32 mCodeMapLength;
+
+        size_t getPositionForPC(uint32 pc);
+            
+    };
+    Formatter& operator<<(Formatter& f, const ByteCodeModule& bcm);
+
+    #define BufferIncrement (32)
+
+#define NotALabel ((uint32)(-1))
+
+    class Label {
+    public:
+        
+        typedef enum { InternalLabel, NamedLabel, BreakLabel, ContinueLabel } LabelKind;
+
+        Label() : mKind(InternalLabel), mHasLocation(false) { }
+        Label(LabelStmtNode *lbl) : mKind(NamedLabel), mHasLocation(false), mLabelStmt(lbl) { }
+        Label(LabelKind kind) : mKind(kind), mHasLocation(false) { }
+
+        bool matches(const StringAtom *name)
+        {
+            return ((mKind == NamedLabel) && (mLabelStmt->name.compare(*name) == 0));
+        }
+
+        bool matches(LabelKind kind)
+        {
+            return (mKind == kind);
+        }
+
+        void addFixup(ByteCodeGen *bcg, uint32 branchLocation);        
+        void setLocation(ByteCodeGen *bcg, uint32 location);
+
+        std::vector<uint32> mFixupList;
+
+        LabelKind mKind;
+        bool mHasLocation;
+        LabelStmtNode *mLabelStmt;
+
+        uint32 mLocation;
+    };
+
+    class ByteCodeGen {
+    public:
+
+        ByteCodeGen(Context *cx, ScopeChain *scopeChain) 
+            :   mBuffer(new CodeBuffer), 
+                mScopeChain(scopeChain), 
+                mPC_Map(new CodeMap),
+                m_cx(cx), 
+                mNamespaceList(NULL) ,
+                mStackTop(0),
+                mStackMax(0)
+        { }
+
+#ifdef DEBUG
+        void* operator new(size_t s)    { void *t = STD::malloc(s); trace_alloc("ByteCodeGen", s, t); return t; }
+        void operator delete(void* t)   { trace_release("ByteCodeGen", t); STD::free(t); }
+#endif
+
+        ByteCodeModule *genCodeForScript(StmtNode *p);
+        bool genCodeForStatement(StmtNode *p, ByteCodeGen *static_cg, uint32 finallyLabel);
+        void genCodeForFunction(FunctionDefinition &f, 
+                                    size_t pos,
+                                    JSFunction *fnc, 
+                                    bool isConstructor, 
+                                    JSType *topClass);
+        ByteCodeModule *genCodeForExpression(ExprNode *p);
+
+        JSType *genExpr(ExprNode *p);
+        Reference *genReference(ExprNode *p, Access acc);
+        void genReferencePair(ExprNode *p, Reference *&readRef, Reference *&writeRef);
+
+        typedef std::vector<uint8> CodeBuffer;
+
+        typedef std::vector<PC_Position> CodeMap;
+
+        // this is the current code buffer
+        CodeBuffer *mBuffer;
+        ScopeChain *mScopeChain;
+        CodeMap *mPC_Map;
+
+        Context *m_cx;
+        
+        std::vector<Label> mLabelList;
+        std::vector<uint32> mLabelStack;
+
+        NamespaceList *mNamespaceList;
+
+        int32 mStackTop;        // keep these as signed so as to
+        int32 mStackMax;        // track if they go negative.
+
+        bool hasContent()
+        {
+            return (mBuffer->size() > 0);
+        }
+       
+        void addOp(uint8 op);       // XXX move more outline if it helps to reduce overall .exe size
+
+        void addPosition(size_t pos)    { mPC_Map->push_back(PC_Position(mBuffer->size(), pos)); }
+
+        // Add in the opcode effect as usual, but also stretch the
+        // execution stack by N, as the opcode has that effect during
+        // execution.
+        void addOpStretchStack(uint8 op, int32 n)        
+        {
+            addByte(op);
+            mStackTop += gByteCodeData[op].stackImpact;
+            if ((mStackTop + n) > mStackMax)
+                mStackMax = mStackTop + n;
+            ASSERT(mStackTop >= 0);
+        }
+
+        void adjustStack(int32 n)
+        {
+            mStackTop += n;
+            if ((mStackTop + n) > mStackMax)
+                mStackMax = mStackTop + n;
+            ASSERT(mStackTop >= 0);
+        }
+
+        // Make sure there's room for n more operands on the stack
+        void stretchStack(int32 n)
+        {
+            if ((mStackTop + n) > mStackMax)
+                mStackMax = mStackTop + n;
+        }
+
+        // these routines assume the depth is being reduced
+        // i.e. they don't reset mStackMax
+        void addOpAdjustDepth(uint8 op, int32 depth)        
+                                    { addByte(op); mStackTop += depth; ASSERT(mStackTop >= 0); }
+        void addOpSetDepth(uint8 op, int32 depth)        
+                                    { addByte(op); mStackTop = depth; ASSERT(mStackTop >= 0); }
+
+        void addByte(uint8 v)       { mBuffer->push_back(v); }
+        void addShort(uint16 v)     { mBuffer->push_back((uint8)(v >> 8)); mBuffer->push_back((uint8)(v)); }
+
+        void addPointer(void *v)    { ASSERT(sizeof(void *) == sizeof(uint32)); addLong((uint32)(v)); }   // XXX Pointer size dependant !!!
+        
+        void addLong(uint32 v)     
+            { mBuffer->insert(mBuffer->end(), (uint8 *)&v, (uint8 *)(&v) + sizeof(uint32)); }
+        void addOffset(int32 v)     
+            { mBuffer->insert(mBuffer->end(), (uint8 *)&v, (uint8 *)(&v) + sizeof(int32)); }
+        void setOffset(uint32 index, int32 v)
+            {   *((int32 *)(mBuffer->begin() + index)) = v; }   // XXX
+
+        void addFixup(uint32 label) 
+        { 
+            mLabelList[label].addFixup(this, mBuffer->size()); 
+        }
+
+        uint32 getLabel();
+
+        uint32 getLabel(Label::LabelKind kind);
+
+        uint32 getLabel(LabelStmtNode *lbl);
+
+        uint32 getTopLabel(Label::LabelKind kind, const StringAtom *name);
+
+        uint32 getTopLabel(Label::LabelKind kind);
+
+        void setLabel(uint32 label)
+        {
+            mLabelList[label].setLocation(this, mBuffer->size()); 
+        }
+
+        uint32 currentOffset()
+        {
+            return mBuffer->size();
+        }
+
+        std::vector<String> mStringPoolContents;
+        typedef std::map<String, uint32, std::less<String> > StringPool;
+        StringPool mStringPool;
+
+        std::vector<float64> mNumberPoolContents;
+        typedef std::map<float64, uint32, std::less<double> > NumberPool;
+        NumberPool mNumberPool;
+
+
+        void addNumberRef(float64 f);
+        
+        void addStringRef(const String &str);
+
+
+    };
+
+
+    uint32 printInstruction(Formatter &f, uint32 i, const ByteCodeModule& bcm);
+}
+}
+#endif /* bytecodegen_h___ */

mozilla/js2/src/collector.cpp

@@ -0,0 +1,240 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s):  Patrick Beard <beard@netscape.com>
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#include "collector.h"
+
+namespace JavaScript
+{
+
+Collector::Collector()
+    :   mObjectSpace(kObjectSpaceSize),
+        mFloatSpace(kFloatSpaceSize)
+{
+}
+
+Collector::~Collector()
+{
+}
+
+void
+Collector::addRoot(void* root, size_type n)
+{
+    mRoots.push_back(RootSegment(pointer(root), n));
+}
+
+void
+Collector::removeRoot(void* root)
+{
+    for (RootSegments::iterator i = mRoots.begin(), e = mRoots.end(); i != e; ++i) {
+        if (i->first == root) {
+            mRoots.erase(i);
+            return;
+        }
+    }
+}
+
+inline Collector::size_type align(Collector::size_type n)
+{
+    return (n + (kObjectAlignment - 1)) & kObjectAddressMask;
+}
+
+Collector::pointer
+Collector::allocateObject(size_type n, pointer type)
+{
+    size_type size = align(n + sizeof(ObjectHeader));
+    pointer ptr = mObjectSpace.mAllocPtr;
+    if ((ptr + size) <= mObjectSpace.mLimitPtr) {
+        mObjectSpace.mAllocPtr += size;
+        ObjectHeader* header = (ObjectHeader*) ptr;
+        header->mSize = size;
+        header->mType = type;
+        return (pointer) std::memset(ptr + sizeof(ObjectHeader), 0, n);
+    }
+    // need to run a garbage collection to recover more space, or double space size?
+    return 0;
+}
+
+float64*
+Collector::allocateFloat64(float64 value)
+{
+    float64* fptr = mFloatSpace.mAllocPtr;
+    if (fptr < mFloatSpace.mLimitPtr) {
+        mFloatSpace.mAllocPtr++;
+        *fptr = value;
+        return (float64*) (uint32(fptr) | kFloat64Tag);
+    }
+    // need to run a garbage collection to recover more space, or double space size?
+    return 0;
+}
+
+inline bool is_object(Collector::pointer ref)
+{
+    return ((uint32(ref) & kObjectAddressMask) == uint32(ref));
+}
+
+inline bool is_float64(Collector::pointer ref)
+{
+    return ((uint32(ref) & kFloat64TagMask) == kFloat64Tag);
+}
+
+void
+Collector::collect()
+{
+    // 0. swap from/to space. we now start allocating in the new toSpace.
+    Space<char>::pointer_type scanPtr = mObjectSpace.Swap();
+    mFloatSpace.Swap();
+
+    // 1. scan all registered root segments.
+    for (RootSegments::iterator i = mRoots.begin(), e = mRoots.end(); i != e; ++i) {
+        RootSegment& r = *i;
+        
+        pointer* refs = (pointer*) r.first;
+        pointer* limit = (pointer*) (r.first + r.second);
+        while (refs < limit) {
+            pointer& ref = *refs++;
+            if (ref) {
+                if (is_object(ref))
+                    ref = copy(ref);
+                else
+                if (is_float64(ref))
+                    ref = copyFloat64(ref);
+            }
+        }
+    }
+    
+    // 2. Scan through toSpace until scanPtr meets mAllocPtr.
+    while (scanPtr < mObjectSpace.mAllocPtr) {
+        ObjectHeader* header = (ObjectHeader*) scanPtr;
+        if (header->mType)
+            header->mType = copy(header->mType);
+        scanPtr += header->mSize;
+        pointer* refs = (pointer*) (header + 1);
+        pointer* limit = (pointer*) scanPtr;
+        while (refs < limit) {
+            pointer& ref = *refs++;
+            if (ref) {
+                if (is_object(ref))
+                    ref = copy(ref);
+                else
+                if (is_float64(ref))
+                    ref = copyFloat64(ref);
+            }
+        }
+    }
+}
+
+Collector::pointer
+Collector::copy(pointer object)
+{
+    // forwarding pointer?
+    ObjectHeader* oldHeader = ((ObjectHeader*)object) - 1;
+    if (oldHeader->mSize == kIsForwardingPointer)
+        return oldHeader->mType;
+
+    // copy the old object into toSpace. copy will always succeed,
+    // because we only call it from within collect. the problem
+    // is when we don't recover any space... will have to be able
+    // to expand the heaps.
+    size_type n = oldHeader->mSize;
+    ObjectHeader* newHeader = (ObjectHeader*) mObjectSpace.mAllocPtr;
+    mObjectSpace.mAllocPtr += n;
+    std::memcpy(newHeader, oldHeader, n);
+    oldHeader->mSize = kIsForwardingPointer;
+    oldHeader->mType = (pointer) (newHeader + 1);
+    
+    return (pointer) (newHeader + 1);
+}
+
+Collector::pointer
+Collector::copyFloat64(pointer object)
+{
+    float64* fptr = mFloatSpace.mAllocPtr++;
+    *fptr = *(float64*) (uint32(object) & kFloat64AddressMask);
+    return (pointer) (uint32(fptr) | kFloat64Tag);
+}
+
+#if DEBUG
+
+struct ConsCell {
+    float64* car;
+    ConsCell* cdr;
+
+    void* operator new(std::size_t n, Collector& gc)
+    {
+        return gc.allocateObject(n);
+    }
+};
+
+void testCollector()
+{
+    Collector gc;
+    
+    ConsCell* head = 0;
+    gc.addRoot(&head, sizeof(ConsCell*));
+    
+    const uint32 kCellCount = 100;
+    
+    ConsCell* cell;
+    ConsCell** link = &head;
+    
+    for (uint32 i = 0; i < kCellCount; ++i) {
+        *link = cell = new (gc) ConsCell;
+        ASSERT(cell);
+        cell->car = gc.allocateFloat64(i);
+        ASSERT(cell->car);
+        link = &cell->cdr;
+    }
+    
+    // circularly link the list.
+    *link = head;
+    
+    // run a garbage collection.
+    gc.collect();
+    
+    // walk the list again to verify that it is intact.
+    link = &head;
+    for (uint32 i = 0; i < kCellCount; i++) {
+        cell = *link;
+        ASSERT(cell->car);
+        float64 value = gc.getFloat64(cell->car);
+        ASSERT(value == (float64)i);
+        link = &cell->cdr;
+    }
+    
+    // make sure list is still circularly linked.
+    ASSERT(*link == head);
+}
+
+#endif // DEBUG
+
+}

mozilla/js2/src/collector.h

@@ -0,0 +1,156 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s):  Patrick Beard <beard@netscape.com>
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#ifndef collector_h___
+#define collector_h___
+
+#include "mem.h"
+#include <deque>
+#include <utility>
+
+namespace JavaScript
+{
+    using std::deque;
+    using std::pair;
+
+    // tuneable parameters of the collector.
+    enum {
+        kLogObjectAlignment = 3,
+        kObjectAlignment = (1 << kLogObjectAlignment),
+        kObjectAddressMask = (-1 << kLogObjectAlignment),
+
+        kFloat64Tag = 0x2,
+        kFloat64TagMask = ~(-1 << 2),
+        kFloat64AddressMask = (-1 << 2),
+
+        kIsForwardingPointer = 0x1,
+
+        kObjectSpaceSize = 1024 * 1024,
+        kFloatSpaceSize = kObjectSpaceSize / sizeof(float64)
+    };
+
+    // collector entry points.
+    class Collector {
+    public:
+        typedef size_t size_type;
+        typedef ptrdiff_t difference_type;
+        typedef char *pointer;
+        typedef const char *const_pointer;
+
+        struct ObjectHeader {
+            size_type mSize;
+            pointer mType;
+        };
+        
+        Collector();
+        ~Collector();
+
+        void addRoot(void* root, size_type n);
+        void removeRoot(void* root);
+
+        pointer allocateObject(size_type n, pointer type = 0);
+        float64* allocateFloat64(float64 value = 0.0);
+        
+        void collect();
+        
+        pointer getType(pointer object)
+        {
+            return ((ObjectHeader*)object)[-1].mType;
+        }
+        
+        size_type getSize(pointer object)
+        {
+            return ((ObjectHeader*)object)[-1].mSize;
+        }
+        
+        float64 getFloat64(float64* fptr)
+        {
+            return *(float64*)(uint32(fptr) & kFloat64AddressMask);
+        }
+        
+    private:
+        template <typename T> struct Space {
+            typedef T value_type;
+            typedef T *pointer_type;
+            size_type mSize;
+            pointer_type mFromPtr;
+            pointer_type mToPtr;
+            pointer_type mAllocPtr;
+            pointer_type mLimitPtr;
+            
+            Space(size_type n)
+                :   mSize(n), mFromPtr(0), mToPtr(0),
+                    mAllocPtr(0), mLimitPtr(0)
+            {
+                mFromPtr = new value_type[n];
+                mToPtr = new value_type[n];
+                mAllocPtr = mToPtr;
+                mLimitPtr = mToPtr + n;
+            }
+            
+            ~Space()
+            {
+                delete[] mFromPtr;
+                delete[] mToPtr;
+            }
+            
+            pointer_type Swap()
+            {
+                pointer_type newToPtr = mFromPtr;
+                pointer_type newFromPtr = mToPtr;
+                mToPtr = newToPtr;
+                mAllocPtr = newToPtr;
+                mLimitPtr = newToPtr + mSize;
+                mFromPtr = newFromPtr;
+                pointer_type scanPtr = newToPtr;
+                return scanPtr;
+            }
+        };
+        Space<char> mObjectSpace;
+        Space<float64> mFloatSpace;
+
+        typedef pair<pointer, size_type> RootSegment;
+        typedef deque<RootSegment> RootSegments;
+        RootSegments mRoots;
+
+        pointer copy(pointer object);
+        pointer copyFloat64(pointer object);
+        
+        Collector(const Collector&);        // No copy constructor
+        void operator=(const Collector&);   // No assignment operator
+    };
+
+    void testCollector();
+}
+
+#endif // collector_h___

mozilla/js2/src/cpucfg.h

@@ -0,0 +1,191 @@
+/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is Mozilla Communicator client code, released
+ * March 31, 1998.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#ifndef cpucfg_h
+#define cpucfg_h
+
+#define JS_HAVE_LONG_LONG
+
+#ifdef XP_MAC
+#undef  IS_LITTLE_ENDIAN
+#define IS_BIG_ENDIAN 1
+
+#define JS_BYTES_PER_BYTE   1L
+#define JS_BYTES_PER_SHORT  2L
+#define JS_BYTES_PER_INT    4L
+#define JS_BYTES_PER_INT64  8L
+#define JS_BYTES_PER_LONG   4L
+#define JS_BYTES_PER_FLOAT  4L
+#define JS_BYTES_PER_DOUBLE 8L
+#define JS_BYTES_PER_WORD   4L
+#define JS_BYTES_PER_DWORD  8L
+
+#define JS_BITS_PER_BYTE    8L
+#define JS_BITS_PER_SHORT   16L
+#define JS_BITS_PER_INT     32L
+#define JS_BITS_PER_INT64   64L
+#define JS_BITS_PER_LONG    32L
+#define JS_BITS_PER_FLOAT   32L
+#define JS_BITS_PER_DOUBLE  64L
+#define JS_BITS_PER_WORD    32L
+
+#define JS_BITS_PER_BYTE_LOG2   3L
+#define JS_BITS_PER_SHORT_LOG2  4L
+#define JS_BITS_PER_INT_LOG2    5L
+#define JS_BITS_PER_INT64_LOG2  6L
+#define JS_BITS_PER_LONG_LOG2   5L
+#define JS_BITS_PER_FLOAT_LOG2  5L
+#define JS_BITS_PER_DOUBLE_LOG2 6L
+#define JS_BITS_PER_WORD_LOG2   5L
+
+#define JS_ALIGN_OF_SHORT   2L
+#define JS_ALIGN_OF_INT     4L
+#define JS_ALIGN_OF_LONG    4L
+#define JS_ALIGN_OF_INT64   2L
+#define JS_ALIGN_OF_FLOAT   4L
+#define JS_ALIGN_OF_DOUBLE  4L
+#define JS_ALIGN_OF_POINTER 4L
+#define JS_ALIGN_OF_WORD    4L
+
+#define JS_BYTES_PER_WORD_LOG2   2L
+#define JS_BYTES_PER_DWORD_LOG2  3L
+#define PR_WORDS_PER_DWORD_LOG2  1L
+
+#elif defined(XP_PC)
+
+#ifdef _WIN32
+#define IS_LITTLE_ENDIAN 1
+#undef  IS_BIG_ENDIAN
+
+#define JS_BYTES_PER_BYTE   1L
+#define JS_BYTES_PER_SHORT  2L
+#define JS_BYTES_PER_INT    4L
+#define JS_BYTES_PER_INT64  8L
+#define JS_BYTES_PER_LONG   4L
+#define JS_BYTES_PER_FLOAT  4L
+#define JS_BYTES_PER_DOUBLE 8L
+#define JS_BYTES_PER_WORD   4L
+#define JS_BYTES_PER_DWORD  8L
+
+#define JS_BITS_PER_BYTE    8L
+#define JS_BITS_PER_SHORT   16L
+#define JS_BITS_PER_INT     32L
+#define JS_BITS_PER_INT64   64L
+#define JS_BITS_PER_LONG    32L
+#define JS_BITS_PER_FLOAT   32L
+#define JS_BITS_PER_DOUBLE  64L
+#define JS_BITS_PER_WORD    32L
+
+#define JS_BITS_PER_BYTE_LOG2   3L
+#define JS_BITS_PER_SHORT_LOG2  4L
+#define JS_BITS_PER_INT_LOG2    5L
+#define JS_BITS_PER_INT64_LOG2  6L
+#define JS_BITS_PER_LONG_LOG2   5L
+#define JS_BITS_PER_FLOAT_LOG2  5L
+#define JS_BITS_PER_DOUBLE_LOG2 6L
+#define JS_BITS_PER_WORD_LOG2   5L
+
+#define JS_ALIGN_OF_SHORT   2L
+#define JS_ALIGN_OF_INT     4L
+#define JS_ALIGN_OF_LONG    4L
+#define JS_ALIGN_OF_INT64   8L
+#define JS_ALIGN_OF_FLOAT   4L
+#define JS_ALIGN_OF_DOUBLE  4L
+#define JS_ALIGN_OF_POINTER 4L
+#define JS_ALIGN_OF_WORD    4L
+
+#define JS_BYTES_PER_WORD_LOG2   2L
+#define JS_BYTES_PER_DWORD_LOG2  3L
+#define PR_WORDS_PER_DWORD_LOG2  1L
+#endif /* _WIN32 */
+
+#if defined(_WINDOWS) && !defined(_WIN32) /* WIN16 */
+#define IS_LITTLE_ENDIAN 1
+#undef  IS_BIG_ENDIAN
+
+#define JS_BYTES_PER_BYTE   1L
+#define JS_BYTES_PER_SHORT  2L
+#define JS_BYTES_PER_INT    2L
+#define JS_BYTES_PER_INT64  8L
+#define JS_BYTES_PER_LONG   4L
+#define JS_BYTES_PER_FLOAT  4L
+#define JS_BYTES_PER_DOUBLE 8L
+#define JS_BYTES_PER_WORD   4L
+#define JS_BYTES_PER_DWORD  8L
+
+#define JS_BITS_PER_BYTE    8L
+#define JS_BITS_PER_SHORT   16L
+#define JS_BITS_PER_INT     16L
+#define JS_BITS_PER_INT64   64L
+#define JS_BITS_PER_LONG    32L
+#define JS_BITS_PER_FLOAT   32L
+#define JS_BITS_PER_DOUBLE  64L
+#define JS_BITS_PER_WORD    32L
+
+#define JS_BITS_PER_BYTE_LOG2   3L
+#define JS_BITS_PER_SHORT_LOG2  4L
+#define JS_BITS_PER_INT_LOG2    4L
+#define JS_BITS_PER_INT64_LOG2  6L
+#define JS_BITS_PER_LONG_LOG2   5L
+#define JS_BITS_PER_FLOAT_LOG2  5L
+#define JS_BITS_PER_DOUBLE_LOG2 6L
+#define JS_BITS_PER_WORD_LOG2   5L
+
+#define JS_ALIGN_OF_SHORT   2L
+#define JS_ALIGN_OF_INT     2L
+#define JS_ALIGN_OF_LONG    2L
+#define JS_ALIGN_OF_INT64   2L
+#define JS_ALIGN_OF_FLOAT   2L
+#define JS_ALIGN_OF_DOUBLE  2L
+#define JS_ALIGN_OF_POINTER 2L
+#define JS_ALIGN_OF_WORD    2L
+
+#define JS_BYTES_PER_WORD_LOG2   2L
+#define JS_BYTES_PER_DWORD_LOG2  3L
+#define PR_WORDS_PER_DWORD_LOG2  1L
+#endif /* defined(_WINDOWS) && !defined(_WIN32) */
+
+#elif defined(XP_UNIX) || defined(XP_BEOS)
+
+#error "This file is supposed to be auto-generated on UNIX platforms, but the"
+#error "static version for Mac and Windows platforms is being used."
+#error "Something's probably wrong with paths/headers/dependencies/Makefiles."
+
+#else
+
+#error "Must define one of XP_MAC, XP_PC, or XP_UNIX"
+
+#endif
+
+#endif

mozilla/js2/src/debugger.cpp

@@ -0,0 +1,472 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#ifdef _WIN32
+ // Turn off warnings about identifiers too long in browser information
+ #pragma warning(disable: 4786)
+#endif
+
+#include "world.h"
+#include "utilities.h"
+#include "debugger.h"
+
+#include <string>
+#include <ctype.h>
+#include <assert.h>
+
+namespace JavaScript {
+namespace Debugger {
+
+    using namespace Interpreter;
+
+    /* keep in sync with list in debugger.h */
+    static const char *shell_cmds[][3] = {
+        {"assemble", "", 0},
+        {"ambiguous", "", "Test command for ambiguous command detection"},
+        {"ambiguous2", "", "Test command for ambiguous command detection"},
+        {"continue", "", "Continue execution until complete."},
+        {"dissassemble", "[start_pc] [end_pc]", "Dissassemble entire module, or subset of module."},
+        {"exit", "", 0},
+        {"help", "", "Display this message."},
+        {"istep", "", "Execute the current opcode and stop."},
+        {"let", "", "Set a debugger environment variable."},
+        {"print", "", 0},
+        {"register", "", "(nyi) Show the value of a single register or all registers, or set the value of a single register."},
+        {"step", "", "Execute the current JS statement and stop."},
+        {0, 0} /* sentry */
+    };
+
+    enum ShellVariable {
+        TRACE_SOURCE,
+        TRACE_ICODE,
+        VARIABLE_COUNT
+    };
+    
+    static const char *shell_vars[][3] = {
+        {"tracesource", "", "(bool) Show JS source while executing."},
+        {"traceicode", " ", "(bool) Show opcodes while executing."},
+        {0, 0} /* sentry */
+    };
+    
+    /* return true if str2 starts with/is str1
+     * XXX ignore case */
+    static bool
+    startsWith (const String &str1, const String &str2)
+    {
+        uint n;
+        size_t m = str1.size();
+
+        if (m > str2.size())
+            return false;
+
+        for (n = 0; n < m; ++n)
+            if (str1[n] != str2[n])
+                return false;
+        
+        return true;
+    }
+
+
+    /**
+     * locate the best match for |partial| in the command list |list|.
+     * if no matches are found, return |length|, if multiple matches are found,
+     * return |length| plus the number of ambiguous matches
+     */
+    static uint32
+    matchElement (const String &partial, const char *list[][3], size_t length)
+    {
+        uint32 ambig_matches = 0;
+        uint32 match = length;
+        
+        for (uint32 i = 0; i < length ; ++i)
+        {
+            String possibleMatch (widenCString(list[i][0]));
+            if (startsWith(partial, possibleMatch))
+            {
+                if (partial.size() == possibleMatch.size())
+                {
+                    /* exact match */
+                    ambig_matches = 0;
+                    return i;
+                }
+                else if (match == COMMAND_COUNT) /* no match yet */
+                    match = i;
+                else
+                    ++ambig_matches; /* something already matched, 
+                                      * ambiguous command */
+            }
+            
+        }
+
+        if (ambig_matches == 0)
+            return match;
+        else
+            return length + ambig_matches;
+        
+    }    
+
+    static void
+    showHelp(Formatter &out)
+    {
+        int i;
+        
+        out << "JavaScript 2.0 Debugger Help...\n\n";
+        
+        for (i = 0; shell_cmds[i][0] != 0; i++)
+        {
+            out << "Command : " << shell_cmds[i][0] << " " << 
+                shell_cmds[i][1] << "\n";
+
+            if (shell_cmds[i][2])
+                out << "Help    : " << shell_cmds[i][2] << "\n";
+            else
+                out << "Help    : (probably) Not Implemented.\n";
+        }
+    }
+
+    static uint32
+    getClosestSourcePosForPC (Context *cx, InstructionIterator pc)
+    {
+        ICodeModule *iCode = cx->getICode();
+        
+        if (iCode->mInstructionMap->begin() == iCode->mInstructionMap->end())
+            return NotABanana;
+            /*NOT_REACHED ("Instruction map is empty, waah.");*/
+
+        InstructionMap::iterator pos_iter =
+            iCode->mInstructionMap->upper_bound (static_cast<uint32>(pc - iCode->its_iCode->begin()));
+        if (pos_iter != iCode->mInstructionMap->begin())
+            --pos_iter;
+    
+        return pos_iter->second;
+    }
+        
+    void
+    Shell::showSourceAtPC (Context *cx, InstructionIterator pc)
+    {
+        if (!mResolveFileCallback)
+        {
+            mErr << "Source not available (Debugger was improperly initialized.)\n";
+            return;
+        }
+
+        ICodeModule *iCode = cx->getICode();
+
+        String fn = iCode->getFileName();
+        const Reader *reader = mResolveFileCallback(fn);
+        if (!reader)
+        {
+            mErr << "Source not available.\n";
+            return;
+        }
+        
+        uint32 pos = getClosestSourcePosForPC(cx, pc);
+        if (pos == NotABanana)
+        {
+            mErr << "Map is empty, cannot display source.\n";
+            return;
+        }
+            
+        uint32 lineNum = reader->posToLineNum (pos);
+        const char16 *lineBegin, *lineEnd;
+
+        uint32 lineStartPos = reader->getLine (lineNum, lineBegin, lineEnd);
+        String sourceLine (lineBegin, lineEnd);
+        
+        mOut << fn << ":" << lineNum << " " << sourceLine << "\n";
+
+        uint padding = fn.length() + (uint32)(lineNum / 10) + 3;
+        uint i;        
+
+        for (i = 0; i < padding; i++)
+            mOut << " ";
+        
+        padding = (pos - lineStartPos);
+        for (i = 0; i < padding; i++)
+            mOut << ".";
+        
+        mOut << "^\n";
+        
+    }
+
+    void
+    Shell::showOpAtPC(Context* cx, InstructionIterator pc)
+    {
+        ICodeModule *iCode = cx->getICode();
+
+        if ((pc < iCode->its_iCode->begin()) ||
+            (pc >= iCode->its_iCode->end()))
+        {
+            mErr << "PC Out Of Range.";
+            return;
+        }
+
+        JSValues &registers = cx->getRegisters();
+
+        printFormat(mOut, "trace [%02u:%04u]: ",
+                    iCode->mID, (pc - iCode->its_iCode->begin()));
+        Instruction* i = *pc;
+        stdOut << *i;
+        if (i->op() != BRANCH && i->count() > 0) {
+            mOut << " [";
+            i->printOperands(stdOut, registers);
+            mOut << "]\n";
+        } else {
+            mOut << '\n';
+        }
+    }    
+
+    void
+    Shell::listen(Context* cx, Context::Event event)
+    {
+        InstructionIterator pc = cx->getPC();
+        
+        if (mTraceSource)
+            showSourceAtPC (cx, pc);
+        if (mTraceICode)
+            showOpAtPC (cx, pc);
+            
+        if (!(mStopMask & event))
+            return;
+
+        if ((mLastCommand == STEP) && (mLastICodeID == cx->getICode()->mID) &&
+            (mLastSourcePos == getClosestSourcePosForPC (cx, cx->getPC())))
+            /* we're in source-step mode, and the source position hasn't
+             * changed yet */
+            return;
+
+        if (!mTraceSource && !mTraceICode)
+            showSourceAtPC (cx, pc);
+                
+        static String lastLine(widenCString("help\n"));
+        String line;
+        LineReader reader(mIn);
+
+        do {
+            stdOut << "jsd";
+            if (mLastCommand != COMMAND_COUNT)
+                stdOut << " (" << shell_cmds[mLastCommand][0] << ") ";
+            stdOut << "> ";
+        
+            reader.readLine(line);
+
+            if (line[0] == uni::lf)
+                line = lastLine;
+            else
+                lastLine = line;
+
+        } while (doCommand(cx, line));
+    }
+
+
+    /**
+     * lex and execute the debugger command in |source|, return true if the
+     * command does not require the script being debugged to continue (eg, ask
+     * for more debugger input.)
+     */
+    bool
+    Shell::doCommand (Interpreter::Context *cx, const String &source)
+    {
+        Lexer lex (mWorld, source, widenCString("debugger console"), 0);
+        const String *cmd;
+        uint32 match;
+        bool rv = true;
+        
+        const Token &t = lex.get(true);
+
+        if (t.hasKind(Token::identifier))
+            cmd = &(t.getIdentifier());
+        else
+        {
+            mErr << "you idiot.\n";
+            return true;
+        }        
+
+        match = matchElement (*cmd, shell_cmds, (size_t)COMMAND_COUNT);
+        
+        if (match <= (uint32)COMMAND_COUNT)
+        {
+            switch ((ShellCommand)match)
+            {
+                case COMMAND_COUNT:
+                    mErr << "Unknown command '" << *cmd << "'.\n";
+                    break;
+
+                case AMBIGUOUS:
+                case AMBIGUOUS2:
+                    mErr << "I pity the foogoo.\n";
+                    break;
+
+                case CONTINUE:
+                    mStopMask &= (Context::EV_ALL ^ Context::EV_STEP);
+                    rv = false;
+                    break;
+
+                case DISSASSEMBLE:
+                    mOut << *cx->getICode();
+                    break;    
+
+                case HELP:
+                    showHelp (mOut);
+                    break;
+
+                case PRINT:
+                    doPrint (cx, lex);
+                    break;
+                    
+                case STEP:
+                    mStopMask |= Context::EV_STEP;
+                    rv = false;
+                    break;
+                    
+                case LET:
+                    doSetVariable (lex);
+                    break;
+
+                default:
+                    mErr << "Input '" << *cmd << "' matched unimplemented " <<
+                        "command '" << shell_cmds[match][0] << "'.\n";
+                    break;
+                    
+            }
+
+            mLastSourcePos = getClosestSourcePosForPC (cx, cx->getPC());
+            mLastICodeID = cx->getICode()->mID;
+            mLastCommand = (ShellCommand)match;
+
+        } else
+            mErr << "Ambiguous command '" << *cmd << "', " <<
+                (match - (uint32)COMMAND_COUNT + 1) << " similar commands.\n";
+
+        return rv;        
+    }
+
+    void
+    Shell::doSetVariable (Lexer &lex)
+    {
+        uint32 match;
+        const String *varname;        
+        const Token *t = &(lex.get(true));
+
+        if (t->hasKind(Token::identifier))
+            varname = &(t->getIdentifier());
+        else
+        {
+            mErr << "invalid variable name.\n";
+            return;
+        }        
+
+        match = matchElement (*varname, shell_vars, (size_t)VARIABLE_COUNT);
+
+        if (match <= (uint32)VARIABLE_COUNT)
+            switch ((ShellVariable)match)
+            {
+                case VARIABLE_COUNT:
+                    mErr << "Unknown variable '" << *varname << "'.\n";
+                    break;
+                    
+                case TRACE_SOURCE:
+                    t = &(lex.get(true));
+                    if (t->hasKind(Token::assignment))
+                        t = &(lex.get(true)); /* optional = */
+
+                    if (t->hasKind(Token::True))
+                        mTraceSource = true;
+                    else if (t->hasKind(Token::False))
+                        mTraceSource = false;
+                    else
+                        goto badval;
+                    break;
+
+                case TRACE_ICODE:
+                    t = &(lex.get(true));
+                    if (t->hasKind(Token::assignment))
+                        t = &(lex.get(true)); /* optional = */
+
+                    if (t->hasKind(Token::True))
+                        mTraceICode = true;
+                    else if (t->hasKind(Token::False))
+                        mTraceICode = false;
+                    else
+                        goto badval;
+                    break;
+
+                default:
+                    mErr << "Variable '" << *varname <<
+                        "' matched unimplemented variable '" << 
+                        shell_vars[match][0] << "'.\n";
+            }
+        else
+            mErr << "Ambiguous variable '" << *varname << "', " <<
+                (match - (uint32)COMMAND_COUNT + 1) << " similar variables.\n";
+        
+        return;
+        
+    badval:
+        mErr << "Invalid value for variable '" <<
+            shell_vars[(ShellVariable)match][0] << "'\n";
+
+    }
+    
+    void
+    Shell::doPrint (Context *, Lexer &lex)
+    {
+        const Token *t = &(lex.get(true));
+
+        if (!(t->hasKind(Token::identifier)))
+        {
+            mErr << "Invalid register name.\n";
+            return;
+        }
+
+/*
+        const StringAtom *name = &(t->getIdentifier());
+        
+        VariableMap::iterator i = ((cx->getICode())->itsVariables)->find(*name);
+//        if (i)
+            mOut << (*i).first << " = " << (*i).second << "\n";
+//        else
+//            mOut << "No " << *name << " defined.\n";
+  
+*/      
+    }
+    
+            
+            
+    
+} /* namespace Debugger */
+} /* namespace JavaScript */
+
+                    
+            
+        

mozilla/js2/src/debugger.h

@@ -0,0 +1,163 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+/* this is all vapor, don't take it to serious yet */
+
+#ifndef debugger_h
+#define debugger_h
+
+#include "utilities.h"
+#include "interpreter.h"
+
+#include <stdio.h>
+
+namespace JavaScript {
+namespace Debugger {
+
+    using namespace Interpreter;
+
+    class Shell;
+    
+    typedef const Reader *ResolveFileCallback (const String &fileName);
+    typedef bool DebuggerCommandCallback (Shell &debugger, const Lexer &lex);
+
+    class Breakpoint {
+    public:
+        /* representation of a breakpoint */
+        void set();
+        void clear();
+        bool getState();
+        InstructionIterator getPC();
+    };    
+
+    struct DebuggerCommand
+    {
+        DebuggerCommand(String aName, String aParamDesc, String aShortHelp,
+                        String aLongHelp = widenCString("No more help available."),
+                        DebuggerCommandCallback *aCommandFunction = 0) 
+            : mName(aName), mParamDesc(aParamDesc), mShortHelp(aShortHelp),
+              mLongHelp(aLongHelp), mCommandFunction(aCommandFunction) {}
+
+        String mName;
+        String mParamDesc;
+        String mShortHelp;
+        String mLongHelp;
+        DebuggerCommandCallback *mCommandFunction;
+    };
+
+    /* keep in sync with list in debugger.cpp */
+    enum ShellCommand {
+        ASSEMBLE,
+        AMBIGUOUS,
+        AMBIGUOUS2,
+        CONTINUE,
+        DISSASSEMBLE,
+        EXIT,
+        HELP,
+        ISTEP,
+        LET,
+        PRINT,
+        REGISTER,
+        STEP,
+        COMMAND_COUNT
+    };
+        
+    class Shell : public Context::Listener {
+    public:        
+        Shell (World &aWorld, FILE *aIn, Formatter &aOut, Formatter &aErr,
+               ResolveFileCallback *aCallback = 0) :
+            mWorld(aWorld), mIn(aIn), mOut(aOut), mErr(aErr),
+            mResolveFileCallback(aCallback), mStopMask(Context::EV_DEBUG),
+            mTraceSource(false), mTraceICode(false), mLastSourcePos(0),
+            mLastICodeID(NotABanana), mLastCommand(COMMAND_COUNT)
+        {
+        }
+
+        ~Shell ()
+        {
+        }
+        
+        ResolveFileCallback
+            *setResolveFileCallback (ResolveFileCallback  *aCallback)
+        {
+            ResolveFileCallback *rv = mResolveFileCallback;
+            mResolveFileCallback = aCallback;
+            return rv;
+        }
+        
+        void listen(Context *context, Context::Event event);
+        
+        /**
+         * install on a context
+         */
+        bool attachToContext (Context *aContext)
+        {
+            aContext->addListener (this);
+            return true;
+        }
+        
+        /**
+         * detach an icdebugger from a context
+         */
+        bool detachFromContext (Context *aContext)
+        {
+            aContext->removeListener (this);
+            return true;
+        }
+
+        FILE *getIStream() { return mIn; }
+        Formatter &getOStream() { return mOut; }
+        Formatter &getEStream() { return mErr; }
+
+    private:
+        bool doCommand (Context *cx, const String &aSource);
+        void doSetVariable (Lexer &lex);
+        void doPrint (Context *cx, Lexer &lex);
+
+        void showOpAtPC(Context* cx, InstructionIterator pc);
+        void showSourceAtPC(Context* cx, InstructionIterator pc);
+        
+        World &mWorld;
+        FILE *mIn;
+        Formatter &mOut, &mErr;
+        ResolveFileCallback *mResolveFileCallback;
+        uint32 mStopMask;
+        bool mTraceSource, mTraceICode;
+        uint32 mLastSourcePos, mLastICodeID;
+        ShellCommand mLastCommand;
+    };    
+
+} /* namespace Debugger */
+} /* namespace JavaScript */
+
+#endif /* debugger_h */

mozilla/js2/src/ds.h

@@ -0,0 +1,740 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#ifndef ds_h___
+#define ds_h___
+
+#include <memory>
+
+#include "utilities.h"
+
+namespace JavaScript 
+{
+
+//
+// Save-Restore Pattern
+//
+
+    // Use the definition
+    //   SaveRestore<T> temp(var)
+    // to save the current value of var at the time of the definition into a temporary temp
+    // and restore var to the saved value at the end of temp's scope, regardless of whether
+    // temp goes out of scope due to normal execution or due to a thrown exception.
+    template<typename T> class SaveRestore {
+        const T savedValue;
+        T &var;
+
+      public:
+        SaveRestore(T &t): savedValue(t), var(t) {}
+        ~SaveRestore() {var = savedValue;}
+    };
+
+
+//
+// Doubly Linked Lists
+//
+
+    // A ListQueue provides insert and delete operations on a doubly-linked list of
+    // objects threaded through fields named 'next' and 'prev'.  The type parameter
+    // E must be a class derived from ListQueueEntry.
+    // The ListQueue does not own its elements.  They must be deleted explicitly if
+    // needed.
+    struct ListQueueEntry {
+        ListQueueEntry *next;                   // Next entry in linked list
+        ListQueueEntry *prev;                   // Previous entry in linked list
+        
+#ifdef DEBUG
+        ListQueueEntry(): next(0), prev(0) {}
+#endif
+    };
+    
+    template <class E>
+    struct ListQueue: private ListQueueEntry {
+        
+        ListQueue() {next = this; prev = this;}
+        
+        // Return true if the ListQueue is nonempty.
+        operator bool() const {return next != static_cast<const ListQueueEntry *>(this);}
+
+        // Return true if the ListQueue is empty.
+        bool operator !() const {return next == static_cast<const ListQueueEntry *>(this);}
+
+        E &front() const {ASSERT(operator bool()); return *static_cast<E *>(next);}
+        E &back() const {ASSERT(operator bool()); return *static_cast<E *>(prev);}
+
+        void push_front(E &elt) {
+            ASSERT(!elt.next && !elt.prev);
+            elt.next = next; elt.prev = this; next->prev = &elt; next = &elt;
+        }
+        
+        void push_back(E &elt) {
+            ASSERT(!elt.next && !elt.prev);
+            elt.next = this; elt.prev = prev; prev->next = &elt; prev = &elt;
+        }
+
+        E &pop_front() {
+            ASSERT(operator bool());
+            E *elt = static_cast<E *>(next); next = elt->next; next->prev = this;
+            DEBUG_ONLY(elt->next = 0; elt->prev = 0;) return *elt;
+        }
+        
+        E &pop_back() {
+            ASSERT(operator bool());
+            E *elt = static_cast<E *>(prev); prev = elt->prev; prev->next = this;
+            DEBUG_ONLY(elt->next = 0; elt->prev = 0;);
+            return *elt;
+        }
+    };
+
+
+//
+// Growable Arrays
+//
+
+    // A Buffer initially points to inline storage of initialSize elements of type T.
+    // The Buffer can be expanded via the expand method to increase its size by
+    // allocating storage from the heap.
+    template <typename T, size_t initialSize> class Buffer {
+      public:
+        T *buffer;                      // Pointer to the current buffer
+        size_t size;                    // Current size of the buffer
+      private:
+        T initialBuffer[initialSize];   // Initial buffer
+      public:
+        Buffer(): buffer(initialBuffer), size(initialSize) {}
+        ~Buffer() {if (buffer != initialBuffer) delete[] buffer;}
+        
+        void expand(size_t newSize);
+    };
+
+
+    // Expand the buffer to size newSize, which must be greater than the current
+    // size. The buffer's contents are not preserved.
+    template <typename T, size_t initialSize>
+    inline void Buffer<T, initialSize>::expand(size_t newSize) {
+        ASSERT(newSize > size);
+        if (buffer != initialBuffer) {
+            delete[] buffer;
+            buffer = 0;     // For exception safety if the allocation below fails.
+        }
+        buffer = new T[newSize];
+        size = newSize;
+    }
+
+
+    // See ArrayBuffer below.
+    template <typename T> class RawArrayBuffer {
+        T *const cache;                 // Pointer to a fixed-size cache for holding the buffer if it's small enough
+      protected:
+        T *buffer;                      // Pointer to the current buffer
+        size_t length;                  // Logical size of the buffer
+        size_t bufferSize;              // Physical size of the buffer
+#ifdef DEBUG
+        size_t maxReservedSize;         // Maximum size reserved so far
+#endif
+
+      public:
+        RawArrayBuffer(T *cache, size_t cacheSize) :
+            cache(cache), buffer(cache), length(0), bufferSize(cacheSize) {
+            DEBUG_ONLY(maxReservedSize = 0);
+        }
+      private:
+        RawArrayBuffer(const RawArrayBuffer&);      // No copy constructor
+        void operator=(const RawArrayBuffer&);      // No assignment operator
+      public:
+        ~RawArrayBuffer() {if (buffer != cache) delete[] buffer;}
+        
+      private:
+        void enlarge(size_t newLength);
+      public:
+        // Methods that do not expand the buffer cannot throw exceptions.
+        size_t size() const {return length;}
+        operator bool() const {return length != 0;}
+        bool operator !() const {return length == 0;}
+        
+        T &front() {ASSERT(length); return *buffer;}
+        const T &front() const {ASSERT(length); return *buffer;}
+        T &back() {ASSERT(length); return buffer[length-1];}
+        const T &back() const {ASSERT(length); return buffer[length-1];}
+        T *contents() const {return buffer;}
+        
+        void reserve(size_t nElts);
+        T *reserve_back(size_t nElts = 1);
+        T *advance_back(size_t nElts = 1);
+        T *reserve_advance_back(size_t nElts = 1);
+        
+        void fast_push_back(const T &elt);
+        void push_back(const T &elt);
+        void append(const T *elts, size_t nElts);
+        void append(const T *begin, const T *end) {ASSERT(end >= begin); append(begin, toSize_t(end - begin));}
+        
+        T &pop_back() {ASSERT(length); return buffer[--length];}
+    };
+
+
+    // Enlarge the buffer so that it can hold at least newLength elements.
+    // May throw an exception, in which case the buffer is left unchanged.
+    template <typename T>
+    void RawArrayBuffer<T>::enlarge(size_t newLength) {
+        size_t newBufferSize = bufferSize * 2;
+        if (newBufferSize < newLength)
+            newBufferSize = newLength;
+        
+        auto_ptr<T> newBuffer(new T[newBufferSize]);
+        T *oldBuffer = buffer;
+        std::copy(oldBuffer, oldBuffer + length, newBuffer.get());
+        buffer = newBuffer.release();
+        if (oldBuffer != cache)
+            delete[] oldBuffer;
+        bufferSize = newBufferSize;
+    }
+
+    // Ensure that there is room to hold nElts elements in the buffer, without
+    // expanding the buffer's logical length.
+    // May throw an exception, in which case the buffer is left unchanged.
+    template <typename T>
+    inline void RawArrayBuffer<T>::reserve(size_t nElts) {
+        if (bufferSize < nElts)
+            enlarge(nElts);
+#ifdef DEBUG
+        if (maxReservedSize < nElts)
+            maxReservedSize = nElts;
+#endif
+    }
+
+    // Ensure that there is room to hold nElts more elements in the buffer, without
+    // expanding the buffer's logical length.  Return a pointer to the first element
+    // just past the logical length.
+    // May throw an exception, in which case the buffer is left unchanged.
+    template <typename T>
+    inline T *RawArrayBuffer<T>::reserve_back(size_t nElts) {
+        reserve(length + nElts);
+        return buffer[length];
+    }
+
+    // Advance the logical length by nElts, assuming that the memory has previously
+    // been reserved.
+    // Return a pointer to the first new element.
+    template <typename T>
+    inline T *RawArrayBuffer<T>::advance_back(size_t nElts) {
+        ASSERT(length + nElts <= maxReservedSize);
+        T *p = buffer + length;
+        length += nElts;
+        return p;
+    }
+
+    // Combine the effects of reserve_back and advance_back.
+    template <typename T>
+    inline T *RawArrayBuffer<T>::reserve_advance_back(size_t nElts) {
+        reserve(length + nElts);
+        T *p = buffer + length;
+        length += nElts;
+        return p;
+    }
+
+    // Same as push_back but assumes that the memory has previously been reserved.
+    // May throw an exception if copying elt throws one, in which case the buffer is
+    // left unchanged.
+    template <typename T>
+    inline void RawArrayBuffer<T>::fast_push_back(const T &elt) {
+        ASSERT(length < maxReservedSize);
+        buffer[length] = elt;
+        ++length;
+    }
+
+    // Append elt to the back of the buffer.
+    // May throw an exception, in which case the buffer is left unchanged.
+    template <typename T>
+    inline void RawArrayBuffer<T>::push_back(const T &elt) {
+        *reserve_back() = elt;
+        ++length;
+    }
+
+    // Append nElts elements elts to the back of the array buffer.
+    // May throw an exception, in which case the buffer is left unchanged.
+    template <typename T>
+    void RawArrayBuffer<T>::append(const T *elts, size_t nElts) {
+        size_t newLength = length + nElts;
+        if (newLength > bufferSize)
+            enlarge(newLength);
+        std::copy(elts, elts + nElts, buffer + length);
+        length = newLength;
+    }
+
+
+    // An ArrayBuffer represents an array of elements of type T.  The ArrayBuffer
+    // contains storage for a fixed size array of cacheSize elements; if this size
+    // is exceeded, the ArrayBuffer allocates the array from the heap.  Elements can
+    // be appended to the back of the array using append.  An ArrayBuffer can also
+    // act as a stack: elements can be pushed and popped from the back.
+    //
+    // All ArrayBuffer operations are atomic with respect to exceptions -- either
+    // they succeed or they do not affect the ArrayBuffer's existing elements and
+    // length. If T has a constructor, it must have a constructor with no arguments;
+    // that constructor is called at the time memory for the ArrayBuffer is
+    // allocated, just like when allocating a regular C++ array.
+    template <typename T, size_t cacheSize>
+    class ArrayBuffer: public RawArrayBuffer<T> {
+        T cacheArray[cacheSize];
+      public:
+        ArrayBuffer(): RawArrayBuffer<T>(cacheArray, cacheSize) {}
+    };
+
+
+//
+// Bit Sets
+//
+
+    template<size_t size> class BitSet {
+        STATIC_CONST(size_t, nWords = (size+31)>>5);
+        STATIC_CONST(uint32, lastWordMask = (2u<<((size-1)&31)) - 1);
+
+        uint32 words[nWords];   // Bitmap; the first word contains bits 0(LSB)...31(MSB), the second contains bits 32...63, etc.
+
+      public:
+        void clear() {zero(words, words+nWords);}
+        BitSet() {clear();}
+
+        // Construct a BitSet out of an array of alternating low (inclusive)
+        // and high (exclusive) ends of ranges of set bits.
+        // The array is terminated by a 0,0 range.
+        template<typename In> explicit BitSet(In a) {
+            clear();
+            size_t low, high;
+            while (low = *a++, (high = *a++) != 0) setRange(low, high);
+        }
+                
+        bool operator[](size_t i) const {ASSERT(i < size); return static_cast<bool>(words[i>>5]>>(i&31) & 1);}
+        bool none() const;
+        bool operator==(const BitSet &s) const;
+        bool operator!=(const BitSet &s) const;
+        
+        void set(size_t i) {ASSERT(i < size); words[i>>5] |= 1u<<(i&31);}
+        void reset(size_t i) {ASSERT(i < size); words[i>>5] &= ~(1u<<(i&31));}
+        void flip(size_t i) {ASSERT(i < size); words[i>>5] ^= 1u<<(i&31);}
+        void setRange(size_t low, size_t high);
+        void resetRange(size_t low, size_t high);
+        void flipRange(size_t low, size_t high);
+    };
+
+
+    // Return true if all bits are clear.
+    template<size_t size>
+    inline bool BitSet<size>::none() const {
+        if (nWords == 1)
+            return !words[0];
+        else {
+            const uint32 *w = words;
+            while (w != words + nWords)
+                if (*w++)
+                    return false;
+            return true;
+        }
+    }
+
+    // Return true if the BitSets are equal.
+    template<size_t size>
+    inline bool BitSet<size>::operator==(const BitSet &s) const {
+        if (nWords == 1)
+            return words[0] == s.words[0];
+        else
+            return std::equal(words, s.words);
+    }
+
+    // Return true if the BitSets are not equal.
+    template<size_t size>
+    inline bool BitSet<size>::operator!=(const BitSet &s) const {
+        return !operator==(s);
+    }
+
+    // Set all bits between low inclusive and high exclusive.
+    template<size_t size>
+    void BitSet<size>::setRange(size_t low, size_t high) {
+        ASSERT(low <= high && high <= size);
+        if (low != high)
+            if (nWords == 1)
+                words[0] |= (2u<<(high-1)) - (1u<<low);
+            else {
+                --high;
+                uint32 *w = words + (low>>5);
+                uint32 *wHigh = words + (high>>5);
+                uint32 l = 1u << (low&31);
+                uint32 h = 2u << (high&31);
+                if (w == wHigh)
+                    *w |= h - l;
+                else {
+                    *w++ |= -l;
+                    while (w != wHigh)
+                        *w++ = static_cast<uint32>(-1);
+                    *w |= h - 1;
+                }
+            }
+    }
+
+    // Clear all bits between low inclusive and high exclusive.
+    template<size_t size>
+    void BitSet<size>::resetRange(size_t low, size_t high) {
+        ASSERT(low <= high && high <= size);
+        if (low != high)
+            if (nWords == 1)
+                words[0] &= (1u<<low) - 1 - (2u<<(high-1));
+            else {
+                --high;
+                uint32 *w = words + (low>>5);
+                uint32 *wHigh = words + (high>>5);
+                uint32 l = 1u << (low&31);
+                uint32 h = 2u << (high&31);
+                if (w == wHigh)
+                    *w &= l - 1 - h;
+                else {
+                    *w++ &= l - 1;
+                    while (w != wHigh)
+                        *w++ = 0;
+                    *w &= -h;
+                }
+            }
+    }
+
+    // Invert all bits between low inclusive and high exclusive.
+    template<size_t size>
+    void BitSet<size>::flipRange(size_t low, size_t high) {
+        ASSERT(low <= high && high <= size);
+        if (low != high)
+            if (nWords == 1)
+                words[0] ^= (2u<<(high-1)) - (1u<<low);
+            else {
+                --high;
+                uint32 *w = words + (low>>5);
+                uint32 *wHigh = words + (high>>5);
+                uint32 l = 1u << (low&31);
+                uint32 h = 2u << (high&31);
+                if (w == wHigh)
+                    *w ^= h - l;
+                else {
+                    *w++ ^= -l;
+                    while (w != wHigh)
+                        *w++ ^= static_cast<uint32>(-1);
+                    *w ^= h - 1;
+                }
+            }
+    }
+
+
+//
+// Array Queues
+//
+
+    // See ArrayQueue below.
+    template <typename T> class RawArrayQueue {
+        T *const cache;                 // Pointer to a fixed-size cache for holding the buffer if it's small enough
+      protected:
+        T *buffer;                      // Pointer to the current buffer
+        T *bufferEnd;                   // Pointer to the end of the buffer
+        T *f;                           // Front end of the circular buffer, used for reading elements; buffer <= f < bufferEnd
+        T *b;                           // Back end of the circular buffer, used for writing elements; buffer < b <= bufferEnd
+        size_t length;                  // Number of elements used in the circular buffer
+        size_t bufferSize;              // Physical size of the buffer
+#ifdef DEBUG
+        size_t maxReservedSize;         // Maximum size reserved so far
+#endif
+
+      public:
+        RawArrayQueue(T *cache, size_t cacheSize):
+                cache(cache), buffer(cache), bufferEnd(cache + cacheSize),
+                f(cache), b(cache), length(0), bufferSize(cacheSize)
+            {DEBUG_ONLY(maxReservedSize = 0);}
+      private:
+        RawArrayQueue(const RawArrayQueue&);        // No copy constructor
+        void operator=(const RawArrayQueue&);       // No assignment operator
+      public:
+        ~RawArrayQueue() {if (buffer != cache) delete[] buffer;}
+
+      private:
+        void enlarge(size_t newLength);
+      public:
+
+        // Methods that do not expand the buffer cannot throw exceptions.
+        size_t size() const {return length;}
+        operator bool() const {return length != 0;}
+        bool operator !() const {return length == 0;}
+        
+        T &front() {ASSERT(length); return *f;}
+        const T &front() const {ASSERT(length); return *f;}
+        T &back() {ASSERT(length); return b[-1];}
+        const T &back() const {ASSERT(length); return b[-1];}
+        
+        T &pop_front() {
+            ASSERT(length);
+            --length;
+            T &elt = *f++;
+            if (f == bufferEnd)
+                f = buffer;
+            return elt;
+        }
+        
+        size_t pop_front(size_t nElts, T *&begin, T *&end);
+
+        T &pop_back() {
+            ASSERT(length);
+            --length;
+            T &elt = *--b;
+            if (b == buffer)
+                b = bufferEnd;
+            return elt;
+        }
+
+        void reserve_back();
+        void reserve_back(size_t nElts);
+        T *advance_back();
+        T *advance_back(size_t nElts, size_t &nEltsAdvanced);
+
+        void fast_push_back(const T &elt);
+        void push_back(const T &elt);
+
+        // Same as append but assumes that memory has previously been reserved.
+        // Does not throw exceptions.  T::operator= must not throw exceptions.
+        template <class InputIter>
+        void fast_append(InputIter begin, InputIter end) {
+            size_t nElts = toSize_t(std::distance(begin, end));
+            ASSERT(length + nElts <= maxReservedSize);
+            while (nElts) {
+                size_t nEltsAdvanced;
+                T *dst = advance_back(nElts, nEltsAdvanced);
+                nElts -= nEltsAdvanced;
+                while (nEltsAdvanced--) {
+                    *dst = *begin; ++dst; ++begin;
+                }
+            }
+        }
+
+        // Append elements from begin to end to the back of the queue.
+        // T::operator= must not throw exceptions.
+        // reserve_back may throw an exception, in which case the queue is left
+        // unchanged.
+        template <class InputIter> void append(InputIter begin, InputIter end) {
+            size_t nElts = toSize_t(std::distance(begin, end));
+            reserve_back(nElts);
+            while (nElts) {
+                size_t nEltsAdvanced;
+                T *dst = advance_back(nElts, nEltsAdvanced);
+                nElts -= nEltsAdvanced;
+                while (nEltsAdvanced--) {
+                    *dst = *begin; ++dst; ++begin;
+                }
+            }
+        }
+    };
+
+
+    // Pop between one and nElts elements from the front of the queue.  Set begin
+    // and end to an array of the first n elements, where n is the return value.
+    // The popped elements may be accessed until the next non-const operation.
+    // Does not throw exceptions.
+    template <typename T>
+    size_t RawArrayQueue<T>::pop_front(size_t nElts, T *&begin, T *&end) {
+        ASSERT(nElts <= length);
+        begin = f;
+        size_t eltsToEnd = toSize_t(bufferEnd - f);
+        if (nElts < eltsToEnd) {
+            length -= nElts;
+            f += nElts;
+            end = f;
+            return nElts;
+        } else {
+            length -= eltsToEnd;
+            end = bufferEnd;
+            f = buffer;
+            return eltsToEnd;
+        }
+    }
+
+    // Enlarge the buffer so that it can hold at least newLength elements.
+    // May throw an exception, in which case the queue is left unchanged.
+    template <typename T>
+    void RawArrayQueue<T>::enlarge(size_t newLength) {
+        size_t newBufferSize = bufferSize * 2;
+        if (newBufferSize < newLength)
+            newBufferSize = newLength;
+        
+        auto_ptr<T> newBuffer(new T[newBufferSize]);
+        T *oldBuffer = buffer;
+        size_t eltsToEnd = toSize_t(bufferEnd - f);
+        if (eltsToEnd <= length)
+            std::copy(f, f + eltsToEnd, newBuffer.get());
+        else {
+            std::copy(f, bufferEnd, newBuffer.get());
+            std::copy(oldBuffer, b, newBuffer.get() + eltsToEnd);
+        }
+        buffer = newBuffer.release();
+        f = buffer;
+        b = buffer + length;
+        if (oldBuffer != cache)
+            delete[] oldBuffer;
+        bufferSize = newBufferSize;
+    }
+
+    // Ensure that there is room to hold one more element at the back of the queue,
+    // without expanding the queue's logical length.
+    // May throw an exception, in which case the queue is left unchanged.
+    template <typename T>
+    inline void RawArrayQueue<T>::reserve_back() {
+        if (length == bufferSize)
+            enlarge(length + 1);
+#ifdef DEBUG
+        if (maxReservedSize <= length)
+            maxReservedSize = length + 1;
+#endif
+    }
+
+    // Ensure that there is room to hold nElts more elements at the back of the
+    // queue, without expanding the queue's logical length.
+    // May throw an exception, in which case the queue is left unchanged.
+    template <typename T>
+    inline void RawArrayQueue<T>::reserve_back(size_t nElts) {
+        nElts += length;
+        if (bufferSize < nElts)
+            enlarge(nElts);
+#ifdef DEBUG
+        if (maxReservedSize < nElts)
+            maxReservedSize = nElts;
+#endif
+    }
+
+    // Advance the back of the queue by one element, assuming that the memory has
+    // previously been reserved.
+    // Return a pointer to that new element.
+    // Does not throw exceptions.
+    template <typename T>
+    inline T *RawArrayQueue<T>::advance_back() {
+        ASSERT(length < maxReservedSize);
+        ++length;
+        if (b == bufferEnd)
+            b = buffer;
+        return b++;
+    }
+
+    // Advance the back of the queue by between one and nElts elements and return a
+    // pointer to them, assuming that the memory has previously been reserved.
+    // nEltsAdvanced gets the actual number of elements advanced.
+    // Does not throw exceptions.
+    template <typename T>
+    T *RawArrayQueue<T>::advance_back(size_t nElts, size_t &nEltsAdvanced) {
+        size_t newLength = length + nElts;
+        ASSERT(newLength <= maxReservedSize);
+        if (nElts) {
+            T *b2 = b;
+            if (b2 == bufferEnd)
+                b2 = buffer;
+            
+            size_t room = toSize_t(bufferEnd - b2);
+            if (nElts > room) {
+                nElts = room;
+                newLength = length + nElts;
+            }
+            length = newLength;
+            nEltsAdvanced = nElts;
+            b = b2 + nElts;
+            return b2;
+        } else {
+            nEltsAdvanced = 0;
+            return 0;
+        }
+    }
+
+    // Same as push_back but assumes that the memory has previously been reserved.
+    // May throw an exception if copying elt throws one, in which case the queue is
+    // left unchanged.
+    template <typename T>
+    inline void RawArrayQueue<T>::fast_push_back(const T &elt) {
+        ASSERT(length < maxReservedSize);
+        T *b2 = b;
+        if (b2 == bufferEnd)
+            b2 = buffer;
+        *b2 = elt;
+        b = b2 + 1;
+        ++length;
+    }
+
+    // Append elt to the back of the queue.
+    // May throw an exception, in which case the queue is left unchanged.
+    template <typename T>
+    inline void RawArrayQueue<T>::push_back(const T &elt) {
+        reserve_back();
+        T *b2 = b == bufferEnd ? buffer : b;
+        *b2 = elt;
+        b = b2 + 1;
+        ++length;
+    }
+
+
+    // An ArrayQueue represents an array of elements of type T that can be written
+    // at its back end and read at its front or back end.  In addition, arrays of
+    // multiple elements may be written at the back end or read at the front end.
+    // The ArrayQueue contains storage for a fixed size array of cacheSize elements;
+    // if this size is exceeded, the ArrayQueue allocates the array from the heap.
+    template <typename T, size_t cacheSize>
+    class ArrayQueue: public RawArrayQueue<T> {
+        T cacheArray[cacheSize];
+          public:
+        ArrayQueue(): RawArrayQueue<T>(cacheArray, cacheSize) {}
+    };
+
+
+//
+// Array auto_ptr's
+//
+
+    // An ArrayAutoPtr holds a pointer to an array initialized by new T[x].
+    // A regular auto_ptr cannot be used here because it deletes its pointer using
+    // delete rather than delete[].
+    // An appropriate operator[] is also provided.
+    template <typename T> class ArrayAutoPtr {
+        T *ptr;
+        
+      public:
+        explicit ArrayAutoPtr(T *p = 0): ptr(p) {}
+        ArrayAutoPtr(ArrayAutoPtr &a): ptr(a.ptr) {a.ptr = 0;}
+        ArrayAutoPtr &operator=(ArrayAutoPtr &a) {reset(a.release());}
+        ~ArrayAutoPtr() {delete[] ptr;}
+        
+        T &operator*() const {return *ptr;}
+        T &operator->() const {return *ptr;}
+        template<class N> T &operator[](N i) const {return ptr[i];}
+        T *get() const {return ptr;}
+        T *release() {T *p = ptr; ptr = 0; return p;}
+        void reset(T *p = 0) {delete[] ptr; ptr = p;}
+    };
+    
+    typedef ArrayAutoPtr<char> CharAutoPtr;
+}
+#endif /* ds_h___ */

mozilla/js2/src/exception.cpp

@@ -0,0 +1,85 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#include <cstdio>
+#include "exception.h"
+
+namespace JS = JavaScript;
+
+
+//
+// Exceptions
+//
+
+static const char *const kindStrings[] = {
+    "Syntax error",                         // syntaxError
+    "Stack overflow",                       // stackOverflow
+    "Internal error",                       // diabetes
+    "Runtime error",                        // runtimeError
+    "Reference error",                      // referenceError
+    "Range error",                          // burnt the beans
+    "Type error",                           // Yype error
+    "Uncaught exception error",             // uncaught exception error
+    "Semantic error",                       // semantic error
+};
+
+// Return a null-terminated string describing the exception's kind.
+const char *JS::Exception::kindString() const
+{
+    return kindStrings[kind];
+}
+
+
+// Return the full error message.
+JS::String JS::Exception::fullMessage() const
+{
+    String m(widenCString("In "));
+    m += sourceFile;
+    if (lineNum) {
+        char b[32];
+        sprintf(b, ", line %d:\n", lineNum);
+        m += b;
+        m += sourceLine;
+        m += '\n';
+        String sourceLine2(sourceLine);
+        insertChars(sourceLine2, charNum, "[ERROR]");
+        m += sourceLine2;
+        m += '\n';
+    } else
+        m += ":\n";
+    m += kindString();
+    m += ": ";
+    m += message;
+    m += '\n';
+    return m;
+}

mozilla/js2/src/exception.h

@@ -0,0 +1,95 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#ifndef exception_h___
+#define exception_h___
+
+#include "strings.h"
+
+namespace JavaScript
+{
+
+//
+// Exceptions
+//
+
+    // A JavaScript exception (other than out-of-memory, for which we use the
+    // standard C++ exception bad_alloc).
+    struct Exception {
+        enum Kind {
+            syntaxError,
+            stackOverflow,
+            internalError,
+            runtimeError,
+            referenceError,
+            rangeError,
+            typeError,
+            uncaughtError,
+            semanticError
+        };
+        
+        Kind kind;              // The exception's kind
+        String message;         // The detailed message
+        String sourceFile;      // A description of the source code that caused the error
+        uint32 lineNum;         // Number of line that caused the error
+        size_t charNum;         // Character offset within the line that caused the error
+        size_t pos;             // Offset within the input of the error
+        String sourceLine;      // The text of the source line
+
+        Exception (Kind kind, const char *message):
+                kind(kind), message(widenCString(message)), lineNum(0), charNum(0) {}
+        
+        Exception (Kind kind, const String &message):
+                kind(kind), message(message), lineNum(0), charNum(0) {}
+        
+        Exception(Kind kind, const String &message, const String &sourceFile, uint32 lineNum, size_t charNum,
+                  size_t pos, const String &sourceLine):
+                kind(kind), message(message), sourceFile(sourceFile), lineNum(lineNum), charNum(charNum), pos(pos),
+                sourceLine(sourceLine) {}
+        
+        Exception(Kind kind, const String &message, const String &sourceFile, uint32 lineNum, size_t charNum,
+                  size_t pos, const char16 *sourceLineBegin, const char16 *sourceLineEnd):
+                kind(kind), message(message), sourceFile(sourceFile), lineNum(lineNum), charNum(charNum), pos(pos),
+                sourceLine(sourceLineBegin, sourceLineEnd) {}
+
+        bool hasKind(Kind k) const {return kind == k;}
+        const char *kindString() const;
+        String fullMessage() const;
+    };
+
+
+    // Throw a stackOverflow exception if the execution stack has gotten too large.
+    inline void checkStackSize() {}
+}
+
+#endif /* exception_h___ */

mozilla/js2/src/exception_msgs.cpp

@@ -0,0 +1,66 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s): 
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+namespace JavaScript {
+
+    const char* exception_types[] = {
+        "Unknown",
+        "Lexer",
+        "Parser",
+        "Runtime",
+        0
+    };
+    
+    const char* exception_msgs[] = {
+        "Expected boolean value",
+        "Expected double value",
+        "Expected int32 value",
+        "Expected uint32 value",
+        "Expected register value",
+        "Expected argument list value",
+        "Expected colon",
+        "Expected close parenthesis",
+        "Expected binary operator",
+        "Expected string",
+        "Expected label",
+        "Expected comma",
+        "Expected newline",
+        "Expected identifier",
+        "Duplicate label",
+        "Unknown icode",
+        "Unknown binary operator",
+        "Unterminated string literal",
+        0
+    };
+    
+}

mozilla/js2/src/fdlibm_ns.cpp

@@ -0,0 +1,2 @@
+
+// this file intentionally left blank

mozilla/js2/src/fdlibm_ns.h

@@ -0,0 +1,140 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s):  
+ *   Roger Lawrence <rogerl@netscape.com>
+ *   Patrick Beard <beard@netscape.com>
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#include <math.h>
+
+#if defined(_WIN32) && !defined(__MWERKS__)
+#define __STDC__
+#endif
+
+/*
+ * Use math routines in fdlibm.
+ */
+
+#undef __P
+#ifdef __STDC__
+#define __P(p)  p
+#else
+#define __P(p)  ()
+#endif
+
+#if defined _WIN32 || defined SUNOS4 
+
+// these are functions we trust the local implementation
+// to provide, so we just inline them into calls to the
+// standard library.
+namespace fd {
+    inline double floor(double x)           { return ::floor(x); }
+    inline double acos(double x)            { return ::acos(x); }
+    inline double asin(double x)            { return ::asin(x); }
+    inline double atan(double x)            { return ::atan(x); }
+    inline double cos(double x)             { return ::cos(x); }
+    inline double sin(double x)             { return ::sin(x); }
+    inline double tan(double x)             { return ::tan(x); }
+    inline double exp(double x)             { return ::exp(x); }
+    inline double log(double x)             { return ::log(x); }
+    inline double sqrt(double x)            { return ::sqrt(x); }
+    inline double ceil(double x)            { return ::ceil(x); }
+    inline double fabs(double x)            { return ::fabs(x); }
+    inline double fmod(double x, double y)  { return ::fmod(x, y); }
+}
+
+// these one we get from the fdlibm library
+namespace fd {
+    extern "C" {
+        double fd_atan2 __P((double, double));
+        double fd_copysign __P((double, double));
+        double fd_pow __P((double, double));
+    }
+    inline double atan2(double x, double y)      { return fd_atan2(x, y); }
+    inline double copysign(double x, double y)   { return fd_copysign(x, y); }
+    inline double pow(double x, double y)        { return fd_pow(x, y); }
+}
+
+
+#elif defined(linux)
+
+namespace fd {
+    inline double atan(double x)               { return ::atan(x); }
+    inline double atan2(double x, double y)    { return ::atan2(x, y); }
+    inline double ceil(double x)               { return ::ceil(x); }
+    inline double cos(double x)                { return ::cos(x); }
+    inline double fabs(double x)               { return ::fabs(x); }
+    inline double floor(double x)              { return ::floor(x); }
+    inline double fmod(double x, double y)     { return ::fmod(x, y); }
+    inline double sin(double x)                { return ::sin(x); }
+    inline double sqrt(double x)               { return ::sqrt(x); }
+    inline double tan(double x)                { return ::tan(x); }
+    inline double copysign(double x, double y) { return ::copysign(x, y); }
+}
+
+namespace fd {
+    extern "C" {
+        double fd_asin __P((double));
+        double fd_acos __P((double));
+        double fd_exp __P((double));
+        double fd_log __P((double));
+        double fd_pow __P((double, double));
+    }
+    inline double asin(double x)                 { return fd_asin(x); }
+    inline double acos(double x)                 { return fd_acos(x); }
+    inline double exp(double x)                  { return fd_exp(x); }
+    inline double log(double x)                  { return fd_log(x); }
+    inline double pow(double x, double y)        { return fd_pow(x, y); }
+}
+
+#elif defined(macintosh)
+
+// the macintosh MSL provides acceptable implementations for all of these.
+namespace fd {
+    inline double atan(double x)               { return ::atan(x); }
+    inline double atan2(double x, double y)    { return ::atan2(x, y); }
+    inline double ceil(double x)               { return ::ceil(x); }
+    inline double cos(double x)                { return ::cos(x); }
+    inline double fabs(double x)               { return ::fabs(x); }
+    inline double floor(double x)              { return ::floor(x); }
+    inline double fmod(double x, double y)     { return ::fmod(x, y); }
+    inline double sin(double x)                { return ::sin(x); }
+    inline double sqrt(double x)               { return ::sqrt(x); }
+    inline double tan(double x)                { return ::tan(x); }
+    inline double copysign(double x, double y) { return ::copysign(x, y); }
+    inline double asin(double x)               { return ::asin(x); }
+    inline double acos(double x)               { return ::acos(x); }
+    inline double exp(double x)                { return ::exp(x); }
+    inline double log(double x)                { return ::log(x); }
+    inline double pow(double x, double y)      { return ::pow(x, y); }
+}
+
+#endif

mozilla/js2/src/formatter.cpp

@@ -0,0 +1,880 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+*
+* The contents of this file are subject to the Netscape Public
+* License Version 1.1 (the "License"); you may not use this file
+* except in compliance with the License. You may obtain a copy of
+* the License at http://www.mozilla.org/NPL/
+*
+* Software distributed under the License is distributed on an "AS
+* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+* implied. See the License for the specific language governing
+* rights and limitations under the License.
+*
+* The Original Code is the JavaScript 2 Prototype.
+*
+* The Initial Developer of the Original Code is Netscape
+* Communications Corporation.   Portions created by Netscape are
+* Copyright (C) 1998 Netscape Communications Corporation. All
+* Rights Reserved.
+*
+* Contributor(s):
+*
+* Alternatively, the contents of this file may be used under the
+* terms of the GNU Public License (the "GPL"), in which case the
+* provisions of the GPL are applicable instead of those above.
+* If you wish to allow use of your version of this file only
+* under the terms of the GPL and not to allow others to use your
+* version of this file under the NPL, indicate your decision by
+* deleting the provisions above and replace them with the notice
+* and other provisions required by the GPL.  If you do not delete
+* the provisions above, a recipient may use your version of this
+* file under either the NPL or the GPL.
+*/
+
+#include "algo.h"
+#include "formatter.h"
+
+namespace JS = JavaScript;
+
+
+static const char controlCharNames[6] = {'b', 't', 'n', 'v', 'f', 'r'};
+
+// Print the characters from begin to end, escaping them as necessary to make
+// the resulting string be readable if placed between two quotes specified by
+// quote (which should be either '\'' or '"').
+void JS::escapeString(Formatter &f, const char16 *begin, const char16 *end, char16 quote)
+{
+    ASSERT(begin <= end);
+
+    const char16 *chunk = begin;
+    while (begin != end) {
+        char16 ch = *begin++;
+        CharInfo ci(ch);
+        if (char16Value(ch) < 0x20 || isLineBreak(ci) || isFormat(ci) || ch == '\\' || ch == quote) {
+            if (begin-1 != chunk)
+                printString(f, chunk, begin-1);
+            chunk = begin;
+
+            f << '\\';
+            switch (ch) {
+              case 0x0008:
+              case 0x0009:
+              case 0x000A:
+              case 0x000B:
+              case 0x000C:
+              case 0x000D:
+                f << controlCharNames[ch - 0x0008];
+                break;
+
+              case '\'':
+              case '"':
+              case '\\':
+                f << ch;
+                break;
+
+              case 0x0000:
+                if (begin == end || char16Value(*begin) < '0' || char16Value(*begin) > '9') {
+                    f << '0';
+                    break;
+                }
+              default:
+                if (char16Value(ch) <= 0xFF) {
+                    f << 'x';
+                    printHex(f, static_cast<uint32>(char16Value(ch)), 2);
+                } else {
+                    f << 'u';
+                    printHex(f, static_cast<uint32>(char16Value(ch)), 4);
+                }
+            }
+        }
+    }
+    if (begin != chunk)
+        printString(f, chunk, begin);
+}
+
+
+// Print s as a quoted string using the given quotes (which should be
+// either '\'' or '"').
+void JS::quoteString(Formatter &f, const String &s, char16 quote)
+{
+    f << quote;
+    const char16 *begin = s.data();
+    escapeString(f, begin, begin + s.size(), quote);
+    f << quote;
+}
+
+
+#ifdef XP_MAC_MPW
+// Macintosh MPW replacements for the ANSI routines.  These translate LF's to
+// CR's because the MPW libraries supplied by Metrowerks don't do that for some
+// reason.
+static void translateLFtoCR(char *begin, char *end)
+{
+    while (begin != end) {
+        if (*begin == '\n')
+            *begin = '\r';
+        ++begin;
+    }
+}
+
+
+size_t JS::printChars(FILE *file, const char *begin, const char *end)
+{
+    ASSERT(end >= begin);
+    size_t n = toSize_t(end - begin);
+    size_t extra = 0;
+    char buffer[1024];
+
+    while (n > sizeof buffer) {
+        std::memcpy(buffer, begin, sizeof buffer);
+        translateLFtoCR(buffer, buffer + sizeof buffer);
+        extra += fwrite(buffer, 1, sizeof buffer, file);
+        n -= sizeof buffer;
+        begin += sizeof buffer;
+    }
+    std::memcpy(buffer, begin, n);
+    translateLFtoCR(buffer, buffer + n);
+    return extra + fwrite(buffer, 1, n, file);
+}
+
+
+int std::fputc(int c, FILE *file)
+{
+    char buffer = static_cast<char>(c);
+    if (buffer == '\n')
+        buffer = '\r';
+    return static_cast<int>(fwrite(&buffer, 1, 1, file));
+}
+
+
+int std::fputs(const char *s, FILE *file)
+{
+    return static_cast<int>(printChars(file, s, s + strlen(s)));
+}
+
+
+int std::fprintf(FILE* file, const char *format, ...)
+{
+    Buffer<char, 1024> b;
+
+    while (true) {
+        va_list args;
+        va_start(args, format);
+        int n = vsnprintf(b.buffer, b.size, format, args);
+        va_end(args);
+        if (n >= 0 && n < b.size) {
+            translateLFtoCR(b.buffer, b.buffer + n);
+            return static_cast<int>(fwrite(b.buffer, 1, toSize_t(n), file));
+        }
+        b.expand(b.size*2);
+    }
+}
+#endif // XP_MAC_MPW
+
+
+// Write ch.
+void JS::Formatter::printChar8(char ch)
+{
+    printStr8(&ch, &ch + 1);
+}
+
+
+// Write ch.
+void JS::Formatter::printChar16(char16 ch)
+{
+    printStr16(&ch, &ch + 1);
+}
+
+
+// Write the null-terminated string str.
+void JS::Formatter::printZStr8(const char *str)
+{
+    printStr8(str, str + strlen(str));
+}
+
+
+// Write the String s.
+void JS::Formatter::printString16(const String &s)
+{
+    const char16 *begin = s.data();
+    printStr16(begin, begin + s.size());
+}
+
+
+// Write the printf format using the supplied args.
+void JS::Formatter::printVFormat8(const char *format, va_list args)
+{
+    Buffer<char, 1024> b;
+
+    while (true) {
+        int n = vsnprintf(b.buffer, b.size, format, args);
+        if (n >= 0 && static_cast<uint>(n) < b.size) {
+            printStr8(b.buffer, b.buffer + n);
+            return;
+        }
+        b.expand(b.size*2);
+    }
+}
+
+
+// Write either "true" or "false".
+JS::Formatter &JS::Formatter::operator<<(bool b)
+{
+    printZStr8(b ? "true" : "false");
+    return *this;
+}
+
+
+// Write the printf format using the supplied args.
+void JS::printFormat(Formatter &f, const char *format, ...)
+{
+    va_list args;
+    va_start(args, format);
+    f.printVFormat8(format, args);
+    va_end(args);
+}
+
+
+static const int printCharBufferSize = 64;
+
+// Print ch count times.
+void JS::printChar(Formatter &f, char ch, int count)
+{
+    char str[printCharBufferSize];
+
+    while (count > 0) {
+        int c = count;
+        if (c > printCharBufferSize)
+            c = printCharBufferSize;
+        count -= c;
+        STD::memset(str, ch, toSize_t(c));
+        printString(f, str, str+c);
+    }
+}
+
+
+// Print ch count times.
+void JS::printChar(Formatter &f, char16 ch, int count)
+{
+    char16 str[printCharBufferSize];
+
+    while (count > 0) {
+        int c = count;
+        if (c > printCharBufferSize)
+            c = printCharBufferSize;
+        count -= c;
+        char16 *strEnd = str + c;
+        std::fill(str, strEnd, ch);
+        printString(f, str, strEnd);
+    }
+}
+
+
+// Print i using the given formatting string, padding on the left with pad
+// characters to use at least nDigits characters.
+void JS::printNum(Formatter &f, uint32 i, int nDigits, char pad, const char *format)
+{
+    char str[20];
+    int n = sprintf(str, format, i);
+    if (n < nDigits)
+        printChar(f, pad, nDigits - n);
+    printString(f, str, str+n);
+}
+
+
+// Print p as a pointer.
+void JS::printPtr(Formatter &f, void *p)
+{
+    char str[20];
+    int n = sprintf(str, "%p", p);
+    printString(f, str, str+n);
+}
+
+
+// printf formats for printing non-ASCII characters on an ASCII stream
+#ifdef XP_MAC
+static const char unprintableFormat[] = "\xC7%.4X\xC8"; // Use angle quotes
+#elif defined _WIN32
+static const char unprintableFormat[] = "\xAB%.4X\xBB"; // Use angle quotes
+#else
+static const char unprintableFormat[] = "<%.4X>";
+#endif
+
+
+static const uint16 defaultFilterRanges[] = {
+    0x00, 0x09,     // Filter all control characters except \t and \n
+    0x0B, 0x20,
+    0x7F, 0x100,    // Filter all non-ASCII characters
+    0, 0
+};
+
+JS::BitSet<256> JS::AsciiFileFormatter::defaultFilter(defaultFilterRanges);
+
+
+// Construct an AsciiFileFormatter using the given file and filter f.
+// If f is nil, use the default filter.
+JS::AsciiFileFormatter::AsciiFileFormatter(FILE *file, BitSet<256> *f): file(file)
+#ifndef _WIN32  // Microsoft Visual C++ 6.0 bug
+    , filter(f ? *f : defaultFilter)
+#endif
+{
+#ifdef _WIN32       // Microsoft Visual C++ 6.0 bug
+    if (f)
+        filter = *f;
+    else
+        filter = defaultFilter;
+#endif
+    filterEmpty = filter.none();
+}
+
+
+// Write ch, escaping non-ASCII characters.
+void JS::AsciiFileFormatter::printChar8(char ch)
+{
+    if (filterChar(ch))
+        fprintf(file, unprintableFormat, static_cast<uchar>(ch));
+    else
+        fputc(ch, file);
+}
+
+
+// Write ch, escaping non-ASCII characters.
+void JS::AsciiFileFormatter::printChar16(char16 ch)
+{
+    if (filterChar(ch))
+        fprintf(file, unprintableFormat, char16Value(ch));
+    else
+        fputc(static_cast<char>(ch), file);
+}
+
+
+// Write the null-terminated string str, escaping non-ASCII characters.
+void JS::AsciiFileFormatter::printZStr8(const char *str)
+{
+    if (filterEmpty)
+        fputs(str, file);
+    else
+        printStr8(str, str + strlen(str));
+}
+
+
+// Write the string between strBegin and strEnd, escaping non-ASCII characters.
+void JS::AsciiFileFormatter::printStr8(const char *strBegin, const char *strEnd)
+{
+    if (filterEmpty)
+        printChars(file, strBegin, strEnd);
+    else {
+        ASSERT(strEnd >= strBegin);
+        const char *p = strBegin;
+        while (strBegin != strEnd) {
+            char ch = *strBegin;
+            if (filterChar(ch)) {
+                if (p != strBegin) {
+                    printChars(file, p, strBegin);
+                    p = strBegin;
+                }
+                fprintf(file, unprintableFormat, static_cast<uchar>(ch));
+            }
+            ++strBegin;
+        }
+        if (p != strBegin)
+            printChars(file, p, strBegin);
+    }
+}
+
+
+// Write the string between strBegin and strEnd, escaping non-ASCII characters.
+void JS::AsciiFileFormatter::printStr16(const char16 *strBegin, const char16 *strEnd)
+{
+    char buffer[512];
+
+    ASSERT(strEnd >= strBegin);
+    char *q = buffer;
+    while (strBegin != strEnd) {
+        char16 ch = *strBegin++;
+        if (filterChar(ch)) {
+            if (q != buffer) {
+                printChars(file, buffer, q);
+                q = buffer;
+            }
+            fprintf(file, unprintableFormat, char16Value(ch));
+        } else {
+            *q++ = static_cast<char>(ch);
+            if (q == buffer + sizeof buffer) {
+                printChars(file, buffer, buffer + sizeof buffer);
+                q = buffer;
+            }
+        }
+    }
+    if (q != buffer)
+        printChars(file, buffer, q);
+}
+
+
+JS::AsciiFileFormatter JS::stdOut(stdout);
+JS::AsciiFileFormatter JS::stdErr(stderr);
+
+
+// Write ch.
+void JS::StringFormatter::printChar8(char ch)
+{
+    s += ch;
+}
+
+
+// Write ch.
+void JS::StringFormatter::printChar16(char16 ch)
+{
+    s += ch;
+}
+
+
+// Write the null-terminated string str.
+void JS::StringFormatter::printZStr8(const char *str)
+{
+    s += str;
+}
+
+
+// Write the string between strBegin and strEnd.
+void JS::StringFormatter::printStr8(const char *strBegin, const char *strEnd)
+{
+    appendChars(s, strBegin, strEnd);
+}
+
+
+// Write the string between strBegin and strEnd.
+void JS::StringFormatter::printStr16(const char16 *strBegin, const char16 *strEnd)
+{
+    s.append(strBegin, strEnd);
+}
+
+
+// Write the String str.
+void JS::StringFormatter::printString16(const String &str)
+{
+    s += str;
+}
+
+
+
+//
+// Formatted Output
+//
+
+// See "Prettyprinting" by Derek Oppen in ACM Transactions on Programming
+// Languages and Systems 2:4, October 1980, pages 477-482 for the algorithm.
+
+// The default line width for pretty printing
+uint32 JS::PrettyPrinter::defaultLineWidth = 20;
+
+
+// Create a PrettyPrinter that outputs to Formatter f.  The PrettyPrinter
+// breaks lines at optional breaks so as to try not to exceed lines of width
+// lineWidth, although it may not always be able to do so.  Formatter f should
+// be at the beginning of a line. Call end before destroying the Formatter;
+// otherwise the last line may not be output to f.
+JS::PrettyPrinter::PrettyPrinter(Formatter &f, uint32 lineWidth):
+        lineWidth(min(lineWidth, static_cast<uint32>(unlimitedLineWidth))),
+        outputFormatter(f),
+        outputPos(0),
+        lineNum(0),
+        lastBreak(0),
+        margin(0),
+        nNestedBlocks(0),
+        leftSerialPos(0),
+        rightSerialPos(0),
+        itemPool(20)
+{
+#ifdef DEBUG
+    topRegion = 0;
+#endif
+}
+
+
+// Destroy the PrettyPrinter.  Because it's a very bad idea for a destructor to
+// throw exceptions, this destructor does not flush any buffered output.  Call
+// end just before destroying the PrettyPrinter to do that.
+JS::PrettyPrinter::~PrettyPrinter()
+{
+    ASSERT(!topRegion && !nNestedBlocks);
+}
+
+
+// Output either a line break (if sameLine is false) or length spaces (if
+// sameLine is true). Also advance leftSerialPos by length.
+//
+// If this method throws an exception, it is guaranteed to already have updated
+// all of the PrettyPrinter state; all that might be missing would be some
+// output to outputFormatter.
+void JS::PrettyPrinter::outputBreak(bool sameLine, uint32 length)
+{
+    leftSerialPos += length;
+
+    if (sameLine) {
+        outputPos += length;
+        // Exceptions may be thrown below.
+        printChar(outputFormatter, ' ', static_cast<int>(length));
+    } else {
+        lastBreak = ++lineNum;
+        outputPos = margin;
+        // Exceptions may be thrown below.
+        outputFormatter << '\n';
+        printChar(outputFormatter, ' ', static_cast<int>(margin));
+    }
+}
+
+
+// Check to see whether (rightSerialPos+rightOffset)-leftSerialPos has gotten so large that we may pop items
+// off the left end of activeItems because their totalLengths are known to be larger than the
+// amount of space left on the current line.
+// Return true if there are any items left on activeItems.
+//
+// If this method throws an exception, it leaves the PrettyPrinter in a consistent state, having
+// atomically popped off one or more items from the left end of activeItems.
+bool JS::PrettyPrinter::reduceLeftActiveItems(uint32 rightOffset)
+{
+    uint32 newRightSerialPos = rightSerialPos + rightOffset;
+    while (activeItems) {
+        Item *leftItem = &activeItems.front();
+        if (itemStack && leftItem == itemStack.front()) {
+            if (outputPos + newRightSerialPos - leftSerialPos > lineWidth) {
+                itemStack.pop_front();
+                leftItem->lengthKnown = true;
+                leftItem->totalLength = infiniteLength;
+            } else if (leftItem->lengthKnown)
+                itemStack.pop_front();
+        }
+
+        if (!leftItem->lengthKnown)
+            return true;
+
+        activeItems.pop_front();
+        try {
+            uint32 length = leftItem->length;
+            switch (leftItem->kind) {
+              case Item::text:
+                {
+                    outputPos += length;
+                    leftSerialPos += length;
+                        // Exceptions may be thrown below.
+                    char16 *textBegin;
+                    char16 *textEnd;
+                    do {
+                        length -= itemText.pop_front(length, textBegin, textEnd);
+                        printString(outputFormatter, textBegin, textEnd);
+                    } while (length);
+                }
+                break;
+
+              case Item::blockBegin:
+              case Item::indentBlockBegin:
+                {
+                    BlockInfo *b = savedBlocks.advance_back();
+                    b->margin = margin;
+                    b->lastBreak = lastBreak;
+                    b->fits = outputPos + leftItem->totalLength <= lineWidth;
+                    if (leftItem->hasKind(Item::blockBegin))
+                        margin = outputPos;
+                    else
+                        margin += length;
+                }
+                break;
+
+              case Item::blockEnd:
+                {
+                    BlockInfo &b = savedBlocks.pop_back();
+                    margin = b.margin;
+                    lastBreak = b.lastBreak;
+                }
+                break;
+
+              case Item::indent:
+                margin += length;
+                ASSERT(static_cast<int32>(margin) >= 0);
+                break;
+
+              case Item::linearBreak:
+                // Exceptions may be thrown below, but only after updating the PrettyPrinter.
+                outputBreak(savedBlocks.back().fits, length);
+                break;
+
+              case Item::fillBreak:
+                // Exceptions may be thrown below, but only after updating the PrettyPrinter.
+                outputBreak(lastBreak == lineNum && outputPos + leftItem->totalLength <= lineWidth, length);
+                break;
+            }
+        } catch (...) {
+            itemPool.destroy(leftItem);
+            throw;
+        }
+        itemPool.destroy(leftItem);
+    }
+    return false;
+}
+
+
+// A break or end of input is about to be processed.  Check whether there are
+// any complete blocks or clumps on the itemStack whose lengths we can now
+// compute; if so, compute these and pop them off the itemStack.
+// The current rightSerialPos must be the beginning of the break or end of input.
+//
+// This method can't throw exceptions.
+void JS::PrettyPrinter::reduceRightActiveItems()
+{
+    uint32 nUnmatchedBlockEnds = 0;
+    while (itemStack) {
+        Item *rightItem = itemStack.pop_back();
+        switch (rightItem->kind) {
+          case Item::blockBegin:
+          case Item::indentBlockBegin:
+            if (!nUnmatchedBlockEnds) {
+                itemStack.fast_push_back(rightItem);
+                return;
+            }
+            rightItem->computeTotalLength(rightSerialPos);
+            --nUnmatchedBlockEnds;
+            break;
+
+          case Item::blockEnd:
+            ++nUnmatchedBlockEnds;
+            break;
+
+          case Item::linearBreak:
+          case Item::fillBreak:
+            rightItem->computeTotalLength(rightSerialPos);
+            if (!nUnmatchedBlockEnds)
+                // There can be at most one consecutive break posted on the itemStack.
+                return;
+            break;
+
+          default:
+            ASSERT(false);  // Other kinds can't be pushed onto the itemStack.
+        }
+    }
+}
+
+
+// Indent the beginning of every new line after this one by offset until the
+// corresponding endIndent call.  Return an Item to pass to endIndent that will
+// end this indentation. This method may throw an exception, in which case the
+// PrettyPrinter is left unchanged.
+JS::PrettyPrinter::Item &JS::PrettyPrinter::beginIndent(int32 offset)
+{
+    Item *unindent = new(itemPool) Item(Item::indent, static_cast<uint32>(-offset));
+    if (activeItems) {
+        try {
+            activeItems.push_back(*new(itemPool) Item(Item::indent, static_cast<uint32>(offset)));
+        } catch (...) {
+            itemPool.destroy(unindent);
+            throw;
+        }
+    } else {
+        margin += offset;
+        ASSERT(static_cast<int32>(margin) >= 0);
+    }
+    return *unindent;
+}
+
+
+// End an indent began by beginIndent.  i should be the result of a beginIndent.
+// This method can't throw exceptions (it's called by the Indent destructor).
+void JS::PrettyPrinter::endIndent(Item &i)
+{
+    if (activeItems)
+        activeItems.push_back(i);
+    else {
+        margin += i.length;
+        ASSERT(static_cast<int32>(margin) >= 0);
+        itemPool.destroy(&i);
+    }
+}
+
+
+// Begin a logical block.  If kind is Item::indentBlockBegin, offset is the
+// indent to use for the second and subsequent lines of this block.
+// Return an Item to pass to endBlock that will end this block.
+// This method may throw an exception, in which case the PrettyPrinter is left
+// unchanged.
+JS::PrettyPrinter::Item &JS::PrettyPrinter::beginBlock(Item::Kind kind, int32 offset)
+{
+    uint32 newNNestedBlocks = nNestedBlocks + 1;
+    savedBlocks.reserve(newNNestedBlocks);
+    itemStack.reserve_back(1 + newNNestedBlocks);
+    Item *endItem = new(itemPool) Item(Item::blockEnd);
+    Item *beginItem;
+    try {
+        beginItem = new(itemPool) Item(kind, static_cast<uint32>(offset), rightSerialPos);
+    } catch (...) {
+        itemPool.destroy(endItem);
+        throw;
+    }
+    // No state modifications before this point.
+    // No exceptions after this point.
+    activeItems.push_back(*beginItem);
+    itemStack.fast_push_back(beginItem);
+    nNestedBlocks = newNNestedBlocks;
+    return *endItem;
+}
+
+
+// End a logical block began by beginBlock.  i should be the result of a
+// beginBlock.
+// This method can't throw exceptions (it's called by the Block destructor).
+void JS::PrettyPrinter::endBlock(Item &i)
+{
+    activeItems.push_back(i);
+    itemStack.fast_push_back(&i);
+    --nNestedBlocks;
+}
+
+
+// Write a conditional line break.  This kind of a line break can only be
+// emitted inside a block.
+// A linear line break starts a new line if the containing block cannot be put
+// all one one line; otherwise the line break is replaced by nSpaces spaces.
+// Typically a block contains several linear breaks; either they all start new
+// lines or none of them do.
+// Moreover, if a block directly contains a required break then linear breaks
+// become required breaks.
+//
+// A fill line break starts a new line if either the preceding clump or the
+// following clump cannot be placed entirely on one line or if the following
+// clump would not fit on the current line.  A clump is a consecutive sequence
+// of strings and nested blocks delimited by either a break or the beginning or
+// end of the currently enclosing block.
+//
+// If this method throws an exception, it leaves the PrettyPrinter in a
+// consistent state.
+void JS::PrettyPrinter::conditionalBreak(uint32 nSpaces, Item::Kind kind)
+{
+    ASSERT(nSpaces <= unlimitedLineWidth && nNestedBlocks);
+    reduceRightActiveItems();
+    itemStack.reserve_back(1 + nNestedBlocks);
+    // Begin of exception-atomic stack update.  Only new(itemPool) can throw
+    // an exception here, in which case nothing is updated.
+    Item *i = new(itemPool) Item(kind, nSpaces, rightSerialPos);
+    activeItems.push_back(*i);
+    itemStack.fast_push_back(i);
+    rightSerialPos += nSpaces;
+    // End of exception-atomic stack update.
+    reduceLeftActiveItems(0);
+}
+
+
+// Write the string between strBegin and strEnd.  Any embedded newlines ('\n'
+// only) become required line breaks.
+//
+// If this method throws an exception, it may have partially formatted the
+// string but leaves the PrettyPrinter in a consistent state.
+void JS::PrettyPrinter::printStr8(const char *strBegin, const char *strEnd)
+{
+    while (strBegin != strEnd) {
+        const char *sectionEnd = findValue(strBegin, strEnd, '\n');
+        uint32 sectionLength = static_cast<uint32>(sectionEnd - strBegin);
+        if (sectionLength) {
+            if (reduceLeftActiveItems(sectionLength)) {
+                itemText.reserve_back(sectionLength);
+                Item &backItem = activeItems.back();
+                // Begin of exception-atomic update.  Only new(itemPool) can throw an exception here,
+                // in which case nothing is updated.
+                if (backItem.hasKind(Item::text))
+                    backItem.length += sectionLength;
+                else
+                    activeItems.push_back(*new(itemPool) Item(Item::text, sectionLength));
+                rightSerialPos += sectionLength;
+                itemText.fast_append(reinterpret_cast<const uchar *>(strBegin), reinterpret_cast<const uchar *>(sectionEnd));
+                // End of exception-atomic update.
+            } else {
+                ASSERT(!itemStack && !activeItems && !itemText && leftSerialPos == rightSerialPos);
+                outputPos += sectionLength;
+                printString(outputFormatter, strBegin, sectionEnd);
+            }
+            strBegin = sectionEnd;
+            if (strBegin == strEnd)
+                break;
+        }
+        requiredBreak();
+        ++strBegin;
+    }
+}
+
+
+// Write the string between strBegin and strEnd.  Any embedded newlines ('\n'
+// only) become required line breaks.
+//
+// If this method throws an exception, it may have partially formatted the
+// string but leaves the PrettyPrinter in a consistent state.
+void JS::PrettyPrinter::printStr16(const char16 *strBegin, const char16 *strEnd)
+{
+    while (strBegin != strEnd) {
+        const char16 *sectionEnd = findValue(strBegin, strEnd, uni::lf);
+        uint32 sectionLength = static_cast<uint32>(sectionEnd - strBegin);
+        if (sectionLength) {
+            if (reduceLeftActiveItems(sectionLength)) {
+                itemText.reserve_back(sectionLength);
+                Item &backItem = activeItems.back();
+                // Begin of exception-atomic update.  Only new(itemPool) can throw an exception here,
+                // in which case nothing is updated.
+                if (backItem.hasKind(Item::text))
+                    backItem.length += sectionLength;
+                else
+                    activeItems.push_back(*new(itemPool) Item(Item::text, sectionLength));
+                rightSerialPos += sectionLength;
+                itemText.fast_append(strBegin, sectionEnd);
+                // End of exception-atomic update.
+            } else {
+                ASSERT(!itemStack && !activeItems && !itemText && leftSerialPos == rightSerialPos);
+                outputPos += sectionLength;
+                printString(outputFormatter, strBegin, sectionEnd);
+            }
+            strBegin = sectionEnd;
+            if (strBegin == strEnd)
+                break;
+        }
+        requiredBreak();
+        ++strBegin;
+    }
+}
+
+
+// Write a required line break.
+//
+// If this method throws an exception, it may have emitted partial output but
+// leaves the PrettyPrinter in a consistent state.
+void JS::PrettyPrinter::requiredBreak()
+{
+    reduceRightActiveItems();
+    reduceLeftActiveItems(infiniteLength);
+    ASSERT(!itemStack && !activeItems && !itemText && leftSerialPos == rightSerialPos);
+    outputBreak(false, 0);
+}
+
+
+// If required is true, write a required line break; otherwise write a linear
+// line break of the given width.
+//
+// If this method throws an exception, it may have emitted partial output but
+// leaves the PrettyPrinter in a consistent state.
+void JS::PrettyPrinter::linearBreak(uint32 nSpaces, bool required)
+{
+    if (required)
+        requiredBreak();
+    else
+        linearBreak(nSpaces);
+}
+
+
+// Flush any saved output in the PrettyPrinter to the output.  Call this just
+// before destroying the PrettyPrinter.  All Indent and Block objects must have
+// been exited already.
+//
+// If this method throws an exception, it may have emitted partial output but
+// leaves the PrettyPrinter in a consistent state.
+void JS::PrettyPrinter::end()
+{
+    ASSERT(!topRegion);
+    reduceRightActiveItems();
+    reduceLeftActiveItems(infiniteLength);
+    ASSERT(!savedBlocks && !itemStack && !activeItems && !itemText && rightSerialPos == leftSerialPos && !margin);
+}

mozilla/js2/src/formatter.h

@@ -0,0 +1,320 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public
+ * License Version 1.1 (the "License"); you may not use this file
+ * except in compliance with the License. You may obtain a copy of
+ * the License at http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the License is distributed on an "AS
+ * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
+ * implied. See the License for the specific language governing
+ * rights and limitations under the License.
+ *
+ * The Original Code is the JavaScript 2 Prototype.
+ *
+ * The Initial Developer of the Original Code is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation. All
+ * Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * Alternatively, the contents of this file may be used under the
+ * terms of the GNU Public License (the "GPL"), in which case the
+ * provisions of the GPL are applicable instead of those above.
+ * If you wish to allow use of your version of this file only
+ * under the terms of the GPL and not to allow others to use your
+ * version of this file under the NPL, indicate your decision by
+ * deleting the provisions above and replace them with the notice
+ * and other provisions required by the GPL.  If you do not delete
+ * the provisions above, a recipient may use your version of this
+ * file under either the NPL or the GPL.
+ */
+
+#ifndef formatter_h___
+#define formatter_h___
+
+#include <cstdio>
+#include <cstdarg>
+
+#include "systemtypes.h"
+#include "utilities.h"
+#include "stlcfg.h"
+#include "ds.h"
+#include "strings.h"
+
+namespace JavaScript
+{
+//
+// Output
+//
+
+    // Print the characters between begin and end to the given file.  These
+    // characters may include nulls.
+    size_t printChars(FILE *file, const char *begin, const char *end);
+
+#ifndef XP_MAC_MPW
+    inline size_t printChars(FILE *file, const char *begin, const char *end) {
+        ASSERT(end >= begin);
+        return STD::fwrite(begin, 1, toSize_t(end - begin), file);
+    }
+#endif
+
+
+    // A Formatter is an abstract base class representing a simplified output stream.
+    // One can print text to a Formatter by using << and the various global
+    // print... methods below. Formatters accept both char and char16 text and
+    // convert as appropriate to their actual stream.
+    class Formatter {
+      protected:
+        virtual void printChar8(char ch);
+        virtual void printChar16(char16 ch);
+        virtual void printZStr8(const char *str);
+        virtual void printStr8(const char *strBegin, const char *strEnd) = 0;
+        virtual void printStr16(const char16 *strBegin, const char16 *strEnd) = 0;
+        virtual void printString16(const String &s);
+        virtual void printVFormat8(const char *format, va_list args);
+      public:
+
+#ifdef __GNUC__ // Workaround for gcc pedantry.  No one should be calling delete on a raw Formatter.
+        virtual ~Formatter() {}
+#endif
+
+        Formatter &operator<<(char ch) {printChar8(ch); return *this;}
+        Formatter &operator<<(char16 ch) {printChar16(ch); return *this;}
+        Formatter &operator<<(const char *str) {printZStr8(str); return *this;}
+        Formatter &operator<<(const String &s) {printString16(s); return *this;}
+        Formatter &operator<<(bool b);
+        Formatter &operator<<(uint8 i) {printFormat(*this, "%u", i); return *this;}
+        Formatter &operator<<(uint32 i) {printFormat(*this, "%u", i); return *this;}
+        Formatter &operator<<(int32 i) {printFormat(*this, "%d", i); return *this;}
+
+#ifndef _WIN32
+        // Cause compile-time undefined YOU_TRIED_TO_PRINT_A_RAW_POINTER identifier errors for accidental printing of pointers.
+        // The error occurs at the place where you try to instantiate this template; the compiler may or may not tell you where it is.
+        template<class T> Formatter &operator<<(const T *s) {YOU_TRIED_TO_PRINT_A_RAW_POINTER(s); return *this;}
+#endif
+
+        friend void printString(Formatter &f, const char *strBegin, const char *strEnd) {f.printStr8(strBegin, strEnd);}
+        friend void printString(Formatter &f, const char16 *strBegin, const char16 *strEnd) {f.printStr16(strBegin, strEnd);}
+        friend void printFormat(Formatter &f, const char *format, ...);
+    };
+
+    void printNum(Formatter &f, uint32 i, int nDigits, char pad, const char *format);
+    void printChar(Formatter &f, char ch, int count);
+    void printChar(Formatter &f, char16 ch, int count);
+    inline void printDec(Formatter &f, int32 i, int nDigits = 0, char pad = ' ') {printNum(f, (uint32)i, nDigits, pad, "%i");}
+    inline void printDec(Formatter &f, uint32 i, int nDigits = 0, char pad = ' ') {printNum(f, i, nDigits, pad, "%u");}
+    inline void printHex(Formatter &f, int32 i, int nDigits = 0, char pad = '0') {printNum(f, (uint32)i, nDigits, pad, "%X");}
+    inline void printHex(Formatter &f, uint32 i, int nDigits = 0, char pad = '0') {printNum(f, i, nDigits, pad, "%X");}
+    void printPtr(Formatter &f, void *p);
+
+
+    // An AsciiFileFormatter is a Formatter that prints to a standard ASCII
+    // file or stream. Characters with Unicode values of 256 or higher are
+    // converted to escape sequences. Selected lower characters can also be
+    // converted to escape sequences; these are specified by set bits in the
+    // BitSet passed to the constructor.
+    class AsciiFileFormatter: public Formatter {
+        FILE *file;
+        BitSet<256> filter; // Set of first 256 characters that are to be converted to escape sequences
+        bool filterEmpty;   // True if filter passes all 256 characters
+      public:
+        static BitSet<256> defaultFilter;  // Default value of filter when not given in the constructor
+
+        explicit AsciiFileFormatter(FILE *file, BitSet<256> *filter = 0);
+
+      private:
+        bool filterChar(char ch) {return filter[static_cast<uchar>(ch)];}
+        bool filterChar(char16 ch) {
+            return char16Value(ch) >= 0x100 || filter[char16Value(ch)];
+        }
+
+      protected:
+        void printChar8(char ch);
+        void printChar16(char16 ch);
+        void printZStr8(const char *str);
+        void printStr8(const char *strBegin, const char *strEnd);
+        void printStr16(const char16 *strBegin, const char16 *strEnd);
+    };
+
+    extern AsciiFileFormatter stdOut;
+    extern AsciiFileFormatter stdErr;
+
+
+    // A StringFormatter is a Formatter that prints to a String.
+    class StringFormatter: public Formatter {
+        String s;
+
+      public:
+        const String& getString() { return s; }
+        void clear() {JavaScript::clear(s);}
+      protected:
+        void printChar8(char ch);
+        void printChar16(char16 ch);
+        void printZStr8(const char *str);
+        void printStr8(const char *strBegin, const char *strEnd);
+        void printStr16(const char16 *strBegin, const char16 *strEnd);
+        void printString16(const String &str);
+    };
+
+
+//
+// Formatted Output
+//
+
+    class PrettyPrinter: public Formatter {
+      public:
+        STATIC_CONST(uint32, unlimitedLineWidth = 0x7FFFFFFF);
+        class Region;
+        class Indent;
+        class Block;
+
+      private:
+        STATIC_CONST(uint32, infiniteLength = 0x80000000);
+        const uint32 lineWidth;         // Current maximum desired line width
+
+        struct BlockInfo {
+            uint32 margin;              // Saved margin before this block's beginning
+            uint32 lastBreak;           // Saved lastBreak before this block's beginning
+            bool fits;                  // True if this entire block fits on one line
+        };
+
+        // Variables for the back end that prints to the destination
+        Formatter &outputFormatter;     // Destination formatter on which the result should be printed
+        uint32 outputPos;               // Number of characters printed on current output line
+        uint32 lineNum;                 // Serial number of current line
+        uint32 lastBreak;               // Number of line just after the last break that occurred in this block
+        uint32 margin;                  // Current left margin in spaces
+        ArrayBuffer<BlockInfo, 20> savedBlocks; // Stack of saved information about partially printed blocks
+
+        // Variables for the front end that calculates block sizes
+        struct Item: ListQueueEntry {
+            enum Kind {text, blockBegin, indentBlockBegin, blockEnd, indent, linearBreak, fillBreak};
+
+            const Kind kind;            // The kind of this text sequence
+            bool lengthKnown;           // True if totalLength is known; always true for text, blockEnd, and indent Items
+            uint32 length;              // Length of this text sequence, number of spaces for this break, or delta for indent or indentBlockBegin
+            uint32 totalLength;         // Total length of this block (for blockBegin) or length of this break plus following clump (for breaks);
+                                        // If lengthKnown is false, this is the serialPos of this Item instead of a length
+            bool hasKind(Kind k) const {return kind == k;}
+
+            explicit Item(Kind kind): kind(kind), lengthKnown(true) {}
+            Item(Kind kind, uint32 length): kind(kind), lengthKnown(true), length(length) {}
+            Item(Kind kind, uint32 length, uint32 beginSerialPos):
+                    kind(kind), lengthKnown(false), length(length), totalLength(beginSerialPos) {}
+
+            void computeTotalLength(uint32 endSerialPos) {
+                ASSERT(!lengthKnown);
+                lengthKnown = true;
+                totalLength = endSerialPos - totalLength;
+            }
+
+        };
+
+#ifdef DEBUG
+        Region *topRegion;              // Most deeply nested Region
+#endif
+        uint32 nNestedBlocks;           // Number of nested Blocks
+
+        uint32 leftSerialPos;           // The difference rightSerialPos-
+        uint32 rightSerialPos;          // leftSerialPos is always the number of characters that would be output by
+                                        // printing activeItems if they all fit on one line; only the difference
+                                        // matters -- the absolute values are irrelevant and may wrap around 2^32.
+
+        ArrayQueue<Item *, 20> itemStack; // Stack of enclosing nested Items whose lengths have not yet been determined;
+                                        // itemStack always has room for at least nNestedBlocks extra entries so that end Items
+                                        // may be added without throwing an exception.
+        Pool<Item> itemPool;            // Pool from which to allocate activeItems
+        ListQueue<Item> activeItems;    // Queue of items left to be printed
+        ArrayQueue<char16, 256> itemText; // Text of text items in activeItems, in the same order as in activeItems
+
+      public:
+        static uint32 defaultLineWidth; // Default for lineWidth if not given to the constructor
+
+        explicit PrettyPrinter(Formatter &f, uint32 lineWidth = defaultLineWidth);
+      private:
+        PrettyPrinter(const PrettyPrinter&);    // No copy constructor
+        void operator=(const PrettyPrinter&);   // No assignment operator
+      public:
+        virtual ~PrettyPrinter();
+
+      private:
+        void outputBreak(bool sameLine, uint32 nSpaces);
+        bool reduceLeftActiveItems(uint32 rightOffset);
+        void reduceRightActiveItems();
+
+        Item &beginIndent(int32 offset);
+        void endIndent(Item &i);
+
+        Item &beginBlock(Item::Kind kind, int32 offset);
+        void endBlock(Item &i);
+
+        void conditionalBreak(uint32 nSpaces, Item::Kind kind);
+
+      protected:
+        void printStr8(const char *strBegin, const char *strEnd);
+        void printStr16(const char16 *strBegin, const char16 *strEnd);
+      public:
+
+        void requiredBreak();
+        void linearBreak(uint32 nSpaces) {conditionalBreak(nSpaces, Item::linearBreak);}
+        void linearBreak(uint32 nSpaces, bool required);
+        void fillBreak(uint32 nSpaces) {conditionalBreak(nSpaces, Item::fillBreak);}
+
+        void end();
+
+        friend class Region;
+        friend class Indent;
+        friend class Block;
+
+        class Region {
+#ifdef DEBUG
+            Region *next;  // Link to next most deeply nested Region
+#endif
+          protected:
+            PrettyPrinter &pp;
+
+            Region(PrettyPrinter &pp): pp(pp) {DEBUG_ONLY(next = pp.topRegion; pp.topRegion = this;);}
+          private:
+            Region(const Region&);          // No copy constructor
+            void operator=(const Region&);  // No assignment operator
+          protected:
+#ifdef DEBUG
+            ~Region() {pp.topRegion = next;}
+#endif
+        };
+
+        // Use an Indent object to temporarily indent a PrettyPrinter by the
+        // offset given to the Indent's constructor. The PrettyPrinter's margin
+        // is set back to its original value when the Indent object is destroyed.
+        // Using an Indent object is exception-safe; no matter how control
+        // leaves an Indent scope, the indent is undone.
+        // Scopes of Indent and Block objects must be properly nested.
+        class Indent: public Region {
+            Item &endItem;              // The Item returned by beginIndent
+          public:
+            Indent(PrettyPrinter &pp, int32 offset): Region(pp), endItem(pp.beginIndent(offset)) {}
+            ~Indent() {pp.endIndent(endItem);}
+        };
+
+        // Use a Block object to temporarily enter a PrettyPrinter block.  If an
+        // offset is provided, line breaks inside the block are indented by that
+        // offset relative to the existing indent; otherwise, line breaks inside
+        // the block are indented to the current output position.  The block
+        // lasts until the Block object is destroyed.
+        // Scopes of Indent and Block objects must be properly nested.
+        class Block: public Region {
+            Item &endItem;              // The Item returned by beginBlock
+          public:
+            explicit Block(PrettyPrinter &pp): Region(pp), endItem(pp.beginBlock(Item::blockBegin, 0)) {}
+            Block(PrettyPrinter &pp, int32 offset): Region(pp), endItem(pp.beginBlock(Item::indentBlockBegin, offset)) {}
+            ~Block() {pp.endBlock(endItem);}
+        };
+    };
+
+
+    void escapeString(Formatter &f, const char16 *begin, const char16 *end, char16 quote);
+    void quoteString(Formatter &f, const String &s, char16 quote);
+}
+#endif /* formatter_h___ */

mozilla/js2/src/gc_allocator.cpp

@@ -0,0 +1,151 @@
+// -*- Mode: C++; tab-width: 4; indent-tabs-mode: t; c-basic-offset: 4 -*-
+//
+// The contents of this file are subject to the Netscape Public
+// License Version 1.1 (the "License"); you may not use this file
+// except in compliance with the License. You may obtain a copy of
+// the License at http://www.mozilla.org/NPL/
+//
+// Software distributed under the License is distributed on an "AS
+// IS" basis, WITHOUT WARRANTY OF ANY KIND, either express oqr
+// implied. See the License for the specific language governing
+// rights and limitations under the License.
+//
+// The Original Code is the JavaScript 2 Prototype.
+//
+// The Initial Developer of the Original Code is Netscape
+// Communications Corporation.  Portions created by Netscape are
+// Copyright (C) 2000 Netscape Communications Corporation. All
+// Rights Reserved.
+
+#include <iostream>
+#include <string>
+#include <vector>
+#include <algorithm>
+
+#include "stlcfg.h"
+#include "gc_allocator.h"
+#include "gc_container.h"
+
+/*
+namespace JavaScript {
+
+template <class T>
+typename gc_allocator<T>::pointer
+gc_allocator<T>::allocate(gc_allocator<T>::size_type n, const void*)
+{
+	return static_cast<pointer>(GC_malloc(n*sizeof(T)));
+}
+
+template <class T>
+void gc_allocator<T>::deallocate(gc_allocator<T>::pointer ptr, gc_allocator<T>::size_type)
+{
+	// this can really be a NO-OP with the GC.
+	// ::GC_free(static_cast<void*>(ptr));
+}
+
+}
+ */
+
+// test driver for standalone GC development.
+
+namespace JS = JavaScript;
+
+template <class T>
+void* operator new(std::size_t, const JS::gc_allocator<T>& alloc)
+{
+	return alloc.allocate(1);
+}
+
+/**
+ * Define a C++ class that is garbage collectable, and wants to have its destructor
+ * called when it is finalized.
+ */
+class A {
+public:
+	typedef JS::gc_traits_finalizable<A> traits;
+	typedef JS::gc_allocator<A, traits> allocator;
+	friend struct traits;
+	
+	static int instances;
+	
+	void* operator new(std::size_t)
+	{
+		return allocator::allocate(1);
+	}
+	
+	A()
+	{
+		++instances;
+		std::cout << "A::A() here." << std::endl;
+	}
+
+protected:	
+	~A()
+	{
+		--instances;
+		std::cout << "A::~A() here." << std::endl;
+	}
+
+private:
+	// void operator delete(void*) {}
+};
+
+int A::instances = 0;
+
+int main(int /* argc */, char* /* argv[] */)
+{
+	using namespace std;
+	using namespace JS;
+
+	cout << "testing the GC allocator." << endl;
+
+#ifdef XP_MAC
+	// allocate a string, using the GC, and owned by an auto_ptr, that knows how to correctly destroy the string.
+	typedef gc_container<char>::string char_string;
+	typedef gc_allocator<char_string> char_string_alloc;
+	auto_ptr<char_string, char_string_alloc> ptr(new(char_string_alloc()) char_string("This is a garbage collectable string."));
+	const char_string& str = *ptr;
+	cout << str << endl;
+#endif
+	
+	// question, how can we partially evaluate a template?
+	// can we say, typedef template <class T> vector<typename T>.
+	// typedef vector<int, gc_allocator<int> > int_vector;
+	typedef gc_container<int>::vector int_vector;
+	
+	// generate 1000 random values.
+	int_vector values;
+	for (int i = 0; i < 1000; ++i) {
+		int value = rand() % 32767;
+		values.push_back(value);
+		// allocate a random amount of garbage.
+		if (!GC_malloc(toSize_t(value)))
+			cerr << "GC_malloc failed." << endl;
+		// allocate an object that has a finalizer to call its destructor.
+		A* a = new A();
+	}
+
+	// run a collection.
+	// gc_allocator<void>::collect();
+	GC_gcollect();
+
+	// print out instance count.
+	cout << "A::instances = " << A::instances << endl;
+	
+	// sort the values.
+	sort(values.begin(), values.end());
+	
+	// print the values.
+	int_vector::iterator iter = values.begin(), last = values.end();
+	cout << *iter++;
+	while (iter < last)
+		cout << ' ' << *iter++;
+	cout << endl;
+
+#ifdef XP_MAC	
+	// finally, print the string again.
+	cout << str << endl;
+#endif
+
+	return 0;
+}