This is a copy of regalloc_code2_BRANCH from Netscape's private repository,

as it existed in January of 1998.


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

mozilla/ef/Compiler/RegisterAllocator/BitSet.cpp

@@ -0,0 +1,134 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "BitSet.h"
+
+// Return the next bit after index set to true or -1 if none.
+//
+Int32 BitSet::nextOne(Int32 pos) const
+{
+	++pos;
+
+	if (pos < 0 || Uint32(pos) >= universeSize)
+		return -1;
+
+	Uint32 offset = getWordOffset(pos);
+	Uint8 index = getBitOffset(pos);
+	Word* ptr = &word[offset];
+	Word currentWord = *ptr++ >> index;
+	
+	if (currentWord != Word(0)) {
+		while ((currentWord & Word(1)) == 0) {
+			++index;
+			currentWord >>= 1;
+		}
+		return (offset << nBitsInWordLog2) + index;
+	}
+
+	Word* limit = &word[getSizeInWords(universeSize)];
+	while (ptr < limit) {
+		++offset;
+		currentWord = *ptr++;
+		if (currentWord != Word(0)) {
+			index = 0;
+			while ((currentWord & Word(1)) == 0) {
+				++index;
+				currentWord >>= 1;
+			}
+			return (offset << nBitsInWordLog2) + index;
+		}
+	}
+	return -1;
+}
+
+// Return the next bit after index set to false or -1 if none.
+//
+Int32 BitSet::nextZero(Int32 pos) const
+{
+	++pos;
+
+	if (pos < 0 || Uint32(pos) >= universeSize)
+		return -1;
+
+	Uint32 offset = getWordOffset(pos);
+	Uint8 index = getBitOffset(pos);
+	Word* ptr = &word[offset];
+	Word currentWord = *ptr++ >> index;
+	
+	if (currentWord != Word(~0)) {
+		for (; index < nBitsInWord; ++index) {
+			if ((currentWord & Word(1)) == 0) {
+				Int32 ret = (offset << nBitsInWordLog2) + index;
+				return (Uint32(ret) < universeSize) ? ret : -1;
+			}
+			currentWord >>= 1;
+		}
+	}
+
+	Word* limit = &word[getSizeInWords(universeSize)];
+	while (ptr < limit) {
+		++offset;
+		currentWord = *ptr++;
+		if (currentWord != Word(~0)) {
+			for (index = 0; index < nBitsInWord; ++index) {
+				if ((currentWord & Word(1)) == 0) {
+					Int32 ret = (offset << nBitsInWordLog2) + index;
+					return (Uint32(ret) < universeSize) ? ret : -1;
+				}
+				currentWord >>= 1;
+			}
+		}
+	}
+	return -1;
+}
+
+#ifdef DEBUG_LOG
+
+// Print the set.
+//
+void BitSet::printPretty(LogModuleObject log)
+{
+	UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("[ "));
+
+	for (Int32 i = firstOne(); i != -1; i = nextOne(i)) {
+		Int32 currentBit = i;
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("%d", currentBit));
+
+		Int32 nextBit = nextOne(currentBit);
+		if (nextBit != currentBit + 1) {
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, (" "));
+			continue;
+		}
+		  
+		while ((nextBit != -1) && (nextBit == (currentBit + 1))) {
+			currentBit = nextBit;
+			nextBit = nextOne(nextBit);
+		}
+
+		if (currentBit > (i+1))
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("-%d ", currentBit));
+		else
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, (" %d ", currentBit));
+
+		i = currentBit;
+	}
+	UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("]\n"));
+}
+
+#endif // DEBUG_LOG

mozilla/ef/Compiler/RegisterAllocator/BitSet.h

@@ -0,0 +1,195 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _BITSET_H_
+#define _BITSET_H_
+
+#include "Fundamentals.h"
+#include "LogModule.h"
+#include "Pool.h"
+#include <string.h>
+
+//------------------------------------------------------------------------------
+// BitSet -
+
+class BitSet
+{
+private:
+
+#if (PR_BITS_PER_WORD == 64)
+	typedef Uint64 Word;
+#elif (PR_BITS_PER_WORD == 32)
+	typedef Uint32 Word;
+#endif
+
+	static const nBitsInWord = 		PR_BITS_PER_WORD;
+	static const nBytesInWord = 	PR_BYTES_PER_WORD;
+	static const nBitsInWordLog2 =	PR_BITS_PER_WORD_LOG2;
+	static const nBytesInWordLog2 = PR_BYTES_PER_WORD_LOG2;
+
+	// Return the number of Word need to store the universe.
+	static Uint32 getSizeInWords(Uint32 sizeOfUniverse) {return (sizeOfUniverse + (nBitsInWord - 1)) >> nBitsInWordLog2;}
+	// Return the given element offset in its containing Word.
+	static Uint32 getBitOffset(Uint32 element) {return element & (nBitsInWord - 1);}
+	// Return the Word offset for the given element int the universe.
+	static Uint32 getWordOffset(Uint32 element) {return element >> nBitsInWordLog2;}
+	// Return the mask for the given bit index.
+	static Word getMask(Uint8 index) {return Word(1) << index;}
+	
+private:
+
+	Uint32							universeSize;			// Size of the universe
+	Word*							word;					// universe memory.
+
+private:
+
+	// No copy constructor.
+	BitSet(const BitSet&);
+
+	// Check if the given set's universe is of the same size than this universe.
+	void checkUniverseCompatibility(const BitSet& set) const {assert(set.universeSize == universeSize);}
+	// Check if pos is valid for this set's universe.
+	void checkMember(Int32 pos) const {assert(pos >=0 && Uint32(pos) < universeSize);}
+
+public:
+
+	// Create a bitset of universeSize bits.
+	BitSet(Pool& pool, Uint32 universeSize) : universeSize(universeSize) {word = new(pool) Word[getSizeInWords(universeSize)]; clear();}
+
+	// Return the size of this bitset.
+	Uint32 getSize() const {return universeSize;}
+
+	// Clear the bitset.
+	void clear() {memset(word, 0x00, getSizeInWords(universeSize) << nBytesInWordLog2);}
+	// Clear the bit at index.
+	void clear(Uint32 index) {checkMember(index); word[getWordOffset(index)] &= ~getMask(index);}
+	// Set the bitset.
+	void set() {memset(word, 0xFF, getSizeInWords(universeSize) << nBytesInWordLog2);}
+	// Set the bit at index.
+	void set(Uint32 index) {checkMember(index); word[getWordOffset(index)] |= getMask(index);}
+	// Return true if the bit at index is set.
+	bool test(Uint32 index) const {checkMember(index); return (word[getWordOffset(index)] & getMask(index)) != 0;}
+	// Union with the given bitset.
+	inline void or(const BitSet& set);
+	// Intersection with the given bitset.
+	inline void and(const BitSet& set);
+	// Difference with the given bitset.
+	inline void difference(const BitSet& set);
+	// Copy set.
+	inline BitSet& operator = (const BitSet& set);
+	// Return true if the bitset are identical.
+	friend bool operator == (const BitSet& set1, const BitSet& set2);
+	// Return true if the bitset are different.
+	friend bool operator != (const BitSet& set1, const BitSet& set2);
+
+	// Logical operators.
+	BitSet& operator |= (const BitSet& set) {or(set); return *this;}
+	BitSet& operator &= (const BitSet& set) {and(set); return *this;}
+	BitSet& operator -= (const BitSet& set) {difference(set); return *this;}
+
+	// Return the first bit at set to true or -1 if none.
+	Int32 firstOne() const {return nextOne(-1);}
+	// Return the next bit after index set to true or -1 if none.
+	Int32 nextOne(Int32 pos) const;
+	// Return the first bit at set to false or -1 if none.
+	Int32 firstZero() const {return nextZero(-1);}
+	// Return the next bit after index set to false or -1 if none.
+	Int32 nextZero(Int32 pos) const;
+
+	// Iterator to conform with the set API.
+	typedef Int32 iterator;
+	// Return true if the walk is ordered.
+	static bool isOrdered() {return true;}
+	// Return the iterator for the first element of this set.
+	iterator begin() const {return firstOne();}
+	// Return the next iterator.
+	iterator advance(iterator pos) const {return nextOne(pos);}
+	// Return true if the iterator is at the end of the set.
+	bool done(iterator pos) const {return pos == -1;}
+	// Return the element corresponding to the given iterator.
+	Uint32 get(iterator pos) const {return pos;}
+
+#ifdef DEBUG_LOG
+	// Print the set.
+	void printPretty(LogModuleObject log);
+#endif // DEBUG_LOG
+};
+
+// Union with the given bitset.
+//
+inline void  BitSet::or(const BitSet& set)
+{
+	checkUniverseCompatibility(set);
+	Word* src = set.word;
+	Word* dst = word;
+	Word* limit = &src[getSizeInWords(universeSize)];
+
+	while (src < limit)
+		*dst++ |= *src++;
+}
+
+// Intersection with the given bitset.
+//
+inline void  BitSet::and(const BitSet& set)
+{
+	checkUniverseCompatibility(set);
+	Word* src = set.word;
+	Word* dst = word;
+	Word* limit = &src[getSizeInWords(universeSize)];
+
+	while (src < limit)
+		*dst++ &= *src++;
+}
+
+// Difference with the given bitset.
+//
+inline void BitSet::difference(const BitSet& set)
+{
+	checkUniverseCompatibility(set);
+	Word* src = set.word;
+	Word* dst = word;
+	Word* limit = &src[getSizeInWords(universeSize)];
+
+	while (src < limit)
+		*dst++ &= ~*src++;
+}
+
+// Copy the given set into this set.
+//
+inline BitSet& BitSet::operator = (const BitSet& set)
+{
+	checkUniverseCompatibility(set);
+	if (this != &set)
+		memcpy(word, set.word, getSizeInWords(universeSize) << nBytesInWordLog2);
+	return *this;
+}
+
+// Return true if the given set is identical to this set.
+inline bool operator == (const BitSet& set1, const BitSet& set2)
+{
+	set1.checkUniverseCompatibility(set2);
+
+	if (&set1 == &set2)
+		return true;
+
+	return memcmp(set1.word, set2.word, BitSet::getSizeInWords(set1.universeSize) << BitSet::nBytesInWordLog2) == 0;
+}
+
+inline bool operator != (const BitSet& set1, const BitSet& set2) {return !(set1 == set2);}
+
+#endif // _BITSET_H

mozilla/ef/Compiler/RegisterAllocator/Coalescing.h

@@ -0,0 +1,159 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _COALESCING_H_
+#define _COALESCING_H_
+
+#include "Fundamentals.h"
+#include "Pool.h"
+#include "RegisterPressure.h"
+#include "InterferenceGraph.h"
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+#include "Instruction.h"
+#include "SparseSet.h"
+#include "RegisterAllocator.h"
+#include "RegisterAllocatorTools.h"
+
+#if 1
+// Performing an ultra conservative coalescing meens that when we look at
+// candidates (source,destination) for coalescing we need to make sure
+// that the combined interference of the source and destination register
+// will not exceed the total number of register available for the register
+// class. 
+#define ULTRA_CONSERVATIVE_COALESCING
+#else
+// If we are not doing an ultra conservative coalescing we have to make sure 
+// that the total number of neighbor whose degree is greater than the total 
+// number of register is not greater than the total number of register.
+#undef ULTRA_CONSERVATIVE_COALESCING
+#endif
+
+template <class RegisterPressure>
+struct Coalescing
+{
+	static bool coalesce(RegisterAllocator& registerAllocator);
+};
+
+template <class RegisterPressure>
+bool Coalescing<RegisterPressure>::coalesce(RegisterAllocator& registerAllocator)
+{
+	Pool& pool = registerAllocator.pool;
+
+   	// Initialize the lookup table
+	//
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	RegisterName* newRange = new RegisterName[2 * rangeCount];
+	RegisterName* coalescedRange = &newRange[rangeCount];
+	RegisterName* name2range = registerAllocator.name2range;
+
+	init(coalescedRange, rangeCount);
+
+	SparseSet interferences(pool, rangeCount);
+	InterferenceGraph<RegisterPressure>& iGraph = registerAllocator.iGraph;
+	bool removedInstructions = false;
+
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	ControlNode** nodes = controlGraph.lndList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+
+	// Walk the nodes in the loop nesting depth list.
+	for (Int32 n = nNodes - 1; n >= 0; n--) {
+		InstructionList& instructions = nodes[n]->getInstructions();
+
+		InstructionList::iterator it = instructions.begin();
+		while (!instructions.done(it)) {
+			Instruction& instruction = instructions.get(it);
+			it = instructions.advance(it);
+
+			if ((instruction.getFlags() & ifCopy) != 0) {
+				assert(instruction.getInstructionUseBegin() != instruction.getInstructionUseEnd() && instruction.getInstructionUseBegin()[0].isRegister());
+				assert(instruction.getInstructionDefineBegin() != instruction.getInstructionDefineEnd() && instruction.getInstructionDefineBegin()[0].isRegister());
+
+				RegisterName source = findRoot(name2range[instruction.getInstructionUseBegin()[0].getRegisterName()], coalescedRange);
+				RegisterName destination = findRoot(name2range[instruction.getInstructionDefineBegin()[0].getRegisterName()], coalescedRange);
+
+				if (source == destination) {
+					instruction.remove();
+				} else if (!iGraph.interfere(source, destination)) {
+					InterferenceVector* sourceVector = iGraph.getInterferenceVector(source);
+					InterferenceVector* destinationVector = iGraph.getInterferenceVector(destination);
+
+#ifdef ULTRA_CONSERVATIVE_COALESCING
+					interferences.clear();
+
+					InterferenceVector* vector;
+					for (vector = sourceVector; vector != NULL; vector = vector->next) {
+						RegisterName* neighbors = vector->neighbors;
+						for (Uint32 i = 0; i < vector->count; i++)
+							interferences.set(findRoot(neighbors[i], coalescedRange));
+					}
+					for (vector = destinationVector; vector != NULL; vector = vector->next) {
+						RegisterName* neighbors = vector->neighbors;
+						for (Uint32 i = 0; i < vector->count; i++)
+							interferences.set(findRoot(neighbors[i], coalescedRange));
+					}
+
+					Uint32 count = interferences.getSize();
+#else // ULTRA_CONSERVATIVE_COALESCING
+					trespass("not implemented");
+					Uint32 count = 0;
+#endif // ULTRA_CONSERVATIVE_COALESCING
+
+					if (count < 6 /* FIX: should get the number from the class */) {
+						// Update the interferences vector.
+						if (sourceVector == NULL) {
+							iGraph.setInterferenceVector(source, destinationVector);
+							sourceVector = destinationVector;
+						} else if (destinationVector == NULL)
+							iGraph.setInterferenceVector(destination, sourceVector);
+						else {
+							InterferenceVector* last = NULL;
+							for (InterferenceVector* v = sourceVector; v != NULL; v = v->next)
+								last = v;
+							assert(last);
+							last->next = destinationVector;
+							iGraph.setInterferenceVector(destination, sourceVector);
+						}
+						// Update the interference matrix.
+						for (InterferenceVector* v = sourceVector; v != NULL; v = v->next) {
+							RegisterName* neighbors = v->neighbors;
+							for (Uint32 i = 0; i < v->count; i++) {
+								RegisterName neighbor = findRoot(neighbors[i], coalescedRange);
+								iGraph.setInterference(neighbor, source);
+								iGraph.setInterference(neighbor, destination);
+							}
+						}
+
+						instruction.remove();
+						coalescedRange[source] = destination;
+						removedInstructions = true;
+					}
+				}
+			}
+		}
+	}
+
+	registerAllocator.rangeCount = compress(registerAllocator.name2range, coalescedRange, registerAllocator.nameCount, rangeCount);
+	delete newRange;
+
+	return removedInstructions;
+}
+
+#endif // _COALESCING_H_

mozilla/ef/Compiler/RegisterAllocator/Coloring.cpp

@@ -0,0 +1,283 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef NEW_LAURENTM_CODE
+
+#include "Coloring.h"
+#include "VirtualRegister.h"
+#include "FastBitSet.h"
+#include "FastBitMatrix.h"
+#include "CpuInfo.h"
+
+bool Coloring::
+assignRegisters(FastBitMatrix& interferenceMatrix)
+{
+  PRUint32 *stackPtr = new(pool) PRUint32[vRegManager.count()];
+
+  return select(interferenceMatrix, stackPtr, simplify(interferenceMatrix, stackPtr));
+}
+
+PRInt32 Coloring::
+getLowestSpillCostRegister(FastBitSet& bitset)
+{
+  PRInt32 lowest = bitset.firstOne();
+  if (lowest != -1)
+	{
+	  Flt32 cost = vRegManager.getVirtualRegister(lowest).spillInfo.spillCost;
+	  for (PRInt32 r = bitset.nextOne(lowest); r != -1; r = bitset.nextOne(r))
+		{
+		  VirtualRegister& vReg = vRegManager.getVirtualRegister(r);
+		  if (!vReg.spillInfo.infiniteSpillCost && (vReg.spillInfo.spillCost < cost))
+			{
+			  cost = vReg.spillInfo.spillCost;
+			  lowest = r;
+			}
+		}
+	}
+  return lowest;
+}
+
+PRUint32* Coloring::
+simplify(FastBitMatrix interferenceMatrix, PRUint32* stackPtr)
+{
+  // first we construct the sets low and high. low contains all nodes of degree
+  // inferior to the number of register available on the processor. All the
+  // nodes with an high degree and a finite spill cost are placed in high.
+  // Nodes of high degree and infinite spill cost are not included in either sets.
+
+  PRUint32 nRegisters = vRegManager.count();
+  FastBitSet low(pool, nRegisters);
+  FastBitSet high(pool, nRegisters);
+  FastBitSet stack(pool, nRegisters);
+
+  for (VirtualRegisterManager::iterator i = vRegManager.begin(); !vRegManager.done(i); i = vRegManager.advance(i))
+	{
+	  VirtualRegister& vReg = vRegManager.getVirtualRegister(i);
+	  
+	  if (vReg.getClass() == vrcStackSlot)
+		{
+		  stack.set(i);
+		  vReg.colorRegister(nRegisters);
+		}
+	  else
+		{
+		  if (vReg.colorInfo.interferenceDegree < NUMBER_OF_REGISTERS)
+			low.set(i);
+		  else // if (!vReg.spillInfo.infiniteSpillCost)
+			high.set(i);
+
+		  // Set coloring info.
+		  vReg.spillInfo.willSpill = false;
+
+		  switch(vReg.getClass())
+			{
+			case vrcInteger:
+			  vReg.colorRegister(LAST_GREGISTER + 1);
+			  break;
+			case vrcFloatingPoint:
+			case vrcFixedPoint:
+			  vReg.colorRegister(LAST_FPREGISTER + 1);
+			  break;
+			default:
+			  PR_ASSERT(false); // Cannot happen.
+			}
+		}
+	}
+
+  // push the stack registers
+  PRInt32 j;
+  for (j = stack.firstOne(); j != -1; j = stack.nextOne(j))
+	*stackPtr++ = j;
+
+  // simplify
+  while (true)
+	{
+	  PRInt32 r;
+	  while ((r = getLowestSpillCostRegister(low)) != -1)
+		{
+		  VirtualRegister& vReg = vRegManager.getVirtualRegister(r);
+
+		  /* update low and high */
+		  FastBitSet inter(interferenceMatrix.getRow(r), nRegisters);
+		  for (j = inter.firstOne(); j != -1; j = inter.nextOne(j))
+			{
+			  VirtualRegister& neighbor = vRegManager.getVirtualRegister(j);
+			  // if the new interference degree of one of his neighbor becomes
+			  // NUMBER_OF_REGISTERS - 1 then it is added to the set 'low'.
+			  
+			  PRUint32 maxInterference = 0;
+			  switch (neighbor.getClass())
+				{
+				case vrcInteger:
+				  maxInterference = NUMBER_OF_GREGISTERS;
+				  break;
+				case vrcFloatingPoint:
+				case vrcFixedPoint:
+				  maxInterference = NUMBER_OF_FPREGISTERS;
+				  break;
+				default:
+				  PR_ASSERT(false);
+				}
+			  if ((vRegManager.getVirtualRegister(j).colorInfo.interferenceDegree-- == maxInterference))
+				{
+				  high.clear(j);
+				  low.set(j);
+				}
+			  vReg.colorInfo.interferenceDegree--;
+			  interferenceMatrix.clear(r, j);
+			  interferenceMatrix.clear(j, r);
+			}
+		  low.clear(r);
+
+		  // Push this register.
+		  *stackPtr++ = r;
+		}
+	  if ((r = getLowestSpillCostRegister(high)) != -1)
+		{
+		  high.clear(r);
+		  low.set(r);
+		}
+	  else
+		break;
+	}
+
+  return stackPtr;
+}
+
+bool Coloring::
+select(FastBitMatrix& interferenceMatrix, PRUint32* stackBase, PRUint32* stackPtr)
+{
+  PRUint32 nRegisters = vRegManager.count();
+  FastBitSet usedRegisters(NUMBER_OF_REGISTERS + 1); // usedRegisters if used for both GR & FPR.
+  FastBitSet preColoredRegisters(NUMBER_OF_REGISTERS + 1);
+  FastBitSet usedStack(nRegisters + 1);
+  bool success = true;
+  Int32 lastUsedSSR = -1;
+
+  // select
+  while (stackPtr != stackBase)
+	{
+	  // Pop one register.
+	  PRUint32 r = *--stackPtr;
+	  VirtualRegister& vReg = vRegManager.getVirtualRegister(r);
+
+	  FastBitSet neighbors(interferenceMatrix.getRow(r), nRegisters);
+		  
+	  if (vReg.getClass() == vrcStackSlot)
+		// Stack slots coloring.
+		{
+		  usedStack.clear();
+
+		  for (PRInt32 i = neighbors.firstOne(); i != -1; i = neighbors.nextOne(i))
+			usedStack.set(vRegManager.getVirtualRegister(i).getColor());
+
+		  Int32 color = usedStack.firstZero();
+		  vReg.colorRegister(color);
+		  if (color > lastUsedSSR)
+			  lastUsedSSR = color;
+		}
+	  else
+		// Integer & Floating point register coloring.
+		{
+		  usedRegisters.clear();
+		  preColoredRegisters.clear();
+		  
+		  for (PRInt32 i = neighbors.firstOne(); i != -1; i = neighbors.nextOne(i))
+			{
+			  VirtualRegister& nvReg = vRegManager.getVirtualRegister(i);
+			  usedRegisters.set(nvReg.getColor());
+			  if (nvReg.isPreColored())
+				preColoredRegisters.set(nvReg.getPreColor());
+			}
+		  if (vReg.hasSpecialInterference)
+			usedRegisters |= vReg.specialInterference;
+
+		  PRInt8 c = -1;
+		  PRInt8 maxColor = 0;
+		  PRInt8 firstColor = 0;
+		  switch (vReg.getClass())
+			{
+			case vrcInteger:
+			  firstColor = FIRST_GREGISTER;
+			  maxColor = LAST_GREGISTER;
+			  break;
+			case vrcFloatingPoint:
+			case vrcFixedPoint:
+			  firstColor = FIRST_FPREGISTER;
+			  maxColor = LAST_FPREGISTER;
+			  break;
+			default:
+			  PR_ASSERT(false);
+			}
+
+		  if (vReg.isPreColored())
+			{
+			  c = vReg.getPreColor();
+			  if (usedRegisters.test(c))
+				c = -1;
+			}
+		  else
+			{
+			  for (c = usedRegisters.nextZero(firstColor - 1); (c >= 0) && (c <= maxColor) && (preColoredRegisters.test(c)); 
+				   c = usedRegisters.nextZero(c)) {}
+			}
+
+		  if ((c >= 0) && (c <= maxColor))
+			{
+			  vReg.colorRegister(c);
+			}
+		  else
+			{
+			  VirtualRegister& stackRegister = vRegManager.newVirtualRegister(vrcStackSlot);
+			  vReg.equivalentRegister[vrcStackSlot] = &stackRegister;	  
+			  vReg.spillInfo.willSpill = true;
+			  success = false;
+			}
+		}
+	}
+  
+#ifdef DEBUG
+  if (success)
+	{
+	  for (VirtualRegisterManager::iterator i = vRegManager.begin(); !vRegManager.done(i); i = vRegManager.advance(i))
+		{
+		  VirtualRegister& vReg = vRegManager.getVirtualRegister(i);
+		  switch (vReg.getClass())
+			{
+			case vrcInteger:
+			  if (vReg.getColor() > LAST_GREGISTER)
+				PR_ASSERT(false);
+			  break;
+			case vrcFloatingPoint:
+			case vrcFixedPoint:
+#if NUMBER_OF_FPREGISTERS != 0
+			  if (vReg.getColor() > LAST_FPREGISTER)
+				PR_ASSERT(false);
+#endif
+			  break;
+			default:
+			  break;
+			}
+		}
+	}
+#endif
+
+  vRegManager.nUsedStackSlots = lastUsedSSR + 1;
+  return success;
+}
+#endif // NEW_LAURENTM_CODE

