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