Initial check in rtl
This commit is contained in:
@@ -0,0 +1,357 @@
|
||||
{
|
||||
* A Child-Sibling Tree.
|
||||
*
|
||||
* A tree with PLUS at the root and with two children 3 and 4 is
|
||||
* structured as:
|
||||
*
|
||||
* PLUS
|
||||
* |
|
||||
* 3 -- 4
|
||||
*
|
||||
* and can be specified easily in LISP notation as
|
||||
*
|
||||
* (PLUS 3 4)
|
||||
*
|
||||
* where every '(' starts a new subtree.
|
||||
*
|
||||
* These trees are particular useful for translators because of
|
||||
* the flexibility of the children lists. They are also very easy
|
||||
* to walk automatically, whereas trees with specific children
|
||||
* reference fields can't easily be walked automatically.
|
||||
*
|
||||
* This class contains the basic support for an AST.
|
||||
* Most people will create ASTs that are subclasses of
|
||||
* BaseAST or of CommonAST.
|
||||
*/
|
||||
}
|
||||
unit dpgrtl.astBase;
|
||||
|
||||
interface
|
||||
uses
|
||||
System.Classes,
|
||||
Generics.Collections,
|
||||
dpgrtl.Token;
|
||||
|
||||
|
||||
type
|
||||
TAST = class;
|
||||
TASTList = TList<TAST>;
|
||||
|
||||
TAST = class
|
||||
protected
|
||||
fDown : TAST;
|
||||
fRight : TAST;
|
||||
|
||||
fAstText : AnsiString;
|
||||
fAstType : integer;
|
||||
fAstLine : integer;
|
||||
fAstColumn : integer;
|
||||
|
||||
private
|
||||
fVerbose : boolean; // verbose string conversion
|
||||
fTokenNames : TStringList;
|
||||
|
||||
private
|
||||
procedure DoFindAll( NodeToSearch : TAST;
|
||||
// v : Vector;
|
||||
Target : TAST;
|
||||
PartialMatch : boolean);
|
||||
|
||||
protected
|
||||
function GetNumberofChildren: integer;
|
||||
|
||||
function GetEquals( Node : TAST): boolean; virtual;
|
||||
function GetEqualsList( Node : TAST): boolean; virtual;
|
||||
function GetEqualsListPartial( Node : TAST): boolean; virtual;
|
||||
function GetEqualsTree( Node : TAST): boolean; virtual;
|
||||
function GetEqualsTreePartial( Node : TAST): boolean; virtual;
|
||||
|
||||
function GetTokenNames : TStringList;
|
||||
|
||||
procedure SetVerbose( Verbose : boolean;
|
||||
Names : TStringList);
|
||||
|
||||
public
|
||||
procedure Initialize( AstType : integer;
|
||||
AstText : AnsiString); overload; virtual; abstract;
|
||||
|
||||
procedure Initialize( Node : TAST); overload; virtual; abstract;
|
||||
procedure Initialize( Token : TToken); overload; virtual; abstract;
|
||||
|
||||
procedure AddChild( node: TAST);
|
||||
procedure RemoveChildren;
|
||||
|
||||
public
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
|
||||
public
|
||||
property NumberOfChildren : integer read GetNumberofChildren;
|
||||
|
||||
property NextSibling : TAST read fRight write fRight;
|
||||
property FirstChild : TAST read fDown write fDown;
|
||||
|
||||
property AstText : AnsiString read fAstText write fAstText;
|
||||
property AstType : integer read fAstType write fAstType;
|
||||
property AstLine : integer read fAstLine write fAstLine;
|
||||
property AstColumn : integer read fAstColumn write fAstColumn;
|
||||
|
||||
property Equals [n: TAST]: boolean read GetEquals;
|
||||
property EqualsList [n: TAST]: boolean read GetEqualsList;
|
||||
property EqualsListPartial [n: TAST]: boolean read GetEqualsListPartial;
|
||||
property EqualsTree [n: TAST]: boolean read GetEqualsTree;
|
||||
property EqualsTreePartial [n: TAST]: boolean read GetEqualsTreepartial;
|
||||
end;
|
||||
|
||||
TASTClass = class of TAST;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{ TastBase }
|
||||
|
||||
procedure TAST.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
fTokenNames := TStringList.Create;
|
||||
end;
|
||||
|
||||
procedure TAST.BeforeDestruction;
|
||||
begin
|
||||
fTokenNames.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// DoFindAll
|
||||
// ================================================================================================
|
||||
procedure TAST.DoFindAll(NodeToSearch, Target: TAST; PartialMatch: boolean);
|
||||
var
|
||||
sibling: TAST;
|
||||
|
||||
begin
|
||||
// start walking sibling lists, looking for matches
|
||||
sibling := NodeToSearch;
|
||||
|
||||
while Assigned(sibling) do
|
||||
begin
|
||||
if ( PartialMatch and sibling.EqualsTreePartial[Target]) or
|
||||
( not PartialMatch and sibling.EqualsTree[Target]) then
|
||||
// v.appendelement(sibling)
|
||||
;
|
||||
|
||||
if Assigned( sibling.FirstChild) then
|
||||
DoFindAll( sibling.FirstChild, {v,} Target, PartialMatch);
|
||||
|
||||
sibling := sibling.NextSibling
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
// ================================================================================================
|
||||
// Get Number of Children
|
||||
// ================================================================================================
|
||||
function TAST.GetNumberofChildren: integer;
|
||||
var
|
||||
t: TAST;
|
||||
n: integer;
|
||||
|
||||
begin
|
||||
t := fDown;
|
||||
n := 0;
|
||||
|
||||
if Assigned(t) then
|
||||
begin
|
||||
INC(n);
|
||||
|
||||
while Assigned(t.fRight) do
|
||||
begin
|
||||
t := t.fRight;
|
||||
INC(n)
|
||||
end;
|
||||
end;
|
||||
|
||||
result := n
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Equals
|
||||
// ================================================================================================
|
||||
function TAST.GetEquals(Node: TAST): boolean;
|
||||
begin
|
||||
if Assigned(Node)
|
||||
then result := (Node.fAstText = fAstText) and (Node.fAstType = fAstType)
|
||||
else result := false
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Equals List
|
||||
// ================================================================================================
|
||||
function TAST.GetEqualsList(Node: TAST): boolean;
|
||||
var
|
||||
sibling: TAST;
|
||||
|
||||
begin
|
||||
result := false;
|
||||
|
||||
if Assigned(Node) then
|
||||
begin
|
||||
sibling := self;
|
||||
|
||||
while Assigned(sibling) and Assigned(Node) do
|
||||
begin
|
||||
// as a quick optimization, check roots firt
|
||||
if not sibling.Equals[Node] then
|
||||
break;
|
||||
|
||||
// if roots match, do full list match test on children
|
||||
if Assigned( sibling.FirstChild) then
|
||||
begin
|
||||
if not sibling.FirstChild.EqualsList[Node.FirstChild] then
|
||||
break
|
||||
end
|
||||
|
||||
// sibling has no kids, make sure Node doesn't either
|
||||
else if Assigned(Node.FirstChild) then
|
||||
break;
|
||||
|
||||
sibling := sibling .NextSibling;
|
||||
Node := Node .NextSibling;
|
||||
end;
|
||||
|
||||
if not Assigned(sibling) and not Assigned(Node) then
|
||||
result := true
|
||||
end;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Equals List Partial
|
||||
//
|
||||
// Is Node a subtree of this list ? The siblings of the root are NOT ignored.
|
||||
// ================================================================================================
|
||||
function TAST.GetEqualsListPartial(Node: TAST): boolean;
|
||||
var
|
||||
sibling: TAST;
|
||||
|
||||
begin
|
||||
result := false;
|
||||
|
||||
if Assigned(Node) then
|
||||
begin
|
||||
sibling := self;
|
||||
|
||||
while Assigned(sibling) and Assigned(Node) do
|
||||
begin
|
||||
// as a quick optimization, check roots firt
|
||||
if not sibling.Equals[Node] then
|
||||
break;
|
||||
|
||||
// if roots match, do partial list match test on children
|
||||
if Assigned( sibling.FirstChild) then
|
||||
if not sibling.FirstChild.EqualsListPartial[Node.FirstChild] then
|
||||
break
|
||||
end;
|
||||
|
||||
if not Assigned(sibling) and Assigned(Node)
|
||||
then result := false
|
||||
else result := true
|
||||
end;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Equals Tree
|
||||
//
|
||||
// Is the tree rooted at *self* equals to *Node* ?
|
||||
// The sibling of *self* are ignored.
|
||||
// ================================================================================================
|
||||
function TAST.GetEqualsTree(Node: TAST): boolean;
|
||||
begin
|
||||
result := false;
|
||||
|
||||
if Equals[Node] then
|
||||
begin
|
||||
// if roots match, do full list match test on children
|
||||
if Assigned(FirstChild) then
|
||||
begin
|
||||
if not FirstChild.EqualsList[Node.FirstChild] then
|
||||
exit;
|
||||
end
|
||||
|
||||
// No kids, make sure *Node* hasn't either
|
||||
else if Assigned(Node.FirstChild) then
|
||||
exit;
|
||||
end;
|
||||
|
||||
result := true
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Equals Tree Partial
|
||||
// ================================================================================================
|
||||
function TAST.GetEqualsTreePartial(Node: TAST): boolean;
|
||||
begin
|
||||
result := false;
|
||||
|
||||
if Equals[Node] then
|
||||
if Assigned(FirstChild) then
|
||||
if not FirstChild.EqualsListPartial[Node] then
|
||||
exit;
|
||||
|
||||
result := true
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Token Names
|
||||
// ================================================================================================
|
||||
function TAST.GetTokenNames: TStringList;
|
||||
begin
|
||||
result := TStringList.Create;
|
||||
result.AddStrings(fTokenNames);
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Verbose
|
||||
// ================================================================================================
|
||||
procedure TAST.SetVerbose(Verbose: boolean; Names: TStringList);
|
||||
begin
|
||||
fVerbose := Verbose;
|
||||
fTokenNames.Clear;
|
||||
ftokenNames.AddStrings(Names);
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// AddChild
|
||||
// ================================================================================================
|
||||
procedure TAST.AddChild(node: TAST);
|
||||
var
|
||||
n: TAST;
|
||||
|
||||
begin
|
||||
if Assigned(node) then
|
||||
begin
|
||||
n := fDown;
|
||||
|
||||
if Assigned(n) then
|
||||
begin
|
||||
while Assigned(n.fRight) do
|
||||
n := n.fRight;
|
||||
|
||||
n.fRight := node
|
||||
end
|
||||
|
||||
else
|
||||
fDown := node
|
||||
end;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Remove Children
|
||||
// ================================================================================================
|
||||
procedure TAST.RemoveChildren;
|
||||
begin
|
||||
fDown := nil
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,14 @@
|
||||
unit dpgrtl.astCommon;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.astBase;
|
||||
|
||||
type
|
||||
TastCommon = class( TAST)
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,349 @@
|
||||
// AST Support code shared by TreeParser and Parser.
|
||||
// We use delegation to share code (and have only one
|
||||
// bit of code to maintain) rather than subclassing
|
||||
// or superclassing (forces AST support code to be
|
||||
// loaded even when you don't want to do AST stuff).
|
||||
//
|
||||
// Typically, setASTNodeType is used to specify the
|
||||
// homogeneous type of node to create, but you can override
|
||||
// create to make heterogeneous nodes etc...
|
||||
|
||||
unit dpgrtl.astFactory;
|
||||
|
||||
interface
|
||||
uses
|
||||
Generics.Collections,
|
||||
dpgrtl.types,
|
||||
dpgrtl.astBase,
|
||||
dpgrtl.astPair;
|
||||
|
||||
type
|
||||
TTokenToASTMap = TDictionary<integer,TASTClass>;
|
||||
|
||||
TASTFactory = class
|
||||
protected
|
||||
// How to specify the classname to create for a particular
|
||||
// token type. Note that DPG allows you to say, for example,
|
||||
//
|
||||
// tokens
|
||||
// {
|
||||
// PLUS<AST=PLUSNode>;
|
||||
// ...
|
||||
// }
|
||||
//
|
||||
// and it tracks everything statically. #[PLUS] will make you
|
||||
// a PLUSNode w/o use of this table.
|
||||
//
|
||||
// For tokens that DPG cannot track statically like #[i],
|
||||
// you can use this table to map PLUS (Integer) -> PLUSNode (Class)
|
||||
// etc... DPG sets the class map from the tokens {...} section
|
||||
// via the ASTFactory(Hashtable) ctor in antlr.Parser.
|
||||
|
||||
fASTNodeTypeName : AnsiString;
|
||||
fASTNodeTypeClass : TASTClass;
|
||||
|
||||
fTokenToASTMap : TTokenToASTMap;
|
||||
|
||||
protected
|
||||
function GetASTClass( TokenType: integer): TASTClass;
|
||||
procedure SetASTClass( TokenType: integer; ASTClass: TASTClass);
|
||||
|
||||
public
|
||||
function CreateAST( TokenType: integer=TT_INVALID;
|
||||
TokenText: string = ''): TAST; overload;
|
||||
|
||||
function CreateAST( TokenType: integer;
|
||||
TokenText: string;
|
||||
ASTName : string) : TAST; overload;
|
||||
|
||||
function CreateAST( ASTName : string) : TAST; overload;
|
||||
|
||||
function CreateAST( AST : TAST) : TAST; overload;
|
||||
function CreateAST( Token : IToken) : TAST; overload;
|
||||
|
||||
function Clone( AST : TAST) : TAST;
|
||||
function CloneList( AST : TAST) : TAST;
|
||||
function CloneTree( AST : TAST) : TAST;
|
||||
|
||||
function Make( Nodes : array of TAST) : TAST;
|
||||
procedure MakeRoot( ASTPair : TASTPair;
|
||||
Root : TAST);
|
||||
|
||||
|
||||
public
|
||||
constructor Create( map: TTokenToASTMap);
|
||||
destructor Destroy; override;
|
||||
|
||||
public
|
||||
property ASTClass[t: integer] : TASTClass read GetASTClass
|
||||
write SetASTClass;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
uses
|
||||
System.RTTI,
|
||||
dpgrtl.astCommon,
|
||||
System.SysUtils;
|
||||
|
||||
{ TASTFactory }
|
||||
|
||||
// ================================================================================================
|
||||
// Constructor
|
||||
// ================================================================================================
|
||||
constructor TASTFactory.Create(map: TTokenToASTMap);
|
||||
begin
|
||||
inherited Create;
|
||||
fTokenToASTMap := TTokenToASTMap.Create;
|
||||
|
||||
// SetTokenToASTMap(map);
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Destructor
|
||||
// ================================================================================================
|
||||
destructor TASTFactory.Destroy;
|
||||
begin
|
||||
FreeAndNil(fTokenToASTMap);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Interface
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Create AST (TokenType,TokenText)
|
||||
//
|
||||
// Create a new empty AST node. If the user did not specify an AST node type, then create a
|
||||
// default one: *TastCommon*
|
||||
// ================================================================================================
|
||||
function TASTFactory.CreateAST(TokenType: integer; TokenText: string): TAST;
|
||||
begin
|
||||
result := ASTClass[TokenType].Create;
|
||||
|
||||
if Assigned(result) then
|
||||
result.Initialize( TokenType, AnsiString(TokenText));
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Create AST (AST Class Name)
|
||||
// ================================================================================================
|
||||
function TASTFactory.CreateAST(ASTName: string): TAST;
|
||||
var
|
||||
ctx : TRttiContext;
|
||||
typ : TRttiType;
|
||||
|
||||
begin
|
||||
result := nil;
|
||||
ctx := TRttiContext.Create;
|
||||
typ := ctx.FindType(ASTName);
|
||||
|
||||
if Assigned(typ) then
|
||||
result := TASTClass(typ).Create;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Create AST
|
||||
// ================================================================================================
|
||||
function TASTFactory.CreateAST(TokenType: integer; TokenText, ASTName: string): TAST;
|
||||
begin
|
||||
result := CreateAST( ASTName);
|
||||
|
||||
if Assigned(result) then
|
||||
result.Initialize( TokenType, AnsiString(TokenText))
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Create AST
|
||||
// ================================================================================================
|
||||
function TASTFactory.CreateAST(AST: TAST): TAST;
|
||||
begin
|
||||
result := nil;
|
||||
|
||||
if Assigned(AST) then
|
||||
result := CreateAST(AST.ClassName);
|
||||
|
||||
if Assigned(result) then
|
||||
result.Initialize( AST.AstType, AST.AstText);
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Create AST
|
||||
// ================================================================================================
|
||||
function TASTFactory.CreateAST(Token: IToken): TAST;
|
||||
begin
|
||||
result := nil;
|
||||
|
||||
if Assigned(Token) then
|
||||
result := CreateAST( Token.TokenType, string(Token.TokenText))
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Clone
|
||||
// ================================================================================================
|
||||
function TASTFactory.Clone( AST: TAST) : TAST;
|
||||
begin
|
||||
result := nil;
|
||||
|
||||
if Assigned(AST) then
|
||||
result := CreateAST(AST);
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Clone List
|
||||
//
|
||||
// Duplicate a tree including siblings of root.
|
||||
// ================================================================================================
|
||||
function TASTFactory.CloneList( AST: TAST): TAST;
|
||||
var
|
||||
nt: TAST;
|
||||
|
||||
begin
|
||||
result := CloneTree(AST);
|
||||
nt := result;
|
||||
|
||||
while Assigned(AST) do
|
||||
begin
|
||||
AST := AST.NextSibling;
|
||||
|
||||
nt.NextSibling := CloneTree(AST);
|
||||
nt := nt.NextSibling;
|
||||
end;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Clone Tree
|
||||
//
|
||||
// Duplicate a tree, assuming this is a root node of a tree.
|
||||
// Duplicate that node and what's below; ignore siblings of a root node.
|
||||
// ================================================================================================
|
||||
function TASTFactory.CloneTree( AST: TAST): TAST;
|
||||
begin
|
||||
result := Clone(AST);
|
||||
|
||||
if Assigned(result) then
|
||||
result.FirstChild := CloneList( AST.FirstChild)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Make
|
||||
//
|
||||
// Make a tree from a list of nodes. The first element in the array is the root.
|
||||
// If the root is null, then the tree is a simple list not a tree.
|
||||
// Handles null children nodes correctly.
|
||||
//
|
||||
// For example, build(a, b, null, c) yields tree (a b c).
|
||||
// build(null,a,b) yields tree (nil a b).
|
||||
// ================================================================================================
|
||||
function TASTFactory.Make(Nodes: array of TAST): TAST;
|
||||
var
|
||||
i : integer;
|
||||
root : TAST;
|
||||
tail : TAST;
|
||||
|
||||
begin
|
||||
result := nil;
|
||||
|
||||
if Length(Nodes) > 0 then
|
||||
begin
|
||||
root := Nodes[Low(Nodes)];
|
||||
tail := nil;
|
||||
|
||||
if Assigned(root) then
|
||||
root.FirstChild := nil;
|
||||
|
||||
// link in children
|
||||
for i:=Low(Nodes)+1 to High(Nodes) do
|
||||
begin
|
||||
// ignore nil nodes
|
||||
if Nodes[i] = nil then
|
||||
continue;
|
||||
|
||||
if not Assigned(root) then
|
||||
begin
|
||||
root := nodes[i];
|
||||
tail := nodes[i];
|
||||
end
|
||||
|
||||
else if not Assigned(tail) then
|
||||
begin
|
||||
root.FirstChild := Nodes[i];
|
||||
tail := root.FirstChild;
|
||||
end
|
||||
|
||||
else begin
|
||||
tail.NextSibling:= Nodes[i];
|
||||
tail := tail.NextSibling;
|
||||
end;
|
||||
|
||||
while Assigned(tail.NextSibling) do
|
||||
tail := tail.NextSibling;
|
||||
end
|
||||
end
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Make root
|
||||
// ================================================================================================
|
||||
procedure TASTFactory.MakeRoot(ASTPair: TASTPair; Root: TAST);
|
||||
begin
|
||||
if Assigned(Root) then
|
||||
begin
|
||||
Root.AddChild(ASTPair.Root);
|
||||
|
||||
ASTPair.Child := ASTPair.Root;
|
||||
ASTPair.AdvanceChildToEnd;
|
||||
ASTPair.Root := Root;
|
||||
end
|
||||
end;
|
||||
|
||||
// @@@: Property handlers +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Property handlers
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Get the AST class that assigned to a token type
|
||||
// ================================================================================================
|
||||
function TASTFactory.GetASTClass(TokenType: integer): TASTClass;
|
||||
begin
|
||||
result := nil;
|
||||
|
||||
if Assigned( fTokenToASTMap) then
|
||||
fTokenToASTMap.TryGetValue( TokenType, result);
|
||||
|
||||
if not Assigned(result) then
|
||||
result := fASTNodeTypeClass;
|
||||
|
||||
if not Assigned(result) then
|
||||
result := TastCommon;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Assign an AST class to a token type
|
||||
// ================================================================================================
|
||||
procedure TASTFactory.SetASTClass(TokenType: integer; ASTClass: TASTClass);
|
||||
begin
|
||||
if Assigned( fTokenToASTMap) then
|
||||
begin
|
||||
if fTokenToASTMap.ContainsKey(TokenType) then
|
||||
fTokenToASTMap.Remove(TokenType);
|
||||
|
||||
if Assigned(ASTClass) then
|
||||
fTokenToASTMap.Add(TokenType,ASTClass)
|
||||
end
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,64 @@
|
||||
unit dpgrtl.astPair;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.astBase;
|
||||
|
||||
type
|
||||
TASTPair = class
|
||||
public
|
||||
Root : TAST;
|
||||
Child : TAST;
|
||||
|
||||
public
|
||||
procedure AdvanceChildToEnd;
|
||||
function Clone: TASTPair;
|
||||
function ToString: string; override;
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TASTPair }
|
||||
|
||||
// ================================================================================================
|
||||
// Advance Child To End
|
||||
// ================================================================================================
|
||||
procedure TASTPair.AdvanceChildToEnd;
|
||||
begin
|
||||
if Assigned(Child) then
|
||||
while Assigned( Child.NextSibling) do
|
||||
Child := Child.NextSibling
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Clone
|
||||
// ================================================================================================
|
||||
function TASTPair.Clone: TASTPair;
|
||||
begin
|
||||
result := TASTPair.Create;
|
||||
result.Root := Root;
|
||||
result.Child := Child;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// As String
|
||||
// ================================================================================================
|
||||
function TASTPair.ToString: string;
|
||||
var
|
||||
r: string;
|
||||
c: string;
|
||||
|
||||
begin
|
||||
if Assigned(Root)
|
||||
then r := Root.ToString
|
||||
else r := 'nil';
|
||||
|
||||
if Assigned(Child)
|
||||
then c := Child.ToString
|
||||
else c := 'nil';
|
||||
|
||||
result := '[' + r + ',' + c + ']'
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,156 @@
|
||||
// TODO: jo lenne cache-elni az LA(x) karaktereket...
|
||||
|
||||
unit dpgrtl.charbuffer;
|
||||
|
||||
interface
|
||||
uses
|
||||
System.Classes,
|
||||
dpgrtl.types,
|
||||
dpgrtl.inputbuffer,
|
||||
dpgrtl.charqueue;
|
||||
|
||||
type
|
||||
TCharBuffer = class( TInputBuffer, IInputBuffer, ICharBuffer)
|
||||
protected
|
||||
fStream : TStream;
|
||||
fQueue : TCharQueue;
|
||||
|
||||
protected
|
||||
function GetNext: AnsiChar;
|
||||
procedure Fill( Amount: integer);
|
||||
|
||||
// ------------------------------------------------------------
|
||||
// TInputBuffer overrides
|
||||
// ------------------------------------------------------------
|
||||
protected
|
||||
procedure Remove( ACount: integer); override;
|
||||
|
||||
// ------------------------------------------------------------
|
||||
// ICharBuffer
|
||||
// ------------------------------------------------------------
|
||||
protected
|
||||
function LA( i: integer): AnsiChar;
|
||||
|
||||
// ------------------------------------------------------------
|
||||
// Construction/destruction
|
||||
// ------------------------------------------------------------
|
||||
public
|
||||
constructor Create( AStream: TStream);
|
||||
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TCharBuffer }
|
||||
|
||||
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Constructor
|
||||
// ================================================================================================
|
||||
constructor TCharBuffer.Create(AStream: TStream);
|
||||
begin
|
||||
inherited Create;
|
||||
fStream := AStream
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// After Destruction
|
||||
// ================================================================================================
|
||||
procedure TCharBuffer.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fMarkerCount := 0;
|
||||
fMarkerOffset := 0;
|
||||
fNumToConsume := 0;
|
||||
|
||||
fQueue := TCharQueue.Create
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TCharBuffer.BeforeDestruction;
|
||||
begin
|
||||
fQueue.Free;
|
||||
inherited
|
||||
end;
|
||||
|
||||
// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Interface
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// LA
|
||||
//
|
||||
// Ensures that the 'fQueue' object holds sufficient characters, and gets the 'i'th Look Ahead
|
||||
// character from the 'fQueue'.
|
||||
// ================================================================================================
|
||||
function TCharBuffer.LA(i: integer): AnsiChar;
|
||||
begin
|
||||
Fill(i);
|
||||
result := fQueue.Items[fMarkerOffset +i]
|
||||
end;
|
||||
|
||||
// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Internals
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Get Next
|
||||
// ================================================================================================
|
||||
function TCharBuffer.GetNext: AnsiChar;
|
||||
begin
|
||||
if fStream.Read( result, 1) <> 1 then
|
||||
result := #0
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Fill
|
||||
// ================================================================================================
|
||||
procedure TCharBuffer.Fill(Amount: integer);
|
||||
begin
|
||||
SyncConsume;
|
||||
|
||||
while fQueue.Count < (Amount +fMarkerOffset) do
|
||||
fQueue.Add(GetNext)
|
||||
end;
|
||||
|
||||
// @@@: Overrides +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Overrides
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Remove
|
||||
// ================================================================================================
|
||||
procedure TCharBuffer.Remove(ACount: integer);
|
||||
begin
|
||||
fQueue.Remove(ACount)
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,291 @@
|
||||
unit dpgrtl.charqueue;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types;
|
||||
|
||||
type
|
||||
TCharQueue = class( TInterfacedObject)
|
||||
private
|
||||
fBlockLog : integer; // log2 of block size
|
||||
fBlockSize : integer; // block size
|
||||
|
||||
fOffset : integer; // logical start of the vector
|
||||
fCount : integer; // items in a vector
|
||||
fArray : TCharMatrix; // data
|
||||
|
||||
private
|
||||
procedure Expand( i: integer);
|
||||
|
||||
protected
|
||||
function GetItem( i:integer): AnsiChar;
|
||||
procedure SetItem( i:integer; Value:AnsiChar);
|
||||
|
||||
public
|
||||
procedure Clear;
|
||||
procedure Add( Value : AnsiChar);
|
||||
procedure Remove( ACount: integer);
|
||||
|
||||
public
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
|
||||
public
|
||||
property Count : integer read fCount;
|
||||
property Items[i:integer] : AnsiChar read GetItem write SetItem;
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
System.Math,
|
||||
System.SysUtils;
|
||||
|
||||
{ TCharQueue }
|
||||
|
||||
// @@@: construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TCharQueue.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fBlockLog := trunc( log2( 4096));
|
||||
fBlockSize := trunc( IntPower(2, fBlockLog));
|
||||
|
||||
fArray := nil;
|
||||
fOffset := 0;
|
||||
fCount := 0;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TCharQueue.BeforeDestruction;
|
||||
var
|
||||
i: integer;
|
||||
|
||||
begin
|
||||
Clear;
|
||||
|
||||
for i:=Low(fArray) to High(fArray) do
|
||||
fArray[i] := nil;
|
||||
|
||||
fArray := nil;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Interface
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Add
|
||||
// ================================================================================================
|
||||
procedure TCharQueue.Add(Value: AnsiChar);
|
||||
begin
|
||||
Items[ fCount +1] := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Remove
|
||||
//
|
||||
// Removes 'Count' items from the beginning of the queue. If the 'Count' is bigger than the
|
||||
// count then simply clear the Queue.
|
||||
// ================================================================================================
|
||||
procedure TCharQueue.Remove( ACount: integer);
|
||||
var
|
||||
tmp: TCharMatrix;
|
||||
i : integer;
|
||||
|
||||
begin
|
||||
if ACount > 0 then
|
||||
begin
|
||||
// ------------------------------------------------------------
|
||||
// if the removable item count > than the item count, then
|
||||
// simply clear the queue...
|
||||
// ------------------------------------------------------------
|
||||
if ACount > fCount then
|
||||
Clear
|
||||
|
||||
|
||||
// ------------------------------------------------------------
|
||||
// ...else calculate the new offset and count values. If the
|
||||
// one or more blocks in the vector beginning is freed, then
|
||||
// move these blocks to the end of the vector.
|
||||
// ------------------------------------------------------------
|
||||
else begin
|
||||
INC( fOffset, ACount);
|
||||
DEC( fCount, ACount);
|
||||
|
||||
SetLength( tmp, 1);
|
||||
|
||||
// ---------------------------------------------------------
|
||||
// Well, not so efficient, but simple
|
||||
// ---------------------------------------------------------
|
||||
while fOffset > fBlockSize -1 do
|
||||
begin
|
||||
tmp[0] := fArray[0];
|
||||
|
||||
// --------------------------------------------
|
||||
// clear the free block
|
||||
// --------------------------------------------
|
||||
for i:=0 to High(tmp[0]) do
|
||||
tmp[0,i] := #0;
|
||||
|
||||
// --------------------------------------------
|
||||
// shift blocks down
|
||||
// --------------------------------------------
|
||||
for i:=0 to High(fArray)-1 do
|
||||
fArray[i] := fArray[i+1];
|
||||
|
||||
// --------------------------------------------
|
||||
// set the vector's last block
|
||||
// --------------------------------------------
|
||||
fArray[High(fArray)] := tmp[0];
|
||||
|
||||
DEC( fOffset, fBlockSize)
|
||||
end;
|
||||
|
||||
tmp := nil
|
||||
end
|
||||
end
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Clear
|
||||
//
|
||||
// This is a real pain in the ass. I'm not in the mood to optimize it.
|
||||
// ================================================================================================
|
||||
procedure TCharQueue.Clear;
|
||||
var
|
||||
i: integer;
|
||||
|
||||
begin
|
||||
for i:=1 to fCount do
|
||||
Items[i] := #0;
|
||||
|
||||
fOffset := 0;
|
||||
fCount := 0;
|
||||
end;
|
||||
|
||||
|
||||
// @@@: Property Handlers +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Property Handlers
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Get Item
|
||||
//
|
||||
// Get the item specified by it's index. If the index less than 1 or bigger than the size of
|
||||
// the queue, an ERangeError exception will be generated.
|
||||
// ================================================================================================
|
||||
function TCharQueue.GetItem(i: integer): AnsiChar;
|
||||
var
|
||||
block: integer;
|
||||
index: integer;
|
||||
|
||||
begin
|
||||
// -------------------------------------------------------------------------
|
||||
// Check for valid index value.
|
||||
// -------------------------------------------------------------------------
|
||||
if i > fCount then raise ERangeError.CreateFmt( 'Index "%d" is too big', [i]);
|
||||
if i < 1 then raise ERangeError.CreateFmt( 'Index is less than 1', []);
|
||||
|
||||
// -------------------------------------------------------------------------
|
||||
// Now process the request.
|
||||
// -------------------------------------------------------------------------
|
||||
block := (i -1 +fOffset) shr fBlockLog;
|
||||
index := (i -1 +fOffset) and (fBlockSize -1);
|
||||
|
||||
result := fArray[block,index];
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Item
|
||||
//
|
||||
// Set the item specified by it's index. If the the index bigger than the count of the Queue
|
||||
// then the Queue will be resized to hold this data. If the index less than 1 an ERangeError
|
||||
// exception will be generated.
|
||||
// ================================================================================================
|
||||
procedure TCharQueue.SetItem(i: integer; Value: AnsiChar);
|
||||
var
|
||||
block: integer;
|
||||
index: integer;
|
||||
|
||||
begin
|
||||
// -------------------------------------------------------------------------
|
||||
// Check for valid index value.
|
||||
// -------------------------------------------------------------------------
|
||||
if i < 1 then raise ERangeError.CreateFmt( 'Index is less than 1', []);
|
||||
|
||||
// -------------------------------------------------------------------------
|
||||
// If the index bigger than the size of the Queue then expand the Queue.
|
||||
// -------------------------------------------------------------------------
|
||||
if i > fCount then
|
||||
begin
|
||||
Expand(i);
|
||||
fCount := i;
|
||||
end;
|
||||
|
||||
// -------------------------------------------------------------------------
|
||||
// Now process the request.
|
||||
// -------------------------------------------------------------------------
|
||||
block := (i -1 +fOffset) shr fBlockLog;
|
||||
index := (i -1 +fOffset) and (fBlockSize -1);
|
||||
|
||||
fArray[block,index] := Value
|
||||
end;
|
||||
|
||||
// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Internals
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Expand
|
||||
//
|
||||
// Expands the Queue. The size of expanding is always fBlockSize*n.
|
||||
// ================================================================================================
|
||||
procedure TCharQueue.Expand(i: integer);
|
||||
var
|
||||
hi: integer;
|
||||
bn: integer;
|
||||
j : integer;
|
||||
|
||||
begin
|
||||
if (i-1)+fOffset >= (High(fArray)+1) * fBlockSize then
|
||||
begin
|
||||
hi := High(fArray) +1;
|
||||
bn := (i-1+fOffset) shr fBlockLog;
|
||||
|
||||
SetLength( fArray, bn+1);
|
||||
|
||||
for j:=hi to bn do
|
||||
SetLength( fArray[j], fBlockSize);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,258 @@
|
||||
unit dpgrtl.exception;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types,
|
||||
System.SysUtils;
|
||||
|
||||
type
|
||||
EException = class(Exception)
|
||||
strict protected
|
||||
fFileName : string;
|
||||
fLine : integer;
|
||||
fColumn : integer;
|
||||
|
||||
public
|
||||
constructor Create( AFileName : string;
|
||||
ALine : integer;
|
||||
AColumn : integer);
|
||||
|
||||
public
|
||||
property FileName : string read fFileName;
|
||||
property Line : integer read fLine;
|
||||
property Column : integer read fColumn;
|
||||
|
||||
end;
|
||||
|
||||
EMismatchedChar = class( EException)
|
||||
strict protected
|
||||
fCharSet : TCharSet;
|
||||
fString : AnsiString;
|
||||
|
||||
fFoundChar : AnsiChar;
|
||||
fFoundString: AnsiString;
|
||||
|
||||
fInverted : boolean;
|
||||
|
||||
public
|
||||
function ToString: string; override;
|
||||
|
||||
public
|
||||
constructor Create( AFoundChar : AnsiChar;
|
||||
ACharSet : TCharSet;
|
||||
AFileName : string;
|
||||
ALine : integer;
|
||||
AColumn : integer;
|
||||
AInverted : boolean=false); overload;
|
||||
|
||||
constructor Create( AFoundString : AnsiString;
|
||||
AExpectedString : AnsiString;
|
||||
AFileName : string;
|
||||
ALine : integer;
|
||||
AColumn : integer); overload;
|
||||
|
||||
|
||||
|
||||
public
|
||||
property FoundChar : AnsiChar read fFoundChar;
|
||||
property FoundString : AnsiString read fFoundString;
|
||||
property CharSet : TCharSet read fCharSet;
|
||||
property Str : AnsiString read fString;
|
||||
property Inverted : boolean read fInverted;
|
||||
end;
|
||||
|
||||
EMismatchedToken = class (EException)
|
||||
strict protected
|
||||
fToken : IToken;
|
||||
fTokenSet : TByteSet;
|
||||
fFoundToken : IToken;
|
||||
fInverted : boolean;
|
||||
|
||||
public
|
||||
constructor Create( AFoundToken : IToken;
|
||||
ATokenType : byte;
|
||||
AFileName : string;
|
||||
AInverted : boolean=false); overload;
|
||||
|
||||
constructor Create( AFoundToken : IToken;
|
||||
ATokenSet : TByteSet;
|
||||
AFileName : string;
|
||||
AInverted : boolean=false); overload;
|
||||
|
||||
procedure BeforeDestruction; override;
|
||||
|
||||
public
|
||||
property FoundToken : IToken read fFoundToken;
|
||||
property TokenSet : TByteSet read fTokenSet;
|
||||
property Inverted : boolean read fInverted;
|
||||
end;
|
||||
|
||||
ESemantic = class (EException)
|
||||
strict protected
|
||||
fAssert : AnsiString;
|
||||
|
||||
public
|
||||
constructor Create( ASemPred : AnsiString;
|
||||
AFileName : string;
|
||||
ALine : integer=0;
|
||||
AColumn : integer=0);
|
||||
|
||||
public
|
||||
property Assert: AnsiString read fAssert;
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ EException }
|
||||
|
||||
// @@@: EException ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// EException
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// constructor
|
||||
// ================================================================================================
|
||||
constructor EException.Create(AFileName: string; ALine, AColumn: integer);
|
||||
begin
|
||||
fFileName := AFileName;
|
||||
fLine := ALine;
|
||||
fColumn := AColumn;
|
||||
end;
|
||||
|
||||
{ EMismatchedChar }
|
||||
|
||||
// @@@: EMismatchedChar +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// EMismatchedChar
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// constructor([char..char])
|
||||
// ================================================================================================
|
||||
constructor EMismatchedChar.Create( AFoundChar : AnsiChar;
|
||||
ACharSet : TCharSet;
|
||||
AFileName : string;
|
||||
ALine : integer;
|
||||
AColumn : integer;
|
||||
AInverted : boolean=false);
|
||||
begin
|
||||
inherited Create( AFileName, ALine, AColumn);
|
||||
|
||||
fCharSet := ACharSet;
|
||||
fString := '';
|
||||
|
||||
fFoundChar := AFoundChar;
|
||||
fFoundString := '';
|
||||
|
||||
fInverted := AInverted
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// constructor(string)
|
||||
// ================================================================================================
|
||||
constructor EMismatchedChar.Create( AFoundString : AnsiString;
|
||||
AExpectedString : AnsiString;
|
||||
AFileName : string;
|
||||
ALine : integer;
|
||||
AColumn : integer);
|
||||
begin
|
||||
inherited Create( AFileName, ALine, AColumn);
|
||||
|
||||
fCharSet := [];
|
||||
fString := AExpectedString;
|
||||
|
||||
fFoundChar := #0;
|
||||
fFoundString := AFoundString;
|
||||
|
||||
fInverted := false
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// ToString
|
||||
// ================================================================================================
|
||||
function EMismatchedChar.ToString: string;
|
||||
begin
|
||||
result := '?'
|
||||
end;
|
||||
|
||||
{ EMismatchedToken }
|
||||
|
||||
// @@@: EMismatchedToken ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// EMismatchedToken
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// constructor
|
||||
// ================================================================================================
|
||||
constructor EMismatchedToken.Create(AFoundToken : IToken;
|
||||
ATokenType : byte;
|
||||
AFileName : string;
|
||||
AInverted : boolean=false);
|
||||
begin
|
||||
inherited Create(AFileName, AFoundToken.TokenLine, AFoundToken.TokenColumn);
|
||||
|
||||
fFoundToken := AFoundToken;
|
||||
fTokenSet := [ATokenType];
|
||||
fInverted := AInverted
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// constructor
|
||||
// ================================================================================================
|
||||
constructor EMismatchedToken.Create(AFoundToken : IToken;
|
||||
ATokenSet : TByteSet;
|
||||
AFileName : string;
|
||||
AInverted : boolean=false);
|
||||
begin
|
||||
inherited Create(AFileName, AFoundToken.TokenLine, AFoundToken.TokenColumn);
|
||||
|
||||
fFoundToken := AFoundToken;
|
||||
fTokenSet := ATokenSet;
|
||||
fInverted := AInverted
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure EMismatchedToken.BeforeDestruction;
|
||||
begin
|
||||
fFoundToken := nil;
|
||||
inherited
|
||||
end;
|
||||
|
||||
{ ESemantic }
|
||||
|
||||
// @@@: ESemantic +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// ESemantic
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// constructor
|
||||
// ================================================================================================
|
||||
constructor ESemantic.Create(ASemPred: AnsiString; AFileName: string; ALine, AColumn: integer);
|
||||
begin
|
||||
inherited Create( AFileName, ALine, AColumn);
|
||||
fAssert := ASemPred
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,123 @@
|
||||
unit dpgrtl.inputbuffer;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types;
|
||||
|
||||
type
|
||||
TInputBuffer = class( TInterfacedObject, IInputBuffer)
|
||||
protected
|
||||
fMarkerCount : integer;
|
||||
fMarkerOffset : integer;
|
||||
fNumToConsume : integer;
|
||||
|
||||
protected
|
||||
procedure Remove( Num: integer); virtual; abstract;
|
||||
procedure SyncConsume; inline;
|
||||
|
||||
protected
|
||||
function GetMarked: boolean; inline;
|
||||
|
||||
procedure Consume; inline;
|
||||
procedure Commit; inline;
|
||||
|
||||
function Mark: integer;
|
||||
procedure Rewind( Value: integer);
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{ TInputBuffer }
|
||||
|
||||
// @@@: IInputBuffer implementation +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// IInputBuffer implementation
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Mark
|
||||
//
|
||||
// Returns an integer marker theh can be used to rewind the buffer to its current state.
|
||||
// ================================================================================================
|
||||
function TInputBuffer.Mark: integer;
|
||||
begin
|
||||
SyncConsume;
|
||||
INC( fMarkerCount);
|
||||
|
||||
result := fMarkerOffset
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Consume
|
||||
//
|
||||
// Mark another input item for deferred consumption.
|
||||
// ================================================================================================
|
||||
procedure TInputBuffer.Consume;
|
||||
begin
|
||||
INC( fNumToConsume);
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Commit
|
||||
//
|
||||
// This method updates the state of the input buffer so that the text matched since the most
|
||||
// recent Mark() is no longer held by the buffer. So, you either do a mark/rewind for failed
|
||||
// predicate or mark/commit to keep on parsing without rewinding the input.
|
||||
// ================================================================================================
|
||||
procedure TInputBuffer.Commit;
|
||||
begin
|
||||
if fMarkerCount > 0 then
|
||||
DEC( fMarkerCount)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Rewind
|
||||
//
|
||||
// Rewind the character buffer to a marker. 'Value' marker returned previously from mark.
|
||||
// ================================================================================================
|
||||
procedure TInputBuffer.Rewind(Value: integer);
|
||||
begin
|
||||
SyncConsume;
|
||||
|
||||
fMarkerOffset := Value;
|
||||
DEC( fMarkerCount)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// GetMarked
|
||||
// ================================================================================================
|
||||
function TInputBuffer.GetMarked: boolean;
|
||||
begin
|
||||
result := fMarkerCount <> 0
|
||||
end;
|
||||
|
||||
// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Internals
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Sync Consume
|
||||
// ================================================================================================
|
||||
procedure TInputBuffer.SyncConsume;
|
||||
begin
|
||||
if fNumToConsume > 0 then
|
||||
begin
|
||||
if fMarkerCount > 0
|
||||
then INC( fMarkerOffset, fNumToConsume)
|
||||
else Remove( fNumToConsume);
|
||||
|
||||
fNumToConsume := 0
|
||||
end
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,593 @@
|
||||
unit dpgrtl.lexer;
|
||||
|
||||
interface
|
||||
uses
|
||||
System.Classes,
|
||||
System.SysUtils,
|
||||
System.AnsiStrings,
|
||||
dpgrtl.types,
|
||||
dpgrtl.token,
|
||||
dpgrtl.stringmap,
|
||||
dpgrtl.lexerstate;
|
||||
|
||||
type
|
||||
TLexer = class( TInterfacedObject, ITokenStream)
|
||||
protected
|
||||
TokenText : AnsiString;
|
||||
|
||||
fTokenClass : TTokenClass;
|
||||
fLexerState : ILexerState;
|
||||
fLiterals : TStringMap;
|
||||
|
||||
fCaseSensitive : boolean;
|
||||
fSaveConsumedInput: boolean;
|
||||
|
||||
fReturnToken : IToken;
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// Property Handlers
|
||||
// ----------------------------------------------------------------------
|
||||
private
|
||||
function GetTokenClass: TTokenClass;
|
||||
procedure SetTokenClass( AClass: TTokenClass);
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// ITokenStream
|
||||
// ----------------------------------------------------------------------
|
||||
protected
|
||||
function NextToken: IToken; virtual; abstract;
|
||||
|
||||
protected
|
||||
// -------------------------------------------------------------------
|
||||
procedure Append( AChar : AnsiChar); overload;
|
||||
procedure Append( AString : AnsiString); overload;
|
||||
|
||||
// -------------------------------------------------------------------
|
||||
procedure Consume;
|
||||
procedure ConsumeUntil( AChar : AnsiChar); overload;
|
||||
procedure ConsumeUntil( ASet : TCharSet); overload;
|
||||
|
||||
// -------------------------------------------------------------------
|
||||
procedure MatchNot( AChar : AnsiChar);
|
||||
|
||||
procedure Match( AChar : AnsiChar); overload;
|
||||
procedure Match( ASet : TCharSet); overload;
|
||||
procedure Match( AString : AnsiString); overload;
|
||||
procedure Match( AChar1 : AnsiChar;
|
||||
AChar2 : AnsiChar); overload;
|
||||
|
||||
// -------------------------------------------------------------------
|
||||
function TestLiteral( AType : integer): integer; overload;
|
||||
function TestLiteral( AText : AnsiString;
|
||||
AType : integer): integer; overload;
|
||||
|
||||
// -------------------------------------------------------------------
|
||||
procedure Tab; virtual;
|
||||
procedure UponEof; virtual;
|
||||
procedure Initialize; virtual;
|
||||
procedure ReportError( e: Exception); virtual;
|
||||
|
||||
// -------------------------------------------------------------------
|
||||
function LA(i:integer): AnsiChar;
|
||||
function Mark: integer;
|
||||
procedure Rewind( Pos: integer);
|
||||
procedure Commit;
|
||||
procedure NewLine;
|
||||
procedure ResetText;
|
||||
|
||||
// -------------------------------------------------------------------
|
||||
function MakeToken( ATokenType : integer;
|
||||
ATokenText : AnsiString=''): IToken;
|
||||
|
||||
public
|
||||
constructor Create( ABuffer: ICharBuffer); overload;
|
||||
constructor Create( AState : ILexerState); overload;
|
||||
constructor Create( AStream: TStream); overload;
|
||||
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
|
||||
public
|
||||
property SaveConsumedInput : boolean read fSaveConsumedInput
|
||||
write fSaveConsumedInput;
|
||||
|
||||
property CaseSensitive : boolean read fCaseSensitive
|
||||
write fCaseSensitive;
|
||||
|
||||
property TokenClass : TTokenClass read GetTokenClass
|
||||
write SetTokenClass;
|
||||
|
||||
property InputState : ILexerState read fLexerState
|
||||
write fLexerState;
|
||||
|
||||
property ReturnToken : IToken read fReturnToken
|
||||
write fReturnToken;
|
||||
end;
|
||||
|
||||
TLexerClass = class of TLexer;
|
||||
|
||||
implementation
|
||||
uses
|
||||
dpgrtl.exception;
|
||||
|
||||
{ TLexer }
|
||||
|
||||
|
||||
|
||||
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Constructor(ICharBuffer)
|
||||
// ================================================================================================
|
||||
constructor TLexer.Create( ABuffer: ICharBuffer);
|
||||
begin
|
||||
inherited Create;
|
||||
fLexerState := TLexerState.Create( ABuffer);
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Constructor(ILexerState)
|
||||
// ================================================================================================
|
||||
constructor TLexer.Create( AState: ILexerState);
|
||||
begin
|
||||
inherited Create;
|
||||
fLexerState := AState
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Constructor(TStream)
|
||||
// ================================================================================================
|
||||
constructor TLexer.Create( AStream: TStream);
|
||||
begin
|
||||
inherited Create;
|
||||
fLexerState := TLexerState.Create( AStream)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TLexer.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fLiterals := TStringMap.Create;
|
||||
fLiterals.CaseSensitive := true;
|
||||
fCaseSensitive := true;
|
||||
fSaveConsumedInput := true;
|
||||
|
||||
Initialize;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TLexer.BeforeDestruction;
|
||||
begin
|
||||
fLexerState := nil;
|
||||
fLiterals.Free;
|
||||
|
||||
inherited
|
||||
end;
|
||||
|
||||
|
||||
|
||||
// @@@: Property Handlers +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Property Handlers
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Get Token Class
|
||||
// ================================================================================================
|
||||
function TLexer.GetTokenClass: TTokenClass;
|
||||
begin
|
||||
if fTokenClass = nil
|
||||
then result := TToken
|
||||
else result := fTokenClass
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Token Class
|
||||
// ================================================================================================
|
||||
procedure TLexer.SetTokenClass( AClass: TTokenClass);
|
||||
begin
|
||||
fTokenClass := AClass
|
||||
end;
|
||||
|
||||
|
||||
|
||||
// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Internals
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Append(Char)
|
||||
// ================================================================================================
|
||||
procedure TLexer.Append( AChar: AnsiChar);
|
||||
begin
|
||||
if fSaveConsumedInput then
|
||||
TokenText := TokenText +AChar
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Append(String)
|
||||
// ================================================================================================
|
||||
procedure TLexer.Append( AString: AnsiString);
|
||||
begin
|
||||
if fSaveConsumedInput then
|
||||
TokenText := TokenText +AString
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Consume
|
||||
// ================================================================================================
|
||||
procedure TLexer.Consume;
|
||||
var
|
||||
chr: AnsiChar;
|
||||
|
||||
begin
|
||||
chr := LA(1);
|
||||
|
||||
if fLexerState.Guessing = 0 then
|
||||
begin
|
||||
Append(chr);
|
||||
|
||||
if chr = #9
|
||||
then TAB
|
||||
else fLexerState.Column := fLexerState.Column +1;
|
||||
end;
|
||||
|
||||
fLexerState.InputBuffer.Consume
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// ComsumeUntil(Char)
|
||||
// ================================================================================================
|
||||
procedure TLexer.ConsumeUntil(AChar: AnsiChar);
|
||||
var
|
||||
chr: AnsiChar;
|
||||
|
||||
begin
|
||||
chr := LA(1);
|
||||
|
||||
while (chr <> EOF_CHAR) and (chr <> AChar) do
|
||||
begin
|
||||
Consume;
|
||||
chr := LA(1)
|
||||
end
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// ConsumeUntil(Set)
|
||||
// ================================================================================================
|
||||
procedure TLexer.ConsumeUntil(ASet: TCharSet);
|
||||
var
|
||||
chr: AnsiChar;
|
||||
|
||||
begin
|
||||
chr := LA(1);
|
||||
|
||||
while (chr <> EOF_CHAR) and not(chr in ASet) do
|
||||
begin
|
||||
Consume;
|
||||
chr := LA(1)
|
||||
end
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Match Not(Char)
|
||||
// ================================================================================================
|
||||
procedure TLexer.MatchNot(AChar: AnsiChar);
|
||||
var
|
||||
chr : AnsiChar;
|
||||
la1 : AnsiChar;
|
||||
|
||||
begin
|
||||
if not fCaseSensitive then
|
||||
begin
|
||||
chr := UpCase( AChar);
|
||||
la1 := UpCase( LA(1));
|
||||
end
|
||||
|
||||
else begin
|
||||
chr := AChar;
|
||||
la1 := LA(1);
|
||||
end;
|
||||
|
||||
if la1 = chr then
|
||||
Raise EMismatchedChar.Create( LA(1),
|
||||
[AChar],
|
||||
fLexerState.FileName,
|
||||
fLexerState.Line,
|
||||
fLexerState.Column,
|
||||
true)
|
||||
else
|
||||
Consume
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Match(Char)
|
||||
// ================================================================================================
|
||||
procedure TLexer.Match(AChar: AnsiChar);
|
||||
var
|
||||
chr : AnsiChar;
|
||||
la1 : AnsiChar;
|
||||
|
||||
begin
|
||||
if not fCaseSensitive then
|
||||
begin
|
||||
chr := UpCase( AChar);
|
||||
la1 := UpCase( LA(1));
|
||||
end
|
||||
|
||||
else begin
|
||||
chr := AChar;
|
||||
la1 := LA(1);
|
||||
end;
|
||||
|
||||
if la1 <> chr then
|
||||
Raise EMismatchedChar.Create( LA(1),
|
||||
[AChar],
|
||||
fLexerState.FileName,
|
||||
fLexerState.Line,
|
||||
fLexerState.Column,
|
||||
false)
|
||||
else
|
||||
Consume
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Match(CharSet)
|
||||
// ================================================================================================
|
||||
procedure TLexer.Match(ASet: TCharSet);
|
||||
var
|
||||
la1: AnsiChar;
|
||||
|
||||
begin
|
||||
la1 := LA(1);
|
||||
|
||||
if not (la1 in ASet) then
|
||||
Raise EMismatchedChar.Create( la1,
|
||||
ASet,
|
||||
fLexerState.FileName,
|
||||
fLexerState.Line,
|
||||
fLexerState.Column,
|
||||
false)
|
||||
else
|
||||
Consume
|
||||
end;
|
||||
|
||||
|
||||
// ================================================================================================
|
||||
// Match(Char..Char)
|
||||
// ================================================================================================
|
||||
procedure TLexer.Match(AChar1, AChar2: AnsiChar);
|
||||
var
|
||||
chr1: AnsiChar;
|
||||
chr2: AnsiChar;
|
||||
la1 : AnsiChar;
|
||||
|
||||
begin
|
||||
if not fCaseSensitive then
|
||||
begin
|
||||
chr1 := UpCase( AChar1);
|
||||
chr2 := UpCase( AChar2);
|
||||
la1 := UpCase( LA(1));
|
||||
end
|
||||
|
||||
else begin
|
||||
chr1 := AChar1;
|
||||
chr2 := AChar2;
|
||||
la1 := LA(1);
|
||||
end;
|
||||
|
||||
if not (la1 in [chr1..chr2]) then
|
||||
Raise EMismatchedChar.Create( la1,
|
||||
[chr1..chr2],
|
||||
fLexerState.FileName,
|
||||
fLexerState.Line,
|
||||
fLexerState.Column,
|
||||
false)
|
||||
else
|
||||
Consume
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Match(string)
|
||||
// ================================================================================================
|
||||
procedure TLexer.Match(AString: AnsiString);
|
||||
var
|
||||
la1 : AnsiChar;
|
||||
s : AnsiString;
|
||||
str : AnsiString;
|
||||
len : integer;
|
||||
i : integer;
|
||||
|
||||
begin
|
||||
if not fCaseSensitive
|
||||
then str := AnsiUpperCase( AString)
|
||||
else str := AString;
|
||||
|
||||
len := Length(str);
|
||||
s := '';
|
||||
|
||||
for i:=1 to len do
|
||||
begin
|
||||
if not fCaseSensitive
|
||||
then la1 := UpCase(LA(1))
|
||||
else la1 := LA(1);
|
||||
|
||||
s := s + la1;
|
||||
|
||||
if la1 <> str[i] then
|
||||
Raise EMismatchedChar.Create( s,
|
||||
str,
|
||||
fLexerState.FileName,
|
||||
fLexerState.Line,
|
||||
fLexerState.Column)
|
||||
else
|
||||
Consume
|
||||
end;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Test Literal
|
||||
// ================================================================================================
|
||||
function TLexer.TestLiteral(AType: integer): integer;
|
||||
begin
|
||||
result := fLiterals.Value[TokenText];
|
||||
|
||||
if result < 0 then
|
||||
result := AType
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Test Literal
|
||||
// ================================================================================================
|
||||
function TLexer.TestLiteral(AText: AnsiString; AType: integer): integer;
|
||||
begin
|
||||
result := fLiterals.Value[AText];
|
||||
|
||||
if result < 0 then
|
||||
result := AType
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Tab
|
||||
//
|
||||
// Advance the current column number by an appropriate amount. If you do not override this
|
||||
// to specify how much to jump for a tab, then tabs are counted as one char. This method is
|
||||
// called from consume().
|
||||
//
|
||||
// update inputState->column as function of inputState->column and tab stops. For example,
|
||||
// if tab stops are columns 1 and 5 etc... and column is 3, then add 2 to column.
|
||||
// ================================================================================================
|
||||
procedure TLexer.Tab;
|
||||
begin
|
||||
fLexerState.Column := fLexerState.Column +1;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// UponEof
|
||||
//
|
||||
// This method is called by YourLexer::nextToken() when the lexer has hit EOF condition.
|
||||
// EOF is NOT a character. This method is not called if EOF is reached during syntactic
|
||||
// predicate evaluation or during evaluation of normal lexical rules, which presumably
|
||||
// would be an IOException. This traps the "normal" EOF condition.
|
||||
//
|
||||
// UponEOF() is called after the complete evaluation of the previous token and only if your
|
||||
// parser asks for another token beyond that last non-EOF token.
|
||||
//
|
||||
// You might want to throw token or char stream exceptions like: "Heh, premature eof" or a
|
||||
// retry stream exception ("I found the end of this file, go back to referencing file").
|
||||
// ================================================================================================
|
||||
procedure TLexer.UponEof;
|
||||
begin
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Initialize
|
||||
// ================================================================================================
|
||||
procedure TLexer.Initialize;
|
||||
begin
|
||||
end;
|
||||
// ================================================================================================
|
||||
// ReportError
|
||||
// ================================================================================================
|
||||
procedure TLexer.ReportError(e: Exception);
|
||||
begin
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// LA
|
||||
// ================================================================================================
|
||||
function TLexer.LA(i: integer): AnsiChar;
|
||||
begin
|
||||
result := fLexerState.InputBuffer.LA(i)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Commit
|
||||
// ================================================================================================
|
||||
procedure TLexer.Commit;
|
||||
begin
|
||||
fLexerState.InputBuffer.Commit
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Mark
|
||||
// ================================================================================================
|
||||
function TLexer.Mark: integer;
|
||||
begin
|
||||
result := fLexerState.InputBuffer.Mark
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Pos
|
||||
// ================================================================================================
|
||||
procedure TLexer.Rewind(Pos: integer);
|
||||
begin
|
||||
fLexerState.InputBuffer.Rewind(Pos)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// ResetText
|
||||
// ================================================================================================
|
||||
procedure TLexer.ResetText;
|
||||
begin
|
||||
TokenText := '';
|
||||
|
||||
with fLexerState do
|
||||
begin
|
||||
TokenStartLine := Line;
|
||||
TokenStartColumn := Column;
|
||||
end
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// NewLine
|
||||
// ================================================================================================
|
||||
procedure TLexer.NewLine;
|
||||
begin
|
||||
with fLexerState do
|
||||
begin
|
||||
Line := Line +1;
|
||||
Column := 1;
|
||||
end
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// MakeToken
|
||||
// ================================================================================================
|
||||
function TLexer.MakeToken(ATokenType: integer; ATokenText: AnsiString): IToken;
|
||||
begin
|
||||
if fTokenClass = nil then
|
||||
fTokenClass := TToken;
|
||||
|
||||
result := fTokenClass.Create( ATokenType, ATokenText);
|
||||
|
||||
with result, fLexerState do
|
||||
begin
|
||||
TokenLine := Line;
|
||||
TokenColumn := Column
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,221 @@
|
||||
unit dpgrtl.lexerstate;
|
||||
|
||||
interface
|
||||
uses
|
||||
System.Classes,
|
||||
dpgrtl.types,
|
||||
dpgrtl.charbuffer;
|
||||
|
||||
type
|
||||
TLexerState = class( TInterfacedObject, ILexerState)
|
||||
private
|
||||
fFileName : string;
|
||||
fLine : integer;
|
||||
fColumn : integer;
|
||||
fGuessing : integer;
|
||||
|
||||
fInputBuffer : ICharBuffer;
|
||||
|
||||
fTokenStartLine : integer;
|
||||
fTokenStartColumn : integer;
|
||||
|
||||
// ------------------------------------------------------------
|
||||
// ILexerState
|
||||
// ------------------------------------------------------------
|
||||
protected
|
||||
function GetFileName : string;
|
||||
function GetLine : integer;
|
||||
function GetColumn : integer;
|
||||
function GetGuessing : integer;
|
||||
|
||||
function GetInputBuffer : ICharBuffer;
|
||||
|
||||
function GetTokenStartLine : integer;
|
||||
function GetTokenStartColumn : integer;
|
||||
|
||||
procedure SetFileName( Value: string);
|
||||
procedure SetLine( Value: integer);
|
||||
procedure SetColumn( Value: integer);
|
||||
procedure SetGuessing( Value: integer);
|
||||
|
||||
procedure SetTokenStartLine( Value: integer);
|
||||
procedure SetTokenStartColumn( Value: integer);
|
||||
|
||||
public
|
||||
constructor Create( AStream: TStream); overload;
|
||||
constructor Create( ABuffer: ICharBuffer); overload;
|
||||
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TLexerState }
|
||||
|
||||
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Constructor
|
||||
// ================================================================================================
|
||||
constructor TLexerState.Create(AStream: TStream);
|
||||
begin
|
||||
inherited Create;
|
||||
fInputBuffer := TCharBuffer.Create(AStream)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Constructor
|
||||
// ================================================================================================
|
||||
constructor TLexerState.Create(ABuffer: ICharBuffer);
|
||||
begin
|
||||
inherited Create;
|
||||
fInputBuffer := ABuffer
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TLexerState.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fFileName := '';
|
||||
fLine := 1;
|
||||
fColumn := 1;
|
||||
fGuessing := 0;
|
||||
|
||||
fTokenStartLine := 1;
|
||||
fTokenStartColumn := 1;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TLexerState.BeforeDestruction;
|
||||
begin
|
||||
fInputBuffer := nil;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
// @@@: ILexerState +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// ILexerState
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Get File Name
|
||||
// ================================================================================================
|
||||
function TLexerState.GetFileName: string;
|
||||
begin
|
||||
result := fFileName
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Line number
|
||||
// ================================================================================================
|
||||
function TLexerState.GetLine: integer;
|
||||
begin
|
||||
result := fLine
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Column number
|
||||
// ================================================================================================
|
||||
function TLexerState.GetColumn: integer;
|
||||
begin
|
||||
result := fColumn
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Guessing
|
||||
// ================================================================================================
|
||||
function TLexerState.GetGuessing: integer;
|
||||
begin
|
||||
result := fGuessing
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Input Buffer
|
||||
// ================================================================================================
|
||||
function TLexerState.GetInputBuffer: ICharBuffer;
|
||||
begin
|
||||
result := fInputBuffer
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Token Start Line
|
||||
// ================================================================================================
|
||||
function TLexerState.GetTokenStartLine: integer;
|
||||
begin
|
||||
result := fTokenStartLine
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Token Start Column
|
||||
// ================================================================================================
|
||||
function TLexerState.GetTokenStartColumn: integer;
|
||||
begin
|
||||
result := fTokenStartColumn
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set File Name
|
||||
// ================================================================================================
|
||||
procedure TLexerState.SetFileName(Value: string);
|
||||
begin
|
||||
fFileName := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Line number
|
||||
// ================================================================================================
|
||||
procedure TLexerState.SetLine(Value: integer);
|
||||
begin
|
||||
fLine := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Column Number
|
||||
// ================================================================================================
|
||||
procedure TLexerState.SetColumn(Value: integer);
|
||||
begin
|
||||
fColumn := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Guessing
|
||||
// ================================================================================================
|
||||
procedure TLexerState.SetGuessing(Value: integer);
|
||||
begin
|
||||
fGuessing := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Token Start Line
|
||||
// ================================================================================================
|
||||
procedure TLexerState.SetTokenStartLine(Value: integer);
|
||||
begin
|
||||
fTokenStartLine := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Token Start Column
|
||||
// ================================================================================================
|
||||
procedure TLexerState.SetTokenStartColumn(Value: integer);
|
||||
begin
|
||||
fTokenStartColumn := Value
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,103 @@
|
||||
unit dpgrtl.llkparser;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types,
|
||||
dpgrtl.parser;
|
||||
|
||||
type
|
||||
TllkParser = class( TParser)
|
||||
protected
|
||||
fK : integer;
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// Interface
|
||||
// ----------------------------------------------------------------------
|
||||
public
|
||||
procedure Consume; override;
|
||||
function LA(i:integer):byte; override;
|
||||
function LT(i:integer):IToken; override;
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// Construction/destruction
|
||||
// ----------------------------------------------------------------------
|
||||
public
|
||||
constructor Create( AParserState: IParserState; K: integer); overload;
|
||||
constructor Create( ATokenBuffer: ITokenBuffer; K: integer); overload;
|
||||
constructor Create( ATokenStream: ITokenStream; K: integer); overload;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TllkParser }
|
||||
|
||||
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Constructor(ParserState)
|
||||
// ================================================================================================
|
||||
constructor TllkParser.Create(AParserState: IParserState; K: integer);
|
||||
begin
|
||||
inherited Create( AParserState);
|
||||
fK := K
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Constructor(TokenBuffer)
|
||||
// ================================================================================================
|
||||
constructor TllkParser.Create(ATokenBuffer: ITokenBuffer; K: integer);
|
||||
begin
|
||||
inherited Create(ATokenBuffer);
|
||||
fK := K
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Constructor(TokenStream)
|
||||
// ================================================================================================
|
||||
constructor TllkParser.Create(ATokenStream: ITokenStream; K: integer);
|
||||
begin
|
||||
inherited Create(ATokenStream);
|
||||
fK := K
|
||||
end;
|
||||
|
||||
// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Interface
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Consume
|
||||
// ================================================================================================
|
||||
procedure TllkParser.Consume;
|
||||
begin
|
||||
fParserState.InputBuffer.Consume
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// LA
|
||||
// ================================================================================================
|
||||
function TllkParser.LA(i: integer): byte;
|
||||
begin
|
||||
result := fParserState.InputBuffer.LA(i)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// LT
|
||||
// ================================================================================================
|
||||
function TllkParser.LT(i: integer): IToken;
|
||||
begin
|
||||
result := fParserState.InputBuffer.LT(i)
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,231 @@
|
||||
unit dpgrtl.parser;
|
||||
|
||||
interface
|
||||
uses
|
||||
System.SysUtils,
|
||||
dpgrtl.types;
|
||||
|
||||
type
|
||||
TParser = class
|
||||
protected
|
||||
fParserState : IParserState;
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// Interface
|
||||
// ----------------------------------------------------------------------
|
||||
public
|
||||
procedure ConsumeUntil( ATokenType : byte); overload;
|
||||
procedure ConsumeUntil( ATokenSet : TByteSet); overload;
|
||||
|
||||
procedure Match( ATokenSet : TByteSet); overload;
|
||||
procedure Match( ATokenType : byte); overload;
|
||||
procedure MatchNot( ATokenType : byte);
|
||||
|
||||
function Mark: integer; virtual;
|
||||
procedure Rewind( Pos: integer); virtual;
|
||||
|
||||
procedure ReportError( e: Exception); overload; virtual;
|
||||
procedure ReportError( s: string); overload; virtual;
|
||||
|
||||
procedure Consume; virtual; abstract;
|
||||
function LA(i:integer): byte; virtual; abstract;
|
||||
function LT(i:integer): IToken; virtual; abstract;
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// Construction/destruction
|
||||
// ----------------------------------------------------------------------
|
||||
public
|
||||
constructor Create( AState : IParserState); overload;
|
||||
constructor Create( ABuffer: ITokenBuffer); overload;
|
||||
constructor Create( AStream: ITokenStream); overload;
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
public
|
||||
property InputState : IParserState read fParserState
|
||||
write fParserState;
|
||||
end;
|
||||
|
||||
TParserClass = class of TParser;
|
||||
|
||||
implementation
|
||||
uses
|
||||
dpgrtl.exception,
|
||||
dpgrtl.parserstate,
|
||||
dpgrtl.tokenbuffer;
|
||||
|
||||
{ TParser }
|
||||
|
||||
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Constructor(ParserState)
|
||||
// ================================================================================================
|
||||
constructor TParser.Create(AState: IParserState);
|
||||
begin
|
||||
inherited Create;
|
||||
fParserState := AState
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Constructor(TokenBuffer)
|
||||
// ================================================================================================
|
||||
constructor TParser.Create(ABuffer: ITokenBuffer);
|
||||
begin
|
||||
inherited Create;
|
||||
fParserState := TParserState.Create( ABuffer)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Constructor(TokenStream)
|
||||
// ================================================================================================
|
||||
constructor TParser.Create(AStream: ITokenStream);
|
||||
var
|
||||
tb: TTokenBuffer;
|
||||
|
||||
begin
|
||||
inherited Create;
|
||||
|
||||
tb := TTokenBuffer.Create(AStream);
|
||||
fParserState := TParserState.Create(tb);
|
||||
end;
|
||||
|
||||
// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Interface
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// ConsumeUntil(TokenType)
|
||||
// ================================================================================================
|
||||
procedure TParser.ConsumeUntil(ATokenType: byte);
|
||||
var
|
||||
la1: byte;
|
||||
|
||||
begin
|
||||
la1 := LA(1);
|
||||
|
||||
while (la1 <> TT_EOF) and (la1 <> ATokenType) do
|
||||
begin
|
||||
Consume;
|
||||
la1 := LA(1)
|
||||
end
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// ConsumeUntil(TokenSet)
|
||||
// ================================================================================================
|
||||
procedure TParser.ConsumeUntil(ATokenSet: TByteSet);
|
||||
var
|
||||
la1: byte;
|
||||
|
||||
begin
|
||||
la1 := LA(1);
|
||||
|
||||
while (la1 <> TT_EOF) and not(la1 in ATokenSet) do
|
||||
begin
|
||||
Consume;
|
||||
la1 := LA(1)
|
||||
end
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Match Not
|
||||
//
|
||||
// Make sure current lookahead symbol NOT matches token type 'pTokenType'. Throw an exception
|
||||
// upon mismatch, which is catched by either the error handler or by the syntactic predicate.
|
||||
// ================================================================================================
|
||||
procedure TParser.MatchNot(ATokenType: byte);
|
||||
var
|
||||
la1: byte;
|
||||
|
||||
begin
|
||||
la1 := LA(1);
|
||||
|
||||
if la1 = ATokenType
|
||||
then Raise EMismatchedToken.Create( LT(1), ATokenType, fParserState.FileName, true)
|
||||
else Consume
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Match
|
||||
//
|
||||
// Make sure current lookahead symbol matches token type 'pTokenType'. Throw an exception upon
|
||||
// mismatch, which is catched by either the error handler or by the syntactic predicate.
|
||||
// ================================================================================================
|
||||
procedure TParser.Match(ATokenType: byte);
|
||||
var
|
||||
la1: byte;
|
||||
lt1: IToken;
|
||||
|
||||
begin
|
||||
la1 := LA(1);
|
||||
|
||||
if la1 <> ATokenType then
|
||||
begin
|
||||
lt1 := LT(1);
|
||||
Raise EMismatchedToken.Create( lt1, ATokenType, fParserState.FileName, false)
|
||||
end;
|
||||
|
||||
Consume
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Match
|
||||
//
|
||||
// Make sure current lookahead symbol matches the given set. Throw an exception upon mismatch,
|
||||
// which is catched by either the error handler or by the syntactic predicate.
|
||||
// ================================================================================================
|
||||
procedure TParser.Match(ATokenSet: TByteSet);
|
||||
var
|
||||
la1: byte;
|
||||
|
||||
begin
|
||||
la1 := LA(1);
|
||||
|
||||
if not (la1 in ATokenSet)
|
||||
then Raise EMismatchedToken.Create( LT(1), ATokenSet, fParserState.FileName, false)
|
||||
else Consume
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Mark
|
||||
// ================================================================================================
|
||||
function TParser.Mark: integer;
|
||||
begin
|
||||
result := fParserState.InputBuffer.Mark
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Rewind
|
||||
// ================================================================================================
|
||||
procedure TParser.Rewind(Pos: integer);
|
||||
begin
|
||||
fParserState.InputBuffer.Rewind(Pos)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Report Error
|
||||
// ================================================================================================
|
||||
procedure TParser.ReportError(e: Exception);
|
||||
begin
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Report Error
|
||||
// ================================================================================================
|
||||
procedure TParser.ReportError(s: string);
|
||||
begin
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,125 @@
|
||||
unit dpgrtl.parserstate;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types;
|
||||
|
||||
type
|
||||
TParserState = class( TInterfacedObject, IParserState)
|
||||
protected
|
||||
fFileName : string;
|
||||
fGuessing : integer;
|
||||
fInputBuffer : ITokenBuffer;
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// IParserState
|
||||
// ----------------------------------------------------------------------
|
||||
protected
|
||||
function GetInputBuffer : ITokenBuffer;
|
||||
function GetFileName : string;
|
||||
function GetGuessing : integer;
|
||||
|
||||
procedure SetFileName( Value: string);
|
||||
procedure SetGuessing( Value: integer);
|
||||
|
||||
// ----------------------------------------------------------------------
|
||||
// Construction/destruction
|
||||
// ----------------------------------------------------------------------
|
||||
public
|
||||
constructor Create( ABuffer: ITokenBuffer);
|
||||
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TParserState }
|
||||
|
||||
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Constructor
|
||||
// ================================================================================================
|
||||
constructor TParserState.Create(ABuffer: ITokenBuffer);
|
||||
begin
|
||||
inherited Create;
|
||||
fInputBuffer := ABuffer
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TParserState.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
fFileName := '';
|
||||
fGuessing := 0
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TParserState.BeforeDestruction;
|
||||
begin
|
||||
fInputBuffer := nil;
|
||||
inherited
|
||||
end;
|
||||
|
||||
// @@@: IParserState implementation +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// IParserState implementation
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Get File Name
|
||||
// ================================================================================================
|
||||
function TParserState.GetFileName: string;
|
||||
begin
|
||||
result := fFileName
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Guessing
|
||||
// ================================================================================================
|
||||
function TParserState.GetGuessing: integer;
|
||||
begin
|
||||
result := fGuessing
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Input Buffer
|
||||
// ================================================================================================
|
||||
function TParserState.GetInputBuffer: ITokenBuffer;
|
||||
begin
|
||||
result := fInputBuffer
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set File Name
|
||||
// ================================================================================================
|
||||
procedure TParserState.SetFileName(Value: string);
|
||||
begin
|
||||
fFileName := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Guessing
|
||||
// ================================================================================================
|
||||
procedure TParserState.SetGuessing(Value: integer);
|
||||
begin
|
||||
fGuessing := Value
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,123 @@
|
||||
unit dpgrtl.stringmap;
|
||||
|
||||
interface
|
||||
uses
|
||||
System.Classes;
|
||||
|
||||
type
|
||||
TStringMap = class
|
||||
strict protected
|
||||
fData : TStringList;
|
||||
|
||||
private
|
||||
function GetCaseSensitive : boolean;
|
||||
function GetValue(Name:AnsiString): integer;
|
||||
|
||||
procedure SetCaseSensitive( Value: boolean);
|
||||
procedure SetValue( Name:AnsiString; Value: integer);
|
||||
|
||||
public
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
|
||||
procedure Clear;
|
||||
procedure Sort;
|
||||
|
||||
public
|
||||
property CaseSensitive : boolean read GetCaseSensitive
|
||||
write SetCaseSensitive;
|
||||
|
||||
property Value[Name:AnsiString] : integer read GetValue
|
||||
write SetValue; default;
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
System.SysUtils;
|
||||
|
||||
{ TStringMap }
|
||||
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TStringMap.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
fData := TStringList.Create
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TStringMap.BeforeDestruction;
|
||||
begin
|
||||
fData.Free;
|
||||
inherited
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get CaseSensitive
|
||||
// ================================================================================================
|
||||
function TStringMap.GetCaseSensitive: boolean;
|
||||
begin
|
||||
result := fData.CaseSensitive
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Value
|
||||
// ================================================================================================
|
||||
function TStringMap.GetValue(Name: AnsiString): integer;
|
||||
var
|
||||
idx: integer;
|
||||
|
||||
begin
|
||||
idx := fData.IndexOfName(String(Name));
|
||||
|
||||
if idx >= 0
|
||||
then result := StrToIntDef( fData.ValueFromIndex[idx], -1)
|
||||
else result := -1
|
||||
end;
|
||||
|
||||
|
||||
// ================================================================================================
|
||||
// Set CaseSensitive
|
||||
// ================================================================================================
|
||||
procedure TStringMap.SetCaseSensitive(Value: boolean);
|
||||
begin
|
||||
fData.CaseSensitive := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Value
|
||||
// ================================================================================================
|
||||
procedure TStringMap.SetValue(Name: AnsiString; Value: integer);
|
||||
var
|
||||
idx: integer;
|
||||
val: string;
|
||||
|
||||
begin
|
||||
idx := fData.IndexOfName(String(Name));
|
||||
val := IntToStr(Value);
|
||||
|
||||
if idx >= 0
|
||||
then fData.ValueFromIndex[idx] := val
|
||||
else fData.Add(String(Name)+'='+val)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Clear
|
||||
// ================================================================================================
|
||||
procedure TStringMap.Clear;
|
||||
begin
|
||||
fData.Clear
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Sort
|
||||
// ================================================================================================
|
||||
procedure TStringMap.Sort;
|
||||
begin
|
||||
fData.Sort
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,139 @@
|
||||
unit dpgrtl.token;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types;
|
||||
|
||||
type
|
||||
TToken = class( TInterfacedObject, IToken)
|
||||
strict protected
|
||||
fTokenType : byte;
|
||||
fTokenText : AnsiString;
|
||||
fTokenLine : integer;
|
||||
fTokenColumn : integer;
|
||||
|
||||
protected
|
||||
function GetTokenType : byte;
|
||||
function GetTokenText : AnsiString;
|
||||
function GetTokenLine : integer;
|
||||
function GetTokenColumn : integer;
|
||||
|
||||
procedure SetTokenType( Value: byte);
|
||||
procedure SetTokenText( Value: AnsiString);
|
||||
procedure SetTokenLine( Value: integer);
|
||||
procedure SetTokenColumn( Value: integer);
|
||||
|
||||
public
|
||||
function Clone: IToken;
|
||||
|
||||
public
|
||||
constructor Create( ATokenType : byte=TT_INVALID;
|
||||
ATokenText : AnsiString='';
|
||||
ATokenLine : integer=0;
|
||||
ATokenColumn: integer=0);
|
||||
public
|
||||
end;
|
||||
|
||||
TTokenClass = class of TToken;
|
||||
|
||||
var
|
||||
badToken : IToken;
|
||||
nullToken: IToken;
|
||||
|
||||
implementation
|
||||
|
||||
// ================================================================================================
|
||||
// constructor
|
||||
// ================================================================================================
|
||||
constructor TToken.Create( ATokenType : byte;
|
||||
ATokenText : AnsiString;
|
||||
ATokenLine : integer;
|
||||
ATokenColumn: integer);
|
||||
begin
|
||||
fTokenType := ATokenType;
|
||||
fTokenText := ATokenText;
|
||||
fTokenLine := ATokenLine;
|
||||
fTokenColumn:= ATokenColumn
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Token Text
|
||||
// ================================================================================================
|
||||
function TToken.GetTokenText: AnsiString;
|
||||
begin
|
||||
result := fTokenText
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Token Type
|
||||
// ================================================================================================
|
||||
function TToken.GetTokenType: byte;
|
||||
begin
|
||||
result := fTokenType
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Token Line
|
||||
// ================================================================================================
|
||||
function TToken.GetTokenLine: integer;
|
||||
begin
|
||||
result := fTokenLine
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Token Column
|
||||
// ================================================================================================
|
||||
function TToken.GetTokenColumn: integer;
|
||||
begin
|
||||
result := fTokenColumn
|
||||
end;
|
||||
|
||||
|
||||
// ================================================================================================
|
||||
// Set Token Text
|
||||
// ================================================================================================
|
||||
procedure TToken.SetTokenText( Value: AnsiString);
|
||||
begin
|
||||
fTokenText := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Token Type
|
||||
// ================================================================================================
|
||||
procedure TToken.SetTokenType( Value: byte);
|
||||
begin
|
||||
fTokenType := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Token Line
|
||||
// ================================================================================================
|
||||
procedure TToken.SetTokenLine( Value: integer);
|
||||
begin
|
||||
fTokenLine := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Token Line
|
||||
// ================================================================================================
|
||||
procedure TToken.SetTokenColumn( Value: integer);
|
||||
begin
|
||||
fTokenColumn := Value
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Clone
|
||||
// ================================================================================================
|
||||
function TToken.Clone: IToken;
|
||||
begin
|
||||
result := TToken.Create( fTokenType, fTokenText, fTokenLine, fTokenColumn);
|
||||
end;
|
||||
|
||||
initialization
|
||||
badToken := TToken.Create( TT_INVALID);
|
||||
nullToken := TToken.Create( TT_INVALID);
|
||||
|
||||
finalization
|
||||
badToken := nil;
|
||||
nullToken := nil;
|
||||
end.
|
||||
@@ -0,0 +1,162 @@
|
||||
unit dpgrtl.tokenbuffer;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types,
|
||||
dpgrtl.inputbuffer,
|
||||
dpgrtl.tokenqueue;
|
||||
|
||||
type
|
||||
TTokenBuffer = class( TInputBuffer, IInputBuffer, ITokenBuffer)
|
||||
protected
|
||||
fStream : ITokenStream;
|
||||
fQueue : TTokenQueue;
|
||||
|
||||
// ------------------------------------------------------------
|
||||
// Internals
|
||||
// ------------------------------------------------------------
|
||||
protected
|
||||
function GetNext: IToken; inline;
|
||||
procedure Fill( Amount: integer);
|
||||
|
||||
// ------------------------------------------------------------
|
||||
// TInputBuffer override
|
||||
// ------------------------------------------------------------
|
||||
protected
|
||||
procedure Remove( Num: integer); override;
|
||||
|
||||
// ------------------------------------------------------------
|
||||
// ITokenBuffer
|
||||
// ------------------------------------------------------------
|
||||
protected
|
||||
function LA(i: integer): integer;
|
||||
function LT(i: integer): IToken;
|
||||
|
||||
public
|
||||
constructor Create( AStream: ITokenStream);
|
||||
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TTokenBuffer }
|
||||
|
||||
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Constructor
|
||||
// ================================================================================================
|
||||
constructor TTokenBuffer.Create(AStream: ITokenStream);
|
||||
begin
|
||||
inherited Create;
|
||||
fStream := AStream;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TTokenBuffer.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
fQueue := TTokenQueue.Create
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TTokenBuffer.BeforeDestruction;
|
||||
begin
|
||||
fStream := nil;
|
||||
fQueue.Free;
|
||||
inherited
|
||||
end;
|
||||
|
||||
|
||||
|
||||
// @@@: ITokenBuffer implementation +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// ITokenBuffer implementation
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// LA
|
||||
//
|
||||
// Ensure that the 'fQueue' object hold sufficient tokens, and gets the 'i'th LookAhead token
|
||||
// type from the 'fQueue'.
|
||||
// ================================================================================================
|
||||
function TTokenBuffer.LA(i: integer): integer;
|
||||
begin
|
||||
Fill(i);
|
||||
result := fQueue.Items[ fMarkerOffset +i -1].TokenType
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// LT
|
||||
// ================================================================================================
|
||||
function TTokenBuffer.LT(i: integer): IToken;
|
||||
begin
|
||||
Fill(i);
|
||||
result := fQueue.Items[ fMarkerOffset +i -1]
|
||||
end;
|
||||
|
||||
|
||||
|
||||
// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Internals
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Get Next
|
||||
// ================================================================================================
|
||||
function TTokenBuffer.GetNext: IToken;
|
||||
begin
|
||||
result := fStream.NextToken
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Fill
|
||||
// ================================================================================================
|
||||
procedure TTokenBuffer.Fill(Amount: integer);
|
||||
begin
|
||||
SyncConsume;
|
||||
|
||||
while fQueue.Count < (Amount +fMarkerOffset) do
|
||||
fQueue.Add( GetNext);
|
||||
end;
|
||||
|
||||
// @@@: TInputBuffer overrides ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// TInputBuffer overrides
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Remove
|
||||
// ================================================================================================
|
||||
procedure TTokenBuffer.Remove(Num: integer);
|
||||
begin
|
||||
fQueue.Remove(Num)
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,157 @@
|
||||
unit dpgrtl.tokenqueue;
|
||||
|
||||
interface
|
||||
uses
|
||||
System.Classes,
|
||||
dpgrtl.types;
|
||||
|
||||
type
|
||||
TTokenQueue = class( TInterfacedObject)
|
||||
private
|
||||
fItems : TInterfaceList;
|
||||
|
||||
private
|
||||
function GetCount : integer;
|
||||
function GetItem(i:integer): IToken;
|
||||
procedure SetItem(i:integer;value:IToken);
|
||||
|
||||
public
|
||||
procedure Clear;
|
||||
procedure Add( Item: IToken);
|
||||
procedure Remove( Num: integer=1);
|
||||
|
||||
public
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
|
||||
public
|
||||
property Count : integer read GetCount;
|
||||
property Items[i:integer] : IToken read GetItem write SetItem;
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
System.SysUtils;
|
||||
|
||||
{ TTokenQueue }
|
||||
|
||||
// @@@: Construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Construction/destruction
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TTokenQueue.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fItems := TInterfaceList.Create;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TTokenQueue.BeforeDestruction;
|
||||
begin
|
||||
FreeAndNil(fItems);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Interface
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Clear
|
||||
// ================================================================================================
|
||||
procedure TTokenQueue.Clear;
|
||||
begin
|
||||
fItems.Clear;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Add
|
||||
// ================================================================================================
|
||||
procedure TTokenQueue.Add(Item: IToken);
|
||||
begin
|
||||
if Assigned(Item) then
|
||||
fItems.Add(Item)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Remove
|
||||
// ================================================================================================
|
||||
procedure TTokenQueue.Remove(Num: integer);
|
||||
var
|
||||
i: integer;
|
||||
|
||||
begin
|
||||
if Num > 0 then
|
||||
begin
|
||||
if Num >= fItems.Count then
|
||||
fItems.Clear
|
||||
|
||||
else
|
||||
for i:=0 to Num -1 do
|
||||
fItems.Delete(0)
|
||||
end
|
||||
end;
|
||||
|
||||
|
||||
|
||||
// @@@: Property Handlers +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
//
|
||||
// Property Handlers
|
||||
//
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||||
// ================================================================================================
|
||||
// Get Count
|
||||
// ================================================================================================
|
||||
function TTokenQueue.GetCount: integer;
|
||||
begin
|
||||
result := fItems.Count
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Item
|
||||
// ================================================================================================
|
||||
function TTokenQueue.GetItem(i: integer): IToken;
|
||||
begin
|
||||
// -------------------------------------------------------------------------
|
||||
// Check for valid index value.
|
||||
// -------------------------------------------------------------------------
|
||||
if i > fItems.Count then raise ERangeError.CreateFmt( 'Index "%d" is too big', [i]);
|
||||
if i < 0 then raise ERangeError.CreateFmt( 'Index is less than 0', []);
|
||||
|
||||
result := fItems[i] as IToken
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Item
|
||||
// ================================================================================================
|
||||
procedure TTokenQueue.SetItem(i: integer; value: IToken);
|
||||
begin
|
||||
if i > fItems.Count then raise ERangeError.CreateFmt( 'Index "%d" is too big', [i]);
|
||||
if i < 0 then raise ERangeError.CreateFmt( 'Index is less than 0', []);
|
||||
|
||||
fItems.Items[i] := value
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,147 @@
|
||||
unit dpgrtl.treeparser;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types,
|
||||
dpgrtl.astBase,
|
||||
dpgrtl.astFactory,
|
||||
dpgrtl.treeparserstate;
|
||||
|
||||
type
|
||||
TTreeParser = class
|
||||
|
||||
// The AST Null object; the parsing cursor is set to this when
|
||||
// it is found to be null. This way, we can test the token type
|
||||
// of a node without having to have tests for null everywhere.
|
||||
|
||||
// public static ASTNULLType ASTNULL = new ASTNULLType
|
||||
|
||||
|
||||
protected
|
||||
fASTNULL : TAST;
|
||||
|
||||
|
||||
|
||||
// Where did this rule leave off parsing;
|
||||
// avoids a return parameter
|
||||
fRetTree : TAST;
|
||||
|
||||
fInputState : TTreeParserState;
|
||||
|
||||
// table of token type to token names
|
||||
fTokenNames : TTokenNameMap;
|
||||
|
||||
// AST return value for a rule is squirreled away here
|
||||
fRetAST : TAST;
|
||||
|
||||
// AST support code; parser and tree parser delegate to this object
|
||||
fASTFactory : TASTFactory;
|
||||
|
||||
// Used to keep track of indent depth for trace In/Out
|
||||
fTraceDepth : integer;
|
||||
|
||||
protected
|
||||
procedure match( ast : TAST;
|
||||
typ : integer); overload;
|
||||
|
||||
procedure match( ast : TAST;
|
||||
bits : TByteSet); overload;
|
||||
|
||||
procedure matchNot(ast : TAST;
|
||||
typ : integer);
|
||||
|
||||
|
||||
|
||||
private
|
||||
function GetTokenName( i: integer): AnsiString;
|
||||
|
||||
public
|
||||
procedure AfterConstruction; override;
|
||||
procedure BeforeDestruction; override;
|
||||
|
||||
public
|
||||
property AST : TAST read fRetAST;
|
||||
|
||||
property ASTFactory : TASTFactory read fASTFactory;
|
||||
|
||||
property TokenName[i: integer] : AnsiString read GetTokenName;
|
||||
property TokenNames : TTokenNameMap read fTokenNames;
|
||||
|
||||
end;
|
||||
|
||||
implementation
|
||||
uses
|
||||
dpgrtl.exception,
|
||||
System.SysUtils;
|
||||
|
||||
{ TTreeParser }
|
||||
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TTreeParser.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
fTraceDepth := 0;
|
||||
fInputState := TTreeParserState .Create;
|
||||
fTokenNames := TTokenNameMap .Create;
|
||||
fASTFactory := TASTFactory .Create(nil);
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Before Destruction
|
||||
// ================================================================================================
|
||||
procedure TTreeParser.BeforeDestruction;
|
||||
begin
|
||||
FreeAndNil( fTokenNames);
|
||||
FreeAndNil( fInputState);
|
||||
FreeAndNil( fASTFactory);
|
||||
inherited
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Token Name
|
||||
// ================================================================================================
|
||||
function TTreeParser.GetTokenName(i: integer): AnsiString;
|
||||
begin
|
||||
result := '';
|
||||
|
||||
if Assigned(fTokenNames) then
|
||||
fTokenNames.TryGetValue(i, result)
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// match( AST, type)
|
||||
// ================================================================================================
|
||||
procedure TTreeParser.match(ast: TAST; typ: integer);
|
||||
begin
|
||||
// TODO: Exception creation check!
|
||||
|
||||
if (ast = nil) or (ast = fASTNULL) or (ast.AstType <> typ) then
|
||||
raise Exception.Create('TREE: Mismatched token.');
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// match ( AST, byteset)
|
||||
//
|
||||
// Make sure current lookahead symbol matches the given set.
|
||||
// Throw an exception upon mismatch, which is catch by either the error handler or by the
|
||||
// syntactic predicate.
|
||||
// ================================================================================================
|
||||
procedure TTreeParser.match(ast: TAST; bits: TByteSet);
|
||||
begin
|
||||
if (ast = nil) or (ast = fASTNULL) or not (ast.AstType in bits) then
|
||||
raise Exception.Create('TREE: Mismatched token.');
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// match not
|
||||
// ================================================================================================
|
||||
procedure TTreeParser.matchNot(ast: TAST; typ: integer);
|
||||
begin
|
||||
if (ast = nil) or (ast = fASTNULL) or (ast.AstType = typ) then
|
||||
raise Exception.Create('TREE: Mismatched token.');
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,49 @@
|
||||
unit dpgrtl.treeparserstate;
|
||||
|
||||
interface
|
||||
uses
|
||||
dpgrtl.types;
|
||||
|
||||
type
|
||||
TTreeParserState = class( TInterfacedObject, ITreeParserState)
|
||||
protected
|
||||
fGuessing : integer;
|
||||
|
||||
protected
|
||||
function GetGuessing: integer;
|
||||
procedure SetGuessing( Value: integer);
|
||||
|
||||
public
|
||||
procedure AfterConstruction; override;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TParserState }
|
||||
|
||||
// ================================================================================================
|
||||
// After Construction
|
||||
// ================================================================================================
|
||||
procedure TTreeParserState.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
fGuessing := 0;
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Get Guessing
|
||||
// ================================================================================================
|
||||
function TTreeParserState.GetGuessing: integer;
|
||||
begin
|
||||
result := fGuessing
|
||||
end;
|
||||
|
||||
// ================================================================================================
|
||||
// Set Guessing
|
||||
// ================================================================================================
|
||||
procedure TTreeParserState.SetGuessing(Value: integer);
|
||||
begin
|
||||
fGuessing := Value
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,182 @@
|
||||
unit dpgrtl.types;
|
||||
|
||||
interface
|
||||
uses
|
||||
Generics.Collections,
|
||||
System.SysUtils;
|
||||
|
||||
const
|
||||
// -------------------------------------------------------------------------
|
||||
// autogen values
|
||||
// -------------------------------------------------------------------------
|
||||
AUTOGEN_INVALID = 0;
|
||||
AUTOGEN_NONE = 1;
|
||||
AUTOGEN_CARET = 2;
|
||||
AUTOGEN_BANG = 3;
|
||||
|
||||
// -------------------------------------------------------------------------
|
||||
// predefined token types
|
||||
// -------------------------------------------------------------------------
|
||||
TT_SKIP = $FF;
|
||||
TT_INVALID = 0;
|
||||
TT_EOF = 1;
|
||||
TT_NTLA = 2; // null tree lookahead
|
||||
TT_USER = 4;
|
||||
|
||||
EOF_CHAR = #0;
|
||||
|
||||
type
|
||||
TByteSet = set of 0..255;
|
||||
TCharSet = set of AnsiChar;
|
||||
TCharMatrix = array of array of AnsiChar;
|
||||
|
||||
TTokenNameMap = TDictionary<integer,AnsiString>;
|
||||
|
||||
// ===================================================================================
|
||||
// IToken interface
|
||||
// ===================================================================================
|
||||
IToken = interface
|
||||
['{BFB516D6-7175-40C8-9AA0-592CA11AD391}']
|
||||
|
||||
function GetTokenType : byte;
|
||||
function GetTokenText : AnsiString;
|
||||
function GetTokenLine : integer;
|
||||
function GetTokenColumn : integer;
|
||||
|
||||
procedure SetTokenType( Value: byte);
|
||||
procedure SetTokenText( Value: AnsiString);
|
||||
procedure SetTokenLine( Value: integer);
|
||||
procedure SetTokenColumn( Value: integer);
|
||||
|
||||
function Clone: IToken;
|
||||
|
||||
property TokenType : byte read GetTokenType write SetTokenType;
|
||||
property TokenText : AnsiString read GetTokenText write SetTokenText;
|
||||
property TokenLine : integer read GetTokenLine write SetTokenLine;
|
||||
property TokenColumn : integer read GetTokenColumn write SetTokenColumn;
|
||||
end;
|
||||
|
||||
// ===================================================================================
|
||||
// ITokenStream interface
|
||||
// ===================================================================================
|
||||
ITokenStream = interface
|
||||
['{48293450-4B0C-455B-BC3C-313363C503D2}']
|
||||
|
||||
function NextToken: IToken;
|
||||
end;
|
||||
|
||||
// ===================================================================================
|
||||
// IInputBuffer interface
|
||||
// ===================================================================================
|
||||
IInputBuffer = interface
|
||||
['{936C26A0-E25F-4B4E-9FD3-5E8E7FC23B17}']
|
||||
|
||||
function GetMarked: boolean;
|
||||
|
||||
procedure Consume;
|
||||
procedure Commit;
|
||||
|
||||
function Mark: integer;
|
||||
procedure Rewind( Value: integer);
|
||||
|
||||
property Marked: boolean read GetMarked;
|
||||
end;
|
||||
|
||||
// ===================================================================================
|
||||
// ICharBuffer interface
|
||||
// ===================================================================================
|
||||
ICharBuffer = interface( IInputBuffer)
|
||||
['{AA5CD21F-7982-4FF4-BB52-7A02B65C35A8}']
|
||||
|
||||
function LA(i: integer): AnsiChar;
|
||||
end;
|
||||
|
||||
// ===================================================================================
|
||||
// ITokenBuffer interface
|
||||
// ===================================================================================
|
||||
ITokenBuffer = interface( IInputBuffer)
|
||||
['{1FD2EB56-5385-49B0-815D-8B7F96E33F1A}']
|
||||
|
||||
function LA(i: integer): integer;
|
||||
function LT(i: integer): IToken;
|
||||
end;
|
||||
|
||||
// ===================================================================================
|
||||
// ILexerState
|
||||
// ===================================================================================
|
||||
ILexerState = interface
|
||||
['{D6E15235-CADC-48BA-9390-376284515FAA}']
|
||||
|
||||
function GetFileName : string;
|
||||
function GetLine : integer;
|
||||
function GetColumn : integer;
|
||||
function GetGuessing : integer;
|
||||
|
||||
function GetInputBuffer : ICharBuffer;
|
||||
|
||||
function GetTokenStartLine : integer;
|
||||
function GetTokenStartColumn : integer;
|
||||
|
||||
procedure SetFileName( Value: string);
|
||||
procedure SetLine( Value: integer);
|
||||
procedure SetColumn( Value: integer);
|
||||
procedure SetGuessing( Value: integer);
|
||||
|
||||
procedure SetTokenStartLine( Value: integer);
|
||||
procedure SetTokenStartColumn( Value: integer);
|
||||
|
||||
property FileName : string read GetFileName
|
||||
write SetFileName;
|
||||
|
||||
property Line : integer read GetLine
|
||||
write SetLine;
|
||||
|
||||
property Column : integer read GetColumn
|
||||
write SetColumn;
|
||||
|
||||
property Guessing : integer read GetGuessing
|
||||
write SetGuessing;
|
||||
|
||||
property TokenStartLine : integer read GetTokenStartLine
|
||||
write SetTokenStartLine;
|
||||
|
||||
property TokenStartColumn : integer read GetTokenStartColumn
|
||||
write SetTokenStartColumn;
|
||||
|
||||
property InputBuffer : ICharBuffer read GetInputBuffer;
|
||||
end;
|
||||
|
||||
// ===================================================================================
|
||||
// IParserState
|
||||
// ===================================================================================
|
||||
IParserState = interface
|
||||
['{763A4DAD-91F5-4225-A68D-8FE4B1A29164}']
|
||||
|
||||
function GetFileName : string;
|
||||
function GetGuessing : integer;
|
||||
function GetInputBuffer : ITokenBuffer;
|
||||
|
||||
procedure SetFileName( Value: string);
|
||||
procedure SetGuessing( Value: integer);
|
||||
|
||||
property FileName : string read GetFileName write SetFileName;
|
||||
property Guessing : integer read GetGuessing write SetGuessing;
|
||||
property InputBuffer : ITokenBuffer read GetInputBuffer;
|
||||
end;
|
||||
|
||||
// ===================================================================================
|
||||
// ITreeParserState
|
||||
// ===================================================================================
|
||||
ITreeParserState = interface
|
||||
['{439DCDAA-B1AB-482A-BAAE-843917F60E42}']
|
||||
|
||||
function GetGuessing: integer;
|
||||
procedure SetGuessing( Value: integer);
|
||||
|
||||
property Guessing: integer read GetGuessing write SetGuessing;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user