mozilla/ef/Compiler/RegisterAllocator/Coloring.h

@@ -0,0 +1,284 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+#include "Instruction.h"
+#include "RegisterAllocator.h"
+#include "VirtualRegister.h"
+#include "InterferenceGraph.h"
+#include "SparseSet.h"
+#include "Spilling.h"
+#include "Splits.h"
+
+UT_EXTERN_LOG_MODULE(RegAlloc);
+
+template <class RegisterPressure>
+class Coloring
+{
+private:
+	static RegisterName* simplify(RegisterAllocator& registerAllocator, RegisterName* coloringStack);
+	static bool select(RegisterAllocator& registerAllocator, RegisterName* coloringStack, RegisterName* coloringStackPtr);
+
+public:
+	static bool color(RegisterAllocator& registerAllocator);
+	static void finalColoring(RegisterAllocator& registerAllocator);
+};
+
+
+template <class RegisterPressure>
+void Coloring<RegisterPressure>::finalColoring(RegisterAllocator& registerAllocator)
+{
+	RegisterName* color = registerAllocator.color;
+	RegisterName* name2range = registerAllocator.name2range;
+
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		InstructionList& instructions = nodes[n]->getInstructions();
+
+		for (InstructionList::iterator i = instructions.begin(); !instructions.done(i); i = instructions.advance(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister()) {
+					usePtr->setRegisterName(color[name2range[usePtr->getRegisterName()]]);
+#ifdef DEBUG
+					RegisterID rid = usePtr->getRegisterID();
+					setColoredRegister(rid);
+					usePtr->setRegisterID(rid);
+#endif // DEBUG
+				}
+
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister()) {
+					definePtr->setRegisterName(color[name2range[definePtr->getRegisterName()]]);
+#ifdef DEBUG
+					RegisterID rid = definePtr->getRegisterID();
+					setColoredRegister(rid);
+					definePtr->setRegisterID(rid);
+#endif // DEBUG
+				}
+		}
+	}
+}
+
+template <class RegisterPressure>
+bool Coloring<RegisterPressure>::select(RegisterAllocator& registerAllocator, RegisterName* coloringStack, RegisterName* coloringStackPtr)
+{
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	RegisterName* color = new RegisterName[rangeCount];
+	registerAllocator.color = color;
+
+	for (Uint32 r = 1; r < rangeCount; r++)
+		color[r] = RegisterName(6); // FIX;
+
+	// Color the preColored registers.
+	//
+	VirtualRegisterManager& vrManager = registerAllocator.vrManager;
+	RegisterName* name2range = registerAllocator.name2range;
+	PreColoredRegister* machineEnd = vrManager.getMachineRegistersEnd();
+	for (PreColoredRegister* machinePtr = vrManager.getMachineRegistersBegin(); machinePtr < machineEnd; machinePtr++)
+		if (machinePtr->id != invalidID) {
+			color[name2range[getName(machinePtr->id)]] = machinePtr->color;
+			UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\twill preColor range %d as %d\n", name2range[getName(machinePtr->id)], machinePtr->color));
+		}
+
+	SpillCost* cost = registerAllocator.spillCost;
+	Pool& pool = registerAllocator.pool;
+	SparseSet& spill = *new(pool) SparseSet(pool, rangeCount);
+	registerAllocator.willSpill = &spill;
+	SparseSet neighborColors(pool, 6); // FIX
+	InterferenceGraph<RegisterPressure>& iGraph = registerAllocator.iGraph;
+
+	bool coloringFailed = false;
+	while (coloringStackPtr > coloringStack) {
+		RegisterName range = *--coloringStackPtr;
+
+		if (!cost[range].infinite && cost[range].cost < 0) {
+			coloringFailed = true;
+			spill.set(range);
+			UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\tfailed to color %d, will spill.\n", range));
+		} else {
+			neighborColors.clear();
+
+			for (InterferenceVector* vector = iGraph.getInterferenceVector(range); vector != NULL; vector = vector->next)
+				for (Int32 i = vector->count - 1; i >= 0; --i) {
+					RegisterName neighborColor = color[vector->neighbors[i]];
+					if (neighborColor < 6) // FIX
+						neighborColors.set(neighborColor);
+				}
+
+			if (neighborColors.getSize() == 6) { // FIX
+				coloringFailed = true;
+				UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\tfailed to color %d, ", range));
+
+				if (!Splits<RegisterPressure>::findSplit(registerAllocator, color, range)) {
+					UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("will spill.\n"));
+					spill.set(range);
+				} else
+					UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("will split.\n"));
+			} else {
+				for (Uint32 i = 0; i < 6; i++) // FIX
+					if (!neighborColors.test(i)) {
+						fprintf(stdout, "\twill color %d as %d\n", range, i);
+						color[range] = RegisterName(i);
+						break;
+					}
+			}
+		}
+	}
+
+#ifdef DEBUG_LOG
+	if (coloringFailed) {
+		UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("Coloring failed:\n"));
+		UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\twill spill: "));
+		spill.printPretty(UT_LOG_MODULE(RegAlloc));
+	} else {
+		UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("Coloring succeeded:\n"));
+		for (Uint32 i = 1; i < rangeCount; i++)
+			UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\trange %d colored as %d\n", i, color[i]));
+	}
+#endif
+
+	return !coloringFailed;
+}
+
+template <class RegisterPressure>
+RegisterName* Coloring<RegisterPressure>::simplify(RegisterAllocator& registerAllocator, RegisterName* coloringStack)
+{
+	InterferenceGraph<RegisterPressure>& iGraph = registerAllocator.iGraph;
+	SpillCost* spillCost = registerAllocator.spillCost;
+	Uint32 rangeCount = registerAllocator.rangeCount;
+
+	Uint32* degree = new Uint32[rangeCount];
+	for (RegisterName i = RegisterName(1); i < rangeCount; i = RegisterName(i + 1)) {
+		InterferenceVector* vector = iGraph.getInterferenceVector(i);
+		degree[i] = (vector != NULL) ? vector->count : 0;
+	}
+
+	Pool& pool = registerAllocator.pool;
+	SparseSet low(pool, rangeCount);
+	SparseSet high(pool, rangeCount);
+	SparseSet highInfinite(pool, rangeCount);
+	SparseSet preColored(pool, rangeCount);
+
+	// Get the precolored registers.
+	//
+	VirtualRegisterManager& vrManager = registerAllocator.vrManager;
+	RegisterName* name2range = registerAllocator.name2range;
+	PreColoredRegister* machineEnd = vrManager.getMachineRegistersEnd();
+	for (PreColoredRegister* machinePtr = vrManager.getMachineRegistersBegin(); machinePtr < machineEnd; machinePtr++)
+		if (machinePtr->id != invalidID)
+			preColored.set(name2range[getName(machinePtr->id)]);
+
+	// Insert the live ranges in the sets.
+	//
+	for (Uint32 range = 1; range < rangeCount; range++)
+		if (!preColored.test(range))
+			if (degree[range] < 6) // FIX
+				low.set(range);
+			else if (!spillCost[range].infinite)
+				high.set(range);
+			else
+				highInfinite.set(range);
+
+#ifdef DEBUG_LOG
+	UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("Coloring sets:\n\tlow = "));
+	low.printPretty(UT_LOG_MODULE(RegAlloc));
+	UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\thigh = "));
+	high.printPretty(UT_LOG_MODULE(RegAlloc));
+	UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\thighInfinite = "));
+	highInfinite.printPretty(UT_LOG_MODULE(RegAlloc));
+	UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\tpreColored = "));
+	preColored.printPretty(UT_LOG_MODULE(RegAlloc));
+#endif // DEBUG_LOG
+
+	RegisterName* coloringStackPtr = coloringStack;
+
+	while (low.getSize() != 0 || high.getSize() != 0) {
+		while (low.getSize() != 0) {
+			RegisterName range = RegisterName(low.getOne());
+			low.clear(range);
+			*coloringStackPtr++ = range;
+
+			for (InterferenceVector* vector = iGraph.getInterferenceVector(range); vector != NULL; vector = vector->next)
+				for (Int32 i = (vector->count - 1); i >= 0; --i) {
+					RegisterName neighbor = vector->neighbors[i];
+					degree[neighbor]--;
+
+					if (degree[neighbor] < 6) // FIX
+						if (high.test(neighbor)) {
+							high.clear(neighbor);
+							low.set(neighbor);
+						} else if (highInfinite.test(neighbor)) {
+							highInfinite.clear(neighbor);
+							low.set(neighbor);
+						}
+				}
+		}
+
+		if (high.getSize() != 0) {
+			RegisterName best = RegisterName(high.getOne());
+			double bestCost = spillCost[best].cost;
+			double bestDegree = degree[best];
+
+			// Choose the next best candidate.
+			//
+			for (SparseSet::iterator i = high.begin(); !high.done(i); i = high.advance(i)) {
+				RegisterName range = RegisterName(high.get(i));
+				double thisCost = spillCost[range].cost;
+				double thisDegree = degree[range];
+
+				if (thisCost * bestDegree < bestCost * thisDegree) {
+					best = range;
+					bestCost = thisCost;
+					bestDegree = thisDegree;
+				}
+			}
+			
+			high.clear(best);
+			low.set(best);
+		}
+ 	}
+	assert(highInfinite.getSize() == 0);
+
+	delete degree;
+
+#ifdef DEBUG_LOG
+	UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("Coloring stack:\n\t"));
+	for (RegisterName* sp = coloringStack; sp < coloringStackPtr; ++sp)
+		UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("%d ", *sp));
+	UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\n"));
+#endif // DEBUG_LOG
+
+	return coloringStackPtr;
+}
+
+
+template <class RegisterPressure>
+bool Coloring<RegisterPressure>::color(RegisterAllocator& registerAllocator)
+{
+	RegisterName* coloringStack = new RegisterName[registerAllocator.rangeCount];
+	return select(registerAllocator, coloringStack, simplify(registerAllocator, coloringStack));
+}

mozilla/ef/Compiler/RegisterAllocator/DominatorGraph.cpp

@@ -0,0 +1,212 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include <string.h>
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+
+#include "DominatorGraph.h"
+
+DominatorGraph::DominatorGraph(ControlGraph& controlGraph) : controlGraph(controlGraph)
+{
+	Uint32 nNodes = controlGraph.nNodes;
+
+	GtoV = new Uint32[nNodes + 1];
+	VtoG = new Uint32[nNodes + 1];
+
+	Uint32 v = 1;
+	for (Uint32 n = 0; n < nNodes; n++) {
+		VtoG[v] = n;
+		GtoV[n] = v++;
+	}
+
+	// Initialize all the 1-based arrays.
+	//
+	parent =	new Uint32[v];
+	semi =		new Uint32[v];
+	vertex =	new Uint32[v];
+	label =		new Uint32[v];
+	size =		new Uint32[v];
+	ancestor =	new Uint32[v];
+	child =		new Uint32[v];
+	dom =		new Uint32[v];
+	bucket =	new DGLinkedList*[v];
+
+	memset(semi, '\0', v * sizeof(Uint32));
+	memset(bucket, '\0', v * sizeof(DGLinkedList*));
+
+	vCount = v;
+
+	build();
+
+	delete parent;
+	delete semi;
+	delete vertex;
+	delete label;
+	delete size;
+	delete ancestor;
+	delete child;
+	delete dom;
+	delete bucket;
+}
+
+Uint32 DominatorGraph::DFS(Uint32 vx, Uint32 n)
+{
+	semi[vx] = ++n;
+	vertex[n] = label[vx] = vx;
+	ancestor[vx] = child[vx] = 0;
+	size[vx] = 1;
+
+
+	ControlNode& node = *controlGraph.dfsList[VtoG[vx]];
+	ControlEdge* successorEnd = node.getSuccessorsEnd();
+	for (ControlEdge* successorPtr = node.getSuccessorsBegin(); successorPtr < successorEnd; successorPtr++) {
+		Uint32 w = GtoV[successorPtr->getTarget().dfsNum];
+		if (semi[w] == 0) {
+			parent[w] = vx;
+			n = DFS(w, n);
+		}
+	}
+	return n;
+}
+
+void DominatorGraph::LINK(Uint32 vx, Uint32 w)
+{
+    Uint32 s = w;
+
+	while (semi[label[w]] < semi[label[child[s]]]) {
+		if (size[s] + size[child[child[s]]] >= (size[child[s]] << 1)) {
+			ancestor[child[s]] = s;
+			child[s] = child[child[s]];
+		} else {
+			size[child[s]] = size[s];
+			s = ancestor[s] = child[s];
+		}
+	}
+	label[s] = label[w];
+	size[vx] += size[w];
+	if(size[vx] < (size[w] << 1)) {
+		Uint32 t = s;
+		s = child[vx]; 
+		child[vx] = t;
+	}
+	while( s != 0 ) {
+		ancestor[s] = vx;
+		s = child[s];
+	}
+}
+
+
+void DominatorGraph::COMPRESS(Uint32 vx)
+{
+	if(ancestor[ancestor[vx]] != 0) {
+		COMPRESS(ancestor[vx]);
+		if(semi[label[ancestor[vx]]] < semi[label[vx]])
+			label[vx] = label[ancestor[vx]];
+		ancestor[vx] = ancestor[ancestor[vx]];
+	}
+}
+
+Uint32 DominatorGraph::EVAL(Uint32 vx)
+{
+	if(ancestor[vx] == 0) 
+		return label[vx];
+	COMPRESS(vx);
+	return (semi[label[ancestor[vx]]] >= semi[label[vx]]) ? label[vx] : label[ancestor[vx]];
+}
+
+void DominatorGraph::build()
+{
+	Uint32 n = DFS(GtoV[0], 0);
+	size[0] = label[0] = semi[0];
+
+	for (Uint32 i = n; i >= 2; i--) {
+		Uint32 w = vertex[i];
+
+		ControlNode& node = *controlGraph.dfsList[VtoG[w]];
+		const DoublyLinkedList<ControlEdge>& predecessors = node.getPredecessors();
+		for (DoublyLinkedList<ControlEdge>::iterator p = predecessors.begin(); !predecessors.done(p); p = predecessors.advance(p)) {
+			Uint32 vx = GtoV[predecessors.get(p).getSource().dfsNum];
+			Uint32 u = EVAL(vx);
+
+			if(semi[u] < semi[w])
+				semi[w] = semi[u];
+		}
+
+		DGLinkedList* elem = new DGLinkedList();
+		elem->next = bucket[vertex[semi[w]]];
+		elem->index = w;
+		bucket[vertex[semi[w]]] = elem;
+
+		LINK(parent[w], w);
+
+		elem = bucket[parent[w]];
+		while(elem != NULL) {
+			Uint32 vx = elem->index;
+			Uint32 u = EVAL(vx);
+			dom[vx] = (semi[u] < semi[vx]) ? u : parent[w];
+			elem = elem->next;
+		}
+	}
+
+	memset(size, '\0', n * sizeof(Uint32));
+	Pool& pool = controlGraph.pool;
+	nodes = new(pool) DGNode[n];
+
+	for(Uint32 j = 2; j <= n; j++) {
+		Uint32 w = vertex[j];
+		Uint32 d = dom[w];
+		if(d != vertex[semi[w]]) {
+			d = dom[d];
+			dom[w] = d;
+		}
+		size[d]++;
+	}
+	dom[GtoV[0]] = 0;
+
+	for (Uint32 k = 1; k <= n; k++) {
+		DGNode& node = nodes[VtoG[k]];
+		Uint32 count = size[k];
+		node.successorsEnd = node.successorsBegin = (count) ? new(pool) Uint32[count] : (Uint32*) 0;
+	}
+
+	for (Uint32 l = 2; l <= n; l++)
+		*(nodes[VtoG[dom[l]]].successorsEnd)++ = VtoG[l];
+}
+
+#ifdef DEBUG_LOG
+void DominatorGraph::printPretty(LogModuleObject log)
+{
+	UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("Dominator Graph:\n"));
+	Uint32 nNodes = controlGraph.nNodes;
+	for (Uint32 i = 0; i < nNodes; i++) {
+		DGNode& node = nodes[i];
+		if (node.successorsBegin !=  node.successorsEnd) {
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\tN%d dominates ", i));
+			for (Uint32* successorsPtr = node.successorsBegin; successorsPtr < node.successorsEnd; successorsPtr++)
+				UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("N%d ", *successorsPtr));
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\n"));
+		}
+	}
+}
+
+#endif // DEBUG_LOG
+
+
+

mozilla/ef/Compiler/RegisterAllocator/DominatorGraph.h

@@ -0,0 +1,80 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _DOMINATOR_GRAPH_H_
+#define _DOMINATOR_GRAPH_H_
+
+#include "LogModule.h"
+
+class ControlGraph;
+
+struct DGNode
+{
+	Uint32* successorsBegin;
+	Uint32* successorsEnd;
+};
+
+struct DGLinkedList
+{
+	DGLinkedList* next;
+	Uint32 index;
+};
+
+class DominatorGraph
+{
+private:
+
+	ControlGraph&	controlGraph;
+
+	Uint32			vCount;
+
+	Uint32*			VtoG;
+	Uint32*			GtoV;
+	Uint32*			parent;
+	Uint32*			semi;
+	Uint32*			vertex;
+	Uint32*			label;
+	Uint32*			size;
+	Uint32*			ancestor;
+	Uint32*			child;
+	Uint32*			dom;
+	DGLinkedList**	bucket;
+	DGNode*			nodes;
+	
+private:
+
+	void build();
+
+	Uint32 DFS(Uint32 vx, Uint32 n);
+	void LINK(Uint32 vx, Uint32 w);
+	void COMPRESS(Uint32 vx);
+	Uint32 EVAL(Uint32 vx);
+
+public:
+
+	DominatorGraph(ControlGraph& controlGraph);
+
+	Uint32* getSuccessorsBegin(Uint32 n) const {return nodes[n].successorsBegin;}
+	Uint32* getSuccessorsEnd(Uint32 n) const {return nodes[n].successorsEnd;}
+
+#ifdef DEBUG_LOG
+	void printPretty(LogModuleObject log);
+#endif // DEBUG_LOG
+};
+
+#endif // _DOMINATOR_GRAPH_H_

mozilla/ef/Compiler/RegisterAllocator/HashSet.cpp

@@ -0,0 +1,20 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "HashSet.h"

mozilla/ef/Compiler/RegisterAllocator/HashSet.h

