Compare commits

..

1 Commits

Author SHA1 Message Date
(no author)
258dc9fead This commit was manufactured by cvs2svn to create branch 'src'.
git-svn-id: svn://10.0.0.236/branches/src@33658 18797224-902f-48f8-a5cc-f745e15eee43
1999-06-03 23:10:01 +00:00
266 changed files with 18627 additions and 71485 deletions

View File

@@ -1 +0,0 @@

View File

@@ -1,29 +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 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.

View File

@@ -1,14 +0,0 @@
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)

View File

@@ -1 +0,0 @@

View File

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

View File

@@ -1 +0,0 @@

View File

@@ -1,98 +0,0 @@
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.

View File

@@ -1,26 +0,0 @@
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 ?

140
mozilla/js2/aclocal.m4 vendored
View File

@@ -1,140 +0,0 @@
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([,]))])

View File

@@ -1,20 +0,0 @@
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

View File

@@ -1,42 +0,0 @@
/* 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

2407
mozilla/js2/configure vendored

File diff suppressed because it is too large Load Diff

View File

@@ -1,57 +0,0 @@
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)

View File

@@ -1,251 +0,0 @@
#!/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

View File

@@ -1,190 +0,0 @@
#! /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

View File

@@ -1,40 +0,0 @@
#! /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

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -1,550 +0,0 @@
;;; 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))))))

View File

@@ -1,485 +0,0 @@
;;; 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")
|#

View File

@@ -1,96 +0,0 @@
;;; 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)

View File

@@ -1,696 +0,0 @@
;;; 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))))
|#

View File

@@ -1,400 +0,0 @@
;;;
;;; 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))
|#

View File

@@ -1,179 +0,0 @@
(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'\"'\"")
|#

View File

@@ -1,567 +0,0 @@
;;;
;;; 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*))

File diff suppressed because it is too large Load Diff

View File

@@ -1,655 +0,0 @@
;;;
;;; 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*))

View File

@@ -1,192 +0,0 @@
;;;
;;; 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*))

View File

@@ -1,492 +0,0 @@
;;; 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))

View File

@@ -1,863 +0,0 @@
;;; 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'")
|#

View File

@@ -1,779 +0,0 @@
;;; 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)))

View File

@@ -1,89 +0,0 @@
;;; 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)

View File

@@ -1,700 +0,0 @@
;;; 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)))))

View File

@@ -1,360 +0,0 @@
;;; 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))

View File

@@ -1,837 +0,0 @@
;;; 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)))

View File

@@ -1,11 +0,0 @@
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.

File diff suppressed because it is too large Load Diff

View File

@@ -1,68 +0,0 @@
(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*))

View File

@@ -1,66 +0,0 @@
;;; 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*))

View File

@@ -1,71 +0,0 @@
;;; 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*))

View File

@@ -1,68 +0,0 @@
;;; 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*))

View File

@@ -1,71 +0,0 @@
(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*))

View File

@@ -1,37 +0,0 @@
(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*))

View File

@@ -1,56 +0,0 @@
(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*))

View File

@@ -1,736 +0,0 @@
;;; 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)))

View File

@@ -1,72 +0,0 @@
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}

View File

@@ -1,124 +0,0 @@
// 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);

View File

@@ -1,417 +0,0 @@
#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.
*/

View File

@@ -1,136 +0,0 @@
/*
* 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.
*/

View File

@@ -1,28 +0,0 @@
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

View File

@@ -1,65 +0,0 @@
/* -*- 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___ */

File diff suppressed because it is too large Load Diff

View File

@@ -1,396 +0,0 @@
/* -*- 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___ */

View File

@@ -1,240 +0,0 @@
/* -*- 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
}

View File

@@ -1,156 +0,0 @@
/* -*- 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___

View File

@@ -1,191 +0,0 @@
/* -*- 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

View File

@@ -1,472 +0,0 @@
/* -*- 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 */

View File

@@ -1,163 +0,0 @@
/* -*- 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 */

View File

@@ -1,740 +0,0 @@
/* -*- 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___ */

View File

@@ -1,85 +0,0 @@
/* -*- 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;
}

View File

@@ -1,95 +0,0 @@
/* -*- 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___ */

View File

@@ -1,66 +0,0 @@
/* -*- 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
};
}

View File

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

View File

@@ -1,140 +0,0 @@
/* -*- 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

View File

@@ -1,880 +0,0 @@
/* -*- 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);
}

View File

@@ -1,320 +0,0 @@
/* -*- 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___ */

View File

@@ -1,151 +0,0 @@
// -*- 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;
}

View File

@@ -1,214 +0,0 @@
/* -*- 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 gc_allocator_h
#define gc_allocator_h
#include <memory>
// Microsoft VC6 bug: standard identifiers should be in std namespace
#ifndef _WIN32
using std::size_t;
using std::ptrdiff_t;
#endif
namespace JavaScript {
extern "C" {
void* GC_malloc(size_t bytes);
void* GC_malloc_atomic(size_t bytes);
void GC_free(void* ptr);
void GC_gcollect(void);
typedef void (*GC_finalization_proc) (void* obj, void* client_data);
void GC_register_finalizer(void* obj, GC_finalization_proc proc,
void* client_data,
GC_finalization_proc *old_proc,
void* *old_client_data);
}
#if 0 && !defined(XP_MAC)
// for platforms where GC doesn't exist yet.
inline void* GC_malloc(size_t bytes) { return ::operator new(bytes); }
inline void* GC_malloc_atomic(size_t bytes) { return ::operator new(bytes); }
inline void GC_free(void* ptr) { operator delete(ptr); }
inline void GC_gcollect() {}
inline void GC_register_finalizer(void* obj, GC_finalization_proc proc,
void* client_data,
GC_finalization_proc *old_proc,
void* *old_client_data) {}
#endif
/**
* General case: memory for type must be allocated as a conservatively
* scanned block of memory.
*/
template <class T> struct gc_traits {
static T* allocate(size_t n) {
return static_cast<T*>(GC_malloc(n * sizeof(T)));
}
};
/**
* Specializations for blocks of atomic types: the macro define_atomic_type(_type)
* specializes gc_traits<T> for types that need not be scanned by the
* GC. Implementors are free to define other types as atomic, if they are
* guaranteed not to contain pointers.
*/
#define define_atomic_type(_type) \
template <> struct gc_traits<_type> { \
static _type* allocate(size_t n) \
{ \
return static_cast<_type*>(GC_malloc_atomic(n * sizeof(_type))); \
} \
};
define_atomic_type(char)
define_atomic_type(unsigned char)
define_atomic_type(short)
define_atomic_type(unsigned short)
define_atomic_type(int)
define_atomic_type(unsigned int)
define_atomic_type(long)
define_atomic_type(unsigned long)
define_atomic_type(float)
define_atomic_type(double)
#undef define_atomic_type
/**
* Traits for classes that need to have their destructor called
* when reclaimed by the garbage collector.
*/
template <class T> struct gc_traits_finalizable {
static void finalizer(void* obj, void* client_data)
{
T* t = static_cast<T*>(obj);
size_t n = reinterpret_cast<size_t>(client_data);
for (size_t i = 0; i < n; ++i)
t[i].~T();
}
static T* allocate(size_t n)
{
T* t = gc_traits<T>::allocate(n);
GC_finalization_proc old_proc; void* old_client_data;
GC_register_finalizer(t, &finalizer, reinterpret_cast<void*>(n),
&old_proc, &old_client_data);
return t;
}
};
/**
* An allocator that can be used to allocate objects in the garbage
* collected heap.
*/
template <class T, class traits = gc_traits<T> > class gc_allocator {
public:
typedef T value_type;
typedef size_t size_type;
typedef ptrdiff_t difference_type;
typedef T *pointer;
typedef const T *const_pointer;
typedef T &reference;
typedef const T &const_reference;
gc_allocator() {}
template<typename U, typename UTraits>
gc_allocator(const gc_allocator<U, UTraits>&) {}
// ~gc_allocator() {}
static pointer address(reference r) { return &r; }
static const_pointer address(const_reference r) { return &r; }
static pointer allocate(size_type n, const void* /* hint */ = 0) {
return traits::allocate(n);
}
static void deallocate(pointer, size_type) {}
static void construct(pointer p, const T &val) { new(p) T(val);}
static void destroy(pointer p) { p->~T(); }
#if defined(__GNUC__) || defined(_WIN32)
static size_type max_size() { return size_type(-1) / sizeof(T); }
#else
static size_type max_size() {
return std::numeric_limits<size_type>::max() / sizeof(T);
}
#endif
template<class U> struct rebind { typedef gc_allocator<U> other; };
#ifdef _WIN32
// raw byte allocator used on some platforms (grrr).
typedef char _Char[1];
static char* _Charalloc(size_type n) {
return (char*) rebind<_Char>::other::allocate(n);
}
/**
* funky operator required for calling basic_string<T> constructor
* (grrr).
*/
template<typename U, typename UTraits>
int operator==(const gc_allocator<U, UTraits>&) { return 0; }
#endif
// void* deallocate used on some platforms (grrr).
static void deallocate(void*, size_type) {}
static void collect() { GC_gcollect(); }
};
/**
* Generic base class for objects allocated using a gc_allocator. How they
* are allocated can be controlled by specializing gc_traits for the
* specific class.
*/
template <typename T> class gc_object {
public:
void* operator new(size_t) { return gc_allocator<T>::allocate(1, 0); }
void operator delete(void* /* ptr */) {}
};
/**
* Simpler base class for classes that have no need to specialize allocation
* behavior.
*/
class gc_base {
public:
void* operator new(size_t n) { return GC_malloc(n); }
void operator delete(void*) {}
};
}
#endif /* gc_allocator_h */

View File

@@ -1,85 +0,0 @@
/* -*- 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 gc_container_h
#define gc_container_h
#include "gc_allocator.h"
#include <list>
#include <vector>
#include <string>
#define LIST std::list
#define VECTOR std::vector
#if defined(__GNUC__)
// grr, what kind of standard is this?
#define STRING basic_string
#define CHAR_TRAITS string_char_traits
#else
#define STRING std::basic_string
#define CHAR_TRAITS std::char_traits
#endif
namespace JavaScript {
/**
* Rebind some of the basic container types to use a GC_allocator.
* What I really want is something more general, something like:
* template <typename Container, typename T> class gc_rebind {
* typedef typename Container<T, gc_allocator<T> > other;
* };
* But I can't figure out how to do that with C++ templates.
*/
template <class T> struct gc_container {
typedef typename LIST<T, gc_allocator<T> > list;
typedef typename VECTOR<T, gc_allocator<T> > vector;
typedef typename STRING<T, CHAR_TRAITS<T>, gc_allocator<T> > string;
};
/**
* But, it's pretty easy to do with macros:
*/
#define GC_CONTAINER(container, type) container<T, gc_allocator<T> >
/*
// this gives an "unimplemented C++ feature" error using CWPro5.
// maybe someday.
template <template<class, class> typename Container, typename T>
struct gc_rebind {
typedef typename Container<T, gc_allocator<T> > container;
};
*/
}
#endif /* gc_container_h */

View File

@@ -1,185 +0,0 @@
/* -*- 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 "hash.h"
#include <new>
namespace JS = JavaScript;
//
// Hash Codes
//
// General-purpose null-terminated C string hash function
JS::HashNumber JS::hashString(const char *s)
{
HashNumber h = 0;
uchar ch;
while ((ch = (uchar)*s++) != 0)
h = (h >> 28) ^ (h << 4) ^ ch;
return h;
}
// General-purpose String hash function
JS::HashNumber JS::hashString(const String &s)
{
HashNumber h = 0;
String::const_iterator p = s.begin();
String::size_type n = s.size();
if (n < 16)
// Hash every character in a short string.
while (n--)
h = (h >> 28) ^ (h << 4) ^ *p++;
else
// Sample a la java.lang.String.hash().
for (String::size_type m = n / 8; n >= m; p += m, n -= m)
h = (h >> 28) ^ (h << 4) ^ *p;
return h;
}
//
// Hash Tables
//
const uint minLgNBuckets = 4;
JS::GenericHashTableIterator::GenericHashTableIterator(GenericHashTable &ht):
ht(ht), entry(0), nextBucket(ht.buckets)
{
DEBUG_ONLY(++ht.nReferences);
operator++();
}
JS::GenericHashTableIterator &JS::GenericHashTableIterator::operator++()
{
GenericHashEntry *e = entry;
if (e) {
backpointer = &e->next;
e = e->next;
}
if (!e) {
GenericHashEntry **const bucketsEnd = ht.bucketsEnd;
GenericHashEntry **bucket = nextBucket;
while (bucket != bucketsEnd) {
e = *bucket++;
if (e) {
backpointer = bucket-1;
break;
}
}
nextBucket = bucket;
}
entry = e;
return *this;
}
JS::GenericHashTable::GenericHashTable(uint32 nEntriesDefault):
nEntries(0)
{
DEBUG_ONLY(nReferences = 0);
uint lgNBuckets = ceilingLog2(nEntriesDefault);
if (lgNBuckets < minLgNBuckets)
lgNBuckets = minLgNBuckets;
defaultLgNBuckets = lgNBuckets;
recomputeMinMaxNEntries(lgNBuckets);
uint32 nBuckets = JS_BIT(lgNBuckets);
buckets = new GenericHashEntry*[nBuckets];
// No exceptions after this point unless buckets is deleted.
bucketsEnd = buckets + nBuckets;
zero(buckets, bucketsEnd);
}
// Initialize shift, minNEntries, and maxNEntries based on the lg2 of the
// number of buckets.
void JS::GenericHashTable::recomputeMinMaxNEntries(uint lgNBuckets)
{
uint32 nBuckets = JS_BIT(lgNBuckets);
shift = 32 - lgNBuckets;
maxNEntries = nBuckets; // Maximum ratio is 100%
// Minimum ratio is 37.5%
minNEntries = lgNBuckets <= defaultLgNBuckets ? 0 : 3*(nBuckets>>3);
}
// Rehash the table. This method cannot throw out-of-memory exceptions, so it is
// safe to call from a destructor.
void JS::GenericHashTable::rehash()
{
uint32 newLgNBuckets = ceilingLog2(nEntries);
if (newLgNBuckets < defaultLgNBuckets)
newLgNBuckets = defaultLgNBuckets;
uint32 newNBuckets = JS_BIT(newLgNBuckets);
try {
GenericHashEntry **newBuckets = new GenericHashEntry*[newNBuckets];
// No exceptions after this point.
GenericHashEntry **newBucketsEnd = newBuckets + newNBuckets;
zero(newBuckets, newBucketsEnd);
recomputeMinMaxNEntries(newLgNBuckets);
GenericHashEntry **be = bucketsEnd;
for (GenericHashEntry **b = buckets; b != be; b++) {
GenericHashEntry *e = *b;
while (e) {
GenericHashEntry *next = e->next;
// Place e in the new set of buckets.
GenericHashEntry **nb = newBuckets + (e->keyHash*goldenRatio >> shift);
e->next = *nb;
*nb = e;
e = next;
}
}
delete[] buckets;
buckets = newBuckets;
bucketsEnd = newBucketsEnd;
} catch (std::bad_alloc) {
// Out of memory. Ignore the error and just relax the resizing boundaries.
if (buckets + JS_BIT(newLgNBuckets) > bucketsEnd)
maxNEntries >>= 1;
else
minNEntries <<= 1;
}
}

View File

@@ -1,402 +0,0 @@
/* -*- 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 hash_h___
#define hash_h___
#include "systemtypes.h"
#include "utilities.h"
#include "strings.h"
#include "algo.h"
namespace JavaScript {
//
// Hash Codes
//
typedef uint32 HashNumber;
HashNumber hashString(const char *s);
HashNumber hashString(const String &s);
template<class Key>
struct Hash {
HashNumber operator()(Key key) const;
};
template<class Key>
inline HashNumber Hash<Key>::operator()(Key key) const
{
return hashString(key);
}
const HashNumber goldenRatio = 0x9E3779B9U;
//
// Private
//
// Base class for user-defined hash entries.
// private
class GenericHashEntry {
public:
GenericHashEntry *next; // Link to next entry in the same bucket
const HashNumber keyHash; // This entry's hash value
protected:
explicit GenericHashEntry(HashNumber keyHash): next(0), keyHash(keyHash) {}
friend class GenericHashTable;
};
// private
class GenericHashTableIterator;
class GenericHashTable {
protected:
GenericHashEntry **buckets; // Vector of hash buckets
GenericHashEntry **bucketsEnd; // Pointer past end of vector of hash buckets
uint defaultLgNBuckets; // lg2 of minimum number of buckets for which to size the table
uint32 nEntries; // Number of entries in table
uint32 minNEntries; // Minimum number of entries without rehashing
uint32 maxNEntries; // Maximum number of entries without rehashing
uint32 shift; // 32 - lg2(number of buckets)
#ifdef DEBUG
public:
uint32 nReferences; // Number of iterators and references
// currently pointing to this hash table
#endif
public:
explicit GenericHashTable(uint32 nEntriesDefault);
~GenericHashTable() {
#ifndef _WIN32
ASSERT(nReferences == 0);
#endif
delete[] buckets;
}
void recomputeMinMaxNEntries(uint lgNBuckets);
void rehash();
void maybeGrow() {if (nEntries > maxNEntries) rehash();}
void maybeShrink() {if (nEntries < minNEntries) rehash();}
friend class GenericHashTableIterator;
typedef GenericHashTableIterator Iterator;
};
// This ought to be GenericHashTable::Iterator, but this doesn't work
// due to a Microsoft VC6 bug.
class GenericHashTableIterator {
protected:
GenericHashTable &ht; // Hash table being iterated
GenericHashEntry *entry; // Current entry; nil if done
GenericHashEntry **backpointer; // Pointer to pointer to current entry
GenericHashEntry **nextBucket; // Next bucket; pointer past end of vector of hash buckets if done
public:
explicit GenericHashTableIterator(GenericHashTable &ht);
~GenericHashTableIterator() {ht.maybeShrink(); DEBUG_ONLY(--ht.nReferences);}
// Return true if there are entries left.
operator bool() const {return entry != 0;}
GenericHashTableIterator &operator++();
};
//
// Hash Tables
//
template<class Data, class Key, class H = Hash<Key> >
class HashTable: private GenericHashTable {
H hasher; // Hash function
struct Entry: public GenericHashEntry {
Data data;
Entry(HashNumber keyHash, Key key): GenericHashEntry(keyHash), data(key) {}
template<class Value>
Entry(HashNumber keyHash, Key key, Value value): GenericHashEntry(keyHash), data(key, value) {}
};
public:
class Reference {
#ifdef _WIN32
// Microsoft VC6 bug: friend declarations to inner classes don't work
public:
#endif
Entry *entry; // Current entry; nil if done
GenericHashEntry **backpointer; // Pointer to pointer to current entry
const HashNumber keyHash; // This entry's key's hash value
#ifdef DEBUG
GenericHashTable *ht; // Hash table to which this Reference points
#endif
public:
#ifndef _WIN32
Reference(HashTable &ht, Key key); // Search for an entry with the given key.
#else
// Microsoft VC6 bug: VC6 doesn't allow this to be defined outside the class
Reference(HashTable &ht, Key key): keyHash(ht.hasher(key)) {
#ifdef DEBUG
Reference::ht = &ht;
++ht.nReferences;
#endif
HashNumber kh = keyHash;
HashNumber h = kh*goldenRatio >> ht.shift;
GenericHashEntry **bp = ht.buckets + h;
Entry *e;
while ((e = static_cast<Entry *>(*bp)) != 0 && !(e->keyHash == kh && e->data == key))
bp = &e->next;
entry = e;
backpointer = bp;
}
#endif
private:
Reference(const Reference&); // No copy constructor
void operator=(const Reference&); // No assignment operator
public:
#if defined(DEBUG) && !defined(_WIN32)
~Reference() {if (ht) --ht->nReferences;}
#endif
// Return true if an entry was found.
operator bool() const {return entry != 0;}
// Return the data of the entry that was found.
Data &operator*() const {ASSERT(entry); return entry->data;}
friend class HashTable;
};
class Iterator: public GenericHashTableIterator {
public:
explicit Iterator(HashTable &ht): GenericHashTableIterator(ht) {}
private:
Iterator(const Iterator&); // No copy constructor
void operator=(const Iterator&); // No assignment operator
public:
// Go to next entry.
Iterator &operator++() {return *static_cast<Iterator*>(&GenericHashTableIterator::operator++());}
// Return current entry's data.
Data &operator*() const {ASSERT(entry); return static_cast<Entry *>(entry)->data;}
void erase();
};
HashTable(uint32 nEntriesDefault = 0, const H &hasher = H()): GenericHashTable(nEntriesDefault), hasher(hasher) {}
~HashTable();
template<class Value> Data &insert(Reference &r, Key key, Value value);
Data &insert(Reference &r, Key key);
Data &insert(Key key);
void erase(Reference &r);
void erase(Key key);
Data *operator[](Key key);
friend class Reference;
friend class Iterator;
#ifndef _WIN32
template<class Value> Data &insert(Key key, Value value);
#else
// Microsoft VC6 bug: VC6 doesn't allow this to be defined outside the
// class
template<class Value> Data &insert(Key key, Value value) {
Reference r(*this, key);
if (r)
return *r = value;
else
return insert(r, key, value);
}
#endif
};
//
// Implementation
//
template<class Data, class Key, class H>
HashTable<Data, Key, H>::~HashTable()
{
GenericHashEntry **be = bucketsEnd;
for (GenericHashEntry **b = buckets; b != be; b++) {
Entry *e = static_cast<Entry *>(*b);
while (e) {
Entry *next = static_cast<Entry *>(e->next);
delete e;
e = next;
}
}
}
#ifndef _WIN32
template<class Data, class Key, class H>
HashTable<Data, Key, H>::Reference::Reference(HashTable &ht, Key key):
keyHash(ht.hasher(key))
{
#ifdef DEBUG
Reference::ht = &ht;
++ht.nReferences;
#endif
HashNumber kh = keyHash;
HashNumber h = kh*goldenRatio >> ht.shift;
GenericHashEntry **bp = ht.buckets + h;
Entry *e;
while ((e = static_cast<Entry *>(*bp)) != 0 &&
!(e->keyHash == kh && e->data == key))
bp = &e->next;
entry = e;
backpointer = bp;
}
// Insert the given key/value pair into the hash table. Reference must
// be the result of an unsuccessful search for that key in the table.
// The reference is not valid after this method is called.
// Return a reference to the new entry's value.
template<class Data, class Key, class H> template<class Value>
inline Data &HashTable<Data, Key, H>::insert(Reference &r, Key key, Value value)
{
ASSERT(r.ht == this && !r.entry);
Entry *e = new Entry(r.keyHash, key, value);
*r.backpointer = e;
++nEntries;
maybeGrow();
#ifdef DEBUG
--r.ht->nReferences;
r.ht = 0;
#endif
return e->data;
}
#endif
// Same as above but without a Value argument.
template<class Data, class Key, class H>
inline Data &HashTable<Data, Key, H>::insert(Reference &r, Key key)
{
ASSERT(r.ht == this && !r.entry);
Entry *e = new Entry(r.keyHash, key);
*r.backpointer = e;
++nEntries;
maybeGrow();
#ifdef DEBUG
--r.ht->nReferences;
r.ht = 0;
#endif
return e->data;
}
// Insert the given key/value pair into the hash table. If an entry with a
// matching key already exists, replace that entry's value.
// Return a reference to the new entry's value.
#ifndef _WIN32
// Microsoft VC6 bug: VC6 doesn't allow this to be defined outside the class
template<class Data, class Key, class H> template<class Value>
Data &HashTable<Data, Key, H>::insert(Key key, Value value)
{
Reference r(*this, key);
if (r)
return *r = value;
else
return insert(r, key, value);
}
#endif
// Same as above but without a Value argument.
template<class Data, class Key, class H>
Data &HashTable<Data, Key, H>::insert(Key key)
{
Reference r(*this, key);
if (r)
return *r;
else
return insert(r, key);
}
// Reference r must point to an existing entry. Delete that entry.
// The reference is not valid after this method is called.
template<class Data, class Key, class H>
inline void HashTable<Data, Key, H>::erase(Reference &r)
{
Entry *e = r.entry;
ASSERT(r.ht == this && e);
*r.backpointer = e->next;
--nEntries;
delete e;
#ifdef DEBUG
--r.ht->nReferences;
r.ht = 0;
#endif
maybeShrink();
}
// Remove the hash table entry, if any, matching the given key.
template<class Data, class Key, class H>
void HashTable<Data, Key, H>::erase(Key key)
{
Reference r(*this, key);
if (r)
erase(r);
}
// Return a pointer to the value of the hash table entry matching the given
// key. Return nil if no entry matches.
template<class Data, class Key, class H>
Data *HashTable<Data, Key, H>::operator[](Key key)
{
Reference r(*this, key);
if (r)
return &*r;
else
return 0;
}
}
#endif

View File

@@ -1,51 +0,0 @@
/* -*- 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 "exception.h"
namespace JavaScript {
extern const char* exception_types[];
extern const char* exception_msgs[];
void
JSException::toString8 (string8 &rval)
{
rval = string8(exception_types[mType]) + " Exception: " +
string8(exception_msgs[mID]);
if (mSource.size() != 0)
rval += " in " + mSource;
}
}

View File

@@ -1,115 +0,0 @@
/* -*- 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 "utilities.h"
namespace JavaScript {
enum ExceptionType {
etUnknown = 0,
etLexer,
etParser,
etRuntime,
etCount
};
enum ExceptionID {
eidExpectBool = 0,
eidExpectDouble,
eidExpectInt32,
eidExpectUInt32,
eidExpectRegister,
eidExpectArgList,
eidExpectColon,
eidExpectCloseParen,
eidExpectBinaryOp,
eidExpectString,
eidExpectLabel,
eidExpectComma,
eidExpectNewline,
eidExpectIdentifier,
eidDuplicateLabel,
eidUnknownICode,
eidUnknownBinaryOp,
eidUnterminatedString,
eidCount
};
class JSException {
public:
JSException (ExceptionID ID, string8_citer pos = 0,
string8 source = "", ExceptionType type = etUnknown)
: mID(ID), mType(type), mPos(pos), mSource(source) {}
ExceptionID mID;
ExceptionType mType;
string8_citer mPos;
string8 mSource;
public:
void toString8(string8 &rval);
/*
private:
JSException(const JSException&);
*/
};
class JSLexException : public JSException {
public:
JSLexException (ExceptionID ID, string8_citer pos = 0,
string8 source = "") :
JSException(ID, pos, source, etLexer) {}
/*
private:
JSLexException (const JSLexException&);
*/
};
class JSParseException : public JSException {
public:
JSParseException (ExceptionID ID, string8_citer pos = 0,
string8 source = "") :
JSException(ID, pos, source, etParser) {}
/*
private:
JSParseException (const JSParseException&);
*/
};
}
#endif /* exception_h___ */

