unit Antlr.Runtime.Tree;
(*
[The "BSD licence"]
Copyright (c) 2008 Erik van Bilsen
Copyright (c) 2005-2007 Kunle Odutola
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code MUST RETAIN the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form MUST REPRODUCE the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
3. The name of the author may not be used to endorse or promote products
derived from this software without specific prior WRITTEN permission.
4. Unless explicitly state otherwise, any contribution intentionally
submitted for inclusion in this work to the copyright owner or licensor
shall be under the terms and conditions of this license, without any
additional terms or conditions.
THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
interface
{$IF CompilerVersion < 20}
{$MESSAGE ERROR 'You need Delphi 2009 or higher to use the Antlr runtime'}
{$IFEND}
uses
Classes,
SysUtils,
Antlr.Runtime,
Antlr.Runtime.Tools,
Antlr.Runtime.Collections;
type
/// <summary>
/// How to create and navigate trees. Rather than have a separate factory
/// and adaptor, I've merged them. Makes sense to encapsulate.
///
/// This takes the place of the tree construction code generated in the
/// generated code in 2.x and the ASTFactory.
///
/// I do not need to know the type of a tree at all so they are all
/// generic Objects. This may increase the amount of typecasting needed. :(
/// </summary>
ITreeAdaptor = interface(IANTLRInterface)
['{F9DEB286-F555-4CC8-A51A-93F3F649B248}']
{ Methods }
// C o n s t r u c t i o n
/// <summary>
/// Create a tree node from Token object; for CommonTree type trees,
/// then the token just becomes the payload.
/// </summary>
/// <remarks>
/// This is the most common create call. Override if you want another kind of node to be built.
/// </remarks>
function CreateNode(const Payload: IToken): IANTLRInterface; overload;
/// <summary>Duplicate a single tree node </summary>
/// <remarks> Override if you want another kind of node to be built.</remarks>
function DupNode(const TreeNode: IANTLRInterface): IANTLRInterface;
/// <summary>Duplicate tree recursively, using DupNode() for each node </summary>
function DupTree(const Tree: IANTLRInterface): IANTLRInterface;
/// <summary>
/// Return a nil node (an empty but non-null node) that can hold
/// a list of element as the children. If you want a flat tree (a list)
/// use "t=adaptor.nil(); t.AddChild(x); t.AddChild(y);"
/// </summary>
function GetNilNode: IANTLRInterface;
/// <summary>
/// Return a tree node representing an error. This node records the
/// tokens consumed during error recovery. The start token indicates the
/// input symbol at which the error was detected. The stop token indicates
/// the last symbol consumed during recovery.
/// </summary>
/// <remarks>
/// <para>You must specify the input stream so that the erroneous text can
/// be packaged up in the error node. The exception could be useful
/// to some applications; default implementation stores ptr to it in
/// the CommonErrorNode.</para>
///
/// <para>This only makes sense during token parsing, not tree parsing.
/// Tree parsing should happen only when parsing and tree construction
/// succeed.</para>
/// </remarks>
function ErrorNode(const Input: ITokenStream; const Start, Stop: IToken;
const E: ERecognitionException): IANTLRInterface;
/// <summary>
/// Is tree considered a nil node used to make lists of child nodes?
/// </summary>
function IsNil(const Tree: IANTLRInterface): Boolean;
/// <summary>
/// Add a child to the tree t. If child is a flat tree (a list), make all
/// in list children of t.
/// </summary>
/// <remarks>
/// <para>
/// Warning: if t has no children, but child does and child isNil then you
/// can decide it is ok to move children to t via t.children = child.children;
/// i.e., without copying the array. Just make sure that this is consistent
/// with have the user will build ASTs. Do nothing if t or child is null.
/// </para>
/// <para>
/// This is for construction and I'm not sure it's completely general for
/// a tree's addChild method to work this way. Make sure you differentiate
/// between your tree's addChild and this parser tree construction addChild
/// if it's not ok to move children to t with a simple assignment.
/// </para>
/// </remarks>
procedure AddChild(const T, Child: IANTLRInterface);
/// <summary>
/// If oldRoot is a nil root, just copy or move the children to newRoot.
/// If not a nil root, make oldRoot a child of newRoot.
/// </summary>
/// <remarks>
///
/// old=^(nil a b c), new=r yields ^(r a b c)
/// old=^(a b c), new=r yields ^(r ^(a b c))
///
/// If newRoot is a nil-rooted single child tree, use the single
/// child as the new root node.
///
/// old=^(nil a b c), new=^(nil r) yields ^(r a b c)
/// old=^(a b c), new=^(nil r) yields ^(r ^(a b c))
///
/// If oldRoot was null, it's ok, just return newRoot (even if isNil).
///
/// old=null, new=r yields r
/// old=null, new=^(nil r) yields ^(nil r)
///
/// Return newRoot. Throw an exception if newRoot is not a
/// simple node or nil root with a single child node--it must be a root
/// node. If newRoot is ^(nil x) return x as newRoot.
///
/// Be advised that it's ok for newRoot to point at oldRoot's
/// children; i.e., you don't have to copy the list. We are
/// constructing these nodes so we should have this control for
/// efficiency.
/// </remarks>
function BecomeRoot(const NewRoot, OldRoot: IANTLRInterface): IANTLRInterface; overload;
/// <summary>
/// Given the root of the subtree created for this rule, post process
/// it to do any simplifications or whatever you want. A required
/// behavior is to convert ^(nil singleSubtree) to singleSubtree
/// as the setting of start/stop indexes relies on a single non-nil root
/// for non-flat trees.
///
/// Flat trees such as for lists like "idlist : ID+ ;" are left alone
/// unless there is only one ID. For a list, the start/stop indexes
/// are set in the nil node.
///
/// This method is executed after all rule tree construction and right
/// before SetTokenBoundaries().
/// </summary>
function RulePostProcessing(const Root: IANTLRInterface): IANTLRInterface;
/// <summary>
/// For identifying trees. How to identify nodes so we can say "add node
/// to a prior node"?
/// </summary>
/// <remarks>
/// Even BecomeRoot is an issue. Ok, we could:
/// <list type="number">
/// <item>Number the nodes as they are created?</item>
/// <item>
/// Use the original framework assigned hashcode that's unique
/// across instances of a given type.
/// WARNING: This is usually implemented either as IL to make a
/// non-virt call to object.GetHashCode() or by via a call to
/// System.Runtime.CompilerServices.RuntimeHelpers.GetHashCode().
/// Both have issues especially on .NET 1.x and Mono.
/// </item>
/// </list>
/// </remarks>
function GetUniqueID(const Node: IANTLRInterface): Integer;
// R e w r i t e R u l e s
/// <summary>
/// Create a node for newRoot make it the root of oldRoot.
/// If oldRoot is a nil root, just copy or move the children to newRoot.
/// If not a nil root, make oldRoot a child of newRoot.
///
/// Return node created for newRoot.
/// </summary>
function BecomeRoot(const NewRoot: IToken; const OldRoot: IANTLRInterface): IANTLRInterface; overload;
/// <summary>Create a new node derived from a token, with a new token type.
/// This is invoked from an imaginary node ref on right side of a
/// rewrite rule as IMAG[$tokenLabel].
///
/// This should invoke createToken(Token).
/// </summary>
function CreateNode(const TokenType: Integer; const FromToken: IToken): IANTLRInterface; overload;
/// <summary>Same as Create(tokenType,fromToken) except set the text too.
/// This is invoked from an imaginary node ref on right side of a
/// rewrite rule as IMAG[$tokenLabel, "IMAG"].
///
/// This should invoke createToken(Token).
/// </summary>
function CreateNode(const TokenType: Integer; const FromToken: IToken;
const Text: String): IANTLRInterface; overload;
/// <summary>Create a new node derived from a token, with a new token type.
/// This is invoked from an imaginary node ref on right side of a
/// rewrite rule as IMAG["IMAG"].
///
/// This should invoke createToken(int,String).
/// </summary>
function CreateNode(const TokenType: Integer; const Text: String): IANTLRInterface; overload;
// C o n t e n t
/// <summary>For tree parsing, I need to know the token type of a node </summary>
function GetNodeType(const T: IANTLRInterface): Integer;
/// <summary>Node constructors can set the type of a node </summary>
procedure SetNodeType(const T: IANTLRInterface; const NodeType: Integer);
function GetNodeText(const T: IANTLRInterface): String;
/// <summary>Node constructors can set the text of a node </summary>
procedure SetNodeText(const T: IANTLRInterface; const Text: String);
/// <summary>
/// Return the token object from which this node was created.
/// </summary>
/// <remarks>
/// Currently used only for printing an error message. The error
/// display routine in BaseRecognizer needs to display where the
/// input the error occurred. If your tree of limitation does not
/// store information that can lead you to the token, you can create
/// a token filled with the appropriate information and pass that back.
/// <see cref="BaseRecognizer.GetErrorMessage"/>
/// </remarks>
function GetToken(const TreeNode: IANTLRInterface): IToken;
/// <summary>
/// Where are the bounds in the input token stream for this node and
/// all children?
/// </summary>
/// <remarks>
/// Each rule that creates AST nodes will call this
/// method right before returning. Flat trees (i.e., lists) will
/// still usually have a nil root node just to hold the children list.
/// That node would contain the start/stop indexes then.
/// </remarks>
procedure SetTokenBoundaries(const T: IANTLRInterface; const StartToken,
StopToken: IToken);
/// <summary>
/// Get the token start index for this subtree; return -1 if no such index
/// </summary>
function GetTokenStartIndex(const T: IANTLRInterface): Integer;
/// <summary>
/// Get the token stop index for this subtree; return -1 if no such index
/// </summary>
function GetTokenStopIndex(const T: IANTLRInterface): Integer;
// N a v i g a t i o n / T r e e P a r s i n g
/// <summary>Get a child 0..n-1 node </summary>
function GetChild(const T: IANTLRInterface; const I: Integer): IANTLRInterface;
/// <summary>Set ith child (0..n-1) to t; t must be non-null and non-nil node</summary>
procedure SetChild(const T: IANTLRInterface; const I: Integer; const Child: IANTLRInterface);
/// <summary>Remove ith child and shift children down from right.</summary>
function DeleteChild(const T: IANTLRInterface; const I: Integer): IANTLRInterface;
/// <summary>How many children? If 0, then this is a leaf node </summary>
function GetChildCount(const T: IANTLRInterface): Integer;
/// <summary>
/// Who is the parent node of this node; if null, implies node is root.
/// </summary>
/// <remarks>
/// If your node type doesn't handle this, it's ok but the tree rewrites
/// in tree parsers need this functionality.
/// </remarks>
function GetParent(const T: IANTLRInterface): IANTLRInterface;
procedure SetParent(const T, Parent: IANTLRInterface);
/// <summary>
/// What index is this node in the child list? Range: 0..n-1
/// </summary>
/// <remarks>
/// If your node type doesn't handle this, it's ok but the tree rewrites
/// in tree parsers need this functionality.
/// </remarks>
function GetChildIndex(const T: IANTLRInterface): Integer;
procedure SetChildIdex(const T: IANTLRInterface; const Index: Integer);
/// <summary>
/// Replace from start to stop child index of parent with t, which might
/// be a list. Number of children may be different after this call.
/// </summary>
/// <remarks>
/// If parent is null, don't do anything; must be at root of overall tree.
/// Can't replace whatever points to the parent externally. Do nothing.
/// </remarks>
procedure ReplaceChildren(const Parent: IANTLRInterface; const StartChildIndex,
StopChildIndex: Integer; const T: IANTLRInterface);
end;
/// <summary>A stream of tree nodes, accessing nodes from a tree of some kind </summary>
ITreeNodeStream = interface(IIntStream)
['{75EA5C06-8145-48F5-9A56-43E481CE86C6}']
{ Property accessors }
function GetTreeSource: IANTLRInterface;
function GetTokenStream: ITokenStream;
function GetTreeAdaptor: ITreeAdaptor;
procedure SetHasUniqueNavigationNodes(const Value: Boolean);
{ Methods }
/// <summary>Get a tree node at an absolute index i; 0..n-1.</summary>
/// <remarks>
/// If you don't want to buffer up nodes, then this method makes no
/// sense for you.
/// </remarks>
function Get(const I: Integer): IANTLRInterface;
/// <summary>
/// Get tree node at current input pointer + i ahead where i=1 is next node.
/// i<0 indicates nodes in the past. So LT(-1) is previous node, but
/// implementations are not required to provide results for k < -1.
/// LT(0) is undefined. For i>=n, return null.
/// Return null for LT(0) and any index that results in an absolute address
/// that is negative.
///
/// This is analogus to the LT() method of the TokenStream, but this
/// returns a tree node instead of a token. Makes code gen identical
/// for both parser and tree grammars. :)
/// </summary>
function LT(const K: Integer): IANTLRInterface;
/// <summary>Return the text of all nodes from start to stop, inclusive.
/// If the stream does not buffer all the nodes then it can still
/// walk recursively from start until stop. You can always return
/// null or "" too, but users should not access $ruleLabel.text in
/// an action of course in that case.
/// </summary>
function ToString(const Start, Stop: IANTLRInterface): String; overload;
function ToString: String; overload;
// REWRITING TREES (used by tree parser)
/// <summary>
/// Replace from start to stop child index of parent with t, which might
/// be a list. Number of children may be different after this call.
/// </summary>
/// <remarks>
/// The stream is notified because it is walking the tree and might need
/// to know you are monkeying with the underlying tree. Also, it might be
/// able to modify the node stream to avoid restreaming for future phases.
///
/// If parent is null, don't do anything; must be at root of overall tree.
/// Can't replace whatever points to the parent externally. Do nothing.
/// </remarks>
procedure ReplaceChildren(const Parent: IANTLRInterface; const StartChildIndex,
StopChildIndex: Integer; const T: IANTLRInterface);
{ Properties }
/// <summary>
/// Where is this stream pulling nodes from? This is not the name, but
/// the object that provides node objects.
///
/// TODO: do we really need this?
/// </summary>
property TreeSource: IANTLRInterface read GetTreeSource;
/// <summary>
/// Get the ITokenStream from which this stream's Tree was created
/// (may be null)
/// </summary>
/// <remarks>
/// If the tree associated with this stream was created from a
/// TokenStream, you can specify it here. Used to do rule $text
/// attribute in tree parser. Optional unless you use tree parser
/// rule text attribute or output=template and rewrite=true options.
/// </remarks>
property TokenStream: ITokenStream read GetTokenStream;
/// <summary>
/// What adaptor can tell me how to interpret/navigate nodes and trees.
/// E.g., get text of a node.
/// </summary>
property TreeAdaptor: ITreeAdaptor read GetTreeAdaptor;
/// <summary>
/// As we flatten the tree, we use UP, DOWN nodes to represent
/// the tree structure. When debugging we need unique nodes
/// so we have to instantiate new ones. When doing normal tree
/// parsing, it's slow and a waste of memory to create unique
/// navigation nodes. Default should be false;
/// </summary>
property HasUniqueNavigationNodes: Boolean write SetHasUniqueNavigationNodes;
end;
/// <summary>
/// What does a tree look like? ANTLR has a number of support classes
/// such as CommonTreeNodeStream that work on these kinds of trees. You
/// don't have to make your trees implement this interface, but if you do,
/// you'll be able to use more support code.
///
/// NOTE: When constructing trees, ANTLR can build any kind of tree; it can
/// even use Token objects as trees if you add a child list to your tokens.
///
/// This is a tree node without any payload; just navigation and factory stuff.
/// </summary>
ITree = interface(IANTLRInterface)
['{4B6EFB53-EBF6-4647-BA4D-48B68134DC2A}']
{ Property accessors }
function GetChildCount: Integer;
function GetParent: ITree;
procedure SetParent(const Value: ITree);
function GetChildIndex: Integer;
procedure SetChildIndex(const Value: Integer);
function GetIsNil: Boolean;
function GetTokenType: Integer;
function GetText: String;
function GetLine: Integer;
function GetCharPositionInLine: Integer;
function GetTokenStartIndex: Integer;
procedure SetTokenStartIndex(const Value: Integer);
function GetTokenStopIndex: Integer;
procedure SetTokenStopIndex(const Value: Integer);
{ Methods }
/// <summary>Set (or reset) the parent and child index values for all children</summary>
procedure FreshenParentAndChildIndexes;
function GetChild(const I: Integer): ITree;
/// <summary>
/// Add t as a child to this node. If t is null, do nothing. If t
/// is nil, add all children of t to this' children.
/// </summary>
/// <param name="t">Tree to add</param>
procedure AddChild(const T: ITree);
/// <summary>Set ith child (0..n-1) to t; t must be non-null and non-nil node</summary>
procedure SetChild(const I: Integer; const T: ITree);
function DeleteChild(const I: Integer): IANTLRInterface;
/// <summary>
/// Delete children from start to stop and replace with t even if t is
/// a list (nil-root tree). num of children can increase or decrease.
/// For huge child lists, inserting children can force walking rest of
/// children to set their childindex; could be slow.
/// </summary>
procedure ReplaceChildren(const StartChildIndex, StopChildIndex: Integer;
const T: IANTLRInterface);
function DupNode: ITree;
function ToStringTree: String;
function ToString: String;
{ Properties }
property ChildCount: Integer read GetChildCount;
// Tree tracks parent and child index now > 3.0
property Parent: ITree read GetParent write SetParent;
/// <summary>This node is what child index? 0..n-1</summary>
property ChildIndex: Integer read GetChildIndex write SetChildIndex;
/// <summary>
/// Indicates the node is a nil node but may still have children, meaning
/// the tree is a flat list.
/// </summary>
property IsNil: Boolean read GetIsNil;
/// <summary>Return a token type; needed for tree parsing </summary>
property TokenType: Integer read GetTokenType;
property Text: String read GetText;
/// <summary>In case we don't have a token payload, what is the line for errors? </summary>
property Line: Integer read GetLine;
property CharPositionInLine: Integer read GetCharPositionInLine;
/// <summary>
/// What is the smallest token index (indexing from 0) for this node
/// and its children?
/// </summary>
property TokenStartIndex: Integer read GetTokenStartIndex write SetTokenStartIndex;
/// <summary>
/// What is the largest token index (indexing from 0) for this node
/// and its children?
/// </summary>
property TokenStopIndex: Integer read GetTokenStopIndex write SetTokenStopIndex;
end;
/// <summary>
/// A generic tree implementation with no payload. You must subclass to
/// actually have any user data. ANTLR v3 uses a list of children approach
/// instead of the child-sibling approach in v2. A flat tree (a list) is
/// an empty node whose children represent the list. An empty, but
/// non-null node is called "nil".
/// </summary>
IBaseTree = interface(ITree)
['{6772F6EA-5FE0-40C6-BE5C-800AB2540E55}']
{ Property accessors }
function GetChildren: IList<IBaseTree>;
function GetChildIndex: Integer;
procedure SetChildIndex(const Value: Integer);
function GetParent: ITree;
procedure SetParent(const Value: ITree);
function GetTokenType: Integer;
function GetTokenStartIndex: Integer;
procedure SetTokenStartIndex(const Value: Integer);
function GetTokenStopIndex: Integer;
procedure SetTokenStopIndex(const Value: Integer);
function GetText: String;
{ Methods }
/// <summary>
/// Add all elements of kids list as children of this node
/// </summary>
/// <param name="kids"></param>
procedure AddChildren(const Kids: IList<IBaseTree>);
procedure SetChild(const I: Integer; const T: ITree);
procedure FreshenParentAndChildIndexes(const Offset: Integer);
procedure SanityCheckParentAndChildIndexes; overload;
procedure SanityCheckParentAndChildIndexes(const Parent: ITree;
const I: Integer); overload;
/// <summary>
/// Print out a whole tree not just a node
/// </summary>
function ToStringTree: String;
function DupNode: ITree;
{ Properties }
/// <summary>
/// Get the children internal list of children. Manipulating the list
/// directly is not a supported operation (i.e. you do so at your own risk)
/// </summary>
property Children: IList<IBaseTree> read GetChildren;
/// <summary>BaseTree doesn't track child indexes.</summary>
property ChildIndex: Integer read GetChildIndex write SetChildIndex;
/// <summary>BaseTree doesn't track parent pointers.</summary>
property Parent: ITree read GetParent write SetParent;
/// <summary>Return a token type; needed for tree parsing </summary>
property TokenType: Integer read GetTokenType;
/// <summary>
/// What is the smallest token index (indexing from 0) for this node
/// and its children?
/// </summary>
property TokenStartIndex: Integer read GetTokenStartIndex write SetTokenStartIndex;
/// <summary>
/// What is the largest token index (indexing from 0) for this node
/// and its children?
/// </summary>
property TokenStopIndex: Integer read GetTokenStopIndex write SetTokenStopIndex;
property Text: String read GetText;
end;
/// <summary>A tree node that is wrapper for a Token object. </summary>
/// <remarks>
/// After 3.0 release while building tree rewrite stuff, it became clear
/// that computing parent and child index is very difficult and cumbersome.
/// Better to spend the space in every tree node. If you don't want these
/// extra fields, it's easy to cut them out in your own BaseTree subclass.
/// </remarks>
ICommonTree = interface(IBaseTree)
['{791C0EA6-1E4D-443E-83E2-CC1EFEAECC8B}']
{ Property accessors }
function GetToken: IToken;
function GetStartIndex: Integer;
procedure SetStartIndex(const Value: Integer);
function GetStopIndex: Integer;
procedure SetStopIndex(const Value: Integer);
{ Properties }
property Token: IToken read GetToken;
property StartIndex: Integer read GetStartIndex write SetStartIndex;
property StopIndex: Integer read GetStopIndex write SetStopIndex;
end;
// A node representing erroneous token range in token stream
ICommonErrorNode = interface(ICommonTree)
['{20FF30BA-C055-4E8F-B3E7-7FFF6313853E}']
end;
/// <summary>
/// A TreeAdaptor that works with any Tree implementation
/// </summary>
IBaseTreeAdaptor = interface(ITreeAdaptor)
['{B9CE670A-E53F-494C-B700-E4A3DF42D482}']
/// <summary>
/// This is generic in the sense that it will work with any kind of
/// tree (not just the ITree interface). It invokes the adaptor routines
/// not the tree node routines to do the construction.
/// </summary>
function DupTree(const Tree: IANTLRInterface): IANTLRInterface; overload;
function DupTree(const T, Parent: IANTLRInterface): IANTLRInterface; overload;
/// <summary>
/// Tell me how to create a token for use with imaginary token nodes.
/// For example, there is probably no input symbol associated with imaginary
/// token DECL, but you need to create it as a payload or whatever for
/// the DECL node as in ^(DECL type ID).
///
/// If you care what the token payload objects' type is, you should
/// override this method and any other createToken variant.
/// </summary>
function CreateToken(const TokenType: Integer; const Text: String): IToken; overload;
/// <summary>
/// Tell me how to create a token for use with imaginary token nodes.
/// For example, there is probably no input symbol associated with imaginary
/// token DECL, but you need to create it as a payload or whatever for
/// the DECL node as in ^(DECL type ID).
///
/// This is a variant of createToken where the new token is derived from
/// an actual real input token. Typically this is for converting '{'
/// tokens to BLOCK etc... You'll see
///
/// r : lc='{' ID+ '}' -> ^(BLOCK[$lc] ID+) ;
///
/// If you care what the token payload objects' type is, you should
/// override this method and any other createToken variant.
/// </summary>
function CreateToken(const FromToken: IToken): IToken; overload;
end;
/// <summary>
/// A TreeAdaptor that works with any Tree implementation. It provides
/// really just factory methods; all the work is done by BaseTreeAdaptor.
/// If you would like to have different tokens created than ClassicToken
/// objects, you need to override this and then set the parser tree adaptor to
/// use your subclass.
///
/// To get your parser to build nodes of a different type, override
/// Create(Token).
/// </summary>
ICommonTreeAdaptor = interface(IBaseTreeAdaptor)
['{B067EE7A-38EB-4156-9447-CDD6DDD6D13B}']
end;
/// <summary>
/// A buffered stream of tree nodes. Nodes can be from a tree of ANY kind.
/// </summary>
/// <remarks>
/// This node stream sucks all nodes out of the tree specified in the
/// constructor during construction and makes pointers into the tree
/// using an array of Object pointers. The stream necessarily includes
/// pointers to DOWN and UP and EOF nodes.
///
/// This stream knows how to mark/release for backtracking.
///
/// This stream is most suitable for tree interpreters that need to
/// jump around a lot or for tree parsers requiring speed (at cost of memory).
/// There is some duplicated functionality here with UnBufferedTreeNodeStream
/// but just in bookkeeping, not tree walking etc...
///
/// <see cref="UnBufferedTreeNodeStream"/>
///
/// </remarks>
ICommonTreeNodeStream = interface(ITreeNodeStream)
['{0112FB31-AA1E-471C-ADC3-D97AC5D77E05}']
{ Property accessors }
function GetCurrentSymbol: IANTLRInterface;
function GetTreeSource: IANTLRInterface;
function GetSourceName: String;
function GetTokenStream: ITokenStream;
procedure SetTokenStream(const Value: ITokenStream);
function GetTreeAdaptor: ITreeAdaptor;
procedure SetTreeAdaptor(const Value: ITreeAdaptor);
function GetHasUniqueNavigationNodes: Boolean;
procedure SetHasUniqueNavigationNodes(const Value: Boolean);
{ Methods }
/// <summary>
/// Walk tree with depth-first-search and fill nodes buffer.
/// Don't do DOWN, UP nodes if its a list (t is isNil).
/// </summary>
procedure FillBuffer(const T: IANTLRInterface);
function Get(const I: Integer): IANTLRInterface;
function LT(const K: Integer): IANTLRInterface;
/// <summary>
/// Look backwards k nodes
/// </summary>
function LB(const K: Integer): IANTLRInterface;
/// <summary>
/// Make stream jump to a new location, saving old location.
/// Switch back with pop().
/// </summary>
procedure Push(const Index: Integer);
/// <summary>
/// Seek back to previous index saved during last Push() call.
/// Return top of stack (return index).
/// </summary>
function Pop: Integer;
procedure Reset;
// Debugging
function ToTokenString(const Start, Stop: Integer): String;
function ToString(const Start, Stop: IANTLRInterface): String; overload;
function ToString: String; overload;
{ Properties }
property CurrentSymbol: IANTLRInterface read GetCurrentSymbol;
/// <summary>
/// Where is this stream pulling nodes from? This is not the name, but
/// the object that provides node objects.
/// </summary>
property TreeSource: IANTLRInterface read GetTreeSource;
property SourceName: String read GetSourceName;
property TokenStream: ITokenStream read GetTokenStream write SetTokenStream;
property TreeAdaptor: ITreeAdaptor read GetTreeAdaptor write SetTreeAdaptor;
property HasUniqueNavigationNodes: Boolean read GetHasUniqueNavigationNodes write SetHasUniqueNavigationNodes;
end;
/// <summary>
/// A record of the rules used to Match a token sequence. The tokens
/// end up as the leaves of this tree and rule nodes are the interior nodes.
/// This really adds no functionality, it is just an alias for CommonTree
/// that is more meaningful (specific) and holds a String to display for a node.
/// </summary>
IParseTree = interface(IANTLRInterface)
['{1558F260-CAF8-4488-A242-3559BCE4E573}']
{ Methods }
// Emit a token and all hidden nodes before. EOF node holds all
// hidden tokens after last real token.
function ToStringWithHiddenTokens: String;
// Print out the leaves of this tree, which means printing original
// input back out.
function ToInputString: String;
procedure _ToStringLeaves(const Buf: TStringBuilder);
end;
/// <summary>
/// A generic list of elements tracked in an alternative to be used in
/// a -> rewrite rule. We need to subclass to fill in the next() method,
/// which returns either an AST node wrapped around a token payload or
/// an existing subtree.
///
/// Once you start next()ing, do not try to add more elements. It will
/// break the cursor tracking I believe.
///
/// <see cref="RewriteRuleSubtreeStream"/>
/// <see cref="RewriteRuleTokenStream"/>
///
/// TODO: add mechanism to detect/puke on modification after reading from stream
/// </summary>
IRewriteRuleElementStream = interface(IANTLRInterface)
['{3CB6C521-F583-40DC-A1E3-4D7D57B98C74}']
{ Property accessors }
function GetDescription: String;
{ Methods }
procedure Add(const El: IANTLRInterface);
/// <summary>
/// Reset the condition of this stream so that it appears we have
/// not consumed any of its elements. Elements themselves are untouched.
/// </summary>
/// <remarks>
/// Once we reset the stream, any future use will need duplicates. Set
/// the dirty bit.
/// </remarks>
procedure Reset;
function HasNext: Boolean;
/// <summary>
/// Return the next element in the stream.
/// </summary>
function NextTree: IANTLRInterface;
function NextNode: IANTLRInterface;
function Size: Integer;
{ Properties }
property Description: String read GetDescription;
end;
/// <summary>
/// Queues up nodes matched on left side of -> in a tree parser. This is
/// the analog of RewriteRuleTokenStream for normal parsers.
/// </summary>
IRewriteRuleNodeStream = interface(IRewriteRuleElementStream)
['{F60D1D36-FE13-4312-99DA-11E5F4BEBB66}']
{ Methods }
function NextNode: IANTLRInterface;
end;
IRewriteRuleSubtreeStream = interface(IRewriteRuleElementStream)
['{C6BDA145-D926-45BC-B293-67490D72829B}']
{ Methods }
/// <summary>
/// Treat next element as a single node even if it's a subtree.
/// </summary>
/// <remarks>
/// This is used instead of next() when the result has to be a
/// tree root node. Also prevents us from duplicating recently-added
/// children; e.g., ^(type ID)+ adds ID to type and then 2nd iteration
/// must dup the type node, but ID has been added.
///
/// Referencing a rule result twice is ok; dup entire tree as
/// we can't be adding trees as root; e.g., expr expr.
/// </remarks>
function NextNode: IANTLRInterface;
end;
IRewriteRuleTokenStream = interface(IRewriteRuleElementStream)
['{4D46AB00-7A19-4F69-B159-1EF09DB8C09C}']
/// <summary>
/// Get next token from stream and make a node for it.
/// </summary>
/// <remarks>
/// ITreeAdaptor.Create() returns an object, so no further restrictions possible.
/// </remarks>
function NextNode: IANTLRInterface;
function NextToken: IToken;
end;
/// <summary>
/// A parser for a stream of tree nodes. "tree grammars" result in a subclass
/// of this. All the error reporting and recovery is shared with Parser via
/// the BaseRecognizer superclass.
/// </summary>
ITreeParser = interface(IBaseRecognizer)
['{20611FB3-9830-444D-B385-E8C2D094484B}']
{ Property accessors }
function GetTreeNodeStream: ITreeNodeStream;
procedure SetTreeNodeStream(const Value: ITreeNodeStream);
{ Methods }
procedure TraceIn(const RuleName: String; const RuleIndex: Integer);
procedure TraceOut(const RuleName: String; const RuleIndex: Integer);
{ Properties }
property TreeNodeStream: ITreeNodeStream read GetTreeNodeStream write SetTreeNodeStream;
end;
ITreePatternLexer = interface(IANTLRInterface)
['{C3FEC614-9E6F-48D2-ABAB-59FC83D8BC2F}']
{ Methods }
function NextToken: Integer;
function SVal: String;
end;
IContextVisitor = interface(IANTLRInterface)
['{92B80D23-C63E-48B4-A9CD-EC2639317E43}']
{ Methods }
procedure Visit(const T, Parent: IANTLRInterface; const ChildIndex: Integer;
const Labels: IDictionary<String, IANTLRInterface>);
end;
/// <summary>
/// Build and navigate trees with this object. Must know about the names
/// of tokens so you have to pass in a map or array of token names (from which
/// this class can build the map). I.e., Token DECL means nothing unless the
/// class can translate it to a token type.
/// </summary>
/// <remarks>
/// In order to create nodes and navigate, this class needs a TreeAdaptor.
///
/// This class can build a token type -> node index for repeated use or for
/// iterating over the various nodes with a particular type.
///
/// This class works in conjunction with the TreeAdaptor rather than moving
/// all this functionality into the adaptor. An adaptor helps build and
/// navigate trees using methods. This class helps you do it with string
/// patterns like "(A B C)". You can create a tree from that pattern or
/// match subtrees against it.
/// </remarks>
ITreeWizard = interface(IANTLRInterface)
['{4F440E19-893A-4E52-A979-E5377EAFA3B8}']
{ Methods }
/// <summary>
/// Compute a Map<String, Integer> that is an inverted index of
/// tokenNames (which maps int token types to names).
/// </summary>
function ComputeTokenTypes(const TokenNames: TStringArray): IDictionary<String, Integer>;
/// <summary>
/// Using the map of token names to token types, return the type.
/// </summary>
function GetTokenType(const TokenName: String): Integer;
/// <summary>
/// Walk the entire tree and make a node name to nodes mapping.
/// </summary>
/// <remarks>
/// For now, use recursion but later nonrecursive version may be
/// more efficient. Returns Map<Integer, List> where the List is
/// of your AST node type. The Integer is the token type of the node.
///
/// TODO: save this index so that find and visit are faster
/// </remarks>
function Index(const T: IANTLRInterface): IDictionary<Integer, IList<IANTLRInterface>>;
/// <summary>Return a List of tree nodes with token type ttype</summary>
function Find(const T: IANTLRInterface; const TokenType: Integer): IList<IANTLRInterface>; overload;
/// <summary>Return a List of subtrees matching pattern</summary>
function Find(const T: IANTLRInterface; const Pattern: String): IList<IANTLRInterface>; overload;
function FindFirst(const T: IANTLRInterface; const TokenType: Integer): IANTLRInterface; overload;
function FindFirst(const T: IANTLRInterface; const Pattern: String): IANTLRInterface; overload;
/// <summary>
/// Visit every ttype node in t, invoking the visitor.
/// </summary>
/// <remarks>
/// This is a quicker
/// version of the general visit(t, pattern) method. The labels arg
/// of the visitor action method is never set (it's null) since using
/// a token type rather than a pattern doesn't let us set a label.
/// </remarks>
procedure Visit(const T: IANTLRInterface; const TokenType: Integer;
const Visitor: IContextVisitor); overload;
/// <summary>
/// For all subtrees that match the pattern, execute the visit action.
/// </summary>
/// <remarks>
/// The implementation uses the root node of the pattern in combination
/// with visit(t, ttype, visitor) so nil-rooted patterns are not allowed.
/// Patterns with wildcard roots are also not allowed.
/// </remarks>
procedure Visit(const T: IANTLRInterface; const Pattern: String;
const Visitor: IContextVisitor); overload;
/// <summary>
/// Given a pattern like (ASSIGN %lhs:ID %rhs:.) with optional labels
/// on the various nodes and '.' (dot) as the node/subtree wildcard,
/// return true if the pattern matches and fill the labels Map with
/// the labels pointing at the appropriate nodes. Return false if
/// the pattern is malformed or the tree does not match.
/// </summary>
/// <remarks>
/// If a node specifies a text arg in pattern, then that must match
/// for that node in t.
///
/// TODO: what's a better way to indicate bad pattern? Exceptions are a hassle
/// </remarks>
function Parse(const T: IANTLRInterface; const Pattern: String;
const Labels: IDictionary<String, IANTLRInterface>): Boolean; overload;
function Parse(const T: IANTLRInterface; const Pattern: String): Boolean; overload;
/// <summary>
/// Create a tree or node from the indicated tree pattern that closely
/// follows ANTLR tree grammar tree element syntax:
///
/// (root child1 ... child2).
///
/// </summary>
/// <remarks>
/// You can also just pass in a node: ID
///
/// Any node can have a text argument: ID[foo]
/// (notice there are no quotes around foo--it's clear it's a string).
///
/// nil is a special name meaning "give me a nil node". Useful for
/// making lists: (nil A B C) is a list of A B C.
/// </remarks>
function CreateTreeOrNode(const Pattern: String): IANTLRInterface;
/// <summary>
/// Compare type, structure, and text of two trees, assuming adaptor in
/// this instance of a TreeWizard.
/// </summary>
function Equals(const T1, T2: IANTLRInterface): Boolean; overload;
/// <summary>
/// Compare t1 and t2; return true if token types/text, structure match exactly.
/// The trees are examined in their entirety so that (A B) does not match
/// (A B C) nor (A (B C)).
/// </summary>
/// <remarks>
/// TODO: allow them to pass in a comparator
/// TODO: have a version that is nonstatic so it can use instance adaptor
///
/// I cannot rely on the tree node's equals() implementation as I make
/// no constraints at all on the node types nor interface etc...
/// </remarks>
function Equals(const T1, T2: IANTLRInterface; const Adaptor: ITreeAdaptor): Boolean; overload;
end;
ITreePatternParser = interface(IANTLRInterface)
['{0CE3DF2A-7E4C-4A7C-8FE8-F1D7AFF97CAE}']
{ Methods }
function Pattern: IANTLRInterface;
function ParseTree: IANTLRInterface;
function ParseNode: IANTLRInterface;
end;
/// <summary>
/// This is identical to the ParserRuleReturnScope except that
/// the start property is a tree node and not a Token object
/// when you are parsing trees. To be generic the tree node types
/// have to be Object :(
/// </summary>
ITreeRuleReturnScope = interface(IRuleReturnScope)
['{FA2B1766-34E5-4D92-8996-371D5CFED999}']
end;
/// <summary>
/// A stream of tree nodes, accessing nodes from a tree of ANY kind.
/// </summary>
/// <remarks>
/// No new nodes should be created in tree during the walk. A small buffer
/// of tokens is kept to efficiently and easily handle LT(i) calls, though
/// the lookahead mechanism is fairly complicated.
///
/// For tree rewriting during tree parsing, this must also be able
/// to replace a set of children without "losing its place".
/// That part is not yet implemented. Will permit a rule to return
/// a different tree and have it stitched into the output tree probably.
///
/// <see cref="CommonTreeNodeStream"/>
///
/// </remarks>
IUnBufferedTreeNodeStream = interface(ITreeNodeStream)
['{E46367AD-ED41-4D97-824E-575A48F7435D}']
{ Property accessors }
function GetHasUniqueNavigationNodes: Boolean;
procedure SetHasUniqueNavigationNodes(const Value: Boolean);
function GetCurrent: IANTLRInterface;
function GetTokenStream: ITokenStream;
procedure SetTokenStream(const Value: ITokenStream);
{ Methods }
procedure Reset;
function MoveNext: Boolean;
{ Properties }
property HasUniqueNavigationNodes: Boolean read GetHasUniqueNavigationNodes write SetHasUniqueNavigationNodes;
property Current: IANTLRInterface read GetCurrent;
property TokenStream: ITokenStream read GetTokenStream write SetTokenStream;
end;
/// <summary>Base class for all exceptions thrown during AST rewrite construction.</summary>
/// <remarks>
/// This signifies a case where the cardinality of two or more elements
/// in a subrule are different: (ID INT)+ where |ID|!=|INT|
/// </remarks>
ERewriteCardinalityException = class(Exception)
strict private
FElementDescription: String;
public
constructor Create(const AElementDescription: String);
property ElementDescription: String read FElementDescription write FElementDescription;
end;
/// <summary>
/// No elements within a (...)+ in a rewrite rule
/// </summary>
ERewriteEarlyExitException = class(ERewriteCardinalityException)
// No new declarations
end;
/// <summary>
/// Ref to ID or expr but no tokens in ID stream or subtrees in expr stream
/// </summary>
ERewriteEmptyStreamException = class(ERewriteCardinalityException)
// No new declarations
end;
type
TTree = class sealed
strict private
class var
FINVALID_NODE: ITree;
private
class procedure Initialize; static;
public
class property INVALID_NODE: ITree read FINVALID_NODE;
end;
TBaseTree = class abstract(TANTLRObject, IBaseTree, ITree)
protected
{ ITree / IBaseTree }
function GetParent: ITree; virtual;
procedure SetParent(const Value: ITree); virtual;
function GetChildIndex: Integer; virtual;
procedure SetChildIndex(const Value: Integer); virtual;
function GetTokenType: Integer; virtual; abstract;
function GetText: String; virtual; abstract;
function GetTokenStartIndex: Integer; virtual; abstract;
procedure SetTokenStartIndex(const Value: Integer); virtual; abstract;
function GetTokenStopIndex: Integer; virtual; abstract;
procedure SetTokenStopIndex(const Value: Integer); virtual; abstract;
function DupNode: ITree; virtual; abstract;
function ToStringTree: String; virtual;
function GetChildCount: Integer; virtual;
function GetIsNil: Boolean; virtual;
function GetLine: Integer; virtual;
function GetCharPositionInLine: Integer; virtual;
function GetChild(const I: Integer): ITree; virtual;
procedure AddChild(const T: ITree);
function DeleteChild(const I: Integer): IANTLRInterface;
procedure FreshenParentAndChildIndexes; overload;
procedure ReplaceChildren(const StartChildIndex, StopChildIndex: Integer;
const T: IANTLRInterface);
protected
{ IBaseTree }
function GetChildren: IList<IBaseTree>;
procedure AddChildren(const Kids: IList<IBaseTree>);
procedure SetChild(const I: Integer; const T: ITree); virtual;
procedure FreshenParentAndChildIndexes(const Offset: Integer); overload;
procedure SanityCheckParentAndChildIndexes; overload; virtual;
procedure SanityCheckParentAndChildIndexes(const Parent: ITree;
const I: Integer); overload; virtual;
strict protected
FChildren: IList<IBaseTree>;
/// <summary>Override in a subclass to change the impl of children list </summary>
function CreateChildrenList: IList<IBaseTree>; virtual;
public
constructor Create; overload;
/// <summary>Create a new node from an existing node does nothing for BaseTree
/// as there are no fields other than the children list, which cannot
/// be copied as the children are not considered part of this node.
/// </summary>
constructor Create(const ANode: ITree); overload;
function ToString: String; override; abstract;
end;
TCommonTree = class(TBaseTree, ICommonTree)
strict protected
/// <summary>A single token is the payload </summary>
FToken: IToken;
/// <summary>
/// What token indexes bracket all tokens associated with this node
/// and below?
/// </summary>
FStartIndex: Integer;
FStopIndex: Integer;
/// <summary>Who is the parent node of this node; if null, implies node is root</summary>
/// <remarks>
/// FParent should be of type ICommonTree, but that would introduce a
/// circular reference because the tree also maintains links to it's
/// children. This circular reference would cause a memory leak because
/// the reference count will never reach 0. This is avoided by making
/// FParent a regular pointer and letting the GetParent and SetParent
/// property accessors do the conversion to/from ICommonTree.
/// </remarks>
FParent: Pointer; { ICommonTree ; }
/// <summary>What index is this node in the child list? Range: 0..n-1</summary>
FChildIndex: Integer;
protected
{ ITree / IBaseTree }
function GetIsNil: Boolean; override;
function GetTokenType: Integer; override;
function GetText: String; override;
function GetLine: Integer; override;
function GetCharPositionInLine: Integer; override;
function GetTokenStartIndex: Integer; override;
procedure SetTokenStartIndex(const Value: Integer); override;
function GetTokenStopIndex: Integer; override;
procedure SetTokenStopIndex(const Value: Integer); override;
function GetChildIndex: Integer; override;
procedure SetChildIndex(const Value: Integer); override;
function GetParent: ITree; override;
procedure SetParent(const Value: ITree); override;
function DupNode: ITree; override;
protected
{ ICommonTree }
function GetToken: IToken;
function GetStartIndex: Integer;
procedure SetStartIndex(const Value: Integer);
function GetStopIndex: Integer;
procedure SetStopIndex(const Value: Integer);
public
constructor Create; overload;
constructor Create(const ANode: ICommonTree); overload;
constructor Create(const AToken: IToken); overload;
function ToString: String; override;
end;
TCommonErrorNode = class(TCommonTree, ICommonErrorNode)
strict private
FInput: IIntStream;
FStart: IToken;
FStop: IToken;
FTrappedException: ERecognitionException;
protected
{ ITree / IBaseTree }
function GetIsNil: Boolean; override;
function GetTokenType: Integer; override;
function GetText: String; override;
public
constructor Create(const AInput: ITokenStream; const AStart, AStop: IToken;
const AException: ERecognitionException);
function ToString: String; override;
end;
TBaseTreeAdaptor = class abstract(TANTLRObject, IBaseTreeAdaptor, ITreeAdaptor)
strict private
/// <summary>A map of tree node to unique IDs.</summary>
FTreeToUniqueIDMap: IDictionary<IANTLRInterface, Integer>;
/// <summary>Next available unique ID.</summary>
FUniqueNodeID: Integer;
protected
{ ITreeAdaptor }
function CreateNode(const Payload: IToken): IANTLRInterface; overload; virtual; abstract;
function DupNode(const TreeNode: IANTLRInterface): IANTLRInterface; virtual; abstract;
function DupTree(const Tree: IANTLRInterface): IANTLRInterface; overload; virtual;
function GetNilNode: IANTLRInterface; virtual;
function ErrorNode(const Input: ITokenStream; const Start, Stop: IToken;
const E: ERecognitionException): IANTLRInterface; virtual;
function IsNil(const Tree: IANTLRInterface): Boolean; virtual;
procedure AddChild(const T, Child: IANTLRInterface); virtual;
function BecomeRoot(const NewRoot, OldRoot: IANTLRInterface): IANTLRInterface; overload; virtual;
function RulePostProcessing(const Root: IANTLRInterface): IANTLRInterface; virtual;
function GetUniqueID(const Node: IANTLRInterface): Integer;
function BecomeRoot(const NewRoot: IToken; const OldRoot: IANTLRInterface): IANTLRInterface; overload; virtual;
function CreateNode(const TokenType: Integer; const FromToken: IToken): IANTLRInterface; overload; virtual;
function CreateNode(const TokenType: Integer; const FromToken: IToken;
const Text: String): IANTLRInterface; overload; virtual;
function CreateNode(const TokenType: Integer; const Text: String): IANTLRInterface; overload; virtual;
function GetNodeType(const T: IANTLRInterface): Integer; virtual;
procedure SetNodeType(const T: IANTLRInterface; const NodeType: Integer); virtual;
function GetNodeText(const T: IANTLRInterface): String; virtual;
procedure SetNodeText(const T: IANTLRInterface; const Text: String); virtual;
function GetToken(const TreeNode: IANTLRInterface): IToken; virtual; abstract;
procedure SetTokenBoundaries(const T: IANTLRInterface; const StartToken,
StopToken: IToken); virtual; abstract;
function GetTokenStartIndex(const T: IANTLRInterface): Integer; virtual; abstract;
function GetTokenStopIndex(const T: IANTLRInterface): Integer; virtual; abstract;
function GetChild(const T: IANTLRInterface; const I: Integer): IANTLRInterface; virtual;
procedure SetChild(const T: IANTLRInterface; const I: Integer; const Child: IANTLRInterface); virtual;
function DeleteChild(const T: IANTLRInterface; const I: Integer): IANTLRInterface; virtual;
function GetChildCount(const T: IANTLRInterface): Integer; virtual;
function GetParent(const T: IANTLRInterface): IANTLRInterface; virtual; abstract;
procedure SetParent(const T, Parent: IANTLRInterface); virtual; abstract;
function GetChildIndex(const T: IANTLRInterface): Integer; virtual; abstract;
procedure SetChildIdex(const T: IANTLRInterface; const Index: Integer); virtual; abstract;
procedure ReplaceChildren(const Parent: IANTLRInterface; const StartChildIndex,
StopChildIndex: Integer; const T: IANTLRInterface); virtual; abstract;
protected
{ IBaseTreeAdaptor }
function DupTree(const T, Parent: IANTLRInterface): IANTLRInterface; overload; virtual;
function CreateToken(const TokenType: Integer; const Text: String): IToken; overload; virtual; abstract;
function CreateToken(const FromToken: IToken): IToken; overload; virtual; abstract;
public
constructor Create;
end;
TCommonTreeAdaptor = class(TBaseTreeAdaptor, ICommonTreeAdaptor)
protected
{ ITreeAdaptor }
function DupNode(const TreeNode: IANTLRInterface): IANTLRInterface; override;
function CreateNode(const Payload: IToken): IANTLRInterface; overload; override;
procedure SetTokenBoundaries(const T: IANTLRInterface; const StartToken,
StopToken: IToken); override;
function GetTokenStartIndex(const T: IANTLRInterface): Integer; override;
function GetTokenStopIndex(const T: IANTLRInterface): Integer; override;
function GetNodeText(const T: IANTLRInterface): String; override;
function GetToken(const TreeNode: IANTLRInterface): IToken; override;
function GetNodeType(const T: IANTLRInterface): Integer; override;
function GetChild(const T: IANTLRInterface; const I: Integer): IANTLRInterface; override;
function GetChildCount(const T: IANTLRInterface): Integer; override;
function GetParent(const T: IANTLRInterface): IANTLRInterface; override;
procedure SetParent(const T, Parent: IANTLRInterface); override;
function GetChildIndex(const T: IANTLRInterface): Integer; override;
procedure SetChildIdex(const T: IANTLRInterface; const Index: Integer); override;
procedure ReplaceChildren(const Parent: IANTLRInterface; const StartChildIndex,
StopChildIndex: Integer; const T: IANTLRInterface); override;
protected
{ IBaseTreeAdaptor }
function CreateToken(const TokenType: Integer; const Text: String): IToken; overload; override;
function CreateToken(const FromToken: IToken): IToken; overload; override;
end;
TCommonTreeNodeStream = class(TANTLRObject, ICommonTreeNodeStream, ITreeNodeStream)
public
const
DEFAULT_INITIAL_BUFFER_SIZE = 100;
INITIAL_CALL_STACK_SIZE = 10;
strict private
// all these navigation nodes are shared and hence they
// cannot contain any line/column info
FDown: IANTLRInterface;
FUp: IANTLRInterface;
FEof: IANTLRInterface;
/// <summary>
/// The complete mapping from stream index to tree node. This buffer
/// includes pointers to DOWN, UP, and EOF nodes.
///
/// It is built upon ctor invocation. The elements are type Object
/// as we don't what the trees look like. Load upon first need of
/// the buffer so we can set token types of interest for reverseIndexing.
/// Slows us down a wee bit to do all of the if p==-1 testing everywhere though.
/// </summary>
FNodes: IList<IANTLRInterface>;
/// <summary>Pull nodes from which tree? </summary>
FRoot: IANTLRInterface;
/// <summary>IF this tree (root) was created from a token stream, track it</summary>
FTokens: ITokenStream;
/// <summary>What tree adaptor was used to build these trees</summary>
FAdaptor: ITreeAdaptor;
/// <summary>
/// Reuse same DOWN, UP navigation nodes unless this is true
/// </summary>
FUniqueNavigationNodes: Boolean;
/// <summary>
/// The index into the nodes list of the current node (next node
/// to consume). If -1, nodes array not filled yet.
/// </summary>
FP: Integer;
/// <summary>
/// Track the last mark() call result value for use in rewind().
/// </summary>
FLastMarker: Integer;
/// <summary>
/// Stack of indexes used for push/pop calls
/// </summary>
FCalls: IStackList<Integer>;
protected
{ IIntStream }
function GetSourceName: String; virtual;
procedure Consume; virtual;
function LA(I: Integer): Integer; virtual;
function LAChar(I: Integer): Char;
function Mark: Integer; virtual;
function Index: Integer; virtual;
procedure Rewind(const Marker: Integer); overload; virtual;
procedure Rewind; overload;
procedure Release(const Marker: Integer); virtual;
procedure Seek(const Index: Integer); virtual;
function Size: Integer; virtual;
protected
{ ITreeNodeStream }
function GetTreeSource: IANTLRInterface; virtual;
function GetTokenStream: ITokenStream; virtual;
function GetTreeAdaptor: ITreeAdaptor;
procedure SetHasUniqueNavigationNodes(const Value: Boolean);
function Get(const I: Integer): IANTLRInterface;
function LT(const K: Integer): IANTLRInterface;
function ToString(const Start, Stop: IANTLRInterface): String; reintroduce; overload;
procedure ReplaceChildren(const Parent: IANTLRInterface; const StartChildIndex,
StopChildIndex: Integer; const T: IANTLRInterface);
protected
{ ICommonTreeNodeStream }
function GetCurrentSymbol: IANTLRInterface; virtual;
procedure SetTokenStream(const Value: ITokenStream); virtual;
procedure SetTreeAdaptor(const Value: ITreeAdaptor);
function GetHasUniqueNavigationNodes: Boolean;
procedure FillBuffer(const T: IANTLRInterface); overload;
function LB(const K: Integer): IANTLRInterface;
procedure Push(const Index: Integer);
function Pop: Integer;
procedure Reset;
function ToTokenString(const Start, Stop: Integer): String;
strict protected
/// <summary>
/// Walk tree with depth-first-search and fill nodes buffer.
/// Don't do DOWN, UP nodes if its a list (t is isNil).
/// </summary>
procedure FillBuffer; overload;
/// <summary>
/// As we flatten the tree, we use UP, DOWN nodes to represent
/// the tree structure. When debugging we need unique nodes
/// so instantiate new ones when uniqueNavigationNodes is true.
/// </summary>
procedure AddNavigationNode(const TokenType: Integer);
/// <summary>
/// Returns the stream index for the spcified node in the range 0..n-1 or,
/// -1 if node not found.
/// </summary>
function GetNodeIndex(const Node: IANTLRInterface): Integer;
public
constructor Create; overload;
constructor Create(const ATree: IANTLRInterface); overload;
constructor Create(const AAdaptor: ITreeAdaptor;
const ATree: IANTLRInterface); overload;
constructor Create(const AAdaptor: ITreeAdaptor;
const ATree: IANTLRInterface; const AInitialBufferSize: Integer); overload;
function ToString: String; overload; override;
end;
TParseTree = class(TBaseTree, IParseTree)
strict private
FPayload: IANTLRInterface;
FHiddenTokens: IList<IToken>;
protected
{ ITree / IBaseTree }
function GetTokenType: Integer; override;
function GetText: String; override;
function GetTokenStartIndex: Integer; override;
procedure SetTokenStartIndex(const Value: Integer); override;
function GetTokenStopIndex: Integer; override;
procedure SetTokenStopIndex(const Value: Integer); override;
function DupNode: ITree; override;
protected
{ IParseTree }
function ToStringWithHiddenTokens: String;
function ToInputString: String;
procedure _ToStringLeaves(const Buf: TStringBuilder);
public
constructor Create(const ALabel: IANTLRInterface);
function ToString: String; override;
end;
TRewriteRuleElementStream = class abstract(TANTLRObject, IRewriteRuleElementStream)
private
/// <summary>
/// Cursor 0..n-1. If singleElement!=null, cursor is 0 until you next(),
/// which bumps it to 1 meaning no more elements.
/// </summary>
FCursor: Integer;
/// <summary>
/// Track single elements w/o creating a list. Upon 2nd add, alloc list
/// </summary>
FSingleElement: IANTLRInterface;
/// <summary>
/// The list of tokens or subtrees we are tracking
/// </summary>
FElements: IList<IANTLRInterface>;
/// <summary>
/// Tracks whether a node or subtree has been used in a stream
/// </summary>
/// <remarks>
/// Once a node or subtree has been used in a stream, it must be dup'd
/// from then on. Streams are reset after subrules so that the streams
/// can be reused in future subrules. So, reset must set a dirty bit.
/// If dirty, then next() always returns a dup.
/// </remarks>
FDirty: Boolean;
/// <summary>
/// The element or stream description; usually has name of the token or
/// rule reference that this list tracks. Can include rulename too, but
/// the exception would track that info.
/// </summary>
FElementDescription: String;
FAdaptor: ITreeAdaptor;
protected
{ IRewriteRuleElementStream }
function GetDescription: String;
procedure Add(const El: IANTLRInterface);
procedure Reset; virtual;
function HasNext: Boolean;
function NextTree: IANTLRInterface; virtual;
function NextNode: IANTLRInterface; virtual; abstract;
function Size: Integer;
strict protected
/// <summary>
/// Do the work of getting the next element, making sure that
/// it's a tree node or subtree.
/// </summary>
/// <remarks>
/// Deal with the optimization of single-element list versus
/// list of size > 1. Throw an exception if the stream is
/// empty or we're out of elements and size>1.
/// </remarks>
function _Next: IANTLRInterface;
/// <summary>
/// Ensure stream emits trees; tokens must be converted to AST nodes.
/// AST nodes can be passed through unmolested.
/// </summary>
function ToTree(const El: IANTLRInterface): IANTLRInterface; virtual;
public
constructor Create(const AAdaptor: ITreeAdaptor;
const AElementDescription: String); overload;
/// <summary>
/// Create a stream with one element
/// </summary>
constructor Create(const AAdaptor: ITreeAdaptor;
const AElementDescription: String; const AOneElement: IANTLRInterface); overload;
/// <summary>
/// Create a stream, but feed off an existing list
/// </summary>
constructor Create(const AAdaptor: ITreeAdaptor;
const AElementDescription: String; const AElements: IList<IANTLRInterface>); overload;
end;
TRewriteRuleNodeStream = class(TRewriteRuleElementStream, IRewriteRuleNodeStream)
protected
{ IRewriteRuleElementStream }
function NextNode: IANTLRInterface; override;
function ToTree(const El: IANTLRInterface): IANTLRInterface; override;
end;
TRewriteRuleSubtreeStream = class(TRewriteRuleElementStream, IRewriteRuleSubtreeStream)
public
type
/// <summary>
/// This delegate is used to allow the outfactoring of some common code.
/// </summary>
/// <param name="o">The to be processed object</param>
TProcessHandler = function(const O: IANTLRInterface): IANTLRInterface of Object;
strict private
/// <summary>
/// This method has the common code of two other methods, which differed in only one
/// function call.
/// </summary>
/// <param name="ph">The delegate, which has the chosen function</param>
/// <returns>The required object</returns>
function FetchObject(const PH: TProcessHandler): IANTLRInterface;
function DupNode(const O: IANTLRInterface): IANTLRInterface;
/// <summary>
/// Tests, if the to be returned object requires duplication
/// </summary>
/// <returns><code>true</code>, if positive, <code>false</code>, if negative.</returns>
function RequiresDuplication: Boolean;
/// <summary>
/// When constructing trees, sometimes we need to dup a token or AST
/// subtree. Dup'ing a token means just creating another AST node
/// around it. For trees, you must call the adaptor.dupTree()
/// unless the element is for a tree root; then it must be a node dup
/// </summary>
function Dup(const O: IANTLRInterface): IANTLRInterface;
protected
{ IRewriteRuleElementStream }
function NextNode: IANTLRInterface; override;
function NextTree: IANTLRInterface; override;
end;
TRewriteRuleTokenStream = class(TRewriteRuleElementStream, IRewriteRuleTokenStream)
protected
{ IRewriteRuleElementStream }
function NextNode: IANTLRInterface; override;
function NextToken: IToken;
function ToTree(const El: IANTLRInterface): IANTLRInterface; override;
end;
TTreeParser = class(TBaseRecognizer, ITreeParser)
public
const
DOWN = TToken.DOWN;
UP = TToken.UP;
strict private
FInput: ITreeNodeStream;
strict protected
property Input: ITreeNodeStream read FInput;
protected
{ IBaseRecognizer }
function GetSourceName: String; override;
procedure Reset; override;
procedure MatchAny(const Input: IIntStream); override;
function GetInput: IIntStream; override;
function GetErrorHeader(const E: ERecognitionException): String; override;
function GetErrorMessage(const E: ERecognitionException;
const TokenNames: TStringArray): String; override;
protected
{ ITreeParser }
function GetTreeNodeStream: ITreeNodeStream; virtual;
procedure SetTreeNodeStream(const Value: ITreeNodeStream); virtual;
procedure TraceIn(const RuleName: String; const RuleIndex: Integer); reintroduce; overload; virtual;
procedure TraceOut(const RuleName: String; const RuleIndex: Integer); reintroduce; overload; virtual;
strict protected
function GetCurrentInputSymbol(const Input: IIntStream): IANTLRInterface; override;
function GetMissingSymbol(const Input: IIntStream;
const E: ERecognitionException; const ExpectedTokenType: Integer;
const Follow: IBitSet): IANTLRInterface; override;
procedure Mismatch(const Input: IIntStream; const TokenType: Integer;
const Follow: IBitSet); override;
public
constructor Create(const AInput: ITreeNodeStream); overload;
constructor Create(const AInput: ITreeNodeStream;
const AState: IRecognizerSharedState); overload;
end;
TTreePatternLexer = class(TANTLRObject, ITreePatternLexer)
public
const
EOF = -1;
START = 1;
STOP = 2;
ID = 3;
ARG = 4;
PERCENT = 5;
COLON = 6;
DOT = 7;
strict private
/// <summary>The tree pattern to lex like "(A B C)"</summary>
FPattern: String;
/// <summary>Index into input string</summary>
FP: Integer;
/// <summary>Current char</summary>
FC: Integer;
/// <summary>How long is the pattern in char?</summary>
FN: Integer;
/// <summary>
/// Set when token type is ID or ARG (name mimics Java's StreamTokenizer)
/// </summary>
FSVal: TStringBuilder;
FError: Boolean;
protected
{ ITreePatternLexer }
function NextToken: Integer;
function SVal: String;
strict protected
procedure Consume;
public
constructor Create; overload;
constructor Create(const APattern: String); overload;
destructor Destroy; override;
end;
TTreeWizard = class(TANTLRObject, ITreeWizard)
strict private
FAdaptor: ITreeAdaptor;
FTokenNameToTypeMap: IDictionary<String, Integer>;
public
type
/// <summary>
/// When using %label:TOKENNAME in a tree for parse(), we must track the label.
/// </summary>
ITreePattern = interface(ICommonTree)
['{893C6B4E-8474-4A1E-BEAA-8B704868401B}']
{ Property accessors }
function GetHasTextArg: Boolean;
procedure SetHasTextArg(const Value: Boolean);
function GetTokenLabel: String;
procedure SetTokenLabel(const Value: String);
{ Properties }
property HasTextArg: Boolean read GetHasTextArg write SetHasTextArg;
property TokenLabel: String read GetTokenLabel write SetTokenLabel;
end;
IWildcardTreePattern = interface(ITreePattern)
['{4778789A-5EAB-47E3-A05B-7F35CD87ECE4}']
end;
type
TVisitor = class abstract(TANTLRObject, IContextVisitor)
protected
{ IContextVisitor }
procedure Visit(const T, Parent: IANTLRInterface; const ChildIndex: Integer;
const Labels: IDictionary<String, IANTLRInterface>); overload;
strict protected
procedure Visit(const T: IANTLRInterface); overload; virtual; abstract;
end;
TTreePattern = class(TCommonTree, ITreePattern)
strict private
FLabel: String;
FHasTextArg: Boolean;
protected
{ ITreePattern }
function GetHasTextArg: Boolean;
procedure SetHasTextArg(const Value: Boolean);
function GetTokenLabel: String;
procedure SetTokenLabel(const Value: String);
public
function ToString: String; override;
end;
TWildcardTreePattern = class(TTreePattern, IWildcardTreePattern)
end;
/// <summary>
/// This adaptor creates TreePattern objects for use during scan()
/// </summary>
TTreePatternTreeAdaptor = class(TCommonTreeAdaptor)
protected
{ ITreeAdaptor }
function CreateNode(const Payload: IToken): IANTLRInterface; overload; override;
end;
strict private
type
TRecordAllElementsVisitor = class sealed(TVisitor)
strict private
FList: IList<IANTLRInterface>;
strict protected
procedure Visit(const T: IANTLRInterface); override;
public
constructor Create(const AList: IList<IANTLRInterface>);
end;
type
TPatternMatchingContextVisitor = class sealed(TANTLRObject, IContextVisitor)
strict private
FOwner: TTreeWizard;
FPattern: ITreePattern;
FList: IList<IANTLRInterface>;
protected
{ IContextVisitor }
procedure Visit(const T, Parent: IANTLRInterface; const ChildIndex: Integer;
const Labels: IDictionary<String, IANTLRInterface>); overload;
public
constructor Create(const AOwner: TTreeWizard; const APattern: ITreePattern;
const AList: IList<IANTLRInterface>);
end;
type
TInvokeVisitorOnPatternMatchContextVisitor = class sealed(TANTLRObject, IContextVisitor)
strict private
FOwner: TTreeWizard;
FPattern: ITreePattern;
FVisitor: IContextVisitor;
FLabels: IDictionary<String, IANTLRInterface>;
protected
{ IContextVisitor }
procedure Visit(const T, Parent: IANTLRInterface; const ChildIndex: Integer;
const UnusedLabels: IDictionary<String, IANTLRInterface>); overload;
public
constructor Create(const AOwner: TTreeWizard; const APattern: ITreePattern;
const AVisitor: IContextVisitor);
end;
protected
{ ITreeWizard }
function ComputeTokenTypes(const TokenNames: TStringArray): IDictionary<String, Integer>;
function GetTokenType(const TokenName: String): Integer;
function Index(const T: IANTLRInterface): IDictionary<Integer, IList<IANTLRInterface>>;
function Find(const T: IANTLRInterface; const TokenType: Integer): IList<IANTLRInterface>; overload;
function Find(const T: IANTLRInterface; const Pattern: String): IList<IANTLRInterface>; overload;
function FindFirst(const T: IANTLRInterface; const TokenType: Integer): IANTLRInterface; overload;
function FindFirst(const T: IANTLRInterface; const Pattern: String): IANTLRInterface; overload;
procedure Visit(const T: IANTLRInterface; const TokenType: Integer;
const Visitor: IContextVisitor); overload;
procedure Visit(const T: IANTLRInterface; const Pattern: String;
const Visitor: IContextVisitor); overload;
function Parse(const T: IANTLRInterface; const Pattern: String;
const Labels: IDictionary<String, IANTLRInterface>): Boolean; overload;
function Parse(const T: IANTLRInterface; const Pattern: String): Boolean; overload;
function CreateTreeOrNode(const Pattern: String): IANTLRInterface;
function Equals(const T1, T2: IANTLRInterface): Boolean; reintroduce; overload;
function Equals(const T1, T2: IANTLRInterface;
const Adaptor: ITreeAdaptor): Boolean; reintroduce; overload;
strict protected
function _Parse(const T1: IANTLRInterface; const T2: ITreePattern;
const Labels: IDictionary<String, IANTLRInterface>): Boolean;
/// <summary>Do the work for index</summary>
procedure _Index(const T: IANTLRInterface;
const M: IDictionary<Integer, IList<IANTLRInterface>>);
/// <summary>Do the recursive work for visit</summary>
procedure _Visit(const T, Parent: IANTLRInterface; const ChildIndex,
TokenType: Integer; const Visitor: IContextVisitor);
class function _Equals(const T1, T2: IANTLRInterface;
const Adaptor: ITreeAdaptor): Boolean; static;
public
constructor Create(const AAdaptor: ITreeAdaptor); overload;
constructor Create(const AAdaptor: ITreeAdaptor;
const ATokenNameToTypeMap: IDictionary<String, Integer>); overload;
constructor Create(const AAdaptor: ITreeAdaptor;
const TokenNames: TStringArray); overload;
constructor Create(const TokenNames: TStringArray); overload;
end;
TTreePatternParser = class(TANTLRObject, ITreePatternParser)
strict private
FTokenizer: ITreePatternLexer;
FTokenType: Integer;
FWizard: ITreeWizard;
FAdaptor: ITreeAdaptor;
protected
{ ITreePatternParser }
function Pattern: IANTLRInterface;
function ParseTree: IANTLRInterface;
function ParseNode: IANTLRInterface;
public
constructor Create(const ATokenizer: ITreePatternLexer;
const AWizard: ITreeWizard; const AAdaptor: ITreeAdaptor);
end;
TTreeRuleReturnScope = class(TRuleReturnScope, ITreeRuleReturnScope)
strict private
/// <summary>First node or root node of tree matched for this rule.</summary>
FStart: IANTLRInterface;
protected
{ IRuleReturnScope }
function GetStart: IANTLRInterface; override;
procedure SetStart(const Value: IANTLRInterface); override;
end;
TUnBufferedTreeNodeStream = class(TANTLRObject, IUnBufferedTreeNodeStream, ITreeNodeStream)
public
const
INITIAL_LOOKAHEAD_BUFFER_SIZE = 5;
strict protected
type
/// <summary>
/// When walking ahead with cyclic DFA or for syntactic predicates,
/// we need to record the state of the tree node stream. This
/// class wraps up the current state of the UnBufferedTreeNodeStream.
/// Calling Mark() will push another of these on the markers stack.
/// </summary>
ITreeWalkState = interface(IANTLRInterface)
['{506D1014-53CF-4B9D-BE0E-1666E9C22091}']
{ Property accessors }
function GetCurrentChildIndex: Integer;
procedure SetCurrentChildIndex(const Value: Integer);
function GetAbsoluteNodeIndex: Integer;
procedure SetAbsoluteNodeIndex(const Value: Integer);
function GetCurrentNode: IANTLRInterface;
procedure SetCurrentNode(const Value: IANTLRInterface);
function GetPreviousNode: IANTLRInterface;
procedure SetPreviousNode(const Value: IANTLRInterface);
function GetNodeStackSize: Integer;
procedure SetNodeStackSize(const Value: Integer);
function GetIndexStackSize: integer;
procedure SetIndexStackSize(const Value: integer);
function GetLookAhead: TANTLRInterfaceArray;
procedure SetLookAhead(const Value: TANTLRInterfaceArray);
{ Properties }
property CurrentChildIndex: Integer read GetCurrentChildIndex write SetCurrentChildIndex;
property AbsoluteNodeIndex: Integer read GetAbsoluteNodeIndex write SetAbsoluteNodeIndex;
property CurrentNode: IANTLRInterface read GetCurrentNode write SetCurrentNode;
property PreviousNode: IANTLRInterface read GetPreviousNode write SetPreviousNode;
///<summary>Record state of the nodeStack</summary>
property NodeStackSize: Integer read GetNodeStackSize write SetNodeStackSize;
///<summary>Record state of the indexStack</summary>
property IndexStackSize: integer read GetIndexStackSize write SetIndexStackSize;
property LookAhead: TANTLRInterfaceArray read GetLookAhead write SetLookAhead;
end;
TTreeWalkState = class(TANTLRObject, ITreeWalkState)
strict private
FCurrentChildIndex: Integer;
FAbsoluteNodeIndex: Integer;
FCurrentNode: IANTLRInterface;
FPreviousNode: IANTLRInterface;
///<summary>Record state of the nodeStack</summary>
FNodeStackSize: Integer;
///<summary>Record state of the indexStack</summary>
FIndexStackSize: integer;
FLookAhead: TANTLRInterfaceArray;
protected
{ ITreeWalkState }
function GetCurrentChildIndex: Integer;
procedure SetCurrentChildIndex(const Value: Integer);
function GetAbsoluteNodeIndex: Integer;
procedure SetAbsoluteNodeIndex(const Value: Integer);
function GetCurrentNode: IANTLRInterface;
procedure SetCurrentNode(const Value: IANTLRInterface);
function GetPreviousNode: IANTLRInterface;
procedure SetPreviousNode(const Value: IANTLRInterface);
function GetNodeStackSize: Integer;
procedure SetNodeStackSize(const Value: Integer);
function GetIndexStackSize: integer;
procedure SetIndexStackSize(const Value: integer);
function GetLookAhead: TANTLRInterfaceArray;
procedure SetLookAhead(const Value: TANTLRInterfaceArray);
end;
strict private
/// <summary>Reuse same DOWN, UP navigation nodes unless this is true</summary>
FUniqueNavigationNodes: Boolean;
/// <summary>Pull nodes from which tree? </summary>
FRoot: IANTLRInterface;
/// <summary>IF this tree (root) was created from a token stream, track it.</summary>
FTokens: ITokenStream;
/// <summary>What tree adaptor was used to build these trees</summary>
FAdaptor: ITreeAdaptor;
/// <summary>
/// As we walk down the nodes, we must track parent nodes so we know
/// where to go after walking the last child of a node. When visiting
/// a child, push current node and current index.
/// </summary>
FNodeStack: IStackList<IANTLRInterface>;
/// <summary>
/// Track which child index you are visiting for each node we push.
/// TODO: pretty inefficient...use int[] when you have time
/// </summary>
FIndexStack: IStackList<Integer>;
/// <summary>Which node are we currently visiting? </summary>
FCurrentNode: IANTLRInterface;
/// <summary>Which node did we visit last? Used for LT(-1) calls. </summary>
FPreviousNode: IANTLRInterface;
/// <summary>
/// Which child are we currently visiting? If -1 we have not visited
/// this node yet; next Consume() request will set currentIndex to 0.
/// </summary>
FCurrentChildIndex: Integer;
/// <summary>
/// What node index did we just consume? i=0..n-1 for n node trees.
/// IntStream.next is hence 1 + this value. Size will be same.
/// </summary>
FAbsoluteNodeIndex: Integer;
/// <summary>
/// Buffer tree node stream for use with LT(i). This list grows
/// to fit new lookahead depths, but Consume() wraps like a circular
/// buffer.
/// </summary>
FLookahead: TANTLRInterfaceArray;
/// <summary>lookahead[head] is the first symbol of lookahead, LT(1). </summary>
FHead: Integer;
/// <summary>
/// Add new lookahead at lookahead[tail]. tail wraps around at the
/// end of the lookahead buffer so tail could be less than head.
/// </summary>
FTail: Integer;
/// <summary>
/// Calls to Mark() may be nested so we have to track a stack of them.
/// The marker is an index into this stack. This is a List<TreeWalkState>.
/// Indexed from 1..markDepth. A null is kept at index 0. It is created
/// upon first call to Mark().
/// </summary>
FMarkers: IList<ITreeWalkState>;
///<summary>
/// tracks how deep Mark() calls are nested
/// </summary>
FMarkDepth: Integer;
///<summary>
/// Track the last Mark() call result value for use in Rewind().
/// </summary>
FLastMarker: Integer;
// navigation nodes
FDown: IANTLRInterface;
FUp: IANTLRInterface;
FEof: IANTLRInterface;
FCurrentEnumerationNode: ITree;
protected
{ IIntStream }
function GetSourceName: String;
procedure Consume; virtual;
function LA(I: Integer): Integer; virtual;
function LAChar(I: Integer): Char;
function Mark: Integer; virtual;
function Index: Integer; virtual;
procedure Rewind(const Marker: Integer); overload; virtual;
procedure Rewind; overload;
procedure Release(const Marker: Integer); virtual;
procedure Seek(const Index: Integer); virtual;
function Size: Integer; virtual;
protected
{ ITreeNodeStream }
function GetTreeSource: IANTLRInterface; virtual;
function GetTokenStream: ITokenStream;
function GetTreeAdaptor: ITreeAdaptor;
function Get(const I: Integer): IANTLRInterface; virtual;
function LT(const K: Integer): IANTLRInterface; virtual;
function ToString(const Start, Stop: IANTLRInterface): String; reintroduce; overload; virtual;
procedure ReplaceChildren(const Parent: IANTLRInterface; const StartChildIndex,
StopChildIndex: Integer; const T: IANTLRInterface);
protected
{ IUnBufferedTreeNodeStream }
function GetHasUniqueNavigationNodes: Boolean;
procedure SetHasUniqueNavigationNodes(const Value: Boolean);
function GetCurrent: IANTLRInterface; virtual;
procedure SetTokenStream(const Value: ITokenStream);
procedure Reset; virtual;
/// <summary>
/// Navigates to the next node found during a depth-first walk of root.
/// Also, adds these nodes and DOWN/UP imaginary nodes into the lokoahead
/// buffer as a side-effect. Normally side-effects are bad, but because
/// we can Emit many tokens for every MoveNext() call, it's pretty hard to
/// use a single return value for that. We must add these tokens to
/// the lookahead buffer.
///
/// This routine does *not* cause the 'Current' property to ever return the
/// DOWN/UP nodes; those are only returned by the LT() method.
///
/// Ugh. This mechanism is much more complicated than a recursive
/// solution, but it's the only way to provide nodes on-demand instead
/// of walking once completely through and buffering up the nodes. :(
/// </summary>
function MoveNext: Boolean; virtual;
strict protected
/// <summary>Make sure we have at least k symbols in lookahead buffer </summary>
procedure Fill(const K: Integer); virtual;
function LookaheadSize: Integer;
/// <summary>
/// Add a node to the lookahead buffer. Add at lookahead[tail].
/// If you tail+1 == head, then we must create a bigger buffer
/// and copy all the nodes over plus reset head, tail. After
/// this method, LT(1) will be lookahead[0].
/// </summary>
procedure AddLookahead(const Node: IANTLRInterface); virtual;
procedure ToStringWork(const P, Stop: IANTLRInterface;
const Buf: TStringBuilder); virtual;
function HandleRootNode: IANTLRInterface; virtual;
function VisitChild(const Child: Integer): IANTLRInterface; virtual;
/// <summary>
/// Walk upwards looking for a node with more children to walk.
/// </summary>
procedure WalkBackToMostRecentNodeWithUnvisitedChildren; virtual;
/// <summary>
/// As we flatten the tree, we use UP, DOWN nodes to represent
/// the tree structure. When debugging we need unique nodes
/// so instantiate new ones when uniqueNavigationNodes is true.
/// </summary>
procedure AddNavigationNode(const TokenType: Integer); virtual;
public
constructor Create; overload;
constructor Create(const ATree: IANTLRInterface); overload;
constructor Create(const AAdaptor: ITreeAdaptor; const ATree: IANTLRInterface); overload;
function ToString: String; overload; override;
end;
{ These functions return X or, if X = nil, an empty default instance }
function Def(const X: ICommonTree): ICommonTree; overload;
implementation
uses
Math;
{ TTree }
class procedure TTree.Initialize;
begin
FINVALID_NODE := TCommonTree.Create(TToken.INVALID_TOKEN);
end;
{ TBaseTree }
constructor TBaseTree.Create;
begin
inherited;
end;
procedure TBaseTree.AddChild(const T: ITree);
var
ChildTree: IBaseTree;
C: IBaseTree;
begin
if (T = nil) then
Exit;
ChildTree := T as IBaseTree;
if ChildTree.IsNil then // t is an empty node possibly with children
begin
if Assigned(FChildren) and SameObj(FChildren, ChildTree.Children) then
raise EInvalidOperation.Create('Attempt to add child list to itself');
// just add all of childTree's children to this
if Assigned(ChildTree.Children) then
begin
if Assigned(FChildren) then // must copy, this has children already
begin
for C in ChildTree.Children do
begin
FChildren.Add(C);
// handle double-link stuff for each child of nil root
C.Parent := Self;
C.ChildIndex := FChildren.Count - 1;
end;
end
else begin
// no children for this but t has children; just set pointer
// call general freshener routine
FChildren := ChildTree.Children;
FreshenParentAndChildIndexes;
end;
end;
end
else
begin
// child is not nil (don't care about children)
if (FChildren = nil) then
begin
FChildren := CreateChildrenList; // create children list on demand
end;
FChildren.Add(ChildTree);
ChildTree.Parent := Self;
ChildTree.ChildIndex := FChildren.Count - 1;
end;
end;
procedure TBaseTree.AddChildren(const Kids: IList<IBaseTree>);
var
T: IBaseTree;
begin
for T in Kids do
AddChild(T);
end;
constructor TBaseTree.Create(const ANode: ITree);
begin
Create;
// No default implementation
end;
function TBaseTree.CreateChildrenList: IList<IBaseTree>;
begin
Result := TList<IBaseTree>.Create;
end;
function TBaseTree.DeleteChild(const I: Integer): IANTLRInterface;
begin
if (FChildren = nil) then
Result := nil
else
begin
Result := FChildren[I];
FChildren.Delete(I);
// walk rest and decrement their child indexes
FreshenParentAndChildIndexes(I);
end;
end;
procedure TBaseTree.FreshenParentAndChildIndexes(const Offset: Integer);
var
N, C: Integer;
Child: ITree;
begin
N := GetChildCount;
for C := Offset to N - 1 do
begin
Child := GetChild(C);
Child.ChildIndex := C;
Child.Parent := Self;
end;
end;
procedure TBaseTree.FreshenParentAndChildIndexes;
begin
FreshenParentAndChildIndexes(0);
end;
function TBaseTree.GetCharPositionInLine: Integer;
begin
Result := 0;
end;
function TBaseTree.GetChild(const I: Integer): ITree;
begin
if (FChildren = nil) or (I >= FChildren.Count) then
Result := nil
else
Result := FChildren[I];
end;
function TBaseTree.GetChildCount: Integer;
begin
if Assigned(FChildren) then
Result := FChildren.Count
else
Result := 0;
end;
function TBaseTree.GetChildIndex: Integer;
begin
// No default implementation
Result := 0;
end;
function TBaseTree.GetChildren: IList<IBaseTree>;
begin
Result := FChildren;
end;
function TBaseTree.GetIsNil: Boolean;
begin
Result := False;
end;
function TBaseTree.GetLine: Integer;
begin
Result := 0;
end;
function TBaseTree.GetParent: ITree;
begin
// No default implementation
Result := nil;
end;
procedure TBaseTree.ReplaceChildren(const StartChildIndex,
StopChildIndex: Integer; const T: IANTLRInterface);
var
ReplacingHowMany, ReplacingWithHowMany, NumNewChildren, Delta, I, J: Integer;
IndexToDelete, C, ReplacedSoFar: Integer;
NewTree, Killed: IBaseTree;
NewChildren: IList<IBaseTree>;
Child: IBaseTree;
begin
if (FChildren = nil) then
raise EArgumentException.Create('indexes invalid; no children in list');
ReplacingHowMany := StopChildIndex - StartChildIndex + 1;
NewTree := T as IBaseTree;
// normalize to a list of children to add: newChildren
if (NewTree.IsNil) then
NewChildren := NewTree.Children
else
begin
NewChildren := TList<IBaseTree>.Create;
NewChildren.Add(NewTree);
end;
ReplacingWithHowMany := NewChildren.Count;
NumNewChildren := NewChildren.Count;
Delta := ReplacingHowMany - ReplacingWithHowMany;
// if same number of nodes, do direct replace
if (Delta = 0) then
begin
J := 0; // index into new children
for I := StartChildIndex to StopChildIndex do
begin
Child := NewChildren[J];
FChildren[I] := Child;
Child.Parent := Self;
Child.ChildIndex := I;
Inc(J);
end;
end
else
if (Delta > 0) then
begin
// fewer new nodes than there were
// set children and then delete extra
for J := 0 to NumNewChildren - 1 do
FChildren[StartChildIndex + J] := NewChildren[J];
IndexToDelete := StartChildIndex + NumNewChildren;
for C := IndexToDelete to StopChildIndex do
begin
// delete same index, shifting everybody down each time
Killed := FChildren[IndexToDelete];
FChildren.Delete(IndexToDelete);
end;
FreshenParentAndChildIndexes(StartChildIndex);
end
else
begin
// more new nodes than were there before
// fill in as many children as we can (replacingHowMany) w/o moving data
ReplacedSoFar := 0;
while (ReplacedSoFar < ReplacingHowMany) do
begin
FChildren[StartChildIndex + ReplacedSoFar] := NewChildren[ReplacedSoFar];
Inc(ReplacedSoFar);
end;
// replacedSoFar has correct index for children to add
while (ReplacedSoFar < ReplacingWithHowMany) do
begin
FChildren.Insert(StartChildIndex + ReplacedSoFar,NewChildren[ReplacedSoFar]);
Inc(ReplacedSoFar);
end;
FreshenParentAndChildIndexes(StartChildIndex);
end;
end;
procedure TBaseTree.SanityCheckParentAndChildIndexes;
begin
SanityCheckParentAndChildIndexes(nil, -1);
end;
procedure TBaseTree.SanityCheckParentAndChildIndexes(const Parent: ITree;
const I: Integer);
var
N, C: Integer;
Child: ICommonTree;
begin
if not SameObj(Parent, GetParent) then
raise EArgumentException.Create('parents don''t match; expected '
+ Parent.ToString + ' found ' + GetParent.ToString);
if (I <> GetChildIndex) then
raise EArgumentException.Create('child indexes don''t match; expected '
+ IntToStr(I) + ' found ' + IntToStr(GetChildIndex));
N := GetChildCount;
for C := 0 to N - 1 do
begin
Child := GetChild(C) as ICommonTree;
Child.SanityCheckParentAndChildIndexes(Self, C);
end;
end;
procedure TBaseTree.SetChild(const I: Integer; const T: ITree);
begin
if (T = nil) then
Exit;
if T.IsNil then
raise EArgumentException.Create('Cannot set single child to a list');
if (FChildren = nil) then
begin
FChildren := CreateChildrenList;
end;
FChildren[I] := T as IBaseTree;
T.Parent := Self;
T.ChildIndex := I;
end;
procedure TBaseTree.SetChildIndex(const Value: Integer);
begin
// No default implementation
end;
procedure TBaseTree.SetParent(const Value: ITree);
begin
// No default implementation
end;
function TBaseTree.ToStringTree: String;
var
Buf: TStringBuilder;
I: Integer;
T: IBaseTree;
begin
if (FChildren = nil) or (FChildren.Count = 0) then
Result := ToString
else
begin
Buf := TStringBuilder.Create;
try
if (not GetIsNil) then
begin
Buf.Append('(');
Buf.Append(ToString);
Buf.Append(' ');
end;
for I := 0 to FChildren.Count - 1 do
begin
T := FChildren[I];
if (I > 0) then
Buf.Append(' ');
Buf.Append(T.ToStringTree);
end;
if (not GetIsNil) then
Buf.Append(')');
Result := Buf.ToString;
finally
Buf.Free;
end;
end;
end;
{ TCommonTree }
constructor TCommonTree.Create;
begin
inherited;
FStartIndex := -1;
FStopIndex := -1;
FChildIndex := -1;
end;
constructor TCommonTree.Create(const ANode: ICommonTree);
begin
inherited Create(ANode);
FToken := ANode.Token;
FStartIndex := ANode.StartIndex;
FStopIndex := ANode.StopIndex;
FChildIndex := -1;
end;
constructor TCommonTree.Create(const AToken: IToken);
begin
Create;
FToken := AToken;
end;
function TCommonTree.DupNode: ITree;
begin
Result := TCommonTree.Create(Self) as ICommonTree;
end;
function TCommonTree.GetCharPositionInLine: Integer;
begin
if (FToken = nil) or (FToken.CharPositionInLine = -1) then
begin
if (GetChildCount > 0) then
Result := GetChild(0).CharPositionInLine
else
Result := 0;
end
else
Result := FToken.CharPositionInLine;
end;
function TCommonTree.GetChildIndex: Integer;
begin
Result := FChildIndex;
end;
function TCommonTree.GetIsNil: Boolean;
begin
Result := (FToken = nil);
end;
function TCommonTree.GetLine: Integer;
begin
if (FToken = nil) or (FToken.Line = 0) then
begin
if (GetChildCount > 0) then
Result := GetChild(0).Line
else
Result := 0
end
else
Result := FToken.Line;
end;
function TCommonTree.GetParent: ITree;
begin
Result := ITree(FParent);
end;
function TCommonTree.GetStartIndex: Integer;
begin
Result := FStartIndex;
end;
function TCommonTree.GetStopIndex: Integer;
begin
Result := FStopIndex;
end;
function TCommonTree.GetText: String;
begin
if (FToken = nil) then
Result := ''
else
Result := FToken.Text;
end;
function TCommonTree.GetToken: IToken;
begin
Result := FToken;
end;
function TCommonTree.GetTokenStartIndex: Integer;
begin
if (FStartIndex = -1) and (FToken <> nil) then
Result := FToken.TokenIndex
else
Result := FStartIndex;
end;
function TCommonTree.GetTokenStopIndex: Integer;
begin
if (FStopIndex = -1) and (FToken <> nil) then
Result := FToken.TokenIndex
else
Result := FStopIndex;
end;
function TCommonTree.GetTokenType: Integer;
begin
if (FToken = nil) then
Result := TToken.INVALID_TOKEN_TYPE
else
Result := FToken.TokenType;
end;
procedure TCommonTree.SetChildIndex(const Value: Integer);
begin
FChildIndex := Value;
end;
procedure TCommonTree.SetParent(const Value: ITree);
begin
FParent := Pointer(Value as ICommonTree);
end;
procedure TCommonTree.SetStartIndex(const Value: Integer);
begin
FStartIndex := Value;
end;
procedure TCommonTree.SetStopIndex(const Value: Integer);
begin
FStopIndex := Value;
end;
procedure TCommonTree.SetTokenStartIndex(const Value: Integer);
begin
FStartIndex := Value;
end;
procedure TCommonTree.SetTokenStopIndex(const Value: Integer);
begin
FStopIndex := Value;
end;
function TCommonTree.ToString: String;
begin
if (GetIsNil) then
Result := 'nil'
else
if (GetTokenType = TToken.INVALID_TOKEN_TYPE) then
Result := '<errornode>'
else
if (FToken = nil) then
Result := ''
else
Result := FToken.Text;
end;
{ TCommonErrorNode }
constructor TCommonErrorNode.Create(const AInput: ITokenStream; const AStart,
AStop: IToken; const AException: ERecognitionException);
begin
inherited Create;
if (AStop = nil) or ((AStop.TokenIndex < AStart.TokenIndex)
and (AStop.TokenType <> TToken.EOF))
then
// sometimes resync does not consume a token (when LT(1) is
// in follow set). So, stop will be 1 to left to start. adjust.
// Also handle case where start is the first token and no token
// is consumed during recovery; LT(-1) will return null.
FStop := AStart
else
FStop := AStop;
FInput := AInput;
FStart := AStart;
FTrappedException := AException;
end;
function TCommonErrorNode.GetIsNil: Boolean;
begin
Result := False;
end;
function TCommonErrorNode.GetText: String;
var
I, J: Integer;
begin
I := FStart.TokenIndex;
if (FStop.TokenType = TToken.EOF) then
J := (FInput as ITokenStream).Size
else
J := FStop.TokenIndex;
Result := (FInput as ITokenStream).ToString(I, J);
end;
function TCommonErrorNode.GetTokenType: Integer;
begin
Result := TToken.INVALID_TOKEN_TYPE;
end;
function TCommonErrorNode.ToString: String;
begin
if (FTrappedException is EMissingTokenException) then
Result := '<missing type: '
+ IntToStr(EMissingTokenException(FTrappedException).MissingType) + '>'
else
if (FTrappedException is EUnwantedTokenException) then
Result := '<extraneous: '
+ EUnwantedTokenException(FTrappedException).UnexpectedToken.ToString
+ ', resync=' + GetText + '>'
else
if (FTrappedException is EMismatchedTokenException) then
Result := '<mismatched token: ' + FTrappedException.Token.ToString
+ ', resync=' + GetText + '>'
else
if (FTrappedException is ENoViableAltException) then
Result := '<unexpected: ' + FTrappedException.Token.ToString
+ ', resync=' + GetText + '>'
else
Result := '<error: ' + GetText + '>';
end;
{ TBaseTreeAdaptor }
procedure TBaseTreeAdaptor.AddChild(const T, Child: IANTLRInterface);
begin
if Assigned(T) and Assigned(Child) then
(T as ITree).AddChild(Child as ITree);
end;
function TBaseTreeAdaptor.BecomeRoot(const NewRoot,
OldRoot: IANTLRInterface): IANTLRInterface;
var
NewRootTree, OldRootTree: ITree;
NC: Integer;
begin
NewRootTree := NewRoot as ITree;
OldRootTree := OldRoot as ITree;
if (OldRoot = nil) then
Result := NewRoot
else
begin
// handle ^(nil real-node)
if (NewRootTree.IsNil) then
begin
NC := NewRootTree.ChildCount;
if (NC = 1) then
NewRootTree := NewRootTree.GetChild(0)
else
if (NC > 1) then
raise Exception.Create('more than one node as root');
end;
// add oldRoot to newRoot; AddChild takes care of case where oldRoot
// is a flat list (i.e., nil-rooted tree). All children of oldRoot
// are added to newRoot.
NewRootTree.AddChild(OldRootTree);
Result := NewRootTree;
end;
end;
function TBaseTreeAdaptor.BecomeRoot(const NewRoot: IToken;
const OldRoot: IANTLRInterface): IANTLRInterface;
begin
Result := BecomeRoot(CreateNode(NewRoot), OldRoot);
end;
function TBaseTreeAdaptor.CreateNode(const TokenType: Integer;
const FromToken: IToken): IANTLRInterface;
var
Token: IToken;
begin
Token := CreateToken(FromToken);
Token.TokenType := TokenType;
Result := CreateNode(Token);
end;
function TBaseTreeAdaptor.CreateNode(const TokenType: Integer;
const Text: String): IANTLRInterface;
var
Token: IToken;
begin
Token := CreateToken(TokenType, Text);
Result := CreateNode(Token);
end;
function TBaseTreeAdaptor.CreateNode(const TokenType: Integer;
const FromToken: IToken; const Text: String): IANTLRInterface;
var
Token: IToken;
begin
Token := CreateToken(FromToken);
Token.TokenType := TokenType;
Token.Text := Text;
Result := CreateNode(Token);
end;
constructor TBaseTreeAdaptor.Create;
begin
inherited Create;
FUniqueNodeID := 1;
end;
function TBaseTreeAdaptor.DeleteChild(const T: IANTLRInterface;
const I: Integer): IANTLRInterface;
begin
Result := (T as ITree).DeleteChild(I);
end;
function TBaseTreeAdaptor.DupTree(const T,
Parent: IANTLRInterface): IANTLRInterface;
var
I, N: Integer;
Child, NewSubTree: IANTLRInterface;
begin
if (T = nil) then
Result := nil
else
begin
Result := DupNode(T);
// ensure new subtree root has parent/child index set
SetChildIdex(Result, GetChildIndex(T));
SetParent(Result, Parent);
N := GetChildCount(T);
for I := 0 to N - 1 do
begin
Child := GetChild(T, I);
NewSubTree := DupTree(Child, T);
AddChild(Result, NewSubTree);
end;
end;
end;
function TBaseTreeAdaptor.DupTree(const Tree: IANTLRInterface): IANTLRInterface;
begin
Result := DupTree(Tree, nil);
end;
function TBaseTreeAdaptor.ErrorNode(const Input: ITokenStream; const Start,
Stop: IToken; const E: ERecognitionException): IANTLRInterface;
begin
Result := TCommonErrorNode.Create(Input, Start, Stop, E);
end;
function TBaseTreeAdaptor.GetChild(const T: IANTLRInterface;
const I: Integer): IANTLRInterface;
begin
Result := (T as ITree).GetChild(I);
end;
function TBaseTreeAdaptor.GetChildCount(const T: IANTLRInterface): Integer;
begin
Result := (T as ITree).ChildCount;
end;
function TBaseTreeAdaptor.GetNilNode: IANTLRInterface;
begin
Result := CreateNode(nil);
end;
function TBaseTreeAdaptor.GetNodeText(const T: IANTLRInterface): String;
begin
Result := (T as ITree).Text;
end;
function TBaseTreeAdaptor.GetNodeType(const T: IANTLRInterface): Integer;
begin
Result := 0;
end;
function TBaseTreeAdaptor.GetUniqueID(const Node: IANTLRInterface): Integer;
begin
if (FTreeToUniqueIDMap = nil) then
FTreeToUniqueIDMap := TDictionary<IANTLRInterface, Integer>.Create;
if (not FTreeToUniqueIDMap.TryGetValue(Node, Result)) then
begin
Result := FUniqueNodeID;
FTreeToUniqueIDMap[Node] := Result;
Inc(FUniqueNodeID);
end;
end;
function TBaseTreeAdaptor.IsNil(const Tree: IANTLRInterface): Boolean;
begin
Result := (Tree as ITree).IsNil;
end;
function TBaseTreeAdaptor.RulePostProcessing(
const Root: IANTLRInterface): IANTLRInterface;
var
R: ITree;
begin
R := Root as ITree;
if Assigned(R) and (R.IsNil) then
begin
if (R.ChildCount = 0) then
R := nil
else
if (R.ChildCount = 1) then
begin
R := R.GetChild(0);
// whoever invokes rule will set parent and child index
R.Parent := nil;
R.ChildIndex := -1;
end;
end;
Result := R;
end;
procedure TBaseTreeAdaptor.SetChild(const T: IANTLRInterface; const I: Integer;
const Child: IANTLRInterface);
begin
(T as ITree).SetChild(I, Child as ITree);
end;
procedure TBaseTreeAdaptor.SetNodeText(const T: IANTLRInterface;
const Text: String);
begin
raise EInvalidOperation.Create('don''t know enough about Tree node');
end;
procedure TBaseTreeAdaptor.SetNodeType(const T: IANTLRInterface;
const NodeType: Integer);
begin
raise EInvalidOperation.Create('don''t know enough about Tree node');
end;
{ TCommonTreeAdaptor }
function TCommonTreeAdaptor.CreateNode(const Payload: IToken): IANTLRInterface;
begin
Result := TCommonTree.Create(Payload);
end;
function TCommonTreeAdaptor.CreateToken(const TokenType: Integer;
const Text: String): IToken;
begin
Result := TCommonToken.Create(TokenType, Text);
end;
function TCommonTreeAdaptor.CreateToken(const FromToken: IToken): IToken;
begin
Result := TCommonToken.Create(FromToken);
end;
function TCommonTreeAdaptor.DupNode(
const TreeNode: IANTLRInterface): IANTLRInterface;
begin
if (TreeNode = nil) then
Result := nil
else
Result := (TreeNode as ITree).DupNode;
end;
function TCommonTreeAdaptor.GetChild(const T: IANTLRInterface;
const I: Integer): IANTLRInterface;
begin
if (T = nil) then
Result := nil
else
Result := (T as ITree).GetChild(I);
end;
function TCommonTreeAdaptor.GetChildCount(const T: IANTLRInterface): Integer;
begin
if (T = nil) then
Result := 0
else
Result := (T as ITree).ChildCount;
end;
function TCommonTreeAdaptor.GetChildIndex(const T: IANTLRInterface): Integer;
begin
Result := (T as ITree).ChildIndex;
end;
function TCommonTreeAdaptor.GetNodeText(const T: IANTLRInterface): String;
begin
if (T = nil) then
Result := ''
else
Result := (T as ITree).Text;
end;
function TCommonTreeAdaptor.GetNodeType(const T: IANTLRInterface): Integer;
begin
if (T = nil) then
Result := TToken.INVALID_TOKEN_TYPE
else
Result := (T as ITree).TokenType;
end;
function TCommonTreeAdaptor.GetParent(
const T: IANTLRInterface): IANTLRInterface;
begin
Result := (T as ITree).Parent;
end;
function TCommonTreeAdaptor.GetToken(const TreeNode: IANTLRInterface): IToken;
var
CommonTree: ICommonTree;
begin
if Supports(TreeNode, ICommonTree, CommonTree) then
Result := CommonTree.Token
else
Result := nil; // no idea what to do
end;
function TCommonTreeAdaptor.GetTokenStartIndex(
const T: IANTLRInterface): Integer;
begin
if (T = nil) then
Result := -1
else
Result := (T as ITree).TokenStartIndex;
end;
function TCommonTreeAdaptor.GetTokenStopIndex(
const T: IANTLRInterface): Integer;
begin
if (T = nil) then
Result := -1
else
Result := (T as ITree).TokenStopIndex;
end;
procedure TCommonTreeAdaptor.ReplaceChildren(const Parent: IANTLRInterface;
const StartChildIndex, StopChildIndex: Integer; const T: IANTLRInterface);
begin
if Assigned(Parent) then
(Parent as ITree).ReplaceChildren(StartChildIndex, StopChildIndex, T);
end;
procedure TCommonTreeAdaptor.SetChildIdex(const T: IANTLRInterface;
const Index: Integer);
begin
(T as ITree).ChildIndex := Index;
end;
procedure TCommonTreeAdaptor.SetParent(const T, Parent: IANTLRInterface);
begin
(T as ITree).Parent := (Parent as ITree);
end;
procedure TCommonTreeAdaptor.SetTokenBoundaries(const T: IANTLRInterface;
const StartToken, StopToken: IToken);
var
Start, Stop: Integer;
begin
if Assigned(T) then
begin
if Assigned(StartToken) then
Start := StartToken.TokenIndex
else
Start := 0;
if Assigned(StopToken) then
Stop := StopToken.TokenIndex
else
Stop := 0;
(T as ITree).TokenStartIndex := Start;
(T as ITree).TokenStopIndex := Stop;
end;
end;
{ TCommonTreeNodeStream }
procedure TCommonTreeNodeStream.AddNavigationNode(const TokenType: Integer);
var
NavNode: IANTLRInterface;
begin
if (TokenType = TToken.DOWN) then
begin
if (GetHasUniqueNavigationNodes) then
NavNode := FAdaptor.CreateNode(TToken.DOWN, 'DOWN')
else
NavNode := FDown;
end
else
begin
if (GetHasUniqueNavigationNodes) then
NavNode := FAdaptor.CreateNode(TToken.UP, 'UP')
else
NavNode := FUp;
end;
FNodes.Add(NavNode);
end;
procedure TCommonTreeNodeStream.Consume;
begin
if (FP = -1) then
FillBuffer;
Inc(FP);
end;
constructor TCommonTreeNodeStream.Create;
begin
inherited;
FP := -1;
end;
constructor TCommonTreeNodeStream.Create(const ATree: IANTLRInterface);
begin
Create(TCommonTreeAdaptor.Create, ATree);
end;
constructor TCommonTreeNodeStream.Create(const AAdaptor: ITreeAdaptor;
const ATree: IANTLRInterface);
begin
Create(AAdaptor, ATree, DEFAULT_INITIAL_BUFFER_SIZE);
end;
constructor TCommonTreeNodeStream.Create(const AAdaptor: ITreeAdaptor;
const ATree: IANTLRInterface; const AInitialBufferSize: Integer);
begin
Create;
FRoot := ATree;
FAdaptor := AAdaptor;
FNodes := TList<IANTLRInterface>.Create;
FNodes.Capacity := AInitialBufferSize;
FDown := FAdaptor.CreateNode(TToken.DOWN, 'DOWN');
FUp := FAdaptor.CreateNode(TToken.UP, 'UP');
FEof := FAdaptor.CreateNode(TToken.EOF, 'EOF');
end;
procedure TCommonTreeNodeStream.FillBuffer;
begin
FillBuffer(FRoot);
FP := 0; // buffer of nodes intialized now
end;
procedure TCommonTreeNodeStream.FillBuffer(const T: IANTLRInterface);
var
IsNil: Boolean;
C, N: Integer;
begin
IsNil := FAdaptor.IsNil(T);
if (not IsNil) then
FNodes.Add(T); // add this node
// add DOWN node if t has children
N := FAdaptor.GetChildCount(T);
if (not IsNil) and (N > 0) then
AddNavigationNode(TToken.DOWN);
// and now add all its children
for C := 0 to N - 1 do
FillBuffer(FAdaptor.GetChild(T, C));
// add UP node if t has children
if (not IsNil) and (N > 0) then
AddNavigationNode(TToken.UP);
end;
function TCommonTreeNodeStream.Get(const I: Integer): IANTLRInterface;
begin
if (FP = -1) then
FillBuffer;
Result := FNodes[I];
end;
function TCommonTreeNodeStream.GetCurrentSymbol: IANTLRInterface;
begin
Result := LT(1);
end;
function TCommonTreeNodeStream.GetHasUniqueNavigationNodes: Boolean;
begin
Result := FUniqueNavigationNodes;
end;
function TCommonTreeNodeStream.GetNodeIndex(
const Node: IANTLRInterface): Integer;
var
T: IANTLRInterface;
begin
if (FP = -1) then
FillBuffer;
for Result := 0 to FNodes.Count - 1 do
begin
T := FNodes[Result];
if (T = Node) then
Exit;
end;
Result := -1;
end;
function TCommonTreeNodeStream.GetSourceName: String;
begin
Result := GetTokenStream.SourceName;
end;
function TCommonTreeNodeStream.GetTokenStream: ITokenStream;
begin
Result := FTokens;
end;
function TCommonTreeNodeStream.GetTreeAdaptor: ITreeAdaptor;
begin
Result := FAdaptor;
end;
function TCommonTreeNodeStream.GetTreeSource: IANTLRInterface;
begin
Result := FRoot;
end;
function TCommonTreeNodeStream.Index: Integer;
begin
Result := FP;
end;
function TCommonTreeNodeStream.LA(I: Integer): Integer;
begin
Result := FAdaptor.GetNodeType(LT(I));
end;
function TCommonTreeNodeStream.LAChar(I: Integer): Char;
begin
Result := Char(LA(I));
end;
function TCommonTreeNodeStream.LB(const K: Integer): IANTLRInterface;
begin
if (K = 0) then
Result := nil
else
if ((FP - K) < 0) then
Result := nil
else
Result := FNodes[FP - K];
end;
function TCommonTreeNodeStream.LT(const K: Integer): IANTLRInterface;
begin
if (FP = -1) then
FillBuffer;
if (K = 0) then
Result := nil
else
if (K < 0) then
Result := LB(-K)
else
if ((FP + K - 1) >= FNodes.Count) then
Result := FEof
else
Result := FNodes[FP + K - 1];
end;
function TCommonTreeNodeStream.Mark: Integer;
begin
if (FP = -1) then
FillBuffer;
FLastMarker := Index;
Result := FLastMarker;
end;
function TCommonTreeNodeStream.Pop: Integer;
begin
Result := FCalls.Pop;
Seek(Result);
end;
procedure TCommonTreeNodeStream.Push(const Index: Integer);
begin
if (FCalls = nil) then
FCalls := TStackList<Integer>.Create;
FCalls.Push(FP); // save current index
Seek(Index);
end;
procedure TCommonTreeNodeStream.Release(const Marker: Integer);
begin
// no resources to release
end;
procedure TCommonTreeNodeStream.ReplaceChildren(const Parent: IANTLRInterface;
const StartChildIndex, StopChildIndex: Integer; const T: IANTLRInterface);
begin
if Assigned(Parent) then
FAdaptor.ReplaceChildren(Parent, StartChildIndex, StopChildIndex, T);
end;
procedure TCommonTreeNodeStream.Reset;
begin
FP := -1;
FLastMarker := 0;
if Assigned(FCalls) then
FCalls.Clear;
end;
procedure TCommonTreeNodeStream.Rewind(const Marker: Integer);
begin
Seek(Marker);
end;
procedure TCommonTreeNodeStream.Rewind;
begin
Seek(FLastMarker);
end;
procedure TCommonTreeNodeStream.Seek(const Index: Integer);
begin
if (FP = -1) then
FillBuffer;
FP := Index;
end;
procedure TCommonTreeNodeStream.SetHasUniqueNavigationNodes(
const Value: Boolean);
begin
FUniqueNavigationNodes := Value;
end;
procedure TCommonTreeNodeStream.SetTokenStream(const Value: ITokenStream);
begin
FTokens := Value;
end;
procedure TCommonTreeNodeStream.SetTreeAdaptor(const Value: ITreeAdaptor);
begin
FAdaptor := Value;
end;
function TCommonTreeNodeStream.Size: Integer;
begin
if (FP = -1) then
FillBuffer;
Result := FNodes.Count;
end;
function TCommonTreeNodeStream.ToString(const Start,
Stop: IANTLRInterface): String;
var
CommonTree: ICommonTree;
I, BeginTokenIndex, EndTokenIndex: Integer;
T: IANTLRInterface;
Buf: TStringBuilder;
Text: String;
begin
WriteLn('ToString');
if (Start = nil) or (Stop = nil) then
Exit;
if (FP = -1) then
FillBuffer;
if Supports(Start, ICommonTree, CommonTree) then
Write('ToString: ' + CommonTree.Token.ToString + ', ')
else
WriteLn(Start.ToString);
if Supports(Stop, ICommonTree, CommonTree) then
WriteLn(CommonTree.Token.ToString)
else
WriteLn(Stop.ToString);
// if we have the token stream, use that to dump text in order
if Assigned(FTokens) then
begin
BeginTokenIndex := FAdaptor.GetTokenStartIndex(Start);
EndTokenIndex := FAdaptor.GetTokenStartIndex(Stop);
// if it's a tree, use start/stop index from start node
// else use token range from start/stop nodes
if (FAdaptor.GetNodeType(Stop) = TToken.UP) then
EndTokenIndex := FAdaptor.GetTokenStopIndex(Start)
else
if (FAdaptor.GetNodeType(Stop) = TToken.EOF) then
EndTokenIndex := Size - 2; // don't use EOF
Result := FTokens.ToString(BeginTokenIndex, EndTokenIndex);
Exit;
end;
// walk nodes looking for start
T := nil;
I := 0;
while (I < FNodes.Count) do
begin
T := FNodes[I];
if SameObj(T, Start) then
Break;
Inc(I);
end;
// now walk until we see stop, filling string buffer with text
Buf := TStringBuilder.Create;
try
T := FNodes[I];
while (T <> Stop) do
begin
Text := FAdaptor.GetNodeText(T);
if (Text = '') then
Text := ' ' + IntToStr(FAdaptor.GetNodeType(T));
Buf.Append(Text);
Inc(I);
T := FNodes[I];
end;
// include stop node too
Text := FAdaptor.GetNodeText(Stop);
if (Text = '') then
Text := ' ' + IntToStr(FAdaptor.GetNodeType(Stop));
Buf.Append(Text);
Result := Buf.ToString;
finally
Buf.Free;
end;
end;
function TCommonTreeNodeStream.ToString: String;
var
Buf: TStringBuilder;
T: IANTLRInterface;
begin
if (FP = -1) then
FillBuffer;
Buf := TStringBuilder.Create;
try
for T in FNodes do
begin
Buf.Append(' ');
Buf.Append(FAdaptor.GetNodeType(T));
end;
Result := Buf.ToString;
finally
Buf.Free;
end;
end;
function TCommonTreeNodeStream.ToTokenString(const Start,
Stop: Integer): String;
var
I: Integer;
T: IANTLRInterface;
Buf: TStringBuilder;
begin
if (FP = -1) then
FillBuffer;
Buf := TStringBuilder.Create;
try
for I := Stop to Min(FNodes.Count - 1, Stop) do
begin
T := FNodes[I];
Buf.Append(' ');
Buf.Append(FAdaptor.GetToken(T).ToString);
end;
Result := Buf.ToString;
finally
Buf.Free;
end;
end;
{ TParseTree }
constructor TParseTree.Create(const ALabel: IANTLRInterface);
begin
inherited Create;
FPayload := ALabel;
end;
function TParseTree.DupNode: ITree;
begin
Result := nil;
end;
function TParseTree.GetText: String;
begin
Result := ToString;
end;
function TParseTree.GetTokenStartIndex: Integer;
begin
Result := 0;
end;
function TParseTree.GetTokenStopIndex: Integer;
begin
Result := 0;
end;
function TParseTree.GetTokenType: Integer;
begin
Result := 0;
end;
procedure TParseTree.SetTokenStartIndex(const Value: Integer);
begin
// No implementation
end;
procedure TParseTree.SetTokenStopIndex(const Value: Integer);
begin
// No implementation
end;
function TParseTree.ToInputString: String;
var
Buf: TStringBuilder;
begin
Buf := TStringBuilder.Create;
try
_ToStringLeaves(Buf);
Result := Buf.ToString;
finally
Buf.Free;
end;
end;
function TParseTree.ToString: String;
var
T: IToken;
begin
if Supports(FPayload, IToken, T) then
begin
if (T.TokenType = TToken.EOF) then
Result := '<EOF>'
else
Result := T.Text;
end
else
Result := FPayload.ToString;
end;
function TParseTree.ToStringWithHiddenTokens: String;
var
Buf: TStringBuilder;
Hidden: IToken;
NodeText: String;
begin
Buf := TStringBuilder.Create;
try
if Assigned(FHiddenTokens) then
begin
for Hidden in FHiddenTokens do
Buf.Append(Hidden.Text);
end;
NodeText := ToString;
if (NodeText <> '<EOF>') then
Buf.Append(NodeText);
Result := Buf.ToString;
finally
Buf.Free;
end;
end;
procedure TParseTree._ToStringLeaves(const Buf: TStringBuilder);
var
T: IBaseTree;
begin
if Supports(FPayload, IToken) then
begin
// leaf node token?
Buf.Append(ToStringWithHiddenTokens);
Exit;
end;
if Assigned(FChildren) then
for T in FChildren do
(T as IParseTree)._ToStringLeaves(Buf);
end;
{ ERewriteCardinalityException }
constructor ERewriteCardinalityException.Create(
const AElementDescription: String);
begin
inherited Create(AElementDescription);
FElementDescription := AElementDescription;
end;
{ TRewriteRuleElementStream }
procedure TRewriteRuleElementStream.Add(const El: IANTLRInterface);
begin
if (El = nil) then
Exit;
if Assigned(FElements) then
// if in list, just add
FElements.Add(El)
else
if (FSingleElement = nil) then
// no elements yet, track w/o list
FSingleElement := El
else
begin
// adding 2nd element, move to list
FElements := TList<IANTLRInterface>.Create;
FElements.Capacity := 5;
FElements.Add(FSingleElement);
FSingleElement := nil;
FElements.Add(El);
end;
end;
constructor TRewriteRuleElementStream.Create(const AAdaptor: ITreeAdaptor;
const AElementDescription: String);
begin
inherited Create;
FAdaptor := AAdaptor;
FElementDescription := AElementDescription;
end;
constructor TRewriteRuleElementStream.Create(const AAdaptor: ITreeAdaptor;
const AElementDescription: String; const AOneElement: IANTLRInterface);
begin
Create(AAdaptor, AElementDescription);
Add(AOneElement);
end;
constructor TRewriteRuleElementStream.Create(const AAdaptor: ITreeAdaptor;
const AElementDescription: String; const AElements: IList<IANTLRInterface>);
begin
Create(AAdaptor, AElementDescription);
FElements := AElements;
end;
function TRewriteRuleElementStream.GetDescription: String;
begin
Result := FElementDescription;
end;
function TRewriteRuleElementStream.HasNext: Boolean;
begin
Result := ((FSingleElement <> nil) and (FCursor < 1))
or ((FElements <> nil) and (FCursor < FElements.Count));
end;
function TRewriteRuleElementStream.NextTree: IANTLRInterface;
begin
Result := _Next;
end;
procedure TRewriteRuleElementStream.Reset;
begin
FCursor := 0;
FDirty := True;
end;
function TRewriteRuleElementStream.Size: Integer;
begin
if Assigned(FSingleElement) then
Result := 1
else
if Assigned(FElements) then
Result := FElements.Count
else
Result := 0;
end;
function TRewriteRuleElementStream.ToTree(const El: IANTLRInterface): IANTLRInterface;
begin
Result := El;
end;
function TRewriteRuleElementStream._Next: IANTLRInterface;
var
Size: Integer;
begin
Size := Self.Size;
if (Size = 0) then
raise ERewriteEmptyStreamException.Create(FElementDescription);
if (FCursor >= Size) then
begin
// out of elements?
if (Size = 1) then
// if size is 1, it's ok; return and we'll dup
Result := ToTree(FSingleElement)
else
// out of elements and size was not 1, so we can't dup
raise ERewriteCardinalityException.Create(FElementDescription);
end
else
begin
// we have elements
if Assigned(FSingleElement) then
begin
Inc(FCursor); // move cursor even for single element list
Result := ToTree(FSingleElement);
end
else
begin
// must have more than one in list, pull from elements
Result := ToTree(FElements[FCursor]);
Inc(FCursor);
end;
end;
end;
{ TRewriteRuleNodeStream }
function TRewriteRuleNodeStream.NextNode: IANTLRInterface;
begin
Result := _Next;
end;
function TRewriteRuleNodeStream.ToTree(
const El: IANTLRInterface): IANTLRInterface;
begin
Result := FAdaptor.DupNode(El);
end;
{ TRewriteRuleSubtreeStream }
function TRewriteRuleSubtreeStream.Dup(
const O: IANTLRInterface): IANTLRInterface;
begin
Result := FAdaptor.DupTree(O);
end;
function TRewriteRuleSubtreeStream.DupNode(
const O: IANTLRInterface): IANTLRInterface;
begin
Result := FAdaptor.DupNode(O);
end;
function TRewriteRuleSubtreeStream.FetchObject(
const PH: TProcessHandler): IANTLRInterface;
begin
if (RequiresDuplication) then
// process the object
Result := PH(_Next)
else
// test above then fetch
Result := _Next;
end;
function TRewriteRuleSubtreeStream.NextNode: IANTLRInterface;
begin
// if necessary, dup (at most a single node since this is for making root nodes).
Result := FetchObject(DupNode);
end;
function TRewriteRuleSubtreeStream.NextTree: IANTLRInterface;
begin
// if out of elements and size is 1, dup
Result := FetchObject(Dup);
end;
function TRewriteRuleSubtreeStream.RequiresDuplication: Boolean;
var
Size: Integer;
begin
Size := Self.Size;
// if dirty or if out of elements and size is 1
Result := FDirty or ((FCursor >= Size) and (Size = 1));
end;
{ TRewriteRuleTokenStream }
function TRewriteRuleTokenStream.NextNode: IANTLRInterface;
begin
Result := FAdaptor.CreateNode(_Next as IToken)
end;
function TRewriteRuleTokenStream.NextToken: IToken;
begin
Result := _Next as IToken;
end;
function TRewriteRuleTokenStream.ToTree(
const El: IANTLRInterface): IANTLRInterface;
begin
Result := El;
end;
{ TTreeParser }
constructor TTreeParser.Create(const AInput: ITreeNodeStream);
begin
inherited Create; // highlight that we go to super to set state object
SetTreeNodeStream(AInput);
end;
constructor TTreeParser.Create(const AInput: ITreeNodeStream;
const AState: IRecognizerSharedState);
begin
inherited Create(AState); // share the state object with another parser
SetTreeNodeStream(AInput);
end;
function TTreeParser.GetCurrentInputSymbol(
const Input: IIntStream): IANTLRInterface;
begin
Result := FInput.LT(1);
end;
function TTreeParser.GetErrorHeader(const E: ERecognitionException): String;
begin
Result := GetGrammarFileName + ': node from ';
if (E.ApproximateLineInfo) then
Result := Result + 'after ';
Result := Result + 'line ' + IntToStr(E.Line) + ':' + IntToStr(E.CharPositionInLine);
end;
function TTreeParser.GetErrorMessage(const E: ERecognitionException;
const TokenNames: TStringArray): String;
var
Adaptor: ITreeAdaptor;
begin
if (Self is TTreeParser) then
begin
Adaptor := (E.Input as ITreeNodeStream).TreeAdaptor;
E.Token := Adaptor.GetToken(E.Node);
if (E.Token = nil) then
// could be an UP/DOWN node
E.Token := TCommonToken.Create(Adaptor.GetNodeType(E.Node),
Adaptor.GetNodeText(E.Node));
end;
Result := inherited GetErrorMessage(E, TokenNames);
end;
function TTreeParser.GetInput: IIntStream;
begin
Result := FInput;
end;
function TTreeParser.GetMissingSymbol(const Input: IIntStream;
const E: ERecognitionException; const ExpectedTokenType: Integer;
const Follow: IBitSet): IANTLRInterface;
var
TokenText: String;
begin
TokenText := '<missing ' + GetTokenNames[ExpectedTokenType] + '>';
Result := TCommonTree.Create(TCommonToken.Create(ExpectedTokenType, TokenText));
end;
function TTreeParser.GetSourceName: String;
begin
Result := FInput.SourceName;
end;
function TTreeParser.GetTreeNodeStream: ITreeNodeStream;
begin
Result := FInput;
end;
procedure TTreeParser.MatchAny(const Input: IIntStream);
var
Look: IANTLRInterface;
Level, TokenType: Integer;
begin
FState.ErrorRecovery := False;
FState.Failed := False;
Look := FInput.LT(1);
if (FInput.TreeAdaptor.GetChildCount(Look) = 0) then
begin
FInput.Consume; // not subtree, consume 1 node and return
Exit;
end;
// current node is a subtree, skip to corresponding UP.
// must count nesting level to get right UP
Level := 0;
TokenType := FInput.TreeAdaptor.GetNodeType(Look);
while (TokenType <> TToken.EOF) and not ((TokenType = UP) and (Level = 0)) do
begin
FInput.Consume;
Look := FInput.LT(1);
TokenType := FInput.TreeAdaptor.GetNodeType(Look);
if (TokenType = DOWN) then
Inc(Level)
else
if (TokenType = UP) then
Dec(Level);
end;
FInput.Consume; // consume UP
end;
procedure TTreeParser.Mismatch(const Input: IIntStream;
const TokenType: Integer; const Follow: IBitSet);
begin
raise EMismatchedTreeNodeException.Create(TokenType, FInput);
end;
procedure TTreeParser.Reset;
begin
inherited; // reset all recognizer state variables
if Assigned(FInput) then
FInput.Seek(0); // rewind the input
end;
procedure TTreeParser.SetTreeNodeStream(const Value: ITreeNodeStream);
begin
FInput := Value;
end;
procedure TTreeParser.TraceIn(const RuleName: String; const RuleIndex: Integer);
begin
inherited TraceIn(RuleName, RuleIndex, FInput.LT(1).ToString);
end;
procedure TTreeParser.TraceOut(const RuleName: String;
const RuleIndex: Integer);
begin
inherited TraceOut(RuleName, RuleIndex, FInput.LT(1).ToString);
end;
{ TTreePatternLexer }
constructor TTreePatternLexer.Create;
begin
inherited;
FSVal := TStringBuilder.Create;
end;
procedure TTreePatternLexer.Consume;
begin
Inc(FP);
if (FP > FN) then
FC := EOF
else
FC := Integer(FPattern[FP]);
end;
constructor TTreePatternLexer.Create(const APattern: String);
begin
Create;
FPattern := APattern;
FN := Length(FPattern);
Consume;
end;
destructor TTreePatternLexer.Destroy;
begin
FSVal.Free;
inherited;
end;
function TTreePatternLexer.NextToken: Integer;
begin
FSVal.Length := 0; // reset, but reuse buffer
while (FC <> EOF) do
begin
if (FC = 32) or (FC = 10) or (FC = 13) or (FC = 9) then
begin
Consume;
Continue;
end;
if ((FC >= Ord('a')) and (FC <= Ord('z')))
or ((FC >= Ord('A')) and (FC <= Ord('Z')))
or (FC = Ord('_'))
then begin
FSVal.Append(Char(FC));
Consume;
while ((FC >= Ord('a')) and (FC <= Ord('z')))
or ((FC >= Ord('A')) and (FC <= Ord('Z')))
or ((FC >= Ord('0')) and (FC <= Ord('9')))
or (FC = Ord('_')) do
begin
FSVal.Append(Char(FC));
Consume;
end;
Exit(ID);
end;
if (FC = Ord('(')) then
begin
Consume;
Exit(START);
end;
if (FC = Ord(')')) then
begin
Consume;
Exit(STOP);
end;
if (FC = Ord('%')) then
begin
Consume;
Exit(PERCENT);
end;
if (FC = Ord(':')) then
begin
Consume;
Exit(COLON);
end;
if (FC = Ord('.')) then
begin
Consume;
Exit(DOT);
end;
if (FC = Ord('[')) then
begin
// grab [x] as a string, returning x
Consume;
while (FC <> Ord(']')) do
begin
if (FC = Ord('\')) then
begin
Consume;
if (FC <> Ord(']')) then
FSVal.Append('\');
FSVal.Append(Char(FC));
end
else
FSVal.Append(Char(FC));
Consume;
end;
Consume;
Exit(ARG);
end;
Consume;
FError := True;
Exit(EOF);
end;
Result := EOF;
end;
function TTreePatternLexer.SVal: String;
begin
Result := FSVal.ToString;
end;
{ TTreeWizard }
function TTreeWizard.ComputeTokenTypes(
const TokenNames: TStringArray): IDictionary<String, Integer>;
var
TokenType: Integer;
begin
Result := TDictionary<String, Integer>.Create;
if (Length(TokenNames) > 0)then
begin
for TokenType := TToken.MIN_TOKEN_TYPE to Length(TokenNames) - 1 do
Result.Add(TokenNames[TokenType], TokenType);
end;
end;
constructor TTreeWizard.Create(const AAdaptor: ITreeAdaptor);
begin
inherited Create;
FAdaptor := AAdaptor;
end;
constructor TTreeWizard.Create(const AAdaptor: ITreeAdaptor;
const ATokenNameToTypeMap: IDictionary<String, Integer>);
begin
inherited Create;
FAdaptor := AAdaptor;
FTokenNameToTypeMap := ATokenNameToTypeMap;
end;
constructor TTreeWizard.Create(const AAdaptor: ITreeAdaptor;
const TokenNames: TStringArray);
begin
inherited Create;
FAdaptor := AAdaptor;
FTokenNameToTypeMap := ComputeTokenTypes(TokenNames);
end;
function TTreeWizard.CreateTreeOrNode(const Pattern: String): IANTLRInterface;
var
Tokenizer: ITreePatternLexer;
Parser: ITreePatternParser;
begin
Tokenizer := TTreePatternLexer.Create(Pattern);
Parser := TTreePatternParser.Create(Tokenizer, Self, FAdaptor);
Result := Parser.Pattern;
end;
function TTreeWizard.Equals(const T1, T2: IANTLRInterface;
const Adaptor: ITreeAdaptor): Boolean;
begin
Result := _Equals(T1, T2, Adaptor);
end;
function TTreeWizard.Equals(const T1, T2: IANTLRInterface): Boolean;
begin
Result := _Equals(T1, T2, FAdaptor);
end;
function TTreeWizard.Find(const T: IANTLRInterface;
const Pattern: String): IList<IANTLRInterface>;
var
Tokenizer: ITreePatternLexer;
Parser: ITreePatternParser;
TreePattern: ITreePattern;
RootTokenType: Integer;
Visitor: IContextVisitor;
begin
Result := TList<IANTLRInterface>.Create;
// Create a TreePattern from the pattern
Tokenizer := TTreePatternLexer.Create(Pattern);
Parser := TTreePatternParser.Create(Tokenizer, Self, TTreePatternTreeAdaptor.Create);
TreePattern := Parser.Pattern as ITreePattern;
// don't allow invalid patterns
if (TreePattern = nil) or (TreePattern.IsNil)
or Supports(TreePattern, IWildcardTreePattern)
then
Exit(nil);
RootTokenType := TreePattern.TokenType;
Visitor := TPatternMatchingContextVisitor.Create(Self, TreePattern, Result);
Visit(T, RootTokenType, Visitor);
end;
function TTreeWizard.Find(const T: IANTLRInterface;
const TokenType: Integer): IList<IANTLRInterface>;
begin
Result := TList<IANTLRInterface>.Create;
Visit(T, TokenType, TRecordAllElementsVisitor.Create(Result));
end;
function TTreeWizard.FindFirst(const T: IANTLRInterface;
const TokenType: Integer): IANTLRInterface;
begin
Result := nil;
end;
function TTreeWizard.FindFirst(const T: IANTLRInterface;
const Pattern: String): IANTLRInterface;
begin
Result := nil;
end;
function TTreeWizard.GetTokenType(const TokenName: String): Integer;
begin
if (FTokenNameToTypeMap = nil) then
Exit(TToken.INVALID_TOKEN_TYPE);
if (not FTokenNameToTypeMap.TryGetValue(TokenName, Result)) then
Result := TToken.INVALID_TOKEN_TYPE;
end;
function TTreeWizard.Index(
const T: IANTLRInterface): IDictionary<Integer, IList<IANTLRInterface>>;
begin
Result := TDictionary<Integer, IList<IANTLRInterface>>.Create;
_Index(T, Result);
end;
function TTreeWizard.Parse(const T: IANTLRInterface;
const Pattern: String): Boolean;
begin
Result := Parse(T, Pattern, nil);
end;
function TTreeWizard.Parse(const T: IANTLRInterface; const Pattern: String;
const Labels: IDictionary<String, IANTLRInterface>): Boolean;
var
Tokenizer: ITreePatternLexer;
Parser: ITreePatternParser;
TreePattern: ITreePattern;
begin
Tokenizer := TTreePatternLexer.Create(Pattern);
Parser := TTreePatternParser.Create(Tokenizer, Self, TTreePatternTreeAdaptor.Create);
TreePattern := Parser.Pattern as ITreePattern;
Result := _Parse(T, TreePattern, Labels);
end;
procedure TTreeWizard.Visit(const T: IANTLRInterface; const Pattern: String;
const Visitor: IContextVisitor);
var
Tokenizer: ITreePatternLexer;
Parser: ITreePatternParser;
TreePattern: ITreePattern;
RootTokenType: Integer;
PatternVisitor: IContextVisitor;
begin
// Create a TreePattern from the pattern
Tokenizer := TTreePatternLexer.Create(Pattern);
Parser := TTreePatternParser.Create(Tokenizer, Self, TTreePatternTreeAdaptor.Create);
TreePattern := Parser.Pattern as ITreePattern;
if (TreePattern = nil) or (TreePattern.IsNil)
or Supports(TreePattern, IWildcardTreePattern)
then
Exit;
RootTokenType := TreePattern.TokenType;
PatternVisitor := TInvokeVisitorOnPatternMatchContextVisitor.Create(Self, TreePattern, Visitor);
Visit(T, RootTokenType, PatternVisitor);
end;
class function TTreeWizard._Equals(const T1, T2: IANTLRInterface;
const Adaptor: ITreeAdaptor): Boolean;
var
I, N1, N2: Integer;
Child1, Child2: IANTLRInterface;
begin
// make sure both are non-null
if (T1 = nil) or (T2 = nil) then
Exit(False);
// check roots
if (Adaptor.GetNodeType(T1) <> Adaptor.GetNodeType(T2)) then
Exit(False);
if (Adaptor.GetNodeText(T1) <> Adaptor.GetNodeText(T2)) then
Exit(False);
// check children
N1 := Adaptor.GetChildCount(T1);
N2 := Adaptor.GetChildCount(T2);
if (N1 <> N2) then
Exit(False);
for I := 0 to N1 - 1 do
begin
Child1 := Adaptor.GetChild(T1, I);
Child2 := Adaptor.GetChild(T2, I);
if (not _Equals(Child1, Child2, Adaptor)) then
Exit(False);
end;
Result := True;
end;
procedure TTreeWizard._Index(const T: IANTLRInterface;
const M: IDictionary<Integer, IList<IANTLRInterface>>);
var
I, N, TType: Integer;
Elements: IList<IANTLRInterface>;
begin
if (T = nil) then
Exit;
TType := FAdaptor.GetNodeType(T);
if (not M.TryGetValue(TType, Elements)) then
Elements := nil;
if (Elements = nil) then
begin
Elements := TList<IANTLRInterface>.Create;
M.Add(TType, Elements);
end;
Elements.Add(T);
N := FAdaptor.GetChildCount(T);
for I := 0 to N - 1 do
_Index(FAdaptor.GetChild(T, I), M);
end;
function TTreeWizard._Parse(const T1: IANTLRInterface; const T2: ITreePattern;
const Labels: IDictionary<String, IANTLRInterface>): Boolean;
var
I, N1, N2: Integer;
Child1: IANTLRInterface;
Child2: ITreePattern;
begin
// make sure both are non-null
if (T1 = nil) or (T2 = nil) then
Exit(False);
// check roots (wildcard matches anything)
if (not Supports(T2, IWildcardTreePattern)) then
begin
if (FAdaptor.GetNodeType(T1) <> T2.TokenType) then
Exit(False);
if (T2.HasTextArg) and (FAdaptor.GetNodeText(T1) <> T2.Text) then
Exit(False);
end;
if (T2.TokenLabel <> '') and Assigned(Labels) then
// map label in pattern to node in t1
Labels.AddOrSetValue(T2.TokenLabel, T1);
// check children
N1 := FAdaptor.GetChildCount(T1);
N2 := T2.ChildCount;
if (N1 <> N2) then
Exit(False);
for I := 0 to N1 - 1 do
begin
Child1 := FAdaptor.GetChild(T1, I);
Child2 := T2.GetChild(I) as ITreePattern;
if (not _Parse(Child1, Child2, Labels)) then
Exit(False);
end;
Result := True;
end;
procedure TTreeWizard._Visit(const T, Parent: IANTLRInterface; const ChildIndex,
TokenType: Integer; const Visitor: IContextVisitor);
var
I, N: Integer;
begin
if (T = nil) then
Exit;
if (FAdaptor.GetNodeType(T) = TokenType) then
Visitor.Visit(T, Parent, ChildIndex, nil);
N := FAdaptor.GetChildCount(T);
for I := 0 to N - 1 do
_Visit(FAdaptor.GetChild(T, I), T, I, TokenType, Visitor);
end;
procedure TTreeWizard.Visit(const T: IANTLRInterface; const TokenType: Integer;
const Visitor: IContextVisitor);
begin
_Visit(T, nil, 0, TokenType, Visitor);
end;
constructor TTreeWizard.Create(const TokenNames: TStringArray);
begin
Create(nil, TokenNames);
end;
{ TTreePatternParser }
constructor TTreePatternParser.Create(const ATokenizer: ITreePatternLexer;
const AWizard: ITreeWizard; const AAdaptor: ITreeAdaptor);
begin
inherited Create;
FTokenizer := ATokenizer;
FWizard := AWizard;
FAdaptor := AAdaptor;
FTokenType := FTokenizer.NextToken; // kickstart
end;
function TTreePatternParser.ParseNode: IANTLRInterface;
var
Lbl, TokenName, Text, Arg: String;
WildcardPayload: IToken;
Node: TTreeWizard.ITreePattern;
TreeNodeType: Integer;
begin
// "%label:" prefix
Lbl := '';
if (FTokenType = TTreePatternLexer.PERCENT) then
begin
FTokenType := FTokenizer.NextToken;
if (FTokenType <> TTreePatternLexer.ID) then
Exit(nil);
Lbl := FTokenizer.SVal;
FTokenType := FTokenizer.NextToken;
if (FTokenType <> TTreePatternLexer.COLON) then
Exit(nil);
FTokenType := FTokenizer.NextToken; // move to ID following colon
end;
// Wildcard?
if (FTokenType = TTreePatternLexer.DOT) then
begin
FTokenType := FTokenizer.NextToken;
WildcardPayload := TCommonToken.Create(0, '.');
Node := TTreeWizard.TWildcardTreePattern.Create(WildcardPayload);
if (Lbl <> '') then
Node.TokenLabel := Lbl;
Exit(Node);
end;
// "ID" or "ID[arg]"
if (FTokenType <> TTreePatternLexer.ID) then
Exit(nil);
TokenName := FTokenizer.SVal;
FTokenType := FTokenizer.NextToken;
if (TokenName = 'nil') then
Exit(FAdaptor.GetNilNode);
Text := TokenName;
// check for arg
Arg := '';
if (FTokenType = TTreePatternLexer.ARG) then
begin
Arg := FTokenizer.SVal;
Text := Arg;
FTokenType := FTokenizer.NextToken;
end;
// create node
TreeNodeType := FWizard.GetTokenType(TokenName);
if (TreeNodeType = TToken.INVALID_TOKEN_TYPE) then
Exit(nil);
Result := FAdaptor.CreateNode(TreeNodeType, Text);
if (Lbl <> '') and Supports(Result, TTreeWizard.ITreePattern, Node) then
Node.TokenLabel := Lbl;
if (Arg <> '') and Supports(Result, TTreeWizard.ITreePattern, Node) then
Node.HasTextArg := True;
end;
function TTreePatternParser.ParseTree: IANTLRInterface;
var
Subtree, Child: IANTLRInterface;
begin
if (FTokenType <> TTreePatternLexer.START) then
begin
WriteLn('no BEGIN');
Exit(nil);
end;
FTokenType := FTokenizer.NextToken;
Result := ParseNode;
if (Result = nil) then
Exit;
while (FTokenType in [TTreePatternLexer.START, TTreePatternLexer.ID,
TTreePatternLexer.PERCENT, TTreePatternLexer.DOT]) do
begin
if (FTokenType = TTreePatternLexer.START) then
begin
Subtree := ParseTree;
FAdaptor.AddChild(Result, Subtree);
end
else
begin
Child := ParseNode;
if (Child = nil) then
Exit(nil);
FAdaptor.AddChild(Result, Child);
end;
end;
if (FTokenType <> TTreePatternLexer.STOP) then
begin
WriteLn('no END');
Exit(nil);
end;
FTokenType := FTokenizer.NextToken;
end;
function TTreePatternParser.Pattern: IANTLRInterface;
var
Node: IANTLRInterface;
begin
if (FTokenType = TTreePatternLexer.START) then
Exit(ParseTree);
if (FTokenType = TTreePatternLexer.ID) then
begin
Node := ParseNode;
if (FTokenType = TTreePatternLexer.EOF) then
Result := Node
else
Result := nil; // extra junk on end
end
else
Result := nil;
end;
{ TTreeWizard.TVisitor }
procedure TTreeWizard.TVisitor.Visit(const T, Parent: IANTLRInterface;
const ChildIndex: Integer;
const Labels: IDictionary<String, IANTLRInterface>);
begin
Visit(T);
end;
{ TTreeWizard.TRecordAllElementsVisitor }
constructor TTreeWizard.TRecordAllElementsVisitor.Create(
const AList: IList<IANTLRInterface>);
begin
inherited Create;
FList := AList;
end;
procedure TTreeWizard.TRecordAllElementsVisitor.Visit(const T: IANTLRInterface);
begin
FList.Add(T);
end;
{ TTreeWizard.TPatternMatchingContextVisitor }
constructor TTreeWizard.TPatternMatchingContextVisitor.Create(
const AOwner: TTreeWizard; const APattern: ITreePattern;
const AList: IList<IANTLRInterface>);
begin
inherited Create;
FOwner := AOwner;
FPattern := APattern;
FList := AList;
end;
procedure TTreeWizard.TPatternMatchingContextVisitor.Visit(const T,
Parent: IANTLRInterface; const ChildIndex: Integer;
const Labels: IDictionary<String, IANTLRInterface>);
begin
if (FOwner._Parse(T, FPattern, nil)) then
FList.Add(T);
end;
{ TTreeWizard.TInvokeVisitorOnPatternMatchContextVisitor }
constructor TTreeWizard.TInvokeVisitorOnPatternMatchContextVisitor.Create(
const AOwner: TTreeWizard; const APattern: ITreePattern;
const AVisitor: IContextVisitor);
begin
inherited Create;
FOwner := AOwner;
FPattern := APattern;
FVisitor := AVisitor;
FLabels := TDictionary<String, IANTLRInterface>.Create;
end;
procedure TTreeWizard.TInvokeVisitorOnPatternMatchContextVisitor.Visit(const T,
Parent: IANTLRInterface; const ChildIndex: Integer;
const UnusedLabels: IDictionary<String, IANTLRInterface>);
begin
// the unusedlabels arg is null as visit on token type doesn't set.
FLabels.Clear;
if (FOwner._Parse(T, FPattern, FLabels)) then
FVisitor.Visit(T, Parent, ChildIndex, FLabels);
end;
{ TTreeWizard.TTreePattern }
function TTreeWizard.TTreePattern.GetHasTextArg: Boolean;
begin
Result := FHasTextArg;
end;
function TTreeWizard.TTreePattern.GetTokenLabel: String;
begin
Result := FLabel;
end;
procedure TTreeWizard.TTreePattern.SetHasTextArg(const Value: Boolean);
begin
FHasTextArg := Value;
end;
procedure TTreeWizard.TTreePattern.SetTokenLabel(const Value: String);
begin
FLabel := Value;
end;
function TTreeWizard.TTreePattern.ToString: String;
begin
if (FLabel <> '') then
Result := '%' + FLabel + ':' + inherited ToString
else
Result := inherited ToString;
end;
{ TTreeWizard.TTreePatternTreeAdaptor }
function TTreeWizard.TTreePatternTreeAdaptor.CreateNode(
const Payload: IToken): IANTLRInterface;
begin
Result := TTreePattern.Create(Payload);
end;
{ TTreeRuleReturnScope }
function TTreeRuleReturnScope.GetStart: IANTLRInterface;
begin
Result := FStart;
end;
procedure TTreeRuleReturnScope.SetStart(const Value: IANTLRInterface);
begin
FStart := Value;
end;
{ TUnBufferedTreeNodeStream }
procedure TUnBufferedTreeNodeStream.AddLookahead(const Node: IANTLRInterface);
var
Bigger: TANTLRInterfaceArray;
I, RemainderHeadToEnd: Integer;
begin
FLookahead[FTail] := Node;
FTail := (FTail + 1) mod Length(FLookahead);
if (FTail = FHead) then
begin
// buffer overflow: tail caught up with head
// allocate a buffer 2x as big
SetLength(Bigger,2 * Length(FLookahead));
// copy head to end of buffer to beginning of bigger buffer
RemainderHeadToEnd := Length(FLookahead) - FHead;
for I := 0 to RemainderHeadToEnd - 1 do
Bigger[I] := FLookahead[FHead + I];
// copy 0..tail to after that
for I := 0 to FTail - 1 do
Bigger[RemainderHeadToEnd + I] := FLookahead[I];
FLookahead := Bigger; // reset to bigger buffer
FHead := 0;
Inc(FTail,RemainderHeadToEnd);
end;
end;
procedure TUnBufferedTreeNodeStream.AddNavigationNode(const TokenType: Integer);
var
NavNode: IANTLRInterface;
begin
if (TokenType = TToken.DOWN) then
begin
if (GetHasUniqueNavigationNodes) then
NavNode := FAdaptor.CreateNode(TToken.DOWN,'DOWN')
else
NavNode := FDown;
end
else
begin
if (GetHasUniqueNavigationNodes) then
NavNode := FAdaptor.CreateNode(TToken.UP,'UP')
else
NavNode := FUp;
end;
AddLookahead(NavNode);
end;
procedure TUnBufferedTreeNodeStream.Consume;
begin
// make sure there is something in lookahead buf, which might call next()
Fill(1);
Inc(FAbsoluteNodeIndex);
FPreviousNode := FLookahead[FHead]; // track previous node before moving on
FHead := (FHead + 1) mod Length(FLookahead);
end;
constructor TUnBufferedTreeNodeStream.Create;
begin
inherited;
SetLength(FLookAhead,INITIAL_LOOKAHEAD_BUFFER_SIZE);
FNodeStack := TStackList<IANTLRInterface>.Create;
FIndexStack := TStackList<Integer>.Create;
end;
constructor TUnBufferedTreeNodeStream.Create(const ATree: IANTLRInterface);
begin
Create(TCommonTreeAdaptor.Create, ATree);
end;
constructor TUnBufferedTreeNodeStream.Create(const AAdaptor: ITreeAdaptor;
const ATree: IANTLRInterface);
begin
Create;
FRoot := ATree;
FAdaptor := AAdaptor;
Reset;
FDown := FAdaptor.CreateNode(TToken.DOWN, 'DOWN');
FUp := FAdaptor.CreateNode(TToken.UP, 'UP');
FEof := FAdaptor.CreateNode(TToken.EOF, 'EOF');
end;
procedure TUnBufferedTreeNodeStream.Fill(const K: Integer);
var
I, N: Integer;
begin
N := LookaheadSize;
for I := 1 to K - N do
MoveNext; // get at least k-depth lookahead nodes
end;
function TUnBufferedTreeNodeStream.Get(const I: Integer): IANTLRInterface;
begin
raise EInvalidOperation.Create('stream is unbuffered');
end;
function TUnBufferedTreeNodeStream.GetCurrent: IANTLRInterface;
begin
Result := FCurrentEnumerationNode;
end;
function TUnBufferedTreeNodeStream.GetHasUniqueNavigationNodes: Boolean;
begin
Result := FUniqueNavigationNodes;
end;
function TUnBufferedTreeNodeStream.GetSourceName: String;
begin
Result := GetTokenStream.SourceName;
end;
function TUnBufferedTreeNodeStream.GetTokenStream: ITokenStream;
begin
Result := FTokens;
end;
function TUnBufferedTreeNodeStream.GetTreeAdaptor: ITreeAdaptor;
begin
Result := FAdaptor;
end;
function TUnBufferedTreeNodeStream.GetTreeSource: IANTLRInterface;
begin
Result := FRoot;
end;
function TUnBufferedTreeNodeStream.HandleRootNode: IANTLRInterface;
begin
Result := FCurrentNode;
// point to first child in prep for subsequent next()
FCurrentChildIndex := 0;
if (FAdaptor.IsNil(Result)) then
// don't count this root nil node
Result := VisitChild(FCurrentChildIndex)
else
begin
AddLookahead(Result);
if (FAdaptor.GetChildCount(FCurrentNode) = 0) then
// single node case
Result := nil; // say we're done
end;
end;
function TUnBufferedTreeNodeStream.Index: Integer;
begin
Result := FAbsoluteNodeIndex + 1;
end;
function TUnBufferedTreeNodeStream.LA(I: Integer): Integer;
var
T: IANTLRInterface;
begin
T := LT(I);
if (T = nil) then
Result := TToken.INVALID_TOKEN_TYPE
else
Result := FAdaptor.GetNodeType(T);
end;
function TUnBufferedTreeNodeStream.LAChar(I: Integer): Char;
begin
Result := Char(LA(I));
end;
function TUnBufferedTreeNodeStream.LookaheadSize: Integer;
begin
if (FTail < FHead) then
Result := Length(FLookahead) - FHead + FTail
else
Result := FTail - FHead;
end;
function TUnBufferedTreeNodeStream.LT(const K: Integer): IANTLRInterface;
begin
if (K = -1) then
Exit(FPreviousNode);
if (K < 0) then
raise EArgumentException.Create('tree node streams cannot look backwards more than 1 node');
if (K = 0) then
Exit(TTree.INVALID_NODE);
Fill(K);
Result := FLookahead[(FHead + K - 1) mod Length(FLookahead)];
end;
function TUnBufferedTreeNodeStream.Mark: Integer;
var
State: ITreeWalkState;
I, N, K: Integer;
LA: TANTLRInterfaceArray;
begin
if (FMarkers = nil) then
begin
FMarkers := TList<ITreeWalkState>.Create;
FMarkers.Add(nil); // depth 0 means no backtracking, leave blank
end;
Inc(FMarkDepth);
State := nil;
if (FMarkDepth >= FMarkers.Count) then
begin
State := TTreeWalkState.Create;
FMarkers.Add(State);
end
else
State := FMarkers[FMarkDepth];
State.AbsoluteNodeIndex := FAbsoluteNodeIndex;
State.CurrentChildIndex := FCurrentChildIndex;
State.CurrentNode := FCurrentNode;
State.PreviousNode := FPreviousNode;
State.NodeStackSize := FNodeStack.Count;
State.IndexStackSize := FIndexStack.Count;
// take snapshot of lookahead buffer
N := LookaheadSize;
I := 0;
SetLength(LA,N);
for K := 1 to N do
begin
LA[I] := LT(K);
Inc(I);
end;
State.LookAhead := LA;
FLastMarker := FMarkDepth;
Result := FMarkDepth;
end;
function TUnBufferedTreeNodeStream.MoveNext: Boolean;
begin
// already walked entire tree; nothing to return
if (FCurrentNode = nil) then
begin
AddLookahead(FEof);
FCurrentEnumerationNode := nil;
// this is infinite stream returning EOF at end forever
// so don't throw NoSuchElementException
Exit(False);
end;
// initial condition (first time method is called)
if (FCurrentChildIndex = -1) then
begin
FCurrentEnumerationNode := HandleRootNode as ITree;
Exit(True);
end;
// index is in the child list?
if (FCurrentChildIndex < FAdaptor.GetChildCount(FCurrentNode)) then
begin
FCurrentEnumerationNode := VisitChild(FCurrentChildIndex) as ITree;
Exit(True);
end;
// hit end of child list, return to parent node or its parent ...
WalkBackToMostRecentNodeWithUnvisitedChildren;
if (FCurrentNode <> nil) then
begin
FCurrentEnumerationNode := VisitChild(FCurrentChildIndex) as ITree;
Result := True;
end
else
Result := False;
end;
procedure TUnBufferedTreeNodeStream.Release(const Marker: Integer);
begin
// unwind any other markers made after marker and release marker
FMarkDepth := Marker;
// release this marker
Dec(FMarkDepth);
end;
procedure TUnBufferedTreeNodeStream.ReplaceChildren(
const Parent: IANTLRInterface; const StartChildIndex, StopChildIndex: Integer;
const T: IANTLRInterface);
begin
raise EInvalidOperation.Create('can''t do stream rewrites yet');
end;
procedure TUnBufferedTreeNodeStream.Reset;
begin
FCurrentNode := FRoot;
FPreviousNode := nil;
FCurrentChildIndex := -1;
FAbsoluteNodeIndex := -1;
FHead := 0;
FTail := 0;
end;
procedure TUnBufferedTreeNodeStream.Rewind(const Marker: Integer);
var
State: ITreeWalkState;
begin
if (FMarkers = nil) then
Exit;
State := FMarkers[Marker];
FAbsoluteNodeIndex := State.AbsoluteNodeIndex;
FCurrentChildIndex := State.CurrentChildIndex;
FCurrentNode := State.CurrentNode;
FPreviousNode := State.PreviousNode;
// drop node and index stacks back to old size
FNodeStack.Capacity := State.NodeStackSize;
FIndexStack.Capacity := State.IndexStackSize;
FHead := 0; // wack lookahead buffer and then refill
FTail := 0;
while (FTail < Length(State.LookAhead)) do
begin
FLookahead[FTail] := State.LookAhead[FTail];
Inc(FTail);
end;
Release(Marker);
end;
procedure TUnBufferedTreeNodeStream.Rewind;
begin
Rewind(FLastMarker);
end;
procedure TUnBufferedTreeNodeStream.Seek(const Index: Integer);
begin
if (Index < Self.Index) then
raise EArgumentOutOfRangeException.Create('can''t seek backwards in node stream');
// seek forward, consume until we hit index
while (Self.Index < Index) do
Consume;
end;
procedure TUnBufferedTreeNodeStream.SetHasUniqueNavigationNodes(
const Value: Boolean);
begin
FUniqueNavigationNodes := Value;
end;
procedure TUnBufferedTreeNodeStream.SetTokenStream(const Value: ITokenStream);
begin
FTokens := Value;
end;
function TUnBufferedTreeNodeStream.Size: Integer;
var
S: ICommonTreeNodeStream;
begin
S := TCommonTreeNodeStream.Create(FRoot);
Result := S.Size;
end;
function TUnBufferedTreeNodeStream.ToString: String;
begin
Result := ToString(FRoot, nil);
end;
procedure TUnBufferedTreeNodeStream.ToStringWork(const P, Stop: IANTLRInterface;
const Buf: TStringBuilder);
var
Text: String;
C, N: Integer;
begin
if (not FAdaptor.IsNil(P)) then
begin
Text := FAdaptor.GetNodeText(P);
if (Text = '') then
Text := ' ' + IntToStr(FAdaptor.GetNodeType(P));
Buf.Append(Text); // ask the node to go to string
end;
if SameObj(P, Stop) then
Exit;
N := FAdaptor.GetChildCount(P);
if (N > 0) and (not FAdaptor.IsNil(P)) then
begin
Buf.Append(' ');
Buf.Append(TToken.DOWN);
end;
for C := 0 to N - 1 do
ToStringWork(FAdaptor.GetChild(P, C), Stop, Buf);
if (N > 0) and (not FAdaptor.IsNil(P)) then
begin
Buf.Append(' ');
Buf.Append(TToken.UP);
end;
end;
function TUnBufferedTreeNodeStream.VisitChild(
const Child: Integer): IANTLRInterface;
begin
Result := nil;
// save state
FNodeStack.Push(FCurrentNode);
FIndexStack.Push(Child);
if (Child = 0) and (not FAdaptor.IsNil(FCurrentNode)) then
AddNavigationNode(TToken.DOWN);
// visit child
FCurrentNode := FAdaptor.GetChild(FCurrentNode, Child);
FCurrentChildIndex := 0;
Result := FCurrentNode;
AddLookahead(Result);
WalkBackToMostRecentNodeWithUnvisitedChildren;
end;
procedure TUnBufferedTreeNodeStream.WalkBackToMostRecentNodeWithUnvisitedChildren;
begin
while (FCurrentNode <> nil) and (FCurrentChildIndex >= FAdaptor.GetChildCount(FCurrentNode)) do
begin
FCurrentNode := FNodeStack.Pop;
if (FCurrentNode = nil) then
// hit the root?
Exit;
FCurrentChildIndex := FIndexStack.Pop;
Inc(FCurrentChildIndex); // move to next child
if (FCurrentChildIndex >= FAdaptor.GetChildCount(FCurrentNode)) then
begin
if (not FAdaptor.IsNil(FCurrentNode)) then
AddNavigationNode(TToken.UP);
if SameObj(FCurrentNode, FRoot) then
// we done yet?
FCurrentNode := nil;
end;
end;
end;
function TUnBufferedTreeNodeStream.ToString(const Start,
Stop: IANTLRInterface): String;
var
BeginTokenIndex, EndTokenIndex: Integer;
Buf: TStringBuilder;
begin
if (Start = nil) then
Exit('');
// if we have the token stream, use that to dump text in order
if (FTokens <> nil) then
begin
// don't trust stop node as it's often an UP node etc...
// walk backwards until you find a non-UP, non-DOWN node
// and ask for it's token index.
BeginTokenIndex := FAdaptor.GetTokenStartIndex(Start);
if (Stop <> nil) and (FAdaptor.GetNodeType(Stop) = TToken.UP) then
EndTokenIndex := FAdaptor.GetTokenStopIndex(Start)
else
EndTokenIndex := Size - 1;
Exit(FTokens.ToString(BeginTokenIndex, EndTokenIndex));
end;
Buf := TStringBuilder.Create;
try
ToStringWork(Start, Stop, Buf);
Result := Buf.ToString;
finally
Buf.Free;
end;
end;
{ TUnBufferedTreeNodeStream.TTreeWalkState }
function TUnBufferedTreeNodeStream.TTreeWalkState.GetAbsoluteNodeIndex: Integer;
begin
Result := FAbsoluteNodeIndex;
end;
function TUnBufferedTreeNodeStream.TTreeWalkState.GetCurrentChildIndex: Integer;
begin
Result := FCurrentChildIndex;
end;
function TUnBufferedTreeNodeStream.TTreeWalkState.GetCurrentNode: IANTLRInterface;
begin
Result := FCurrentNode;
end;
function TUnBufferedTreeNodeStream.TTreeWalkState.GetIndexStackSize: integer;
begin
Result := FIndexStackSize;
end;
function TUnBufferedTreeNodeStream.TTreeWalkState.GetLookAhead: TANTLRInterfaceArray;
begin
Result := FLookAhead;
end;
function TUnBufferedTreeNodeStream.TTreeWalkState.GetNodeStackSize: Integer;
begin
Result := FNodeStackSize;
end;
function TUnBufferedTreeNodeStream.TTreeWalkState.GetPreviousNode: IANTLRInterface;
begin
Result := FPreviousNode;
end;
procedure TUnBufferedTreeNodeStream.TTreeWalkState.SetAbsoluteNodeIndex(
const Value: Integer);
begin
FAbsoluteNodeIndex := Value;
end;
procedure TUnBufferedTreeNodeStream.TTreeWalkState.SetCurrentChildIndex(
const Value: Integer);
begin
FCurrentChildIndex := Value;
end;
procedure TUnBufferedTreeNodeStream.TTreeWalkState.SetCurrentNode(
const Value: IANTLRInterface);
begin
FCurrentNode := Value;
end;
procedure TUnBufferedTreeNodeStream.TTreeWalkState.SetIndexStackSize(
const Value: integer);
begin
FIndexStackSize := Value;
end;
procedure TUnBufferedTreeNodeStream.TTreeWalkState.SetLookAhead(
const Value: TANTLRInterfaceArray);
begin
FLookAhead := Value;
end;
procedure TUnBufferedTreeNodeStream.TTreeWalkState.SetNodeStackSize(
const Value: Integer);
begin
FNodeStackSize := Value;
end;
procedure TUnBufferedTreeNodeStream.TTreeWalkState.SetPreviousNode(
const Value: IANTLRInterface);
begin
FPreviousNode := Value;
end;
{ Utilities }
var
EmptyCommonTree: ICommonTree = nil;
function Def(const X: ICommonTree): ICommonTree; overload;
begin
if Assigned(X) then
Result := X
else
begin
if (EmptyCommonTree = nil) then
EmptyCommonTree := TCommonTree.Create;
Result := EmptyCommonTree;
end;
end;
initialization
TTree.Initialize;
end.