@@ -0,0 +1,97 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _HASH_SET_H_
+#define _HASH_SET_H_
+
+#include "Fundamentals.h"
+#include "Pool.h"
+#include <string.h>
+
+struct HashSetElement
+{
+	Uint32 index;
+	HashSetElement* next;
+};
+
+class HashSet
+{
+private:
+
+	static const hashSize = 64;
+
+	// Return the hash code for the given element index.
+	static Uint32 getHashCode(Uint32 index) {return index & (hashSize - 1);} // Could be better !
+
+private:
+
+	Pool&					allocationPool;
+	HashSetElement**		bucket;
+	HashSetElement*			free;
+
+private:
+
+	// No copy constructor.
+	HashSet(const HashSet&);
+	// No copy operator.
+	void operator = (const HashSet&);
+
+public:
+
+	// Create a new HashSet.
+	inline HashSet(Pool& pool, Uint32 universeSize);
+
+	// Clear the hashset.
+	void clear();
+	// Clear the element for the given index.
+	void clear(Uint32 index);
+	// Set the element for the given index.
+	void set(Uint32 index);
+	// Return true if the element at index is a member.
+	bool test(Uint32 index) const;
+	// Union with the given hashset.
+	inline void or(const HashSet& set);
+	// Intersection with the given hashset.
+	inline void and(const HashSet& set);
+	// Difference with the given hashset.
+	inline void difference(const HashSet& set);
+
+	// Logical operators.
+	HashSet& operator |= (const HashSet& set) {or(set); return *this;}
+	HashSet& operator &= (const HashSet& set) {and(set); return *this;}
+	HashSet& operator -= (const HashSet& set) {difference(set); return *this;}
+
+	// Iterator to conform with the set API.
+	typedef HashSetElement* iterator;
+	// Return the iterator for the first element of this set.
+	iterator begin() const;
+	// Return the next iterator.
+	iterator advance(iterator pos) const;
+	// Return true if the iterator is at the end of the set.
+	bool done(iterator pos) const {return pos == NULL;}
+};
+
+
+inline HashSet::HashSet(Pool& pool, Uint32 /*universeSize*/)
+	: allocationPool(pool), free(NULL)
+{
+	bucket = new(pool) HashSetElement*[hashSize];
+	memset(bucket, '\0', sizeof(HashSetElement*));
+}
+
+#endif // _HASH_SET_H_

mozilla/ef/Compiler/RegisterAllocator/IndexedPool.h

@@ -0,0 +1,213 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _INDEXED_POOL_H_
+#define _INDEXED_POOL_H_
+
+#include "Fundamentals.h"
+#include <string.h>
+#include <stdlib.h>
+
+//------------------------------------------------------------------------------
+// IndexedPool<IndexedObjectSubclass> is an indexed pool of objects. The
+// template parameter 'IndexedObjectSubclass' must be a subclass of the struct
+// IndexedObject.
+// 
+// When the indexed pool is ask to allocate and initialize a new object (using
+// the operator new(anIndexedPool) it will zero the memory used to store the
+// object and initialize the field 'index' of this object to its position in
+// the pool.
+//
+// An object allocated by the indexed pool can be freed by calling the method
+// IndexedPool::release(IndexedElement& objectIndex).
+//
+// example:
+//
+//   IndexedPool<IndexedElement> elementPool;
+//
+//   IndexedElement& element1 = *new(elementPool) IndexedElement();
+//   IndexedElement& element2 = *new(elementPool) IndexedElement();
+//
+//   indexedPool.release(element1);
+//   IndexedElement& element3 = *new(elementPool) IndexedElement();
+//
+//  At this point element1 is no longer a valid object, element2 is at
+//  index 2 and element3 is at index 1.
+//
+
+//------------------------------------------------------------------------------
+// IndexedObject -
+//
+
+template<class Object>
+struct IndexedObject
+{
+	Uint32			index;				// Index in the pool.
+	Object*			next;				// Used to link IndexedObject together.
+
+	Uint32 getIndex() {return index;}
+};
+
+//------------------------------------------------------------------------------
+// IndexedPool<IndexedObject> -
+//
+
+template <class IndexedObject>
+class IndexedPool
+{
+private:
+
+	static const	blockSize = 4;		// Size of one block.
+
+	Uint32			nBlocks;			// Number of blocks in the pool.
+	IndexedObject**	block;				// Array of block pointers.
+	IndexedObject*  freeObjects;		// Chained list of free IndexedObjects.
+	Uint32			nextIndex;			// Index of the next free object in the last block. 
+
+private:
+
+	void allocateAnotherBlock();
+	IndexedObject& newObject();
+
+public:
+
+	IndexedPool() : nBlocks(0), block(NULL), freeObjects(NULL), nextIndex(1) {}
+	~IndexedPool();
+
+	IndexedObject& get(Uint32 index) const;
+	void release(IndexedObject& object);
+
+	void setSize(Uint32 size) {assert(size < nextIndex); nextIndex = size;}
+
+	// Return the universe size.
+	Uint32 getSize() {return nextIndex;}
+
+	friend void* operator new(size_t, IndexedPool<IndexedObject>& pool); // Needs to call newObject().
+};
+
+// Free all the memory allocated for this object.
+//
+template <class IndexedObject>
+IndexedPool<IndexedObject>::~IndexedPool()
+{
+	for (Uint32 n = 0; n < nBlocks; n++)
+		free(&((IndexedObject **) &block[n][n*blockSize])[-(n + 1)]);
+}
+
+// Release the given. This object will be iserted in the chained
+// list of free IndexedObjects. To minimize the fragmentation the chained list 
+// is ordered by ascending indexes.
+//
+template <class IndexedObject>
+void IndexedPool<IndexedObject>::release(IndexedObject& object)
+{
+	Uint32 index = object.index;
+	IndexedObject* list = freeObjects;
+
+	assert(&object == &get(index)); // Make sure that object is owned by this pool.
+
+	if (list == NULL) { // The list is empty.
+		freeObjects = &object;
+		object.next = NULL;
+	} else { // The list contains at least 1 element.
+		if (index < list->index) { // insert as first element.
+			freeObjects = &object;
+			object.next = list;
+		} else { // Find this object's place.
+			while ((list->next) != NULL && (list->next->index < index))
+				list = list->next;
+
+			object.next = list->next;
+			list->next = &object;
+		}
+	}
+
+#ifdef DEBUG
+	// Sanity check to be sure that the list is correctly ordered.
+	for (IndexedObject* obj = freeObjects; obj != NULL; obj = obj->next)
+		if (obj->next != NULL)
+			assert(obj->index < obj->next->index);
+#endif
+}
+
+// Create a new block of IndexedObjects. We will allocate the memory to
+// store IndexedPool::blockSize IndexedObject and the new Array of block
+// pointers.
+// The newly created IndexedObjects will not be initialized.
+//
+template <class IndexedObject>
+void IndexedPool<IndexedObject>::allocateAnotherBlock()
+{
+	void* memory = (void *) malloc((nBlocks + 1) * sizeof(Uint32) + blockSize * sizeof(IndexedObject));
+
+	memcpy(memory, block, nBlocks * sizeof(Uint32));
+
+	block = (IndexedObject **) memory;
+	IndexedObject* objects = (IndexedObject *) &block[nBlocks + 1];
+
+	block[nBlocks] = &objects[-(nBlocks * blockSize)];
+	nBlocks++;
+}
+
+// Return the IndexedObject at the position 'index' in the pool.
+//
+template <class IndexedObject>
+IndexedObject& IndexedPool<IndexedObject>::get(Uint32 index) const
+{
+	Uint32 blockIndex = index / blockSize;
+	assert(blockIndex < nBlocks);
+
+	return block[blockIndex][index];
+}
+
+// Return the reference of an unused object in the pool.
+//
+template <class IndexedObject>
+IndexedObject& IndexedPool<IndexedObject>::newObject()
+{
+	if (freeObjects != NULL) {
+		IndexedObject& newObject = *freeObjects;
+		freeObjects = newObject.next;
+		return newObject;
+	}
+	
+	Uint32 nextIndex = this->nextIndex++;
+	Uint32 blockIndex = nextIndex / blockSize;
+
+	while (blockIndex >= nBlocks)
+		allocateAnotherBlock();
+	
+	IndexedObject& newObject = block[blockIndex][nextIndex];
+	newObject.index = nextIndex;
+
+	return newObject;
+}
+
+// Return the address of the next unsused object in the given
+// indexed pool. The field index of the newly allocated object
+// will be initialized to the corresponding index of this object
+// in the pool.
+//
+template <class IndexedObject>
+void* operator new(size_t size, IndexedPool<IndexedObject>& pool)
+{
+	assert(size == sizeof(IndexedObject));
+	return (void *) &pool.newObject();
+}
+
+#endif // _INDEXED_POOL_H_

mozilla/ef/Compiler/RegisterAllocator/InterferenceGraph.h

@@ -0,0 +1,258 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _INTERFERENCE_GRAPH_H_
+#define _INTERFERENCE_GRAPH_H_
+
+#include "Fundamentals.h"
+#include "ControlGraph.h"
+#include "Primitives.h"
+#include "Instruction.h"
+#include "VirtualRegister.h"
+#include "RegisterPressure.h"
+#include "SparseSet.h"
+#include <string.h>
+
+struct InterferenceVector
+{
+	Uint32				count;
+	InterferenceVector*	next;
+	RegisterName*		neighbors;
+
+	InterferenceVector() : count(0), next(NULL) {}
+};
+
+class RegisterAllocator;
+
+template <class RegisterPressure>
+class InterferenceGraph
+{
+private:
+
+	RegisterAllocator&			registerAllocator;
+
+	RegisterPressure::Set*		interferences;
+	InterferenceVector**		vector;
+	Uint32*						offset;
+	Uint32 						rangeCount;
+
+private:
+
+	// No copy constructor.
+	InterferenceGraph(const InterferenceGraph&);
+	// No copy operator.
+	void operator = (const InterferenceGraph&);
+
+	// Check if reg is a member of the universe.
+	void checkMember(RegisterName name) {assert(name < rangeCount);}
+	// Return the edge index for the interference between name1 and name2.
+	Uint32 getEdgeIndex(RegisterName name1, RegisterName name2);
+
+public:
+	InterferenceGraph(RegisterAllocator& registerAllocator) : registerAllocator(registerAllocator) {}
+
+	// Calculate the interferences.
+	void build();
+	// Return true if reg1 and reg2 interfere.
+	bool interfere(RegisterName name1, RegisterName name2);
+	// Return the interference vector for the given register or NULL if there is none.
+	InterferenceVector* getInterferenceVector(RegisterName name) {return vector[name];}
+	// Set the interference between name1 and name2.
+	void setInterference(RegisterName name1, RegisterName name2);
+	// Set the interference vector for the given register.
+	void setInterferenceVector(RegisterName name, InterferenceVector* v) {vector[name] = v;}
+
+
+#ifdef DEBUG_LOG
+	// Print the interferences.
+	void printPretty(LogModuleObject log);
+#endif // DEBUG_LOG
+};
+
+template <class RegisterPressure>
+void InterferenceGraph<RegisterPressure>::build()
+{
+	Pool& pool = registerAllocator.pool;
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	this->rangeCount = rangeCount;
+
+	// Initialize the structures.
+	//
+	offset = new(pool) Uint32[rangeCount + 1];
+	vector = new(pool) InterferenceVector*[rangeCount];
+	memset(vector, '\0', sizeof(InterferenceVector*) * rangeCount);
+
+	Uint32 o = 0;
+	offset[0] = 0;
+	for (Uint32 i = 1; i <= rangeCount; ++i) {
+		offset[i] = o;
+		o += i;
+	}
+	
+	interferences = new(pool) RegisterPressure::Set(pool, (rangeCount * rangeCount) / 2);
+
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	RegisterName* name2range = registerAllocator.name2range;
+	LivenessInfo<RegisterPressure> liveness = Liveness<RegisterPressure>::analysis(controlGraph, rangeCount, name2range);
+	registerAllocator.liveness = liveness;
+	SparseSet currentLive(pool, rangeCount);
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		ControlNode& node = *nodes[n];
+		currentLive = liveness.liveOut[n];
+
+		InstructionList& instructions = node.getInstructions();
+		for (InstructionList::iterator i = instructions.end(); !instructions.done(i); i = instructions.retreat(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			InstructionUse* useBegin = instruction.getInstructionUseBegin();
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			InstructionUse* usePtr;
+			InstructionDefine* defineBegin = instruction.getInstructionDefineBegin();
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			InstructionDefine* definePtr;
+
+			// Handle the copy instruction to avoid unnecessary interference between the 2 registers.
+			if ((instruction.getFlags() & ifCopy) != 0) {
+				assert(useBegin != useEnd && useBegin[0].isRegister());
+				currentLive.clear(name2range[useBegin[0].getRegisterName()]);
+			}
+
+			// Create the interferences.
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister()) {
+					RegisterName define = name2range[definePtr->getRegisterName()];
+
+					for (SparseSet::iterator e = currentLive.begin(); !currentLive.done(e); e = currentLive.advance(e)) {
+						RegisterName live = RegisterName(currentLive.get(e));
+
+						if ((live != define) && !interfere(live, define) && registerAllocator.canInterfere(live, define)) {
+
+							if (vector[define] == NULL)
+								vector[define] = new(pool) InterferenceVector();
+							vector[define]->count++;
+
+							if (vector[live] == NULL)
+								vector[live] = new(pool) InterferenceVector();
+							vector[live]->count++;
+
+							setInterference(live, define);
+						}
+					}
+				}
+
+			// Now update the liveness.
+			//
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister())
+					currentLive.clear(name2range[definePtr->getRegisterName()]);
+
+			for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister())
+					currentLive.set(name2range[usePtr->getRegisterName()]);
+		}
+	}
+
+	// Allocate the memory to store the interferences.
+	//
+	for (Uint32 e = 0; e < rangeCount; e++)
+		if (vector[e] != NULL) {
+			InterferenceVector& v = *vector[e];
+			v.neighbors = new(pool) RegisterName[v.count];
+			v.count = 0;
+		}
+
+	// Initialize the edges.
+	//
+	if (RegisterPressure::Set::isOrdered()) {
+		RegisterName name1 = RegisterName(0);
+
+		for (RegisterPressure::Set::iterator i = interferences->begin(); !interferences->done(i); i = interferences->advance(i)) {
+			Uint32 interferenceIndex = interferences->get(i);
+
+			while(interferenceIndex >= offset[name1 + 1])
+				name1 = RegisterName(name1 + 1);
+
+			assert((interferenceIndex >= offset[name1]) && (interferenceIndex < offset[name1 + 1]));
+
+			RegisterName name2 = RegisterName(interferenceIndex - offset[name1]);
+
+			assert(interfere(name1, name2));
+
+			InterferenceVector& vector1 = *vector[name1];
+			vector1.neighbors[vector1.count++] = name2;
+		
+			InterferenceVector& vector2 = *vector[name2];
+			vector2.neighbors[vector2.count++] = name1;
+		}
+	} else {
+		trespass("not Implemented"); // FIX: need one more pass to initialize the vectors.
+	}
+}
+
+template <class RegisterPressure>
+Uint32 InterferenceGraph<RegisterPressure>::getEdgeIndex(RegisterName name1, RegisterName name2)
+{
+	checkMember(name1); checkMember(name2);
+	assert(name1 != name2); // This is not possible.
+	return (name1 < name2) ? offset[name2] + name1 : offset[name1] + name2;
+}
+
+template <class RegisterPressure>
+void InterferenceGraph<RegisterPressure>::setInterference(RegisterName name1, RegisterName name2)
+{
+	interferences->set(getEdgeIndex(name1, name2));
+}
+
+template <class RegisterPressure>
+bool InterferenceGraph<RegisterPressure>::interfere(RegisterName name1, RegisterName name2)
+{
+	return interferences->test(getEdgeIndex(name1, name2));
+}
+
+#ifdef DEBUG_LOG
+template <class RegisterPressure>
+void InterferenceGraph<RegisterPressure>::printPretty(LogModuleObject log)
+{
+	UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("Interference Vectors:\n"));
+	for (Uint32 i = 1; i < rangeCount; i++) {
+		if (vector[i] != NULL) {
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\tvr%d: (", i));
+			for (InterferenceVector* v = vector[i]; v != NULL; v = v->next)
+				for (Uint32 j = 0; j < v->count; j++) {
+					UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("%d", v->neighbors[j]));
+					if (v->next != NULL || j != (v->count - 1))
+						UT_OBJECTLOG(log, PR_LOG_ALWAYS, (","));
+				}
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, (")\n"));
+		}
+	}
+	UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("Interference Matrix:\n"));
+	for (RegisterName name1 = RegisterName(1); name1 < rangeCount; name1 = RegisterName(name1 + 1)) {
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\t%d:\t", name1));
+		for (RegisterName name2 = RegisterName(1); name2 < rangeCount; name2 = RegisterName(name2 + 1))
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("%c", ((name1 != name2) && interfere(name1, name2)) ? '1' : '0'));
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\n"));
+	}
+}
+#endif // DEBUG_LOG
+
+#endif // _INTERFERENCE_GRAPH_H_

mozilla/ef/Compiler/RegisterAllocator/LiveRange.h

@@ -0,0 +1,87 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _LIVE_RANGE_H_
+#define _LIVE_RANGE_H_
+
+#include "Fundamentals.h"
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+#include "Primitives.h"
+#include "Instruction.h"
+#include "RegisterAllocator.h"
+#include "RegisterAllocatorTools.h"
+
+template <class RegisterPressure>
+struct LiveRange
+{
+	static void build(RegisterAllocator& registerAllocator);
+};
+
+template <class RegisterPressure>
+void LiveRange<RegisterPressure>::build(RegisterAllocator& registerAllocator)
+{
+	// Intialize the lookup table.
+	//
+	Uint32 nameCount = registerAllocator.nameCount;
+	RegisterName* nameTable = new(registerAllocator.pool) RegisterName[2*nameCount];
+	RegisterName* rangeName = &nameTable[nameCount];
+
+	init(rangeName, nameCount);
+
+	// Walk the graph.
+	//
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	SparseSet destination(registerAllocator.pool, nameCount);
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		InstructionList& phiNodes = nodes[n]->getPhiNodeInstructions();
+
+		destination.clear();
+		for (InstructionList::iterator i = phiNodes.begin(); !phiNodes.done(i); i = phiNodes.advance(i)) {
+			Instruction& phiNode = phiNodes.get(i);
+			assert(phiNode.getInstructionDefineBegin() != phiNode.getInstructionDefineEnd() && phiNode.getInstructionDefineBegin()[0].isRegister());
+			destination.set(findRoot(phiNode.getInstructionDefineBegin()[0].getRegisterName(), rangeName));
+		}
+
+		for (InstructionList::iterator p = phiNodes.begin(); !phiNodes.done(p); p = phiNodes.advance(p)) {
+			Instruction& phiNode = phiNodes.get(p);
+
+			assert(phiNode.getInstructionDefineBegin() != phiNode.getInstructionDefineEnd() && phiNode.getInstructionDefineBegin()[0].isRegister());
+			RegisterName destinationName = phiNode.getInstructionDefineBegin()[0].getRegisterName();
+			RegisterName destinationRoot = findRoot(destinationName, rangeName);
+
+			InstructionUse* useEnd = phiNode.getInstructionUseEnd();
+			for (InstructionUse* usePtr = phiNode.getInstructionUseBegin(); usePtr < useEnd; usePtr++) {
+				assert(usePtr->isRegister());
+				RegisterName sourceName = usePtr->getRegisterName();
+				RegisterName sourceRoot = findRoot(sourceName, rangeName);
+
+				if (sourceRoot != destinationRoot && !destination.test(sourceRoot))
+					rangeName[sourceRoot] = destinationRoot;
+			}
+		}
+	}
+
+	registerAllocator.rangeCount = compress(registerAllocator.name2range, rangeName, nameCount, nameCount);
+}
+
+#endif // _LIVE_RANGE_H_

mozilla/ef/Compiler/RegisterAllocator/LiveRangeGraph.h