View File

@@ -1,235 +0,0 @@
/* -*- 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 <stdio.h>
#include <string>
#include "utilities.h"
#include "icodegenerator.h"
#include "lexutils.h"
#include "icodeasm.h"
using namespace JavaScript;
void
testAlpha (const string8 &str, const string &expect)
{
string *result;
LexUtils::lexAlpha (str.begin(), str.end(), &result);
if (*result == expect)
fprintf (stderr, "PASS: ");
else
fprintf (stderr, "FAIL: ");
fprintf (stderr, "string '%s' alpha parsed as '%s'\n", str.c_str(),
result->c_str());
}
void
testBool (const string8 &str, bool expect)
{
bool b;
LexUtils::lexBool (str.begin(), str.end(), &b);
if (b == expect)
fprintf (stderr, "PASS: ");
else
fprintf (stderr, "FAIL: ");
fprintf (stderr, "string '%s' bool parsed as %i\n", str.c_str(), b);
}
void
testDouble (const string8 &str, double expect)
{
double result;
LexUtils::lexDouble (str.begin(), str.end(), &result);
if (result == expect)
fprintf (stderr, "PASS: ");
else
fprintf (stderr, "FAIL: ");
fprintf (stderr, "string '%s' double parsed as %f\n", str.c_str(),
result);
}
void
testString (const string8 &str, const string &expect)
{
string *result;
LexUtils::lexString8 (str.begin(), str.end(), &result);
if (*result == expect)
fprintf (stderr, "PASS: ");
else
fprintf (stderr, "FAIL: ");
fprintf (stderr, "string '%s' string parsed as '%s'\n", str.c_str(),
result->c_str());
}
void
testUInt32 (const string8 &str, uint32 expect)
{
uint32 result;
LexUtils::lexUInt32 (str.begin(), str.end(), &result);
if (result == expect)
fprintf (stderr, "PASS: ");
else
fprintf (stderr, "FAIL: ");
fprintf (stderr, "string '%s' uint32 parsed as %u\n", str.c_str(),
result);
}
void
testParse (JavaScript::ICodeASM::ICodeParser &icp,
JavaScript::Interpreter::Context cx,
const string &str)
{
using namespace JavaScript;
icp.parseSourceFromString (str);
ICG::ICodeModule icm = ICG::ICodeModule (icp.mInstructions,
new ICG::VariableList(),
new ICG::ParameterList(),
icp.mMaxRegister, 0,
&JSTypes::Object_Type);
stdOut << icm;
JSTypes::JSValues args;
cx.interpret (&icm, args);
}
static JSTypes::JSValue
print(Interpreter::Context *, const JSTypes::JSValues &argv)
{
size_t n = argv.size();
if (n > 1) { // the 'this' parameter is un-interesting
stdOut << argv[1];
for (size_t i = 2; i < n; ++i)
stdOut << ' ' << argv[i];
}
stdOut << "\n";
return JSTypes::kUndefinedValue;
}
int
main (int , char **)
{
World world;
JSTypes::JSScope global;
global.defineNativeFunction(world.identifiers["print"], print);
Interpreter::Context cx (world, &global);
ICodeASM::ICodeParser icp(&cx);
testAlpha ("False", "False");
testAlpha ("fe fi fo fum", "fe");
testAlpha (" bla", "");
testBool ("true", true);
testBool ("True", true);
testBool ("tRue", true);
testBool ("TRUE", true);
testBool ("True", true);
testBool ("false", false);
testBool ("False", false);
testBool ("fAlSe", false);
testBool ("FALSE", false);
testBool ("False", false);
testDouble ("123", 123);
testDouble ("12.3", 12.3);
testDouble ("-123", -123);
testDouble ("-12.3", -12.3);
testString ("\"fe fi fo fum\"", "fe fi fo fum");
testString ("'the tab is ->\\t<- here'", "the tab is ->\t<- here");
testString ("'the newline is ->\\n<- here'", "the newline is ->\n<- here");
testString ("'the cr is ->\\r<- here'", "the cr is ->\r<- here");
testString ("\"an \\\"escaped\\\" string\"", "an \"escaped\" string");
testUInt32 ("123", 123);
testUInt32 ("12.3", 12);
testUInt32 ("-123", 0);
testUInt32 ("-12.3", 0);
/* XXX what to do with the overflow? */
//testUInt32 (icp, "12123687213612873621873438754387934657834", 0);
string src;
src =
"some_label:\n"
"LOAD_STRING R1, 'hello' ;test comment\n"
"CAST R2, R1, 'any';another test comment\n"
"SAVE_NAME 'x', R2\n"
"LOAD_NAME R1, 'x'\n"
"LOAD_NAME R2, 'print'\n"
"CALL R3, R2, <NaR>, (R1)\n"
"RETURN R3";
testParse (icp, cx, src);
/* {x= 1; for (i = 10; i > 0; --i) x = x * i; print ("x is " + x);} */
src =
"LOAD_IMMEDIATE R1, 1\n"
"CAST R2, R1, 'any'\n"
"SAVE_NAME 'x', R2\n"
"LOAD_IMMEDIATE R1, 10\n"
"CAST R2, R1, 'any'\n"
"SAVE_NAME 'i', R2\n"
"BRANCH Offset 16\n"
"LOAD_NAME R1, 'x'\n"
"LOAD_NAME R2, 'i'\n"
"GENERIC_BINARY_OP R3, Multiply, R1, R2\n"
"CAST R4, R3, 'any'\n"
"SAVE_NAME 'x', R4\n"
"LOAD_NAME R1, 'i'\n"
"LOAD_IMMEDIATE R2, 1\n"
"GENERIC_BINARY_OP R3, Subtract, R1, R2\n"
"SAVE_NAME 'i', R3\n"
"LOAD_NAME R4, 'i'\n"
"LOAD_IMMEDIATE R5, 0\n"
"GENERIC_BINARY_OP R6, Less, R5, R4\n"
"BRANCH_TRUE Offset 7, R6\n"
"LOAD_STRING R1, 'x is '\n"
"LOAD_NAME R2, 'x'\n"
"GENERIC_BINARY_OP R3, Add, R1, R2\n"
"LOAD_NAME R4, 'print'\n"
"CALL R5, R4, <NaR>, (R3)\n"
"RETURN <NaR>\n";
testParse (icp, cx, src);
return 0;
}

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -1,549 +0,0 @@
/* -*- 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 <stdio.h>
#include "icodeasm.h"
#include "icodemap.h"
#include "utilities.h"
#include "lexutils.h"
#include "exception.h"
namespace JavaScript {
namespace ICodeASM {
using namespace LexUtils;
static char *keyword_offset = "offset";
static char *keyword_exprNodeKinds[] = {"add", "subtract", "multiply", "divide",
"remainder", "leftshift", "rightshift",
"logicalrightshift", "bitwiseor",
"bitwisexor", "bitwiseand", "less",
"lessorequal", "equal", "identical", 0};
static ExprNode::Kind exprNodeOps[] =
{ ExprNode::add, ExprNode::subtract, ExprNode::multiply, ExprNode::divide,
ExprNode::modulo, ExprNode::leftShift, ExprNode::rightShift,
ExprNode::logicalRightShift, ExprNode::bitwiseOr,
ExprNode::bitwiseXor, ExprNode::bitwiseAnd, ExprNode::lessThan,
ExprNode::lessThanOrEqual, ExprNode::equal, ExprNode::identical };
void
ICodeParser::parseSourceFromString (const string8 &source)
{
uint statementNo = 0;
string8_citer begin = source.begin();
string8_citer end = source.end();
mInstructions = new VM::InstructionStream();
mMaxRegister = 0;
mInstructionCount = 0;
mLabels.clear();
mNamedLabels.clear();
while (begin < end)
{
try
{
++statementNo;
begin = parseNextStatement (begin, end);
}
catch (JSException &e)
{
string8 etext;
e.toString8(etext);
fprintf (stderr, "%s at statement %u\n",
etext.c_str(), statementNo);
return;
}
}
if (begin > end)
NOT_REACHED ("Overran source buffer!");
}
/**********************************************************************
* operand parse functions (see comment in the .h file) ...
*/
string8_citer
ICodeParser::parseArgumentListOperand (string8_citer begin,
string8_citer end,
VM::ArgumentList **rval)
{
/* parse argument list on the format "(['argname': ]register[, ...])" */
TokenLocation tl = seekTokenStart (begin, end);
VM::ArgumentList *al = new VM::ArgumentList();
if (tl.estimate != teOpenParen)
throw JSParseException (eidExpectArgList);
tl = seekTokenStart (tl.begin + 1, end);
StringFormatter s_fmt;
while (tl.estimate == teString || tl.estimate == teAlpha) {
string *argName = 0;
if (tl.estimate == teString) {
/* look for the argname in quotes */
begin = lexString8 (tl.begin, end, &argName);
/* look for the : */
tl = seekTokenStart (begin, end);
if (tl.estimate != teColon)
throw JSParseException (eidExpectColon);
/* and now the register */
tl = seekTokenStart (tl.begin + 1, end);
}
if (tl.estimate != teAlpha)
throw JSParseException (eidExpectRegister);
JSTypes::Register r;
begin = lexRegister (tl.begin, end, &r);
if (r != VM::NotARegister && r > mMaxRegister)
mMaxRegister = r;
/* pass 0 (null) as the "type" because it is
* not actually used by the interpreter, only in (the current)
* codegen (acording to rogerl.)
*/
VM::TypedRegister tr = VM::TypedRegister(r, 0);
StringAtom *sap = 0;
if (argName) {
sap = &(mCx->getWorld().identifiers[argName->c_str()]);
delete argName;
}
else {
/* if an argument name was not specified, use the position
* to build a default name.
*/
s_fmt << (uint32)al->size();
sap = &(mCx->getWorld().identifiers[s_fmt.getString()]);
s_fmt.clear();
}
VM::Argument arg = VM::Argument (tr, sap);
al->push_back(arg);
tl = seekTokenStart (begin, end);
/* if the next token is a comma,
* seek to the next one and go again */
if (tl.estimate == teComma) {
tl = seekTokenStart (tl.begin + 1, end);
}
}
if (tl.estimate != teCloseParen)
throw JSParseException (eidExpectCloseParen);
*rval = al;
return tl.begin + 1;
}
string8_citer
ICodeParser::parseExprNodeKindOperand (string8_citer begin, string8_citer end,
ExprNode::Kind *rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teAlpha)
throw JSParseException (eidExpectBinaryOp);
string8 *str;
end = lexAlpha (tl.begin, end, &str);
for (int i = 0; keyword_exprNodeKinds[i] != 0; ++i)
if (cmp_nocase (*str, keyword_exprNodeKinds[i], keyword_exprNodeKinds[i] +
strlen (keyword_exprNodeKinds[i])) == 0) {
*rval = exprNodeOps[i];
delete str;
return end;
}
delete str;
throw JSParseException (eidUnknownBinaryOp);
}
string8_citer
ICodeParser::parseBoolOperand (string8_citer begin, string8_citer end,
bool *rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teAlpha)
throw JSParseException (eidExpectBool);
return lexBool (tl.begin, end, rval);
}
string8_citer
ICodeParser::parseDoubleOperand (string8_citer begin, string8_citer end,
double *rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if ((tl.estimate != teNumeric) && (tl.estimate != teMinus) &&
(tl.estimate != tePlus))
throw JSParseException (eidExpectDouble);
return lexDouble (tl.begin, end, rval);
}
string8_citer
ICodeParser::parseICodeModuleOperand (string8_citer begin,
string8_citer end,
VM::ICodeModule **rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teString)
throw JSParseException (eidExpectString);
string8 *str;
end = lexString8 (tl.begin, end, &str);
StringAtom &typename_atom = mCx->getWorld().identifiers[str->c_str()];
delete str;
JSTypes::JSValue jsv =
mCx->getGlobalObject()->getVariable(typename_atom);
if (!jsv.isFunction()) {
ASSERT(false);
}
*rval = jsv.function->getICode();
return end;
// NOT_REACHED ("ICode modules are hard, lets go shopping.");
// return end;
}
string8_citer
ICodeParser::parseJSClassOperand (string8_citer begin,
string8_citer end, JSTypes::JSType **rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teString)
throw JSParseException (eidExpectString);
string8 *str;
end = lexString8 (tl.begin, end, &str);
StringAtom &typename_atom = mCx->getWorld().identifiers[str->c_str()];
delete str;
JSTypes::JSValue jsv =
mCx->getGlobalObject()->getVariable(typename_atom);
if (jsv.isType())
*rval = jsv.type;
else
*rval = &(JSTypes::Object_Type);
return end;
// NOT_REACHED ("JSClasses are hard, lets go shopping.");
// return end;
}
string8_citer
ICodeParser::parseJSStringOperand (string8_citer begin, string8_citer end,
JSTypes::JSString **rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teString)
throw JSParseException (eidExpectString);
string8 *str;
end = lexString8 (tl.begin, end, &str);
*rval = new JSTypes::JSString (str->c_str());
delete str;
return end;
}
string8_citer
ICodeParser::parseJSFunctionOperand (string8_citer /*begin*/,
string8_citer end,
string ** /*rval*/)
{
NOT_REACHED ("JSFunctions are hard, lets go shopping.");
return end;
}
string8_citer
ICodeParser::parseJSTypeOperand (string8_citer begin, string8_citer end,
JSTypes::JSType **rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teString)
throw JSParseException (eidExpectString);
string8 *str;
end = lexString8 (tl.begin, end, &str);
StringAtom &typename_atom = mCx->getWorld().identifiers[str->c_str()];
delete str;
JSTypes::JSValue jsv =
mCx->getGlobalObject()->getVariable(typename_atom);
if (jsv.isType())
*rval = jsv.type;
else
*rval = &(JSTypes::Object_Type);
return end;
}
string8_citer
ICodeParser::parseLabelOperand (string8_citer begin, string8_citer end,
VM::Label **rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teAlpha)
throw JSParseException (eidExpectLabel);
string8 *str;
begin = lexAlpha (tl.begin, end, &str);
if (cmp_nocase(*str, keyword_offset, keyword_offset +
strlen(keyword_offset)) == 0) {
delete str;
/* got the "Offset" keyword, treat next thing as a jump offset
* expressed as "Offset +/-N" */
tl = seekTokenStart (begin, end);
if (tl.estimate != teNumeric)
throw JSParseException (eidExpectUInt32);
uint32 ofs;
begin = lexUInt32 (tl.begin, end, &ofs);
VM::Label *new_label = new VM::Label(mInstructions);
new_label->mOffset = ofs;
mLabels.push_back (new_label);
*rval = new_label;
} else {
/* label expressed as "label_name", look for it in the
* namedlabels map */
LabelMap::const_iterator l = mNamedLabels.find(str->c_str());
if (l != mNamedLabels.end()) {
/* found the label, use it */
*rval = (*l).second;
} else {
/* havn't seen the label definition yet, put a placeholder
* in the namedlabels map */
VM::Label *new_label = new VM::Label(mInstructions);
new_label->mOffset = VM::NotALabel;
*rval = new_label;
mNamedLabels[str->c_str()] = new_label;
mLabels.push_back (new_label);
}
delete str;
}
return begin;
}
string8_citer
ICodeParser::parseUInt32Operand (string8_citer begin,
string8_citer end, uint32 *rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teNumeric)
throw JSParseException (eidExpectUInt32);
return lexUInt32 (tl.begin, end, rval);
}
string8_citer
ICodeParser::parseRegisterOperand (string8_citer begin, string8_citer end,
JSTypes::Register *rval)
{
TokenLocation tl = seekTokenStart (begin, end);
end = lexRegister (tl.begin, end, rval);
if (*rval != VM::NotARegister && *rval > mMaxRegister)
mMaxRegister = *rval;
return end;
}
string8_citer
ICodeParser::parseStringAtomOperand (string8_citer begin, string8_citer end,
StringAtom **rval)
{
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate != teString)
throw JSParseException (eidExpectString);
string8 *str;
end = lexString8 (tl.begin, end, &str);
*rval = &(mCx->getWorld().identifiers[str->c_str()]);
delete str;
return end;
}
/* "High Level" parse functions ... */
string8_citer
ICodeParser::parseInstruction (uint icodeID, string8_citer begin,
string8_citer end)
{
string8_citer curpos = begin;
StatementNode node;
node.icodeID = icodeID;
# define CASE_TYPE(T, C, CTYPE) \
case ot##T: \
{ \
C rval; \
node.operand[i].type = ot##T; \
curpos = parse##T##Operand (curpos, end, &rval); \
node.operand[i].data = CTYPE<int64>(rval); \
break; \
}
for (uint i = 0; i < 4; ++i)
{
switch (icodemap[icodeID].otype[i])
{
CASE_TYPE(ArgumentList, VM::ArgumentList *, reinterpret_cast);
CASE_TYPE(ExprNodeKind, ExprNode::Kind, static_cast);
CASE_TYPE(Bool, bool, static_cast);
CASE_TYPE(Double, double, static_cast);
CASE_TYPE(ICodeModule, VM::ICodeModule *, reinterpret_cast);
CASE_TYPE(JSClass, JSTypes::JSType *, reinterpret_cast);
CASE_TYPE(JSString, JSTypes::JSString *, reinterpret_cast);
CASE_TYPE(JSFunction, string *, reinterpret_cast);
CASE_TYPE(JSType, JSTypes::JSType *, reinterpret_cast);
CASE_TYPE(Label, VM::Label *, reinterpret_cast);
CASE_TYPE(UInt32, uint32, static_cast);
CASE_TYPE(Register, JSTypes::Register, static_cast);
CASE_TYPE(StringAtom, StringAtom *, reinterpret_cast);
default:
node.operand[i].type = otNone;
break;
}
if (i != 3 && icodemap[icodeID].otype[i + 1] != otNone) {
/* if the instruction has more arguments, eat a comma and
* locate the next token */
TokenLocation tl = seekTokenStart (curpos, end);
if (tl.estimate != teComma)
throw JSParseException (eidExpectComma);
tl = seekTokenStart (tl.begin + 1, end);
curpos = tl.begin;
}
}
# undef CASE_TYPE
mInstructions->push_back (InstructionFromNode(&node));
++mInstructionCount;
TokenLocation tl = seekTokenStart (curpos, end);
if (tl.estimate != teNewline && tl.estimate != teEOF)
throw JSParseException (eidExpectNewline);
if (tl.estimate == teEOF)
return tl.begin;
else
return tl.begin + 1;
}
string8_citer
ICodeParser::parseNextStatement (string8_citer begin, string8_citer end)
{
bool isLabel = false;
string8_citer firstTokenEnd = end;
TokenLocation tl = seekTokenStart (begin, end);
if (tl.estimate == teNewline) {
/* empty statement, do nothing */
return tl.begin + 1;
}
if (tl.estimate != teAlpha)
throw JSParseException (eidExpectIdentifier);
for (string8_citer curpos = tl.begin; curpos < end; ++curpos) {
switch (*curpos)
{
case ':':
isLabel = true;
firstTokenEnd = ++curpos;
goto scan_done;
default:
if (!IS_ALPHA(*curpos)) {
firstTokenEnd = curpos;
goto scan_done;
}
}
}
scan_done:
if (isLabel) {
/* the thing we scanned was a label...
* ignore the trailing : */
string8 label_str(tl.begin, firstTokenEnd - 1);
/* check to see if it was already referenced... */
LabelMap::const_iterator l = mNamedLabels.find(label_str.c_str());
if (l == mNamedLabels.end()) {
/* if it wasn't already referenced, add it */
VM::Label *new_label = new VM::Label (mInstructions);
new_label->mOffset = mInstructionCount;
mNamedLabels[label_str.c_str()] = new_label;
mLabels.push_back(new_label);
} else {
/* if it was already referenced, check to see if the offset
* was already set */
if ((*l).second->mOffset == VM::NotALabel) {
/* offset not set yet, set it and move along */
(*l).second->mOffset = mInstructionCount;
} else {
/* offset was already set, this must be a dupe! */
throw JSParseException (eidDuplicateLabel);
}
}
} else {
/* the thing we scanned was an instruction, search the icode map
* for a matching instruction */
string8 icode_str(tl.begin, firstTokenEnd);
for (uint i = 0; i < icodemap_size; ++i)
if (cmp_nocase(icode_str, &icodemap[i].name[0],
&icodemap[i].name[0] +
strlen(icodemap[i].name)) == 0)
/* if match found, parse it's operands */
return parseInstruction (i, firstTokenEnd, end);
/* otherwise, choke on it */
throw JSParseException (eidUnknownICode);
}
return firstTokenEnd;
}
}
}

View File

