roka/bds.mr.dpg
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial check in rtl

Browse Source
This commit is contained in:
Abu Abacus
2026-01-03 18:32:50 +01:00
parent ee130973e2
commit b20cd8e688
23 changed files with 4929 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+7
View File
@@ -1,7 +1,14 @@
bin bin
dcu
prj.dpgxcon\Win32 prj.dpgxcon\Win32
prj.dpgxcon\Win64 prj.dpgxcon\Win64
*.res
*.identcache
*.local
*.dsk
*.dsv
# documentation intermediate files (TeX) # documentation intermediate files (TeX)
*.aux *.aux
*.bmt *.bmt
prj.rtl/Delphi12Athens/mr.dpgrtl.dpk
+56
View File
@@ -0,0 +1,56 @@
package mr.dpgrtl;
{$R *.res}
{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION OFF}
{$OVERFLOWCHECKS ON}
{$RANGECHECKS ON}
{$REFERENCEINFO ON}
{$SAFEDIVIDE OFF}
{$STACKFRAMES ON}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST OFF}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DEFINE DEBUG}
{$ENDIF IMPLICITBUILDING}
{$LIBVERSION '290'}
{$IMPLICITBUILD ON}
requires
rtl;
contains
dpgrtl.charbuffer in '..\..\src.rtl\dpgrtl.charbuffer.pas',
dpgrtl.charqueue in '..\..\src.rtl\dpgrtl.charqueue.pas',
dpgrtl.exception in '..\..\src.rtl\dpgrtl.exception.pas',
dpgrtl.inputbuffer in '..\..\src.rtl\dpgrtl.inputbuffer.pas',
dpgrtl.lexer in '..\..\src.rtl\dpgrtl.lexer.pas',
dpgrtl.lexerstate in '..\..\src.rtl\dpgrtl.lexerstate.pas',
dpgrtl.llkparser in '..\..\src.rtl\dpgrtl.llkparser.pas',
dpgrtl.parser in '..\..\src.rtl\dpgrtl.parser.pas',
dpgrtl.parserstate in '..\..\src.rtl\dpgrtl.parserstate.pas',
dpgrtl.stringmap in '..\..\src.rtl\dpgrtl.stringmap.pas',
dpgrtl.token in '..\..\src.rtl\dpgrtl.token.pas',
dpgrtl.tokenbuffer in '..\..\src.rtl\dpgrtl.tokenbuffer.pas',
dpgrtl.tokenqueue in '..\..\src.rtl\dpgrtl.tokenqueue.pas',
dpgrtl.treeparser in '..\..\src.rtl\dpgrtl.treeparser.pas',
dpgrtl.treeparserstate in '..\..\src.rtl\dpgrtl.treeparserstate.pas',
dpgrtl.types in '..\..\src.rtl\dpgrtl.types.pas',
dpgrtl.astBase in '..\..\src.rtl\ast\dpgrtl.astBase.pas',
dpgrtl.astCommon in '..\..\src.rtl\ast\dpgrtl.astCommon.pas',
dpgrtl.astFactory in '..\..\src.rtl\ast\dpgrtl.astFactory.pas',
dpgrtl.astPair in '..\..\src.rtl\ast\dpgrtl.astPair.pas';
end.
prj.rtl/Delphi12Athens/mr.dpgrtl.dproj
+1022
View File
File diff suppressed because it is too large Load Diff
src.rtl/ast/dpgrtl.astBase.pas
+357
View File
@@ -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.
src.rtl/ast/dpgrtl.astCommon.pas
+14
View File
@@ -0,0 +1,14 @@
unit dpgrtl.astCommon;
interface
uses
dpgrtl.astBase;
type
TastCommon = class( TAST)
end;
implementation
end.
src.rtl/ast/dpgrtl.astFactory.pas
+349
View File
@@ -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.
src.rtl/ast/dpgrtl.astPair.pas
+64
View File
@@ -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.
src.rtl/dpgrtl.charbuffer.pas
+156
View File
@@ -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.
src.rtl/dpgrtl.charqueue.pas
+291
View File
@@ -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.
src.rtl/dpgrtl.exception.pas
+258
View File
@@ -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.
src.rtl/dpgrtl.inputbuffer.pas
+123
View File
@@ -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.
src.rtl/dpgrtl.lexer.pas
+593
View File
@@ -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.
src.rtl/dpgrtl.lexerstate.pas
+221
View File
@@ -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.
src.rtl/dpgrtl.llkparser.pas
+103
View File
@@ -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.
src.rtl/dpgrtl.parser.pas
+231
View File
@@ -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.
src.rtl/dpgrtl.parserstate.pas
+125
View File
@@ -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.
src.rtl/dpgrtl.stringmap.pas
+123
View File
@@ -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.
src.rtl/dpgrtl.token.pas
+139
View File
@@ -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.
src.rtl/dpgrtl.tokenbuffer.pas
+162
View File
@@ -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.
src.rtl/dpgrtl.tokenqueue.pas
+157
View File
@@ -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.
src.rtl/dpgrtl.treeparser.pas
+147
View File
@@ -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.
src.rtl/dpgrtl.treeparserstate.pas
+49
View File
@@ -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.
src.rtl/dpgrtl.types.pas
+182
View File
@@ -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.