@@ -0,0 +1,163 @@
+/* -*- Mode: C++; tab-width: 4; indent-tabs-mode: nil; c-basic-offset: 4 -*-
+ *
+ * The contents of this file are subject to the Netscape Public License
+ * Version 1.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _LIVE_RANGE_GRAPH_
+#define _LIVE_RANGE_GRAPH_
+
+#include "Fundamentals.h"
+#include "Pool.h"
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+#include "Instruction.h"
+#include "RegisterTypes.h"
+
+class RegisterAllocator;
+
+template <class RegisterPressure>
+class LiveRangeGraph
+{
+private:
+
+	RegisterAllocator&		registerAllocator;
+
+	RegisterPressure::Set*	edges;
+	Uint32					rangeCount;
+
+public:
+	//
+	//
+	LiveRangeGraph(RegisterAllocator& registerAllocator) : registerAllocator(registerAllocator) {}
+
+	//
+	//
+	void build();
+
+	//
+	//
+	void addEdge(RegisterName name1, RegisterName name2);
+
+	//
+	//
+	bool haveEdge(RegisterName name1, RegisterName name2);
+
+#ifdef DEBUG_LOG
+	//
+	//
+	void printPretty(LogModuleObject log);
+#endif // DEBUG_LOG
+};
+
+template <class RegisterPressure>
+void LiveRangeGraph<RegisterPressure>::build()
+{
+	Pool& pool = registerAllocator.pool;
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	this->rangeCount = rangeCount;
+
+	edges = new(pool) RegisterPressure::Set(pool, rangeCount * rangeCount);
+
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	RegisterName* name2range = registerAllocator.name2range;
+	LivenessInfo<RegisterPressure>& liveness = registerAllocator.liveness;
+	SparseSet currentLive(pool, rangeCount);
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		ControlNode& node = *nodes[n];
+		currentLive = liveness.liveOut[n];
+
+		InstructionList& instructions = node.getInstructions();
+		for (InstructionList::iterator i = instructions.end(); !instructions.done(i); i = instructions.retreat(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			InstructionUse* useBegin = instruction.getInstructionUseBegin();
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			InstructionUse* usePtr;
+			InstructionDefine* defineBegin = instruction.getInstructionDefineBegin();
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			InstructionDefine* definePtr;
+
+			if ((instruction.getFlags() & ifCopy) != 0) {
+				assert(useBegin != useEnd && useBegin[0].isRegister());
+				currentLive.clear(name2range[useBegin[0].getRegisterName()]);
+			}
+
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister()) {
+					RegisterName define = name2range[definePtr->getRegisterName()];
+
+					for (SparseSet::iterator l = currentLive.begin(); !currentLive.done(l); l = currentLive.advance(l)) {
+						RegisterName live = RegisterName(currentLive.get(l));
+						if (define != live && registerAllocator.canInterfere(define, live))
+							addEdge(define, live);
+					}
+				}
+
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister())
+					currentLive.clear(name2range[definePtr->getRegisterName()]);
+
+			for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister())
+					currentLive.set(name2range[usePtr->getRegisterName()]);
+
+			for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister()) {
+					RegisterName use = name2range[usePtr->getRegisterName()];
+
+					for (SparseSet::iterator l = currentLive.begin(); !currentLive.done(l); l = currentLive.advance(l)) {
+						RegisterName live = RegisterName(currentLive.get(l));
+						if (use != live && registerAllocator.canInterfere(use, live))
+							addEdge(use, live);
+					}
+				}
+		}
+	}
+}
+
+template <class RegisterPressure>
+void LiveRangeGraph<RegisterPressure>::addEdge(RegisterName name1, RegisterName name2)
+{
+	assert(name1 != name2);
+	edges->set(name1 * rangeCount + name2);
+}
+
+template <class RegisterPressure>
+bool LiveRangeGraph<RegisterPressure>::haveEdge(RegisterName name1, RegisterName name2)
+{
+	assert(name1 != name2);
+	return edges->test(name1 * rangeCount + name2);
+}
+
+#ifdef DEBUG_LOG
+template <class RegisterPressure>
+void LiveRangeGraph<RegisterPressure>::printPretty(LogModuleObject log)
+{
+	UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("Live ranges graph:\n"));
+	for (RegisterName name1 = RegisterName(1); name1 < rangeCount; name1 = RegisterName(name1 + 1)) {
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\t%d:\t", name1));
+		for (RegisterName name2 = RegisterName(1); name2 < rangeCount; name2 = RegisterName(name2 + 1))
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("%c", ((name1 != name2) && haveEdge(name1, name2)) ? '1' : '0'));
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\n"));
+	}
+}
+#endif // DEBUG_LOG
+
+#endif // _LIVE_RANGE_GRAPH_

mozilla/ef/Compiler/RegisterAllocator/Liveness.cpp

@@ -0,0 +1,21 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "Liveness.h"
+

mozilla/ef/Compiler/RegisterAllocator/Liveness.h

@@ -0,0 +1,301 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _LIVENESS_H_
+#define _LIVENESS_H_
+
+#include "Fundamentals.h"
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+#include "Instruction.h"
+#include "RegisterTypes.h"
+
+// ----------------------------------------------------------------------------
+// LivenessInfo -
+
+template <class RegisterPressure>
+struct LivenessInfo
+{
+	RegisterPressure::Set*	liveIn;
+	RegisterPressure::Set*	liveOut;
+	DEBUG_LOG_ONLY(Uint32	size);
+
+#ifdef DEBUG_LOG
+	void printPretty(LogModuleObject log);
+#endif // DEBUG_LOG
+};
+
+// ----------------------------------------------------------------------------
+// Liveness
+//
+// The liveness is defined by the following data-flow equations:
+//
+//		LiveIn(n) = LocalLive(n) U (LiveOut(n) - Killed(n)).
+//		LiveOut(n) = U LiveIn(s) (s a successor of n).
+//
+//	where LocalLive(n) is the set of used registers in the block n, Killed(n)
+//  is the set of defined registers in the block n, LiveIn(n) is the set of
+//  live registers at the begining of the block n and LiveOut(n) is the set
+//  of live registers at the end of the block n.
+//
+//
+// We will compute the liveness analysis in two stages:
+//
+//	1- Build LocalLive(n) (wich is an approximation of LiveIn(n)) and Killed(n) 
+//     for each block n.
+//  2- Perform a backward data-flow analysis to propagate the liveness information
+//     through the entire control-flow graph.
+//
+
+template <class RegisterPressure>
+struct Liveness
+{
+	static LivenessInfo<RegisterPressure> analysis(ControlGraph& controlGraph, Uint32 rangeCount, const RegisterName* name2range);
+	static LivenessInfo<RegisterPressure> analysis(ControlGraph& controlGraph, Uint32 nameCount);
+};
+
+template <class RegisterPressure>
+LivenessInfo<RegisterPressure> Liveness<RegisterPressure>::analysis(ControlGraph& controlGraph, Uint32 rangeCount, const RegisterName* name2range)
+{
+	Pool& pool = controlGraph.pool;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	// Allocate the temporary sets.
+	RegisterPressure::Set* killed = new(pool) RegisterPressure::Set[nNodes](pool, rangeCount);
+	
+	// Allocate the globals sets.
+	RegisterPressure::Set* liveIn = new(pool) RegisterPressure::Set[nNodes](pool, rangeCount);
+	RegisterPressure::Set* liveOut = new(pool) RegisterPressure::Set[nNodes](pool, rangeCount);
+
+	// First stage of the liveness analysis: Compute the sets LocalLive(stored in LiveIn) and Killed.
+	//
+	for (Uint32 n = 0; n < (nNodes - 1); n++) {
+		ControlNode& node = *nodes[n];
+
+		RegisterPressure::Set& currentLocalLive = liveIn[n];
+		RegisterPressure::Set& currentKilled = killed[n];
+		
+		// Find the instructions contributions to the sets LocalLive and Killed.
+		//
+		InstructionList& instructions = node.getInstructions();
+		for (InstructionList::iterator i = instructions.begin(); !instructions.done(i); i = instructions.advance(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			// If a VirtualRegister is 'used' before being 'defined' then we add it to set LocalLive.
+
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister()) {
+					Uint32 index = name2range[usePtr->getRegisterName()];
+
+					if (!currentKilled.test(index))
+						currentLocalLive.set(index);
+				}
+
+			// If a Virtualregister is 'defined' then we add it to the set Killed.
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister())
+					currentKilled.set(name2range[definePtr->getRegisterName()]);
+		}
+	}
+
+	// Second stage of the liveness analysis: We propagate the LiveIn & LiveOut through the entire 
+	// control-flow graph.
+	//
+	RegisterPressure::Set temp(pool, rangeCount);
+
+	bool changed;
+	do {
+		changed = false;
+
+		// For all nodes is this graph except the endNode.
+		for (Int32 n = (nNodes - 2); n >= 0; n--) {
+			ControlNode& node = *nodes[n];
+
+			RegisterPressure::Set& currentLiveIn = liveIn[n];
+			RegisterPressure::Set& currentLiveOut = liveOut[n];
+
+			// Compute temp = Union of LiveIn(s) (s a successor of this node) | usedByPhiNodes(n).
+			// temp will be the new LiveOut(n).
+			Uint32 nSuccessors = node.nSuccessors();
+			if (nSuccessors != 0) {
+				temp = liveIn[node.nthSuccessor(0).getTarget().dfsNum];
+				for (Uint32 s = 1; s < nSuccessors; s++)
+					temp |= liveIn[node.nthSuccessor(s).getTarget().dfsNum];
+			} else 
+				temp.clear();
+
+			// If temp and LiveOut(n) differ then set LiveOut(n) = temp and recalculate the
+			// new LiveIn(n).
+			if (currentLiveOut != temp) {
+				currentLiveOut = temp;
+				temp -= killed[n]; // FIX: could be optimized with one call to unionDiff !
+				temp |= currentLiveIn;
+			
+				if (currentLiveIn != temp) {
+					currentLiveIn = temp;
+					changed = true;
+				}
+			}
+		}
+	} while(changed);
+
+	LivenessInfo<RegisterPressure> liveness;
+	liveness.liveIn = liveIn;
+	liveness.liveOut = liveOut;
+	DEBUG_LOG_ONLY(liveness.size = nNodes);
+	return liveness;
+}
+
+template <class RegisterPressure>
+LivenessInfo<RegisterPressure> Liveness<RegisterPressure>::analysis(ControlGraph& controlGraph, Uint32 nameCount)
+{
+	Pool& pool = controlGraph.pool;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	// Allocate the temporary sets.
+	RegisterPressure::Set* killed = new(pool) RegisterPressure::Set[nNodes](pool, nameCount);
+	RegisterPressure::Set* usedByPhiNodes = NULL;
+	
+	// Allocate the globals sets.
+	RegisterPressure::Set* liveIn = new(pool) RegisterPressure::Set[nNodes](pool, nameCount);
+	RegisterPressure::Set* liveOut = new(pool) RegisterPressure::Set[nNodes](pool, nameCount);
+
+	// First stage of the liveness analysis: Compute the sets LocalLive(stored in LiveIn) and Killed.
+	//
+	for (Uint32 n = 0; n < (nNodes - 1); n++) {
+		ControlNode& node = *nodes[n];
+
+		RegisterPressure::Set& currentLocalLive = liveIn[n];
+		RegisterPressure::Set& currentKilled = killed[n];
+		
+		InstructionList& phiNodes = node.getPhiNodeInstructions();
+
+		if ((usedByPhiNodes == NULL) && !phiNodes.empty())
+			usedByPhiNodes = new(pool) RegisterPressure::Set[nNodes](pool, nameCount);
+
+		for (InstructionList::iterator p = phiNodes.begin(); !phiNodes.done(p); p = phiNodes.advance(p)) {
+			Instruction& phiNode = phiNodes.get(p);
+
+			InstructionDefine& define = phiNode.getInstructionDefineBegin()[0];
+			currentKilled.set(define.getRegisterName());
+
+			typedef DoublyLinkedList<ControlEdge> ControlEdgeList;
+			const ControlEdgeList& predecessors = node.getPredecessors();
+			ControlEdgeList::iterator p = predecessors.begin();
+			InstructionUse* useEnd = phiNode.getInstructionUseEnd();
+			for (InstructionUse* usePtr = phiNode.getInstructionUseBegin(); usePtr < useEnd; usePtr++, p = predecessors.advance(p))
+				if (usePtr->isRegister())
+					usedByPhiNodes[predecessors.get(p).getSource().dfsNum].set(usePtr->getRegisterName());
+		}
+
+		// Find the instructions contributions to the sets LocalLive and Killed.
+		//
+		InstructionList& instructions = node.getInstructions();
+		for (InstructionList::iterator i = instructions.begin(); !instructions.done(i); i = instructions.advance(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			// If a VirtualRegister is 'used' before being 'defined' then we add it to set LocalLive.
+
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister()) {
+					Uint32 index = usePtr->getRegisterName();
+
+					if (!currentKilled.test(index))
+						currentLocalLive.set(index);
+				}
+
+			// If a Virtualregister is 'defined' then we add it to the set Killed.
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister())
+					currentKilled.set(definePtr->getRegisterName());
+		}
+	}
+
+	// Second stage of the liveness analysis: We propagate the LiveIn & LiveOut through the entire 
+	// control-flow graph.
+	//
+	RegisterPressure::Set temp(pool, nameCount);
+
+	bool changed;
+	do {
+		changed = false;
+
+		// For all nodes is this graph except the endNode.
+		for (Int32 n = (nNodes - 2); n >= 0; n--) {
+			ControlNode& node = *nodes[n];
+
+			RegisterPressure::Set& currentLiveIn = liveIn[n];
+			RegisterPressure::Set& currentLiveOut = liveOut[n];
+
+			// Compute temp = Union of LiveIn(s) (s a successor of this node) | usedByPhiNodes(n).
+			// temp will be the new LiveOut(n).
+			Uint32 nSuccessors = node.nSuccessors();
+			if (nSuccessors != 0) {
+				temp = liveIn[node.nthSuccessor(0).getTarget().dfsNum];
+				for (Uint32 s = 1; s < nSuccessors; s++)
+					temp |= liveIn[node.nthSuccessor(s).getTarget().dfsNum];
+			} else 
+				temp.clear();
+
+			// Insert the phiNodes contribution.
+			if (usedByPhiNodes != NULL)
+				temp |= usedByPhiNodes[n];
+
+			// If temp and LiveOut(n) differ then set LiveOut(n) = temp and recalculate the
+			// new LiveIn(n).
+			if (currentLiveOut != temp) {
+				currentLiveOut = temp;
+				temp -= killed[n]; // FIX: could be optimized with one call to unionDiff !
+				temp |= currentLiveIn;
+			
+				if (currentLiveIn != temp) {
+					currentLiveIn = temp;
+					changed = true;
+				}
+			}
+		}
+	} while(changed);
+
+	LivenessInfo<RegisterPressure> liveness;
+	liveness.liveIn = liveIn;
+	liveness.liveOut = liveOut;
+	DEBUG_LOG_ONLY(liveness.size = nNodes);
+	return liveness;
+}
+
+#ifdef DEBUG_LOG
+template <class RegisterPressure>
+void LivenessInfo<RegisterPressure>::printPretty(LogModuleObject log)
+{
+	for (Uint32 n = 0; n < size; n++) {
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("Node N%d:\n\tliveIn = ", n));
+		liveIn[n].printPretty(log);
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\tliveOut = "));
+		liveOut[n].printPretty(log);
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\n"));
+	}
+}
+#endif // DEBUG_LOG
+
+#endif // _LIVENESS_H_

mozilla/ef/Compiler/RegisterAllocator/Makefile

@@ -0,0 +1,40 @@
+#! gmake
+
+DEPTH			= ../..
+
+MODULE_NAME		= RegisterAllocator
+
+include $(DEPTH)/config/config.mk
+
+INCLUDES		+=										\
+	-I$(DEPTH)/Utilities/General						\
+	-I$(DEPTH)/Utilities/zlib							\
+	-I$(DEPTH)/Runtime/ClassReader						\
+	-I$(DEPTH)/Runtime/NativeMethods					\
+	-I$(DEPTH)/Runtime/System							\
+	-I$(DEPTH)/Runtime/ClassInfo						\
+	-I$(DEPTH)/Runtime/FileReader						\
+	-I$(DEPTH)/Compiler/PrimitiveGraph					\
+	-I$(DEPTH)/Compiler/FrontEnd						\
+	-I$(DEPTH)/Compiler/Optimizer						\
+	-I$(DEPTH)/Compiler/CodeGenerator					\
+	-I$(DEPTH)/Compiler/CodeGenerator/md				\
+	-I$(DEPTH)/Compiler/CodeGenerator/md/$(CPU_ARCH)	\
+	-I$(DEPTH)/Compiler/RegisterAllocator				\
+	-I$(DEPTH)/Driver/StandAloneJava					\
+	-I$(DEPTH)/Debugger									\
+	$(NULL)
+
+CXXSRCS 		=										\
+	RegisterAllocator.cpp								\
+	RegisterAllocatorTools.cpp							\
+	DominatorGraph.cpp									\
+	VirtualRegister.cpp									\
+	BitSet.cpp											\
+	SparseSet.cpp										\
+	$(NULL)
+
+
+include $(DEPTH)/config/rules.mk
+
+libs:: $(MODULE)

mozilla/ef/Compiler/RegisterAllocator/PhiNodeRemover.h

@@ -0,0 +1,392 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _PHI_NODE_REMOVER_H_
+#define _PHI_NODE_REMOVER_H_
+
+#include "Fundamentals.h"
+#include "Pool.h"
+#include "ControlGraph.h"
+#include "DominatorGraph.h"
+#include "VirtualRegister.h"
+#include "RegisterPressure.h"
+#include "Liveness.h"
+#include "Instruction.h"
+#include "InstructionEmitter.h"
+#include "SparseSet.h"
+#include <string.h>
+
+//------------------------------------------------------------------------------
+// RegisterNameNode -
+
+struct RegisterNameNode 
+{
+	RegisterNameNode*	next;
+	RegisterName		newName;
+	Uint32				nextPushed;
+};
+
+//------------------------------------------------------------------------------
+// CopyData -
+
+struct CopyData
+{
+	RegisterName		source;
+	RegisterClassKind	classKind;
+	Uint32				useCount;
+	bool				isLiveOut;
+	RegisterName		sourceNameToUse;
+	RegisterName		temporaryName;
+	RegisterNameNode*	newName;
+};
+
+//------------------------------------------------------------------------------
+// PhiNodeRemover<RegisterPressure> -
+
+template <class RegisterPressure>
+struct PhiNodeRemover
+{
+	// Replace the phi nodes by copy instructions.
+	static void replacePhiNodes(ControlGraph& controlGraph, VirtualRegisterManager& vrManager, InstructionEmitter& emitter);
+};
+
+// Split some of the critical edges and return true if there are still some
+// in the graph after that.
+//
+static bool splitCriticalEdges(ControlGraph& /*cg*/)
+{
+	// FIX: not implemented.
+	return true;
+}
+
+inline void pushName(Pool& pool, RegisterNameNode** stack, SparseSet& pushed, Uint32* nodeListPointer, RegisterName oldName, RegisterName newName)
+{
+	RegisterNameNode& newNode = *new(pool) RegisterNameNode();
+
+	if (pushed.test(oldName))
+		(*stack)->newName = newName;
+	else {
+		newNode.newName = newName;
+		newNode.nextPushed = *nodeListPointer;
+		*nodeListPointer = oldName;
+		newNode.next = *stack;
+		*stack = &newNode;
+		pushed.set(oldName);
+	}
+}
+
+template <class RegisterPressure>
+void PhiNodeRemover<RegisterPressure>::replacePhiNodes(ControlGraph& controlGraph, VirtualRegisterManager& vrManager, InstructionEmitter& emitter)
+{
+	Pool& pool = controlGraph.pool;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	// Initialize the local variables.
+	//
+
+	// When we insert the copies we will also need to create new VirtualRegisters for
+	// the insertion of temporaries. The maximum number of temporary register will not
+	// exceed the number of phiNodes in the primitive graph.
+	Uint32 nameCount = vrManager.getSize();
+	Uint32 maxNameCount = nameCount;
+	for (Uint32 n = 0; n < nNodes; n++)
+		maxNameCount += nodes[n]->getPhiNodes().length();
+
+	// If the CFG contains some critical edges (backward edge which source has more than one
+	// outgoing edge and destination has more than one incomimg edge) then we need the liveness
+	// information to be able to insert temporary copies.
+	RegisterPressure::Set* liveOut = NULL;
+	if (splitCriticalEdges(controlGraph))
+		liveOut = Liveness<LowRegisterPressure>::analysis(controlGraph, nameCount).liveOut;
+
+	DominatorGraph dGraph(controlGraph);
+
+	SparseSet pushed(pool, maxNameCount);
+	SparseSet destinationList(pool, maxNameCount);
+	SparseSet workList(pool, maxNameCount);
+
+	CopyData* copyStats = new(pool) CopyData[maxNameCount];
+	memset(copyStats, '\0', maxNameCount*sizeof(CopyData));
+
+	struct NodeStack {
+		Uint32* next;
+		Uint32* limit;
+		Uint32 pushedList;
+	};
+
+	// Allocate the node stack and initialize the node stack pointer.
+	NodeStack* nodeStack = new(pool) NodeStack[nNodes + 1];
+	NodeStack* nodeStackPtr = nodeStack;
+
+	// We start by the begin node. 
+	Uint32 startNode = 0;
+	Uint32* next = &startNode;
+	Uint32* limit = &startNode + 1;
+
+	while (true) {
+
+		if (next == limit) {
+			// If there are no more node in the sibling, we have to pop the current
+			// frame from the stack and update the copyStats of the pushed nodes.
+			//
+			if (nodeStackPtr == nodeStack)
+				// We are at the bottom of the stack and there are no more nodes
+				// to look at. We are done !
+				break;
+
+			--nodeStackPtr;
+			// We are done with all the children of this node in the dominator tree.
+			// We need to update the copy information of all the new names pushed
+			// during the walk over this node.
+			Uint32 pushedList = nodeStackPtr->pushedList;
+			while (pushedList != 0) {
+				Uint32 nextName = copyStats[pushedList].newName->nextPushed;
+				copyStats[pushedList].newName = copyStats[pushedList].newName->next;
+				pushedList = nextName;
+			}
+
+			// restore the previous frame.
+			next = nodeStackPtr->next;
+			limit = nodeStackPtr->limit;
+		} else {
+			Uint32 currentNode = *next++;
+			Uint32 pushedList = 0;
+
+
+			// Initialize the sets.
+			pushed.clear();
+			destinationList.clear();
+
+			// STEP1:
+			//  Walk the instruction list and to replace all the instruction uses with their new name. 
+			//  If the instruction is a phi node and its defined register is alive at the end of this 
+			//  block then we push the defined register into the stack.
+			//
+			ControlNode& node = *nodes[currentNode];
+			RegisterPressure::Set* currentLiveOut = (liveOut != NULL) ? &liveOut[currentNode] : (RegisterPressure::Set*) 0;
+
+			InstructionList& phiNodes = node.getPhiNodeInstructions();
+			for (InstructionList::iterator p = phiNodes.begin(); !phiNodes.done(p); p = phiNodes.advance(p)) {
+				Instruction& phiNode = phiNodes.get(p);
+
+				InstructionUse* useEnd = phiNode.getInstructionUseEnd();
+				for (InstructionUse* usePtr = phiNode.getInstructionUseBegin(); usePtr < useEnd; usePtr++) {
+					assert(usePtr->isRegister());
+					RegisterName name = usePtr->getRegisterName();
+
+					if (copyStats[name].newName != NULL && copyStats[name].newName->newName != name)
+						usePtr->setRegisterName(copyStats[name].newName->newName);
+				}
+
+				if (currentLiveOut != NULL) {
+					// This is a phi node and we have to push its defined name if it is live
+					// at the end of the node. We only need to do this if the CFG has critical edges.
+					assert(phiNode.getInstructionDefineBegin() != phiNode.getInstructionDefineEnd() && phiNode.getInstructionDefineBegin()[0].isRegister());
+					RegisterName name = phiNode.getInstructionDefineBegin()[0].getRegisterName();
+
+					if (currentLiveOut->test(name))
+						pushName(pool, &(copyStats[name].newName), pushed, &pushedList, name, name);
+				}
+				
+			}
+
+			InstructionList& instructions = node.getInstructions();
+			for (InstructionList::iterator i = instructions.begin(); !instructions.done(i); i = instructions.advance(i)) {
+				Instruction& instruction = instructions.get(i);
+
+				InstructionUse* useEnd = instruction.getInstructionUseEnd();
+				for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+					if (usePtr->isRegister()) {
+						RegisterName name = usePtr->getRegisterName();
+
+						if (copyStats[name].newName != NULL && copyStats[name].newName->newName != name)
+							usePtr->setRegisterName(copyStats[name].newName->newName);
+					}
+			}
+
+			// STEP2:
+			//  Look at this node's successors' phiNodes. We keep track of the number of time
+			//  a VR will be used by another copy instruction and insert each definition into the 
+			//  destinationList. This is the only pass over this node's successors as we will
+			//  get all the information we need in the CopyData structures.
+			//
+			ControlEdge* successorEdgeEnd = node.getSuccessorsEnd();
+			for (ControlEdge* successorEdgePtr = node.getSuccessorsBegin(); successorEdgePtr < successorEdgeEnd; successorEdgePtr++) {
+				Uint32 useIndex = successorEdgePtr->getIndex();
+				ControlNode& successor = successorEdgePtr->getTarget();
+
+				// Look at its phi nodes. The phi nodes are at the top of the instruction list. We exit
+				// as soon as we find an instruction which is not a phi node
+				InstructionList& phiNodes = successor.getPhiNodeInstructions();
+				for (InstructionList::iterator p = phiNodes.begin(); !phiNodes.done(p); p = phiNodes.advance(p)) {
+					Instruction& phiNode = phiNodes.get(p);
+					
+					assert((phiNode.getInstructionUseBegin() + useIndex) < phiNode.getInstructionUseEnd());
+					assert(phiNode.getInstructionDefineBegin() != phiNode.getInstructionDefineEnd());
+
+					InstructionUse& source = phiNode.getInstructionUseBegin()[useIndex];
+					InstructionDefine& destination = phiNode.getInstructionDefineBegin()[0];
+
+					assert(source.isRegister() && destination.isRegister());
+
+					RegisterName sourceName = source.getRegisterName();
+					RegisterName destinationName = destination.getRegisterName();
+
+					// Get the correct name for the source.
+					if (copyStats[sourceName].newName != NULL)
+						sourceName = copyStats[sourceName].newName->newName;
+
+					// Update the CopyData structures.
+					if ((sourceName != rnInvalid) && (sourceName != destinationName)) {
+						copyStats[destinationName].source = sourceName;
+						copyStats[destinationName].classKind = destination.getRegisterClass();
+						copyStats[destinationName].isLiveOut = (currentLiveOut != NULL) ? currentLiveOut->test(destinationName) : false;
+						copyStats[destinationName].sourceNameToUse = destinationName;
+						copyStats[sourceName].sourceNameToUse = sourceName;
+						copyStats[sourceName].useCount++;
+						destinationList.set(destinationName);
+					}
+				}
+			}
+
+			// STEP3:
+			//  Insert into the worklist only the destination registers that will be not used in 
+			//  another copy instruction in this block.
+			//
+			assert(workList.getSize() == 0);
+			for (SparseSet::iterator d = destinationList.begin(); !destinationList.done(d); d = destinationList.advance(d)) {
+				Uint32 dest = destinationList.get(d);
+				if (copyStats[dest].useCount == 0)
+					workList.set(dest);
+			}
+
+			// STEP4:
+			//  Insert the copy instructions.
+			//
+			Uint32 destinationListSize = destinationList.getSize();
+			InstructionList::iterator endOfTheNode = instructions.end();
+
+			// Find the right place to insert the copy instructions.
+			if (destinationListSize != 0)
+				while (instructions.get(endOfTheNode).getFlags() & ifControl)
+					endOfTheNode = instructions.retreat(endOfTheNode);
+
+			while (destinationListSize != 0) {
+				while(workList.getSize()) {
+					RegisterName destinationName = RegisterName(workList.getOne());
+					RegisterName sourceName = copyStats[destinationName].source;
+
+					workList.clear(destinationName);
+					if (copyStats[destinationName].isLiveOut && !copyStats[destinationName].temporaryName) {
+						// Lost copy problem.
+						copyStats[destinationName].isLiveOut = false;
+
+						RegisterName sourceName = destinationName;
+						RegisterClassKind classKind = copyStats[sourceName].classKind;
+						RegisterName destinationName = getName(vrManager.newVirtualRegister(classKind));
+						assert(destinationName < maxNameCount);
+
+						copyStats[destinationName].classKind = classKind;
+						copyStats[sourceName].useCount = 0;
+				
+						// We need to insert a copy to a temporary register to keep the
+						// source register valid at the end of the node defining it.
+						// This copy will be inserted right after the phi node defining it.
+						RegisterName from = copyStats[sourceName].sourceNameToUse;
+						Instruction* definingPhiNode = vrManager.getVirtualRegister(from).getDefiningInstruction();
+						assert(definingPhiNode && (definingPhiNode->getFlags() & ifPhiNode) != 0);
+
+						RegisterID fromID = buildRegisterID(from, classKind);
+						RegisterID toID = buildRegisterID(destinationName, classKind);
+						Instruction& copy = emitter.newCopy(*definingPhiNode->getPrimitive(), fromID, toID);
+						vrManager.getVirtualRegister(destinationName).setDefiningInstruction(copy);
+						definingPhiNode->getPrimitive()->getContainer()->getInstructions().addFirst(copy);
+
+						copyStats[sourceName].temporaryName = destinationName;
+						copyStats[sourceName].sourceNameToUse = destinationName;
+						pushName(pool, &(copyStats[sourceName].newName), pushed, &pushedList, sourceName, destinationName);
+					}
+
+					// Insert the copy instruction at the end of the current node.
+					RegisterName from = copyStats[sourceName].sourceNameToUse;
+
+					RegisterClassKind classKind = copyStats[destinationName].classKind;
+					RegisterID fromID = buildRegisterID(from, classKind);
+					RegisterID toID = buildRegisterID(destinationName, classKind);
+					Instruction& copy = emitter.newCopy(*vrManager.getVirtualRegister(from).getDefiningInstruction()->getPrimitive(), fromID, toID);
+					instructions.insertAfter(copy, endOfTheNode);
+					endOfTheNode = instructions.advance(endOfTheNode);
+
+					copyStats[sourceName].useCount = 0;
+					if (destinationList.test(sourceName) && copyStats[sourceName].isLiveOut)
+						pushName(pool, &(copyStats[sourceName].newName), pushed, &pushedList, sourceName, destinationName);
+					copyStats[sourceName].isLiveOut = false;
+					copyStats[sourceName].sourceNameToUse = destinationName;
+
+					if (destinationList.test(sourceName))
+						workList.set(sourceName);
+					destinationList.clear(destinationName);
+				}
+
+				destinationListSize = destinationList.getSize();
+				if (destinationListSize != 0) {
+					RegisterName sourceName = RegisterName(destinationList.getOne());
+					RegisterName destinationName;
+
+					if (!copyStats[sourceName].temporaryName) {
+						// Cycle problem.
+						RegisterClassKind classKind = copyStats[sourceName].classKind;
+						destinationName = getName(vrManager.newVirtualRegister(classKind));
+						assert(destinationName < maxNameCount);
+				
+						copyStats[destinationName].classKind = classKind;
+						copyStats[sourceName].temporaryName = destinationName;
+
+						// Insert the copy instruction at the end of the current node.
+						RegisterName from = copyStats[sourceName].sourceNameToUse;
+
+						RegisterID fromID = buildRegisterID(from, classKind);
+						RegisterID toID = buildRegisterID(destinationName, classKind);
+						Instruction& copy = emitter.newCopy(*vrManager.getVirtualRegister(from).getDefiningInstruction()->getPrimitive(), fromID, toID);
+						vrManager.getVirtualRegister(destinationName).setDefiningInstruction(copy);
+						instructions.insertAfter(copy, endOfTheNode);
+						endOfTheNode = instructions.advance(endOfTheNode);
+					} else 
+						destinationName = copyStats[sourceName].temporaryName;
+
+					copyStats[sourceName].useCount = 0;
+					copyStats[sourceName].isLiveOut = false;
+					copyStats[sourceName].sourceNameToUse = destinationName;
+					pushName(pool, &(copyStats[sourceName].newName), pushed, &pushedList, sourceName, destinationName);
+
+					workList.set(sourceName);
+				}
+			}
+
+			nodeStackPtr->pushedList = pushedList;
+			nodeStackPtr->next = next;
+			nodeStackPtr->limit = limit;
+			++nodeStackPtr;
+			next = dGraph.getSuccessorsBegin(currentNode);
+			limit = dGraph.getSuccessorsEnd(currentNode);
+		}
+	}
+}
+
+#endif // _PHI_NODE_REMOVER_H_