@@ -1,160 +0,0 @@
/* -*- 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
// Microsoft Visual C++ 6.0 whines about name lengths over 255 getting truncated in the browser database
#pragma warning(disable : 4786)
#endif
#ifndef icodeasm_h___
#define icodeasm_h___
#include <string>
#include <iterator>
#include "vmtypes.h"
#include "jstypes.h"
#include "interpreter.h"
namespace JavaScript {
namespace ICodeASM {
enum OperandType {
otNone = 0,
otArgumentList,
otExprNodeKind,
otBool,
otDouble,
otICodeModule,
otJSClass,
otJSString,
otJSFunction,
otJSType,
otLabel,
otUInt32,
otRegister,
otStringAtom
};
struct AnyOperand {
OperandType type;
int64 data;
/*void *data;*/
};
struct StatementNode {
uint icodeID;
AnyOperand operand[4];
};
class ICodeParser
{
private:
ICodeParser(const ICodeParser&); /* No copy constructor */
Interpreter::Context *mCx;
uint32 mInstructionCount;
VM::LabelList mLabels; /* contains both named *and* unnamed labels */
typedef std::map<const char *, VM::Label*> LabelMap;
LabelMap mNamedLabels;
public:
uint32 mMaxRegister;
VM::InstructionStream *mInstructions;
public:
ICodeParser (Interpreter::Context *aCx) : mCx(aCx), mInstructions(0) {}
void parseSourceFromString (const string8 &source);
/* operand parse functions; These functions take care of finding
* the start of the token with |SeekTokenStart|, and checking the
* "estimation" (explicit checking takes care of |begin| == |end|,
* aka EOF, because EOF is a token estimate.) Once the start of the
* token is found, and it is of the expected type, the actual parsing is
* carried out by one of the general purpose parse functions.
*/
string8_citer
parseArgumentListOperand (string8_citer begin, string8_citer end,
VM::ArgumentList **rval);
string8_citer
parseExprNodeKindOperand (string8_citer begin, string8_citer end,
JavaScript::ExprNode::Kind *rval);
string8_citer
parseBoolOperand (string8_citer begin, string8_citer end,
bool *rval);
string8_citer
parseDoubleOperand (string8_citer begin, string8_citer end,
double *rval);
string8_citer
parseICodeModuleOperand (string8_citer begin, string8_citer end,
VM::ICodeModule **rval);
string8_citer
parseJSClassOperand (string8_citer begin, string8_citer end,
JSTypes::JSType **rval);
string8_citer
parseJSStringOperand (string8_citer begin, string8_citer end,
JSTypes::JSString **rval);
string8_citer
parseJSFunctionOperand (string8_citer begin, string8_citer end,
string8 **rval);
string8_citer
parseJSTypeOperand (string8_citer begin, string8_citer end,
JSTypes::JSType **rval);
string8_citer
parseLabelOperand (string8_citer begin, string8_citer end,
VM::Label **rval);
string8_citer
parseUInt32Operand (string8_citer begin, string8_citer end,
uint32 *rval);
string8_citer
parseRegisterOperand (string8_citer begin, string8_citer end,
JSTypes::Register *rval);
string8_citer
parseStringAtomOperand (string8_citer begin, string8_citer end,
StringAtom **rval);
/* "high level" parse functions */
string8_citer
parseInstruction (uint icodeID, string8_citer start,
string8_citer end);
string8_citer
parseNextStatement (string8_citer begin, string8_citer end);
};
}
}
#endif /* #ifndef icodeasm_h___ */

View File