mozilla/ef/Compiler/RegisterAllocator/RegisterAllocator.cpp

@@ -0,0 +1,155 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "LogModule.h"
+#include "RegisterAllocator.h"
+#include "RegisterPressure.h"
+#include "RegisterAllocatorTools.h"
+#include "PhiNodeRemover.h"
+#include "LiveRange.h"
+#include "Liveness.h"
+#include "InterferenceGraph.h"
+#include "LiveRangeGraph.h"
+#include "Coalescing.h"
+#include "Spilling.h"
+#include "Coloring.h"
+#include "Splits.h"
+
+class Pool;
+class ControlGraph;
+class VirtualRegisterManager;
+class InstructionEmitter;
+
+UT_DEFINE_LOG_MODULE(RegAlloc);
+
+void RegisterAllocator::allocateRegisters(Pool& pool, ControlGraph& controlGraph, VirtualRegisterManager& vrManager, InstructionEmitter& emitter)
+{
+	// Insert the phi node instructions. We want to do this to have a single defined register per instruction.
+	// If we keep the PhiNode (as a DataNode) and a PhiNode is of DoubleWordKind then we have to execute
+	// some special code for the high word annotation.
+	//
+	RegisterAllocatorTools::insertPhiNodeInstructions(controlGraph, emitter);
+
+	// Perform some tests on the instruction graph.
+	//
+	DEBUG_ONLY(RegisterAllocatorTools::testTheInstructionGraph(controlGraph, vrManager));
+
+	// Replace the phi node instructions by their equivalent copy instructions.
+	//
+	PhiNodeRemover<LowRegisterPressure>::replacePhiNodes(controlGraph, vrManager, emitter);
+
+	// Do the register allocation.
+	//
+	RegisterAllocator registerAllocator(pool, controlGraph, vrManager, emitter);
+	registerAllocator.doGraphColoring();
+}
+
+void RegisterAllocator::doGraphColoring()
+{
+	// Initialize the liverange map.
+	//
+	initLiveRanges();
+
+	// Build the live ranges. We do this to compress the number of RegisterNames 
+	// used in the insterference graph.
+	//
+	LiveRange<LowRegisterPressure>::build(*this);
+
+	// Remove unnecessary copies.
+	//
+	RegisterAllocatorTools::removeUnnecessaryCopies(*this);
+
+	for (Uint8 loop = 0; loop < 10; loop++) {
+
+		UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("********* RegisterAllocator loop %d *********\n", loop));
+
+		while(true) {
+			// Build the interference graph.
+			//
+			iGraph.build();
+
+			// Coalesce the copy instructions.
+			//
+			if (!Coalescing<LowRegisterPressure>::coalesce(*this))
+				break;
+		}
+
+		// Print the interference graph.
+		//
+		DEBUG_LOG_ONLY(iGraph.printPretty(UT_LOG_MODULE(RegAlloc)));
+
+		// Calculate the spill costs.
+		//
+		Spilling<LowRegisterPressure>::calculateSpillCosts(*this);
+		DEBUG_LOG_ONLY(RegisterAllocatorTools::printSpillCosts(*this));
+
+		// Calculate the split costs.
+		//
+		Splits<LowRegisterPressure>::calculateSplitCosts(*this);
+		DEBUG_LOG_ONLY(RegisterAllocatorTools::printSplitCosts(*this));
+
+		// Build the live range graph.
+		//
+		lGraph.build();
+		DEBUG_LOG_ONLY(lGraph.printPretty(UT_LOG_MODULE(RegAlloc)));
+
+		// Color the graph. If it succeeds then we're done with the
+		// register allocation.
+		//
+		if (Coloring<LowRegisterPressure>::color(*this)) {
+			// Write the final colors in the instruction graph.
+			//
+			Coloring<LowRegisterPressure>::finalColoring(*this);
+
+			UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("********** RegisterAllocator  done **********\n"));
+			DEBUG_LOG_ONLY(RegisterAllocatorTools::printInstructions(*this));
+
+			return;
+		}
+
+		// We need to spill some registers.
+		//
+		Spilling<LowRegisterPressure>::insertSpillCode(*this);
+
+		// Insert the split instructions.
+		//
+		Splits<LowRegisterPressure>::insertSplitCode(*this);
+
+		// Update the live ranges.
+		// 
+		// FIX
+	}
+
+#ifdef DEBUG_LOG
+	RegisterAllocatorTools::updateInstructionGraph(*this);
+	RegisterAllocatorTools::printInstructions(*this);
+#endif
+	fprintf(stderr, "!!! Coloring failed after 10 loops !!!\n");
+	abort();
+}
+
+void RegisterAllocator::initLiveRanges()
+{
+	Uint32 count = this->nameCount;
+	RegisterName* name2range = new(pool) RegisterName[nameCount];
+	for (RegisterName r = RegisterName(1); r < count; r = RegisterName(r + 1))
+		name2range[r] = r;
+	this->name2range = name2range;
+	rangeCount = count;
+}

mozilla/ef/Compiler/RegisterAllocator/RegisterAllocator.h

@@ -0,0 +1,88 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _REGISTER_ALLOCATOR_H_
+#define _REGISTER_ALLOCATOR_H_
+
+class Pool;
+class ControlGraph;
+class InstructionEmitter;
+struct SpillCost;
+struct SplitCost;
+
+#include "Liveness.h"
+#include "VirtualRegister.h"
+#include "RegisterPressure.h" // This should included by Backend.cpp
+#include "InterferenceGraph.h"
+#include "LiveRangeGraph.h"
+
+//template <class RegisterPressure>
+class RegisterAllocator
+{
+public:
+
+	Pool&									pool;			//
+	ControlGraph&							controlGraph;	//
+	VirtualRegisterManager&					vrManager;		//
+	InstructionEmitter&						emitter;		//
+
+	RegisterName*							name2range;		//
+	RegisterName*							color;			//
+	SpillCost*								spillCost;		//
+	SparseSet*								willSpill;		//
+	SplitCost*								splitCost;		//
+	NameLinkedList**						splitAround;	//
+	InterferenceGraph<LowRegisterPressure>	iGraph;			//
+	LiveRangeGraph<LowRegisterPressure>		lGraph;			//
+	LivenessInfo<LowRegisterPressure>		liveness;		//
+	Uint32									nameCount;		//
+	Uint32									rangeCount;		//
+	bool									splitFound;		//
+
+private:
+
+	//
+	//
+	void doGraphColoring();
+
+public:
+
+	//
+	//
+	inline RegisterAllocator(Pool& pool, ControlGraph& controlGraph, VirtualRegisterManager& vrManager, InstructionEmitter& emitter);
+
+	//
+	//
+	bool canInterfere(RegisterName /*name1*/, RegisterName /*name2*/) const {return true;}
+
+	//
+	//
+	void initLiveRanges();
+
+	//
+	//
+	static void allocateRegisters(Pool& pool, ControlGraph& controlGraph, VirtualRegisterManager& vrManager, InstructionEmitter& emitter);
+};
+
+//
+//
+inline RegisterAllocator::RegisterAllocator(Pool& pool, ControlGraph& controlGraph, VirtualRegisterManager& vrManager, InstructionEmitter& emitter)
+	: pool(pool), controlGraph(controlGraph), vrManager(vrManager), emitter(emitter), iGraph(*this), lGraph(*this), nameCount(vrManager.getSize()) {}
+
+#endif // _REGISTER_ALLOCATOR_H_
+

mozilla/ef/Compiler/RegisterAllocator/RegisterAllocatorTools.cpp

@@ -0,0 +1,355 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "LogModule.h"
+#include "RegisterAllocatorTools.h"
+#include "Pool.h"
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+#include "Primitives.h"
+#include "InstructionEmitter.h"
+#include "Instruction.h"
+#include "RegisterAllocator.h"
+#include "Spilling.h"
+#include "Splits.h"
+#include "BitSet.h"
+
+UT_EXTERN_LOG_MODULE(RegAlloc);
+
+#ifdef DEBUG
+void RegisterAllocatorTools::testTheInstructionGraph(ControlGraph& controlGraph, VirtualRegisterManager& vrManager)
+{
+	// Test the declared VirtualRegisters. The register allocator tries to condense the register universe.
+	// Any gap in the VirtualRegister names will be a loss of efficiency !!!!
+
+	Uint32 nameCount = vrManager.getSize();
+	BitSet registerSeen(controlGraph.pool, nameCount);
+
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+
+		InstructionList& instructions = nodes[n]->getInstructions();
+		for (InstructionList::iterator i = instructions.begin(); !instructions.done(i); i = instructions.advance(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister())
+					registerSeen.set(usePtr->getRegisterName());
+
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister())
+					registerSeen.set(definePtr->getRegisterName());
+		}
+
+		InstructionList& phiNodes = nodes[n]->getPhiNodeInstructions();
+		for (InstructionList::iterator p = phiNodes.begin(); !phiNodes.done(p); p = phiNodes.advance(p)) {
+			Instruction& instruction = phiNodes.get(p);
+
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister())
+					registerSeen.set(usePtr->getRegisterName());
+
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister())
+					registerSeen.set(definePtr->getRegisterName());
+		}
+	}
+
+	bool renameRegisters = false;
+	for (BitSet::iterator i = registerSeen.nextZero(0); !registerSeen.done(i); i = registerSeen.nextZero(i)) {
+		renameRegisters = true;
+		fprintf(stderr, 
+				"WARNING: The VirtualRegister vr%d has been allocated during CodeGeneration but\n"
+				"         is never used nor defined by any instruction in the instruction graph\n"
+				"                                  PLEASE FIX                                  \n",
+				i);
+	}
+	if (renameRegisters) {
+		Instruction** definingInstruction = new Instruction*[nameCount];
+		memset(definingInstruction, '\0', nameCount * sizeof(Instruction*));
+		RegisterName* newName = new RegisterName[nameCount];
+		memset(newName, '\0', nameCount * sizeof(RegisterName));
+		RegisterName nextName = RegisterName(1);
+
+		for (Uint32 n = 0; n < nNodes; n++) {
+
+			InstructionList& instructions = nodes[n]->getInstructions();
+			for (InstructionList::iterator i = instructions.begin(); !instructions.done(i); i = instructions.advance(i)) {
+				Instruction& instruction = instructions.get(i);
+
+				InstructionUse* useEnd = instruction.getInstructionUseEnd();
+				for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+					if (usePtr->isRegister()) {
+						RegisterName name = usePtr->getRegisterName();
+						if (newName[name] == rnInvalid) {
+							newName[name] = nextName;
+							definingInstruction[nextName] = vrManager.getVirtualRegister(name).getDefiningInstruction();
+							nextName = RegisterName(nextName + 1);
+						}
+						usePtr->setRegisterName(newName[name]);
+					}
+
+				InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+				for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+					if (definePtr->isRegister()) {
+						RegisterName name = definePtr->getRegisterName();
+						if (newName[name] == rnInvalid) {
+							newName[name] = nextName;
+							definingInstruction[nextName] = vrManager.getVirtualRegister(name).getDefiningInstruction();
+							nextName = RegisterName(nextName + 1);
+						}
+						definePtr->setRegisterName(newName[name]);
+					}
+			}
+
+			InstructionList& phiNodes = nodes[n]->getPhiNodeInstructions();
+			for (InstructionList::iterator p = phiNodes.begin(); !phiNodes.done(p); p = phiNodes.advance(p)) {
+				Instruction& instruction = phiNodes.get(p);
+
+				InstructionUse* useEnd = instruction.getInstructionUseEnd();
+				for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+					if (usePtr->isRegister()) {
+						RegisterName name = usePtr->getRegisterName();
+						if (newName[name] == rnInvalid) {
+							newName[name] = nextName;
+							definingInstruction[nextName] = vrManager.getVirtualRegister(name).getDefiningInstruction();
+							nextName = RegisterName(nextName + 1);
+						}
+						usePtr->setRegisterName(newName[name]);
+					}
+
+				InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+				for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+					if (definePtr->isRegister()) {
+						RegisterName name = definePtr->getRegisterName();
+						if (newName[name] == rnInvalid) {
+							newName[name] = nextName;
+							definingInstruction[nextName] = vrManager.getVirtualRegister(name).getDefiningInstruction();
+							nextName = RegisterName(nextName + 1);
+						}
+						definePtr->setRegisterName(newName[name]);
+					}
+			}
+		}
+		
+		vrManager.setSize(nextName);
+
+		for (RegisterName r = RegisterName(1); r < nextName; r = RegisterName(r + 1))
+			vrManager.getVirtualRegister(r).definingInstruction = definingInstruction[r];
+
+		UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("RegisterMap:\n"));
+		for (Uint32 i = 1; i < nameCount; i++)
+			if (newName[i] != 0)
+				UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\tvr%d becomes vr%d.\n", i, newName[i]));
+			else
+				UT_OBJECTLOG(UT_LOG_MODULE(RegAlloc), PR_LOG_ALWAYS, ("\tvr%d is dead.\n", i));
+
+
+		delete newName;
+		delete definingInstruction;
+	}
+
+}
+#endif // DEBUG
+
+void RegisterAllocatorTools::removeUnnecessaryCopies(RegisterAllocator& registerAllocator)
+{
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+	RegisterName* name2range = registerAllocator.name2range;
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		InstructionList& instructions = nodes[n]->getInstructions();
+		for (InstructionList::iterator i = instructions.begin(); !instructions.done(i);) {
+			Instruction& instruction = instructions.get(i);
+			i = instructions.advance(i);
+
+			if (instruction.getFlags() & ifCopy) {
+				assert(instruction.getInstructionUseBegin() != instruction.getInstructionUseEnd() && instruction.getInstructionUseBegin()[0].isRegister());
+				assert(instruction.getInstructionDefineBegin() != instruction.getInstructionDefineEnd() && instruction.getInstructionDefineBegin()[0].isRegister());
+				
+				RegisterName source = name2range[instruction.getInstructionUseBegin()[0].getRegisterName()];
+				RegisterName destination = name2range[instruction.getInstructionDefineBegin()[0].getRegisterName()];
+
+				if (source == destination)
+					instruction.remove();
+			}
+		}
+	}
+}
+
+
+void RegisterAllocatorTools::updateInstructionGraph(RegisterAllocator& registerAllocator)
+{
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+	RegisterName* name2range = registerAllocator.name2range;
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		InstructionList& instructions = nodes[n]->getInstructions();
+		for (InstructionList::iterator i = instructions.begin(); !instructions.done(i); i = instructions.advance(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister())
+					usePtr->setRegisterName(name2range[usePtr->getRegisterName()]);
+
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister())
+					definePtr->setRegisterName(name2range[definePtr->getRegisterName()]);
+		}
+
+		InstructionList& phiNodes = nodes[n]->getPhiNodeInstructions();
+		for (InstructionList::iterator p = phiNodes.begin(); !phiNodes.done(p); p = phiNodes.advance(p)) {
+			Instruction& instruction = phiNodes.get(p);
+
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			for (InstructionUse* usePtr = instruction.getInstructionUseBegin(); usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister())
+					usePtr->setRegisterName(name2range[usePtr->getRegisterName()]);
+
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			for (InstructionDefine* definePtr = instruction.getInstructionDefineBegin(); definePtr < defineEnd; definePtr++)
+				if (definePtr->isRegister())
+					definePtr->setRegisterName(name2range[definePtr->getRegisterName()]);
+		}
+	}
+}
+
+
+void RegisterAllocatorTools::insertPhiNodeInstructions(ControlGraph& controlGraph, InstructionEmitter& emitter)
+{
+	Pool& pool = controlGraph.pool;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+	
+	for (Uint32 n = 0; n < nNodes; n++) {
+		ControlNode& node = *nodes[n];
+		DoublyLinkedList<PhiNode>& phiNodes = node.getPhiNodes();
+
+		if (!phiNodes.empty()) {
+
+			// Set the index of the incoming edges.
+			Uint32 index = 0;
+			const DoublyLinkedList<ControlEdge>& predecessors = node.getPredecessors();
+			for (DoublyLinkedList<ControlEdge>::iterator p = predecessors.begin(); !predecessors.done(p); p = predecessors.advance(p))
+				predecessors.get(p).setIndex(index++);
+
+			// Insert the phi node instruction in the instruction list.
+			for (DoublyLinkedList<PhiNode>::iterator i = phiNodes.begin(); !phiNodes.done(i); i = phiNodes.advance(i)) {
+				PhiNode& phiNode = phiNodes.get(i);
+				ValueKind kind = phiNode.getKind();
+
+				if (!isStorableKind(kind))
+					continue;
+
+				RegisterClassKind classKind = rckGeneral; // FIX: get class kind from phi node kind.
+				Uint32 nInputs = phiNode.nInputs();
+
+				PhiNodeInstruction& phiNodeInstruction = *new(pool) PhiNodeInstruction(&phiNode, pool, nInputs);
+
+				emitter.defineProducer(phiNode, phiNodeInstruction, 0, classKind, drLow);
+				for (Uint32 whichInput = 0; whichInput < nInputs; whichInput++)
+					emitter.useProducer(phiNode.nthInputVariable(whichInput), phiNodeInstruction, whichInput, classKind, drLow);
+
+				node.addPhiNodeInstruction(phiNodeInstruction);
+
+				if (isDoublewordKind(kind)) {
+					PhiNodeInstruction& phiNodeInstruction = *new(pool) PhiNodeInstruction(&phiNode, pool, nInputs);
+
+					emitter.defineProducer(phiNode, phiNodeInstruction, 0, classKind, drHigh);
+					for (Uint32 whichInput = 0; whichInput < nInputs; whichInput++)
+						emitter.useProducer(phiNode.nthInputVariable(whichInput), phiNodeInstruction, whichInput, classKind, drHigh);
+
+					node.addPhiNodeInstruction(phiNodeInstruction);
+				}
+			}
+		}
+	}
+}
+
+#ifdef DEBUG_LOG
+
+void RegisterAllocatorTools::printSpillCosts(RegisterAllocator& registerAllocator)
+{
+	LogModuleObject log = UT_LOG_MODULE(RegAlloc);
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	SpillCost* cost = registerAllocator.spillCost;
+
+	UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("Spill costs:\n"));
+	for (Uint32 i = 1; i < rangeCount; i++) {
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\trange %d : ", i));
+		if (cost[i].infinite)
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("infinite\n"));
+		else
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("%f\n", cost[i].cost));
+	}
+}
+
+void RegisterAllocatorTools::printSplitCosts(RegisterAllocator& registerAllocator)
+{
+	LogModuleObject log = UT_LOG_MODULE(RegAlloc);
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	SplitCost* cost = registerAllocator.splitCost;
+
+	UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("Split costs:\n"));
+	for (Uint32 i = 1; i < rangeCount; i++) {
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\trange %d : loads = %f stores = %f\n", i, cost[i].loads, cost[i].stores));
+	}
+}
+
+void RegisterAllocatorTools::printInstructions(RegisterAllocator& registerAllocator)
+{
+	LogModuleObject log = UT_LOG_MODULE(RegAlloc);
+	ControlNode** nodes = registerAllocator.controlGraph.dfsList;
+	Uint32 nNodes = registerAllocator.controlGraph.nNodes;
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("N%d:\n", n));
+
+		InstructionList& phiNodes = nodes[n]->getPhiNodeInstructions();
+		InstructionList& instructions = nodes[n]->getInstructions();
+
+		if (!phiNodes.empty()) {
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, (" PhiNodes:\n", n));
+			for(InstructionList::iterator i = phiNodes.begin(); !phiNodes.done(i); i = phiNodes.advance(i)) {
+				phiNodes.get(i).printPretty(log);
+				UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\n"));
+			}
+			if (!instructions.empty())
+				UT_OBJECTLOG(log, PR_LOG_ALWAYS, (" Instructions:\n", n));
+		}
+
+		for(InstructionList::iterator i = instructions.begin(); !instructions.done(i); i = instructions.advance(i)) {
+			instructions.get(i).printPretty(log);
+			UT_OBJECTLOG(log, PR_LOG_ALWAYS, ("\n"));
+		}
+	}
+}
+#endif // DEBUG_LOG

mozilla/ef/Compiler/RegisterAllocator/RegisterAllocatorTools.h

@@ -0,0 +1,117 @@
+//	-*- mode:C++; tab-width:4; truncate-lines:t -*-
+//
+//           CONFIDENTIAL AND PROPRIETARY SOURCE CODE OF
+//              NETSCAPE COMMUNICATIONS CORPORATION
+// Copyright © 1996, 1997 Netscape Communications Corporation.  All Rights
+// Reserved.  Use of this Source Code is subject to the terms of the
+// applicable license agreement from Netscape Communications Corporation.
+// The copyright notice(s) in this Source Code does not indicate actual or
+// intended publication of this Source Code.
+//
+// $Id: RegisterAllocatorTools.h,v 1.1.2.1 1999-03-02 16:12:05 fur%netscape.com Exp $
+//
+
+#ifndef _REGISTER_ALLOCATOR_TOOLS_H_
+#define _REGISTER_ALLOCATOR_TOOLS_H_
+
+#include "LogModule.h"
+#include "RegisterTypes.h"
+#include <string.h>
+
+class RegisterAllocator;
+class ControlGraph;
+class InstructionEmitter;
+class VirtualRegisterManager;
+
+struct RegisterAllocatorTools
+{
+	//
+	//
+	static void insertPhiNodeInstructions(ControlGraph& controlGraph, InstructionEmitter& emitter);
+
+	//
+	//
+	static void updateInstructionGraph(RegisterAllocator& registerAllocator);
+
+	//
+	//
+	static void removeUnnecessaryCopies(RegisterAllocator& registerAllocator);
+
+#ifdef DEBUG
+	//
+	//
+	static void testTheInstructionGraph(ControlGraph& controlGraph, VirtualRegisterManager& vrManager);
+#endif // DEBUG
+
+#ifdef DEBUG_LOG
+	//
+	//
+	static void printInstructions(RegisterAllocator& registerAllocator);
+
+	//
+	//
+	static void printSpillCosts(RegisterAllocator& registerAllocator);
+
+	//
+	//
+	static void printSplitCosts(RegisterAllocator& registerAllocator);
+#endif // DEBUG_LOG
+};
+
+//
+// FIX: this should go in a class (LookupTable ?)
+//
+
+inline RegisterName findRoot(RegisterName name, RegisterName* table)
+{
+	RegisterName* stack = table;
+	RegisterName* stackPtr = stack;
+
+	RegisterName newName;
+	while((newName = table[name]) != name) {
+		*--stackPtr = name;
+		name = newName;
+	}
+
+	while (stackPtr != stack)
+		table[*stackPtr++] = name;
+
+	return name;
+}
+
+inline void init(RegisterName* table, Uint32 nameCount)
+{
+	for (RegisterName r = RegisterName(0); r < nameCount; r = RegisterName(r + 1))
+		table[r] = r;
+}
+
+inline Uint32 compress(RegisterName* name2range, RegisterName* table, Uint32 nameCount, Uint32 tableSize)
+{
+	RegisterName* liveRange = new RegisterName[tableSize];
+	memset(liveRange, '\0', tableSize * sizeof(RegisterName));
+
+	// Update the lookup table.
+	for (RegisterName r = RegisterName(1); r < tableSize; r = RegisterName(r + 1))
+		findRoot(r, table);
+
+	// Count the liveranges.
+	Uint32 liveRangeCount = 1;
+	for (RegisterName s = RegisterName(1); s < tableSize; s = RegisterName(s + 1))
+		if (table[s] == s)
+			liveRange[s] = RegisterName(liveRangeCount++);
+
+	for (RegisterName t = RegisterName(1); t < nameCount; t = RegisterName(t + 1))
+		name2range[t] = liveRange[table[name2range[t]]];
+
+	return liveRangeCount;
+}
+
+inline double doLog10(Uint32 power)
+{
+	double log = 1.0;
+	while (power--)
+		log *= 10.0;
+	return log;
+}
+
+#endif // _REGISTER_ALLOCATOR_TOOLS_H_

mozilla/ef/Compiler/RegisterAllocator/RegisterAssigner.h

@@ -0,0 +1,38 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _REGISTER_ASSIGNER_H_
+#define _REGISTER_ASSIGNER_H_
+
+#include "Fundamentals.h"
+#include "VirtualRegister.h"
+
+class FastBitMatrix;
+
+class RegisterAssigner
+{
+protected:
+  VirtualRegisterManager& vRegManager;
+  
+public:
+  RegisterAssigner(VirtualRegisterManager& vrMan) : vRegManager(vrMan) {}
+  
+  virtual bool assignRegisters(FastBitMatrix& interferenceMatrix) = 0;
+};
+
+#endif /* _REGISTER_ASSIGNER_H_ */

mozilla/ef/Compiler/RegisterAllocator/RegisterClass.h

@@ -0,0 +1,25 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _REGISTER_CLASS_H_
+#define _REGISTER_CLASS_H_
+
+#include "Fundamentals.h"
+#include "RegisterTypes.h"
+
+#endif // _REGISTER_CLASS_H_

mozilla/ef/Compiler/RegisterAllocator/RegisterPressure.h

@@ -0,0 +1,37 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _REGISTER_PRESSURE_H_
+#define _REGISTER_PRESSURE_H_
+
+#include "BitSet.h"
+#include "HashSet.h"
+
+struct LowRegisterPressure
+{
+	typedef BitSet Set;
+	static const bool setIsOrdered = true;
+};
+
+struct HighRegisterPressure
+{
+	typedef HashSet Set;
+	static const bool setIsOrdered = false;
+};
+
+#endif // _REGISTER_PRESSURE_H_

mozilla/ef/Compiler/RegisterAllocator/RegisterTypes.h

@@ -0,0 +1,104 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _REGISTER_TYPES_H_
+#define _REGISTER_TYPES_H_
+
+#include "Fundamentals.h"
+
+//------------------------------------------------------------------------------
+// RegisterName -
+//
+
+enum RegisterName {
+	rnInvalid = 0,
+};
+
+//------------------------------------------------------------------------------
+// RegisterClassKind -
+//
+
+enum RegisterClassKind {
+	rckInvalid = 0,
+	rckGeneral,
+	rckStackSlot,
+
+	nRegisterClassKind
+};
+
+//------------------------------------------------------------------------------
+// RegisterID -
+//
+
+enum RegisterID {
+	invalidID = 0
+};
+
+//------------------------------------------------------------------------------
+// RegisterKind -
+//
+
+enum RegisterKind {
+	rkCallerSave = 0,
+	rkCalleeSave,
+};
+
+struct NameLinkedList {
+	RegisterName name;
+	NameLinkedList* next;
+};
+
+#ifdef DEBUG
+
+const registerNameMask = 		0x03ffffff;
+const coloredRegisterMask = 	0x04000000;
+const machineRegisterMask = 	0x08000000;
+const registerClassMask = 		0xf0000000;
+
+const registerNameShift = 		0;
+const coloredRegisterShift = 	26;
+const machineRegisterShift = 	27;
+const registerClassShift = 		28;
+
+#else // DEBUG
+
+const registerNameMask = 		0x0fffffff;
+const registerClassMask = 		0xf0000000;
+
+const registerNameShift = 		0;
+const registerClassShift = 		28;
+
+#endif // DEBUG
+
+
+inline RegisterClassKind getClass(RegisterID registerID) {return RegisterClassKind((registerID & registerClassMask) >> registerClassShift);}
+inline RegisterName getName(RegisterID registerID) {return RegisterName((registerID & registerNameMask) >> registerNameShift);}
+inline void setClass(RegisterID& registerID, RegisterClassKind classKind) {registerID = RegisterID((registerID & ~registerClassMask) | ((classKind << registerClassShift) & registerClassMask));}
+inline void setName(RegisterID& registerID, RegisterName name) {assert((name & ~registerNameMask) == 0); registerID = RegisterID((registerID & ~registerNameMask) | ((name << registerNameShift) & registerNameMask));}
+inline RegisterID buildRegisterID(RegisterName name, RegisterClassKind classKind) {return RegisterID(((classKind << registerClassShift) & registerClassMask) | ((name << registerNameShift) & registerNameMask));}
+
+#ifdef DEBUG
+
+inline bool isMachineRegister(RegisterID rid) {return (rid & machineRegisterMask) != 0;}
+inline void setMachineRegister(RegisterID& rid) {rid = RegisterID(rid | machineRegisterMask);}
+inline bool isColoredRegister(RegisterID rid) {return (rid & coloredRegisterMask) != 0;}
+inline void setColoredRegister(RegisterID& rid) {rid = RegisterID(rid | coloredRegisterMask);}
+
+#endif // DEBUG
+
+#endif // _REGISTER_TYPES_H_

mozilla/ef/Compiler/RegisterAllocator/SSATools.cpp

@@ -0,0 +1,32 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "SSATools.h"
+#include "ControlGraph.h"
+#include "VirtualRegister.h"
+#include "Liveness.h"
+
+void replacePhiNodes(ControlGraph& controlGraph, VirtualRegisterManager& vrManager)
+{
+	if (!controlGraph.hasBackEdges)
+		return;
+
+	Liveness liveness(controlGraph.pool);
+	liveness.buildLivenessAnalysis(controlGraph, vrManager);
+}

mozilla/ef/Compiler/RegisterAllocator/SSATools.h

@@ -0,0 +1,29 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _SSA_TOOLS_H_
+#define _SSA_TOOLS_H_
+
+#include "Fundamentals.h"
+
+class ControlGraph;
+class VirtualRegisterManager;
+
+extern void replacePhiNodes(ControlGraph& controlGraph, VirtualRegisterManager& vrManager);
+
+#endif // _SSA_TOOLS_H_

mozilla/ef/Compiler/RegisterAllocator/SparseSet.cpp

@@ -0,0 +1,37 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "SparseSet.h"
+#include "BitSet.h"
+#include "Pool.h"
+
+#ifdef DEBUG_LOG
+// Print the set.
+//
+void SparseSet::printPretty(LogModuleObject log)
+{
+	Pool pool;
+	BitSet set(pool, universeSize);
+
+	for (Uint32 i = 0; i < count; i++)
+	   set.set(node[i].element);
+
+	set.printPretty(log);
+}
+#endif // DEBUG_LOG

mozilla/ef/Compiler/RegisterAllocator/SparseSet.h

@@ -0,0 +1,168 @@
+//	-*- mode:C++; tab-width:4; truncate-lines:t -*-
+//
+//           CONFIDENTIAL AND PROPRIETARY SOURCE CODE OF
+//              NETSCAPE COMMUNICATIONS CORPORATION
+// Copyright © 1996, 1997 Netscape Communications Corporation.  All Rights
+// Reserved.  Use of this Source Code is subject to the terms of the
+// applicable license agreement from Netscape Communications Corporation.
+// The copyright notice(s) in this Source Code does not indicate actual or
+// intended publication of this Source Code.
+//
+// $Id: SparseSet.h,v 1.1.2.1 1999-03-02 16:12:07 fur%netscape.com Exp $
+//
+
+#ifndef _SPARSE_SET_H_
+#define _SPARSE_SET_H_
+
+#include "Fundamentals.h"
+#include "Pool.h"
+#include "LogModule.h"
+#include "BitSet.h"
+
+class SparseSet
+{
+private:
+
+	struct Node {
+		Uint32		element;
+		Uint32		stackIndex;
+	};
+
+	Node*			node;
+	Uint32			count;
+	Uint32			universeSize;
+
+private:
+
+	// No copy constructor.
+	SparseSet(const SparseSet&);
+
+	// Check if the given set's universe is of the same size than this universe.
+	void checkUniverseCompatibility(const SparseSet& set) const {assert(set.universeSize == universeSize);}
+	// Check if pos is valid for this set's universe.
+	void checkMember(Int32 pos) const {assert(pos >=0 && Uint32(pos) < universeSize);}
+
+public:
+
+	SparseSet(Pool& pool, Uint32 universeSize) : universeSize(universeSize) {node = new(pool) Node[universeSize]; clear();}
+
+	// Clear the sparse set.
+	void clear() {count = 0;}
+	// Clear the element at index.
+	inline void clear(Uint32 index);
+	// Set the element at index.
+	inline void set(Uint32 index);
+	// Return true if the element at index is set.
+	inline bool test(Uint32 index) const;
+	// Union with the given sparse set.
+	inline void or(const SparseSet& set);
+	// Intersection with the given sparse set.
+	inline void and(const SparseSet& set);
+	// Difference with the given sparse set.
+	inline void difference(const SparseSet& set);
+	// Copy set.
+	inline SparseSet& operator = (const SparseSet& set);
+	inline SparseSet& operator = (const BitSet& set);
+	// Return true if the sparse sets are identical.
+	friend bool operator == (const SparseSet& set1, const SparseSet& set2);
+	// Return true if the sparse sets are different.
+	friend bool operator != (const SparseSet& set1, const SparseSet& set2);
+
+	// Logical operators.
+	SparseSet& operator |= (const SparseSet& set) {or(set); return *this;}
+	SparseSet& operator &= (const SparseSet& set) {and(set); return *this;}
+	SparseSet& operator -= (const SparseSet& set) {difference(set); return *this;}
+
+	// Iterator to conform with the set API.
+	typedef Int32 iterator;
+	// Return the iterator for the first element of this set.
+	iterator begin() const {return count - 1;}
+	// Return the next iterator.
+	iterator advance(iterator pos) const {return --pos;}
+	// Return true if the iterator is at the end of the set.
+	bool done(iterator pos) const {return pos < 0;}
+	// Return the element for the given iterator;
+	Uint32 get(iterator pos) const {return node[pos].element;}
+	// Return one element of this set.
+	Uint32 getOne() const {assert(count > 0); return node[0].element;}
+	// Return the size of this set.
+	Uint32 getSize() const {return count;}
+
+#ifdef DEBUG_LOG
+	// Print the set.
+	void printPretty(LogModuleObject log);
+#endif // DEBUG_LOG
+};
+
+inline void SparseSet::clear(Uint32 element)
+{
+	checkMember(element);
+	Uint32 count = this->count;
+	Node* node = this->node;
+
+	Uint32 stackIndex = node[element].stackIndex;
+
+	if ((stackIndex < count) && (node[stackIndex].element == element)) {
+		Uint32 stackTop = node[count - 1].element;
+
+		node[stackIndex].element = stackTop;
+		node[stackTop].stackIndex = stackIndex;
+		this->count = count - 1;
+	}
+}
+
+inline void SparseSet::set(Uint32 element)
+{
+	checkMember(element);
+  	Uint32 count = this->count;
+	Node* node = this->node;
+
+	Uint32 stackIndex = node[element].stackIndex;
+
+	if ((stackIndex >= count) || (node[stackIndex].element != element)) {
+		node[count].element = element;
+		node[element].stackIndex = count;
+		this->count = count + 1;
+	}
+}
+
+inline bool SparseSet::test(Uint32 element) const
+{
+	checkMember(element);
+	Node* node = this->node;
+
+	Uint32 stackIndex = node[element].stackIndex;
+	return ((stackIndex < count) && (node[stackIndex].element == element));
+}
+
+inline SparseSet& SparseSet::operator = (const SparseSet& set)
+{
+	checkUniverseCompatibility(set);
+	Uint32 sourceCount = set.getSize();
+	Node* node = this->node;
+
+	memcpy(node, set.node, sourceCount * sizeof(Node));
+
+	for (Uint32 i = 0; i < sourceCount; i++) {
+		Uint32 element = node[i].element;
+		node[element].stackIndex = i;
+	}
+
+	count = sourceCount;
+
+	return *this;
+}
+
+
+inline SparseSet& SparseSet::operator = (const BitSet& set)
+{
+	// FIX: there's room for optimization here.
+	assert(universeSize == set.getSize());
+
+	clear();
+	for (Int32 i = set.firstOne(); i != -1; i = set.nextOne(i))
+		this->set(i);
+	return *this;
+}
+
+#endif // _SPARSE_SET_H_