@@ -1,905 +0,0 @@
/* -*- 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 <algorithm>
#include "numerics.h"
#include "world.h"
#include "vmtypes.h"
#include "jstypes.h"
#include "jsclasses.h"
#include "icodegenerator.h"
#include "interpreter.h"
#include "exception.h"
#include "icodeasm.h"
#include <stdexcept>
#include <stdio.h>
namespace JavaScript {
namespace ICG {
using namespace VM;
using namespace JSTypes;
using namespace JSClasses;
using namespace Interpreter;
using namespace ICodeASM;
inline char narrow(char16 ch) { return char(ch); }
uint32 ICodeModule::sMaxID = 0;
Formatter& operator<<(Formatter &f, ICodeGenerator &i)
{
return i.print(f);
}
Formatter& operator<<(Formatter &f, ICodeModule &i)
{
return i.print(f);
}
//
// ICodeGenerator
//
ICodeGenerator::ICodeGenerator(Context *cx,
ICodeGenerator *containingFunction,
JSClass *aClass,
ICodeGeneratorFlags flags,
JSType *resultType)
: mTopRegister(0),
mExceptionRegister(TypedRegister(NotARegister, &None_Type)),
variableList(new VariableList()),
parameterList(new ParameterList()),
mContext(cx),
mInstructionMap(new InstructionMap()),
mClass(aClass),
mFlags(flags),
pLabels(NULL),
mInitName(cx->getWorld().identifiers["__init__"]),
mContainingFunction(containingFunction),
mResultType(resultType)
{
iCode = new InstructionStream();
iCodeOwner = true;
}
/*
-Called to allocate parameter and variable registers, aka 'permanent' registers.
-mTopRegister is the current high-water mark.
-mPermanentRegister marks those registers given to variables/parameters.
-Theoretically, mPermanentRegister[n] can be become false when a scope ends and
the registers allocated to contained variables are then available for re-use.
-Mostly the need is to handle overlapping allocation of temps & permanents as the
variables' declarations are encountered. This wouldn't be necessary if a function
presented a list of all variables, or a pre-pass executed to discover same.
*/
TypedRegister ICodeGenerator::allocateRegister(JSType *type)
{
Register r = mTopRegister;
while (r < mPermanentRegister.size())
if (!mPermanentRegister[r])
break;
else
++r;
if (r == mPermanentRegister.size())
mPermanentRegister.resize(r + 1);
mPermanentRegister[r] = true;
TypedRegister result(r, type);
mTopRegister = ++r;
return result;
}
TypedRegister ICodeGenerator::allocateVariable(const StringAtom& name, const StringAtom& typeName)
{
return allocateVariable(name, mContext->findType(typeName));
}
TypedRegister ICodeGenerator::allocateParameter(const StringAtom& name, bool isOptional, const StringAtom& typeName)
{
return allocateParameter(name, isOptional, mContext->findType(typeName));
}
ICodeModule *ICodeGenerator::complete()
{
#ifdef DEBUG
for (LabelList::iterator i = labels.begin();
i != labels.end(); i++) {
ASSERT((*i)->mBase == iCode);
ASSERT((*i)->mOffset <= iCode->size());
}
#endif
if (iCode->size()) {
ICodeOp lastOp = (*iCode)[iCode->size() - 1]->op();
if ((lastOp != RETURN) && (lastOp != RETURN_VOID))
returnStmt();
}
else
returnStmt();
/*
XXX FIXME
I wanted to do the following rather than have to have the label set hanging around as well
as the ICodeModule. Branches have since changed, but the concept is still good and should
be re-introduced at some point.
for (InstructionIterator ii = iCode->begin();
ii != iCode->end(); ii++) {
if ((*ii)->op() == BRANCH) {
Instruction *t = *ii;
*ii = new ResolvedBranch(static_cast<Branch *>(*ii)->operand1->itsOffset);
delete t;
}
else
if ((*ii)->itsOp >= BRANCH_LT && (*ii)->itsOp <= BRANCH_GT) {
Instruction *t = *ii;
*ii = new ResolvedBranchCond((*ii)->itsOp,
static_cast<BranchCond *>(*ii)->itsOperand1->itsOffset,
static_cast<BranchCond *>(*ii)->itsOperand2);
delete t;
}
}
*/
ICodeModule* module = new ICodeModule(*this);
if (pLabels) {
uint32 i;
uint32 parameterInits = pLabels->size() - 1; // there's an extra label at the end for the actual entryPoint
module->mParameterInit = new uint32[parameterInits];
for (i = 0; i < parameterInits; i++) {
module->mParameterInit[i] = (*pLabels)[i]->mOffset;
}
module->mEntryPoint = (*pLabels)[i]->mOffset;
}
iCodeOwner = false; // give ownership to the module.
return module;
}
/********************************************************************/
TypedRegister ICodeGenerator::loadImmediate(double value)
{
TypedRegister dest(getTempRegister(), &Number_Type);
LoadImmediate *instr = new LoadImmediate(dest, value);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::loadString(const String &value)
{
TypedRegister dest(getTempRegister(), &String_Type);
LoadString *instr = new LoadString(dest, new JSString(value));
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::loadString(const StringAtom &value)
{
TypedRegister dest(getTempRegister(), &String_Type);
LoadString *instr = new LoadString(dest, new JSString(value));
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::loadBoolean(bool value)
{
TypedRegister dest(getTempRegister(), &Boolean_Type);
if (value)
iCode->push_back(new LoadTrue(dest));
else
iCode->push_back(new LoadFalse(dest));
return dest;
}
TypedRegister ICodeGenerator::loadNull()
{
TypedRegister dest(getTempRegister(), &Object_Type);
iCode->push_back(new LoadNull(dest));
return dest;
}
TypedRegister ICodeGenerator::loadType(JSType *type)
{
TypedRegister dest(getTempRegister(), type);
iCode->push_back(new LoadType(dest, type));
return dest;
}
TypedRegister ICodeGenerator::newObject(TypedRegister constructor)
{
TypedRegister dest(getTempRegister(), &Object_Type);
NewObject *instr = new NewObject(dest, constructor);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::newClass(JSClass *clazz)
{
TypedRegister dest(getTempRegister(), &Object_Type);
NewClass *instr = new NewClass(dest, clazz);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::genericNew(TypedRegister target, ArgumentList *args)
{
TypedRegister dest(getTempRegister(), &Object_Type);
NewGeneric *instr = new NewGeneric(dest, target, args);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::newFunction(ICodeModule *icm)
{
TypedRegister dest(getTempRegister(), &Function_Type);
NewFunction *instr = new NewFunction(dest, icm);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::newArray()
{
TypedRegister dest(getTempRegister(), &Array_Type);
NewArray *instr = new NewArray(dest);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::dotClass(TypedRegister base)
{
TypedRegister dest(getTempRegister(), &Type_Type);
Class *instr = new Class(dest, base);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::instanceOf(TypedRegister base, TypedRegister type)
{
TypedRegister dest(getTempRegister(), &Boolean_Type);
Instanceof *instr = new Instanceof(dest, base, type);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::is(TypedRegister base, TypedRegister type)
{
TypedRegister dest(getTempRegister(), &Boolean_Type);
Is *instr = new Is(dest, base, type);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::loadName(const StringAtom &name, JSType *t)
{
TypedRegister dest(getTempRegister(), t);
LoadName *instr = new LoadName(dest, &name);
iCode->push_back(instr);
return dest;
}
void ICodeGenerator::saveName(const StringAtom &name, TypedRegister value)
{
SaveName *instr = new SaveName(&name, value);
iCode->push_back(instr);
}
TypedRegister ICodeGenerator::nameXcr(const StringAtom &name, ICodeOp op)
{
TypedRegister dest(getTempRegister(), &Number_Type);
NameXcr *instr = new NameXcr(dest, &name, (op == ADD) ? 1.0 : -1.0);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::varXcr(TypedRegister var, ICodeOp op)
{
TypedRegister dest(getTempRegister(), &Number_Type);
VarXcr *instr = new VarXcr(dest, var, (op == ADD) ? 1.0 : -1.0);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::getField(TypedRegister base, TypedRegister field)
{
TypedRegister dest(getTempRegister(), &Object_Type);
GetField *instr = new GetField(dest, base, field);
iCode->push_back(instr);
return dest;
}
void ICodeGenerator::setField(TypedRegister base, TypedRegister field,
TypedRegister value)
{
SetField *instr = new SetField(base, field, value);
iCode->push_back(instr);
}
TypedRegister ICodeGenerator::deleteProperty(TypedRegister base, const StringAtom &name)
{
TypedRegister dest(getTempRegister(), &Object_Type);
DeleteProp *instr = new DeleteProp(dest, base, &name);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::getProperty(TypedRegister base, const StringAtom &name)
{
TypedRegister dest(getTempRegister(), &Object_Type);
GetProp *instr = new GetProp(dest, base, &name);
iCode->push_back(instr);
return dest;
}
void ICodeGenerator::setProperty(TypedRegister base, const StringAtom &name,
TypedRegister value)
{
SetProp *instr = new SetProp(base, &name, value);
iCode->push_back(instr);
}
TypedRegister ICodeGenerator::propertyXcr(TypedRegister base, const StringAtom &name, ICodeOp op)
{
TypedRegister dest(getTempRegister(), &Object_Type);
PropXcr *instr = new PropXcr(dest, base, &name, (op == ADD) ? 1.0 : -1.0);
iCode->push_back(instr);
return dest;
}
static const JSSlot& getStaticSlot(JSClass *&c, const String &name)
{
if (c->hasStatic(name))
return c->getStatic(name);
c = c->getSuperClass();
ASSERT(c);
return getStaticSlot(c, name);
}
TypedRegister ICodeGenerator::getStatic(JSClass *base, const String &name)
{
TypedRegister dest(getTempRegister(), &Object_Type);
const JSSlot& slot = getStaticSlot(base, name);
GetStatic *instr = new GetStatic(dest, base, slot.mIndex);
iCode->push_back(instr);
return dest;
}
void ICodeGenerator::setStatic(JSClass *base, const StringAtom &name,
TypedRegister value)
{
const JSSlot& slot = getStaticSlot(base, name);
SetStatic *instr = new SetStatic(base, slot.mIndex, value);
iCode->push_back(instr);
}
TypedRegister ICodeGenerator::staticXcr(JSClass *base, const StringAtom &name, ICodeOp /*op*/)
{
TypedRegister dest(getTempRegister(), &Object_Type);
const JSSlot& slot = getStaticSlot(base, name);
StaticXcr *instr = new StaticXcr(dest, base, slot.mIndex, 1.0);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::getSlot(TypedRegister base, uint32 slot)
{
TypedRegister dest(getTempRegister(), &Object_Type);
GetSlot *instr = new GetSlot(dest, base, slot);
iCode->push_back(instr);
return dest;
}
void ICodeGenerator::setSlot(TypedRegister base, uint32 slot,
TypedRegister value)
{
SetSlot *instr = new SetSlot(base, slot, value);
iCode->push_back(instr);
}
TypedRegister ICodeGenerator::slotXcr(TypedRegister base, uint32 slot, ICodeOp op)
{
TypedRegister dest(getTempRegister(), &Object_Type);
SlotXcr *instr = new SlotXcr(dest, base, slot, (op == ADD) ? 1.0 : -1.0);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::getElement(TypedRegister base, TypedRegister index)
{
TypedRegister dest(getTempRegister(), &Object_Type);
GetElement *instr = new GetElement(dest, base, index);
iCode->push_back(instr);
return dest;
}
void ICodeGenerator::setElement(TypedRegister base, TypedRegister index,
TypedRegister value)
{
SetElement *instr = new SetElement(base, index, value);
iCode->push_back(instr);
}
TypedRegister ICodeGenerator::elementXcr(TypedRegister base, TypedRegister index, ICodeOp op)
{
TypedRegister dest(getTempRegister(), &Number_Type);
ElemXcr *instr = new ElemXcr(dest, base, index, (op == ADD) ? 1.0 : -1.0);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::op(ICodeOp op, TypedRegister source)
{
TypedRegister dest(getTempRegister(), &Object_Type);
ASSERT(source.first != NotARegister);
Unary *instr = new Unary (op, dest, source);
iCode->push_back(instr);
return dest;
}
void ICodeGenerator::move(TypedRegister destination, TypedRegister source)
{
ASSERT(destination.first != NotARegister);
ASSERT(source.first != NotARegister);
Move *instr = new Move(destination, source);
iCode->push_back(instr);
}
TypedRegister ICodeGenerator::logicalNot(TypedRegister source)
{
TypedRegister dest(getTempRegister(), &Object_Type);
Not *instr = new Not(dest, source);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::test(TypedRegister source)
{
TypedRegister dest(getTempRegister(), &Object_Type);
Test *instr = new Test(dest, source);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::op(ICodeOp op, TypedRegister source1,
TypedRegister source2)
{
ASSERT(source1.first != NotARegister);
ASSERT(source2.first != NotARegister);
TypedRegister dest(getTempRegister(), &Object_Type);
Arithmetic *instr = new Arithmetic(op, dest, source1, source2);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::binaryOp(ICodeOp dblOp, JSTypes::Operator op, TypedRegister source1,
TypedRegister source2)
{
ASSERT(source1.first != NotARegister);
ASSERT(source2.first != NotARegister);
TypedRegister dest(getTempRegister(), &Object_Type);
if ((source1.second == &Number_Type) && (source2.second == &Number_Type)) {
Arithmetic *instr = new Arithmetic(dblOp, dest, source1, source2);
iCode->push_back(instr);
}
else {
GenericBinaryOP *instr = new GenericBinaryOP(dest, op, source1, source2);
iCode->push_back(instr);
}
return dest;
}
TypedRegister ICodeGenerator::unaryOp(JSTypes::Operator op, TypedRegister source)
{
TypedRegister dest(getTempRegister(), &Object_Type);
GenericUnaryOP *instr = new GenericUnaryOP(dest, op, source);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::xcrementOp(JSTypes::Operator op, TypedRegister source)
{
TypedRegister dest(getTempRegister(), &Object_Type);
GenericXcrementOP *instr = new GenericXcrementOP(dest, op, source);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::call(TypedRegister target, ArgumentList *args)
{
TypedRegister dest(getTempRegister(), &Object_Type);
DirectCall *instr = new DirectCall(dest, target, args);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::invokeCallOp(TypedRegister target, ArgumentList *args)
{
TypedRegister dest(getTempRegister(), &Object_Type);
InvokeCall *instr = new InvokeCall(dest, target, args);
iCode->push_back(instr);
return dest;
}
/*
TypedRegister ICodeGenerator::directCall(JSFunction *target, ArgumentList *args)
{
TypedRegister dest(getTempRegister(), &Object_Type);
DirectCall *instr = new DirectCall(dest, target, args);
iCode->push_back(instr);
return dest;
}
*/
TypedRegister ICodeGenerator::bindThis(TypedRegister thisArg, TypedRegister target)
{
TypedRegister dest(getTempRegister(), &Function_Type);
iCode->push_back(new BindThis(dest, thisArg, target));
return dest;
}
TypedRegister ICodeGenerator::getClosure(uint32 count)
{
TypedRegister dest(getTempRegister(), &Object_Type);
iCode->push_back(new GetClosure(dest, count));
return dest;
}
TypedRegister ICodeGenerator::newClosure(ICodeModule *icm)
{
TypedRegister dest(getTempRegister(), &Function_Type);
iCode->push_back(new NewClosure(dest, icm));
return dest;
}
TypedRegister ICodeGenerator::getMethod(TypedRegister thisArg, uint32 slotIndex)
{
TypedRegister dest(getTempRegister(), &Object_Type);
GetMethod *instr = new GetMethod(dest, thisArg, slotIndex);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::super()
{
TypedRegister dest(getTempRegister(), &Object_Type);
Super *instr = new Super(dest);
iCode->push_back(instr);
return dest;
}
TypedRegister ICodeGenerator::cast(TypedRegister arg, JSType *toType)
{
TypedRegister dest(getTempRegister(), toType);
Cast *instr = new Cast(dest, arg, loadType(toType));
iCode->push_back(instr);
return dest;
}
void ICodeGenerator::branch(Label *label)
{
Branch *instr = new Branch(label);
iCode->push_back(instr);
}
GenericBranch *ICodeGenerator::branchTrue(Label *label, TypedRegister condition)
{
GenericBranch *instr = new GenericBranch(BRANCH_TRUE, label, condition);
iCode->push_back(instr);
return instr;
}
GenericBranch *ICodeGenerator::branchFalse(Label *label, TypedRegister condition)
{
GenericBranch *instr = new GenericBranch(BRANCH_FALSE, label, condition);
iCode->push_back(instr);
return instr;
}
GenericBranch *ICodeGenerator::branchInitialized(Label *label, TypedRegister condition)
{
GenericBranch *instr = new GenericBranch(BRANCH_INITIALIZED, label, condition);
iCode->push_back(instr);
return instr;
}
void ICodeGenerator::returnStmt(TypedRegister r)
{
iCode->push_back(new Return(r));
}
void ICodeGenerator::returnStmt()
{
iCode->push_back(new ReturnVoid());
}
/********************************************************************/
Label *ICodeGenerator::getLabel()
{
labels.push_back(new Label(NULL));
return labels.back();
}
Label *ICodeGenerator::setLabel(Label *l)
{
l->mBase = iCode;
l->mOffset = iCode->size();
return l;
}
Formatter& ICodeGenerator::print(Formatter& f)
{
f << "ICG! " << (uint32)iCode->size() << "\n";
VM::operator<<(f, *iCode);
f << " Src : Instr" << "\n";
for (InstructionMap::iterator i = mInstructionMap->begin(); i != mInstructionMap->end(); i++)
{
printDec( f, (*i).first, 6);
f << " : ";
printDec( f, (*i).second, 6);
f << "\n";
// f << (*i)->first << " : " << (*i)->second << "\n";
}
return f;
}
Formatter& ICodeModule::print(Formatter& f)
{
f << "ICM[" << mID << "] from source at '" << mFileName << "' " <<
(uint32)its_iCode->size() << " bytecodes\n";
return VM::operator<<(f, *its_iCode);
}
/*************************************************************************/
Formatter& operator<<(Formatter &f, string &s)
{
f << s.c_str();
return f;
}
ICodeModule *ICodeGenerator::readFunction(XMLNode *element, JSClass *thisClass)
{
#ifdef TEST_ICASM
ICodeModule *result = NULL;
String resultTypeName;
element->getValue(widenCString("type"), resultTypeName);
ParameterList *theParameterList = new ParameterList();
theParameterList->add(mContext->getWorld().identifiers["this"], TypedRegister(0, thisClass), false);
uint32 pCount = 1;
StringFormatter s;
XMLNodeList &parameters = element->children();
for (XMLNodeList::const_iterator k = parameters.begin(); k != parameters.end(); k++) {
XMLNode *parameter = *k;
if (parameter->name().compare(widenCString("parameter")) == 0) {
String parameterName;
String parameterTypeName;
element->getValue(widenCString("name"), parameterName);
element->getValue(widenCString("type"), parameterTypeName);
JSType *parameterType = mContext->findType(mContext->getWorld().identifiers[parameterTypeName]);
theParameterList->add(mContext->getWorld().identifiers[parameterName], TypedRegister(pCount, parameterType), false);
s << pCount - 1;
theParameterList->add(mContext->getWorld().identifiers[s.getString()], TypedRegister(pCount, parameterType), false);
s.clear();
pCount++;
}
}
theParameterList->setPositionalCount(pCount);
JSType *resultType = mContext->findType(mContext->getWorld().identifiers[resultTypeName]);
String &body = element->body();
if (body.length()) {
std::string str(body.length(), char());
std::transform(body.begin(), body.end(), str.begin(), narrow);
ICodeParser icp(mContext);
stdOut << "Calling ICodeParser with :\n" << str << "\n";
icp.parseSourceFromString(str);
result = new ICodeModule(icp.mInstructions,
NULL, /* VariableList *variables */
theParameterList, /* ParameterList *parameters */
icp.mMaxRegister,
NULL, /* InstructionMap *instructionMap */
resultType,
NotABanana); /* exception register */
}
return result;
#else
return 0;
#endif
}
ICodeModule *ICodeGenerator::readICode(const char *fileName)
{
#ifdef TEST_ICASM
ICodeModule *result = NULL;
XMLParser xp(fileName);
XMLNode *top = xp.parseDocument();
stdOut << *top;
XMLNodeList &kids = top->children();
for (XMLNodeList::const_iterator i = kids.begin(); i != kids.end(); i++) {
XMLNode *node = *i;
if (node->name().compare(widenCString("class")) == 0) {
String className;
String superName;
JSClass* superclass = 0;
node->getValue(widenCString("name"), className);
if (node->getValue(widenCString("super"), superName)) {
const JSValue& superclassValue = mContext->getGlobalObject()->getVariable(superName);
superclass = static_cast<JSClass*>(superclassValue.object);
}
JSClass* thisClass = new JSClass(mContext->getGlobalObject(), className, superclass);
JSScope* thisScope = thisClass->getScope();
Context *classContext = new Context(mContext->getWorld(), thisScope);
ICodeGenerator scg(classContext, NULL, thisClass, kIsStaticMethod, &Void_Type);
ICodeGenerator ccg(classContext, NULL, thisClass, kNoFlags, &Void_Type);
ccg.allocateParameter(mContext->getWorld().identifiers["this"], false, thisClass);
thisClass->defineStatic(mInitName, &Function_Type);
mContext->getGlobalObject()->defineVariable(className, &Type_Type, JSValue(thisClass));
XMLNodeList &elements = node->children();
for (XMLNodeList::const_iterator j = elements.begin(); j != elements.end(); j++) {
XMLNode *element = *j;
bool isConstructor = (element->name().compare(widenCString("constructor")) == 0);
if (isConstructor || (element->name().compare(widenCString("method")) == 0)) {
String methodName;
node->getValue(widenCString("name"), methodName);
ICodeModule *icm = readFunction(element, thisClass);
if (icm) {
if (isConstructor) {
thisClass->defineConstructor(methodName);
scg.setStatic(thisClass, mContext->getWorld().identifiers[methodName], scg.newFunction(icm));
}
else
thisClass->defineMethod(methodName, new JSFunction(icm));
}
}
else {
if (element->name().compare(widenCString("field")) == 0) {
String fieldName;
String fieldType;
element->getValue(widenCString("name"), fieldName);
element->getValue(widenCString("type"), fieldType);
JSType *type = mContext->findType(mContext->getWorld().identifiers[fieldType]);
if (element->hasAttribute(widenCString("static")))
thisClass->defineStatic(fieldName, type);
else
thisClass->defineSlot(fieldName, type);
}
}
}
scg.setStatic(thisClass, mInitName, scg.newFunction(ccg.complete()));
thisClass->complete();
if (scg.getICode()->size()) {
ICodeModule* clinit = scg.complete();
classContext->interpret(clinit, JSValues());
delete clinit;
}
delete classContext;
}
else {
if (node->name().compare(widenCString("script")) == 0) {
String &body = node->body();
if (body.length()) {
std::string str(body.length(), char());
std::transform(body.begin(), body.end(), str.begin(), narrow);
ICodeParser icp(mContext);
stdOut << "(script) Calling ICodeParser with :\n" << str << "\n";
icp.parseSourceFromString(str);
result = new ICodeModule(icp.mInstructions,
NULL, /* VariableList *variables */
NULL, /* ParameterList *parameters */
icp.mMaxRegister,
NULL, /* InstructionMap *instructionMap */
&Void_Type,
NotABanana); /* exception register */
}
}
else {
if (node->name().compare(widenCString("function")) == 0) {
String functionName;
node->getValue(widenCString("name"), functionName);
ICodeModule *icm = readFunction(node, NULL);
mContext->getGlobalObject()->defineFunction(functionName, icm);
}
else {
if (node->name().compare(widenCString("instance")) == 0) {
// find the appropriate class and initialize the fields
}
else {
if (node->name().compare(widenCString("object")) == 0) {
// an object literal
}
}
}
}
}
}
return result;
#else
return 0;
#endif
}
} // namespace ICG
} // namespace JavaScript

View File

@@ -1,469 +0,0 @@
/* -*- 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 icodegenerator_h
#define icodegenerator_h
#include <vector>
#include <stack>
#include "utilities.h"
#include "parser.h"
#include "vmtypes.h"
#include "jsclasses.h"
#include "xmlparser.h"
namespace JavaScript {
namespace ICG {
using namespace VM;
using namespace JSTypes;
using namespace JSClasses;
// forward declarations of classes in this header
class ICodeGenerator;
class ICodeModule;
struct VariableList { // Maps from variable (parameter) name to a TypedRegister.
// But because we also want to map from a register number to
// it's type, we keep the TypedRegsters in a separate array and
// just store the index in the name map.
typedef std::map<String, uint32, std::less<String> > VariableMap;
typedef VariableMap::value_type MapValue;
VariableMap variableMap;
std::vector<TypedRegister> registerList;
TypedRegister findVariable(const StringAtom& name)
{
VariableMap::iterator i = variableMap.find(name);
return (i == variableMap.end())
? TypedRegister(NotARegister, &None_Type)
: registerList[i->second];
}
void add(const StringAtom& name, TypedRegister r)
{
variableMap.insert(MapValue(name, r.first));
registerList.resize(r.first + 1);
registerList[r.first] = r;
}
TypedRegister getRegister(uint32 i)
{
ASSERT(i < registerList.size());
return registerList[i];
}
};
struct ParameterList : public VariableList {
typedef enum {
NoRestParameter,
HasRestParameterBeforeBar,
HasRestParameterAfterBar,
HasUnnamedRestParameter
} RestParameterStatus;
std::vector<bool> mOptionalParameters; // whether or not a parameter has an optional value
// ordered by lexical ordering === register number.
RestParameterStatus mRestParameter;
uint32 mPositionalCount; // number of positional parameters
ParameterList() : mRestParameter(NoRestParameter), mPositionalCount(0) { }
void add(const StringAtom& name, TypedRegister r, bool isOptional)
{
VariableList::add(name, r);
mOptionalParameters.resize(r.first + 1);
mOptionalParameters[r.first] = isOptional;
}
uint32 size() { return registerList.size(); } // the variableMap may be larger since it contains aliases
bool isOptional(uint32 i) { ASSERT(i < mOptionalParameters.size()); return mOptionalParameters[i]; }
void setRestParameter(RestParameterStatus rs) { mRestParameter = rs; }
void setPositionalCount(uint32 x) { mPositionalCount = x; }
};
typedef enum { NoKind, Var, Property, Slot, Static, Constructor, Name, Method, ClosureVar, Field } LValueKind;
class Reference {
public:
Reference(const StringAtom &name) : mKind(NoKind), mName(name) { }
LValueKind mKind;
TypedRegister mBase;
const StringAtom &mName;
TypedRegister mField;
uint32 mSlotIndex;
JSClass *mClass;
JSType *mType;
TypedRegister getValue(ICodeGenerator *icg);
void setValue(ICodeGenerator *icg, TypedRegister value);
TypedRegister getCallTarget(ICodeGenerator *icg);
};
typedef std::vector<const StringAtom *> LabelSet;
class LabelEntry {
public:
LabelEntry(LabelSet *labelSet, Label *breakLabel)
: labelSet(labelSet), breakLabel(breakLabel), continueLabel(NULL) { }
LabelEntry(LabelSet *labelSet, Label *breakLabel, Label *continueLabel)
: labelSet(labelSet), breakLabel(breakLabel), continueLabel(continueLabel) { }
bool containsLabel(const StringAtom *label);
LabelSet *labelSet;
Label *breakLabel;
Label *continueLabel;
};
typedef std::vector<LabelEntry *> LabelStack;
typedef std::map<uint32, uint32, std::less<uint32> > InstructionMap;
/****************************************************************/
// An ICodeGenerator provides the interface between the parser and the
// interpreter. The parser constructs one of these for each
// function/script, adds statements and expressions to it and then
// converts it into an ICodeModule, ready for execution.
class ICodeGenerator {
public:
friend class ICodeModule;
typedef enum { kNoFlags = 0, kIsTopLevel = 0x01, kIsStaticMethod = 0x02, kIsWithinWith = 0x04 } ICodeGeneratorFlags;
private:
InstructionStream *iCode;
bool iCodeOwner;
LabelList labels;
Register mTopRegister; // highest (currently) allocated register
TypedRegister mExceptionRegister; // reserved to carry the exception object.
VariableList *variableList; // name|register pair for each variable
ParameterList *parameterList; // name|register pair for each parameter
// (with #0 reserved for 'this' regardless of scope)
Context *mContext; // the world and global object
LabelStack mLabelStack; // stack of LabelEntry objects, one per nested looping construct
// maps source position to instruction index
InstructionMap *mInstructionMap;
JSClass *mClass; // enclosing class when generating code for methods
ICodeGeneratorFlags mFlags; // assorted flags
LabelList *pLabels; // label for each parameter initialization entry point
const StringAtom &mInitName;
ICodeGenerator *mContainingFunction;// outer function for nested functions
JSType *mResultType;
std::vector<bool> mPermanentRegister;
Register getTempRegister()
{
while (mTopRegister < mPermanentRegister.size())
if (!mPermanentRegister[mTopRegister])
return mTopRegister++;
else
++mTopRegister;
mPermanentRegister.resize(mTopRegister + 1);
mPermanentRegister[mTopRegister] = false;
return mTopRegister++;
}
void resetTopRegister() { mTopRegister = 0; }
void resetStatement() { resetTopRegister(); }
TypedRegister allocateRegister(JSType *type);
void addParameterLabel(Label *label) { if (pLabels == NULL) pLabels = new LabelList(); pLabels->push_back(label); }
Label *setLabel(Label *label);
void jsr(Label *label) { iCode->push_back(new Jsr(label)); }
void rts() { iCode->push_back(new Rts()); }
void branch(Label *label);
GenericBranch *branchTrue(Label *label, TypedRegister condition);
GenericBranch *branchFalse(Label *label, TypedRegister condition);
GenericBranch *branchInitialized(Label *label, TypedRegister condition);
void beginTry(Label *catchLabel, Label *finallyLabel)
{ iCode->push_back(new Tryin(catchLabel, finallyLabel)); }
void endTry() { iCode->push_back(new Tryout()); }
void beginWith(TypedRegister obj) { iCode->push_back(new Within(obj)); }
void endWith() { iCode->push_back(new Without()); }
void startStatement(uint32 pos) { (*mInstructionMap)[iCode->size()] = pos; }
bool isTopLevel() { return (mFlags & kIsTopLevel) != 0; }
bool isWithinWith() { return (mFlags & kIsWithinWith) != 0; }
bool isStaticMethod() { return (mFlags & kIsStaticMethod) != 0; }
void setFlag(uint32 flag, bool v) { mFlags = (ICodeGeneratorFlags)((v) ? mFlags | flag : mFlags & ~flag); }
bool getVariableByName(const StringAtom &name, Reference &ref);
bool scanForVariable(const StringAtom &name, Reference &ref);
bool resolveIdentifier(const StringAtom &name, Reference &ref, bool lvalue);
ICodeModule *genFunction(FunctionDefinition &function, bool isStatic, bool isConstructor, JSClass *superClass);
Reference genReference(ExprNode *p);
Operator getOperator(uint32 parameterCount, String &name);
ICodeModule *readFunction(XMLNode *element, JSClass *thisClass);
public:
ICodeGenerator(Context *cx,
ICodeGenerator *containingFunction = NULL,
JSClass *aClass = NULL,
ICodeGeneratorFlags flags = kIsTopLevel,
JSType *resultType = &Object_Type);
~ICodeGenerator()
{
if (iCodeOwner) {
delete iCode;
delete mInstructionMap;
if (pLabels) delete pLabels;
}
}
ICodeModule *complete();
ICodeModule *readICode(const char *fileName);
TypedRegister genExpr(ExprNode *p,
bool needBoolValueInBranch = false,
Label *trueBranch = NULL,
Label *falseBranch = NULL);
TypedRegister genStmt(StmtNode *p, LabelSet *currentLabelSet = NULL);
void returnStmt(TypedRegister r);
void returnStmt();
void throwStmt(TypedRegister r) { iCode->push_back(new Throw(r)); }
void debuggerStmt() { iCode->push_back(new Debugger()); }
TypedRegister allocateVariable(const StringAtom& name)
{
return allocateVariable(name, &Object_Type);
}
TypedRegister allocateVariable(const StringAtom& name, const StringAtom& typeName);
TypedRegister allocateVariable(const StringAtom& name, JSType *type)
{
TypedRegister r = allocateRegister(type);
variableList->add(name, r);
return r;
}
TypedRegister allocateVariable(const StringAtom& name, TypedRegister r)
{
variableList->add(name, r);
return r;
}
TypedRegister allocateParameter(const StringAtom& name, bool isOptional)
{
return allocateParameter(name, isOptional, &Object_Type);
}
TypedRegister allocateParameter(const StringAtom& name, bool isOptional, const StringAtom& typeName);
TypedRegister allocateParameter(const StringAtom& name, bool isOptional, JSType *type)
{
TypedRegister r = allocateRegister(type);
parameterList->add(name, r, isOptional);
return r;
}
Formatter& print(Formatter& f);
TypedRegister op(ICodeOp op, TypedRegister source);
TypedRegister op(ICodeOp op, TypedRegister source1, TypedRegister source2);
TypedRegister binaryOp(ICodeOp dblOp, JSTypes::Operator op, TypedRegister source1, TypedRegister source2);
TypedRegister unaryOp(JSTypes::Operator op, TypedRegister source);
TypedRegister invokeCallOp(TypedRegister target, ArgumentList *args);
TypedRegister xcrementOp(JSTypes::Operator op, TypedRegister source);
TypedRegister call(TypedRegister target, ArgumentList *args);
// TypedRegister directCall(JSFunction *target, ArgumentList *args);
TypedRegister bindThis(TypedRegister thisArg, TypedRegister target);
TypedRegister getMethod(TypedRegister thisArg, uint32 slotIndex);
TypedRegister getClosure(uint32 count);
TypedRegister newClosure(ICodeModule *icm);
void move(TypedRegister destination, TypedRegister source);
TypedRegister logicalNot(TypedRegister source);
TypedRegister test(TypedRegister source);
TypedRegister loadBoolean(bool value);
TypedRegister loadImmediate(double value);
TypedRegister loadString(const String &value);
TypedRegister loadString(const StringAtom &name);
TypedRegister loadNull();
TypedRegister loadType(JSType *toType);
TypedRegister newObject(TypedRegister constructor);
TypedRegister newArray();
TypedRegister newFunction(ICodeModule *icm);
TypedRegister newClass(JSClass *clazz);
TypedRegister genericNew(TypedRegister target, ArgumentList *args);
TypedRegister cast(TypedRegister arg, JSType *toType);
TypedRegister dotClass(TypedRegister base);
TypedRegister instanceOf(TypedRegister base, TypedRegister type);
TypedRegister is(TypedRegister base, TypedRegister type);
TypedRegister super();
TypedRegister loadName(const StringAtom &name, JSType *t = &Object_Type);
void saveName(const StringAtom &name, TypedRegister value);
TypedRegister nameXcr(const StringAtom &name, ICodeOp op);
TypedRegister getField(TypedRegister base, TypedRegister field);
void setField(TypedRegister base, TypedRegister field, TypedRegister value);
TypedRegister deleteProperty(TypedRegister base, const StringAtom &name);
TypedRegister getProperty(TypedRegister base, const StringAtom &name);
void setProperty(TypedRegister base, const StringAtom &name, TypedRegister value);
TypedRegister propertyXcr(TypedRegister base, const StringAtom &name, ICodeOp op);
TypedRegister getStatic(JSClass *base, const String &name);
void setStatic(JSClass *base, const StringAtom &name, TypedRegister value);
TypedRegister staticXcr(JSClass *base, const StringAtom &name, ICodeOp op);
TypedRegister getElement(TypedRegister base, TypedRegister index);
void setElement(TypedRegister base, TypedRegister index, TypedRegister value);
TypedRegister elementXcr(TypedRegister base, TypedRegister index, ICodeOp op);
TypedRegister getSlot(TypedRegister base, uint32 slot);
void setSlot(TypedRegister base, uint32 slot, TypedRegister value);
TypedRegister slotXcr(TypedRegister base, uint32 slot, ICodeOp op);
TypedRegister varXcr(TypedRegister var, ICodeOp op);
InstructionStream *getICode() { return iCode; }
Label *getLabel();
};
class ICodeModule {
public:
ICodeModule(InstructionStream *iCode, VariableList *variables,
ParameterList *parameters,
uint32 maxRegister,
InstructionMap *instructionMap,
JSType *resultType, uint32 exceptionRegister) :
its_iCode(iCode), itsVariables(variables), itsParameters(parameters),
itsMaxRegister(maxRegister),
mID(++sMaxID), mInstructionMap(instructionMap),
mParameterInit(NULL),
mEntryPoint(0),
mResultType(resultType),
mExceptionRegister(exceptionRegister)
{
}
ICodeModule(ICodeGenerator &icg) :
its_iCode(icg.iCode), itsVariables(icg.variableList), itsParameters(icg.parameterList),
itsMaxRegister(icg.mPermanentRegister.size()),
mID(++sMaxID), mInstructionMap(icg.mInstructionMap),
mParameterInit(NULL),
mEntryPoint(0),
mResultType(icg.mResultType),
mExceptionRegister(icg.mExceptionRegister.first)
{
}
~ICodeModule()
{
delete its_iCode;
delete itsVariables;
delete mInstructionMap;
if (mParameterInit) delete mParameterInit;
}
Formatter& print(Formatter& f);
void setFileName (String aFileName) { mFileName = aFileName; }
String getFileName () { return mFileName; }
InstructionStream *its_iCode;
VariableList *itsVariables;
ParameterList *itsParameters;
uint32 itsMaxRegister;
uint32 mID;
InstructionMap *mInstructionMap;
String mFileName;
uint32 *mParameterInit;
uint32 mEntryPoint;
JSType *mResultType;
uint32 mExceptionRegister;
static uint32 sMaxID;
};
Formatter& operator<<(Formatter &f, ICodeGenerator &i);
Formatter& operator<<(Formatter &f, ICodeModule &i);
Formatter& operator<<(Formatter &f, std::string &s);
} /* namespace IGC */
} /* namespace JavaScript */
#endif /* icodegenerator_h */

View File

@@ -1,417 +0,0 @@
/* -*- 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 FILE IS AUTO GENERATED! DO NOT EDIT THIS FILE! *****
* make changes to js2/tools/genmap.pl and regenerate this file *
***** THIS FILE IS AUTO GENERATED! DO NOT EDIT THIS FILE! *****/
#ifndef __icodemap_h
#define __icodemap_h
#include "systemtypes.h"
#include "icodeasm.h"
namespace JavaScript {
namespace ICodeASM {
static uint icodemap_size = 85;
static struct {
char *name;
OperandType otype[4];
} icodemap [] = {
{"ADD", {otRegister, otRegister, otRegister}},
{"AND", {otRegister, otRegister, otRegister}},
{"BIND_THIS", {otRegister, otRegister, otRegister}},
{"BITNOT", {otRegister, otRegister}},
{"BRANCH", {otLabel}},
{"BRANCH_FALSE", {otLabel, otRegister}},
{"BRANCH_INITIALIZED", {otLabel, otRegister}},
{"BRANCH_TRUE", {otLabel, otRegister}},
{"CAST", {otRegister, otRegister, otRegister}},
{"CLASS", {otRegister, otRegister}},
{"COMPARE_EQ", {otRegister, otRegister, otRegister}},
{"COMPARE_GE", {otRegister, otRegister, otRegister}},
{"COMPARE_GT", {otRegister, otRegister, otRegister}},
{"COMPARE_IN", {otRegister, otRegister, otRegister}},
{"COMPARE_LE", {otRegister, otRegister, otRegister}},
{"COMPARE_LT", {otRegister, otRegister, otRegister}},
{"COMPARE_NE", {otRegister, otRegister, otRegister}},
{"DEBUGGER", {otNone}},
{"DELETE_PROP", {otRegister, otRegister, otStringAtom}},
{"DIRECT_CALL", {otRegister, otRegister, otArgumentList}},
{"DIVIDE", {otRegister, otRegister, otRegister}},
{"ELEM_XCR", {otRegister, otRegister, otRegister, otDouble}},
{"GENERIC_BINARY_OP", {otRegister, otJSTypesOperator, otRegister, otRegister}},
{"GENERIC_UNARY_OP", {otRegister, otJSTypesOperator, otRegister}},
{"GENERIC_XCREMENT_OP", {otRegister, otJSTypesOperator, otRegister}},
{"GET_CLOSURE", {otRegister, otUInt32}},
{"GET_ELEMENT", {otRegister, otRegister, otRegister}},
{"GET_FIELD", {otRegister, otRegister, otRegister}},
{"GET_METHOD", {otRegister, otRegister, otUInt32}},
{"GET_PROP", {otRegister, otRegister, otStringAtom}},
{"GET_SLOT", {otRegister, otRegister, otUInt32}},
{"GET_STATIC", {otRegister, otJSClass, otUInt32}},
{"INSTANCEOF", {otRegister, otRegister, otRegister}},
{"INVOKE_CALL", {otRegister, otRegister, otArgumentList}},
{"IS", {otRegister, otRegister, otRegister}},
{"JSR", {otLabel}},
{"LOAD_FALSE", {otRegister}},
{"LOAD_IMMEDIATE", {otRegister, otDouble}},
{"LOAD_NAME", {otRegister, otStringAtom}},
{"LOAD_NULL", {otRegister}},
{"LOAD_STRING", {otRegister, otJSString}},
{"LOAD_TRUE", {otRegister}},
{"LOAD_TYPE", {otRegister, otJSType}},
{"MOVE", {otRegister, otRegister}},
{"MULTIPLY", {otRegister, otRegister, otRegister}},
{"NAME_XCR", {otRegister, otStringAtom, otDouble}},
{"NEGATE_DOUBLE", {otRegister, otRegister}},
{"NEW_ARRAY", {otRegister}},
{"NEW_CLASS", {otRegister, otJSClass}},
{"NEW_CLOSURE", {otRegister, otICodeModule}},
{"NEW_FUNCTION", {otRegister, otICodeModule}},
{"NEW_GENERIC", {otRegister, otRegister, otArgumentList}},
{"NEW_OBJECT", {otRegister, otRegister}},
{"NOP", {otNone}},
{"NOT", {otRegister, otRegister}},
{"OR", {otRegister, otRegister, otRegister}},
{"POSATE_DOUBLE", {otRegister, otRegister}},
{"PROP_XCR", {otRegister, otRegister, otStringAtom, otDouble}},
{"REMAINDER", {otRegister, otRegister, otRegister}},
{"RETURN", {otRegister}},
{"RETURN_VOID", {otNone}},
{"RTS", {otNone}},
{"SAVE_NAME", {otStringAtom, otRegister}},
{"SET_ELEMENT", {otRegister, otRegister, otRegister}},
{"SET_FIELD", {otRegister, otRegister, otRegister}},
{"SET_PROP", {otRegister, otStringAtom, otRegister}},
{"SET_SLOT", {otRegister, otUInt32, otRegister}},
{"SET_STATIC", {otJSClass, otUInt32, otRegister}},
{"SHIFTLEFT", {otRegister, otRegister, otRegister}},
{"SHIFTRIGHT", {otRegister, otRegister, otRegister}},
{"SLOT_XCR", {otRegister, otRegister, otUInt32, otDouble}},
{"STATIC_XCR", {otRegister, otJSClass, otUInt32, otDouble}},
{"STRICT_EQ", {otRegister, otRegister, otRegister}},
{"STRICT_NE", {otRegister, otRegister, otRegister}},
{"SUBTRACT", {otRegister, otRegister, otRegister}},
{"SUPER", {otRegister}},
{"TEST", {otRegister, otRegister}},
{"THROW", {otRegister}},
{"TRYIN", {otLabel, otLabel}},
{"TRYOUT", {otNone}},
{"USHIFTRIGHT", {otRegister, otRegister, otRegister}},
{"VAR_XCR", {otRegister, otRegister, otDouble}},
{"WITHIN", {otRegister}},
{"WITHOUT", {otNone}},
{"XOR", {otRegister, otRegister, otRegister}},
};
VM::Instruction *InstructionFromNode (StatementNode *node)
{
using namespace VM;
using namespace JSTypes;
Instruction *i;
switch (node->icodeID)
{
case 0:
i = new Add (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 1:
i = new And (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 2:
i = new BindThis (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 3:
i = new Bitnot (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 4:
i = new Branch (reinterpret_cast<Label*>(node->operand[0].data));
break;
case 5:
i = new BranchFalse (reinterpret_cast<Label*>(node->operand[0].data), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 6:
i = new BranchInitialized (reinterpret_cast<Label*>(node->operand[0].data), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 7:
i = new BranchTrue (reinterpret_cast<Label*>(node->operand[0].data), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 8:
i = new Cast (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 9:
i = new Class (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 10:
i = new CompareEQ (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 11:
i = new CompareGE (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 12:
i = new CompareGT (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 13:
i = new CompareIN (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 14:
i = new CompareLE (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 15:
i = new CompareLT (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 16:
i = new CompareNE (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 17:
i = new Debugger ();
break;
case 18:
i = new DeleteProp (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), reinterpret_cast<const StringAtom*>(node->operand[2].data));
break;
case 19:
i = new DirectCall (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), reinterpret_cast<ArgumentList*>(node->operand[2].data));
break;
case 20:
i = new Divide (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 21:
i = new ElemXcr (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0), static_cast<double>(node->operand[3].data));
break;
case 22:
i = new GenericBinaryOP (TypedRegister(static_cast<Register>(node->operand[0].data), 0), static_cast<JSTypes::Operator>(node->operand[1].data), TypedRegister(static_cast<Register>(node->operand[2].data), 0), TypedRegister(static_cast<Register>(node->operand[3].data), 0));
break;
case 23:
i = new GenericUnaryOP (TypedRegister(static_cast<Register>(node->operand[0].data), 0), static_cast<JSTypes::Operator>(node->operand[1].data), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 24:
i = new GenericXcrementOP (TypedRegister(static_cast<Register>(node->operand[0].data), 0), static_cast<JSTypes::Operator>(node->operand[1].data), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 25:
i = new GetClosure (TypedRegister(static_cast<Register>(node->operand[0].data), 0), static_cast<uint32>(node->operand[1].data));
break;
case 26:
i = new GetElement (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 27:
i = new GetField (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 28:
i = new GetMethod (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), static_cast<uint32>(node->operand[2].data));
break;
case 29:
i = new GetProp (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), reinterpret_cast<const StringAtom*>(node->operand[2].data));
break;
case 30:
i = new GetSlot (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), static_cast<uint32>(node->operand[2].data));
break;
case 31:
i = new GetStatic (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<JSClass*>(node->operand[1].data), static_cast<uint32>(node->operand[2].data));
break;
case 32:
i = new Instanceof (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 33:
i = new InvokeCall (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), reinterpret_cast<ArgumentList*>(node->operand[2].data));
break;
case 34:
i = new Is (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 35:
i = new Jsr (reinterpret_cast<Label*>(node->operand[0].data));
break;
case 36:
i = new LoadFalse (TypedRegister(static_cast<Register>(node->operand[0].data), 0));
break;
case 37:
i = new LoadImmediate (TypedRegister(static_cast<Register>(node->operand[0].data), 0), static_cast<double>(node->operand[1].data));
break;
case 38:
i = new LoadName (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<const StringAtom*>(node->operand[1].data));
break;
case 39:
i = new LoadNull (TypedRegister(static_cast<Register>(node->operand[0].data), 0));
break;
case 40:
i = new LoadString (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<JSString*>(node->operand[1].data));
break;
case 41:
i = new LoadTrue (TypedRegister(static_cast<Register>(node->operand[0].data), 0));
break;
case 42:
i = new LoadType (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<JSType*>(node->operand[1].data));
break;
case 43:
i = new Move (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 44:
i = new Multiply (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 45:
i = new NameXcr (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<const StringAtom*>(node->operand[1].data), static_cast<double>(node->operand[2].data));
break;
case 46:
i = new NegateDouble (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 47:
i = new NewArray (TypedRegister(static_cast<Register>(node->operand[0].data), 0));
break;
case 48:
i = new NewClass (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<JSClass*>(node->operand[1].data));
break;
case 49:
i = new NewClosure (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<ICodeModule*>(node->operand[1].data));
break;
case 50:
i = new NewFunction (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<ICodeModule*>(node->operand[1].data));
break;
case 51:
i = new NewGeneric (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), reinterpret_cast<ArgumentList*>(node->operand[2].data));
break;
case 52:
i = new NewObject (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 53:
i = new Nop ();
break;
case 54:
i = new Not (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 55:
i = new Or (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 56:
i = new PosateDouble (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 57:
i = new PropXcr (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), reinterpret_cast<const StringAtom*>(node->operand[2].data), static_cast<double>(node->operand[3].data));
break;
case 58:
i = new Remainder (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 59:
i = new Return (TypedRegister(static_cast<Register>(node->operand[0].data), 0));
break;
case 60:
i = new ReturnVoid ();
break;
case 61:
i = new Rts ();
break;
case 62:
i = new SaveName (reinterpret_cast<const StringAtom*>(node->operand[0].data), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 63:
i = new SetElement (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 64:
i = new SetField (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 65:
i = new SetProp (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<const StringAtom*>(node->operand[1].data), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 66:
i = new SetSlot (TypedRegister(static_cast<Register>(node->operand[0].data), 0), static_cast<uint32>(node->operand[1].data), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 67:
i = new SetStatic (reinterpret_cast<JSClass*>(node->operand[0].data), static_cast<uint32>(node->operand[1].data), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 68:
i = new Shiftleft (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 69:
i = new Shiftright (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 70:
i = new SlotXcr (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), static_cast<uint32>(node->operand[2].data), static_cast<double>(node->operand[3].data));
break;
case 71:
i = new StaticXcr (TypedRegister(static_cast<Register>(node->operand[0].data), 0), reinterpret_cast<JSClass*>(node->operand[1].data), static_cast<uint32>(node->operand[2].data), static_cast<double>(node->operand[3].data));
break;
case 72:
i = new StrictEQ (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 73:
i = new StrictNE (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 74:
i = new Subtract (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 75:
i = new Super (TypedRegister(static_cast<Register>(node->operand[0].data), 0));
break;
case 76:
i = new Test (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0));
break;
case 77:
i = new Throw (TypedRegister(static_cast<Register>(node->operand[0].data), 0));
break;
case 78:
i = new Tryin (reinterpret_cast<Label*>(node->operand[0].data), reinterpret_cast<Label*>(node->operand[1].data));
break;
case 79:
i = new Tryout ();
break;
case 80:
i = new Ushiftright (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
case 81:
i = new VarXcr (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), static_cast<double>(node->operand[2].data));
break;
case 82:
i = new Within (TypedRegister(static_cast<Register>(node->operand[0].data), 0));
break;
case 83:
i = new Without ();
break;
case 84:
i = new Xor (TypedRegister(static_cast<Register>(node->operand[0].data), 0), TypedRegister(static_cast<Register>(node->operand[1].data), 0), TypedRegister(static_cast<Register>(node->operand[2].data), 0));
break;
default:
NOT_REACHED("Unknown icodeID");
}
return i;
}
}
}
#endif /* #ifdef __icodemap_h */

File diff suppressed because it is too large Load Diff

View File

@@ -1,203 +0,0 @@
// -*- 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) 2000 Netscape Communications Corporation. All
// Rights Reserved.
#ifndef interpreter_h
#define interpreter_h
#include "utilities.h"
#include "icodegenerator.h"
#include "jstypes.h"
#include "vmtypes.h"
#include "gc_allocator.h"
namespace JavaScript {
namespace Interpreter {
using namespace ICG;
using namespace JSTypes;
struct Activation;
struct Linkage;
class Context : public gc_base {
void initContext();
public:
explicit Context(World& world, JSScope* aGlobal)
: mWorld(world), mGlobal(aGlobal), mLinkage(0), mActivation(0), mCurrentClosure(0) { initContext(); }
Context(Context *cx) : mWorld(cx->getWorld()), mGlobal(cx->getGlobalObject()),
mLinkage(0), mActivation(0), mCurrentClosure(0)
{
initContext();
for (ListenerIterator i = cx->mListeners.begin(), e = cx->mListeners.end(); i != e; ++i)
addListener(*i);
}
World& getWorld() { return mWorld; }
JSScope* getGlobalObject() { return mGlobal; }
InstructionIterator getPC() { return mPC; }
JSValues& getRegisters();
ICodeModule* getICode();
enum Event {
EV_NONE = 0x0000,
EV_STEP = 0x0001,
EV_THROW = 0x0002,
EV_DEBUG = 0x0004,
EV_ALL = 0xffff
};
class Listener {
public:
virtual void listen(Context *context, Event event) = 0;
};
void addListener(Listener* listener);
void removeListener(Listener* listener);
class Frame {
public:
virtual Frame* getNext() = 0;
virtual void getState(InstructionIterator& pc, JSValues*& registers,
ICodeModule*& iCode) = 0;
};
Frame* getFrames();
JSValue interpret(ICodeModule* iCode, const JSValues& args);
bool invokeFunction(JSFunction *target, JSValues* &registers, TypedRegister resultReg, JSValue thisArg, ArgumentList *args);
ICodeModule* compileFunction(const String &source);
ICodeModule* genCode(StmtNode *p, const String &fileName);
JSValue readEvalFile(FILE* in, const String& fileName);
ICodeModule* loadClass(const char *fileName);
const JSValue findBinaryOverride(JSValue &operand1, JSValue &operand2, JSTypes::Operator op);
const JSValue findUnaryOverride(JSValue &operand1, JSTypes::Operator op);
JSType *findType(const StringAtom& typeName);
JSType *extractType(ExprNode *t);
JSType *getParameterType(FunctionDefinition &function, int index);
uint32 getParameterCount(FunctionDefinition &function);
private:
void broadcast(Event event);
void initOperatorsPackage();
bool hasNamedArguments(ArgumentList &args);
private:
World& mWorld;
JSScope* mGlobal;
Linkage* mLinkage;
typedef std::vector<Listener*, gc_allocator<Listener*> > ListenerList;
typedef ListenerList::iterator ListenerIterator;
ListenerList mListeners;
Activation* mActivation;
ICodeModule* mICode;
JSClosure* mCurrentClosure;
InstructionIterator mPC;
}; /* class Context */
/**
*
*/
struct Handler: public gc_base {
Handler(Label *catchLabel, Label *finallyLabel)
: catchTarget(catchLabel), finallyTarget(finallyLabel) {}
Label *catchTarget;
Label *finallyTarget;
};
typedef std::vector<Handler *> CatchStack;
/**
* Represents the current function's invocation state.
*/
struct Activation : public JSObject {
JSValues mRegisters;
CatchStack catchStack;
Activation(uint32 highRegister, const JSValues& args)
: mRegisters(highRegister + 1)
{
// copy arg list to initial registers.
JSValues::iterator dest = mRegisters.begin();
for (JSValues::const_iterator src = args.begin(),
end = args.end(); src != end; ++src, ++dest) {
*dest = *src;
}
}
Activation(uint32 highRegister, Activation* caller, const JSValue thisArg,
const ArgumentList* list)
: mRegisters(highRegister + 1)
{
// copy caller's parameter list to initial registers.
JSValues::iterator dest = mRegisters.begin();
*dest++ = thisArg;
if (list) {
const JSValues& params = caller->mRegisters;
for (ArgumentList::const_iterator src = list->begin(),
end = list->end(); src != end; ++src, ++dest) {
Register r = (*src).first.first;
if (r != NotARegister)
*dest = params[r];
else
*dest = JSValue(JSValue::uninitialized_tag);
}
}
}
// calling a binary operator, no 'this'
Activation(uint32 highRegister, const JSValue thisArg, const JSValue arg1, const JSValue arg2)
: mRegisters(highRegister + 1)
{
mRegisters[0] = thisArg;
mRegisters[1] = arg1;
mRegisters[2] = arg2;
}
// calling a getter function, no arguments
Activation(uint32 highRegister, const JSValue thisArg)
: mRegisters(highRegister + 1)
{
mRegisters[0] = thisArg;
}
// calling a setter function, 1 argument
Activation(uint32 highRegister, const JSValue thisArg, const JSValue arg)
: mRegisters(highRegister + 1)
{
mRegisters[0] = thisArg;
mRegisters[1] = arg;
}
}; /* struct Activation */
} /* namespace Interpreter */
} /* namespace JavaScript */
#endif /* interpreter_h */

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -1,550 +0,0 @@
/* -*- 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)
#pragma warning(disable: 4711)
#pragma warning(disable: 4710)
#endif
#include <algorithm>
#include "parser.h"
#include "numerics.h"
#include "js2runtime.h"
// this is the IdentifierList passed to the name lookup routines
#define CURRENT_ATTR (NULL)
#include "jsarray.h"
namespace JavaScript {
namespace JS2Runtime {
JSValue Array_Constructor(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
JSValue thatValue = thisValue;
if (thatValue.isNull())
thatValue = Array_Type->newInstance(cx);
ASSERT(thatValue.isObject());
JSObject *thisObj = thatValue.object;
ASSERT(dynamic_cast<JSArrayInstance *>(thisObj));
JSArrayInstance *arrInst = (JSArrayInstance *)thisObj;
if (argc > 0) {
if (argc == 1) {
arrInst->mLength = (uint32)(argv[0].toNumber(cx).f64);
}
else {
arrInst->mLength = argc;
for (uint32 i = 0; i < argc; i++) {
String *id = numberToString(i);
arrInst->defineVariable(cx, *id, (NamespaceList *)(NULL), Object_Type, argv[i]);
delete id;
}
}
}
return thatValue;
}
static JSValue Array_toString(Context *cx, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
ASSERT(dynamic_cast<JSArrayInstance *>(thisObj));
JSArrayInstance *arrInst = (JSArrayInstance *)thisObj;
ContextStackReplacement csr(cx);
if (arrInst->mLength == 0)
return JSValue(new String(widenCString("")));
else {
String *s = new String();
for (uint32 i = 0; i < arrInst->mLength; i++) {
String *id = numberToString(i);
arrInst->getProperty(cx, *id, NULL);
JSValue result = cx->popValue();
s->append(*result.toString(cx).string);
if (i < (arrInst->mLength - 1))
s->append(widenCString(","));
}
return JSValue(s);
}
}
static JSValue Array_toSource(Context *cx, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
ASSERT(dynamic_cast<JSArrayInstance *>(thisObj));
JSArrayInstance *arrInst = (JSArrayInstance *)thisObj;
ContextStackReplacement csr(cx);
if (arrInst->mLength == 0)
return JSValue(new String(widenCString("[]")));
else {
String *s = new String(widenCString("["));
for (uint32 i = 0; i < arrInst->mLength; i++) {
String *id = numberToString(i);
arrInst->getProperty(cx, *id, NULL);
JSValue result = cx->popValue();
if (!result.isUndefined())
s->append(*result.toString(cx).string);
if (i < (arrInst->mLength - 1))
s->append(widenCString(", "));
}
s->append(widenCString("]"));
return JSValue(s);
}
}
static JSValue Array_push(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
ASSERT(dynamic_cast<JSArrayInstance *>(thisObj));
JSArrayInstance *arrInst = (JSArrayInstance *)thisObj;
for (uint32 i = 0; i < argc; i++) {
String *id = numberToString(i + arrInst->mLength);
arrInst->defineVariable(cx, *id, (NamespaceList *)(NULL), Object_Type, argv[i]);
delete id;
}
arrInst->mLength += argc;
return JSValue((float64)arrInst->mLength);
}
static JSValue Array_pop(Context *cx, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
ASSERT(dynamic_cast<JSArrayInstance *>(thisObj));
JSArrayInstance *arrInst = (JSArrayInstance *)thisObj;
ContextStackReplacement csr(cx);
if (arrInst->mLength > 0) {
String *id = numberToString(arrInst->mLength - 1);
arrInst->getProperty(cx, *id, NULL);
JSValue result = cx->popValue();
arrInst->deleteProperty(*id, NULL);
--arrInst->mLength;
delete id;
return result;
}
else
return kUndefinedValue;
}
JSValue Array_concat(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
JSValue E = thisValue;
JSArrayInstance *A = (JSArrayInstance *)(Array_Type->newInstance(cx));
uint32 n = 0;
uint32 i = 0;
ContextStackReplacement csr(cx);
do {
if (E.getType() != Array_Type) {
String *id = numberToString(n++);
A->setProperty(cx, *id, CURRENT_ATTR, E);
}
else {
ASSERT(E.isObject() && dynamic_cast<JSArrayInstance *>(E.object));
JSArrayInstance *arrInst = (JSArrayInstance *)(E.object);
for (uint32 k = 0; k < arrInst->mLength; k++) {
String *id = numberToString(k);
arrInst->getProperty(cx, *id, NULL);
JSValue result = cx->popValue();
id = numberToString(n++);
A->setProperty(cx, *id, CURRENT_ATTR, result);
}
}
E = argv[i++];
} while (i <= argc);
return JSValue(A);
}
static JSValue Array_join(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ContextStackReplacement csr(cx);
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
thisObj->getProperty(cx, widenCString("length"), CURRENT_ATTR);
JSValue result = cx->popValue();
uint32 length = (uint32)(result.toUInt32(cx).f64);
const String *separator;
if (argc == 0)
separator = new String(',', 1);
else
separator = argv[0].toString(cx).string;
thisObj->getProperty(cx, *numberToString(0), CURRENT_ATTR);
result = cx->popValue();
String *S = new String();
for (uint32 k = 0; k < length; k++) {
thisObj->getProperty(cx, *numberToString(0), CURRENT_ATTR);
result = cx->popValue();
if (!result.isUndefined() && !result.isNull())
*S += *result.toString(cx).string;
if (k < (length - 1))
*S += *separator;
}
return JSValue(S);
}
static JSValue Array_reverse(Context *cx, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ContextStackReplacement csr(cx);
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
thisObj->getProperty(cx, widenCString("length"), CURRENT_ATTR);
JSValue result = cx->popValue();
uint32 length = (uint32)(result.toUInt32(cx).f64);
uint32 halfway = length / 2;
for (uint32 k = 0; k < halfway; k++) {
String *id1 = numberToString(k);
String *id2 = numberToString(length - k - 1);
PropertyIterator it;
if (thisObj->hasOwnProperty(*id1, CURRENT_ATTR, Read, &it)) {
if (thisObj->hasOwnProperty(*id2, CURRENT_ATTR, Read, &it)) {
thisObj->getProperty(cx, *id1, CURRENT_ATTR);
thisObj->getProperty(cx, *id2, CURRENT_ATTR);
thisObj->setProperty(cx, *id1, CURRENT_ATTR, cx->popValue());
thisObj->setProperty(cx, *id2, CURRENT_ATTR, cx->popValue());
}
else {
thisObj->getProperty(cx, *id1, CURRENT_ATTR);
thisObj->setProperty(cx, *id2, CURRENT_ATTR, cx->popValue());
thisObj->deleteProperty(*id1, CURRENT_ATTR);
}
}
else {
if (thisObj->hasOwnProperty(*id2, CURRENT_ATTR, Read, &it)) {
thisObj->getProperty(cx, *id2, CURRENT_ATTR);
thisObj->setProperty(cx, *id1, CURRENT_ATTR, cx->popValue());
thisObj->deleteProperty(*id2, CURRENT_ATTR);
}
else {
thisObj->deleteProperty(*id1, CURRENT_ATTR);
thisObj->deleteProperty(*id2, CURRENT_ATTR);
}
}
}
return thisValue;
}
static JSValue Array_shift(Context *cx, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ContextStackReplacement csr(cx);
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
thisObj->getProperty(cx, widenCString("length"), CURRENT_ATTR);
JSValue result = cx->popValue();
uint32 length = (uint32)(result.toUInt32(cx).f64);
if (length == 0) {
thisObj->setProperty(cx, widenCString("length"), CURRENT_ATTR, result);
return kUndefinedValue;
}
thisObj->getProperty(cx, *numberToString(0), CURRENT_ATTR);
result = cx->popValue();
for (uint32 k = 1; k < length; k++) {
String *id1 = numberToString(k);
String *id2 = numberToString(k - 1);
PropertyIterator it;
if (thisObj->hasOwnProperty(*id1, CURRENT_ATTR, Read, &it)) {
thisObj->getProperty(cx, *id1, CURRENT_ATTR);
thisObj->setProperty(cx, *id2, CURRENT_ATTR, cx->popValue());
}
else
thisObj->deleteProperty(*id2, CURRENT_ATTR);
}
thisObj->deleteProperty(*numberToString(length - 1), CURRENT_ATTR);
thisObj->setProperty(cx, widenCString("length"), CURRENT_ATTR, JSValue((float64)(length - 1)) );
return result;
}
static JSValue Array_slice(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ContextStackReplacement csr(cx);
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
JSArrayInstance *A = (JSArrayInstance *)Array_Type->newInstance(cx);
thisObj->getProperty(cx, widenCString("length"), CURRENT_ATTR);
JSValue result = cx->popValue();
uint32 length = (uint32)(result.toUInt32(cx).f64);
uint32 start, end;
if (argc < 1)
start = 0;
else {
int32 arg0 = (int32)(argv[0].toInt32(cx).f64);
if (arg0 < 0) {
arg0 += length;
if (arg0 < 0)
start = 0;
else
start = toUInt32(arg0);
}
else {
if (toUInt32(arg0) >= length) // cast ok since > 0
start = length;
else
start = toUInt32(arg0);
}
}
if (argc < 2)
end = length;
else {
int32 arg1 = (int32)(argv[1].toInt32(cx).f64);
if (arg1 < 0) {
arg1 += length;
if (arg1 < 0)
end = 0;
else
end = toUInt32(arg1);
}
else {
if (toUInt32(arg1) >= length)
end = length;
else
end = toUInt32(arg1);
}
}
uint32 n = 0;
while (start < end) {
String *id1 = numberToString(start);
PropertyIterator it;
if (thisObj->hasOwnProperty(*id1, CURRENT_ATTR, Read, &it)) {
String *id2 = numberToString(n);
thisObj->getProperty(cx, *id1, CURRENT_ATTR);
A->setProperty(cx, *id2, CURRENT_ATTR, cx->popValue());
}
n++;
start++;
}
A->setProperty(cx, widenCString("length"), CURRENT_ATTR, JSValue((float64)n) );
return JSValue(A);
}
static JSValue Array_sort(Context * /*cx*/, const JSValue& /*thisValue*/, JSValue * /*argv*/, uint32 /*argc*/)
{
return kUndefinedValue;
}
static JSValue Array_splice(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
if (argc > 1) {
uint32 k;
ContextStackReplacement csr(cx);
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
thisObj->getProperty(cx, widenCString("length"), CURRENT_ATTR);
JSValue result = cx->popValue();
uint32 length = (uint32)(result.toUInt32(cx).f64);
JSArrayInstance *A = (JSArrayInstance *)Array_Type->newInstance(cx);
int32 arg0 = (int32)(argv[0].toInt32(cx).f64);
uint32 start;
if (arg0 < 0) {
arg0 += length;
if (arg0 < 0)
start = 0;
else
start = toUInt32(arg0);
}
else {
if (toUInt32(arg0) >= length)
start = length;
else
start = toUInt32(arg0);
}
uint32 deleteCount;
int32 arg1 = (int32)(argv[1].toInt32(cx).f64);
if (arg1 < 0)
deleteCount = 0;
else
if (toUInt32(arg1) >= (length - start))
deleteCount = length - start;
else
deleteCount = toUInt32(arg1);
for (k = 0; k < deleteCount; k++) {
String *id1 = numberToString(start + k);
PropertyIterator it;
if (thisObj->hasOwnProperty(*id1, CURRENT_ATTR, Read, &it)) {
String *id2 = numberToString(k);
thisObj->getProperty(cx, *id1, CURRENT_ATTR);
A->setProperty(cx, *id2, CURRENT_ATTR, cx->popValue());
}
}
A->setProperty(cx, widenCString("length"), CURRENT_ATTR, JSValue((float64)deleteCount) );
uint32 newItemCount = argc - 2;
if (newItemCount < deleteCount) {
for (k = start; k < (length - deleteCount); k++) {
String *id1 = numberToString(k + deleteCount);
String *id2 = numberToString(k + newItemCount);
PropertyIterator it;
if (thisObj->hasOwnProperty(*id1, CURRENT_ATTR, Read, &it)) {
thisObj->getProperty(cx, *id1, CURRENT_ATTR);
thisObj->setProperty(cx, *id2, CURRENT_ATTR, cx->popValue());
}
else
thisObj->deleteProperty(*id2, CURRENT_ATTR);
}
for (k = length; k > (length - deleteCount + newItemCount); k--) {
String *id1 = numberToString(k - 1);
thisObj->deleteProperty(*id1, CURRENT_ATTR);
}
}
else {
if (newItemCount > deleteCount) {
for (k = length - deleteCount; k > start; k--) {
String *id1 = numberToString(k + deleteCount - 1);
String *id2 = numberToString(k + newItemCount - 1);
PropertyIterator it;
if (thisObj->hasOwnProperty(*id1, CURRENT_ATTR, Read, &it)) {
thisObj->getProperty(cx, *id1, CURRENT_ATTR);
thisObj->setProperty(cx, *id2, CURRENT_ATTR, cx->popValue());
}
else
thisObj->deleteProperty(*id2, CURRENT_ATTR);
}
}
}
k = start;
for (uint32 i = 2; i < argc; i++) {
String *id1 = numberToString(k++);
thisObj->setProperty(cx, *id1, CURRENT_ATTR, argv[i]);
}
thisObj->setProperty(cx, widenCString("length"), CURRENT_ATTR, JSValue((float64)(length - deleteCount + newItemCount)) );
return JSValue(A);
}
return kUndefinedValue;
}
static JSValue Array_unshift(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ContextStackReplacement csr(cx);
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
thisObj->getProperty(cx, widenCString("length"), CURRENT_ATTR);
JSValue result = cx->popValue();
uint32 length = (uint32)(result.toUInt32(cx).f64);
uint32 k;
for (k = length; k > 0; k--) {
String *id1 = numberToString(k - 1);
String *id2 = numberToString(k + argc - 1);
PropertyIterator it;
if (thisObj->hasOwnProperty(*id1, CURRENT_ATTR, Read, &it)) {
thisObj->getProperty(cx, *id1, CURRENT_ATTR);
thisObj->setProperty(cx, *id2, CURRENT_ATTR, cx->popValue());
}
else
thisObj->deleteProperty(*id2, CURRENT_ATTR);
}
for (k = 0; k < argc; k++) {
String *id1 = numberToString(k);
thisObj->setProperty(cx, *id1, CURRENT_ATTR, argv[k]);
}
thisObj->setProperty(cx, widenCString("length"), CURRENT_ATTR, JSValue((float64)(length + argc)) );
return thisValue;
}
Context::PrototypeFunctions *getArrayProtos()
{
Context::ProtoFunDef arrayProtos[] =
{
{ "toString", String_Type, 0, Array_toString },
{ "toLocaleString", String_Type, 0, Array_toString }, // XXX
{ "toSource", String_Type, 0, Array_toSource },
{ "push", Number_Type, 1, Array_push },
{ "pop", Object_Type, 0, Array_pop },
{ "concat", Array_Type, 1, Array_concat },
{ "join", String_Type, 1, Array_join },
{ "reverse", Array_Type, 0, Array_reverse },
{ "shift", Object_Type, 0, Array_shift },
{ "slice", Array_Type, 2, Array_slice },
{ "sort", Array_Type, 1, Array_sort },
{ "splice", Array_Type, 2, Array_splice },
{ "unshift", Number_Type, 1, Array_unshift },
{ NULL }
};
return new Context::PrototypeFunctions(&arrayProtos[0]);
}
}
}

View File

@@ -1,48 +0,0 @@
/* -*- 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 {
namespace JS2Runtime {
extern JSValue Array_Constructor(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc);
extern JSValue Array_concat(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc);
Context::PrototypeFunctions *getArrayProtos();
}
}

View File

@@ -1,491 +0,0 @@
/* -*- 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 jsclasses_h
#define jsclasses_h
#include "jstypes.h"
namespace JavaScript {
namespace JSClasses {
using JSTypes::JSValue;
using JSTypes::JSObject;
using JSTypes::JSType;
using JSTypes::JSScope;
using JSTypes::JSFunction;
using JSTypes::FunctionMap;
using ICG::ICodeModule;
struct JSSlot {
typedef enum { kNoFlag = 0, kIsConstructor = 0x01, kIsVirtual = 0x02 } SlotFlags; // <-- readonly, enumerable etc
// a slot may have a getter or a setter or both, but NOT either if mActual
JSType* mType;
uint32 mIndex;
SlotFlags mFlags;
JSFunction* mGetter;
JSFunction* mSetter;
bool mActual;
JSSlot() : mType(0), mFlags(kNoFlag), mGetter(0), mSetter(0), mActual(true)
{
}
bool isConstructor() const { return (mFlags & kIsConstructor) != 0; }
bool isVirtual() const { return (mFlags & kIsVirtual) != 0; }
};
typedef gc_map_allocator(JSSlot) gc_slot_allocator;
typedef std::map<String, JSSlot, std::less<const String>, gc_slot_allocator> JSSlots;
typedef std::pair<String, JSFunction*> MethodEntry;
typedef std::vector<MethodEntry, gc_allocator<MethodEntry> > JSMethods;
typedef std::vector<JSFunction*, gc_allocator<JSFunction*> > JSFunctions;
struct JSOperator {
JSType *mOperand1;
JSType *mOperand2;
JSFunction *mFunction;
JSOperator(JSType *op1, JSType *op2, JSFunction *f) : mOperand1(op1), mOperand2(op2), mFunction(f) { }
};
typedef std::vector<JSOperator *, gc_allocator<JSOperator *> > JSOperatorList;
/**
* Represents a class in the JavaScript 2 (ECMA 4) language.
* Since a class defines a scope, and is defined in a scope,
* a new scope is created whose parent scope is the scope of
* class definition.
*/
class JSClass : public JSType {
protected:
JSScope* mScope;
uint32 mSlotCount;
JSSlots mSlots;
uint32 mStaticCount;
JSSlots mStaticSlots;
JSValue* mStaticData;
JSMethods mMethods;
bool mHasGetters; // tracks whether any getters/setters get assigned
bool mHasSetters;
JSFunctions mGetters; // allocated at 'complete()' time
JSFunctions mSetters;
JSOperatorList *mOperators[JSTypes::OperatorCount];
public:
JSClass(JSScope* scope, const String& name, JSClass* superClass = 0)
: JSType(name, superClass),
mScope(new JSScope(scope)),
mSlotCount(superClass ? superClass->mSlotCount : 0),
mStaticCount(0),
mStaticData(0),
mHasGetters(false), mHasSetters(false), mGetters(0), mSetters(0)
{
if (superClass) {
// inherit superclass methods
mMethods = JSMethods(superClass->mMethods);
// and virtual fields
JSSlots::iterator sEnd = superClass->mSlots.end();
for (JSSlots::iterator si = superClass->mSlots.begin(); si != sEnd; si++)
if (si->second.isVirtual())
mSlots[si->first] = si->second;
}
for (uint32 i = 0; i < JSTypes::OperatorCount; i++)
mOperators[i] = NULL;
}
JSClass* getSuperClass()
{
return static_cast<JSClass*>(mBaseType);
}
JSScope* getScope()
{
return mScope;
}
const JSSlot& defineSlot(const String& name, JSType* type, JSSlot::SlotFlags flags = JSSlot::kNoFlag, JSFunction* getter = 0, JSFunction* setter = 0)
{
JSSlot& slot = mSlots[name];
slot.mType = type;
slot.mIndex = mSlotCount++; // starts at 0.
slot.mSetter = setter;
slot.mGetter = getter;
slot.mFlags = flags;
if (setter || getter)
slot.mActual = false;
return slot;
}
void setGetter(const String& name, JSFunction *getter, JSType* type)
{
JSSlots::iterator slti = mSlots.find(name);
if (slti == mSlots.end())
defineSlot(name, type, JSSlot::kNoFlag, getter, 0);
else {
ASSERT(!slti->second.mActual || slti->second.isVirtual());
ASSERT(slti->second.mGetter == 0);
slti->second.mGetter = getter;
slti->second.mActual = false;
}
mHasGetters = true;
}
void setSetter(const String& name, JSFunction *setter, JSType* type)
{
JSSlots::iterator slti = mSlots.find(name);
if (slti == mSlots.end())
defineSlot(name, type, JSSlot::kNoFlag, 0, setter);
else {
JSSlot &s = slti->second;
ASSERT(!s.mActual || s.isVirtual());
ASSERT(s.mSetter == 0);
s.mSetter = setter;
s.mActual = false;
}
mHasSetters = true;
}
bool hasGetter(const String& name)
{
JSSlots::iterator slti = mSlots.find(name);
return ((slti != mSlots.end()) && slti->second.mGetter);
}
bool hasSetter(const String& name)
{
JSSlots::iterator slti = mSlots.find(name);
return ((slti != mSlots.end()) && slti->second.mSetter);
}
bool hasGetter(uint32 index)
{
return (index < mGetters.size() && mGetters[index]);
}
bool hasSetter(uint32 index)
{
return (index < mSetters.size() && mSetters[index]);
}
JSFunction* getter(uint32 index)
{
return mGetters[index];
}
JSFunction* setter(uint32 index)
{
return mSetters[index];
}
const JSSlot& getSlot(const String& name)
{
return mSlots[name];
}
bool hasSlot(const String& name)
{
return (mSlots.find(name) != mSlots.end());
}
bool hasGetterOrSetter(const String& name)
{
return (mSlots.find(name) != mSlots.end());
}
JSSlots& getSlots()
{
return mSlots;
}
uint32 getSlotCount()
{
return mSlotCount;
}
/**
* Define a static/class variable.
*/
const JSSlot& defineStatic(const String& name, JSType* type)
{
JSSlot& slot = mStaticSlots[name];
ASSERT(slot.mType == 0);
slot.mType = type;
slot.mIndex = mStaticCount++;
return slot;
}
const JSSlot& defineConstructor(const String& name)
{
JSSlot& slot = mStaticSlots[name];
ASSERT(slot.mType == 0);
slot.mType = &JSTypes::Function_Type;
slot.mIndex = mStaticCount++;
slot.mFlags = JSSlot::kIsConstructor;
return slot;
}
JSFunction *getDefaultConstructor()
{
if (hasStatic(mName)) {
const JSSlot &s = getStatic(mName);
ASSERT(s.isConstructor());
JSValue &v = (*this)[s.mIndex];
ASSERT(v.isFunction());
return v.function;
}
return NULL;
}
const JSSlot& getStatic(const String& name)
{
return mStaticSlots[name];
}
bool hasStatic(const String& name, JSType*& type, bool &isConstructor)
{
JSSlots::const_iterator i = mStaticSlots.find(name);
if (i != mStaticSlots.end()) {
type = i->second.mType;
isConstructor = i->second.isConstructor();
return true;
}
return false;
}
bool hasStatic(const String& name)
{
return (mStaticSlots.find(name) != mStaticSlots.end());
}
bool complete()
{
if (mHasGetters || mHasSetters) {
if (mHasGetters) mGetters.resize(mSlotCount);
if (mHasSetters) mSetters.resize(mSlotCount);
JSSlots::iterator end = mSlots.end();
for (JSSlots::iterator i = mSlots.begin(); i != end; i++) {
if (mHasGetters) mGetters[i->second.mIndex] = i->second.mGetter;
if (mHasSetters) mSetters[i->second.mIndex] = i->second.mSetter;
}
}
mStaticData = new JSValue[mStaticCount];
return (mStaticData != 0);
}
JSValue& operator[] (uint32 index)
{
return mStaticData[index];
}
virtual void printProperties(Formatter& f)
{
f << "Properties:\n";
JSObject::printProperties(f);
f << "Statics:\n";
printStatics(f);
}
void printStatics(Formatter& f)
{
JSClass* superClass = getSuperClass();
if (superClass) superClass->printStatics(f);
for (JSSlots::iterator i = mStaticSlots.begin(), end = mStaticSlots.end(); i != end; ++i) {
f << i->first << " : " << mStaticData[i->second.mIndex] << "\n";
}
}
void defineOperator(JSTypes::Operator op, JSType *operand1, JSType *operand2, JSFunction *f)
{
if (!mOperators[op])
mOperators[op] = new JSOperatorList();
else {
for (JSOperatorList::iterator i = mOperators[op]->begin(),
end = mOperators[op]->end(); i != end; ++i) {
if (((*i)->mOperand1 == operand1)
&& ((*i)->mOperand2 == operand2)) {
(*i)->mFunction = f;
return;
}
}
}
mOperators[op]->push_back(new JSOperator(operand1, operand2, f));
}
void addApplicableOperators(JSOperatorList &list, JSTypes::Operator op, const JSType *operand1, const JSType *operand2)
{
if (mOperators[op]) {
for (JSOperatorList::iterator i = mOperators[op]->begin(),
end = mOperators[op]->end(); i != end; ++i) {
if (operand1->isSubTypeOf((*i)->mOperand1) && operand2->isSubTypeOf((*i)->mOperand2)) {
list.push_back(*i);
}
}
}
}
JSOperator *findUnaryOperator(JSTypes::Operator op)
{
if (mOperators[op])
return *mOperators[op]->begin();
else {
JSClass *super = getSuperClass();
if (super)
return super->findUnaryOperator(op);
else
return NULL;
}
}
void defineMethod(const String& name, JSFunction *f)
{
uint32 slot;
if (hasMethod(name, slot))
mMethods[slot] = MethodEntry(name, f);
else
mMethods.push_back(MethodEntry(name, f));
}
bool hasMethod(const String& name, uint32& index)
{
JSMethods::iterator end = mMethods.end();
for (JSMethods::iterator i = mMethods.begin(); i != end; i++) {
if (i->first == name) {
index = static_cast<uint32>(i - mMethods.begin());
return true;
}
}
return false;
}
JSFunction* getMethod(uint32 index)
{
return mMethods[index].second;
}
};
/**
* Represents an instance of a JSClass.
*/
class JSInstance : public JSObject {
protected:
JSValue mSlots[1];
public:
void* operator new(size_t n, JSClass* thisClass)
{
uint32 slotCount = thisClass->getSlotCount();
if (slotCount > 0) n += sizeof(JSValue) * (slotCount - 1);
return gc_base::operator new(n);
}
void operator delete(void* /*ptr*/) {}
void operator delete(void* /*ptr*/, JSClass* /*thisClass*/) {}
JSInstance(JSClass* thisClass)
{
mType = thisClass;
// initialize extra slots with undefined.
uint32 slotCount = thisClass->getSlotCount();
if (slotCount > 0) {
std::uninitialized_fill(&mSlots[1], &mSlots[1] + (slotCount - 1),
JSTypes::kUndefinedValue);
}
// for grins, use the prototype link to access methods.
// setPrototype(thisClass->getScope());
}
JSFunction* getMethod(uint32 index)
{
return getClass()->getMethod(index);
}
JSClass* getClass()
{
return static_cast<JSClass*>(mType);
}
JSValue& operator[] (uint32 index)
{
return mSlots[index];
}
virtual void printProperties(Formatter& f)
{
f << "Properties:\n";
JSObject::printProperties(f);
f << "Slots:\n";
printSlots(f, getClass());
}
bool hasGetter(uint32 index)
{
return getClass()->hasGetter(index);
}
bool hasSetter(uint32 index)
{
return getClass()->hasSetter(index);
}
JSFunction* getter(uint32 index)
{
return getClass()->getter(index);
}
JSFunction* setter(uint32 index)
{
return getClass()->setter(index);
}
private:
void printSlots(Formatter& f, JSClass* thisClass)
{
JSClass* superClass = thisClass->getSuperClass();
if (superClass) printSlots(f, superClass);
JSSlots& slots = thisClass->getSlots();
for (JSSlots::iterator i = slots.begin(), end = slots.end(); i != end; ++i) {
f << i->first << " : " << mSlots[i->second.mIndex] << "\n";
}
}
};
} /* namespace JSClasses */
} /* namespace JavaScript */
#endif /* jsclasses_h */

View File

@@ -1,261 +0,0 @@
/* -*- 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)
#pragma warning(disable: 4711)
#pragma warning(disable: 4710)
#endif
#include <algorithm>
#include "parser.h"
#include "numerics.h"
#include "js2runtime.h"
#include "jsmath.h"
#include "fdlibm_ns.h"
namespace JavaScript {
namespace JS2Runtime {
#ifndef M_E
#define M_E 2.7182818284590452354
#endif
#ifndef M_LOG2E
#define M_LOG2E 1.4426950408889634074
#endif
#ifndef M_LOG10E
#define M_LOG10E 0.43429448190325182765
#endif
#ifndef M_LN2
#define M_LN2 0.69314718055994530942
#endif
#ifndef M_LN10
#define M_LN10 2.30258509299404568402
#endif
#ifndef M_PI
#define M_PI 3.14159265358979323846
#endif
#ifndef M_SQRT2
#define M_SQRT2 1.41421356237309504880
#endif
#ifndef M_SQRT1_2
#define M_SQRT1_2 0.70710678118654752440
#endif
#define M_CONSTANTS_COUNT 8
static JSValue Math_abs(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
else
return JSValue(fd::fabs(argv[0].toNumber(cx).f64));
}
static JSValue Math_acos(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::acos(argv[0].toNumber(cx).f64));
}
static JSValue Math_asin(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::asin(argv[0].toNumber(cx).f64));
}
static JSValue Math_atan(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::atan(argv[0].toNumber(cx).f64));
}
static JSValue Math_atan2(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc <= 1)
return kNaNValue;
float64 y = argv[0].toNumber(cx).f64;
float64 x = argv[1].toNumber(cx).f64;
return JSValue(fd::atan2(y, x));
}
static JSValue Math_ceil(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::ceil(argv[0].toNumber(cx).f64));
}
static JSValue Math_cos(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::cos(argv[0].toNumber(cx).f64));
}
static JSValue Math_exp(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::exp(argv[0].toNumber(cx).f64));
}
static JSValue Math_floor(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
else
return JSValue(fd::floor(argv[0].toNumber(cx).f64));
}
static JSValue Math_log(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::log(argv[0].toNumber(cx).f64));
}
static JSValue Math_max(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
float64 result = argv[0].toNumber(cx).f64;
for (uint32 i = 1; i < argc; ++i) {
float64 arg = argv[i].toNumber(cx).f64;
if (arg > result)
result = arg;
}
return JSValue(result);
}
static JSValue Math_min(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
float64 result = argv[0].toNumber(cx).f64;
for (uint32 i = 1; i < argc; ++i) {
float64 arg = argv[i].toNumber(cx).f64;
if (arg < result)
result = arg;
}
return JSValue(result);
}
static JSValue Math_pow(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc < 1)
return kNaNValue;
return JSValue(fd::pow(argv[0].toNumber(cx).f64, argv[1].toNumber(cx).f64));
}
static JSValue Math_random(Context * /*cx*/, const JSValue& /*thisValue*/, JSValue * /*argv*/, uint32 /*argc*/)
{
return JSValue(42.0);
}
static JSValue Math_round(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
float64 x = argv[0].toNumber(cx).f64;
return JSValue( fd::copysign( fd::floor(x + 0.5), x ) );
}
static JSValue Math_sin(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::sin(argv[0].toNumber(cx).f64));
}
static JSValue Math_sqrt(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::sqrt(argv[0].toNumber(cx).f64));
}
static JSValue Math_tan(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
if (argc == 0)
return kNaNValue;
return JSValue(fd::tan(argv[0].toNumber(cx).f64));
}
struct {
char *name;
float64 value;
} MathObjectConstants[M_CONSTANTS_COUNT] = {
{ "E", M_E },
{ "LOG2E", M_LOG2E },
{ "LOG10E", M_LOG10E },
{ "LN2", M_LN2 },
{ "LN10", M_LN10 },
{ "PI", M_PI },
{ "SQRT2", M_SQRT2 },
{ "SQRT1_2",M_SQRT1_2 }
};
struct MathObjectFunctionDef {
char *name;
JSFunction::NativeCode *imp;
} MathObjectFunctions[] = {
{ "abs", Math_abs },
{ "acos", Math_acos },
{ "asin", Math_asin },
{ "atan", Math_atan },
{ "atan2", Math_atan2 },
{ "ceil", Math_ceil },
{ "cos", Math_cos },
{ "exp", Math_exp },
{ "floor", Math_floor },
{ "log", Math_log },
{ "max", Math_max },
{ "min", Math_min },
{ "pow", Math_pow },
{ "random", Math_random },
{ "round", Math_round },
{ "sin", Math_sin },
{ "sqrt", Math_sqrt },
{ "tan", Math_tan },
};
void initMathObject(Context *cx, JSObject *mathObj)
{
uint32 i;
for (i = 0; i < M_CONSTANTS_COUNT; i++)
mathObj->defineVariable(cx, widenCString(MathObjectConstants[i].name),
(NamespaceList *)(NULL), Number_Type, JSValue(MathObjectConstants[i].value));
for (i = 0; i < sizeof(MathObjectFunctions) / sizeof(MathObjectFunctionDef); i++) {
JSFunction *f = new JSFunction(MathObjectFunctions[i].imp, Number_Type);
mathObj->defineVariable(cx, widenCString(MathObjectFunctions[i].name),
(NamespaceList *)(NULL), Number_Type, JSValue(f));
}
}
}
}

View File

@@ -1,41 +0,0 @@
/* -*- 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 {
namespace JS2Runtime {
void initMathObject(Context *cx, JSObject *mathObj);
}
}

View File

@@ -1,444 +0,0 @@
/* -*- 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)
#pragma warning(disable: 4711)
#pragma warning(disable: 4710)
#endif
#include <algorithm>
#include "parser.h"
#include "numerics.h"
#include "js2runtime.h"
#include "jsstring.h"
namespace JavaScript {
namespace JS2Runtime {
JSValue String_Constructor(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
JSValue thatValue = thisValue;
if (thatValue.isNull())
thatValue = String_Type->newInstance(cx);
ASSERT(thatValue.isObject());
JSObject *thisObj = thatValue.object;
ASSERT(dynamic_cast<JSStringInstance *>(thisObj));
JSStringInstance *strInst = (JSStringInstance *)thisObj;
if (argc > 0)
thisObj->mPrivate = (void *)(new String(*argv[0].toString(cx).string));
else
thisObj->mPrivate = (void *)(new String(widenCString("")));
strInst->mLength = ((String *)(thisObj->mPrivate))->size();
return thatValue;
}
JSValue String_fromCharCode(Context *cx, const JSValue& /*thisValue*/, JSValue *argv, uint32 argc)
{
String *resultStr = new String();
resultStr->reserve(argc);
for (uint32 i = 0; i < argc; i++)
*resultStr += (char16)(argv[i].toUInt16(cx).f64);
return JSValue(resultStr);
}
static JSValue String_toString(Context * /*cx*/, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ASSERT(thisValue.isObject());
JSObject *thisObj = thisValue.object;
return JSValue((String *)thisObj->mPrivate);
}
struct MatchResult {
bool failure;
uint32 endIndex;
String **captures;
};
static void splitMatch(const String *S, uint32 q, const String *R, MatchResult &result)
{
result.failure = true;
result.captures = NULL;
uint32 r = R->size();
uint32 s = S->size();
if ((q + r) > s)
return;
for (uint32 i = 0; i < r; i++) {
if ((*S)[q + i] != (*R)[i])
return;
}
result.endIndex = q + r;
result.failure = false;
}
static JSValue String_split(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ContextStackReplacement csr(cx);
ASSERT(thisValue.isObject());
JSValue S = thisValue.toString(cx);
JSArrayInstance *A = (JSArrayInstance *)Array_Type->newInstance(cx);
uint32 lim;
JSValue separatorV = (argc > 0) ? argv[0] : kUndefinedValue;
JSValue limitV = (argc > 1) ? argv[1] : kUndefinedValue;
if (limitV.isUndefined())
lim = (uint32)(two32minus1);
else
lim = (uint32)(limitV.toUInt32(cx).f64);
uint32 s = S.string->size();
uint32 p = 0;
// XXX if separatorV.isRegExp() -->
const String *R = separatorV.toString(cx).string;
if (lim == 0)
return JSValue(A);
if (separatorV.isUndefined()) {
A->setProperty(cx, widenCString("0"), NULL, S);
return JSValue(A);
}
if (s == 0) {
MatchResult z;
splitMatch(S.string, 0, R, z);
if (!z.failure)
return JSValue(A);
A->setProperty(cx, widenCString("0"), NULL, S);
return JSValue(A);
}
while (true) {
uint32 q = p;
step11:
if (q == s) {
String *T = new String(*S.string, p, (s - p));
JSValue v(T);
A->setProperty(cx, *numberToString(A->mLength), NULL, v);
return JSValue(A);
}
MatchResult z;
splitMatch(S.string, q, R, z);
if (z.failure) {
q = q + 1;
goto step11;
}
uint32 e = z.endIndex;
if (e == p) {
q = q + 1;
goto step11;
}
String *T = new String(*S.string, p, (q - p));
JSValue v(T);
A->setProperty(cx, *numberToString(A->mLength), NULL, v);
if (A->mLength == lim)
return JSValue(A);
p = e;
// step 20 --> 27, handle captures array (we know it's empty for non regexp)
}
}
static JSValue String_valueOf(Context * /*cx*/, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ASSERT(thisValue.isObject());
if (thisValue.isString())
return thisValue;
else
throw Exception(Exception::typeError, "String.valueOf called on");
return kUndefinedValue;
}
static JSValue String_charAt(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ASSERT(thisValue.isObject());
const String *str = thisValue.toString(cx).string;
uint32 pos = 0;
if (argc > 0)
pos = (uint32)(argv[0].toInt32(cx).f64);
if ((pos < 0) || (pos >= str->size()))
return JSValue(new String()); // have an empty string kValue somewhere?
else
return JSValue(new String(1, (*str)[pos]));
}
static JSValue String_charCodeAt(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ASSERT(thisValue.isObject());
const String *str = thisValue.toString(cx).string;
uint32 pos = 0;
if (argc > 0)
pos = (uint32)(argv[0].toInt32(cx).f64);
if ((pos < 0) || (pos >= str->size()))
return kNaNValue;
else
return JSValue((float64)(*str)[pos]);
}
static JSValue String_concat(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ASSERT(thisValue.isObject());
const String *str = thisValue.toString(cx).string;
String *result = new String(*str);
for (uint32 i = 0; i < argc; i++) {
*result += *argv[i].toString(cx).string;
}
return JSValue(result);
}
static JSValue String_indexOf(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ASSERT(thisValue.isObject());
if (argc == 0)
return JSValue(-1.0);
const String *str = thisValue.toString(cx).string;
const String *searchStr = argv[0].toString(cx).string;
uint32 pos = 0;
if (argc > 1) {
int32 arg1 = (int32)(argv[1].toInt32(cx).f64);
if (arg1 < 0)
pos = 0;
else
if (toUInt32(arg1) >= str->size())
pos = str->size();
else
pos = toUInt32(arg1);
}
pos = str->find(*searchStr, pos);
if (pos == String::npos)
return JSValue(-1.0);
return JSValue((float64)pos);
}
static JSValue String_lastIndexOf(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ASSERT(thisValue.isObject());
if (argc == 0)
return JSValue(-1.0);
const String *str = thisValue.toString(cx).string;
const String *searchStr = argv[0].toString(cx).string;
uint32 pos = 0;
if (argc > 1) {
float64 fpos = argv[1].toNumber(cx).f64;
if (fpos != fpos)
pos = str->size();
else {
int32 arg1 = (int32)(fpos);
if (arg1 < 0)
pos = 0;
else
if (toUInt32(arg1) >= str->size())
pos = str->size();
else
pos = toUInt32(arg1);
}
}
pos = str->rfind(*searchStr, pos);
if (pos == String::npos)
return JSValue(-1.0);
return JSValue((float64)pos);
}
static JSValue String_localeCompare(Context * /*cx*/, const JSValue& /*thisValue*/, JSValue * /*argv*/, uint32 /*argc*/)
{
return kUndefinedValue;
}
static JSValue String_toLowerCase(Context *cx, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ASSERT(thisValue.isObject());
JSValue S = thisValue.toString(cx);
String *result = new String(*S.string);
for (String::iterator i = result->begin(), end = result->end(); i != end; i++)
*i = toLower(*i);
return JSValue(result);
}
static JSValue String_toUpperCase(Context *cx, const JSValue& thisValue, JSValue * /*argv*/, uint32 /*argc*/)
{
ASSERT(thisValue.isObject());
JSValue S = thisValue.toString(cx);
String *result = new String(*S.string);
for (String::iterator i = result->begin(), end = result->end(); i != end; i++)
*i = toUpper(*i);
return JSValue(result);
}
static JSValue String_slice(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ASSERT(thisValue.isObject());
const String *sourceString = thisValue.toString(cx).string;
uint32 sourceLength = sourceString->size();
uint32 start, end;
if (argc > 0) {
int32 arg0 = (int32)(argv[0].toInt32(cx).f64);
if (arg0 < 0) {
arg0 += sourceLength;
if (arg0 < 0)
start = 0;
else
start = toUInt32(arg0);
}
else {
if (toUInt32(arg0) < sourceLength)
start = toUInt32(arg0);
else
start = sourceLength;
}
}
else
start = 0;
if (argc > 1) {
int32 arg1 = (int32)(argv[1].toInt32(cx).f64);
if (arg1 < 0) {
arg1 += sourceLength;
if (arg1 < 0)
end = 0;
else
end = toUInt32(arg1);
}
else {
if (toUInt32(arg1) < sourceLength)
end = toUInt32(arg1);
else
end = sourceLength;
}
}
else
end = sourceLength;
if (start > end)
return JSValue(new String());
return JSValue(new String(sourceString->substr(start, end - start)));
}
static JSValue String_substring(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc)
{
ASSERT(thisValue.isObject());
const String *sourceString = thisValue.toString(cx).string;
uint32 sourceLength = sourceString->size();
uint32 start, end;
if (argc > 0) {
int32 arg0 = (int32)(argv[0].toInt32(cx).f64);
if (arg0 < 0)
start = 0;
else
if (toUInt32(arg0) < sourceLength)
start = toUInt32(arg0);
else
start = sourceLength;
}
else
start = 0;
if (argc > 1) {
int32 arg1 = (int32)(argv[1].toInt32(cx).f64);
if (arg1 < 0)
end = 0;
else
if (toUInt32(arg1) < sourceLength)
end = toUInt32(arg1);
else
end = sourceLength;
}
else
end = sourceLength;
if (start > end) {
uint32 t = start;
start = end;
end = t;
}
return JSValue(new String(sourceString->substr(start, end - start)));
}
Context::PrototypeFunctions *getStringProtos()
{
Context::ProtoFunDef stringProtos[] =
{
{ "toString", String_Type, 0, String_toString },
{ "valueof", String_Type, 0, String_valueOf },
{ "charAt", String_Type, 1, String_charAt },
{ "charCodeAt", Number_Type, 1, String_charCodeAt },
{ "concat", String_Type, 1, String_concat },
{ "indexOf", Number_Type, 1, String_indexOf },
{ "lastIndexOf", Number_Type, 1, String_lastIndexOf },
{ "localeCompare", Number_Type, 1, String_localeCompare },
{ "slice", String_Type, 2, String_slice },
{ "split", Array_Type, 2, String_split },
{ "substring", String_Type, 2, String_substring },
{ "toSource", String_Type, 0, String_toString },
{ "toLocaleUpperCase", String_Type, 0, String_toUpperCase }, // (sic)
{ "toLocaleLowerCase", String_Type, 0, String_toLowerCase }, // (sic)
{ "toUpperCase", String_Type, 0, String_toUpperCase },
{ "toLowerCase", String_Type, 0, String_toLowerCase },
{ NULL }
};
return new Context::PrototypeFunctions(&stringProtos[0]);
}
}
}

View File

@@ -1,45 +0,0 @@
/* -*- 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 {
namespace JS2Runtime {
extern JSValue String_Constructor(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc);
extern JSValue String_fromCharCode(Context *cx, const JSValue& thisValue, JSValue *argv, uint32 argc);
Context::PrototypeFunctions *getStringProtos();
}
}

File diff suppressed because it is too large Load Diff

View File

@@ -1,782 +0,0 @@
/* -*- 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 jstypes_h
#define jstypes_h
#include "utilities.h"
#include "gc_allocator.h"
#include "parser.h"
#include <vector>
#include <map>
#include <stack>
/* forward declare classes from JavaScript::ICG */
namespace JavaScript {
namespace ICG {
class ICodeModule;
} /* namespace ICG */
namespace Interpreter {
class Context;
struct Activation;
} /* namespace Interpreter */
} /* namespace JavaScript */
namespace JavaScript {
namespace JSTypes {
using ICG::ICodeModule;
using Interpreter::Context;
class JSObject;
class JSArray;
class JSString;
class JSFunction;
class JSScope;
class JSType;
class Context;
typedef uint32 Register;
/**
* All JavaScript data types.
*/
struct JSValue {
union {
int8 i8;
uint8 u8;
int16 i16;
uint16 u16;
int32 i32;
uint32 u32;
int64 i64;
uint64 u64;
float32 f32;
float64 f64;
JSObject* object;
JSArray* array;
JSFunction *function;
JSString *string;
JSType *type;
bool boolean;
};
/* These are the ECMA types, for use in 'toPrimitive' calls */
enum ECMA_type {
Undefined, Null, Boolean, Number, Object, String,
NoHint
};
typedef enum {
i8_tag, u8_tag,
i16_tag, u16_tag,
i32_tag, u32_tag,
i64_tag, u64_tag,
f32_tag, f64_tag,
integer_tag,
object_tag, array_tag, function_tag, string_tag, boolean_tag, type_tag,
undefined_tag, null_tag,
uninitialized_tag
} Tag;
Tag tag;
JSValue() : f64(0.0), tag(undefined_tag) {}
explicit JSValue(int32 i32) : i32(i32), tag(i32_tag) {}
explicit JSValue(uint32 u32) : u32(u32), tag(u32_tag) {}
explicit JSValue(float64 f64) : f64(f64), tag(f64_tag) {}
explicit JSValue(JSObject* object) : object(object), tag(object_tag) {}
explicit JSValue(JSArray* array) : array(array), tag(array_tag) {}
explicit JSValue(JSFunction* function) : function(function), tag(function_tag) {}
explicit JSValue(JSString* string) : string(string), tag(string_tag) {}
explicit JSValue(bool boolean) : boolean(boolean), tag(boolean_tag) {}
explicit JSValue(JSType* type) : type(type), tag(type_tag) {}
explicit JSValue(Tag tag) : tag(tag) {}
int32& operator=(int32 i32) { return (tag = i32_tag, this->i32 = i32); }
uint32& operator=(uint32 u32) { return (tag = u32_tag, this->u32 = u32); }
float64& operator=(float64 f64) { return (tag = f64_tag, this->f64 = f64); }
JSObject*& operator=(JSObject* object) { return (tag = object_tag, this->object = object); }
JSArray*& operator=(JSArray* array) { return (tag = array_tag, this->array = array); }
JSFunction*& operator=(JSFunction* function) { return (tag = function_tag, this->function = function); }
JSString*& operator=(JSString* string) { return (tag = string_tag, this->string = string); }
bool& operator=(bool boolean) { return (tag = boolean_tag, this->boolean = boolean); }
JSType*& operator=(JSType* type) { return (tag = type_tag, this->type = type); }
bool isPrimitive() const { return (tag == i32_tag) || (tag == u32_tag) || (tag == f64_tag) || (tag == boolean_tag) || (tag == string_tag); }
bool isFunction() const { return (tag == function_tag); }
bool isArray() const { return (tag == array_tag); }
bool isObject() const { return ((tag == object_tag) || (tag == function_tag) || (tag == array_tag) || (tag == type_tag)); }
bool isString() const { return (tag == string_tag); }
bool isBoolean() const { return (tag == boolean_tag); }
bool isNumber() const { return (tag == f64_tag) || (tag == integer_tag); }
/* this is correct wrt ECMA, The i32 & u32 kinds
will have to be converted (to doubles?) anyway because
we can't have overflow happening in generic arithmetic */
bool isInitialized() const { return (tag != uninitialized_tag); }
bool isUndefined() const { return (tag == undefined_tag); }
bool isNull() const { return (tag == null_tag); }
bool isNaN() const;
bool isNegativeInfinity() const;
bool isPositiveInfinity() const;
bool isNegativeZero() const;
bool isPositiveZero() const;
bool isType() const { return (tag == type_tag); }
JSValue toString(Context *cx) const { return (isString() ? *this : valueToString(cx, *this)); }
JSValue toNumber() const { return (isNumber() ? *this : valueToNumber(*this)); }
JSValue toInt32() const { return ((tag == i32_tag) ? *this : valueToInt32(*this)); }
JSValue toUInt32() const { return ((tag == u32_tag) ? *this : valueToUInt32(*this)); }
JSValue toBoolean(Context *cx) const { return ((tag == boolean_tag) ? *this : valueToBoolean(cx, *this)); }
JSValue toPrimitive(Context *cx, ECMA_type hint = NoHint) const;
JSValue convert(Context *cx, JSType *toType);
static JSValue valueToString(Context *cx, const JSValue& value);
static JSValue valueToNumber(const JSValue& value);
static JSValue valueToInteger(const JSValue& value);
static JSValue valueToInt32(const JSValue& value);
static JSValue valueToUInt32(const JSValue& value);
static JSValue valueToBoolean(Context *cx, const JSValue& value);
const JSType *getType() const; // map from tag type to JS2 type
bool isSameType(const JSValue &other) const
{
const JSType *thisType = getType();
const JSType *otherType = other.getType();
if (thisType == otherType)
return true;
if (isNumber() && other.isNumber())
return true;
return false;
}
int operator==(const JSValue& value) const;
};
Formatter& operator<<(Formatter& f, const JSValue& value);
typedef enum {
None,
Posate,
Negate,
Complement,
Increment,
Decrement,
Const,
Call,
New,
NewArgs,
Index,
IndexEqual,
DeleteIndex,
Plus,
Minus,
Multiply,
Divide,
Remainder,
ShiftLeft,
ShiftRight,
UShiftRight,
Less,
LessEqual,
In,
Equal,
SpittingImage,
BitAnd,
BitXor,
BitOr,
OperatorCount
} Operator;
#if defined(XP_MAC)
// copied from default template parameters in map.
//typedef gc_allocator<std::pair<const String, JSValue> > gc_map_allocator;
//typedef gc_allocator<std::pair<const String, JSValue> > gc_map_allocator;
#define gc_map_allocator(T) gc_allocator<std::pair<const String, T> >
#elif defined(XP_UNIX)
// FIXME: in libg++, they assume the map's allocator is a byte allocator,
// which is wrapped in a simple_allocator. this is crap.
typedef char _Char[1];
//typedef gc_allocator<_Char> gc_map_allocator;
#define gc_map_allocator(T) gc_allocator<JSTypes::_Char>
#elif defined(_WIN32)
// FIXME: MSVC++'s notion. this is why we had to add _Charalloc().
//typedef gc_allocator<JSValue> gc_map_allocator;
//typedef gc_allocator<JSContainer> gc_container_allocator;
#define gc_map_allocator(T) gc_allocator<T>
#endif
/**
* GC-scannable array of values.
*/
typedef std::vector<JSValue, gc_allocator<JSValue> > JSValues;
String getRegisterValue(const JSValues& registerList, Register reg);
extern const JSValue kUndefinedValue;
extern const JSValue kNaNValue;
extern const JSValue kTrueValue;
extern const JSValue kFalseValue;
extern const JSValue kNullValue;
extern const JSValue kNegativeZero;
extern const JSValue kPositiveZero;
extern const JSValue kNegativeInfinity;
extern const JSValue kPositiveInfinity;
// JS2 predefined types:
extern JSType Object_Type;
extern JSType Integer_Type;
extern JSType Number_Type;
extern JSType Character_Type;
extern JSType String_Type;
extern JSType Function_Type;
extern JSType Array_Type;
extern JSType Type_Type;
extern JSType Boolean_Type;
extern JSType Null_Type;
extern JSType Void_Type;
extern JSType None_Type;
// JS1X heritage classes as types:
extern JSType Date_Type;
typedef std::map<String, JSValue, std::less<String>, gc_map_allocator(JSValue) > JSProperties;
typedef std::map<String, JSFunction *, std::less<String> > FunctionMap;
/**
* Basic behavior of all JS objects, mapping a name to a value,
* with prototype-based inheritance.
*/
class JSObject : public gc_base {
protected:
JSProperties mProperties;
FunctionMap *mGetter; // only allocated if the object has properties with getters or setters
FunctionMap *mSetter;
JSObject* mPrototype;
JSType* mType;
JSString* mClass; // this is the internal [[Class]] property
void *mPrivate;
static JSObject *initJSObject();
static JSString *ObjectString;
static JSObject *ObjectPrototypeObject;
void init(JSObject* prototype) { mGetter = NULL; mSetter = NULL; mPrototype = prototype; mType = &Object_Type; mClass = ObjectString; }
public:
JSObject() { init(ObjectPrototypeObject); }
JSObject(JSValue &constructor) { init(constructor.object->getProperty(widenCString("prototype")).object); }
JSObject(JSObject *prototype) { init(prototype); }
virtual ~JSObject()
{
if (mGetter) delete mGetter;
if (mSetter) delete mSetter;
}
void *getPrivate() { return mPrivate; }
void setPrivate(void *underwear) { mPrivate = underwear; }
static void initObjectObject(JSScope *g);
bool hasProperty(const String& name)
{
return (mProperties.count(name) != 0);
}
const JSValue& getProperty(const String& name)
{
JSProperties::const_iterator i = mProperties.find(name);
if (i != mProperties.end())
return i->second;
if (mPrototype)
return mPrototype->getProperty(name);
return kUndefinedValue;
}
JSValue& setProperty(const String& name, const JSValue& value)
{
return (mProperties[name] = value);
}
void setGetter(const String& name, JSFunction *getter)
{
if (mGetter == NULL)
mGetter = new FunctionMap();
mProperties[name] = kUndefinedValue;
(*mGetter)[name] = getter;
}
void setSetter(const String& name, JSFunction *setter)
{
if (mSetter == NULL)
mSetter = new FunctionMap();
mProperties[name] = kUndefinedValue;
(*mSetter)[name] = setter;
}
JSFunction *getter(const String& name)
{
if (hasProperty(name)) {
if (mGetter) {
FunctionMap::iterator g = mGetter->find(name);
if (g != mGetter->end())
return g->second;
}
}
else
if (mPrototype)
return mPrototype->getter(name);
return NULL;
}
JSFunction *setter(const String& name)
{
if (hasProperty(name)) {
if (mSetter) {
FunctionMap::iterator s = mSetter->find(name);
if (s != mSetter->end())
return s->second;
}
}
else
if (mPrototype)
return mPrototype->setter(name);
return NULL;
}
const JSValue& deleteProperty(const String& name)
{
JSProperties::iterator i = mProperties.find(name);
if (i != mProperties.end()) {
mProperties.erase(i);
return kTrueValue;
}
if (mPrototype)
return mPrototype->deleteProperty(name);
return kFalseValue;
}
void setPrototype(JSObject* prototype)
{
mPrototype = prototype;
}
JSObject* getPrototype()
{
return mPrototype;
}
JSType* getType()
{
return mType;
}
JSString* getClass()
{
return mClass;
}
void setClass(JSString* s)
{
mClass = s;
}
virtual void printProperties(Formatter& f);
};
Formatter& operator<<(Formatter& f, JSObject& obj);
/**
* Private representation of a JavaScript array.
*/
class JSArray : public JSObject {
static JSObject* ArrayPrototypeObject;
static JSString* ArrayString;
JSValues elements;
uint32 top;
public:
static JSFunction *Array_length_getter;
static void initArrayObject(JSScope *g);
JSArray() : JSObject(ArrayPrototypeObject), elements(1) { setClass(ArrayString); top = 0; }
JSArray(uint32 size) : JSObject(ArrayPrototypeObject), elements(size) { setClass(ArrayString); top = size; }
JSArray(const JSValues &v) : JSObject(ArrayPrototypeObject), elements(v) { setClass(ArrayString); }
uint32 length()
{
return top;
}
JSValue& operator[](const JSValue& index)
{
// for now, we can only handle f64 index values.
uint32 n = (uint32)index.f64;
// obviously, a sparse representation might be better.
uint32 size = elements.size();
if (n >= size) expand(n, size);
markHiEnd(n);
return elements[n];
}
JSValue& operator[](uint32 n)
{
// obviously, a sparse representation might be better.
uint32 size = elements.size();
if (n >= size) expand(n, size);
markHiEnd(n);
return elements[n];
}
void resize(uint32 size)
{
elements.resize(size);
top = size;
}
private:
void markHiEnd(uint32 index)
{
if ((index + 1) > top) top = index + 1;
}
void expand(uint32 n, uint32 size)
{
do {
size *= 2;
} while (n >= size);
elements.resize(size);
}
};
#if defined(XP_UNIX)
// bastring.cc defines a funky operator new that assumes a byte-allocator.
typedef string_char_traits<char16> JSCharTraits;
typedef gc_allocator<_Char> JSStringAllocator;
#else
typedef std::char_traits<char16> JSCharTraits;
typedef gc_allocator<char16> JSStringAllocator;
#endif
typedef std::basic_string<char16, JSCharTraits, JSStringAllocator> JSStringBase;
/**
* Garbage collectable UNICODE string.
*/
class JSString : public JSStringBase, public gc_base {
public:
JSString() {}
explicit JSString(const JSStringBase& str) : JSStringBase(str) {}
explicit JSString(const JSStringBase* str) : JSStringBase(*str) {}
explicit JSString(const String& str);
explicit JSString(const String* str);
explicit JSString(const char* str);
operator String();
void append(const char* str);
void append(const JSStringBase* str);
};
class JSException : public gc_base {
public:
JSException(String mess) : value(JSValue(new JSString(mess))) { }
JSException(char *mess) : value(JSValue(new JSString(mess))) { }
JSException(JSValue v) : value(v) { }
JSValue value;
};
inline Formatter& operator<<(Formatter& f, const JSString& str)
{
printString(f, str.begin(), str.end());
return f;
}
/**
* Private representation of a JS function. This simply
* holds a reference to the iCode module that is the
* compiled code of the function.
*/
class JSFunction : public JSObject {
protected:
static JSString* FunctionString;
static JSObject* FunctionPrototypeObject;
ICodeModule* mICode;
typedef JavaScript::gc_traits_finalizable<JSFunction> traits;
typedef gc_allocator<JSFunction, traits> allocator;
public:
static void initFunctionObject(JSScope *g);
JSFunction() : mICode(0) {}
JSFunction(ICodeModule* iCode)
: JSObject(FunctionPrototypeObject),
mICode(iCode)
{
setClass(FunctionString);
}
virtual ~JSFunction();
virtual JSValue getThis() { return kNullValue; }
virtual JSFunction *getFunky() { return this; }
void* operator new(size_t) { return allocator::allocate(1); }
ICodeModule* getICode() { return mICode; }
virtual bool isNative() { return false; }
};
class JSBoundThis : public JSFunction {
typedef JavaScript::gc_traits_finalizable<JSBoundThis> traits;
typedef gc_allocator<JSBoundThis, traits> allocator;
public:
JSBoundThis(JSValue aThis, JSFunction *aFunc) : mBoundThis(aThis), mFunction(aFunc) { }
JSValue mBoundThis;
JSFunction *mFunction;
virtual ~JSBoundThis() { mICode = NULL; }
virtual JSValue getThis() { return mBoundThis; }
virtual JSFunction *getFunky() { return mFunction; }
void* operator new(size_t) { return allocator::allocate(1); }
};
class JSNativeFunction : public JSFunction {
typedef JavaScript::gc_traits_finalizable<JSNativeFunction> traits;
typedef gc_allocator<JSNativeFunction, traits> allocator;
public:
typedef JSValue (*JSCode)(Context *cx, const JSValues& argv);
JSCode mCode;
JSNativeFunction(JSCode code) : mCode(code) {}
virtual bool isNative() { return true; }
void* operator new(size_t) { return allocator::allocate(1); }
};
class JSUnaryOperator : public JSFunction {
typedef JavaScript::gc_traits_finalizable<JSUnaryOperator> traits;
typedef gc_allocator<JSUnaryOperator, traits> allocator;
public:
typedef JSValue (*JSUnaryCode)(Context *cx, const JSValue& arg1);
JSUnaryCode mCode;
JSUnaryOperator(JSUnaryCode code) : mCode(code) {}
virtual bool isNative() { return true; }
void* operator new(size_t) { return allocator::allocate(1); }
};
class JSBinaryOperator : public JSFunction {
typedef JavaScript::gc_traits_finalizable<JSBinaryOperator> traits;
typedef gc_allocator<JSBinaryOperator, traits> allocator;
public:
typedef JSValue (*JSBinaryCode)(Context *cx, const JSValue& arg1, const JSValue& arg2);
JSBinaryCode mCode;
JSBinaryOperator(JSBinaryCode code) : mCode(code) {}
virtual bool isNative() { return true; }
void* operator new(size_t) { return allocator::allocate(1); }
};
class JSClosure : public JSFunction {
Interpreter::Activation *mActivation;
JSClosure *mPrevious;
typedef JavaScript::gc_traits_finalizable<JSClosure> traits;
typedef gc_allocator<JSClosure, traits> allocator;
public:
JSClosure(ICodeModule* iCode, Interpreter::Activation *activation, JSClosure *previous)
: JSFunction(iCode), mActivation(activation), mPrevious(previous) {}
JSClosure* getPrevious() { return mPrevious; }
Interpreter::Activation* getActivation() { return mActivation; }
void* operator new(size_t) { return allocator::allocate(1); }
};
/**
* Provides a set of nested scopes.
*/
class JSScope : public JSObject {
protected:
JSScope* mParent;
JSProperties mTypes;
public:
JSScope(JSScope* parent = 0, JSObject* prototype = 0)
: mParent(parent)
{
if (prototype)
setPrototype(prototype);
}
JSScope* getParent()
{
return mParent;
}
bool isDefined(const String& name)
{
if (hasProperty(name))
return true;
if (mParent)
return mParent->isDefined(name);
return false;
}
const JSValue& getVariable(const String& name)
{
const JSValue& ret = getProperty(name);
if (ret.isUndefined() && mParent)
return mParent->getVariable(name);
return ret;
}
JSValue& setVariable(const String& name, const JSValue& value)
{
return (mProperties[name] = value);
}
JSValue& defineVariable(const String& name, JSType* type, const JSValue& value)
{
if (type != &Object_Type)
mTypes[name] = type;
return (mProperties[name] = value);
}
JSValue& defineVariable(const String& name, JSType* type)
{
if (type != &Object_Type)
mTypes[name] = type;
return (mProperties[name] = kUndefinedValue);
}
void setType(const String& name, JSType* type)
{
// only type variables that are defined in this scope.
JSProperties::iterator i = mProperties.find(name);
if (i != mProperties.end())
mTypes[name] = type;
else
if (mParent)
mParent->setType(name, type);
}
JSType* getType(const String& name)
{
JSType* result = &Object_Type;
// only consider types for variables defined in this scope.
JSProperties::const_iterator i = mProperties.find(name);
if (i != mProperties.end()) {
i = mTypes.find(name);
if (i != mTypes.end())
result = i->second.type;
} else {
// see if variable is defined in parent scope.
if (mParent)
result = mParent->getType(name);
}
return result;
}
JSValue& defineFunction(const String& name, ICodeModule* iCode)
{
JSValue value(new JSFunction(iCode));
return defineVariable(name, &Function_Type, value);
}
JSValue& defineNativeFunction(const String& name, JSNativeFunction::JSCode code)
{
JSValue value(new JSNativeFunction(code));
return defineVariable(name, &Function_Type, value);
}
};
class JSType : public JSObject {
protected:
String mName;
JSType *mBaseType;
// The constructor is an implementation of the [[Construct]] mechanism
JSFunction *mConstructor;
// The invokor is an implementation of the [[Call]] mechanism
JSFunction *mInvokor;
public:
JSType() { }
JSType(const String &name, JSType *baseType) : mName(name), mBaseType(baseType), mConstructor(NULL), mInvokor(NULL)
{
mType = &Type_Type;
}
JSType(const String &name, JSType *baseType, JSFunction *constructor, JSFunction *invokor = NULL)
: mName(name), mBaseType(baseType), mConstructor(constructor), mInvokor(invokor)
{
mType = &Type_Type;
}
enum { NoRelation = 0x7FFFFFFF };
const String& getName() const { return mName; }
bool isSubTypeOf(const JSType *other) const;
int32 distance(const JSType *other) const;
JSFunction *getConstructor() const { return mConstructor; }
JSFunction *getInvokor() const { return mInvokor; }
};
class JSBoolean : public JSObject {
protected:
bool mValue;
static JSObject* BooleanPrototypeObject;
static JSString* BooleanString;
public:
JSBoolean(bool value) : JSObject(BooleanPrototypeObject), mValue(value) { setClass(BooleanString); }
static void initBooleanObject(JSScope *g);
bool getValue() { return mValue; }
};
} /* namespace JSTypes */
} /* namespace JavaScript */
#endif /* jstypes_h */

View File

@@ -1,95 +0,0 @@
/* -*- 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 <cstdlib>
#include <cstring>
#include "utilities.h"
#ifdef WIN32
#include <windows.h>
#endif
#ifdef XP_MAC
#include <cstdarg>
#include <Types.h>
#endif
namespace JS = JavaScript;
//
// Input
//
//
// Output
//
//
// Static Initializers
//
#ifndef _WIN32
static void jsNewHandler()
{
std::bad_alloc outOfMemory;
throw outOfMemory;
}
struct InitUtilities
{
InitUtilities() {std::set_new_handler(&jsNewHandler);}
};
#else
#include <new.h>
static int jsNewHandler(size_t)
{
std::bad_alloc outOfMemory;
throw outOfMemory;
}
struct InitUtilities
{
InitUtilities() {_set_new_handler(&jsNewHandler);}
};
#endif
InitUtilities initUtilities;

View File

@@ -1,133 +0,0 @@
/* -*- 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 kitchensink_h___
#define kitchensink_h___
#include <memory>
#include <new>
#include <string>
#include <iterator>
#include <algorithm>
#include <cstdio>
#include <cstdarg>
#include "stlcfg.h"
#include "systemtypes.h"
#include "strings.h"
#include "mem.h"
namespace JavaScript {
//
// Alignment
//
template<typename T>
struct AlignmentHelper {
char ch;
T t;
};
#define ALIGNMENT_OF(T) offsetof(JavaScript::AlignmentHelper<T>, t)
// Assign zero to n elements starting at first.
// This is equivalent ot fill_n(first, n, 0) but may be more efficient.
template<class ForwardIterator, class Size>
inline void zero_n(ForwardIterator first, Size n)
{
while (n) {
*first = 0;
++first;
--n;
}
}
//
// Linked Lists
//
// In some cases it is desirable to manipulate ordinary C-style linked lists as though
// they were STL-like sequences. These classes define STL forward iterators that walk
// through singly-linked lists of objects threaded through fields named 'next'. The type
// parameter E must be a class that has a member named 'next' whose type is E* or const E*.
template <class E>
class ListIterator: public std::iterator<std::forward_iterator_tag, E> {
E *element;
public:
ListIterator() {}
explicit ListIterator(E *e): element(e) {}
E &operator*() const {return *element;}
E *operator->() const {return element;}
ListIterator &operator++() {element = element->next; return *this;}
ListIterator operator++(int) {ListIterator i(*this); element = element->next; return i;}
friend bool operator==(const ListIterator &i, const ListIterator &j) {return i.element == j.element;}
friend bool operator!=(const ListIterator &i, const ListIterator &j) {return i.element != j.element;}
};
template <class E>
#ifndef _WIN32 // Microsoft VC6 bug: std::iterator should support five template arguments
class ConstListIterator: public std::iterator<std::forward_iterator_tag, E, ptrdiff_t, const E*, const E&> {
#else
class ConstListIterator: public std::iterator<std::forward_iterator_tag, E, ptrdiff_t> {
#endif
const E *element;
public:
ConstListIterator() {}
ConstListIterator(const ListIterator<E> &i): element(&*i) {}
explicit ConstListIterator(const E *e): element(e) {}
const E &operator*() const {return *element;}
const E *operator->() const {return element;}
ConstListIterator &operator++() {element = element->next; return *this;}
ConstListIterator operator++(int) {ConstListIterator i(*this); element = element->next; return i;}
friend bool operator==(const ConstListIterator &i, const ConstListIterator &j) {return i.element == j.element;}
friend bool operator!=(const ConstListIterator &i, const ConstListIterator &j) {return i.element != j.element;}
};
//
// Input
//
}
#endif /* kitchensink_h___ */

View File

@@ -1,717 +0,0 @@
/* -*- 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 "numerics.h"
#include "lexer.h"
namespace JS = JavaScript;
// Create a new Lexer for lexing the provided source code. The Lexer will
// intern identifiers, keywords, and regular expressions in the designated
// world.
JS::Lexer::Lexer(World &world, const String &source, const String &sourceLocation, uint32 initialLineNum):
world(world), reader(source, sourceLocation, initialLineNum)
{
nextToken = tokens;
nTokensFwd = 0;
#ifdef DEBUG
nTokensBack = 0;
#endif
lexingUnit = false;
}
// Skip past the next token, which must have been either peeked or read and then unread.
// skip is faster than get but must not be called if the next token has not been seen yet.
void JS::Lexer::skip()
{
ASSERT(nTokensFwd);
if (++nextToken == tokens + tokenBufferSize)
nextToken = tokens;
--nTokensFwd;
DEBUG_ONLY(++nTokensBack);
}
// Get and return the next token. The token remains valid until the next
// call to this Lexer. If the Reader reached the end of file, return a
// Token whose Kind is end. The caller may alter the value of this Token
// (in particular, take control over the auto_ptr's data), but if it does so,
// the caller is not allowed to unget this Token.
//
// If preferRegExp is true, a / will be preferentially interpreted as
// starting a regular expression; otherwise, a / will be preferentially
// interpreted as division or /=.
const JS::Token &JS::Lexer::get(bool preferRegExp)
{
const Token &t = peek(preferRegExp);
if (++nextToken == tokens + tokenBufferSize)
nextToken = tokens;
--nTokensFwd;
DEBUG_ONLY(++nTokensBack);
return t;
}
// Peek at the next token using the given preferRegExp setting. If that
// token's kind matches the given kind, consume that token and return it.
// Otherwise, do not consume that token and return nil.
const JS::Token *JS::Lexer::eat(bool preferRegExp, Token::Kind kind)
{
const Token &t = peek(preferRegExp);
if (t.kind != kind)
return 0;
if (++nextToken == tokens + tokenBufferSize)
nextToken = tokens;
--nTokensFwd;
DEBUG_ONLY(++nTokensBack);
return &t;
}
// Return the next token without consuming it.
//
// If preferRegExp is true, a / will be preferentially interpreted as
// starting a regular expression; otherwise, a / will be preferentially
// interpreted as division or /=. A subsequent call to peek or get will
// return the same token; that call must be presented with the same value
// for preferRegExp.
const JS::Token &JS::Lexer::peek(bool preferRegExp)
{
// Use an already looked-up token if there is one.
if (nTokensFwd) {
ASSERT(savedPreferRegExp[nextToken - tokens] == preferRegExp);
} else {
lexToken(preferRegExp);
nTokensFwd = 1;
#ifdef DEBUG
savedPreferRegExp[nextToken - tokens] = preferRegExp;
if (nTokensBack == tokenLookahead) {
nTokensBack = tokenLookahead-1;
if (tokenGuard)
(nextToken >= tokens+tokenLookahead ?
nextToken-tokenLookahead :
nextToken+tokenBufferSize-tokenLookahead)->valid = false;
}
#endif
}
return *nextToken;
}
#ifdef DEBUG
// Change the setting of preferRegExp for an already peeked token.
// The token must not be one for which that setting mattered.
//
// THIS IS A DANGEROUS FUNCTION!
// Use it only if you can be prove that the already peeked token does not
// start with a slash.
void JS::Lexer::redesignate(bool preferRegExp)
{
if (nTokensFwd) {
ASSERT(savedPreferRegExp[nextToken - tokens] != preferRegExp);
ASSERT(!(nextToken->hasKind(Token::regExp) ||
nextToken->hasKind(Token::divide) ||
nextToken->hasKind(Token::divideEquals)));
savedPreferRegExp[nextToken - tokens] = preferRegExp;
}
}
#endif
// Unread the last token. This call may be called to unread at most
// tokenBufferSize tokens at a time (where a peek also counts as temporarily
// reading and unreading one token). When a token that has been unread is
// peeked or read again, the same value must be passed in preferRegExp as for
// the first time that token was read or peeked.
void JS::Lexer::unget()
{
ASSERT(nTokensBack--);
nTokensFwd++;
if (nextToken == tokens)
nextToken = tokens + tokenBufferSize;
--nextToken;
}
// Report a syntax error at the backUp-th last character read by the Reader.
// In other words, if backUp is 0, the error is at the next character to be
// read by the Reader; if backUp is 1, the error is at the last character
// read by the Reader, and so forth.
void JS::Lexer::syntaxError(const char *message, uint backUp)
{
reader.unget(backUp);
reader.error(Exception::syntaxError, widenCString(message), reader.getPos());
}
// Get the next character from the reader, skipping any Unicode format-control
// (Cf) characters.
inline char16 JS::Lexer::getChar()
{
char16 ch = reader.get();
if (char16Value(ch) >= firstFormatChar)
ch = internalGetChar(ch);
return ch;
}
// Helper for getChar()
char16 JS::Lexer::internalGetChar(char16 ch)
{
while (isFormat(ch))
ch = reader.get();
return ch;
}
// Peek the next character from the reader, skipping any Unicode
// format-control (Cf) characters, which are read and discarded.
inline char16 JS::Lexer::peekChar()
{
char16 ch = reader.peek();
if (char16Value(ch) >= firstFormatChar)
ch = internalPeekChar(ch);
return ch;
}
// Helper for peekChar()
char16 JS::Lexer::internalPeekChar(char16 ch)
{
while (isFormat(ch)) {
reader.get();
ch = reader.peek();
}
return ch;
}
// Peek the next character from the reader, skipping any Unicode
// format-control (Cf) characters, which are read and discarded. If the
// peeked character matches ch, read that character and return true;
// otherwise return false. ch must not be null.
bool JS::Lexer::testChar(char16 ch)
{
ASSERT(ch); // If ch were null, it could match the eof null.
char16 ch2 = peekChar();
if (ch == ch2) {
reader.get();
return true;
}
return false;
}
// A backslash has been read. Read the rest of the escape code.
// Return the interpreted escaped character. Throw an exception if the
// escape is not valid. If unicodeOnly is true, allow only \uxxxx escapes.
char16 JS::Lexer::lexEscape(bool unicodeOnly)
{
char16 ch = getChar();
int nDigits;
if (!unicodeOnly || ch == 'u')
switch (ch) {
case '0':
// Make sure that the next character isn't a digit.
ch = peekChar();
if (!isASCIIDecimalDigit(ch))
return 0x00;
// Point to the next character in the error message
getChar();
break;
case 'b':
return 0x08;
case 'f':
return 0x0C;
case 'n':
return 0x0A;
case 'r':
return 0x0D;
case 't':
return 0x09;
case 'v':
return 0x0B;
case 'x':
nDigits = 2;
goto lexHex;
case 'u':
nDigits = 4;
lexHex:
{
uint32 n = 0;
while (nDigits--) {
ch = getChar();
uint digit;
if (!isASCIIHexDigit(ch, digit))
goto error;
n = (n << 4) | digit;
}
return static_cast<char16>(n);
}
default:
if (!reader.getEof(ch)) {
CharInfo chi(ch);
if (!isAlphanumeric(chi) && !isLineBreak(chi))
return ch;
}
}
error:
syntaxError("Bad escape code");
return 0;
}
// Read an identifier into s. The initial value of s is ignored and cleared.
// Return true if an escape code has been encountered.
// If allowLeadingDigit is true, allow the first character of s to be a digit,
// just like any continuing identifier character.
bool JS::Lexer::lexIdentifier(String &s, bool allowLeadingDigit)
{
reader.beginRecording(s);
bool hasEscape = false;
while (true) {
char16 ch = getChar();
char16 ch2 = ch;
if (ch == '\\') {
ch2 = lexEscape(true);
hasEscape = true;
}
CharInfo chi2(ch2);
if (!(allowLeadingDigit ? isIdContinuing(chi2) :
isIdLeading(chi2))) {
if (ch == '\\')
syntaxError("Identifier escape expands into non-identifier character");
else
reader.unget();
break;
}
reader.recordChar(ch2);
allowLeadingDigit = true;
}
reader.endRecording();
return hasEscape;
}
// Read a numeric literal into nextToken->chars and nextToken->value.
// Return true if the numeric literal is followed by a unit, but don't read
// the unit yet.
bool JS::Lexer::lexNumeral()
{
int hasDecimalPoint = 0;
String &s = nextToken->chars;
uint digit;
reader.beginRecording(s);
char16 ch = getChar();
if (ch == '0') {
reader.recordChar('0');
ch = getChar();
if ((ch&~0x20) == 'X') {
size_t pos = reader.getPos();
char16 ch2 = getChar();
if (isASCIIHexDigit(ch2, digit)) {
reader.recordChar(ch);
do {
reader.recordChar(ch2);
ch2 = getChar();
} while (isASCIIHexDigit(ch2, digit));
ch = ch2;
} else
reader.setPos(pos);
goto done;
} else if (isASCIIDecimalDigit(ch)) {
syntaxError("Numeric constant syntax error");
}
}
while (isASCIIDecimalDigit(ch) || ch == '.' && !hasDecimalPoint++) {
reader.recordChar(ch);
ch = getChar();
}
if ((ch&~0x20) == 'E') {
size_t pos = reader.getPos();
char16 ch2 = getChar();
char16 sign = 0;
if (ch2 == '+' || ch2 == '-') {
sign = ch2;
ch2 = getChar();
}
if (isASCIIDecimalDigit(ch2)) {
reader.recordChar(ch);
if (sign)
reader.recordChar(sign);
do {
reader.recordChar(ch2);
ch2 = getChar();
} while (isASCIIDecimalDigit(ch2));
ch = ch2;
} else
reader.setPos(pos);
}
done:
// At this point the reader is just past the character ch, which
// is the first non-formatting character that is not part of the
// number.
reader.endRecording();
const char16 *sBegin = s.data();
const char16 *sEnd = sBegin + s.size();
const char16 *numEnd;
nextToken->value = stringToDouble(sBegin, sEnd, numEnd);
ASSERT(numEnd == sEnd);
reader.unget();
ASSERT(ch == reader.peek());
return isIdContinuing(ch) || ch == '\\';
}
// Read a string literal into s. The initial value of s is ignored and
// cleared. The opening quote has already been read into separator.
void JS::Lexer::lexString(String &s, char16 separator)
{
char16 ch;
reader.beginRecording(s);
while ((ch = reader.get()) != separator) {
CharInfo chi(ch);
if (!isFormat(chi)) {
if (ch == '\\')
ch = lexEscape(false);
else if (reader.getEof(ch) || isLineBreak(chi))
syntaxError("Unterminated string literal");
reader.recordChar(ch);
}
}
reader.endRecording();
}
// Read a regular expression literal. Store the regular expression in
// nextToken->id and the flags in nextToken->chars.
// The opening slash has already been read.
void JS::Lexer::lexRegExp()
{
String s;
char16 prevCh = 0;
reader.beginRecording(s);
while (true) {
char16 ch = getChar();
CharInfo chi(ch);
if (reader.getEof(ch) || isLineBreak(chi))
syntaxError("Unterminated regular expression literal");
if (prevCh == '\\') {
reader.recordChar(ch);
// Ignore slashes and backslashes immediately after a backslash
prevCh = 0;
} else if (ch != '/') {
reader.recordChar(ch);
prevCh = ch;
} else
break;
}
reader.endRecording();
nextToken->id = &world.identifiers[s];
lexIdentifier(nextToken->chars, true);
}
// Read a token from the Reader and store it at *nextToken.
// If the Reader reached the end of file, store a Token whose Kind is end.
void JS::Lexer::lexToken(bool preferRegExp)
{
Token &t = *nextToken;
t.lineBreak = false;
t.id = 0;
// Don't really need to waste time clearing this string here
//clear(t.chars);
Token::Kind kind;
if (lexingUnit) {
lexIdentifier(t.chars, false);
ASSERT(t.chars.size());
kind = Token::unit; // unit
lexingUnit = false;
} else {
next:
char16 ch = reader.get();
if (reader.getEof(ch)) {
endOfInput:
t.pos = reader.getPos() - 1;
kind = Token::end;
} else {
char16 ch2;
CharInfo chi(ch);
switch (cGroup(chi)) {
case CharInfo::FormatGroup:
case CharInfo::WhiteGroup:
goto next;
case CharInfo::IdGroup:
t.pos = reader.getPos() - 1;
readIdentifier:
{
reader.unget();
String s;
bool hasEscape = lexIdentifier(s, false);
t.id = &world.identifiers[s];
kind = hasEscape ? Token::identifier : t.id->tokenKind;
}
break;
case CharInfo::NonIdGroup:
case CharInfo::IdContinueGroup:
t.pos = reader.getPos() - 1;
switch (ch) {
case '(':
kind = Token::openParenthesis; // (
break;
case ')':
kind = Token::closeParenthesis; // )
break;
case '[':
kind = Token::openBracket; // [
break;
case ']':
kind = Token::closeBracket; // ]
break;
case '{':
kind = Token::openBrace; // {
break;
case '}':
kind = Token::closeBrace; // }
break;
case ',':
kind = Token::comma; // ,
break;
case ';':
kind = Token::semicolon; // ;
break;
case '.':
kind = Token::dot; // .
ch2 = getChar();
if (isASCIIDecimalDigit(ch2)) {
reader.setPos(t.pos);
goto number; // decimal point
} else if (ch2 == '.') {
kind = Token::doubleDot; // ..
if (testChar('.'))
kind = Token::tripleDot;// ...
} else
reader.unget();
break;
case ':':
kind = Token::colon; // :
if (testChar(':'))
kind = Token::doubleColon; // ::
break;
case '#':
kind = Token::pound; // #
break;
case '@':
kind = Token::at; // @
break;
case '?':
kind = Token::question; // ?
break;
case '~':
kind = Token::complement; // ~
break;
case '!':
kind = Token::logicalNot; // !
if (testChar('=')) {
kind = Token::notEqual; // !=
if (testChar('='))
kind = Token::notIdentical; // !==
}
break;
case '*':
kind = Token::times; // * *=
tryAssignment:
if (testChar('='))
kind = Token::Kind(kind + Token::timesEquals - Token::times);
break;
case '/':
kind = Token::divide; // /
ch = getChar();
if (ch == '/') { // // comment
do {
ch = reader.get();
if (reader.getEof(ch))
goto endOfInput;
} while (!isLineBreak(ch));
goto endOfLine;
} else if (ch == '*') { // /*comment*/
ch = 0;
do {
ch2 = ch;
ch = getChar();
if (isLineBreak(ch)) {
reader.beginLine();
t.lineBreak = true;
} else if (reader.getEof(ch))
syntaxError("Unterminated /* comment");
} while (ch != '/' || ch2 != '*');
goto next;
} else {
reader.unget();
if (preferRegExp) { // Regular expression
kind = Token::regExp;
lexRegExp();
} else
goto tryAssignment; // /=
}
break;
case '%':
kind = Token::modulo; // %
goto tryAssignment; // %=
case '+':
kind = Token::plus; // +
if (testChar('+'))
kind = Token::increment; // ++
else
goto tryAssignment; // +=
break;
case '-':
kind = Token::minus; // -
ch = getChar();
if (ch == '-')
kind = Token::decrement; // --
else if (ch == '>')
kind = Token::arrow; // ->
else {
reader.unget();
goto tryAssignment; // -=
}
break;
case '&':
kind = Token::bitwiseAnd; // & && &= &&=
logical:
if (testChar(ch))
kind = Token::Kind(kind - Token::bitwiseAnd + Token::logicalAnd);
goto tryAssignment;
case '^':
kind = Token::bitwiseXor; // ^ ^^ ^= ^^=
goto logical;
case '|':
kind = Token::bitwiseOr; // | || |= ||=
goto logical;
case '=':
kind = Token::assignment; // =
if (testChar('=')) {
kind = Token::equal; // ==
if (testChar('='))
kind = Token::identical; // ===
}
break;
case '<':
kind = Token::lessThan; // <
if (testChar('<')) {
kind = Token::leftShift; // <<
goto tryAssignment; // <<=
}
comparison:
if (testChar('=')) // <= >=
kind = Token::Kind(kind + Token::lessThanOrEqual - Token::lessThan);
break;
case '>':
kind = Token::greaterThan; // >
if (testChar('>')) {
kind = Token::rightShift; // >>
if (testChar('>'))
kind = Token::logicalRightShift; // >>>
goto tryAssignment; // >>= >>>=
}
goto comparison;
case '\\':
goto readIdentifier; // An identifier that starts with an escape
case '\'':
case '"':
kind = Token::string; // 'string' "string"
lexString(t.chars, ch);
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
reader.unget(); // Number
number:
kind = Token::number;
lexingUnit = lexNumeral();
break;
default:
syntaxError("Bad character");
}
break;
case CharInfo::LineBreakGroup:
endOfLine:
reader.beginLine();
t.lineBreak = true;
goto next;
}
}
}
t.kind = kind;
#ifdef DEBUG
t.valid = true;
#endif
}

View File

@@ -1,105 +0,0 @@
/* -*- 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 lexer_h___
#define lexer_h___
#include "utilities.h"
#include "formatter.h"
#include "reader.h"
#include "token.h"
#include "world.h"
namespace JavaScript
{
class Lexer {
enum {tokenLookahead = 2}; // Number of tokens that can be simultaneously live
#ifdef DEBUG
enum {tokenGuard = 10}; // Number of invalid tokens added to circular token buffer to catch references to old tokens
#else
enum {tokenGuard = 0}; // Number of invalid tokens added to circular token buffer to catch references to old tokens
#endif
// Token lookahead buffer size
enum {tokenBufferSize = tokenLookahead + tokenGuard};
Token tokens[tokenBufferSize]; // Circular buffer of recently read or lookahead tokens
Token *nextToken; // Address of next Token in the circular buffer to be returned by get()
int nTokensFwd; // Net number of Tokens on which unget() has been called; these Tokens are ahead of nextToken
#ifdef DEBUG
int nTokensBack; // Number of Tokens on which unget() can be called; these Tokens are beind nextToken
bool savedPreferRegExp[tokenBufferSize]; // Circular buffer of saved values of preferRegExp to get() calls
#endif
bool lexingUnit; // True if lexing a unit identifier immediately following a number
public:
World &world;
Reader reader;
Lexer(World &world, const String &source, const String &sourceLocation, uint32 initialLineNum = 1);
void skip();
const Token &get(bool preferRegExp);
const Token *eat(bool preferRegExp, Token::Kind kind);
const Token &peek(bool preferRegExp);
void redesignate(bool preferRegExp);
void unget();
size_t getPos() const;
private:
void syntaxError(const char *message, uint backUp = 1);
char16 getChar();
char16 internalGetChar(char16 ch);
char16 peekChar();
char16 internalPeekChar(char16 ch);
bool testChar(char16 ch);
char16 lexEscape(bool unicodeOnly);
bool lexIdentifier(String &s, bool allowLeadingDigit);
bool lexNumeral();
void lexString(String &s, char16 separator);
void lexRegExp();
void lexToken(bool preferRegExp);
};
#ifndef DEBUG
inline void Lexer::redesignate(bool) {} // See description for the DEBUG version inside lexer.cpp
#endif
// Return the position of the first character of the next token, which must have been peeked.
inline size_t Lexer::getPos() const
{
ASSERT(nTokensFwd);
return nextToken->getPos();
}
}
#endif /* lexer_h___ */

Some files were not shown because too many files have changed in this diff Show More