mozilla/ef/Compiler/RegisterAllocator/Spilling.cpp

@@ -0,0 +1,270 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef NEW_LAURENTM_CODE
+#define INCLUDE_EMITTER
+#include "CpuInfo.h"
+#include "Fundamentals.h"
+#include "ControlNodes.h"
+#include "Instruction.h"
+#include "InstructionEmitter.h"
+#include "Spilling.h"
+
+
+void Spilling::
+insertSpillCode(ControlNode** dfsList, Uint32 nNodes)
+{
+  PRUint32 nVirtualRegisters = vRegManager.count();
+  FastBitSet currentLive(vRegManager.pool, nVirtualRegisters);
+  FastBitSet usedInThisInstruction(vRegManager.pool, nVirtualRegisters);
+  RegisterFifo grNeedLoad(nVirtualRegisters);
+  RegisterFifo fpNeedLoad(nVirtualRegisters);
+
+  for (PRInt32 n = nNodes - 1; n >= 0; n--)
+	{
+	  PR_ASSERT(grNeedLoad.empty() & fpNeedLoad.empty());
+	  ControlNode& node = *dfsList[n];
+
+	  currentLive = node.liveAtEnd;
+
+	  PRUint32 nGeneralAlive = 0;
+	  PRUint32 nFloatingPointAlive = 0;
+
+	  // Get the number of registers alive at the end of this node.
+	  for (PRInt32 j = currentLive.firstOne(); j != -1; j = currentLive.nextOne(j))
+		{
+		  VirtualRegister& vReg = vRegManager.getVirtualRegister(j);
+		  if (vReg.spillInfo.willSpill)
+			{
+			  currentLive.clear(j);
+			}
+		  else
+			{
+			  switch (vReg.getClass())
+				{
+				case vrcInteger:
+				  nGeneralAlive++;
+				  break;
+				case vrcFloatingPoint:
+				case vrcFixedPoint:
+				  nFloatingPointAlive++;
+				  break;
+				default:
+				  break;
+				}
+			}
+		}
+	  
+//		  if(node.dfsNum == 8) printf("\n________Begin Node %d________\n", node.dfsNum);
+
+		InstructionList& instructions = node.getInstructions();
+	  for (InstructionList::iterator i = instructions.end(); !instructions.done(i); i = instructions.retreat(i))
+		{
+		  Instruction&       instruction = instructions.get(i);
+		  InstructionUse*    useBegin    = instruction.getInstructionUseBegin();
+		  InstructionUse*    useEnd      = instruction.getInstructionUseEnd();
+		  InstructionUse*    usePtr;
+		  InstructionDefine* defBegin    = instruction.getInstructionDefineBegin();
+		  InstructionDefine* defEnd      = instruction.getInstructionDefineEnd();
+		  InstructionDefine* defPtr;
+
+//		if(node.dfsNum == 8)  { printf("\n");
+//		instruction.printPretty(stdout);
+//		printf("\n"); }
+
+		  // Handle definitions
+		  for (defPtr = defBegin; defPtr < defEnd; defPtr++)
+			if (defPtr->isVirtualRegister())
+			  {
+				VirtualRegister& vReg = defPtr->getVirtualRegister();
+				currentLive.clear(vReg.getRegisterIndex());
+				switch (vReg.getClass())
+				  {
+				  case vrcInteger:
+					nGeneralAlive--;
+					break;
+				  case vrcFloatingPoint:
+				  case vrcFixedPoint:
+					nFloatingPointAlive--;
+					break;
+				  default:
+					break;
+				  }
+			  }
+
+		  // Check for deaths
+		  for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+			if (usePtr->isVirtualRegister())
+			  {
+				VirtualRegister& vReg = usePtr->getVirtualRegister();
+				if (!currentLive.test(vReg.getRegisterIndex()))
+				  // This is the last use of this register.
+				  {
+					currentLive.set(vReg.getRegisterIndex());
+					switch (vReg.getClass())
+					  {
+					  case vrcInteger:
+						nGeneralAlive++;
+						while (/*(nGeneralAlive > NUMBER_OF_GREGISTERS) &&*/ !grNeedLoad.empty())
+						  {
+							PRUint32 toLoad = grNeedLoad.get();
+							currentLive.clear(toLoad);
+							nGeneralAlive--;
+							
+							VirtualRegister& nReg = vRegManager.getVirtualRegister(toLoad);
+							Instruction& lastUsingInstruction = *nReg.spillInfo.lastUsingInstruction;
+							emitter.emitLoadAfter(*lastUsingInstruction.getPrimitive(), lastUsingInstruction.getLinks().prev,
+												  nReg.getAlias(), *nReg.equivalentRegister[vrcStackSlot]);
+							nReg.releaseSelf();
+						  }
+						break;
+					  case vrcFloatingPoint:
+					  case vrcFixedPoint:
+						nFloatingPointAlive++;
+						while (/*(nFloatingPointAlive > NUMBER_OF_FPREGISTERS) &&*/ !fpNeedLoad.empty())
+						  {
+							PRUint32 toLoad = fpNeedLoad.get();
+							currentLive.clear(toLoad);
+							nFloatingPointAlive--;
+							
+							VirtualRegister& nReg = vRegManager.getVirtualRegister(toLoad);
+							Instruction& lastUsingInstruction = *nReg.spillInfo.lastUsingInstruction;
+							emitter.emitLoadAfter(*lastUsingInstruction.getPrimitive(), lastUsingInstruction.getLinks().prev,
+												  nReg.getAlias(), *nReg.equivalentRegister[vrcStackSlot]);
+							nReg.releaseSelf();
+						  }
+						break;
+					  default:
+						break;
+					  }
+				  }
+			  }
+
+		  // Handle uses
+		  for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+			if (usePtr->isVirtualRegister())
+			  {
+				VirtualRegister& vReg = usePtr->getVirtualRegister();
+				PRUint32 registerIndex = vReg.getRegisterIndex();
+
+				if (vReg.spillInfo.willSpill) {
+#if defined(GENERATE_FOR_X86)
+				  if (!instruction.switchUseToSpill((usePtr - useBegin), *vReg.equivalentRegister[vrcStackSlot]))
+#endif
+					{
+					  switch (vReg.getClass())
+						{
+						case vrcInteger:
+						  if (!grNeedLoad.test(registerIndex))
+							{
+							  grNeedLoad.put(registerIndex);
+							  VirtualRegister& alias = vRegManager.newVirtualRegister(vrcInteger);
+							  if (vReg.isPreColored())
+								  alias.preColorRegister(vReg.getPreColor());
+							  /* if (vReg.hasSpecialInterference) {
+								  alias.specialInterference.sizeTo(NUMBER_OF_REGISTERS);
+								  alias.specialInterference = vReg.specialInterference;
+								  alias.hasSpecialInterference = true;
+							  } */
+							  vReg.setAlias(alias);
+							  vReg.retainSelf();
+							}
+						  break;
+						case vrcFloatingPoint:
+						case vrcFixedPoint:
+						  if (!fpNeedLoad.test(registerIndex))
+							{
+							  fpNeedLoad.put(registerIndex);
+							  VirtualRegister& alias = vRegManager.newVirtualRegister(vReg.getClass());
+							  if (vReg.isPreColored())
+								  alias.preColorRegister(vReg.getPreColor());
+							  /*if (vReg.hasSpecialInterference) {
+								  alias.specialInterference.sizeTo(NUMBER_OF_REGISTERS);
+								  alias.specialInterference = vReg.specialInterference;
+								  alias.hasSpecialInterference = true;
+							  } */
+							  vReg.setAlias(alias);
+							  vReg.retainSelf();
+							}
+						  break;
+						default:
+						  break;
+						}
+					  usePtr->getVirtualRegisterPtr().initialize(vReg.getAlias());
+					  usedInThisInstruction.set(registerIndex);
+					  vReg.spillInfo.lastUsingInstruction = &instruction;
+					}
+				  currentLive.clear(registerIndex);
+				} else { // will not spill
+				  currentLive.set(registerIndex);
+				}
+			  }
+		  
+		  // Handle definitions
+		  for (defPtr = defBegin; defPtr < defEnd; defPtr++)
+			if (defPtr->isVirtualRegister())
+			  {
+				VirtualRegister& vReg = defPtr->getVirtualRegister();
+				
+				if (vReg.spillInfo.willSpill)
+#if defined(GENERATE_FOR_X86)
+				  if (!instruction.switchDefineToSpill((defPtr - defBegin), *vReg.equivalentRegister[vrcStackSlot]))
+#endif
+					{
+					  if (usedInThisInstruction.test(vReg.getRegisterIndex()))
+						// this virtualRegister was used in this instruction and is also defined. We need to move 
+						// this virtual register to its alias first and then save it to memory.
+						{
+						  emitter.emitStoreAfter(*instruction.getPrimitive(), &instruction.getLinks(), 
+												 vReg.getAlias(), *vReg.equivalentRegister[vrcStackSlot]);
+						  defPtr->getVirtualRegisterPtr().initialize(vReg.getAlias());
+						}
+					  else
+						{
+						  emitter.emitStoreAfter(*instruction.getPrimitive(), &instruction.getLinks(), 
+												 vReg, *vReg.equivalentRegister[vrcStackSlot]);
+						}
+					}
+			  }
+		}
+	  while (!grNeedLoad.empty())
+		{
+		  PRUint32 nl = grNeedLoad.get();
+		  VirtualRegister& nlReg = vRegManager.getVirtualRegister(nl);
+		  Instruction& lastUse = *nlReg.spillInfo.lastUsingInstruction;
+		  
+		  emitter.emitLoadAfter(*lastUse.getPrimitive(), lastUse.getLinks().prev, 
+								nlReg.getAlias(), *nlReg.equivalentRegister[vrcStackSlot]);
+		  nlReg.releaseSelf();
+		}
+	  while (!fpNeedLoad.empty())
+		{
+		  PRUint32 nl = fpNeedLoad.get();
+		  VirtualRegister& nlReg = vRegManager.getVirtualRegister(nl);
+		  Instruction& lastUse = *nlReg.spillInfo.lastUsingInstruction;
+
+		  emitter.emitLoadAfter(*lastUse.getPrimitive(), lastUse.getLinks().prev, 
+								nlReg.getAlias(), *nlReg.equivalentRegister[vrcStackSlot]);
+		  nlReg.releaseSelf();
+		}
+
+//	  if(node.dfsNum == 8) printf("\n________End Node %d________\n", node.dfsNum);
+
+	}
+}
+#endif

mozilla/ef/Compiler/RegisterAllocator/Spilling.h

@@ -0,0 +1,269 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _SPILLING_H_
+#define _SPILLING_H_
+
+#include "Fundamentals.h"
+#include <string.h>
+#include "RegisterAllocator.h"
+#include "RegisterAllocatorTools.h"
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+#include "Instruction.h"
+#include "SparseSet.h"
+
+template <class RegisterPressure>
+class Spilling
+{
+private:
+	static void insertStoreAfter(Instruction& instruction, RegisterName name);
+	static void insertLoadBefore(Instruction& instruction, RegisterName name);
+
+public:
+	static void calculateSpillCosts(RegisterAllocator& registerAllocator);
+	static void insertSpillCode(RegisterAllocator& registerAllocator);
+};
+
+struct SpillCost
+{
+	double loads;
+	double stores;
+	double copies;
+	double cost;
+	bool infinite;
+};
+
+template <class RegisterPressure>
+void Spilling<RegisterPressure>::insertSpillCode(RegisterAllocator& registerAllocator)
+{
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	RegisterName* name2range = registerAllocator.name2range;
+
+	Pool& pool = registerAllocator.pool;
+	SparseSet currentLive(pool, rangeCount);
+	SparseSet needLoad(pool, rangeCount);
+	SparseSet mustSpill(pool, rangeCount);
+	SparseSet& willSpill = *registerAllocator.willSpill;
+	
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	RegisterPressure::Set* liveOut = registerAllocator.liveness.liveOut;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+
+		needLoad.clear();
+		currentLive = liveOut[n];
+		mustSpill = currentLive;
+
+		InstructionList& instructions = nodes[n]->getInstructions();
+		for (InstructionList::iterator i = instructions.end(); !instructions.done(i);) {
+			Instruction& instruction = instructions.get(i);
+			i = instructions.retreat(i);
+
+			InstructionUse* useBegin = instruction.getInstructionUseBegin();
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			InstructionUse* usePtr;
+			InstructionDefine* defineBegin = instruction.getInstructionDefineBegin();
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			InstructionDefine* definePtr;
+
+			bool foundLiveDefine = false;
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++) 
+				if (definePtr->isRegister()) {
+					if (currentLive.test(name2range[definePtr->getRegisterName()])) {
+						foundLiveDefine = true;
+						break;
+					}
+				} else {
+					foundLiveDefine = true;
+					break;
+				}
+			if (defineBegin != defineEnd && !foundLiveDefine) {
+				fprintf(stderr, "!!! Removed instruction because it was only defining unused registers !!!\n");
+				instruction.remove();
+			}
+
+ 			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++) 
+				if (definePtr->isRegister()) {
+					RegisterName range = name2range[definePtr->getRegisterName()];
+#ifdef DEBUG
+					if (needLoad.test(range))
+						if (!mustSpill.test(range) && registerAllocator.spillCost[range].infinite && willSpill.test(range)) {
+							fprintf(stderr, "Tried to spill a register with infinite spill cost\n");
+							abort();
+						}
+#endif // DEBUG
+					if (willSpill.test(range))
+						insertStoreAfter(instruction, range);
+
+					needLoad.clear(range);
+				}
+
+			if (instruction.getFlags() & ifCopy)
+				for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+					if (usePtr->isRegister()) {
+						RegisterName range = name2range[usePtr->getRegisterName()];
+						if (!currentLive.test(range))
+							for (SparseSet::iterator r = needLoad.begin(); !needLoad.done(r); r = needLoad.advance(r)) {
+								RegisterName load = RegisterName(needLoad.get(r));
+								if (willSpill.test(load))
+									insertLoadBefore(instruction, load);
+								mustSpill.set(load);
+							}
+						needLoad.clear();
+					}
+
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++) 
+				if (definePtr->isRegister())
+					currentLive.clear(name2range[definePtr->getRegisterName()]);
+
+
+			for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister()) {
+					RegisterName range = name2range[usePtr->getRegisterName()];
+					currentLive.set(range);
+					needLoad.set(range);
+				}
+		}
+
+		for (SparseSet::iterator l = needLoad.begin(); !needLoad.done(l); l = needLoad.advance(l)) {
+			RegisterName load = RegisterName(needLoad.get(l));
+			if (willSpill.test(load))
+				insertLoadBefore(instructions.first(), load);
+		}		
+	}
+}
+
+template <class RegisterPressure>
+void Spilling<RegisterPressure>::insertLoadBefore(Instruction& /*instruction*/, RegisterName name)
+{
+	fprintf(stdout, "will insert load for range %d\n", name);
+}
+
+template <class RegisterPressure>
+void Spilling<RegisterPressure>::insertStoreAfter(Instruction& /*instruction*/, RegisterName name)
+{
+	fprintf(stdout, "will insert store for range %d\n", name);
+}
+
+template <class RegisterPressure>
+void Spilling<RegisterPressure>::calculateSpillCosts(RegisterAllocator& registerAllocator)
+{
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	RegisterName* name2range = registerAllocator.name2range;
+
+	Pool& pool = registerAllocator.pool;
+	SparseSet live(pool, rangeCount);
+	SparseSet needLoad(pool, rangeCount);
+	SparseSet mustSpill(pool, rangeCount);
+
+	SparseSet alreadyStored(pool, rangeCount); // FIX: should get this from previous spilling.
+
+	SpillCost* cost = new SpillCost[rangeCount];
+	memset(cost, '\0', rangeCount * sizeof(SpillCost));
+
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	RegisterPressure::Set* liveOut = registerAllocator.liveness.liveOut;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		ControlNode& node = *nodes[n];
+
+		double weight = doLog10(node.loopDepth);
+
+		needLoad.clear();
+		live = liveOut[n];
+		mustSpill = live;
+
+		InstructionList& instructions = nodes[n]->getInstructions();
+		for (InstructionList::iterator i = instructions.end(); !instructions.done(i); i = instructions.retreat(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			InstructionUse* useBegin = instruction.getInstructionUseBegin();
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			InstructionUse* usePtr;
+			InstructionDefine* defineBegin = instruction.getInstructionDefineBegin();
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			InstructionDefine* definePtr;
+
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++) 
+				if (definePtr->isRegister()) {
+					RegisterName range = name2range[definePtr->getRegisterName()];
+
+					if (needLoad.test(range))
+						if (!mustSpill.test(range))
+							cost[range].infinite = true;
+
+					if ((false /* !rematerializable(range) */ || !needLoad.test(range)) && !alreadyStored.test(range))
+						cost[range].stores += weight;
+
+					needLoad.clear(range);
+				}
+
+			if (instruction.getFlags() & ifCopy)
+				for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+					if (usePtr->isRegister())
+						if (!live.test(name2range[usePtr->getRegisterName()])) {
+							for (SparseSet::iterator l = needLoad.begin(); !needLoad.done(l); l = needLoad.advance(l)) {
+								Uint32 range = needLoad.get(l);
+								cost[range].loads += weight;
+								mustSpill.set(range);
+							}
+							needLoad.clear();
+						}
+
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++) 
+				if (definePtr->isRegister())
+					live.clear(name2range[definePtr->getRegisterName()]);
+
+			for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister()) {
+					RegisterName range = name2range[usePtr->getRegisterName()];
+
+					live.set(range);
+					needLoad.set(range);
+				}
+
+			if (instruction.getFlags() & ifCopy) {
+				assert(useBegin != useEnd && useBegin[0].isRegister());
+				assert(defineBegin != defineEnd && defineBegin[0].isRegister());
+
+				RegisterName source = name2range[useBegin[0].getRegisterName()];
+				RegisterName destination = name2range[defineBegin[0].getRegisterName()];
+
+				cost[source].copies += weight;
+				cost[destination].copies += weight;
+			}			
+		}
+
+		for (SparseSet::iterator s = needLoad.begin(); !needLoad.done(s); s = needLoad.advance(s))
+			cost[needLoad.get(s)].loads += weight;
+	}
+	
+	for (Uint32 r = 0; r < rangeCount; r++) {
+		SpillCost& c = cost[r];
+		c.cost = 2 * (c.loads + c.stores) - c.copies;
+	}
+
+	registerAllocator.spillCost = cost;
+}
+
+#endif // _SPILLING_H_

mozilla/ef/Compiler/RegisterAllocator/Splits.h

@@ -0,0 +1,239 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _SPLITS_H_
+#define _SPLITS_H_
+
+#include "Fundamentals.h"
+#include <string.h>
+#include "Pool.h"
+#include "ControlGraph.h"
+#include "ControlNodes.h"
+#include "Instruction.h"
+#include "RegisterAllocator.h"
+#include "RegisterAllocatorTools.h"
+
+UT_EXTERN_LOG_MODULE(RegAlloc);
+
+template <class RegisterPressure>
+struct Splits
+{
+	static void calculateSplitCosts(RegisterAllocator& registerAllocator);
+	static bool findSplit(RegisterAllocator& registerAllocator, RegisterName* color, RegisterName range);
+	static void insertSplitCode(RegisterAllocator& registerAllocator);
+};
+
+struct SplitCost
+{
+	double loads;
+	double stores;
+};
+
+template <class RegisterPressure>
+void Splits<RegisterPressure>::insertSplitCode(RegisterAllocator& /*registerAllocator*/)
+{
+	// FIX
+}
+
+template <class RegisterPressure>
+bool Splits<RegisterPressure>::findSplit(RegisterAllocator& registerAllocator, RegisterName* color, RegisterName range)
+{
+	Pool& pool = registerAllocator.pool;
+	NameLinkedList** neighborsWithColor = new(pool) NameLinkedList*[6]; // FIX
+	memset(neighborsWithColor, '\0', 6 * sizeof(NameLinkedList*));
+
+	InterferenceGraph<RegisterPressure>& iGraph = registerAllocator.iGraph;
+
+	for (InterferenceVector* vector = iGraph.getInterferenceVector(range); vector != NULL; vector = vector->next)
+		for (Int32 i = vector->count - 1; i >=0; --i) {
+			RegisterName neighbor = vector->neighbors[i];
+			RegisterName c = color[neighbor];
+
+			if (c < 6) { // FIX
+				NameLinkedList* node = new(pool) NameLinkedList();
+				node->name = neighbor;
+				node->next = neighborsWithColor[c];
+				neighborsWithColor[c] = node;
+			}
+		}
+
+	bool splitAroundName = true;
+
+	LiveRangeGraph<RegisterPressure>& lGraph = registerAllocator.lGraph;
+	RegisterName bestColor = RegisterName(6); // FIX
+	double bestCost = registerAllocator.spillCost[range].cost;
+	SplitCost* splitCost = registerAllocator.splitCost;
+
+	for (RegisterName i = RegisterName(0); i < 6; i = RegisterName(i + 1)) { // FIX
+
+		double splitAroundNameCost = 0.0;
+		bool canSplitAroundName = true;
+
+		SplitCost& sCost = splitCost[range];
+		double addedCost = 2.0 * (sCost.stores + sCost.loads);
+
+		for (NameLinkedList* node = neighborsWithColor[i]; node != NULL; node = node->next) {
+			RegisterName neighbor = node->name;
+			if (lGraph.haveEdge(neighbor, range)) {
+				canSplitAroundName = false;
+				break;
+			} else
+				splitAroundNameCost += addedCost;
+		}
+		if (canSplitAroundName && splitAroundNameCost < bestCost) {
+			bestCost = splitAroundNameCost;
+			bestColor = i;
+			splitAroundName = true;
+		}
+
+		double splitAroundColorCost = 0.0;
+		bool canSplitAroundColor = true;
+
+		for (NameLinkedList* node = neighborsWithColor[i]; node != NULL; node = node->next) {
+			RegisterName neighbor = node->name;
+			if (lGraph.haveEdge(range, neighbor)) {
+				canSplitAroundColor = false;
+				break;
+			} else {
+				SplitCost& sCost = splitCost[neighbor];
+				double addedCost = 2.0 * (sCost.stores + sCost.loads);
+				splitAroundColorCost += addedCost;
+			}
+		}
+		if (canSplitAroundColor && splitAroundColorCost < bestCost) {
+			bestCost = splitAroundColorCost;
+			bestColor = i;
+			splitAroundName = false;
+		}
+ 	}
+	if (bestColor < RegisterName(6)) {
+		color[range] = bestColor;
+		registerAllocator.splitFound = true;
+
+		NameLinkedList** splitAround = registerAllocator.splitAround;
+
+		if (splitAroundName)
+			for (NameLinkedList* node = neighborsWithColor[bestColor]; node != NULL; node = node->next) {
+				NameLinkedList* newNode = new(pool) NameLinkedList();
+				newNode->name = node->name;
+				newNode->next = splitAround[range];
+				splitAround[range] = newNode;
+			}
+		else
+			for (NameLinkedList* node = neighborsWithColor[bestColor]; node != NULL; node = node->next) {
+				NameLinkedList* newNode = new(pool) NameLinkedList();
+				RegisterName neighbor = node->name;
+				newNode->name = range;
+				newNode->next = splitAround[neighbor];
+				splitAround[neighbor] = newNode;
+			}
+
+		trespass("Found a split");
+		return true;
+	}
+
+	return false;
+}
+
+template <class RegisterPressure>
+void Splits<RegisterPressure>::calculateSplitCosts(RegisterAllocator& registerAllocator)
+{
+	Pool& pool = registerAllocator.pool;
+	Uint32 rangeCount = registerAllocator.rangeCount;
+	RegisterName* name2range = registerAllocator.name2range;
+
+	SplitCost* splitCost = new(pool) SplitCost[rangeCount];
+	memset(splitCost, '\0', rangeCount * sizeof(SplitCost));
+
+	SparseSet live(pool, rangeCount);
+	RegisterPressure::Set* liveIn = registerAllocator.liveness.liveIn;
+	RegisterPressure::Set* liveOut = registerAllocator.liveness.liveOut;
+
+	ControlGraph& controlGraph = registerAllocator.controlGraph;
+	ControlNode** nodes = controlGraph.dfsList;
+	Uint32 nNodes = controlGraph.nNodes;
+
+	for (Uint32 n = 0; n < nNodes; n++) {
+		ControlNode& node = *nodes[n];
+		double weight = doLog10(node.loopDepth);
+
+		live = liveOut[n];
+
+		ControlEdge* successorsEnd = node.getSuccessorsEnd();
+		for (ControlEdge* successorsPtr = node.getSuccessorsBegin(); successorsPtr < successorsEnd; successorsPtr++) {
+			ControlNode& successor = successorsPtr->getTarget();
+
+			if (successor.getControlKind() != ckEnd) {
+				RegisterPressure::Set& successorLiveIn = liveIn[successor.dfsNum];
+
+				for (SparseSet::iterator i = live.begin(); !live.done(i); i = live.advance(i)) {
+					RegisterName name = RegisterName(live.get(i));
+					if (!successorLiveIn.test(name))
+						splitCost[name].loads += doLog10(successor.loopDepth);
+				}
+			}
+		}
+
+		InstructionList& instructions = node.getInstructions();
+		for (InstructionList::iterator i = instructions.end(); !instructions.done(i); i = instructions.retreat(i)) {
+			Instruction& instruction = instructions.get(i);
+
+			InstructionUse* useBegin = instruction.getInstructionUseBegin();
+			InstructionUse* useEnd = instruction.getInstructionUseEnd();
+			InstructionUse* usePtr;
+			InstructionDefine* defineBegin = instruction.getInstructionDefineBegin();
+			InstructionDefine* defineEnd = instruction.getInstructionDefineEnd();
+			InstructionDefine* definePtr;
+
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++) 
+				if (definePtr->isRegister())
+					splitCost[name2range[definePtr->getRegisterName()]].stores += weight;
+
+			for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister()) {
+					RegisterName range = name2range[usePtr->getRegisterName()];
+					if (!live.test(range)) {
+						if (&instruction != &instructions.last())
+							splitCost[range].loads += weight;
+						else {
+							ControlEdge* successorsEnd = node.getSuccessorsEnd();
+							for (ControlEdge* successorsPtr = node.getSuccessorsBegin(); successorsPtr < successorsEnd; successorsPtr++)
+								splitCost[range].loads += doLog10(successorsPtr->getTarget().loopDepth);
+						}
+					}
+				}
+
+			for (definePtr = defineBegin; definePtr < defineEnd; definePtr++) 
+				if (definePtr->isRegister())
+					live.clear(name2range[definePtr->getRegisterName()]);
+
+			for (usePtr = useBegin; usePtr < useEnd; usePtr++)
+				if (usePtr->isRegister())
+					live.set(name2range[usePtr->getRegisterName()]);
+		}
+	}
+
+	NameLinkedList** splitAround = new(pool) NameLinkedList*[rangeCount];
+	memset(splitAround, '\0', rangeCount * sizeof(NameLinkedList*));
+	registerAllocator.splitAround = splitAround;
+
+	registerAllocator.splitCost = splitCost;
+	registerAllocator.splitFound = false;
+}
+
+#endif // _SPLITS_H_

mozilla/ef/Compiler/RegisterAllocator/Timer.cpp

@@ -0,0 +1,186 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "HashTable.h"
+#include "Timer.h"
+#include "Pool.h"
+
+static Pool pool;											// Pool for the Timer class.
+static HashTable<TimerEntry*> timerEntries(pool);			// Timers hashtable.
+
+const nTimersInABlock = 128;								// Number of timers in a block.
+static PRTime *timers = new(pool) PRTime[nTimersInABlock];	// A block of timers.
+static Uint8 nextTimer = 0;									// nextAvailableTimer.
+
+//
+// Calibrate the call to PR_Now().
+//
+static PRTime calibrate()
+{
+	PRTime t = PR_Now();
+	PRTime& a = *new(pool) PRTime();
+
+	// Call 10 times the PR_Now() function.
+	a = PR_Now(); a = PR_Now(); a = PR_Now(); a = PR_Now(); a = PR_Now(); a = PR_Now(); 
+	a = PR_Now(); a = PR_Now(); a = PR_Now(); a = PR_Now(); a = PR_Now(); a = PR_Now(); 
+	t = (PR_Now() - t + 9) / 10;
+
+	return t;
+}
+
+static PRTime adjust = calibrate();
+
+//
+// Return the named timer..
+//
+TimerEntry& Timer::getTimerEntry(const char* name)
+{
+	if (!timerEntries.exists(name)) {
+		TimerEntry* newEntry = new(pool) TimerEntry();
+		newEntry->accumulator = 0;
+		newEntry->running = false;
+		timerEntries.add(name, newEntry);
+	}
+
+	return *timerEntries[name];
+}
+
+//
+// Return a reference to a new timer.
+//
+PRTime& Timer::getNewTimer()
+{
+	if (nextTimer >= nTimersInABlock) {
+		timers = new(pool) PRTime[nTimersInABlock];
+		nextTimer = 0;
+	}
+	return timers[nextTimer++];
+}
+
+static Uint32 timersAreFrozen = 0;
+
+//
+// Start the named timer.
+//
+void Timer::start(const char* name)
+{
+	if (timersAreFrozen)
+		return;
+
+	freezeTimers();
+
+	TimerEntry& timer = getTimerEntry(name);
+	PR_ASSERT(!timer.running);
+
+	timer.accumulator = 0;
+	timer.running = true;
+	timer.done = false;
+
+	unfreezeTimers();
+}
+
+//
+// Stop the named timer.
+//
+void Timer::stop(const char* name)
+{
+	if (timersAreFrozen)
+		return;
+
+	freezeTimers();
+
+	TimerEntry& timer = getTimerEntry(name);
+	PR_ASSERT(timer.running);
+	timer.running = false;
+	timer.done = true;
+
+	unfreezeTimers();
+}
+
+//
+// Freeze all the running timers.
+//
+void Timer::freezeTimers()
+{
+	PRTime when = PR_Now() - adjust;
+
+	if (timersAreFrozen == 0) {
+		Vector<TimerEntry*> entries = timerEntries;
+		Uint32 count = entries.size();
+
+		for (Uint32 i = 0; i < count; i++) {
+			TimerEntry& entry = *entries[i];
+			if (entry.running) {
+				entry.accumulator += (when - *entry.startTime);
+			}
+		}
+	}
+	timersAreFrozen++;
+}
+ 
+//
+// Unfreeze all the running timers.
+//
+void Timer::unfreezeTimers()
+{
+	PR_ASSERT(timersAreFrozen != 0);
+	timersAreFrozen--;
+
+	if (timersAreFrozen == 0) {
+		Vector<TimerEntry *> entries = timerEntries;
+		Uint32 count = entries.size();
+		
+		PRTime& newStart = getNewTimer();
+		
+		for (Uint32 i = 0; i < count; i++) {
+			TimerEntry& entry = *entries[i];
+			if (entry.running) {
+				entry.startTime = &newStart;
+			}
+		}
+		
+		newStart = PR_Now();
+	}
+}
+
+//
+// Print the named timer in the file f.
+//
+void Timer::print(FILE* f, const char *name)
+{
+	if (timersAreFrozen)
+		return;
+
+	freezeTimers();
+
+	TimerEntry& timer = getTimerEntry(name);
+  
+	PR_ASSERT(timer.done);
+	PRTime elapsed = timer.accumulator;
+
+	if (elapsed >> 32) {
+		fprintf(f, "[timer %s out of range]\n", name);
+	} else {
+		fprintf(f, "[%dus in %s]\n", Uint32(elapsed), name);
+	}
+	fflush(f);
+
+	unfreezeTimers();
+}
+

mozilla/ef/Compiler/RegisterAllocator/Timer.h

@@ -0,0 +1,80 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _TIMER_H_
+#define _TIMER_H_
+
+#include "Fundamentals.h"
+#include "HashTable.h"
+#include "prtime.h"
+
+//
+// Naming convention:
+//  As the class Timer contains only static methods, the timer's name should start with the 
+//  module name. Otherwise starting 2 timers with the same name will assert.
+//
+
+#ifndef NO_TIMER
+
+struct TimerEntry
+{
+	PRTime *startTime;					// Current time when we start the timer.
+	PRTime accumulator;					// Time spent in this timer.
+	bool running;						// True if the timer is running.
+	bool done;							// True if the timer was running and was stopped. 
+};
+
+class Timer
+{
+private:
+
+	// Return the named timer.
+	static TimerEntry& getTimerEntry(const char* name);
+	// Return a reference to a new Timer.
+	static PRTime& getNewTimer();
+
+public:
+
+	// Start the timer.
+	static void start(const char* name);
+	// Stop the timer.
+	static void stop(const char* name);
+	// Freeze all the running timers.
+	static void freezeTimers();
+	// Unfreeze all the running timers.
+	static void unfreezeTimers();
+	// Print the timer.
+	static void print(FILE* f, const char *name);
+};
+
+inline void startTimer(const char* name) 		{Timer::start(name);}
+inline void stopTimer(const char* name) 		{Timer::stop(name); Timer::print(stdout, name);}
+#define START_TIMER_SAFE						Timer::freezeTimers();
+#define END_TIMER_SAFE							Timer::unfreezeTimers();
+#define TIMER_SAFE(x)							START_TIMER_SAFE x; END_TIMER_SAFE
+
+#else /* NO_TIMER */
+
+inline void startTimer(const char* /*name*/) 	{} 
+inline void stopTimer(const char* /*name*/) 	{} 
+#define START_TIMER_SAFE
+#define END_TIMER_SAFE
+#define TIMER_SAFE(x)							x;
+
+#endif /* NO_TIMER */
+#endif /* _TIMER_H_ */

mozilla/ef/Compiler/RegisterAllocator/VirtualRegister.cpp

@@ -0,0 +1,40 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#include "Fundamentals.h"
+#include "VirtualRegister.h"
+#include "Instruction.h"
+
+//------------------------------------------------------------------------------
+// VirtualRegister -
+
+#ifdef MANUAL_TEMPLATES
+template class IndexedPool<VirtualRegister>;
+#endif
+
+// Set the defining instruction.
+//
+void VirtualRegister::setDefiningInstruction(Instruction& instruction)
+{
+	if (definingInstruction != NULL) {
+		if ((instruction.getFlags() & ifCopy) && (definingInstruction->getFlags() & ifPhiNode))
+			return;
+	}
+	definingInstruction = &instruction;
+}
+

mozilla/ef/Compiler/RegisterAllocator/VirtualRegister.h

@@ -0,0 +1,116 @@
+/* -*- 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.0 (the "NPL"); you may not use this file except in
+ * compliance with the NPL.  You may obtain a copy of the NPL at
+ * http://www.mozilla.org/NPL/
+ *
+ * Software distributed under the NPL is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
+ * for the specific language governing rights and limitations under the
+ * NPL.
+ *
+ * The Initial Developer of this code under the NPL is Netscape
+ * Communications Corporation.  Portions created by Netscape are
+ * Copyright (C) 1998 Netscape Communications Corporation.  All Rights
+ * Reserved.
+ */
+
+#ifndef _VIRTUAL_REGISTER_H_
+#define _VIRTUAL_REGISTER_H_
+
+#include "Fundamentals.h"
+#include "IndexedPool.h"
+#include <string.h>
+
+#include "RegisterTypes.h"
+#include "RegisterClass.h"
+
+
+//------------------------------------------------------------------------------
+// VirtualRegister - 24b
+
+class Instruction;
+
+class VirtualRegister : public IndexedObject<VirtualRegister>
+{
+public:
+
+	Instruction*					definingInstruction;	// Instruction defining this VR.
+
+	// Initialize a VR of the given classKind.
+	VirtualRegister(RegisterClassKind /*classKind*/) : definingInstruction(NULL) {}
+
+	// Return the defining instruction for this VR.
+	Instruction* getDefiningInstruction() const {return definingInstruction;}
+	// Set the defining instruction.
+	void setDefiningInstruction(Instruction& insn);
+};
+
+// Return true if the VirtualRegisters are equals. The only way 2 VRs can be equal is if
+// they have the same index. If they have the same index then they are at the same
+// address in the indexed pool.
+//
+inline bool operator == (const VirtualRegister& regA, const VirtualRegister& regB) {return &regA == &regB;}
+
+//------------------------------------------------------------------------------
+// VirtualRegisterManager -
+
+struct PreColoredRegister
+{
+	RegisterID id;
+	RegisterName color;
+};
+
+class VirtualRegisterManager
+{
+private:
+
+	IndexedPool<VirtualRegister> registerPool;
+	PreColoredRegister machineRegister[6];
+
+public:
+	VirtualRegisterManager()
+		{
+			for (Uint32 i = 0; i < 6; i++)
+				machineRegister[i].id = invalidID;
+		}
+
+	// Return the VirtualRegister at the given index.
+	VirtualRegister& getVirtualRegister(RegisterName name) const {return registerPool.get(name);}
+
+	// Return a new VirtualRegister.
+	RegisterID newVirtualRegister(RegisterClassKind classKind)
+		{
+			VirtualRegister& vReg = *new(registerPool) VirtualRegister(classKind);
+			RegisterID rid;
+
+			setName(rid, RegisterName(vReg.getIndex()));
+			setClass(rid, classKind);
+			return rid;
+		}
+
+	RegisterID newMachineRegister(RegisterName name, RegisterClassKind classKind)
+		{
+			RegisterID rid = machineRegister[name].id;
+
+			if (rid == invalidID) {
+				rid = newVirtualRegister(classKind);
+				DEBUG_ONLY(setMachineRegister(rid));
+				machineRegister[name].id = rid;
+				machineRegister[name].color = name;
+			}
+
+			return rid;
+		}
+
+	PreColoredRegister* getMachineRegistersBegin() const {return (PreColoredRegister*) machineRegister;} // FIX
+	PreColoredRegister* getMachineRegistersEnd() const {return (PreColoredRegister*) &machineRegister[6];} // FIX
+
+	// Return the VirtualRegister universe size.
+	Uint32 getSize() {return registerPool.getSize();}
+
+	void setSize(Uint32 size) {registerPool.setSize(size);}
+};
+
+#endif // _VIRTUAL_REGISTER_H_

mozilla/js2/AUTHORS

@@ -1 +0,0 @@
-

mozilla/js2/COPYING

@@ -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.
-
-

mozilla/js2/ChangeLog

@@ -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)

mozilla/js2/INSTALL

@@ -1 +0,0 @@
-

mozilla/js2/Makefile.am

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

mozilla/js2/NEWS

@@ -1 +0,0 @@
-

mozilla/js2/README

@@ -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.

mozilla/js2/TODO

@@ -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 ?

mozilla/js2/aclocal.m4

@@ -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([,]))])
-

mozilla/js2/common.mk

@@ -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

mozilla/js2/config.h.in

@@ -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
-

mozilla/js2/configure.in

@@ -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)

mozilla/js2/install-sh

@@ -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

mozilla/js2/missing

@@ -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

mozilla/js2/mkinstalldirs

@@ -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

mozilla/js2/semantics/GrammarSymbol.lisp

@@ -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))))))

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

@@ -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")
-|#

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

@@ -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)

mozilla/js2/semantics/HTML.lisp

@@ -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))))
-|#

mozilla/js2/semantics/JS14/Parser.lisp

@@ -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))
-|#

mozilla/js2/semantics/JS20/Kernel.lisp

@@ -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'\"'\"")
-|#
-

mozilla/js2/semantics/JS20/Lexer.lisp

@@ -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*))

mozilla/js2/semantics/JS20/RegExp.lisp

@@ -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*))

mozilla/js2/semantics/JS20/Units.lisp

@@ -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*))

mozilla/js2/semantics/JSECMA/Lexer.lisp

@@ -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))
-
-

mozilla/js2/semantics/JSECMA/Parser.lisp

@@ -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'")
-|#

mozilla/js2/semantics/Lexer.lisp

@@ -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)))
-

mozilla/js2/semantics/Main.lisp

@@ -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)

mozilla/js2/semantics/Markup.lisp

@@ -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)))))

mozilla/js2/semantics/Metaparser.lisp

@@ -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))

mozilla/js2/semantics/Parser.lisp

@@ -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)))
-

mozilla/js2/semantics/README

@@ -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.

mozilla/js2/semantics/Test/BaseExample.lisp

@@ -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*))

mozilla/js2/semantics/Test/CanonicalLRTest.lisp

@@ -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*))

mozilla/js2/semantics/Test/ConstraintTest.lisp

@@ -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*))

mozilla/js2/semantics/Test/LineTest.lisp

@@ -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*))

mozilla/js2/semantics/Test/NameResolution.lisp

@@ -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*))

mozilla/js2/semantics/Test/StandardFunction.lisp

@@ -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*))

mozilla/js2/semantics/Test/ThrowCatch.lisp

@@ -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*))

mozilla/js2/semantics/Utilities.lisp

@@ -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)))

mozilla/js2/semantics/styles.css

@@ -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}

mozilla/js2/semantics/unicodeCompatibility.js

@@ -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);

mozilla/js2/src/JSILGenerator.cpp

@@ -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.
- */

mozilla/js2/src/JSILGenerator.h

@@ -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.
- */

mozilla/js2/src/Makefile.am

@@ -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

mozilla/js2/src/algo.h

@@ -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___ */

mozilla/js2/src/bytecodegen.h

@@ -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___ */

mozilla/js2/src/collector.cpp

@@ -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
-
-}

mozilla/js2/src/collector.h

@@ -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___

mozilla/js2/src/cpucfg.h

@@ -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

mozilla/js2/src/debugger.cpp

@@ -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 */
-
-                    
-            
-        

mozilla/js2/src/debugger.h

@@ -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 */

mozilla/js2/src/ds.h

@@ -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___ */

mozilla/js2/src/exception.cpp

@@ -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;
-}

mozilla/js2/src/exception.h

@@ -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___ */

mozilla/js2/src/exception_msgs.cpp

@@ -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
-    };
-    
-}

mozilla/js2/src/fdlibm_ns.cpp

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