diff --git a/References/DelphiAST/Demo/Parser/ParserDemo.dpr b/References/DelphiAST/Demo/Parser/ParserDemo.dpr
new file mode 100644
index 000000000..e092c9311
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/ParserDemo.dpr
@@ -0,0 +1,18 @@
+program ParserDemo;
+
+uses
+ FastMM4,
+ Forms,
+ uMainForm in 'uMainForm.pas' {MainForm},
+ StringUsageLogging in 'StringUsageLogging.pas';
+
+{$R *.res}
+
+begin
+ System.ReportMemoryLeaksOnShutdown := True;
+
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TMainForm, MainForm);
+ Application.Run;
+end.
diff --git a/References/DelphiAST/Demo/Parser/ParserDemo.dproj b/References/DelphiAST/Demo/Parser/ParserDemo.dproj
new file mode 100644
index 000000000..1c9df8989
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/ParserDemo.dproj
@@ -0,0 +1,547 @@
+
+
+ {6DAA4B8F-6103-4418-BAA9-E92227FE34C9}
+ 18.2
+ VCL
+ ParserDemo.dpr
+ True
+ Debug
+ Win32
+ 1
+ Application
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Cfg_1
+ true
+ true
+
+
+ true
+ Base
+ true
+
+
+ ..\..\Source;..\..\Source\SimpleParser;$(DCC_UnitSearchPath)
+ ParserDemo
+ System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)
+ $(BDS)\bin\default_app.manifest
+ 1049
+ CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=
+ $(BDS)\bin\delphi_PROJECTICON.ico
+ false
+ false
+ false
+ false
+ false
+
+
+ $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png
+ $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png
+ true
+ Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
+ true
+ IndyIPClient;FireDACASADriver;FireDACSqliteDriver;bindcompfmx;FireDACDSDriver;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;RESTBackendComponents;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;inetdb;tethering;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapServer;DataSnapCommon;DBXOdbcDriver;vclFireDAC;DataSnapProviderClient;xmlrtl;DataSnapNativeClient;DBXSybaseASEDriver;DbxCommonDriver;svnui;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;DatasnapConnectorsFreePascal;FireDACCommonDriver;MetropolisUILiveTile;bindcompdbx;bindengine;vclactnband;vcldb;soaprtl;vcldsnap;bindcompvcl;vclie;fmxFireDAC;FireDACADSDriver;DBXDb2Driver;vcltouch;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;FireDACMSSQLDriver;FireDAC;dsnap;DBXInformixDriver;fmxase;vcl;IndyCore;IndyIPServer;DataSnapServerMidas;DBXMSSQLDriver;IndyIPCommon;VCLRESTComponents;dsnapcon;FireDACIBDriver;DBXFirebirdDriver;inet;CloudService;DataSnapFireDAC;fmxobj;DataSnapConnectors;FireDACDBXDriver;FireDACMySQLDriver;soapmidas;vclx;soapserver;inetdbxpress;CodeSiteExpressPkg;svn;DBXSybaseASADriver;dsnapxml;FireDACOracleDriver;FireDACInfxDriver;FireDACDb2Driver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;dbexpress;DataSnapIndy10ServerTransport;adortl;$(DCC_UsePackage)
+ 1033
+
+
+ DEBUG;$(DCC_Define)
+ true
+ false
+ true
+ true
+ true
+
+
+ true
+ Debug
+ true
+ 1033
+ false
+
+
+ false
+ RELEASE;$(DCC_Define)
+ 0
+ 0
+
+
+
+ MainSource
+
+
+
+
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+ Delphi.Personality.12
+
+
+
+
+ ParserDemo.dpr
+
+
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+
+
+
+
+
+ ParserDemo.exe
+ true
+
+
+
+
+ 1
+
+
+ 1
+
+
+
+
+ Contents\Resources
+ 1
+
+
+
+
+ classes
+ 1
+
+
+
+
+ res\drawable-xxhdpi
+ 1
+
+
+
+
+ Contents\MacOS
+ 0
+
+
+ 1
+
+
+ Contents\MacOS
+ 1
+
+
+
+
+ library\lib\mips
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 0
+
+
+ 1
+
+
+ Contents\MacOS
+ 1
+
+
+ library\lib\armeabi-v7a
+ 1
+
+
+ 1
+
+
+
+
+ 0
+
+
+ Contents\MacOS
+ 1
+ .framework
+
+
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
+ 1
+
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ library\lib\armeabi
+ 1
+
+
+
+
+ 0
+
+
+ 1
+
+
+ Contents\MacOS
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ res\drawable-normal
+ 1
+
+
+
+
+ res\drawable-xhdpi
+ 1
+
+
+
+
+ res\drawable-large
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ Assets
+ 1
+
+
+ Assets
+ 1
+
+
+
+
+ ..\
+ 1
+
+
+ ..\
+ 1
+
+
+
+
+ library\lib\armeabi-v7a
+ 1
+
+
+
+
+ res\drawable-hdpi
+ 1
+
+
+
+
+ Contents
+ 1
+
+
+
+
+ ..\
+ 1
+
+
+
+
+ Assets
+ 1
+
+
+ Assets
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ res\values
+ 1
+
+
+
+
+ res\drawable-small
+ 1
+
+
+
+
+ res\drawable
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+
+
+ res\drawable
+ 1
+
+
+
+
+ 0
+
+
+ 0
+
+
+ Contents\Resources\StartUp\
+ 0
+
+
+ 0
+
+
+ 0
+
+
+ 0
+
+
+
+
+ library\lib\armeabi-v7a
+ 1
+
+
+
+
+ 0
+ .bpl
+
+
+ 1
+ .dylib
+
+
+ Contents\MacOS
+ 1
+ .dylib
+
+
+ 1
+ .dylib
+
+
+ 1
+ .dylib
+
+
+
+
+ res\drawable-mdpi
+ 1
+
+
+
+
+ res\drawable-xlarge
+ 1
+
+
+
+
+ res\drawable-ldpi
+ 1
+
+
+
+
+ 0
+ .dll;.bpl
+
+
+ 1
+ .dylib
+
+
+ Contents\MacOS
+ 1
+ .dylib
+
+
+ 1
+ .dylib
+
+
+ 1
+ .dylib
+
+
+
+
+
+
+
+
+
+
+
+
+ True
+
+
+ 12
+
+
+
+
+
diff --git a/References/DelphiAST/Demo/Parser/ParserDemo.lpi b/References/DelphiAST/Demo/Parser/ParserDemo.lpi
new file mode 100644
index 000000000..bcbe86d82
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/ParserDemo.lpi
@@ -0,0 +1,98 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Demo/Parser/ParserDemo.lpr b/References/DelphiAST/Demo/Parser/ParserDemo.lpr
new file mode 100644
index 000000000..c55ff0a9c
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/ParserDemo.lpr
@@ -0,0 +1,16 @@
+program ParserDemo;
+
+{$MODE Delphi}
+
+uses
+ Forms, Interfaces,
+ uMainForm in 'uMainForm.pas' {MainForm};
+
+{$R *.res}
+
+begin
+ Application.Initialize;
+ Application.MainFormOnTaskbar := True;
+ Application.CreateForm(TMainForm, MainForm);
+ Application.Run;
+end.
diff --git a/References/DelphiAST/Demo/Parser/ParserDemo.lps b/References/DelphiAST/Demo/Parser/ParserDemo.lps
new file mode 100644
index 000000000..8735f63a5
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/ParserDemo.lps
@@ -0,0 +1,178 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Demo/Parser/ParserDemo.or b/References/DelphiAST/Demo/Parser/ParserDemo.or
new file mode 100644
index 000000000..682f18451
Binary files /dev/null and b/References/DelphiAST/Demo/Parser/ParserDemo.or differ
diff --git a/References/DelphiAST/Demo/Parser/StringUsageLogging.pas b/References/DelphiAST/Demo/Parser/StringUsageLogging.pas
new file mode 100644
index 000000000..29b5b50b2
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/StringUsageLogging.pas
@@ -0,0 +1,94 @@
+unit StringUsageLogging;
+
+interface
+
+uses
+ Generics.Collections;
+
+type
+ TStringUsage = TPair;
+
+function LogStringUsage: TArray;
+procedure LogStringUsageToFile(const fileName: string);
+
+implementation
+
+uses
+ Generics.Defaults, FastMM4, Math, Classes, SysUtils;
+
+type
+ PStrRec = ^StrRec;
+ StrRec = packed record
+ {$IF defined(CPU64BITS)}
+ _Padding: Integer;
+ {$IFEND}
+ codePage: Word;
+ elemSize: Word;
+ refCnt: Integer;
+ length: Integer;
+ end;
+
+procedure Callback(APBlock: Pointer; ABlockSize: NativeInt; AUserData: Pointer);
+var
+ items: TDictionary;
+ count: Integer;
+begin
+ items := TDictionary(AUserData);
+ if (DetectClassInstance(APBlock) = nil)
+ and (DetectStringData(APBlock, ABlockSize) = stUnicodeString) then
+ begin
+ items.TryGetValue(string(PByte(APBlock) + SizeOf(StrRec)), count);
+ items.AddOrSetValue(string(PByte(APBlock) + SizeOf(StrRec)), count + 1);
+ end;
+end;
+
+function LogStringUsage: TArray;
+var
+ items: TDictionary;
+ comparer: TComparison;
+begin
+ items := TDictionary.Create;
+ try
+ WalkAllocatedBlocks(Callback, items);
+ Result := items.ToArray;
+ comparer :=
+ function(const left, right: TStringUsage): Integer
+ begin
+ Result := -CompareValue(left.Value, right.Value);
+ end;
+ TArray.Sort(Result, IComparer(PPointer(@comparer)^));
+ finally
+ items.Free;
+ end;
+end;
+
+procedure LogStringUsageToFile(const fileName: string);
+var
+ item: TStringUsage;
+ f: TFileStream;
+ b: TBytes;
+ overall: Int64;
+begin
+ f := TFileStream.Create(fileName, fmCreate);
+ b := TEncoding.UTF8.GetPreamble;
+ f.Write(b[0], Length(b));
+ try
+ overall := 0;
+ for item in LogStringUsage do
+ begin
+ if item.Value > 1 then
+ begin
+ b := TEncoding.UTF8.GetBytes(Format('%s x%d'#13#10,[item.Key, item.Value]));
+ f.Write(b[0], Length(b));
+
+ Inc(overall, (SizeOf(StrRec) + Length(item.Key) + 1) * item.Value);
+ end;
+ end;
+ b := TEncoding.UTF8.GetBytes(Format(#13#10'Overall memory wasted: %d KB'#13#10, [overall div 1024]));
+ f.Write(b[0], Length(b));
+ finally
+ f.Free;
+ end;
+end;
+
+end.
diff --git a/References/DelphiAST/Demo/Parser/uMainForm.dfm b/References/DelphiAST/Demo/Parser/uMainForm.dfm
new file mode 100644
index 000000000..0605e5311
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/uMainForm.dfm
@@ -0,0 +1,124 @@
+object MainForm: TMainForm
+ Left = 0
+ Top = 0
+ Caption = 'DelphiAST Parser Demo'
+ ClientHeight = 436
+ ClientWidth = 666
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Tahoma'
+ Font.Style = []
+ Menu = MainMenu
+ OldCreateOrder = False
+ PixelsPerInch = 96
+ TextHeight = 13
+ object Splitter1: TSplitter
+ Left = 0
+ Top = 291
+ Width = 666
+ Height = 3
+ Cursor = crVSplit
+ Align = alTop
+ ExplicitTop = 41
+ ExplicitWidth = 206
+ end
+ object OutputMemo: TMemo
+ Left = 0
+ Top = 41
+ Width = 666
+ Height = 250
+ Align = alTop
+ ScrollBars = ssBoth
+ TabOrder = 0
+ ExplicitTop = 33
+ ExplicitHeight = 168
+ end
+ object StatusBar: TStatusBar
+ Left = 0
+ Top = 417
+ Width = 666
+ Height = 19
+ Panels = <
+ item
+ Width = 50
+ end>
+ ExplicitTop = 370
+ end
+ object CheckBox1: TCheckBox
+ AlignWithMargins = True
+ Left = 3
+ Top = 397
+ Width = 660
+ Height = 17
+ Align = alBottom
+ Caption =
+ 'Use string interning for less memory consumption (has a minor im' +
+ 'pact on speed)'
+ TabOrder = 2
+ ExplicitTop = 350
+ end
+ object CommentsBox: TListBox
+ Left = 0
+ Top = 335
+ Width = 666
+ Height = 59
+ Align = alClient
+ ItemHeight = 13
+ TabOrder = 3
+ ExplicitTop = 288
+ end
+ object Panel1: TPanel
+ Left = 0
+ Top = 0
+ Width = 666
+ Height = 41
+ Align = alTop
+ BevelOuter = bvNone
+ TabOrder = 4
+ ExplicitLeft = 88
+ ExplicitTop = 8
+ ExplicitWidth = 185
+ object Label1: TLabel
+ Left = 16
+ Top = 14
+ Width = 63
+ Height = 13
+ Caption = 'Syntax Tree:'
+ end
+ end
+ object Panel2: TPanel
+ Left = 0
+ Top = 294
+ Width = 666
+ Height = 41
+ Align = alTop
+ BevelOuter = bvNone
+ TabOrder = 5
+ ExplicitLeft = 184
+ ExplicitTop = 272
+ ExplicitWidth = 185
+ object Label2: TLabel
+ Left = 16
+ Top = 14
+ Width = 86
+ Height = 13
+ Caption = 'List of Comments:'
+ end
+ end
+ object MainMenu: TMainMenu
+ Left = 224
+ Top = 96
+ object OpenDelphiUnit1: TMenuItem
+ Caption = 'Open Delphi Unit...'
+ OnClick = OpenDelphiUnit1Click
+ end
+ end
+ object OpenDialog: TOpenDialog
+ Filter = 'Delphi Unit|*.pas|Delphi Package|*.dpk|Delphi Project|*.dpr'
+ Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist, ofEnableSizing]
+ Left = 272
+ Top = 96
+ end
+end
diff --git a/References/DelphiAST/Demo/Parser/uMainForm.lfm b/References/DelphiAST/Demo/Parser/uMainForm.lfm
new file mode 100644
index 000000000..5d35aa45d
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/uMainForm.lfm
@@ -0,0 +1,61 @@
+object MainForm: TMainForm
+ Left = 309
+ Height = 389
+ Top = 89
+ Width = 666
+ Caption = 'DelphiAST Demo'
+ ClientHeight = 369
+ ClientWidth = 666
+ Color = clBtnFace
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'Tahoma'
+ Menu = MainMenu
+ LCLVersion = '1.6.0.4'
+ object OutputMemo: TMemo
+ Left = 0
+ Height = 346
+ Top = 0
+ Width = 666
+ Align = alClient
+ ScrollBars = ssBoth
+ TabOrder = 0
+ end
+ object StatusBar: TStatusBar
+ Left = 0
+ Height = 23
+ Top = 346
+ Width = 666
+ Panels = <
+ item
+ Text = 'TEST'
+ Width = 500
+ end>
+ end
+ object CheckBox1: TCheckBox
+ AlignWithMargins = True
+ Left = 3
+ Top = 350
+ Width = 660
+ Height = 17
+ Align = alBottom
+ Caption =
+ 'Use string interning for less memory consumption (has a minor im' +
+ 'pact on speed)'
+ TabOrder = 2
+ end
+ object MainMenu: TMainMenu
+ left = 224
+ top = 96
+ object OpenDelphiUnit1: TMenuItem
+ Caption = 'Open Delphi Unit...'
+ OnClick = OpenDelphiUnit1Click
+ end
+ end
+ object OpenDialog: TOpenDialog
+ Filter = 'Delphi Unit|*.pas|Delphi Package|*.dpk|Delphi Project|*.dpr'
+ Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist, ofEnableSizing]
+ left = 272
+ top = 96
+ end
+end
diff --git a/References/DelphiAST/Demo/Parser/uMainForm.pas b/References/DelphiAST/Demo/Parser/uMainForm.pas
new file mode 100644
index 000000000..8b79b91a0
--- /dev/null
+++ b/References/DelphiAST/Demo/Parser/uMainForm.pas
@@ -0,0 +1,195 @@
+unit uMainForm;
+
+{$IFDEF FPC}{$MODE Delphi}{$ENDIF}
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+ Dialogs, Menus, StdCtrls, ComCtrls, ExtCtrls;
+
+type
+ TMainForm = class(TForm)
+ OutputMemo: TMemo;
+ MainMenu: TMainMenu;
+ OpenDelphiUnit1: TMenuItem;
+ OpenDialog: TOpenDialog;
+ StatusBar: TStatusBar;
+ CheckBox1: TCheckBox;
+ CommentsBox: TListBox;
+ Panel1: TPanel;
+ Panel2: TPanel;
+ Splitter1: TSplitter;
+ Label1: TLabel;
+ Label2: TLabel;
+ procedure OpenDelphiUnit1Click(Sender: TObject);
+ private
+ procedure UpdateStatusBarText(const StatusText: string);
+ procedure Parse(const FileName: string; UseStringInterning: Boolean);
+ end;
+
+var
+ MainForm: TMainForm;
+
+implementation
+
+uses
+ {$IFNDEF FPC}
+ StringUsageLogging, FastMM4,
+ {$ENDIF}
+ StringPool,
+ DelphiAST, DelphiAST.Writer, DelphiAST.Classes,
+ SimpleParser.Lexer.Types, IOUtils, Diagnostics,
+ DelphiAST.SimpleParserEx;
+
+{$IFNDEF FPC}
+ {$R *.dfm}
+{$ELSE}
+ {$R *.lfm}
+{$ENDIF}
+
+type
+ TIncludeHandler = class(TInterfacedObject, IIncludeHandler)
+ private
+ FPath: string;
+ public
+ constructor Create(const Path: string);
+ function GetIncludeFileContent(const ParentFileName, IncludeName: string;
+ out Content: string; out FileName: string): Boolean;
+ end;
+
+{$IFNDEF FPC}
+function MemoryUsed: Cardinal;
+ var
+ st: TMemoryManagerState;
+ sb: TSmallBlockTypeState;
+ begin
+ GetMemoryManagerState(st);
+ Result := st.TotalAllocatedMediumBlockSize + st.TotalAllocatedLargeBlockSize;
+ for sb in st.SmallBlockTypeStates do
+ Result := Result + sb.UseableBlockSize * sb.AllocatedBlockCount;
+end;
+{$ELSE}
+function MemoryUsed: Cardinal;
+begin
+ Result := GetFPCHeapStatus.CurrHeapUsed;
+end;
+{$ENDIF}
+
+procedure TMainForm.Parse(const FileName: string; UseStringInterning: Boolean);
+var
+ SyntaxTree: TSyntaxNode;
+ memused: Cardinal;
+ sw: TStopwatch;
+ StringPool: TStringPool;
+ OnHandleString: TStringEvent;
+ Builder: TPasSyntaxTreeBuilder;
+ StringStream: TStringStream;
+ I: Integer;
+begin
+ OutputMemo.Clear;
+ CommentsBox.Clear;
+
+ try
+ if UseStringInterning then
+ begin
+ StringPool := TStringPool.Create;
+ OnHandleString := StringPool.StringIntern;
+ end
+ else
+ begin
+ StringPool := nil;
+ OnHandleString := nil;
+ end;
+
+ memused := MemoryUsed;
+ sw := TStopwatch.StartNew;
+ try
+ Builder := TPasSyntaxTreeBuilder.Create;
+ try
+ StringStream := TStringStream.Create;
+ try
+ StringStream.LoadFromFile(FileName);
+
+ Builder.IncludeHandler := TIncludeHandler.Create(ExtractFilePath(FileName));
+ Builder.OnHandleString := OnHandleString;
+ StringStream.Position := 0;
+
+ SyntaxTree := Builder.Run(StringStream);
+ try
+ OutputMemo.Lines.Text := TSyntaxTreeWriter.ToXML(SyntaxTree, True);
+ finally
+ SyntaxTree.Free;
+ end;
+ finally
+ StringStream.Free;
+ end;
+
+ for I := 0 to Builder.Comments.Count - 1 do
+ CommentsBox.Items.Add(Format('[Line: %d, Col: %d] %s',
+ [Builder.Comments[I].Line, Builder.Comments[I].Col, Builder.Comments[I].Text]));
+ finally
+ Builder.Free;
+ end
+ finally
+ if UseStringInterning then
+ StringPool.Free;
+ end;
+ sw.Stop;
+
+ UpdateStatusBarText(Format('Parsed file in %d ms - used memory: %d K',
+ [sw.ElapsedMilliseconds, (MemoryUsed - memused) div 1024]));
+ except
+ on E: ESyntaxTreeException do
+ OutputMemo.Lines.Text := Format('[%d, %d] %s', [E.Line, E.Col, E.Message]) + sLineBreak + sLineBreak +
+ TSyntaxTreeWriter.ToXML(E.SyntaxTree, True);
+ end;
+end;
+
+procedure TMainForm.OpenDelphiUnit1Click(Sender: TObject);
+begin
+ if OpenDialog.Execute then
+ Parse(OpenDialog.FileName, CheckBox1.Checked);
+end;
+
+{ TIncludeHandler }
+
+constructor TIncludeHandler.Create(const Path: string);
+begin
+ inherited Create;
+ FPath := Path;
+end;
+
+function TIncludeHandler.GetIncludeFileContent(const ParentFileName, IncludeName: string;
+ out Content: string; out FileName: string): Boolean;
+var
+ FileContent: TStringList;
+begin
+ FileContent := TStringList.Create;
+ try
+ if not FileExists(TPath.Combine(FPath, IncludeName)) then
+ begin
+ Result := False;
+ Exit;
+ end;
+
+ FileContent.LoadFromFile(TPath.Combine(FPath, IncludeName));
+ Content := FileContent.Text;
+ FileName := TPath.Combine(FPath, IncludeName);
+
+ Result := True;
+ finally
+ FileContent.Free;
+ end;
+end;
+
+procedure TMainForm.UpdateStatusBarText(const StatusText: string);
+begin
+ {$IFDEF FPC}
+ StatusBar.SimpleText:= StatusText;
+ {$ELSE}
+ StatusBar.Panels[0].Text := StatusText;
+ {$ENDIF}
+end;
+
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/ProjectIndexerResearch.dpr b/References/DelphiAST/Demo/ProjectIndexer/ProjectIndexerResearch.dpr
new file mode 100644
index 000000000..1adde9532
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/ProjectIndexerResearch.dpr
@@ -0,0 +1,65 @@
+program ProjectIndexerResearch;
+
+{$APPTYPE CONSOLE}
+
+{$R *.res}
+
+uses
+ FastMM4,
+ System.SysUtils,
+ System.Generics.Collections,
+ DelphiAST.ProjectIndexer,
+ TestUnit in 'TestUnit.pas';
+
+var
+ i : integer;
+ indexer: TProjectIndexer;
+
+begin
+ try
+ if ParamCount <> 1 then
+ Writeln(ParamStr(0) + ' ')
+ else begin
+ indexer := TProjectIndexer.Create;
+ try
+// indexer.SearchPath :=
+// 'x:\common\pkg\dspack\src\DirectX9;x:\common\pkg\dspack\src\DSPack;x:\common\DCPCrypt2;x:\common\DCPCrypt2\Ciphers;x:\common\DCPCrypt2\Hashes;x:\common\EZDSL;x:\common\g32;x:\gp\common;' +
+// 'x:\gp\common\except;x:\common\src;x:\common\iphlpapi;x:\common\jwa;x:\common\OmniXML;x:\common\OmniXML\extras;x:\ms\common;x:\common\MSSpell;x:\common\pkg\devexpress5\sources;' +
+// 'x:\common\pkg\jcl\source\include;x:\common\pkg\jcl\source;x:\common\pkg\jcl\source\common;x:\common\pkg\jcl\source\windows;x:\common\pkg\jcl\source\vcl;x:\common\pkg\jcl\source\prototypes;' +
+// 'x:\common\pkg\Abbrevia\source;x:\common\pkg\APRO\run;x:\common\pkg\ics\source;x:\common\pkg\ics\source\include;x:\common\pkg\ics\source\extras;x:\common\pkg\jvcl\archive;' +
+// 'x:\common\pkg\svcom\AllVersions\DesignTime;x:\common\pkg\svcom\AllVersions\Runtime;x:\common\pkg\tsilang\units;x:\common\pkg\tsilang\units\Auxilary;x:\common\pkg\vt;x:\common\pkg\vt\common;' +
+// 'x:\ms\hl\Delphi;x:\ms\hl\HASP;x:\common\pkg\btree;x:\ms\ettwin;x:\ms\hl\cdg;x:\ms\htdrv;x:\gp\dvb;x:\gp\sttdb3;x:\ms\termcom;x:\ln\Common;x:\ln\Decklink;x:\ln\SubtitleEmbedder;x:\ln\mxf;' +
+// 'x:\ln\gxf;x:\ln\FABAudio;x:\gp\arcman;x:\ms\htdrv10;x:\common\fastmm;x:\gp\edl;x:\gp\edl\compile;x:\ln\TS;x:\ln\Renderer;x:\ln\DebugFilter;x:\common\pkg\ChantSpeechKit;x:\common\elevation;' +
+// 'x:\ms\install;x:\common\omnithreadlibrary;x:\ln\VirtualStringTree;x:\ln\mpeg;x:\common\pkg\_FAB\Rtf98;x:\common\pkg\kbmMemTable;x:\common\pkg\zip;x:\ln\mp4;x:\common\pkg\sapi\demos\USBView;' +
+// 'x:\common\pkg\AAF;x:\common\pkg\taskbarlist;x:\ms\hl\hasp;x:\common\pkg\TsiLang\Units;x:\common\pkg\TsiLang\Units\Auxilary;x:\common\pkg\htmlviewer\source;x:\common\pkg\ppdf;' +
+// 'x:\common\pkg\DragDrop\Source;x:\common\pkg\DM\Source;x:\gp\utils;x:\common\pkg\TsiLang\Units;X:\common;x:\common\pkg\jvcl\run;x:\common\pkg\jvcl\common;x:\common\pkg\jvcl\resources;' +
+// 'x:\ms\netapi;x:\ln\wm\source;x:\common\ribbon\lib;x:\common\ffmpeg;C:\Program Files (x86)\TestInsight\Source;x:\common\detours\src;x:\common\Spring4D\Source\Base;x:\common\Spring4D\Source\Base\Collections;' +
+// 'x:\common\Spring4D\Source\Core\Interception';
+// indexer.Defines := 'DEBUG';
+ indexer.SearchPath := 'sub2';
+ indexer.Index(ParamStr(1));
+ Writeln(indexer.ParsedUnits.Count, ' units');
+ for i := 0 to indexer.ParsedUnits.Count - 1 do
+ Writeln(indexer.ParsedUnits[i].Name, ' in ', indexer.ParsedUnits[i].Path);
+ Writeln;
+ Writeln(indexer.IncludeFiles.Count, ' includes');
+ for i := 0 to indexer.IncludeFiles.Count - 1 do
+ Writeln(indexer.IncludeFiles[i].Name, ' @ ', indexer.IncludeFiles[i].Path);
+ Writeln;
+ Writeln(indexer.NotFoundUnits.Count, ' not found');
+ for i := 0 to indexer.NotFoundUnits.Count - 1 do
+ Writeln(indexer.NotFoundUnits[i]);
+ Writeln;
+ Writeln(indexer.Problems.Count, ' problems');
+ for i := 0 to indexer.Problems.Count - 1 do
+ Writeln(Ord(indexer.Problems[i].ProblemType), ' ', indexer.Problems[i].FileName, ': ',
+ indexer.Problems[i].Description);
+ Write('>');
+ Readln;
+ finally FreeAndNil(indexer); end;
+ end;
+ except
+ on E: Exception do
+ Writeln(E.ClassName, ': ', E.Message);
+ end;
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/ProjectIndexerResearch.dproj b/References/DelphiAST/Demo/ProjectIndexer/ProjectIndexerResearch.dproj
new file mode 100644
index 000000000..e3b81dda5
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/ProjectIndexerResearch.dproj
@@ -0,0 +1,499 @@
+
+
+ {CDE040EC-B3A5-4860-9B08-7B0867F04597}
+ ProjectIndexerResearch.dpr
+ True
+ Debug
+ 1
+ Console
+ None
+ 18.2
+ Win32
+
+
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Base
+ true
+
+
+ true
+ Cfg_2
+ true
+ true
+
+
+ ..\..\source;..\..\source\simpleparser;$(DCC_UnitSearchPath)
+ $(BDS)\bin\delphi_PROJECTICNS.icns
+ false
+ CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=
+ $(BDS)\bin\delphi_PROJECTICON.ico
+ false
+ ProjectIndexerResearch
+ false
+ false
+ false
+ 1033
+ 00400000
+ System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)
+
+
+ CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(ModuleName)
+ Debug
+ Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
+ 1033
+
+
+ 0
+ RELEASE;$(DCC_Define)
+ 0
+ false
+
+
+ true
+ DEBUG;$(DCC_Define)
+ false
+
+
+ FullDebugMode;$(DCC_Define)
+ demo\DemoProject.dpr
+ (None)
+ CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName)
+
+
+
+ MainSource
+
+
+
+ Cfg_2
+ Base
+
+
+ Base
+
+
+ Cfg_1
+ Base
+
+
+
+ Delphi.Personality.12
+
+
+
+
+ ProjectIndexerResearch.dpr
+
+
+ Microsoft Office 2000 Sample Automation Server Wrapper Components
+ Microsoft Office XP Sample Automation Server Wrapper Components
+
+
+
+ True
+
+
+
+
+ ProjectIndexerResearch.exe
+ true
+
+
+
+
+ true
+
+
+
+
+ true
+
+
+
+
+ true
+
+
+
+
+ true
+
+
+
+
+
+ Contents\Resources
+ 1
+
+
+
+
+ classes
+ 1
+
+
+
+
+ Contents\MacOS
+ 0
+
+
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ res\drawable-xxhdpi
+ 1
+
+
+
+
+ library\lib\mips
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 0
+
+
+ 1
+
+
+ 1
+
+
+ library\lib\armeabi-v7a
+ 1
+
+
+ 1
+
+
+
+
+ 0
+
+
+ 1
+ .framework
+
+
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
+ 1
+
+
+ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+
+ library\lib\armeabi
+ 1
+
+
+
+
+ 0
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ res\drawable-normal
+ 1
+
+
+
+
+ res\drawable-xhdpi
+ 1
+
+
+
+
+ res\drawable-large
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ Assets
+ 1
+
+
+ Assets
+ 1
+
+
+
+
+
+ res\drawable-hdpi
+ 1
+
+
+
+
+ library\lib\armeabi-v7a
+ 1
+
+
+
+
+
+
+ Assets
+ 1
+
+
+ Assets
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ res\values
+ 1
+
+
+
+
+ res\drawable-small
+ 1
+
+
+
+
+ res\drawable
+ 1
+
+
+
+
+ 1
+
+
+ 1
+
+
+ 1
+
+
+
+
+ 1
+
+
+
+
+ res\drawable
+ 1
+
+
+
+
+ 0
+
+
+ 0
+
+
+ 0
+
+
+ 0
+
+
+ 0
+
+
+ 0
+
+
+
+
+ library\lib\armeabi-v7a
+ 1
+
+
+
+
+ 0
+ .bpl
+
+
+ 1
+ .dylib
+
+
+ 1
+ .dylib
+
+
+ 1
+ .dylib
+
+
+ 1
+ .dylib
+
+
+
+
+ res\drawable-mdpi
+ 1
+
+
+
+
+ res\drawable-xlarge
+ 1
+
+
+
+
+ res\drawable-ldpi
+ 1
+
+
+
+
+ 0
+ .dll;.bpl
+
+
+ 1
+ .dylib
+
+
+
+
+
+
+
+
+
+
+
+
+ 12
+
+
+
+
+
diff --git a/References/DelphiAST/Demo/ProjectIndexer/TestUnit.pas b/References/DelphiAST/Demo/ProjectIndexer/TestUnit.pas
new file mode 100644
index 000000000..087933421
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/TestUnit.pas
@@ -0,0 +1,17 @@
+unit TestUnit;
+
+interface
+
+type
+ TTestClass = class
+ procedure Test; export;
+ end;
+
+implementation
+
+procedure TTestClass.Test;
+begin
+
+end;
+
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/DemoProject.dpr b/References/DelphiAST/Demo/ProjectIndexer/demo/DemoProject.dpr
new file mode 100644
index 000000000..892eef337
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/DemoProject.dpr
@@ -0,0 +1,27 @@
+program DemoProject;
+
+{$APPTYPE CONSOLE}
+
+{$R *.res}
+
+// Search path: sub2
+
+uses
+ System.SysUtils,
+ Unit1 in 'sub1\Unit1.pas',
+ Unit2;
+// UnitA;
+
+begin
+ try
+ Writeln(Unit1Folder);
+ Writeln(Unit1.unitfolder);
+ Writeln(Unit1FolderIndirect);
+ Writeln(Unit2.unitfolder);
+// Writeln(UnitA.ID);
+ Readln;
+ except
+ on E: Exception do
+ Writeln(E.ClassName, ': ', E.Message);
+ end;
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/DemoProject.otares b/References/DelphiAST/Demo/ProjectIndexer/demo/DemoProject.otares
new file mode 100644
index 000000000..743599575
Binary files /dev/null and b/References/DelphiAST/Demo/ProjectIndexer/demo/DemoProject.otares differ
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/UnitAa.pas b/References/DelphiAST/Demo/ProjectIndexer/demo/UnitAa.pas
new file mode 100644
index 000000000..e7c503a96
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/UnitAa.pas
@@ -0,0 +1,10 @@
+unit UnitA;
+
+interface
+
+const
+ ID = 'A3';
+
+implementation
+
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/sub1/Unit1.pas b/References/DelphiAST/Demo/ProjectIndexer/demo/sub1/Unit1.pas
new file mode 100644
index 000000000..b9fa25c6e
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/sub1/Unit1.pas
@@ -0,0 +1,16 @@
+unit Unit1;
+
+interface
+
+uses
+ UnitA;
+
+{$I ..\sub1inc\include.inc}
+{$I ..\subinc\include.inc}
+
+const
+ Unit1Folder = 'sub1:' + UnitA.ID;
+
+implementation
+
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/sub1/UnitA.pas b/References/DelphiAST/Demo/ProjectIndexer/demo/sub1/UnitA.pas
new file mode 100644
index 000000000..0dc4323ef
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/sub1/UnitA.pas
@@ -0,0 +1,10 @@
+unit UnitA;
+
+interface
+
+const
+ ID = 'A1';
+
+implementation
+
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/sub1inc/include.inc b/References/DelphiAST/Demo/ProjectIndexer/demo/sub1inc/include.inc
new file mode 100644
index 000000000..759a24f17
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/sub1inc/include.inc
@@ -0,0 +1,2 @@
+const
+ unitfolder = 'sub1inc';
\ No newline at end of file
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/Unit1.pas b/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/Unit1.pas
new file mode 100644
index 000000000..f6f56fc74
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/Unit1.pas
@@ -0,0 +1,10 @@
+unit Unit1;
+
+interface
+
+const
+ Unit1Folder = 'sub2';
+
+implementation
+
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/Unit2.pas b/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/Unit2.pas
new file mode 100644
index 000000000..14e5cdc45
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/Unit2.pas
@@ -0,0 +1,21 @@
+unit Unit2;
+
+interface
+
+uses
+ Unit1,
+ UnitA;
+
+{$I ..\sub2inc\include.inc}
+{$I ..\subinc\include.inc}
+
+function Unit1FolderIndirect: string;
+
+implementation
+
+function Unit1FolderIndirect: string;
+begin
+ Result := Unit1Folder + ':' + UnitA.ID;
+end;
+
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/UnitA.pas b/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/UnitA.pas
new file mode 100644
index 000000000..a759eeeae
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/sub2/UnitA.pas
@@ -0,0 +1,12 @@
+unit UnitA;
+
+interface
+
+const
+ ID = 'A2';
+
+implementation
+
+{$I ..\sub2inc\include.inc}
+
+end.
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/sub2inc/include.inc b/References/DelphiAST/Demo/ProjectIndexer/demo/sub2inc/include.inc
new file mode 100644
index 000000000..70d91daf3
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/sub2inc/include.inc
@@ -0,0 +1,2 @@
+const
+ unitfolder = 'sub2inc';
\ No newline at end of file
diff --git a/References/DelphiAST/Demo/ProjectIndexer/demo/subinc/include.inc b/References/DelphiAST/Demo/ProjectIndexer/demo/subinc/include.inc
new file mode 100644
index 000000000..2829da9ef
--- /dev/null
+++ b/References/DelphiAST/Demo/ProjectIndexer/demo/subinc/include.inc
@@ -0,0 +1,2 @@
+const
+ common = 'common';
diff --git a/References/DelphiAST/LICENSE b/References/DelphiAST/LICENSE
new file mode 100644
index 000000000..14e2f777f
--- /dev/null
+++ b/References/DelphiAST/LICENSE
@@ -0,0 +1,373 @@
+Mozilla Public License Version 2.0
+==================================
+
+1. Definitions
+--------------
+
+1.1. "Contributor"
+ means each individual or legal entity that creates, contributes to
+ the creation of, or owns Covered Software.
+
+1.2. "Contributor Version"
+ means the combination of the Contributions of others (if any) used
+ by a Contributor and that particular Contributor's Contribution.
+
+1.3. "Contribution"
+ means Covered Software of a particular Contributor.
+
+1.4. "Covered Software"
+ means Source Code Form to which the initial Contributor has attached
+ the notice in Exhibit A, the Executable Form of such Source Code
+ Form, and Modifications of such Source Code Form, in each case
+ including portions thereof.
+
+1.5. "Incompatible With Secondary Licenses"
+ means
+
+ (a) that the initial Contributor has attached the notice described
+ in Exhibit B to the Covered Software; or
+
+ (b) that the Covered Software was made available under the terms of
+ version 1.1 or earlier of the License, but not also under the
+ terms of a Secondary License.
+
+1.6. "Executable Form"
+ means any form of the work other than Source Code Form.
+
+1.7. "Larger Work"
+ means a work that combines Covered Software with other material, in
+ a separate file or files, that is not Covered Software.
+
+1.8. "License"
+ means this document.
+
+1.9. "Licensable"
+ means having the right to grant, to the maximum extent possible,
+ whether at the time of the initial grant or subsequently, any and
+ all of the rights conveyed by this License.
+
+1.10. "Modifications"
+ means any of the following:
+
+ (a) any file in Source Code Form that results from an addition to,
+ deletion from, or modification of the contents of Covered
+ Software; or
+
+ (b) any new file in Source Code Form that contains any Covered
+ Software.
+
+1.11. "Patent Claims" of a Contributor
+ means any patent claim(s), including without limitation, method,
+ process, and apparatus claims, in any patent Licensable by such
+ Contributor that would be infringed, but for the grant of the
+ License, by the making, using, selling, offering for sale, having
+ made, import, or transfer of either its Contributions or its
+ Contributor Version.
+
+1.12. "Secondary License"
+ means either the GNU General Public License, Version 2.0, the GNU
+ Lesser General Public License, Version 2.1, the GNU Affero General
+ Public License, Version 3.0, or any later versions of those
+ licenses.
+
+1.13. "Source Code Form"
+ means the form of the work preferred for making modifications.
+
+1.14. "You" (or "Your")
+ means an individual or a legal entity exercising rights under this
+ License. For legal entities, "You" includes any entity that
+ controls, is controlled by, or is under common control with You. For
+ purposes of this definition, "control" means (a) the power, direct
+ or indirect, to cause the direction or management of such entity,
+ whether by contract or otherwise, or (b) ownership of more than
+ fifty percent (50%) of the outstanding shares or beneficial
+ ownership of such entity.
+
+2. License Grants and Conditions
+--------------------------------
+
+2.1. Grants
+
+Each Contributor hereby grants You a world-wide, royalty-free,
+non-exclusive license:
+
+(a) under intellectual property rights (other than patent or trademark)
+ Licensable by such Contributor to use, reproduce, make available,
+ modify, display, perform, distribute, and otherwise exploit its
+ Contributions, either on an unmodified basis, with Modifications, or
+ as part of a Larger Work; and
+
+(b) under Patent Claims of such Contributor to make, use, sell, offer
+ for sale, have made, import, and otherwise transfer either its
+ Contributions or its Contributor Version.
+
+2.2. Effective Date
+
+The licenses granted in Section 2.1 with respect to any Contribution
+become effective for each Contribution on the date the Contributor first
+distributes such Contribution.
+
+2.3. Limitations on Grant Scope
+
+The licenses granted in this Section 2 are the only rights granted under
+this License. No additional rights or licenses will be implied from the
+distribution or licensing of Covered Software under this License.
+Notwithstanding Section 2.1(b) above, no patent license is granted by a
+Contributor:
+
+(a) for any code that a Contributor has removed from Covered Software;
+ or
+
+(b) for infringements caused by: (i) Your and any other third party's
+ modifications of Covered Software, or (ii) the combination of its
+ Contributions with other software (except as part of its Contributor
+ Version); or
+
+(c) under Patent Claims infringed by Covered Software in the absence of
+ its Contributions.
+
+This License does not grant any rights in the trademarks, service marks,
+or logos of any Contributor (except as may be necessary to comply with
+the notice requirements in Section 3.4).
+
+2.4. Subsequent Licenses
+
+No Contributor makes additional grants as a result of Your choice to
+distribute the Covered Software under a subsequent version of this
+License (see Section 10.2) or under the terms of a Secondary License (if
+permitted under the terms of Section 3.3).
+
+2.5. Representation
+
+Each Contributor represents that the Contributor believes its
+Contributions are its original creation(s) or it has sufficient rights
+to grant the rights to its Contributions conveyed by this License.
+
+2.6. Fair Use
+
+This License is not intended to limit any rights You have under
+applicable copyright doctrines of fair use, fair dealing, or other
+equivalents.
+
+2.7. Conditions
+
+Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
+in Section 2.1.
+
+3. Responsibilities
+-------------------
+
+3.1. Distribution of Source Form
+
+All distribution of Covered Software in Source Code Form, including any
+Modifications that You create or to which You contribute, must be under
+the terms of this License. You must inform recipients that the Source
+Code Form of the Covered Software is governed by the terms of this
+License, and how they can obtain a copy of this License. You may not
+attempt to alter or restrict the recipients' rights in the Source Code
+Form.
+
+3.2. Distribution of Executable Form
+
+If You distribute Covered Software in Executable Form then:
+
+(a) such Covered Software must also be made available in Source Code
+ Form, as described in Section 3.1, and You must inform recipients of
+ the Executable Form how they can obtain a copy of such Source Code
+ Form by reasonable means in a timely manner, at a charge no more
+ than the cost of distribution to the recipient; and
+
+(b) You may distribute such Executable Form under the terms of this
+ License, or sublicense it under different terms, provided that the
+ license for the Executable Form does not attempt to limit or alter
+ the recipients' rights in the Source Code Form under this License.
+
+3.3. Distribution of a Larger Work
+
+You may create and distribute a Larger Work under terms of Your choice,
+provided that You also comply with the requirements of this License for
+the Covered Software. If the Larger Work is a combination of Covered
+Software with a work governed by one or more Secondary Licenses, and the
+Covered Software is not Incompatible With Secondary Licenses, this
+License permits You to additionally distribute such Covered Software
+under the terms of such Secondary License(s), so that the recipient of
+the Larger Work may, at their option, further distribute the Covered
+Software under the terms of either this License or such Secondary
+License(s).
+
+3.4. Notices
+
+You may not remove or alter the substance of any license notices
+(including copyright notices, patent notices, disclaimers of warranty,
+or limitations of liability) contained within the Source Code Form of
+the Covered Software, except that You may alter any license notices to
+the extent required to remedy known factual inaccuracies.
+
+3.5. Application of Additional Terms
+
+You may choose to offer, and to charge a fee for, warranty, support,
+indemnity or liability obligations to one or more recipients of Covered
+Software. However, You may do so only on Your own behalf, and not on
+behalf of any Contributor. You must make it absolutely clear that any
+such warranty, support, indemnity, or liability obligation is offered by
+You alone, and You hereby agree to indemnify every Contributor for any
+liability incurred by such Contributor as a result of warranty, support,
+indemnity or liability terms You offer. You may include additional
+disclaimers of warranty and limitations of liability specific to any
+jurisdiction.
+
+4. Inability to Comply Due to Statute or Regulation
+---------------------------------------------------
+
+If it is impossible for You to comply with any of the terms of this
+License with respect to some or all of the Covered Software due to
+statute, judicial order, or regulation then You must: (a) comply with
+the terms of this License to the maximum extent possible; and (b)
+describe the limitations and the code they affect. Such description must
+be placed in a text file included with all distributions of the Covered
+Software under this License. Except to the extent prohibited by statute
+or regulation, such description must be sufficiently detailed for a
+recipient of ordinary skill to be able to understand it.
+
+5. Termination
+--------------
+
+5.1. The rights granted under this License will terminate automatically
+if You fail to comply with any of its terms. However, if You become
+compliant, then the rights granted under this License from a particular
+Contributor are reinstated (a) provisionally, unless and until such
+Contributor explicitly and finally terminates Your grants, and (b) on an
+ongoing basis, if such Contributor fails to notify You of the
+non-compliance by some reasonable means prior to 60 days after You have
+come back into compliance. Moreover, Your grants from a particular
+Contributor are reinstated on an ongoing basis if such Contributor
+notifies You of the non-compliance by some reasonable means, this is the
+first time You have received notice of non-compliance with this License
+from such Contributor, and You become compliant prior to 30 days after
+Your receipt of the notice.
+
+5.2. If You initiate litigation against any entity by asserting a patent
+infringement claim (excluding declaratory judgment actions,
+counter-claims, and cross-claims) alleging that a Contributor Version
+directly or indirectly infringes any patent, then the rights granted to
+You by any and all Contributors for the Covered Software under Section
+2.1 of this License shall terminate.
+
+5.3. In the event of termination under Sections 5.1 or 5.2 above, all
+end user license agreements (excluding distributors and resellers) which
+have been validly granted by You or Your distributors under this License
+prior to termination shall survive termination.
+
+************************************************************************
+* *
+* 6. Disclaimer of Warranty *
+* ------------------------- *
+* *
+* Covered Software is provided under this License on an "as is" *
+* basis, without warranty of any kind, either expressed, implied, or *
+* statutory, including, without limitation, warranties that the *
+* Covered Software is free of defects, merchantable, fit for a *
+* particular purpose or non-infringing. The entire risk as to the *
+* quality and performance of the Covered Software is with You. *
+* Should any Covered Software prove defective in any respect, You *
+* (not any Contributor) assume the cost of any necessary servicing, *
+* repair, or correction. This disclaimer of warranty constitutes an *
+* essential part of this License. No use of any Covered Software is *
+* authorized under this License except under this disclaimer. *
+* *
+************************************************************************
+
+************************************************************************
+* *
+* 7. Limitation of Liability *
+* -------------------------- *
+* *
+* Under no circumstances and under no legal theory, whether tort *
+* (including negligence), contract, or otherwise, shall any *
+* Contributor, or anyone who distributes Covered Software as *
+* permitted above, be liable to You for any direct, indirect, *
+* special, incidental, or consequential damages of any character *
+* including, without limitation, damages for lost profits, loss of *
+* goodwill, work stoppage, computer failure or malfunction, or any *
+* and all other commercial damages or losses, even if such party *
+* shall have been informed of the possibility of such damages. This *
+* limitation of liability shall not apply to liability for death or *
+* personal injury resulting from such party's negligence to the *
+* extent applicable law prohibits such limitation. Some *
+* jurisdictions do not allow the exclusion or limitation of *
+* incidental or consequential damages, so this exclusion and *
+* limitation may not apply to You. *
+* *
+************************************************************************
+
+8. Litigation
+-------------
+
+Any litigation relating to this License may be brought only in the
+courts of a jurisdiction where the defendant maintains its principal
+place of business and such litigation shall be governed by laws of that
+jurisdiction, without reference to its conflict-of-law provisions.
+Nothing in this Section shall prevent a party's ability to bring
+cross-claims or counter-claims.
+
+9. Miscellaneous
+----------------
+
+This License represents the complete agreement concerning the subject
+matter hereof. If any provision of this License is held to be
+unenforceable, such provision shall be reformed only to the extent
+necessary to make it enforceable. Any law or regulation which provides
+that the language of a contract shall be construed against the drafter
+shall not be used to construe this License against a Contributor.
+
+10. Versions of the License
+---------------------------
+
+10.1. New Versions
+
+Mozilla Foundation is the license steward. Except as provided in Section
+10.3, no one other than the license steward has the right to modify or
+publish new versions of this License. Each version will be given a
+distinguishing version number.
+
+10.2. Effect of New Versions
+
+You may distribute the Covered Software under the terms of the version
+of the License under which You originally received the Covered Software,
+or under the terms of any subsequent version published by the license
+steward.
+
+10.3. Modified Versions
+
+If you create software not governed by this License, and you want to
+create a new license for such software, you may create and use a
+modified version of this License if you rename the license and remove
+any references to the name of the license steward (except to note that
+such modified license differs from this License).
+
+10.4. Distributing Source Code Form that is Incompatible With Secondary
+Licenses
+
+If You choose to distribute Source Code Form that is Incompatible With
+Secondary Licenses under the terms of this version of the License, the
+notice described in Exhibit B of this License must be attached.
+
+Exhibit A - Source Code Form License Notice
+-------------------------------------------
+
+ This Source Code Form is subject to the terms of the Mozilla Public
+ License, v. 2.0. If a copy of the MPL was not distributed with this
+ file, You can obtain one at http://mozilla.org/MPL/2.0/.
+
+If it is not possible or desirable to put the notice in a particular
+file, then You may include the notice in a location (such as a LICENSE
+file in a relevant directory) where a recipient would be likely to look
+for such a notice.
+
+You may add additional accurate notices of copyright ownership.
+
+Exhibit B - "Incompatible With Secondary Licenses" Notice
+---------------------------------------------------------
+
+ This Source Code Form is "Incompatible With Secondary Licenses", as
+ defined by the Mozilla Public License, v. 2.0.
diff --git a/References/DelphiAST/README.md b/References/DelphiAST/README.md
new file mode 100644
index 000000000..6f9edc0dd
--- /dev/null
+++ b/References/DelphiAST/README.md
@@ -0,0 +1,91 @@
+[](https://github.com/RomanYankovsky/DelphiAST) [](https://github.com/RomanYankovsky/DelphiAST) [](https://github.com/RomanYankovsky/DelphiAST)
+### Abstract Syntax Tree Builder for Delphi
+With DelphiAST you can take real Delphi code and get an abstract syntax tree. One unit at time and without a symbol table though.
+
+FreePascal and Lazarus compatible.
+
+#### Sample input
+```delphi
+unit Unit1;
+
+interface
+
+uses
+ Unit2;
+
+function Sum(A, B: Integer): Integer;
+
+implementation
+
+function Sum(A, B: Integer): Integer;
+begin
+ Result := A + B;
+end;
+
+end.
+```
+
+#### Sample outcome
+```xml
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+```
+
+#### Copyright
+Copyright (c) 2014-2020 Roman Yankovsky (roman@yankovsky.me) et al
+
+DelphiAST is released under the Mozilla Public License, v. 2.0
+
+See LICENSE for details.
diff --git a/References/DelphiAST/Source/DelphiAST.Classes.pas b/References/DelphiAST/Source/DelphiAST.Classes.pas
new file mode 100644
index 000000000..0da6f4978
--- /dev/null
+++ b/References/DelphiAST/Source/DelphiAST.Classes.pas
@@ -0,0 +1,587 @@
+unit DelphiAST.Classes;
+
+{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
+
+interface
+
+uses
+ SysUtils, Generics.Collections, SimpleParser.Lexer.Types, DelphiAST.Consts;
+
+type
+ EParserException = class(Exception)
+ strict private
+ FFileName: string;
+ FLine, FCol: Integer;
+ public
+ constructor Create(Line, Col: Integer; const FileName, Msg: string); reintroduce;
+
+ property FileName: string read FFileName;
+ property Line: Integer read FLine;
+ property Col: Integer read FCol;
+ end;
+
+ TAttributeEntry = TPair;
+ PAttributeEntry = ^TAttributeEntry;
+
+ TSyntaxNodeClass = class of TSyntaxNode;
+ TSyntaxNode = class
+ private
+ FLineSeq: Integer;
+ FCol: Integer;
+ FLine: Integer;
+ FFileName: string;
+ function GetHasChildren: Boolean;
+ function GetHasAttributes: Boolean;
+ function TryGetAttributeEntry(const Key: TAttributeName; var AttributeEntry: PAttributeEntry): boolean;
+ protected
+ FAttributes: TArray;
+ FChildNodes: TArray;
+ FTyp: TSyntaxNodeType;
+ FParentNode: TSyntaxNode;
+ public
+ constructor Create(Typ: TSyntaxNodeType);
+ destructor Destroy; override;
+
+ function Clone: TSyntaxNode; virtual;
+ procedure AssignPositionFrom(const Node: TSyntaxNode);
+
+ function GetAttribute(const Key: TAttributeName): string;
+ function HasAttribute(const Key: TAttributeName): Boolean;
+ procedure SetAttribute(const Key: TAttributeName; const Value: string);
+ procedure ClearAttributes;
+
+ function AddChild(Node: TSyntaxNode): TSyntaxNode; overload;
+ function AddChild(Typ: TSyntaxNodeType): TSyntaxNode; overload;
+ procedure DeleteChild(Node: TSyntaxNode);
+ procedure ExtractChild(Node: TSyntaxNode);
+ function FindNode(Typ: TSyntaxNodeType): TSyntaxNode; overload;
+ // Searches for a node located along the path from the type of nodes
+ // specified in the TypesPath parameter.
+ // ntUnknown in the TypesPath parameter means a node of any type.
+ // For example, for the branch presented below as XML
+ // FindNode([ntAbsolute, ntValue, ntExpression, ntIdentifier]),
+ // FindNode([ntAbsolute, ntUnknown, ntExpression, ntIdentifier]) è
+ // FindNode([ntAbsolute, ntUnknown, ntUnknown, ntIdentifier])
+ // return the IDENTIFIER node.
+ //
+ //
+ //
+ //
+ //
+ //
+ //
+ //
+ //
+ //
+ // .
+ function FindNode(const TypesPath: array of TSyntaxNodeType): TSyntaxNode; overload;
+ property Attributes: TArray read FAttributes;
+ property ChildNodes: TArray read FChildNodes;
+ property HasAttributes: Boolean read GetHasAttributes;
+ property HasChildren: Boolean read GetHasChildren;
+ property Typ: TSyntaxNodeType read FTyp;
+ property ParentNode: TSyntaxNode read FParentNode;
+
+ property LineSeq: Integer read FLineSeq write FLineSeq;
+ property Col: Integer read FCol write FCol;
+ property Line: Integer read FLine write FLine;
+ property FileName: string read FFileName write FFileName;
+ end;
+
+ TCompoundSyntaxNode = class(TSyntaxNode)
+ private
+ FEndCol: Integer;
+ FEndLine: Integer;
+ public
+ function Clone: TSyntaxNode; override;
+
+ property EndCol: Integer read FEndCol write FEndCol;
+ property EndLine: Integer read FEndLine write FEndLine;
+ end;
+
+ TValuedSyntaxNode = class(TSyntaxNode)
+ private
+ FValue: string;
+ public
+ function Clone: TSyntaxNode; override;
+
+ property Value: string read FValue write FValue;
+ end;
+
+ TCommentNode = class(TSyntaxNode)
+ private
+ FText: string;
+ public
+ function Clone: TSyntaxNode; override;
+
+ property Text: string read FText write FText;
+ end;
+
+ TExpressionTools = class
+ private
+ class function CreateNodeWithParentsPosition(NodeType: TSyntaxNodeType; ParentNode: TSyntaxNode): TSyntaxNode;
+ public
+ class function ExprToReverseNotation(Expr: TList): TList; static;
+ class procedure NodeListToTree(Expr: TList; Root: TSyntaxNode); static;
+ class function PrepareExpr(ExprNodes: TList): TList; static;
+ class procedure RawNodeListToTree(RawParentNode: TSyntaxNode; RawNodeList: TList; NewRoot: TSyntaxNode); static;
+ end;
+
+implementation
+
+type
+ TOperatorKind = (okUnary, okBinary);
+ TOperatorAssocType = (atLeft, atRight);
+
+ TOperatorInfo = record
+ Typ: TSyntaxNodeType;
+ Priority: Byte;
+ Kind: TOperatorKind;
+ AssocType: TOperatorAssocType;
+ end;
+
+ TOperators = class
+ strict private
+ class function GetItem(Typ: TSyntaxNodeType): TOperatorInfo; static;
+ public
+ class function IsOpName(Typ: TSyntaxNodeType): Boolean;
+ class property Items[Typ: TSyntaxNodeType]: TOperatorInfo read GetItem; default;
+ end;
+
+const
+ OperatorsInfo: array [0..29] of TOperatorInfo =
+ ((Typ: ntAddr; Priority: 1; Kind: okUnary; AssocType: atRight),
+ (Typ: ntDeref; Priority: 1; Kind: okUnary; AssocType: atLeft),
+ (Typ: ntGeneric; Priority: 1; Kind: okBinary; AssocType: atRight),
+ (Typ: ntIndexed; Priority: 1; Kind: okUnary; AssocType: atLeft),
+ (Typ: ntDot; Priority: 2; Kind: okBinary; AssocType: atRight),
+ (Typ: ntCall; Priority: 3; Kind: okBinary; AssocType: atRight),
+ (Typ: ntUnaryMinus; Priority: 5; Kind: okUnary; AssocType: atRight),
+ (Typ: ntNot; Priority: 6; Kind: okUnary; AssocType: atRight),
+ (Typ: ntMul; Priority: 7; Kind: okBinary; AssocType: atRight),
+ (Typ: ntFDiv; Priority: 7; Kind: okBinary; AssocType: atRight),
+ (Typ: ntDiv; Priority: 7; Kind: okBinary; AssocType: atRight),
+ (Typ: ntMod; Priority: 7; Kind: okBinary; AssocType: atRight),
+ (Typ: ntAnd; Priority: 7; Kind: okBinary; AssocType: atRight),
+ (Typ: ntShl; Priority: 7; Kind: okBinary; AssocType: atRight),
+ (Typ: ntShr; Priority: 7; Kind: okBinary; AssocType: atRight),
+ (Typ: ntAs; Priority: 7; Kind: okBinary; AssocType: atRight),
+ (Typ: ntAdd; Priority: 8; Kind: okBinary; AssocType: atRight),
+ (Typ: ntSub; Priority: 8; Kind: okBinary; AssocType: atRight),
+ (Typ: ntOr; Priority: 8; Kind: okBinary; AssocType: atRight),
+ (Typ: ntXor; Priority: 8; Kind: okBinary; AssocType: atRight),
+ (Typ: ntEqual; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntNotEqual; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntLower; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntGreater; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntLowerEqual; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntGreaterEqual; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntIn; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntNotIn; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntIs; Priority: 9; Kind: okBinary; AssocType: atRight),
+ (Typ: ntIsNot; Priority: 9; Kind: okBinary; AssocType: atRight));
+
+{ TOperators }
+
+class function TOperators.GetItem(Typ: TSyntaxNodeType): TOperatorInfo;
+var
+ i: Integer;
+begin
+ for i := 0 to High(OperatorsInfo) do
+ if OperatorsInfo[i].Typ = Typ then
+ Exit(OperatorsInfo[i]);
+end;
+
+class function TOperators.IsOpName(Typ: TSyntaxNodeType): Boolean;
+var
+ i: Integer;
+begin
+ for i := 0 to High(OperatorsInfo) do
+ if OperatorsInfo[i].Typ = Typ then
+ Exit(True);
+ Result := False;
+end;
+
+function IsRoundClose(Typ: TSyntaxNodeType): Boolean; inline;
+begin
+ Result := Typ = ntRoundClose;
+end;
+
+function IsRoundOpen(Typ: TSyntaxNodeType): Boolean; inline;
+begin
+ Result := Typ = ntRoundOpen;
+end;
+
+class function TExpressionTools.ExprToReverseNotation(Expr: TList): TList;
+var
+ Stack: TStack;
+ Node: TSyntaxNode;
+begin
+ Result := TList.Create;
+ try
+ Stack := TStack.Create;
+ try
+ for Node in Expr do
+ if TOperators.IsOpName(Node.Typ) then
+ begin
+ while (Stack.Count > 0) and TOperators.IsOpName(Stack.Peek.Typ) and
+ (((TOperators.Items[Node.Typ].AssocType = atLeft) and
+ (TOperators.Items[Node.Typ].Priority >= TOperators.Items[Stack.Peek.Typ].Priority))
+ or
+ ((TOperators.Items[Node.Typ].AssocType = atRight) and
+ (TOperators.Items[Node.Typ].Priority > TOperators.Items[Stack.Peek.Typ].Priority)))
+ do
+ Result.Add(Stack.Pop);
+
+ Stack.Push(Node);
+ end
+ else if IsRoundOpen(Node.Typ) then
+ Stack.Push(Node)
+ else if IsRoundClose(Node.Typ) then
+ begin
+ while not IsRoundOpen(Stack.Peek.Typ) do
+ Result.Add(Stack.Pop);
+
+ // RoundOpen and RoundClose nodes are not needed anymore
+ Stack.Pop.Free;
+ Node.Free;
+
+ if (Stack.Count > 0) and TOperators.IsOpName(Stack.Peek.Typ) then
+ Result.Add(Stack.Pop);
+ end else
+ Result.Add(Node);
+
+ while Stack.Count > 0 do
+ Result.Add(Stack.Pop);
+ finally
+ Stack.Free;
+ end;
+ except
+ FreeAndNil(Result);
+ raise;
+ end;
+end;
+
+class procedure TExpressionTools.NodeListToTree(Expr: TList; Root: TSyntaxNode);
+var
+ Stack: TStack;
+ Node, SecondNode: TSyntaxNode;
+begin
+ Stack := TStack.Create;
+ try
+ for Node in Expr do
+ begin
+ if TOperators.IsOpName(Node.Typ) then
+ case TOperators.Items[Node.Typ].Kind of
+ okUnary: Node.AddChild(Stack.Pop);
+ okBinary:
+ begin
+ SecondNode := Stack.Pop;
+ Node.AddChild(Stack.Pop);
+ Node.AddChild(SecondNode);
+ end;
+ end;
+ Stack.Push(Node);
+ end;
+
+ Root.AddChild(Stack.Pop);
+
+ Assert(Stack.Count = 0);
+ finally
+ Stack.Free;
+ end;
+end;
+
+class function TExpressionTools.PrepareExpr(ExprNodes: TList): TList;
+var
+ Node, PrevNode: TSyntaxNode;
+begin
+ Result := TList.Create;
+ try
+ Result.Capacity := ExprNodes.Count * 2;
+
+ PrevNode := nil;
+ for Node in ExprNodes do
+ begin
+ if Node.Typ = ntCall then
+ Continue;
+
+ if Assigned(PrevNode) and IsRoundOpen(Node.Typ) then
+ begin
+ if not TOperators.IsOpName(PrevNode.Typ) and not IsRoundOpen(PrevNode.Typ) then
+ Result.Add(CreateNodeWithParentsPosition(ntCall, Node.ParentNode));
+
+ if TOperators.IsOpName(PrevNode.Typ)
+ and (TOperators.Items[PrevNode.Typ].Kind = okUnary)
+ and (TOperators.Items[PrevNode.Typ].AssocType = atLeft)
+ then
+ Result.Add(CreateNodeWithParentsPosition(ntCall, Node.ParentNode));
+ end;
+
+ if Assigned(PrevNode) and (Node.Typ = ntTypeArgs) then
+ begin
+ if not TOperators.IsOpName(PrevNode.Typ) and (PrevNode.Typ <> ntTypeArgs) then
+ Result.Add(CreateNodeWithParentsPosition(ntGeneric, Node.ParentNode));
+
+ if TOperators.IsOpName(PrevNode.Typ)
+ and (TOperators.Items[PrevNode.Typ].Kind = okUnary)
+ and (TOperators.Items[PrevNode.Typ].AssocType = atLeft)
+ then
+ Result.Add(CreateNodeWithParentsPosition(ntGeneric, Node.ParentNode));
+ end;
+
+ if Node.Typ <> ntAlignmentParam then
+ Result.Add(Node.Clone);
+ PrevNode := Node;
+ end;
+ except
+ FreeAndNil(Result);
+ raise;
+ end;
+end;
+
+class function TExpressionTools.CreateNodeWithParentsPosition(NodeType: TSyntaxNodeType; ParentNode: TSyntaxNode): TSyntaxNode;
+begin
+ Result := TSyntaxNode.Create(NodeType);
+ Result.AssignPositionFrom(ParentNode);
+end;
+
+class procedure TExpressionTools.RawNodeListToTree(RawParentNode: TSyntaxNode; RawNodeList: TList;
+ NewRoot: TSyntaxNode);
+var
+ PreparedNodeList, ReverseNodeList: TList;
+begin
+ try
+ PreparedNodeList := PrepareExpr(RawNodeList);
+ try
+ ReverseNodeList := ExprToReverseNotation(PreparedNodeList);
+ try
+ NodeListToTree(ReverseNodeList, NewRoot);
+ finally
+ ReverseNodeList.Free;
+ end;
+ finally
+ PreparedNodeList.Free;
+ end;
+ except
+ on E: Exception do
+ raise EParserException.Create(NewRoot.Line, NewRoot.Col, NewRoot.FileName, E.Message);
+ end;
+end;
+
+{ TSyntaxNode }
+
+procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: string);
+var
+ AttributeEntry: PAttributeEntry;
+ len: Integer;
+begin
+ if not TryGetAttributeEntry(Key, AttributeEntry) then
+ begin
+ len := Length(FAttributes);
+ SetLength(FAttributes, len + 1);
+ AttributeEntry := @FAttributes[len];
+ AttributeEntry^.Key := Key;
+ end;
+ AttributeEntry^.Value := Value;
+end;
+
+function TSyntaxNode.TryGetAttributeEntry(const Key: TAttributeName; var AttributeEntry: PAttributeEntry): boolean;
+var
+ i: integer;
+begin
+ for i := 0 to High(FAttributes) do
+ if FAttributes[i].Key = Key then
+ begin
+ AttributeEntry := @FAttributes[i];
+ Exit(True);
+ end;
+
+ Result := False;
+end;
+
+function TSyntaxNode.AddChild(Node: TSyntaxNode): TSyntaxNode;
+begin
+ Assert(Assigned(Node));
+
+ SetLength(FChildNodes, Length(FChildNodes) + 1);
+ FChildNodes[Length(FChildNodes) - 1] := Node;
+
+ Node.FParentNode := Self;
+
+ Result := Node;
+end;
+
+function TSyntaxNode.AddChild(Typ: TSyntaxNodeType): TSyntaxNode;
+begin
+ Result := AddChild(TSyntaxNode.Create(Typ));
+end;
+
+function TSyntaxNode.Clone: TSyntaxNode;
+var
+ i: Integer;
+begin
+ Result := TSyntaxNodeClass(Self.ClassType).Create(FTyp);
+
+ SetLength(Result.FChildNodes, Length(FChildNodes));
+ for i := 0 to High(FChildNodes) do
+ begin
+ Result.FChildNodes[i] := FChildNodes[i].Clone;
+ Result.FChildNodes[i].FParentNode := Result;
+ end;
+
+ Result.FAttributes := Copy(FAttributes);
+ Result.AssignPositionFrom(Self);
+end;
+
+constructor TSyntaxNode.Create(Typ: TSyntaxNodeType);
+begin
+ inherited Create;
+ FTyp := Typ;
+end;
+
+procedure TSyntaxNode.ExtractChild(Node: TSyntaxNode);
+var
+ i: integer;
+begin
+ for i := 0 to High(FChildNodes) do
+ if FChildNodes[i] = Node then
+ begin
+ if i < High(FChildNodes) then
+ Move(FChildNodes[i + 1], FChildNodes[i], SizeOf(TSyntaxNode) * (Length(FChildNodes) - i - 1));
+ SetLength(FChildNodes, High(FChildNodes));
+ Break;
+ end;
+end;
+
+procedure TSyntaxNode.DeleteChild(Node: TSyntaxNode);
+begin
+ ExtractChild(Node);
+ Node.Free;
+end;
+
+destructor TSyntaxNode.Destroy;
+var
+ i: integer;
+begin
+ for i := 0 to High(FChildNodes) do
+ FreeAndNil(FChildNodes[i]);
+ inherited;
+end;
+
+function TSyntaxNode.FindNode(Typ: TSyntaxNodeType): TSyntaxNode;
+var
+ i: Integer;
+begin
+ for i := 0 to High(FChildNodes) do
+ if FChildNodes[i].Typ = Typ then
+ Exit(FChildNodes[i]);
+ Result := nil;
+end;
+
+function TSyntaxNode.FindNode(const TypesPath: array of TSyntaxNodeType): TSyntaxNode;
+
+ function FindNodeRecursively(Node: TSyntaxNode;
+ const TypesPath: array of TSyntaxNodeType; TypeIndex: Integer): TSyntaxNode;
+ var
+ ChildNode: TSyntaxNode;
+ begin
+ Result := nil;
+ for ChildNode in Node.ChildNodes do
+ if TypesPath[TypeIndex] in [ChildNode.Typ] + [ntUnknown] then
+ begin
+ if TypeIndex < High(TypesPath) then
+ Result := FindNodeRecursively(ChildNode, TypesPath, TypeIndex + 1)
+ else
+ Result := ChildNode;
+ if Assigned(Result) then
+ Exit;
+ end;
+ end;
+
+begin
+ if TypesPath[High(TypesPath)] <> ntUnknown then
+ Result := FindNodeRecursively(Self, TypesPath, Low(TypesPath))
+ else
+ Result := nil;
+end;
+
+function TSyntaxNode.GetAttribute(const Key: TAttributeName): string;
+var
+ AttributeEntry: PAttributeEntry;
+begin
+ if TryGetAttributeEntry(Key, AttributeEntry) then
+ Result := AttributeEntry^.Value
+ else
+ Result := '';
+end;
+
+function TSyntaxNode.GetHasAttributes: Boolean;
+begin
+ Result := Length(FAttributes) > 0;
+end;
+
+function TSyntaxNode.GetHasChildren: Boolean;
+begin
+ Result := Length(FChildNodes) > 0;
+end;
+
+function TSyntaxNode.HasAttribute(const Key: TAttributeName): Boolean;
+var
+ AttributeEntry: PAttributeEntry;
+begin
+ Result := TryGetAttributeEntry(Key, AttributeEntry);
+end;
+
+procedure TSyntaxNode.ClearAttributes;
+begin
+ SetLength(FAttributes, 0);
+end;
+
+procedure TSyntaxNode.AssignPositionFrom(const Node: TSyntaxNode);
+begin
+ FLineSeq := Node.LineSeq;
+ FCol := Node.Col;
+ FLine := Node.Line;
+ FFileName := Node.FileName;
+end;
+
+{ TCompoundSyntaxNode }
+
+function TCompoundSyntaxNode.Clone: TSyntaxNode;
+begin
+ Result := inherited;
+
+ TCompoundSyntaxNode(Result).EndLine := Self.EndLine;
+ TCompoundSyntaxNode(Result).EndCol := Self.EndCol;
+end;
+
+{ TValuedSyntaxNode }
+
+function TValuedSyntaxNode.Clone: TSyntaxNode;
+begin
+ Result := inherited;
+
+ TValuedSyntaxNode(Result).Value := Self.Value;
+end;
+
+{ TCommentNode }
+
+function TCommentNode.Clone: TSyntaxNode;
+begin
+ Result := inherited;
+
+ TCommentNode(Result).Text := Self.Text;
+end;
+
+{ EParserException }
+
+constructor EParserException.Create(Line, Col: Integer; const FileName, Msg: string);
+begin
+ inherited Create(Msg);
+ FFileName := FileName;
+ FLine := Line;
+ FCol := Col;
+end;
+
+end.
\ No newline at end of file
diff --git a/References/DelphiAST/Source/DelphiAST.Consts.pas b/References/DelphiAST/Source/DelphiAST.Consts.pas
new file mode 100644
index 000000000..13522c037
--- /dev/null
+++ b/References/DelphiAST/Source/DelphiAST.Consts.pas
@@ -0,0 +1,323 @@
+unit DelphiAST.Consts;
+
+interface
+
+type
+ TSyntaxNodeType = (
+ ntUnknown,
+ ntAbsolute,
+ ntAdd,
+ ntAddr,
+ ntAlignmentParam,
+ ntAnd,
+ ntAnonymousMethod,
+ ntArguments,
+ ntAs,
+ ntAssign,
+ ntAt,
+ ntAttribute,
+ ntAttributes,
+ ntBounds,
+ ntCall,
+ ntCase,
+ ntCaseElse,
+ ntCaseLabel,
+ ntCaseLabels,
+ ntCaseSelector,
+ ntClassConstraint,
+ ntConstant,
+ ntConstants,
+ ntConstraints,
+ ntConstructorConstraint,
+ ntContains,
+ ntDefault,
+ ntDeref,
+ ntDimension,
+ ntDiv,
+ ntDot,
+ ntDownTo,
+ ntElement,
+ ntElse,
+ ntEmptyStatement,
+ ntEnum,
+ ntEqual,
+ ntExcept,
+ ntExceptionHandler,
+ ntExports,
+ ntExpression,
+ ntExpressions,
+ ntExternal,
+ ntFDiv,
+ ntField,
+ ntFields,
+ ntFinalization,
+ ntFinally,
+ ntFor,
+ ntFrom,
+ ntGeneric,
+ ntGoto,
+ ntGreater,
+ ntGreaterEqual,
+ ntGuid,
+ ntHelper,
+ ntIdentifier,
+ ntIf,
+ ntImplementation,
+ ntImplements,
+ ntIn,
+ ntIndex,
+ ntIndexed,
+ ntInherited,
+ ntInitialization,
+ ntInterface,
+ ntIs,
+ ntIsNot,
+ ntLabel,
+ ntLHS,
+ ntLiteral,
+ ntLower,
+ ntLowerEqual,
+ ntMessage,
+ ntMethod,
+ ntMod,
+ ntMul,
+ ntName,
+ ntNamedArgument,
+ ntNotEqual,
+ ntNot,
+ ntNotIn,
+ ntOr,
+ ntPackage,
+ ntParameter,
+ ntParameters,
+ ntPath,
+ ntPositionalArgument,
+ ntProtected,
+ ntPrivate,
+ ntProperty,
+ ntPublic,
+ ntPublished,
+ ntRaise,
+ ntRead,
+ ntRecordConstraint,
+ ntRepeat,
+ ntRequires,
+ ntResolutionClause,
+ ntResourceString,
+ ntReturnType,
+ ntRHS,
+ ntRoundClose,
+ ntRoundOpen,
+ ntSet,
+ ntShl,
+ ntShr,
+ ntStatement,
+ ntStatements,
+ ntStrictPrivate,
+ ntStrictProtected,
+ ntSub,
+ ntSubrange,
+ ntTernaryOp,
+ ntThen,
+ ntTo,
+ ntTry,
+ ntType,
+ ntTypeArgs,
+ ntTypeDecl,
+ ntTypeParam,
+ ntTypeParams,
+ ntTypeSection,
+ ntValue,
+ ntVariable,
+ ntVariables,
+ ntXor,
+ ntUnaryMinus,
+ ntUnit,
+ ntUses,
+ ntWhile,
+ ntWith,
+ ntWrite,
+
+ ntAnsiComment,
+ ntBorComment,
+ ntSlashesComment
+ );
+
+ TAttributeName = (
+ anType,
+ anClass,
+ anForwarded,
+ anKind,
+ anName,
+ anVisibility,
+ anCallingConvention,
+ anPath,
+ anMethodBinding,
+ anReintroduce,
+ anOverload,
+ anAbstract,
+ anInline,
+ anAlign
+ );
+
+const
+ SyntaxNodeNames: array [TSyntaxNodeType] of string = (
+ 'unknown',
+ 'absolute',
+ 'add',
+ 'addr',
+ 'alignmentparam',
+ 'and',
+ 'anonymousmethod',
+ 'arguments',
+ 'as',
+ 'assign',
+ 'at',
+ 'attribute',
+ 'attributes',
+ 'bounds',
+ 'call',
+ 'case',
+ 'caseelse',
+ 'caselabel',
+ 'caselabels',
+ 'caseselector',
+ 'classconstraint',
+ 'constant',
+ 'constants',
+ 'constraints',
+ 'constructorconstraint',
+ 'contains',
+ 'default',
+ 'deref',
+ 'dimension',
+ 'div',
+ 'dot',
+ 'downto',
+ 'element',
+ 'else',
+ 'emptystatement',
+ 'enum',
+ 'equal',
+ 'except',
+ 'exceptionhandler',
+ 'exports',
+ 'expression',
+ 'expressions',
+ 'external',
+ 'fdiv',
+ 'field',
+ 'fields',
+ 'finalization',
+ 'finally',
+ 'for',
+ 'from',
+ 'generic',
+ 'goto',
+ 'greater',
+ 'greaterequal',
+ 'guid',
+ 'helper',
+ 'identifier',
+ 'if',
+ 'implementation',
+ 'implements',
+ 'in',
+ 'index',
+ 'indexed',
+ 'inherited',
+ 'initialization',
+ 'interface',
+ 'is',
+ 'isnot',
+ 'label',
+ 'lhs',
+ 'literal',
+ 'lower',
+ 'lowerequal',
+ 'message',
+ 'method',
+ 'mod',
+ 'mul',
+ 'name',
+ 'namedargument',
+ 'notequal',
+ 'not',
+ 'notin',
+ 'or',
+ 'package',
+ 'parameter',
+ 'parameters',
+ 'path',
+ 'positionalargument',
+ 'protected',
+ 'private',
+ 'property',
+ 'public',
+ 'published',
+ 'raise',
+ 'read',
+ 'recordconstraint',
+ 'repeat',
+ 'requires',
+ 'resolutionclause',
+ 'resourcestring',
+ 'returntype',
+ 'rhs',
+ 'roundclose',
+ 'roundopen',
+ 'set',
+ 'shl',
+ 'shr',
+ 'statement',
+ 'statements',
+ 'strictprivate',
+ 'strictprotected',
+ 'sub',
+ 'subrange',
+ 'ternaryop',
+ 'then',
+ 'to',
+ 'try',
+ 'type',
+ 'typeargs',
+ 'typedecl',
+ 'typeparam',
+ 'typeparams',
+ 'typesection',
+ 'value',
+ 'variable',
+ 'variables',
+ 'xor',
+ 'unaryminus',
+ 'unit',
+ 'uses',
+ 'while',
+ 'with',
+ 'write',
+
+ 'ansicomment',
+ 'borlandcomment',
+ 'slashescomment'
+ );
+
+ AttributeNameStrings: array[TAttributeName] of string = (
+ 'type',
+ 'class',
+ 'forwarded',
+ 'kind',
+ 'name',
+ 'visibility',
+ 'callingconvention',
+ 'path',
+ 'methodbinding',
+ 'reintroduce',
+ 'overload',
+ 'abstract',
+ 'inline',
+ 'align'
+ );
+
+implementation
+
+end.
diff --git a/References/DelphiAST/Source/DelphiAST.ProjectIndexer.pas b/References/DelphiAST/Source/DelphiAST.ProjectIndexer.pas
new file mode 100644
index 000000000..4370f5469
--- /dev/null
+++ b/References/DelphiAST/Source/DelphiAST.ProjectIndexer.pas
@@ -0,0 +1,615 @@
+unit DelphiAST.ProjectIndexer;
+
+{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
+
+interface
+
+uses
+ Classes, Generics.Defaults, Generics.Collections,
+ SimpleParser.Lexer.Types,
+ DelphiAST, DelphiAST.Classes, DelphiAST.Consts;
+
+type
+ TProjectIndexer = class
+ strict private type
+ TParsedUnitsCache = TObjectDictionary;
+ TUnitPathsCache = TDictionary;
+
+ TIncludeInfo = record
+ FileName: string;
+ Content : string;
+ end;
+
+ TIncludeCache = TDictionary;
+
+ public type
+ TOption = (piUseDefinesDefinedByCompiler);
+ TOptions = set of TOption;
+ TGetUnitSyntaxEvent = procedure (Sender: TObject; const fileName: string;
+ var syntaxTree: TSyntaxNode; var doParseUnit, doAbort: boolean) of object;
+ TUnitParsedEvent = procedure (Sender: TObject; const unitName: string; const fileName: string;
+ var syntaxTree: TSyntaxNode; syntaxTreeFromParser: boolean; var doAbort: boolean) of object;
+
+ TUnitInfo = record
+ Name: string;
+ Path: string;
+ SyntaxTree: TSyntaxNode;
+ HasError: boolean;
+ ErrorInfo: record
+ Line: integer;
+ Col: integer;
+ Error: string;
+ end;
+ end;
+
+ TParsedUnits = class(TList)
+ protected
+ procedure Initialize(parsedUnits: TParsedUnitsCache; unitPaths: TUnitPathsCache);
+ end;
+
+ TIncludeFileInfo = record
+ Name: string;
+ Path: string;
+ end;
+
+ TIncludeFiles = class(TList)
+ protected
+ procedure Initialize(includeCache: TIncludeCache);
+ end;
+
+ TProblemType = (ptCantFindFile, ptCantOpenFile, ptCantParseFile);
+ TProblemInfo = record
+ ProblemType: TProblemType;
+ FileName : string;
+ Description: string;
+ end;
+
+ TProblems = class(TList)
+ protected
+ procedure LogProblem(problemType: TProblemType; const fileName, description: string);
+ end;
+
+ strict private type
+ TIncludeHandler = class(TInterfacedObject, IIncludeHandler)
+ strict private
+ [weak] FIncludeCache: TIncludeCache;
+ [weak] FIndexer : TProjectIndexer;
+ [weak] FProblems : TProblems;
+ FUnitFile : string;
+ FUnitFileFolder : string;
+ public
+ constructor Create(indexer: TProjectIndexer; includeCache: TIncludeCache;
+ problemList: TProblems; const currentFile: string);
+ function GetIncludeFileContent(const ParentFileName, FileName: string; out Content: string;
+ out filePath: string): Boolean;
+ end;
+
+ var
+ FAborting : boolean;
+ FDefines : string;
+ FDefinesList : TStringList;
+ FIncludeCache : TIncludeCache;
+ FIncludeFiles : TIncludeFiles;
+ FNotFoundUnits : TStringList;
+ FOnGetUnitSyntax: TGetUnitSyntaxEvent;
+ FOnUnitParsed : TUnitParsedEvent;
+ FOptions : TOptions;
+ FParsedUnits : TParsedUnitsCache;
+ FParsedUnitsInfo: TParsedUnits;
+ FProblems : TProblems;
+ FProjectFolder : string;
+ FSearchPath : string;
+ FSearchPaths : TStringList;
+ FUnitPaths : TUnitPathsCache;
+ strict protected
+ procedure AppendUnits(usesNode: TSyntaxNode; const filePath: string; unitList: TStrings);
+ procedure BuildUsesList(unitNode: TSyntaxNode; const fileName: string; isProject: boolean;
+ unitList: TStringList);
+ function FindType(node: TSyntaxNode; nodeType: TSyntaxNodeType): TSyntaxNode;
+ procedure GetUnitSyntax(const fileName: string; var syntaxTree: TSyntaxNode; var
+ doParseUnit: boolean);
+ procedure NotifyUnitParsed(const unitName, fileName: string; var syntaxTree: TSyntaxNode;
+ syntaxTreeFromParser: boolean);
+ procedure ParseUnit(const unitName: string; const fileName: string; isProject: boolean);
+ procedure PrepareSearchPath;
+ procedure PrepareDefines;
+ procedure RunParserOnUnit(const fileName: string; var syntaxTree: TSyntaxNode);
+ procedure ScanUsedUnits(const unitName, fileName: string; isProject: boolean;
+ syntaxTree: TSyntaxNode; syntaxTreeFromParser: boolean);
+ protected
+ function FindFile(const fileName: string; relativeToFolder: string; var filePath: string): boolean;
+ class function SafeOpenFileStream(const fileName: string; var fileStream: TStringStream;
+ var errorMsg: string): boolean;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Index(const fileName: string);
+ property Defines: string read FDefines write FDefines;
+ property Options: TOptions read FOptions write FOptions default [piUseDefinesDefinedByCompiler];
+ property ParsedUnits: TParsedUnits read FParsedUnitsInfo;
+ property IncludeFiles: TIncludeFiles read FIncludeFiles;
+ property Problems: TProblems read FProblems;
+ property NotFoundUnits: TStringList read FNotFoundUnits;
+ property SearchPath: string read FSearchPath write FSearchPath;
+ property OnGetUnitSyntax: TGetUnitSyntaxEvent read FOnGetUnitSyntax write FOnGetUnitSyntax;
+ property OnUnitParsed: TUnitParsedEvent read FOnUnitParsed write FOnUnitParsed;
+ end;
+
+implementation
+
+uses
+ SysUtils,
+ SimpleParser;
+
+{ TProjectIndexer.TParsedUnits }
+
+procedure TProjectIndexer.TParsedUnits.Initialize(parsedUnits: TParsedUnitsCache;
+ unitPaths: TUnitPathsCache);
+var
+ info : TUnitInfo;
+ kv : TPair;
+ unitPath: string;
+begin
+ Clear;
+ Capacity := parsedUnits.Count;
+
+ for kv in parsedUnits do begin
+ if not assigned(kv.Value) then
+ continue; //for kv
+ info.Name := kv.Key;
+ info.SyntaxTree := kv.Value;
+ if not (unitPaths.TryGetValue(kv.Key + '.pas', unitPath)
+ or unitPaths.TryGetValue(kv.Key + '.dpr', unitPath))
+ then
+ unitPath := '';
+ info.Path := unitPath;
+ info.HasError := false; // TODO 1 -oPrimoz Gabrijelcic : fix that
+ Add(info);
+ end;
+
+ TrimExcess;
+ Sort(
+ TComparer.Construct(
+ function(const Left, Right: TUnitInfo): integer
+ begin
+ Result := TOrdinalIStringComparer(TIStringComparer.Ordinal).Compare(Left.Name, Right.Name);
+ end));
+end;
+
+{ TProjectIndexer.TIncludeFiles }
+
+procedure TProjectIndexer.TIncludeFiles.Initialize(includeCache: TIncludeCache);
+var
+ info: TIncludeFileInfo;
+ kv : TPair;
+ p : integer;
+begin
+ Clear;
+ Capacity := includeCache.Count;
+
+ for kv in includeCache do begin
+ p := Pos(#13, kv.Key);
+ if p = 0 then
+ continue; //for kv
+
+ info.Name := Copy(kv.Key, 1, p-1);
+ info.Path := kv.Value.FileName;
+ Add(info);
+ end;
+
+ TrimExcess;
+ Sort(
+ TComparer.Construct(
+ function(const Left, Right: TIncludeFileInfo): integer
+ begin
+ Result := TOrdinalIStringComparer(TIStringComparer.Ordinal).Compare(Left.Name, Right.Name);
+ end));
+end;
+
+{ TProjectIndexer.TProblems }
+
+procedure TProjectIndexer.TProblems.LogProblem(problemType: TProblemType; const fileName,
+ description: string);
+var
+ info: TProblemInfo;
+begin
+ info.ProblemType := problemType;
+ info.FileName := fileName;
+ info.Description := description;
+ Add(info);
+end;
+
+{ TProjectIndexer }
+
+procedure TProjectIndexer.AppendUnits(usesNode: TSyntaxNode; const filePath: string;
+ unitList: TStrings);
+var
+ childNode: TSyntaxNode;
+ unitName : string;
+ unitPath : string;
+begin
+ for childNode in usesNode.ChildNodes do
+ if childNode.Typ = ntUnit then begin
+ unitName := childNode.GetAttribute(anName);
+ unitList.Add(unitName);
+ if not FUnitPaths.ContainsKey(unitName) then begin
+ unitPath := childNode.GetAttribute(anPath);
+ if unitPath <> '' then begin
+ if IsRelativePath(unitPath) then
+ unitPath := filePath + unitPath;
+ FUnitPaths.Add(unitName + '.pas', unitPath);
+ end;
+ end;
+ end;
+end;
+
+procedure TProjectIndexer.BuildUsesList(unitNode: TSyntaxNode; const fileName: string;
+ isProject: boolean; unitList: TStringList);
+var
+ fileFolder: string;
+ implNode : TSyntaxNode;
+ intfNode : TSyntaxNode;
+ usesNode : TSyntaxNode;
+begin
+ fileFolder := IncludeTrailingPathDelimiter(ExtractFilePath(fileName));
+ if isProject then begin
+ usesNode := FindType(unitNode, ntUses);
+ if assigned(usesNode) then
+ AppendUnits(usesNode, fileFolder, unitList);
+ usesNode := FindType(unitNode, ntContains);
+ if assigned(usesNode) then
+ AppendUnits(usesNode, fileFolder, unitList);
+ end
+ else begin
+ intfNode := FindType(unitNode, ntInterface);
+ if assigned(intfNode) then begin
+ usesNode := FindType(intfNode, ntUses);
+ if assigned(usesNode) then
+ AppendUnits(usesNode, fileFolder, unitList);
+ end;
+ implNode := FindType(unitNode, ntImplementation);
+ if assigned(implNode) then begin
+ usesNode := FindType(implNode, ntUses);
+ if assigned(usesNode) then
+ AppendUnits(usesNode, fileFolder, unitList);
+ end;
+ end;
+end;
+
+constructor TProjectIndexer.Create;
+begin
+ inherited Create;
+ FOptions := [piUseDefinesDefinedByCompiler];
+ FSearchPaths := TStringList.Create;
+ FSearchPaths.Delimiter := ';';
+ FSearchPaths.StrictDelimiter := true;
+ FDefinesList := TStringList.Create;
+ FDefinesList.Delimiter := ';';
+ FDefinesList.StrictDelimiter := true;
+ FParsedUnits := TParsedUnitsCache.Create([doOwnsValues], TIStringComparer.Ordinal);
+ FParsedUnitsInfo := TParsedUnits.Create;
+ FIncludeFiles := TIncludeFiles.Create;
+ FNotFoundUnits := TStringList.Create;
+ FNotFoundUnits.Sorted := true;
+ FNotFoundUnits.Duplicates := dupIgnore;
+ FProblems := TProblems.Create;
+end;
+
+destructor TProjectIndexer.Destroy;
+begin
+ FreeAndNil(FProblems);
+ FreeAndNil(FNotFoundUnits);
+ FreeAndNil(FIncludeFiles);
+ FreeAndNil(FParsedUnitsInfo);
+ FreeAndNil(FDefinesList);
+ FreeAndNil(FParsedUnits);
+ FreeAndNil(FSearchPaths);
+ inherited;
+end;
+
+function TProjectIndexer.FindFile(const fileName: string; relativeToFolder: string;
+ var filePath: string): boolean;
+var
+ fName : string;
+ searchPath: string;
+
+ function FilePresent(const testFile: string): boolean;
+ begin
+ Result := FileExists(testFile);
+ if Result then begin
+ filePath := ExpandFileName(testFile);
+ FUnitPaths.Add(fName, filePath);
+ end;
+ end;
+
+begin
+ Result := true;
+ fName := fileName.DeQuotedString;
+
+ if FUnitPaths.TryGetValue(fName, filePath) then
+ Exit;
+
+ if relativeToFolder <> '' then
+ if FilePresent(relativeToFolder + fName) then
+ Exit;
+
+ if FilePresent(FProjectFolder + fName) then
+ Exit;
+
+ for searchPath in FSearchPaths do
+ if FilePresent(searchPath + fName) then
+ Exit;
+
+ if SameText(ExtractFileExt(fileName), '.pas') then
+ Result := false
+ else
+ Result := FindFile(fileName + '.pas', relativeToFolder, filePath);
+
+ if (not Result) and (relativeToFolder = '') {ignore include files} then
+ FNotFoundUnits.Add(fName);
+end;
+
+function TProjectIndexer.FindType(node: TSyntaxNode; nodeType: TSyntaxNodeType):
+ TSyntaxNode;
+begin
+ if node.Typ = nodeType then
+ Exit(node)
+ else
+ Result := node.FindNode(nodeType);
+end;
+
+procedure TProjectIndexer.GetUnitSyntax(const fileName: string; var syntaxTree:
+ TSyntaxNode; var doParseUnit: boolean);
+var
+ doAbort: boolean;
+begin
+ doAbort := false;
+ doParseUnit := true;
+ syntaxTree := nil;
+ if assigned(OnGetUnitSyntax) then begin
+ OnGetUnitSyntax(Self, fileName, syntaxTree, doParseUnit, doAbort);
+ if doAbort then
+ FAborting := true;
+ end;
+end;
+
+procedure TProjectIndexer.Index(const fileName: string);
+var
+ filePath : string;
+ projectName: string;
+begin
+ FAborting := false;
+ FParsedUnits.Clear;
+ FProjectFolder := IncludeTrailingPathDelimiter(ExtractFilePath(fileName));
+ FIncludeCache := TIncludeCache.Create;
+ try
+ FUnitPaths := TUnitPathsCache.Create(TIStringComparer.Ordinal);
+ try
+ PrepareDefines;
+ PrepareSearchPath;
+ FNotFoundUnits.Clear;
+ FProblems.Clear;
+ filePath := ExpandFileName(fileName);
+ projectName := ChangeFileExt(ExtractFileName(fileName), '');
+ FUnitPaths.Add(projectName + '.dpr', fileName);
+ ParseUnit(projectName, filePath, true);
+ FParsedUnitsInfo.Initialize(FParsedUnits, FUnitPaths);
+ FIncludeFiles.Initialize(FIncludeCache);
+ finally FreeAndNil(FUnitPaths); end;
+ finally FreeAndNil(FIncludeCache); end;
+end;
+
+procedure TProjectIndexer.NotifyUnitParsed(const unitName, fileName: string; var
+ syntaxTree: TSyntaxNode; syntaxTreeFromParser: boolean);
+var
+ doAbort: boolean;
+begin
+ if assigned(OnUnitParsed) then begin
+ doAbort := false;
+ OnUnitParsed(Self, unitName, fileName, syntaxTree, syntaxTreeFromParser, doAbort);
+ if doAbort then
+ FAborting := true;
+ end;
+end;
+
+procedure TProjectIndexer.ParseUnit(const unitName: string; const fileName: string; isProject: boolean);
+var
+ doParseUnit: boolean;
+ syntaxTree : TSyntaxNode;
+begin
+ if FAborting then
+ Exit;
+
+ GetUnitSyntax(fileName, syntaxTree, doParseUnit);
+
+ if FAborting then
+ Exit;
+
+ if doParseUnit then
+ RunParserOnUnit(fileName, syntaxTree);
+
+ FParsedUnits.Add(unitName, syntaxTree);
+
+ if (not FAborting) and assigned(syntaxTree) then
+ ScanUsedUnits(unitName, fileName, isProject, syntaxTree, doParseUnit);
+end;
+
+procedure TProjectIndexer.PrepareSearchPath;
+var
+ iPath: integer;
+ sPath: string;
+begin
+ FSearchPaths.DelimitedText := SearchPath;
+ for iPath := 0 to FSearchPaths.Count - 1 do begin
+ sPath := FSearchPaths[iPath];
+ if IsRelativePath(sPath) then
+ sPath := FProjectFolder + sPath;
+ FSearchPaths[iPath] := IncludeTrailingPathDelimiter(sPath);
+ end;
+end;
+
+class function TProjectIndexer.SafeOpenFileStream(const fileName: string; var fileStream:
+ TStringStream; var errorMsg: string): boolean;
+var
+ buf : TBytes;
+ encoding : TEncoding;
+ readStream: TStream;
+begin
+ Result := true;
+ try
+ readStream := TFileStream.Create(fileName, fmOpenRead or fmShareDenyWrite);
+ except
+ on E: EFCreateError do begin
+ errorMsg := E.Message;
+ Result := false;
+ end;
+ on E: EFOpenError do begin
+ errorMsg := E.Message;
+ Result := false;
+ end;
+ end;
+
+ if Result then try
+ SetLength(buf, 4);
+ SetLength(buf, readStream.Read(buf[0], Length(buf)));
+ encoding := nil;
+ readStream.Position := TEncoding.GetBufferEncoding(buf, encoding);
+ fileStream := TStringStream.Create('', encoding);
+ fileStream.CopyFrom(readStream, readStream.Size - readStream.Position);
+ finally FreeAndNil(readStream); end;
+end;
+
+procedure TProjectIndexer.PrepareDefines;
+begin
+ FDefinesList.DelimitedText := FDefines;
+end;
+
+procedure TProjectIndexer.RunParserOnUnit(const fileName: string; var syntaxTree:
+ TSyntaxNode);
+var
+ builder : TPasSyntaxTreeBuilder;
+ define : string;
+ errorMsg : string;
+ fileStream: TStringStream;
+begin
+ if not SafeOpenFileStream(fileName, fileStream, errorMsg) then
+ FProblems.LogProblem(ptCantOpenFile, fileName, errorMsg)
+ else try
+ builder := TPasSyntaxTreeBuilder.Create;
+ try
+ builder.IncludeHandler := TIncludeHandler.Create(Self, FIncludeCache, FProblems, fileName);
+ if piUseDefinesDefinedByCompiler in Options then
+ builder.InitDefinesDefinedByCompiler;
+ for define in FDefinesList do
+ TmwSimplePasPar(builder).Lexer.AddDefine(define);
+ try
+ syntaxTree := builder.Run(fileStream);
+ except
+ on E: ESyntaxTreeException do begin
+ FProblems.LogProblem(ptCantParseFile, fileName,
+ Format('Line %d, Column %d: %s', [E.Line, E.Col, E.Message]));
+ end;
+ end;
+ finally FreeAndNil(builder); end;
+ finally FreeAndNil(fileStream); end;
+end; { TProjectIndexer.RunParserOnUnit }
+
+procedure TProjectIndexer.ScanUsedUnits(const unitName, fileName: string; isProject: boolean;
+ syntaxTree: TSyntaxNode; syntaxTreeFromParser: boolean);
+var
+ unitList: TStringList;
+ unitNode: TSyntaxNode;
+ usesName: string;
+ usesPath: string;
+begin
+ unitNode := FindType(syntaxTree, ntUnit);
+ if not assigned(unitNode) then
+ Exit;
+
+ unitList := TStringList.Create;
+ try
+ BuildUsesList(unitNode, fileName, isProject, unitList);
+
+ NotifyUnitParsed(unitName, fileName, syntaxTree, syntaxTreeFromParser);
+
+ for usesName in unitList do begin
+ if FAborting then
+ Exit;
+ if not FParsedUnits.ContainsKey(usesName) then begin
+ if FindFile(usesName + '.pas', '', usesPath) then
+ ParseUnit(usesName, usesPath, false)
+ else
+ FParsedUnits.Add(usesName, nil);
+ end;
+ end;
+ finally FreeAndNil(unitList); end;
+end;
+
+{ TProjectIndexer.TIncludeHandler }
+
+constructor TProjectIndexer.TIncludeHandler.Create(indexer: TProjectIndexer;
+ includeCache: TIncludeCache; problemList: TProblems; const currentFile: string);
+begin
+ inherited Create;
+ FIndexer := indexer;
+ FIncludeCache := includeCache;
+ FProblems := problemList;
+ FUnitFileFolder := IncludeTrailingPathDelimiter(ExtractFilePath(currentFile));
+ FUnitFile := ChangeFileExt(ExtractFileName(currentFile), '');
+end;
+
+function TProjectIndexer.TIncludeHandler.GetIncludeFileContent(
+ const ParentFileName, fileName: string; out Content: string; out filePath: string): Boolean;
+var
+ errorMsg : string;
+ fileStream : TStringStream;
+ fName : string;
+ includeInfo: TIncludeInfo;
+ key : string;
+begin
+ if fileName.StartsWith('*.') then
+ fName := FUnitFile + fileName.Remove(0 {0-based}, 1)
+ else if fileName.Contains('*') then
+ fName := fileName.Replace('*', '', [rfReplaceAll])
+ else
+ fName := fileName;
+
+ key := fName + #13 + FUnitFileFolder;
+ if FIncludeCache.TryGetValue(key, includeInfo) then
+ begin
+ Content := includeInfo.Content;
+ filePath := includeInfo.FileName;
+ Exit(True);
+ end;
+
+ if not FIndexer.FindFile(fName, FUnitFileFolder, filePath) then begin
+ FProblems.LogProblem(ptCantFindFile, fName, 'Source folder: ' + FUnitFileFolder);
+ includeInfo.FileName := '';
+ includeInfo.Content := '';
+ FIncludeCache.Add(key, includeInfo);
+ Exit(False);
+ end;
+
+ if FIncludeCache.TryGetValue(filePath, includeInfo) then
+ begin
+ Content := includeInfo.Content;
+ Exit(True);
+ end;
+
+ if not TProjectIndexer.SafeOpenFileStream(filePath, fileStream, errorMsg) then begin
+ FProblems.LogProblem(ptCantOpenFile, filePath, errorMsg);
+ Result := False;
+ end
+ else try
+ Content := fileStream.DataString;
+ Result := True;
+ finally FreeAndNil(fileStream); end;
+
+ includeInfo.FileName := filePath;
+ includeInfo.Content := Content;
+ FIncludeCache.Add(fName + #13 + FUnitFileFolder, includeInfo);
+ includeInfo.FileName := '';
+ FIncludeCache.Add(filePath, includeInfo);
+end;
+
+end.
diff --git a/References/DelphiAST/Source/DelphiAST.Serialize.Binary.pas b/References/DelphiAST/Source/DelphiAST.Serialize.Binary.pas
new file mode 100644
index 000000000..04ac28342
--- /dev/null
+++ b/References/DelphiAST/Source/DelphiAST.Serialize.Binary.pas
@@ -0,0 +1,335 @@
+ unit DelphiAST.Serialize.Binary;
+
+ {$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
+
+interface
+
+uses
+ Classes,
+ Generics.Collections,
+ DelphiAST.Consts,
+ DelphiAST.Classes;
+
+type
+ TNodeClass = (ntSyntax, ntCompound, ntValued, ntComment);
+
+ TBinarySerializer = class
+ strict private
+ FStream : TStream;
+ FStringList : TStringList;
+ FStringTable: TDictionary;
+ strict protected
+ function CheckSignature: boolean;
+ function CheckVersion: boolean;
+ function CreateNode(nodeClass: TNodeClass; nodeType: TSyntaxNodeType): TSyntaxNode;
+ function ReadNode(var node: TSyntaxNode): boolean;
+ function ReadNumber(var num: cardinal): Boolean;
+ function ReadString(var str: string): boolean;
+ function WriteNode(Node: TSyntaxNode): Boolean;
+ function WriteNumber(Num: cardinal): Boolean;
+ function WriteString(const S: string): Boolean;
+ public
+ function Read(Stream: TStream; var Root: TSyntaxNode): boolean;
+ function Write(Stream: TStream; Root: TSyntaxNode): boolean;
+ end;
+
+implementation
+
+uses
+ SysUtils;
+
+var
+ CSignature: AnsiString = 'DAST binary file'#26;
+
+function TBinarySerializer.CheckSignature: boolean;
+var
+ sig: AnsiString;
+begin
+ SetLength(sig, Length(CSignature));
+ Result := (FStream.Read(sig[1], Length(CSignature)) = Length(CSignature))
+ and (sig = CSignature);
+end;
+
+function TBinarySerializer.CheckVersion: boolean;
+var
+ version: Integer;
+begin
+ Result := (FStream.Read(version, 4) = 4)
+ and ((version AND $FFFF0000) = $01000000);
+end;
+
+function TBinarySerializer.CreateNode(nodeClass: TNodeClass; nodeType: TSyntaxNodeType):
+ TSyntaxNode;
+begin
+ case nodeClass of
+ ntSyntax: Result := TSyntaxNode.Create(nodeType);
+ ntCompound: Result := TCompoundSyntaxNode.Create(nodeType);
+ ntValued: Result := TValuedSyntaxNode.Create(nodeType);
+ ntComment: Result := TCommentNode.Create(nodeType);
+ else raise Exception.Create('TBinarySerializer.CreateNode: Unexpected node class');
+ end;
+end;
+
+function TBinarySerializer.Read(Stream: TStream; var Root: TSyntaxNode): boolean;
+var
+ node: TSyntaxNode;
+begin
+ Result := false;
+
+ FStringList := TStringList.Create;
+ try
+ FStream := Stream;
+ if not CheckSignature then
+ Exit;
+ if not CheckVersion then
+ Exit;
+ if not ReadNode(node) then
+ Exit;
+ Root := node;
+ finally FStringList.Free; end;
+
+ Result := true;
+end;
+
+function TBinarySerializer.ReadNode(var node: TSyntaxNode): boolean;
+var
+ childNode: TSyntaxNode;
+ i : Integer;
+ nodeClass: TNodeClass;
+ num : cardinal;
+ numSub: cardinal;
+ str : string;
+begin
+ Result := false;
+ node := nil;
+ if (not ReadNumber(num)) or (num > cardinal(Ord(High(TNodeClass)))) then
+ Exit;
+ nodeClass := TNodeClass(num);
+ if (not ReadNumber(num)) or (num > Ord(High(TSyntaxNodeType))) then
+ Exit;
+ node := CreateNode(nodeClass, TSyntaxNodeType(num));
+ try
+
+ if (not ReadNumber(num)) or (num > cardinal(High(integer))) then
+ Exit;
+ Node.Col := num;
+ if (not ReadNumber(num)) or (num > cardinal(High(integer))) then
+ Exit;
+ Node.Line := num;
+
+ case nodeClass of
+ ntCompound:
+ begin
+ if (not ReadNumber(num)) or (num > cardinal(High(integer))) then
+ Exit;
+ TCompoundSyntaxNode(Node).EndCol := num;
+ if (not ReadNumber(num)) or (num > cardinal(High(integer))) then
+ Exit;
+ TCompoundSyntaxNode(Node).EndLine := num;
+ end;
+ ntValued:
+ begin
+ if not ReadString(str) then
+ Exit;
+ TValuedSyntaxNode(Node).Value := str;
+ end;
+ ntComment:
+ begin
+ if not ReadString(str) then
+ Exit;
+ TCommentNode(Node).Text := str;
+ end;
+ end;
+
+ if not ReadNumber(numSub) then
+ Exit;
+ for i := 1 to numSub do begin
+ if (not ReadNumber(num)) or (num > cardinal(Ord(High(TAttributeName)))) then
+ Exit;
+ if not ReadString(str) then
+ Exit;
+ Node.SetAttribute(TAttributeName(num), str);
+ end;
+
+ if not ReadNumber(numSub) then
+ Exit;
+ for i := 1 to numSub do begin
+ if not ReadNode(childNode) then
+ Exit;
+ Node.AddChild(childNode);
+ end;
+
+ Result := true;
+ finally
+ if not Result then begin
+ node.Free;
+ node := nil;
+ end;
+ end;
+end;
+
+function TBinarySerializer.ReadNumber(var num: cardinal): Boolean;
+var
+ lowPart: byte;
+ shift : Integer;
+begin
+ Result := false;
+
+ shift := 0;
+ num := 0;
+ repeat
+ if FStream.Read(lowPart, 1) <> 1 then
+ Exit;
+ num := num OR ((lowPart AND $7F) SHL shift);
+ Inc(shift, 7);
+ until (lowPart AND $80) = 0;
+
+ Result := true;
+end;
+
+function TBinarySerializer.ReadString(var str: string): boolean;
+var
+ id: integer;
+ len: cardinal;
+ u8: UTF8String;
+begin
+ Result := false;
+
+ if not ReadNumber(len) then
+ Exit;
+ if (len SHR 24) = $FF then begin
+ id := len AND $00FFFFFF;
+ if id >= FStringList.Count then
+ Exit;
+ str := FStringList[id];
+ end
+ else begin
+ SetLength(u8, len);
+ if len > 0 then
+ if cardinal(FStream.Read(u8[1], len)) <> len then
+ Exit;
+ str := UTF8ToUnicodeString(u8);
+ if Length(Str) > 4 then
+ FStringList.Add(str);
+ end;
+
+ Result := true;
+end;
+
+function TBinarySerializer.Write(Stream: TStream; Root: TSyntaxNode): boolean;
+var
+ version: Integer;
+begin
+ Result := false;
+
+ FStringTable := TDictionary.Create;
+ try
+ FStream := Stream;
+ if FStream.Write(CSignature[1], Length(CSignature)) <> Length(CSignature) then
+ Exit;
+ version := $01000000;
+ if FStream.Write(version, 4) <> 4 then
+ Exit;
+ if not WriteNode(Root) then
+ Exit;
+ finally FStringTable.Free; end;
+
+ Result := true;
+end;
+
+function TBinarySerializer.WriteNode(Node: TSyntaxNode): Boolean;
+var
+ attr : TAttributeEntry;
+ childNode: TSyntaxNode;
+ nodeClass: TNodeClass;
+begin
+ Result := false;
+
+ if Node is TCompoundSyntaxNode then
+ nodeClass := ntCompound
+ else if Node is TValuedSyntaxNode then
+ nodeClass := ntValued
+ else if Node is TCommentNode then
+ nodeClass := ntComment
+ else
+ nodeClass := ntSyntax;
+
+ if not WriteNumber(Ord(nodeClass)) then Exit;
+ if not WriteNumber(Ord(Node.Typ)) then Exit;
+ if not WriteNumber(Node.Col) then Exit;
+ if not WriteNumber(Node.Line) then Exit;
+
+ case nodeClass of
+ ntCompound:
+ begin
+ if not WriteNumber(TCompoundSyntaxNode(Node).EndCol) then Exit;
+ if not WriteNumber(TCompoundSyntaxNode(Node).EndLine) then Exit;
+ end;
+ ntValued:
+ if not WriteString(TValuedSyntaxNode(Node).Value) then Exit;
+ ntComment:
+ if not WriteString(TCommentNode(Node).Text) then Exit;
+ end;
+
+ if not WriteNumber(Length(Node.Attributes)) then Exit;
+ for attr in Node.Attributes do begin // causes dynamic array assignment, yuck
+ if not WriteNumber(Ord(attr.Key)) then Exit;
+ if not WriteString(attr.Value) then Exit;
+ end;
+
+ if not WriteNumber(Length(Node.ChildNodes)) then Exit;
+ for childNode in Node.ChildNodes do // causes dynamic array assignment, yuck
+ if not WriteNode(childNode) then Exit;
+
+ Result := true;
+end;
+
+function TBinarySerializer.WriteNumber(Num: cardinal): Boolean;
+var
+ lowPart: byte;
+begin
+ Result := false;
+
+ repeat
+ lowPart := Num AND $7F;
+ Num := Num SHR 7;
+ if Num <> 0 then
+ lowPart := lowPart OR $80;
+ if FStream.Write(lowPart, 1) <> 1 then
+ Exit;
+ until Num = 0;
+
+ Result := true;
+end;
+
+function TBinarySerializer.WriteString(const S: string): Boolean;
+var
+ i: Integer;
+ id: integer;
+ u8: UTF8String;
+begin
+ Result := false;
+
+ if (Length(S) > 4) and FStringTable.TryGetValue(S, id) then begin
+ if not WriteNumber(cardinal(id) OR $FF000000) then
+ Exit;
+ end
+ else begin
+ if Length(S) > 4 then begin
+ FStringTable.Add(S, FStringTable.Count);
+ if FStringTable.Count > $FFFFFF then
+ raise Exception.Create('TBinarySerializer.WriteString: Too many strings!');
+ end;
+ u8 := UTF8Encode(s);
+ i := Length(u8);
+ if not WriteNumber(i) then
+ Exit;
+ if i > 0 then
+ if FStream.Write(u8[1], i) <> i then
+ Exit;
+ end;
+
+ Result := true;
+end;
+
+end.
diff --git a/References/DelphiAST/Source/DelphiAST.SimpleParserEx.pas b/References/DelphiAST/Source/DelphiAST.SimpleParserEx.pas
new file mode 100644
index 000000000..6afd71050
--- /dev/null
+++ b/References/DelphiAST/Source/DelphiAST.SimpleParserEx.pas
@@ -0,0 +1,422 @@
+unit DelphiAST.SimpleParserEx;
+
+interface
+
+uses
+ SysUtils, Generics.Collections, SimpleParser, SimpleParser.Lexer.Types,
+ SimpleParser.Lexer, Classes;
+
+type
+ TStringEvent = procedure(var s: string) of object;
+
+ TPasLexer = class
+ private
+ FLexer: TmwPasLex;
+ FOnHandleString: TStringEvent;
+ function GetToken: string; inline;
+ function GetPosXY: TTokenPoint; inline;
+ function GetFileName: string;
+ public
+ constructor Create(const ALexer: TmwPasLex; AOnHandleString: TStringEvent);
+ property FileName: string read GetFileName;
+ property PosXY: TTokenPoint read GetPosXY;
+ property Token: string read GetToken;
+ property Lexer: TmwPasLex read FLexer;
+ end;
+
+ TmwSimplePasParEx = class(TmwSimplePasPar)
+ public type
+ TNameListStack = class;
+ TNameList = class
+ public type
+ TNameItem = class
+ public type
+ TNameItemToken = class
+ strict private
+ FTokenFileName: string;
+ FTokenPoint: TTokenPoint;
+ FTokenPos: Integer;
+ FTokenLen: Integer;
+ public
+ constructor Create(const ATokenFileName: string;
+ const ATokenPoint: TTokenPoint; const ATokenPos, ATokenLen: Integer);
+ property TokenFileName: string read FTokenFileName;
+ property TokenPoint: TTokenPoint read FTokenPoint;
+ property TokenPos: Integer read FTokenPos;
+ property TokenLen: Integer read FTokenLen;
+ end;
+ strict private
+ FTokenList: TObjectList;
+ FEndNameCalled: Boolean;
+ function GetLastNameItemToken: TNameItemToken;
+ public
+ constructor Create(const ATokenFileName: string;
+ const ATokenPoint: TTokenPoint; const ATokenID: TptTokenKind;
+ const ATokenPos, ATokenLen: Integer);
+ destructor Destroy; override;
+ procedure AddToken(const ATokenFileName: string;
+ const ATokenPoint: TTokenPoint; const ATokenID: TptTokenKind;
+ const ATokenPos, ATokenLen: Integer);
+ property TokenList: TObjectList read FTokenList;
+ property LastNameItemToken: TNameItemToken read GetLastNameItemToken;
+ property EndNameCalled: Boolean read FEndNameCalled write FEndNameCalled;
+ end;
+ strict private
+ FParser: TmwSimplePasParEx;
+ FNameItems: TObjectList;
+ FAutoCreated: Boolean;
+ function GetItems(const Index: Integer): TNameItem; inline;
+ function GetLastItem: TNameItem; inline;
+ function GetOriginalNames(const Index: Integer): string;
+ function GetNames(const Index: Integer): string;
+ function GetLastOriginalName: string;
+ function GetLastName: string;
+ function GetCount: Integer; inline;
+ function GetLexer: TmwPasLex; inline;
+ property Lexer: TmwPasLex read GetLexer;
+ public
+ constructor Create(const AParser: TmwSimplePasParEx;
+ const AAutoCreated: Boolean);
+ destructor Destroy; override;
+ procedure BeginName;
+ procedure EndName;
+ procedure AddToken;
+ property AutoCreated: Boolean read FAutoCreated;
+ property Items[const Index: Integer]: TNameItem read GetItems;
+ property LastItem: TNameItem read GetLastItem;
+ property OriginalNames[const Index: Integer]: string read GetOriginalNames;
+ property Names[const Index: Integer]: string read GetNames; default;
+ property LastOriginalName: string read GetLastOriginalName;
+ property LastName: string read GetLastName;
+ property Count: Integer read GetCount;
+ end;
+ TNameListStack = class
+ strict private
+ FParser: TmwSimplePasParEx;
+ FNameListStack: TObjectStack;
+ public
+ constructor Create(const AParser: TmwSimplePasParEx);
+ destructor Destroy; override;
+ procedure PushNames(const AAutoCreated: Boolean); inline;
+ procedure PopNames; inline;
+ function ExtractNames: TNameList; inline;
+ function PeekNames: TNameList; inline;
+ function ToArray: TArray; inline;
+ function Count: Integer; inline;
+ end;
+ strict private
+ FNameListStack: TNameListStack;
+ FPreviousNames: TNameList;
+ FLexer: TPasLexer;
+ FLowerCaseNames: Boolean;
+ FOnHandleString: TStringEvent;
+ function GetCurrentNames: TNameList; inline;
+ strict protected
+ procedure DoHandleString(var AString: string); inline;
+ procedure PushNames; inline;
+ procedure PopNames; inline;
+ function PeekNames: TNameList; inline;
+ procedure BeginName;
+ procedure EndName;
+ property CurrentNames: TNameList read GetCurrentNames;
+ property PreviousNames: TNameList read FPreviousNames;
+ protected
+ procedure NextToken; override;
+ public
+ constructor Create; override;
+ destructor Destroy; override;
+ property Lexer: TPasLexer read FLexer;
+ property LowerCaseNames: Boolean read FLowerCaseNames write FLowerCaseNames;
+ property OnHandleString: TStringEvent read FOnHandleString write FOnHandleString;
+ end;
+
+implementation
+
+{ TPasLexer }
+
+constructor TPasLexer.Create(const ALexer: TmwPasLex; AOnHandleString: TStringEvent);
+begin
+ inherited Create;
+ FLexer := ALexer;
+ FOnHandleString := AOnHandleString;
+end;
+
+function TPasLexer.GetFileName: string;
+begin
+ Result := FLexer.Buffer.FileName;
+end;
+
+function TPasLexer.GetPosXY: TTokenPoint;
+begin
+ Result := FLexer.PosXY;
+end;
+
+function TPasLexer.GetToken: string;
+begin
+ Result := FLexer.Token;
+ FOnHandleString(Result);
+end;
+
+{ TmwSimplePasParEx.TNameList.TNameItem.TNameItemToken }
+
+constructor TmwSimplePasParEx.TNameList.TNameItem.TNameItemToken.Create(
+ const ATokenFileName: string; const ATokenPoint: TTokenPoint;
+ const ATokenPos, ATokenLen: Integer);
+begin
+ FTokenFileName := ATokenFileName;
+ FTokenPoint := ATokenPoint;
+ FTokenPos := ATokenPos;
+ FTokenLen := ATokenLen;
+end;
+
+{ TPasNamesBuilder.TNamesList.TNameItem }
+
+constructor TmwSimplePasParEx.TNameList.TNameItem.Create(
+ const ATokenFileName: string; const ATokenPoint: TTokenPoint;
+ const ATokenID: TptTokenKind; const ATokenPos, ATokenLen: Integer);
+begin
+ FTokenList := TObjectList.Create(True);
+ AddToken(ATokenFileName, ATokenPoint, ATokenID, ATokenPos, ATokenLen);
+end;
+
+destructor TmwSimplePasParEx.TNameList.TNameItem.Destroy;
+begin
+ FTokenList.Free;
+ inherited;
+end;
+
+procedure TmwSimplePasParEx.TNameList.TNameItem.AddToken(
+ const ATokenFileName: string; const ATokenPoint: TTokenPoint;
+ const ATokenID: TptTokenKind; const ATokenPos, ATokenLen: Integer);
+begin
+ if not IsTokenIDJunk(ATokenID) and
+ ((FTokenList.Count = 0) or (FTokenList.Last.TokenPos < ATokenPos)) then
+ FTokenList.Add(TNameItemToken.Create(
+ ATokenFileName, ATokenPoint, ATokenPos, ATokenLen));
+end;
+
+function TmwSimplePasParEx.TNameList.TNameItem.GetLastNameItemToken: TNameItemToken;
+begin
+ Result := TokenList.Last;
+end;
+
+{ TPasNamesBuilder.TNamesList }
+
+constructor TmwSimplePasParEx.TNameList.Create(const AParser: TmwSimplePasParEx;
+ const AAutoCreated: Boolean);
+begin
+ FParser := AParser;
+ FNameItems := TObjectList.Create(True);
+end;
+
+destructor TmwSimplePasParEx.TNameList.Destroy;
+begin
+ FNameItems.Free;
+ inherited;
+end;
+
+function TmwSimplePasParEx.TNameList.GetLexer: TmwPasLex;
+begin
+ Result := FParser.Lexer.Lexer;
+end;
+
+procedure TmwSimplePasParEx.TNameList.BeginName;
+begin
+ FNameItems.Add(TNameItem.Create(Lexer.FileName, Lexer.PosXY, Lexer.TokenID,
+ Lexer.TokenPos, Lexer.TokenLen));
+end;
+
+procedure TmwSimplePasParEx.TNameList.EndName;
+begin
+ FNameItems.Last.EndNameCalled := True;
+end;
+
+procedure TmwSimplePasParEx.TNameList.AddToken;
+begin
+ FNameItems.Last.AddToken(Lexer.FileName, Lexer.PosXY, Lexer.TokenID,
+ Lexer.TokenPos, Lexer.TokenLen);
+end;
+
+function TmwSimplePasParEx.TNameList.GetItems(const Index: Integer): TNameItem;
+begin
+ Result := FNameItems[Index];
+end;
+
+function TmwSimplePasParEx.TNameList.GetLastItem: TNameItem;
+begin
+ Result := FNameItems.Last;
+end;
+
+function TmwSimplePasParEx.TNameList.GetOriginalNames(const Index: Integer): string;
+var
+ I: Integer;
+ NameItem: TNameItem;
+ Token: string;
+begin
+ Result := '';
+ NameItem := Items[Index];
+ for I := 0 to NameItem.TokenList.Count - 1 do
+ begin
+ SetString(Token, Lexer.Buffer.Buf + NameItem.TokenList[I].TokenPos,
+ NameItem.TokenList[I].TokenLen);
+ Result := Result + Token;
+ end;
+ FParser.DoHandleString(Result);
+end;
+
+function TmwSimplePasParEx.TNameList.GetNames(const Index: Integer): string;
+begin
+ Result := OriginalNames[Index];
+ if FParser.LowerCaseNames then
+ begin
+ Result := AnsiLowerCase(Result);
+ FParser.DoHandleString(Result);
+ end;
+end;
+
+function TmwSimplePasParEx.TNameList.GetLastOriginalName: string;
+begin
+ Result := OriginalNames[Count - 1];
+end;
+
+function TmwSimplePasParEx.TNameList.GetLastName: string;
+begin
+ Result := Names[Count - 1];
+end;
+
+function TmwSimplePasParEx.TNameList.GetCount: Integer;
+begin
+ Result := FNameItems.Count;
+end;
+
+{ TPasNamesBuilder.TNameListStack }
+
+function TmwSimplePasParEx.TNameListStack.Count: Integer;
+begin
+ Result := FNameListStack.Count;
+end;
+
+constructor TmwSimplePasParEx.TNameListStack.Create(
+ const AParser: TmwSimplePasParEx);
+begin
+ FParser := AParser;
+ FNameListStack := TObjectStack.Create(True);
+end;
+
+destructor TmwSimplePasParEx.TNameListStack.Destroy;
+begin
+ FNameListStack.Free;
+ inherited;
+end;
+
+procedure TmwSimplePasParEx.TNameListStack.PushNames(const AAutoCreated: Boolean);
+begin
+ FNameListStack.Push(TNameList.Create(FParser, AAutoCreated));
+end;
+
+procedure TmwSimplePasParEx.TNameListStack.PopNames;
+begin
+ FNameListStack.Pop;
+end;
+
+function TmwSimplePasParEx.TNameListStack.ExtractNames: TNameList;
+begin
+ Result := FNameListStack.Extract;
+end;
+
+function TmwSimplePasParEx.TNameListStack.PeekNames: TNameList;
+begin
+ Result := FNameListStack.Peek;
+end;
+
+function TmwSimplePasParEx.TNameListStack.ToArray: TArray;
+begin
+ Result := FNameListStack.ToArray;
+end;
+
+{ TmwSimplePasParEx }
+
+constructor TmwSimplePasParEx.Create;
+begin
+ inherited;
+ FNameListStack := TNameListStack.Create(Self);
+ FNameListStack.PushNames(True);
+ FPreviousNames := TNameList.Create(Self, True);
+ FLexer := TPasLexer.Create(inherited Lexer, DoHandleString);
+ FLowerCaseNames := True;
+end;
+
+destructor TmwSimplePasParEx.Destroy;
+begin
+ FLexer.Free;
+ FPreviousNames.Free;
+ FNameListStack.PopNames;
+ FNameListStack.Free;
+ inherited;
+end;
+
+procedure TmwSimplePasParEx.NextToken;
+var
+ NameList: TNameList;
+begin
+ if FNameListStack.Count > 0 then
+ for NameList in FNameListStack.ToArray do
+ if (NameList.Count > 0) and not NameList.LastItem.EndNameCalled then
+ NameList.AddToken;
+ inherited;
+end;
+
+procedure TmwSimplePasParEx.PushNames;
+begin
+ FNameListStack.PushNames(False);
+end;
+
+procedure TmwSimplePasParEx.PopNames;
+begin
+ FPreviousNames.Free;
+ FPreviousNames := FNameListStack.ExtractNames;
+end;
+
+function TmwSimplePasParEx.PeekNames: TNameList;
+begin
+ Result := FNameListStack.PeekNames;
+end;
+
+procedure TmwSimplePasParEx.BeginName;
+var
+ NameList: TNameList;
+begin
+ NameList := FNameListStack.PeekNames;
+ if (NameList.Count > 0) and not NameList.LastItem.EndNameCalled then
+ begin
+ FNameListStack.PushNames(True);
+ NameList := FNameListStack.PeekNames;
+ end;
+ NameList.BeginName;
+end;
+
+procedure TmwSimplePasParEx.EndName;
+var
+ NameList: TNameList;
+begin
+ NameList := FNameListStack.PeekNames;
+ if NameList.LastItem.EndNameCalled then
+ begin
+ FNameListStack.PopNames;
+ NameList := FNameListStack.PeekNames;
+ end;
+ NameList.EndName;
+end;
+
+procedure TmwSimplePasParEx.DoHandleString(var AString: string);
+begin
+ if Assigned(FOnHandleString) then
+ FOnHandleString(AString);
+end;
+
+function TmwSimplePasParEx.GetCurrentNames: TNameList;
+begin
+ Result := PeekNames;
+end;
+
+end.
diff --git a/References/DelphiAST/Source/DelphiAST.Writer.pas b/References/DelphiAST/Source/DelphiAST.Writer.pas
new file mode 100644
index 000000000..7e9f05ca0
--- /dev/null
+++ b/References/DelphiAST/Source/DelphiAST.Writer.pas
@@ -0,0 +1,158 @@
+unit DelphiAST.Writer;
+
+interface
+
+uses
+ {$IFDEF FPC}
+ StringBuilderUnit,
+ {$ENDIF}
+ Classes,
+ DelphiAST.Classes, SysUtils;
+
+type
+ TSyntaxTreeWriter = class
+ private
+ class procedure NodeToXML(const Builder: TStringBuilder;
+ const Node: TSyntaxNode; Formatted: Boolean); static;
+ public
+ class function ToXML(const Root: TSyntaxNode;
+ Formatted: Boolean = False): string; static;
+
+ {$IFNDEF FPC}
+ class function ToBinary(const Root: TSyntaxNode; Stream: TStream): Boolean; static;
+ {$ENDIF}
+ end;
+
+implementation
+
+uses
+ Generics.Collections,
+ {$IFNDEF FPC}
+ DelphiAST.Serialize.Binary,
+ {$ENDIF}
+ DelphiAST.Consts;
+
+{$I SimpleParser.inc}
+{$IFDEF D18_NEWER}
+ {$ZEROBASEDSTRINGS OFF}
+{$ENDIF}
+
+{ TSyntaxTreeWriter }
+
+class procedure TSyntaxTreeWriter.NodeToXML(const Builder: TStringBuilder;
+ const Node: TSyntaxNode; Formatted: Boolean);
+
+ function XMLEncode(const Data: string): string;
+ var
+ i, n: Integer;
+
+ procedure Encode(const s: string);
+ begin
+ Move(s[1], Result[n], Length(s) * SizeOf(Char));
+ Inc(n, Length(s));
+ end;
+
+ begin
+ SetLength(Result, Length(Data) * 6);
+ n := 1;
+ for i := 1 to Length(Data) do
+ case Data[i] of
+ '<': Encode('<');
+ '>': Encode('>');
+ '&': Encode('&');
+ '"': Encode('"');
+ '''': Encode(''');
+ else
+ Result[n] := Data[i];
+ Inc(n);
+ end;
+ SetLength(Result, n - 1);
+ end;
+
+ procedure NodeToXMLInternal(const Node: TSyntaxNode; const Indent: string);
+ var
+ HasChildren: Boolean;
+ NewIndent: string;
+ Attr: TPair;
+ ChildNode: TSyntaxNode;
+ begin
+ HasChildren := Node.HasChildren;
+ if Formatted then
+ begin
+ NewIndent := Indent + ' ';
+ Builder.Append(Indent);
+ end;
+ Builder.Append('<' + UpperCase(SyntaxNodeNames[Node.Typ]));
+
+ Builder.Append(' line_seq="' + IntToStr(Node.LineSeq) + '"');
+
+ if Node is TCompoundSyntaxNode then
+ begin
+ Builder.Append(' begin_line="' + IntToStr(TCompoundSyntaxNode(Node).Line) + '"');
+ Builder.Append(' begin_col="' + IntToStr(TCompoundSyntaxNode(Node).Col) + '"');
+ Builder.Append(' end_line="' + IntToStr(TCompoundSyntaxNode(Node).EndLine) + '"');
+ Builder.Append(' end_col="' + IntToStr(TCompoundSyntaxNode(Node).EndCol) + '"');
+ end else
+ begin
+ Builder.Append(' line="' + IntToStr(Node.Line) + '"');
+ Builder.Append(' col="' + IntToStr(Node.Col) + '"');
+ end;
+
+ if Node.FileName <> '' then
+ Builder.Append(' file="' + XMLEncode(Node.FileName) + '"');
+
+ if Node is TValuedSyntaxNode then
+ Builder.Append(' value="' + XMLEncode(TValuedSyntaxNode(Node).Value) + '"');
+
+ for Attr in Node.Attributes do
+ Builder.Append(' ' + AttributeNameStrings[Attr.Key] + '="' + XMLEncode(Attr.Value) + '"');
+ if HasChildren then
+ Builder.Append('>')
+ else
+ Builder.Append('/>');
+ if Formatted then
+ Builder.AppendLine;
+ for ChildNode in Node.ChildNodes do
+ NodeToXMLInternal(ChildNode, NewIndent);
+ if HasChildren then
+ begin
+ if Formatted then
+ Builder.Append(Indent);
+ Builder.Append('');
+ if Formatted then
+ Builder.AppendLine;
+ end;
+ end;
+
+begin
+ NodeToXMLInternal(Node, '');
+end;
+
+{$IFNDEF FPC}
+class function TSyntaxTreeWriter.ToBinary(const Root: TSyntaxNode; Stream: TStream):
+ Boolean;
+var
+ Writer: TBinarySerializer;
+begin
+ Writer := TBinarySerializer.Create;
+ try
+ Result := Writer.Write(Stream, Root);
+ finally FreeAndNil(Writer); end;
+end;
+{$ENDIF}
+
+class function TSyntaxTreeWriter.ToXML(const Root: TSyntaxNode;
+ Formatted: Boolean): string;
+var
+ Builder: TStringBuilder;
+begin
+ Builder := TStringBuilder.Create;
+ try
+ NodeToXml(Builder, Root, Formatted);
+ Result := '' + sLineBreak + Builder.ToString;
+ finally
+ Builder.Free;
+ end;
+end;
+
+end.
diff --git a/References/DelphiAST/Source/DelphiAST.pas b/References/DelphiAST/Source/DelphiAST.pas
new file mode 100644
index 000000000..c908cc5ce
--- /dev/null
+++ b/References/DelphiAST/Source/DelphiAST.pas
@@ -0,0 +1,2828 @@
+unit DelphiAST;
+
+{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
+
+interface
+
+uses
+ SysUtils, Classes, Generics.Collections, SimpleParser, SimpleParser.Lexer,
+ SimpleParser.Lexer.Types, DelphiAST.Classes, DelphiAST.Consts, DelphiAST.SimpleParserEx;
+
+type
+ ESyntaxTreeException = class(EParserException)
+ strict private
+ FSyntaxTree: TSyntaxNode;
+ public
+ constructor Create(Line, Col: Integer; const FileName, Msg: string; SyntaxTree: TSyntaxNode); reintroduce;
+ destructor Destroy; override;
+
+ property SyntaxTree: TSyntaxNode read FSyntaxTree write FSyntaxTree;
+ end;
+
+ TNodeStack = class
+ strict private
+ FLexer: TPasLexer;
+ FStack: TStack;
+
+ function GetCount: Integer;
+ public
+ constructor Create(Lexer: TPasLexer);
+ destructor Destroy; override;
+
+ function AddChild(Typ: TSyntaxNodeType): TSyntaxNode; overload;
+ function AddChild(Node: TSyntaxNode): TSyntaxNode; overload;
+ function AddValuedChild(Typ: TSyntaxNodeType; const Value: string): TSyntaxNode;
+
+ procedure Clear;
+ function Peek: TSyntaxNode;
+ function Pop: TSyntaxNode;
+
+ function Push(Typ: TSyntaxNodeType): TSyntaxNode; overload;
+ function Push(Node: TSyntaxNode): TSyntaxNode; overload;
+ function PushCompoundSyntaxNode(Typ: TSyntaxNodeType): TSyntaxNode;
+ function PushValuedNode(Typ: TSyntaxNodeType; const Value: string): TSyntaxNode;
+
+ property Count: Integer read GetCount;
+ end;
+
+ TPasSyntaxTreeBuilder = class(TmwSimplePasParEx)
+ private type
+ TTreeBuilderMethod = procedure of object;
+ private
+ procedure BuildExpressionTree(ExpressionMethod: TTreeBuilderMethod);
+ procedure BuildParametersList(ParametersListMethod: TTreeBuilderMethod);
+ procedure RearrangeVarSection(const VarSect: TSyntaxNode);
+ procedure ParserMessage(Sender: TObject; const Typ: TMessageEventType; const Msg: string; X, Y: Integer);
+ function NodeListToString(NamesNode: TSyntaxNode): string;
+ procedure MoveMembersToVisibilityNodes(TypeNode: TSyntaxNode);
+ procedure CallInheritedConstantExpression;
+ procedure CallInheritedExpression;
+ procedure CallInheritedFormalParameterList;
+ procedure CallInheritedPropertyParameterList;
+ procedure SetCurrentCompoundNodesEndPosition;
+ procedure DoOnComment(Sender: TObject; const Text: string);
+ function DequoteString(const S: string): string;
+ protected
+ FStack: TNodeStack;
+ FComments: TObjectList;
+ procedure AccessSpecifier; override;
+ procedure AdditiveOperator; override;
+ procedure AddressOp; override;
+ procedure AlignmentParameter; override;
+ procedure AnonymousMethod; override;
+ procedure ArrayBounds; override;
+ procedure ArrayConstant; override;
+ procedure ArrayDimension; override;
+ procedure AsmStatement; override;
+ procedure AsOp; override;
+ procedure AssignOp; override;
+ procedure AtExpression; override;
+ procedure CaseElseStatement; override;
+ procedure CaseLabel; override;
+ procedure CaseLabelList; override;
+ procedure CaseSelector; override;
+ procedure CaseStatement; override;
+ procedure ClassClass; override;
+ procedure ClassConstraint; override;
+ procedure ClassField; override;
+ procedure ClassForward; override;
+ procedure ClassFunctionHeading; override;
+ procedure ClassHelper; override;
+ procedure ClassMethod; override;
+ procedure ClassMethodResolution; override;
+ procedure ClassMethodHeading; override;
+ procedure ClassProcedureHeading; override;
+ procedure ClassProperty; override;
+ procedure ClassReferenceType; override;
+ procedure ClassType; override;
+ procedure CompoundStatement; override;
+ procedure ConstParameter; override;
+ procedure ConstantDeclaration; override;
+ procedure ConstantExpression; override;
+ procedure ConstantName; override;
+ procedure ConstraintList; override;
+ procedure ConstSection; override;
+ procedure ConstantValue; override;
+ procedure ConstantValueTyped; override;
+ procedure ConstructorConstraint; override;
+ procedure ConstructorName; override;
+ procedure ContainsClause; override;
+ procedure DestructorName; override;
+ procedure DirectiveBinding; override;
+ procedure DirectiveBindingMessage; override;
+ procedure DirectiveCalling; override;
+ procedure DirectiveInline; override;
+ procedure DispInterfaceForward; override;
+ procedure DotOp; override;
+ procedure ElseExpression; override;
+ procedure ElseStatement; override;
+ procedure EmptyStatement; override;
+ procedure EnumeratedType; override;
+ procedure ExceptBlock; override;
+ procedure ExceptionBlockElseBranch; override;
+ procedure ExceptionHandler; override;
+ procedure ExceptionVariable; override;
+ procedure ExportedHeading; override;
+ procedure ExportsClause; override;
+ procedure ExportsElement; override;
+ procedure ExportsName; override;
+ procedure ExportsNameId; override;
+ procedure Expression; override;
+ procedure ExpressionList; override;
+ procedure ExternalDirective; override;
+ procedure FieldName; override;
+ procedure FinalizationSection; override;
+ procedure FinallyBlock; override;
+ procedure FormalParameterList; override;
+ procedure ForStatement; override;
+ procedure ForStatementDownTo; override;
+ procedure ForStatementFrom; override;
+ procedure ForStatementIn; override;
+ procedure ForStatementTo; override;
+ procedure FunctionHeading; override;
+ procedure FunctionMethodName; override;
+ procedure FunctionProcedureName; override;
+ procedure GotoStatement; override;
+ procedure TernaryOp; override;
+ procedure IfStatement; override;
+ procedure Identifier; override;
+ procedure ImplementationSection; override;
+ procedure ImplementsSpecifier; override;
+ procedure IndexSpecifier; override;
+ procedure IndexOp; override;
+ procedure InheritedStatement; override;
+ procedure InheritedVariableReference; override;
+ procedure InitializationSection; override;
+ procedure InlineVarDeclaration; override;
+ procedure InlineVarSection; override;
+ procedure InterfaceForward; override;
+ procedure InterfaceGUID; override;
+ procedure InterfaceSection; override;
+ procedure InterfaceType; override;
+ procedure IsNotOp; override;
+ procedure LabelId; override;
+ procedure MainUsesClause; override;
+ procedure MainUsedUnitStatement; override;
+ procedure MethodKind; override;
+ procedure MultiplicativeOperator; override;
+ procedure NotInOp; override;
+ procedure NotOp; override;
+ procedure NilToken; override;
+ procedure Number; override;
+ procedure ObjectNameOfMethod; override;
+ procedure OutParameter; override;
+ procedure ParameterFormal; override;
+ procedure ParameterName; override;
+ procedure PointerSymbol; override;
+ procedure PointerType; override;
+ procedure ProceduralType; override;
+ procedure ProcedureHeading; override;
+ procedure ProcedureDeclarationSection; override;
+ procedure ProcedureProcedureName; override;
+ procedure PropertyName; override;
+ procedure PropertyParameterList; override;
+ procedure RaiseStatement; override;
+ procedure RecordAlignValue; override;
+ procedure RecordConstraint; override;
+ procedure RecordFieldConstant; override;
+ procedure RecordType; override;
+ procedure RelativeOperator; override;
+ procedure RepeatStatement; override;
+ procedure ResourceDeclaration; override;
+ procedure ResourceValue; override;
+ procedure RequiresClause; override;
+ procedure RequiresIdentifier; override;
+ procedure RequiresIdentifierId; override;
+ procedure ReturnType; override;
+ procedure RoundClose; override;
+ procedure RoundOpen; override;
+ procedure SetConstructor; override;
+ procedure SetElement; override;
+ procedure SimpleStatement; override;
+ procedure SimpleType; override;
+ procedure StatementList; override;
+ procedure StorageDefault; override;
+ procedure StringConst; override;
+ procedure StringConstSimple; override;
+ procedure StringStatement; override;
+ procedure StructuredType; override;
+ procedure SubrangeType; override;
+ procedure ThenExpression; override;
+ procedure ThenStatement; override;
+ procedure TryStatement; override;
+ procedure TypeArgs; override;
+ procedure TypeDeclaration; override;
+ procedure TypeId; override;
+ procedure TypeParamDecl; override;
+ procedure TypeParams; override;
+ procedure TypeSection; override;
+ procedure TypeSimple; override;
+ procedure UnaryMinus; override;
+ procedure UnitFile; override;
+ procedure UnitName; override;
+ procedure UnitId; override;
+ procedure UsesClause; override;
+ procedure UsedUnitName; override;
+ procedure VarAbsolute; override;
+ procedure VarDeclaration; override;
+ procedure VarName; override;
+ procedure VarParameter; override;
+ procedure VarSection; override;
+ procedure VisibilityPrivate; override;
+ procedure VisibilityProtected; override;
+ procedure VisibilityPublic; override;
+ procedure VisibilityPublished; override;
+ procedure VisibilityStrictPrivate; override;
+ procedure VisibilityStrictProtected; override;
+ procedure WhileStatement; override;
+ procedure WithExpressionList; override;
+ procedure WithStatement; override;
+
+ procedure AttributeSections; override;
+ procedure Attribute; override;
+ procedure AttributeName; override;
+ procedure AttributeArguments; override;
+ procedure PositionalArgument; override;
+ procedure NamedArgument; override;
+ procedure AttributeArgumentName; override;
+ procedure AttributeArgumentExpression; override;
+ public
+ constructor Create; override;
+ destructor Destroy; override;
+ function Run(SourceStream: TStream): TSyntaxNode; reintroduce; overload; virtual;
+ class function Run(const FileName: string; InterfaceOnly: Boolean = False;
+ IncludeHandler: IIncludeHandler = nil;
+ OnHandleString: TStringEvent = nil): TSyntaxNode; reintroduce; overload; static;
+ property Comments: TObjectList read FComments;
+ end;
+
+implementation
+
+uses
+ TypInfo;
+
+{$IFDEF FPC}
+ type
+ TStringStreamHelper = class helper for TStringStream
+ class function Create: TStringStream; overload;
+ procedure LoadFromFile(const FileName: string);
+ end;
+
+ { TStringStreamHelper }
+
+ class function TStringStreamHelper.Create: TStringStream;
+ begin
+ Result := TStringStream.Create('');
+ end;
+
+ procedure TStringStreamHelper.LoadFromFile(const FileName: string);
+ var
+ Strings: TStringList;
+ begin
+ Strings := TStringList.Create;
+ try
+ Strings.LoadFromFile(FileName);
+ Strings.SaveToStream(Self);
+ finally
+ FreeAndNil(Strings);
+ end;
+ end;
+{$ENDIF}
+
+// do not use const strings here to prevent allocating new strings every time
+
+type
+ TAttributeValue = (atAsm, atTrue, atFunction, atProcedure, atClassOf, atClass,
+ atConst, atConstructor, atDestructor, atEnum, atInterface, atNil, atNumeric,
+ atOut, atPointer, atName, atString, atSubRange, atVar, atDispInterface);
+
+var
+ AttributeValues: array[TAttributeValue] of string;
+
+procedure InitAttributeValues;
+var
+ value: TAttributeValue;
+begin
+ for value := Low(TAttributeValue) to High(TAttributeValue) do
+ AttributeValues[value] := Copy(LowerCase(GetEnumName(TypeInfo(TAttributeValue), Ord(value))), 3);
+end;
+
+procedure AssignLexerPositionToNode(const Lexer: TPasLexer; const Node: TSyntaxNode);
+begin
+ Node.LineSeq := Lexer.PosXY.LineSeq;
+ Node.Col := Lexer.PosXY.X;
+ Node.Line := Lexer.PosXY.Y;
+ Node.FileName := Lexer.FileName;
+end;
+
+{ TNodeStack }
+
+function TNodeStack.AddChild(Typ: TSyntaxNodeType): TSyntaxNode;
+begin
+ Result := FStack.Peek.AddChild(TSyntaxNode.Create(Typ));
+ AssignLexerPositionToNode(FLexer, Result);
+end;
+
+function TNodeStack.AddChild(Node: TSyntaxNode): TSyntaxNode;
+begin
+ Result := FStack.Peek.AddChild(Node);
+end;
+
+function TNodeStack.AddValuedChild(Typ: TSyntaxNodeType;
+ const Value: string): TSyntaxNode;
+begin
+ Result := FStack.Peek.AddChild(TValuedSyntaxNode.Create(Typ));
+ AssignLexerPositionToNode(FLexer, Result);
+
+ TValuedSyntaxNode(Result).Value := Value;
+end;
+
+procedure TNodeStack.Clear;
+begin
+ FStack.Clear;
+end;
+
+constructor TNodeStack.Create(Lexer: TPasLexer);
+begin
+ FLexer := Lexer;
+ FStack := TStack.Create;
+end;
+
+destructor TNodeStack.Destroy;
+begin
+ FStack.Free;
+ inherited;
+end;
+
+function TNodeStack.GetCount: Integer;
+begin
+ Result := FStack.Count;
+end;
+
+function TNodeStack.Peek: TSyntaxNode;
+begin
+ Result := FStack.Peek;
+end;
+
+function TNodeStack.Pop: TSyntaxNode;
+begin
+ Result := FStack.Pop;
+end;
+
+function TNodeStack.Push(Node: TSyntaxNode): TSyntaxNode;
+begin
+ FStack.Push(Node);
+ Result := Node;
+ AssignLexerPositionToNode(FLexer, Result);
+end;
+
+function TNodeStack.PushCompoundSyntaxNode(Typ: TSyntaxNodeType): TSyntaxNode;
+begin
+ Result := Push(Peek.AddChild(TCompoundSyntaxNode.Create(Typ)));
+end;
+
+function TNodeStack.PushValuedNode(Typ: TSyntaxNodeType;
+ const Value: string): TSyntaxNode;
+begin
+ Result := Push(Peek.AddChild(TValuedSyntaxNode.Create(Typ)));
+ TValuedSyntaxNode(Result).Value := Value;
+end;
+
+function TNodeStack.Push(Typ: TSyntaxNodeType): TSyntaxNode;
+begin
+ Result := FStack.Peek.AddChild(TSyntaxNode.Create(Typ));
+ Push(Result);
+end;
+
+{ TPasSyntaxTreeBuilder }
+
+procedure TPasSyntaxTreeBuilder.AccessSpecifier;
+begin
+ case ExID of
+ ptRead:
+ FStack.Push(ntRead);
+ ptWrite:
+ FStack.Push(ntWrite);
+ else
+ FStack.Push(ntUnknown);
+ end;
+ try
+ inherited AccessSpecifier;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.AdditiveOperator;
+begin
+ case TokenID of
+ ptMinus: FStack.AddChild(ntSub);
+ ptOr: FStack.AddChild(ntOr);
+ ptPlus: FStack.AddChild(ntAdd);
+ ptXor: FStack.AddChild(ntXor);
+ end;
+
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.AddressOp;
+begin
+ FStack.Push(ntAddr);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.AlignmentParameter;
+begin
+ FStack.Push(ntAlignmentParam);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.AnonymousMethod;
+begin
+ FStack.Push(ntAnonymousMethod);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ArrayBounds;
+begin
+ FStack.Push(ntBounds);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ArrayConstant;
+begin
+ FStack.Push(ntExpressions);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ArrayDimension;
+begin
+ FStack.Push(ntDimension);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.AsmStatement;
+begin
+ FStack.PushCompoundSyntaxNode(ntStatements).SetAttribute(anType, AttributeValues[atAsm]);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.AsOp;
+begin
+ FStack.AddChild(ntAs);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.AssignOp;
+begin
+ FStack.AddChild(ntAssign);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.AtExpression;
+begin
+ FStack.Push(ntAt);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.Attribute;
+begin
+ FStack.Push(ntAttribute);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.AttributeArgumentExpression;
+begin
+ FStack.Push(ntValue);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.AttributeArgumentName;
+begin
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.AttributeArguments;
+begin
+ FStack.Push(ntArguments);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.AttributeName;
+begin
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.AttributeSections;
+begin
+ FStack.Push(ntAttributes);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.BuildExpressionTree(
+ ExpressionMethod: TTreeBuilderMethod);
+var
+ RawExprNode: TSyntaxNode;
+ ExprNode: TSyntaxNode;
+
+ NodeList: TList;
+ Node: TSyntaxNode;
+ Col, Line, LineSeq: Integer;
+ FileName: string;
+begin
+ LineSeq := Lexer.PosXY.LineSeq;
+ Line := Lexer.PosXY.Y;
+ Col := Lexer.PosXY.X;
+ FileName := Lexer.FileName;
+
+ RawExprNode := TSyntaxNode.Create(ntExpression);
+ try
+ FStack.Push(RawExprNode);
+ try
+ ExpressionMethod;
+ finally
+ FStack.Pop;
+ end;
+
+ if RawExprNode.HasChildren then
+ begin
+ ExprNode := FStack.Push(ntExpression);
+ try
+ ExprNode.LineSeq := LineSeq;
+ ExprNode.Line := Line;
+ ExprNode.Col := Col;
+ ExprNode.FileName := FileName;
+
+ NodeList := TList.Create;
+ try
+ for Node in RawExprNode.ChildNodes do
+ NodeList.Add(Node);
+ TExpressionTools.RawNodeListToTree(RawExprNode, NodeList, ExprNode);
+ finally
+ NodeList.Free;
+ end;
+ finally
+ FStack.Pop;
+ end;
+ end;
+ finally
+ RawExprNode.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.BuildParametersList(
+ ParametersListMethod: TTreeBuilderMethod);
+var
+ Params, Temp: TSyntaxNode;
+ ParamList, Param, TypeInfo, ParamExpr: TSyntaxNode;
+ ParamKind: string;
+begin
+ Params := TSyntaxNode.Create(ntUnknown);
+ try
+ FStack.Push(ntParameters);
+
+ FStack.Push(Params);
+ try
+ ParametersListMethod;
+ finally
+ FStack.Pop;
+ end;
+
+ for ParamList in Params.ChildNodes do
+ begin
+ TypeInfo := ParamList.FindNode(ntType);
+ ParamKind := ParamList.GetAttribute(anKind);
+ ParamExpr := ParamList.FindNode(ntExpression);
+
+ for Param in ParamList.ChildNodes do
+ begin
+ if Param.Typ <> ntName then
+ Continue;
+
+ Temp := FStack.Push(ntParameter);
+ if ParamKind <> '' then
+ Temp.SetAttribute(anKind, ParamKind);
+
+ Temp.Col := Param.Col;
+ Temp.Line := Param.Line;
+
+ FStack.AddChild(Param.Clone);
+ if Assigned(TypeInfo) then
+ FStack.AddChild(TypeInfo.Clone);
+
+ if Assigned(ParamExpr) then
+ FStack.AddChild(ParamExpr.Clone);
+
+ FStack.Pop;
+ end;
+ end;
+ FStack.Pop;
+ finally
+ Params.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.CaseElseStatement;
+begin
+ FStack.Push(ntCaseElse);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.CaseLabel;
+begin
+ FStack.Push(ntCaseLabel);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.CaseLabelList;
+begin
+ FStack.Push(ntCaseLabels);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.CaseSelector;
+begin
+ FStack.Push(ntCaseSelector);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.CaseStatement;
+begin
+ FStack.Push(ntCase);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassClass;
+begin
+ FStack.Peek.SetAttribute(anClass, AttributeValues[atTrue]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassField;
+var
+ Fields, Temp: TSyntaxNode;
+ Field, TypeInfo, TypeArgs: TSyntaxNode;
+begin
+ Fields := TSyntaxNode.Create(ntFields);
+ try
+ FStack.Push(Fields);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+
+ TypeInfo := Fields.FindNode(ntType);
+ TypeArgs := Fields.FindNode(ntTypeArgs);
+ for Field in Fields.ChildNodes do
+ begin
+ if Field.Typ <> ntName then
+ Continue;
+
+ Temp := FStack.Push(ntField);
+ try
+ Temp.AssignPositionFrom(Field);
+
+ FStack.AddChild(Field.Clone);
+ TypeInfo := TypeInfo.Clone;
+ if Assigned(TypeArgs) then
+ TypeInfo.AddChild(TypeArgs.Clone);
+ FStack.AddChild(TypeInfo);
+ finally
+ FStack.Pop;
+ end;
+ end;
+ finally
+ Fields.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassForward;
+begin
+ FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]);
+ inherited ClassForward;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassFunctionHeading;
+begin
+ FStack.Peek.SetAttribute(anKind, AttributeValues[atFunction]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassHelper;
+begin
+ FStack.Push(ntHelper);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassMethod;
+begin
+ FStack.Peek.SetAttribute(anClass, AttributeValues[atTrue]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassMethodResolution;
+begin
+ FStack.Push(ntResolutionClause);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassMethodHeading;
+begin
+ FStack.PushCompoundSyntaxNode(ntMethod);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassProcedureHeading;
+begin
+ FStack.Peek.SetAttribute(anKind, AttributeValues[atProcedure]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassProperty;
+begin
+ FStack.Push(ntProperty);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassReferenceType;
+begin
+ FStack.Push(ntType).SetAttribute(anType, AttributeValues[atClassof]);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassType;
+begin
+ FStack.Push(ntType).SetAttribute(anType, AttributeValues[atClass]);
+ try
+ inherited;
+ finally
+ MoveMembersToVisibilityNodes(FStack.Pop);
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.MoveMembersToVisibilityNodes(TypeNode: TSyntaxNode);
+var
+ child, vis: TSyntaxNode;
+ i: Integer;
+ extracted: Boolean;
+begin
+ vis := nil;
+ i := 0;
+ while i < Length(TypeNode.ChildNodes) do
+ begin
+ child := TypeNode.ChildNodes[i];
+ extracted := false;
+ if child.HasAttribute(anVisibility) then
+ vis := child
+ else if Assigned(vis) then
+ begin
+ TypeNode.ExtractChild(child);
+ vis.AddChild(child);
+ extracted := true;
+ end;
+ if not extracted then
+ inc(i);
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstParameter;
+begin
+ FStack.Push(ntParameters).SetAttribute(anKind, AttributeValues[atConst]);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstructorName;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Peek;
+ Temp.SetAttribute(anKind, AttributeValues[atConstructor]);
+ Temp.SetAttribute(anName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.CompoundStatement;
+begin
+ FStack.PushCompoundSyntaxNode(ntStatements);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstantDeclaration;
+begin
+ FStack.Push(ntConstant);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstantExpression;
+var
+ ExpressionMethod: TTreeBuilderMethod;
+begin
+ ExpressionMethod := CallInheritedConstantExpression;
+ BuildExpressionTree(ExpressionMethod);
+end;
+
+procedure TPasSyntaxTreeBuilder.CallInheritedFormalParameterList;
+begin
+ inherited FormalParameterList;
+end;
+
+procedure TPasSyntaxTreeBuilder.CallInheritedConstantExpression;
+begin
+ inherited ConstantExpression;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstantName;
+begin
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstantValue;
+begin
+ FStack.Push(ntValue);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstantValueTyped;
+begin
+ FStack.Push(ntValue);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstraintList;
+begin
+ FStack.Push(ntConstraints);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ClassConstraint;
+begin
+ FStack.Push(ntClassConstraint);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstructorConstraint;
+begin
+ FStack.Push(ntConstructorConstraint);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RecordConstraint;
+begin
+ FStack.Push(ntRecordConstraint);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RecordAlignValue;
+begin
+ FStack.Peek.SetAttribute(anAlign, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ConstSection;
+var
+ ConstSect, Temp: TSyntaxNode;
+ ConstList, Constant, TypeInfo, Value: TSyntaxNode;
+begin
+ ConstSect := TSyntaxNode.Create(ntConstants);
+ try
+ FStack.Push(ntConstants);
+
+ FStack.Push(ConstSect);
+ try
+ inherited ConstSection;
+ finally
+ FStack.Pop;
+ end;
+
+ for ConstList in ConstSect.ChildNodes do
+ begin
+ TypeInfo := ConstList.FindNode(ntType);
+ Value := ConstList.FindNode(ntValue);
+ for Constant in ConstList.ChildNodes do
+ begin
+ if Constant.Typ <> ntName then
+ Continue;
+
+ Temp := FStack.Push(ConstList.Typ);
+ try
+ Temp.AssignPositionFrom(Constant);
+
+ FStack.AddChild(Constant.Clone);
+ if Assigned(TypeInfo) then
+ FStack.AddChild(TypeInfo.Clone);
+ FStack.AddChild(Value.Clone);
+ finally
+ FStack.Pop;
+ end;
+ end;
+ end;
+ FStack.Pop;
+ finally
+ ConstSect.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ContainsClause;
+begin
+ FStack.Push(ntContains);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+constructor TPasSyntaxTreeBuilder.Create;
+begin
+ inherited;
+ FStack := TNodeStack.Create(Lexer);
+ FComments := TObjectList.Create(True);
+ OnComment := DoOnComment;
+end;
+
+function TPasSyntaxTreeBuilder.DequoteString(const S: string): string;
+var
+ QuoteCount, I: Integer;
+begin
+ QuoteCount := 0;
+ for I := Low(S) to High(S) do
+ if S[I] = '''' then
+ Inc(QuoteCount)
+ else
+ Break;
+
+ if (QuoteCount = 1) or (QuoteCount mod 2 = 0) then
+ begin
+ Result := AnsiDequotedStr(S, '''');
+ Exit;
+ end;
+
+ Result := Copy(S, QuoteCount + 1, Length(S) - QuoteCount * 2);
+end;
+
+destructor TPasSyntaxTreeBuilder.Destroy;
+begin
+ FStack.Free;
+ FComments.Free;
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.DestructorName;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Peek;
+ Temp.SetAttribute(anKind, AttributeValues[atDestructor]);
+ Temp.SetAttribute(anName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.DirectiveBinding;
+var
+ token: string;
+begin
+ token := Lexer.Token;
+ // Method bindings:
+ if SameText(token, 'override') or SameText(token, 'virtual')
+ or SameText(token, 'dynamic')
+ then
+ FStack.Peek.SetAttribute(anMethodBinding, token)
+ // Other directives
+ else if SameText(token, 'reintroduce') then
+ FStack.Peek.SetAttribute(anReintroduce, AttributeValues[atTrue])
+ else if SameText(token, 'overload') then
+ FStack.Peek.SetAttribute(anOverload, AttributeValues[atTrue])
+ else if SameText(token, 'abstract') then
+ FStack.Peek.SetAttribute(anAbstract, AttributeValues[atTrue]);
+
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.DirectiveBindingMessage;
+begin
+ FStack.Push(ntMessage);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.DirectiveCalling;
+begin
+ FStack.Peek.SetAttribute(anCallingConvention, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.DirectiveInline;
+begin
+ FStack.Peek.SetAttribute(anInline, AttributeValues[atTrue]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.DispInterfaceForward;
+begin
+ FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.DotOp;
+begin
+ FStack.AddChild(ntDot);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ElseExpression;
+begin
+ FStack.Push(ntElse);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ElseStatement;
+begin
+ FStack.Push(ntElse);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.EmptyStatement;
+begin
+ FStack.Push(ntEmptyStatement);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.EnumeratedType;
+var
+ TypeNode: TSyntaxNode;
+begin
+ TypeNode := FStack.Push(ntType);
+ try
+ TypeNode.SetAttribute(anName, AttributeValues[atEnum]);
+ if ScopedEnums then
+ TypeNode.SetAttribute(anVisibility, 'scoped');
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExceptBlock;
+begin
+ FStack.Push(ntExcept);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExceptionBlockElseBranch;
+begin
+ FStack.Push(ntElse);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExceptionHandler;
+begin
+ FStack.Push(ntExceptionHandler);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExceptionVariable;
+begin
+ FStack.Push(ntVariable);
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExportedHeading;
+begin
+ FStack.PushCompoundSyntaxNode(ntMethod);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExportsClause;
+begin
+ FStack.Push(ntExports);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExportsElement;
+begin
+ FStack.Push(ntElement);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExportsName;
+var
+ NamesNode: TSyntaxNode;
+begin
+ NamesNode := TSyntaxNode.Create(ntUnknown);
+ try
+ FStack.Push(NamesNode);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+
+ FStack.Peek.SetAttribute(anName, NodeListToString(NamesNode));
+ finally
+ NamesNode.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExportsNameId;
+begin
+ FStack.AddChild(ntUnknown).SetAttribute(anName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.Expression;
+var
+ ExpressionMethod: TTreeBuilderMethod;
+begin
+ ExpressionMethod := CallInheritedExpression;
+ BuildExpressionTree(ExpressionMethod);
+end;
+
+procedure TPasSyntaxTreeBuilder.SetCurrentCompoundNodesEndPosition;
+var
+ Temp: TCompoundSyntaxNode;
+begin
+ Temp := TCompoundSyntaxNode(FStack.Peek);
+ Temp.EndCol := Lexer.PosXY.X;
+ Temp.EndLine := Lexer.PosXY.Y;
+ Temp.FileName := Lexer.FileName;
+end;
+
+procedure TPasSyntaxTreeBuilder.CallInheritedExpression;
+begin
+ inherited Expression;
+end;
+
+procedure TPasSyntaxTreeBuilder.CallInheritedPropertyParameterList;
+begin
+ inherited PropertyParameterList;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExpressionList;
+begin
+ FStack.Push(ntExpressions);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ExternalDirective;
+begin
+ FStack.Push(ntExternal);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.FieldName;
+begin
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.FinalizationSection;
+begin
+ FStack.PushCompoundSyntaxNode(ntFinalization);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.FinallyBlock;
+begin
+ FStack.Push(ntFinally);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.FormalParameterList;
+var
+ TreeBuilderMethod: TTreeBuilderMethod;
+begin
+ TreeBuilderMethod := CallInheritedFormalParameterList;
+ BuildParametersList(TreeBuilderMethod);
+end;
+
+procedure TPasSyntaxTreeBuilder.ForStatement;
+begin
+ FStack.Push(ntFor);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ForStatementDownTo;
+begin
+ FStack.Push(ntDownTo);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ForStatementFrom;
+begin
+ FStack.Push(ntFrom);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ForStatementIn;
+begin
+ FStack.Push(ntIn);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ForStatementTo;
+begin
+ FStack.Push(ntTo);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.FunctionHeading;
+begin
+ FStack.Peek.SetAttribute(anKind, AttributeValues[atFunction]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.FunctionMethodName;
+begin
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.FunctionProcedureName;
+var
+ ChildNode, NameNode, TypeParam, TypeNode, Temp: TSyntaxNode;
+ FullName, TypeParams: string;
+begin
+ FStack.Push(ntName);
+ NameNode := FStack.Peek;
+ try
+ inherited;
+ for ChildNode in NameNode.ChildNodes do
+ begin
+ if ChildNode.Typ = ntTypeParams then
+ begin
+ TypeParams := '';
+
+ for TypeParam in ChildNode.ChildNodes do
+ begin
+ TypeNode := TypeParam.FindNode(ntType);
+ if Assigned(TypeNode) then
+ begin
+ if TypeParams <> '' then
+ TypeParams := TypeParams + ',';
+ TypeParams := TypeParams + TypeNode.GetAttribute(anName);
+ end;
+ end;
+
+ FullName := FullName + '<' + TypeParams + '>';
+ Continue;
+ end;
+
+ if FullName <> '' then
+ FullName := FullName + '.';
+ FullName := FullName + TValuedSyntaxNode(ChildNode).Value;
+ end;
+ finally
+ FStack.Pop;
+ Temp := FStack.Peek;
+ DoHandleString(FullName);
+ Temp.SetAttribute(anName, FullName);
+ Temp.DeleteChild(NameNode);
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.GotoStatement;
+begin
+ FStack.Push(ntGoto);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.Identifier;
+begin
+ FStack.AddChild(ntIdentifier).SetAttribute(anName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.TernaryOp;
+begin
+ FStack.Push(ntTernaryOp);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.IfStatement;
+begin
+ FStack.Push(ntIf);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ImplementationSection;
+begin
+ FStack.PushCompoundSyntaxNode(ntImplementation);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ImplementsSpecifier;
+begin
+ FStack.Push(ntImplements);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.IndexOp;
+begin
+ FStack.Push(ntIndexed);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.IndexSpecifier;
+begin
+ FStack.Push(ntIndex);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.InheritedStatement;
+begin
+ FStack.Push(ntInherited);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.InheritedVariableReference;
+begin
+ FStack.Push(ntInherited);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.InitializationSection;
+begin
+ FStack.PushCompoundSyntaxNode(ntInitialization);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.InlineVarDeclaration;
+begin
+ FStack.Push(ntVariables);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.InlineVarSection;
+var
+ VarSect, Variables, Expression: TSyntaxNode;
+begin
+ VarSect := TSyntaxNode.Create(ntUnknown);
+ try
+ Variables := FStack.Push(ntVariables);
+
+ FStack.Push(VarSect);
+ try
+ inherited InlineVarSection;
+ finally
+ FStack.Pop;
+ end;
+ RearrangeVarSection(VarSect);
+ Expression := VarSect.FindNode(ntExpression);
+ if Assigned(Expression) then
+ Variables.AddChild(ntAssign).AddChild(Expression.Clone);
+
+ FStack.Pop;
+ finally
+ VarSect.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.InterfaceForward;
+begin
+ FStack.Peek.SetAttribute(anForwarded, AttributeValues[atTrue]);
+ inherited InterfaceForward;
+end;
+
+procedure TPasSyntaxTreeBuilder.InterfaceGUID;
+begin
+ FStack.Push(ntGuid);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.InterfaceSection;
+begin
+ FStack.PushCompoundSyntaxNode(ntInterface);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.InterfaceType;
+begin
+ case TokenID of
+ ptInterface:
+ FStack.Push(ntType).SetAttribute(anType, AttributeValues[atInterface]);
+ ptDispInterface:
+ FStack.Push(ntType).SetAttribute(anType, AttributeValues[atDispInterface]);
+ end;
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.IsNotOp;
+begin
+ FStack.AddChild(ntIsNot);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.LabelId;
+begin
+ FStack.AddValuedChild(ntLabel, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.MainUsedUnitStatement;
+var
+ NameNode, PathNode, PathLiteralNode, Temp: TSyntaxNode;
+begin
+ FStack.Push(ntUnit);
+ try
+ inherited;
+
+ NameNode := FStack.Peek.FindNode(ntUnit);
+
+ if Assigned(NameNode) then
+ begin
+ Temp := FStack.Peek;
+ Temp.SetAttribute(anName, NameNode.GetAttribute(anName));
+ Temp.DeleteChild(NameNode);
+ end;
+
+ PathNode := FStack.Peek.FindNode(ntExpression);
+ if Assigned(PathNode) then
+ begin
+ FStack.Peek.ExtractChild(PathNode);
+ try
+ PathLiteralNode := PathNode.FindNode(ntLiteral);
+
+ if PathLiteralNode is TValuedSyntaxNode then
+ FStack.Peek.SetAttribute(anPath, TValuedSyntaxNode(PathLiteralNode).Value);
+ finally
+ PathNode.Free;
+ end;
+ end;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.MainUsesClause;
+begin
+ FStack.PushCompoundSyntaxNode(ntUses);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.MethodKind;
+var
+ value: string;
+begin
+ value := LowerCase(Lexer.Token);
+ DoHandleString(value);
+ FStack.Peek.SetAttribute(anKind, value);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.MultiplicativeOperator;
+begin
+ case TokenID of
+ ptAnd:
+ FStack.AddChild(ntAnd);
+ ptDiv:
+ FStack.AddChild(ntDiv);
+ ptMod:
+ FStack.AddChild(ntMod);
+ ptShl:
+ FStack.AddChild(ntShl);
+ ptShr:
+ FStack.AddChild(ntShr);
+ ptSlash:
+ FStack.AddChild(ntFDiv);
+ ptStar:
+ FStack.AddChild(ntMul);
+ else
+ FStack.AddChild(ntUnknown);
+ end;
+
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.NamedArgument;
+begin
+ FStack.Push(ntNamedArgument);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.NilToken;
+begin
+ FStack.AddChild(ntLiteral).SetAttribute(anType, AttributeValues[atNil]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.NotInOp;
+begin
+ FStack.AddChild(ntNotIn);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.NotOp;
+begin
+ FStack.AddChild(ntNot);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.Number;
+var
+ Node: TSyntaxNode;
+begin
+ Node := FStack.AddValuedChild(ntLiteral, Lexer.Token);
+ Node.SetAttribute(anType, AttributeValues[atNumeric]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ObjectNameOfMethod;
+begin
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.DoOnComment(Sender: TObject; const Text: string);
+var
+ Node: TCommentNode;
+begin
+ case TokenID of
+ ptAnsiComment: Node := TCommentNode.Create(ntAnsiComment);
+ ptBorComment: Node := TCommentNode.Create(ntBorComment);
+ ptSlashesComment: Node := TCommentNode.Create(ntSlashesComment);
+ else
+ raise EParserException.Create(Lexer.PosXY.Y, Lexer.PosXY.X, Lexer.FileName, 'Invalid comment type');
+ end;
+
+ AssignLexerPositionToNode(Lexer, Node);
+ Node.Text := Text;
+
+ FComments.Add(Node);
+end;
+
+procedure TPasSyntaxTreeBuilder.ParserMessage(Sender: TObject;
+ const Typ: TMessageEventType; const Msg: string; X, Y: Integer);
+begin
+ if Typ = TMessageEventType.meError then
+ raise EParserException.Create(Y, X, Lexer.FileName, Msg);
+end;
+
+procedure TPasSyntaxTreeBuilder.OutParameter;
+begin
+ FStack.Push(ntParameters).SetAttribute(anKind, AttributeValues[atOut]);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ParameterFormal;
+begin
+ FStack.Push(ntParameters);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ParameterName;
+begin
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.PointerSymbol;
+begin
+ FStack.AddChild(ntDeref);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.PointerType;
+begin
+ FStack.Push(ntType).SetAttribute(anType, AttributeValues[atPointer]);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.PositionalArgument;
+begin
+ FStack.Push(ntPositionalArgument);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ProceduralType;
+begin
+ FStack.Push(ntType).SetAttribute(anName, Lexer.Token);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ProcedureDeclarationSection;
+begin
+ FStack.PushCompoundSyntaxNode(ntMethod);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ProcedureHeading;
+begin
+ FStack.Peek.SetAttribute(anKind, AttributeValues[atProcedure]);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ProcedureProcedureName;
+begin
+ FStack.Peek.SetAttribute(anName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.PropertyName;
+begin
+ FStack.Peek.SetAttribute(anName, Lexer.Token);
+ inherited PropertyName;
+end;
+
+procedure TPasSyntaxTreeBuilder.PropertyParameterList;
+var
+ TreeBuilderMethod: TTreeBuilderMethod;
+begin
+ TreeBuilderMethod := CallInheritedPropertyParameterList;
+ BuildParametersList(TreeBuilderMethod);
+end;
+
+procedure TPasSyntaxTreeBuilder.RaiseStatement;
+begin
+ FStack.Push(ntRaise);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RecordFieldConstant;
+var
+ Node: TSyntaxNode;
+begin
+ Node := FStack.PushValuedNode(ntField, Lexer.Token);
+ try
+ Node.SetAttribute(anType, AttributeValues[atName]);
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RecordType;
+begin
+ inherited RecordType;
+ MoveMembersToVisibilityNodes(FStack.Peek);
+end;
+
+procedure TPasSyntaxTreeBuilder.RelativeOperator;
+begin
+ case TokenID of
+ ptAs:
+ FStack.AddChild(ntAs);
+ ptEqual:
+ FStack.AddChild(ntEqual);
+ ptGreater:
+ FStack.AddChild(ntGreater);
+ ptGreaterEqual:
+ FStack.AddChild(ntGreaterEqual);
+ ptIn:
+ FStack.AddChild(ntIn);
+ ptIs:
+ FStack.AddChild(ntIs);
+ ptLower:
+ FStack.AddChild(ntLower);
+ ptLowerEqual:
+ FStack.AddChild(ntLowerEqual);
+ ptNotEqual:
+ FStack.AddChild(ntNotEqual);
+ else
+ FStack.AddChild(ntUnknown);
+ end;
+
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.RepeatStatement;
+begin
+ FStack.Push(ntRepeat);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RequiresClause;
+begin
+ FStack.Push(ntRequires);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RequiresIdentifier;
+var
+ NamesNode: TSyntaxNode;
+begin
+ NamesNode := TSyntaxNode.Create(ntUnknown);
+ try
+ FStack.Push(NamesNode);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+
+ FStack.AddChild(ntPackage).SetAttribute(anName, NodeListToString(NamesNode));
+ finally
+ NamesNode.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RequiresIdentifierId;
+begin
+ FStack.AddChild(ntUnknown).SetAttribute(anName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.ResourceDeclaration;
+begin
+ FStack.Push(ntResourceString);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ResourceValue;
+begin
+ FStack.Push(ntValue);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ReturnType;
+begin
+ FStack.Push(ntReturnType);
+ try
+ inherited;
+ finally
+ FStack.Pop
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RoundClose;
+begin
+ FStack.AddChild(ntRoundClose);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.RoundOpen;
+begin
+ FStack.AddChild(ntRoundOpen);
+ inherited;
+end;
+
+class function TPasSyntaxTreeBuilder.Run(const FileName: string;
+ InterfaceOnly: Boolean; IncludeHandler: IIncludeHandler;
+ OnHandleString: TStringEvent): TSyntaxNode;
+var
+ Stream: TStringStream;
+ Builder: TPasSyntaxTreeBuilder;
+begin
+ Stream := TStringStream.Create;
+ try
+ Stream.LoadFromFile(FileName);
+ Builder := TPasSyntaxTreeBuilder.Create;
+ Builder.InterfaceOnly := InterfaceOnly;
+ Builder.OnHandleString := OnHandleString;
+ try
+ Builder.InitDefinesDefinedByCompiler;
+ Builder.IncludeHandler := IncludeHandler;
+ Result := Builder.Run(Stream);
+ finally
+ Builder.Free;
+ end;
+ finally
+ Stream.Free;
+ end;
+end;
+
+function TPasSyntaxTreeBuilder.Run(SourceStream: TStream): TSyntaxNode;
+begin
+ Result := TSyntaxNode.Create(ntUnit);
+ try
+ FStack.Clear;
+ FStack.Push(Result);
+ try
+ self.OnMessage := ParserMessage;
+ inherited Run('', SourceStream);
+ finally
+ FStack.Pop;
+ end;
+ except
+ on E: EParserException do
+ raise ESyntaxTreeException.Create(E.Line, E.Col, Lexer.FileName, E.Message, Result);
+ on E: ESyntaxError do
+ raise ESyntaxTreeException.Create(E.PosXY.X, E.PosXY.Y, Lexer.FileName, E.Message, Result);
+ else
+ FreeAndNil(Result);
+ raise;
+ end;
+
+ Assert(FStack.Count = 0);
+end;
+
+function TPasSyntaxTreeBuilder.NodeListToString(NamesNode: TSyntaxNode): string;
+var
+ NamePartNode: TSyntaxNode;
+begin
+ Result := '';
+ for NamePartNode in NamesNode.ChildNodes do
+ begin
+ if Result <> '' then
+ Result := Result + '.';
+ Result := Result + NamePartNode.GetAttribute(anName);
+ end;
+ DoHandleString(Result);
+end;
+
+procedure TPasSyntaxTreeBuilder.SetConstructor;
+begin
+ FStack.Push(ntSet);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.SetElement;
+begin
+ FStack.Push(ntElement);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.SimpleStatement;
+var
+ RawStatement, Temp: TSyntaxNode;
+ Node, LHS, RHS: TSyntaxNode;
+ NodeList: TList;
+ I, AssignIdx: Integer;
+ Position: TTokenPoint;
+ FileName: string;
+ LineSeq: Integer;
+begin
+ LineSeq := Lexer.PosXY.LineSeq;
+ Position := Lexer.PosXY;
+ FileName := Lexer.FileName;
+
+ RawStatement := TSyntaxNode.Create(ntStatement);
+ try
+ FStack.Push(RawStatement);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+
+ if not RawStatement.HasChildren then
+ Exit;
+
+ if RawStatement.FindNode(ntAssign) <> nil then
+ begin
+ Temp := FStack.Push(ntAssign);
+ try
+ Temp.LineSeq := LineSeq;
+ Temp.Col := Position.X;
+ Temp.Line := Position.Y;
+ Temp.FileName := FileName;
+
+ NodeList := TList.Create;
+ try
+ AssignIdx := -1;
+ for I := 0 to Length(RawStatement.ChildNodes) - 1 do
+ begin
+ if RawStatement.ChildNodes[I].Typ = ntAssign then
+ begin
+ AssignIdx := I;
+ Break;
+ end;
+ NodeList.Add(RawStatement.ChildNodes[I]);
+ end;
+
+ if NodeList.Count = 0 then
+ raise EParserException.Create(Position.Y, Position.X, Lexer.FileName, 'Illegal expression');
+
+ LHS := FStack.AddChild(ntLHS);
+ LHS.AssignPositionFrom(NodeList[0]);
+
+ TExpressionTools.RawNodeListToTree(RawStatement, NodeList, LHS);
+
+ NodeList.Clear;
+
+ for I := AssignIdx + 1 to Length(RawStatement.ChildNodes) - 1 do
+ NodeList.Add(RawStatement.ChildNodes[I]);
+
+ if NodeList.Count = 0 then
+ raise EParserException.Create(Position.Y, Position.X, Lexer.FileName, 'Illegal expression');
+
+ RHS := FStack.AddChild(ntRHS);
+ RHS.AssignPositionFrom(NodeList[0]);
+
+ TExpressionTools.RawNodeListToTree(RawStatement, NodeList, RHS);
+ finally
+ NodeList.Free;
+ end;
+ finally
+ FStack.Pop;
+ end;
+ end else
+ begin
+ Temp := FStack.Push(ntCall);
+ try
+ Temp.Col := Position.X;
+ Temp.Line := Position.Y;
+
+ NodeList := TList.Create;
+ try
+ for Node in RawStatement.ChildNodes do
+ NodeList.Add(Node);
+ TExpressionTools.RawNodeListToTree(RawStatement, NodeList, FStack.Peek);
+ finally
+ NodeList.Free;
+ end;
+ finally
+ FStack.Pop;
+ end;
+ end;
+ finally
+ RawStatement.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.SimpleType;
+begin
+ FStack.Push(ntType).SetAttribute(anName, Lexer.Token);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.StatementList;
+begin
+ FStack.PushCompoundSyntaxNode(ntStatements);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.StorageDefault;
+begin
+ FStack.Push(ntDefault);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.StringConst;
+var
+ StrConst: TSyntaxNode;
+ Literal, Node: TSyntaxNode;
+ Str: string;
+begin
+ StrConst := TSyntaxNode.Create(ntUnknown);
+ try
+ FStack.Push(StrConst);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+
+ Str := '';
+ for Literal in StrConst.ChildNodes do
+ Str := Str + TValuedSyntaxNode(Literal).Value;
+ finally
+ StrConst.Free;
+ end;
+
+ DoHandleString(Str);
+ Node := FStack.AddValuedChild(ntLiteral, Str);
+ Node.SetAttribute(anType, AttributeValues[atString]);
+end;
+
+procedure TPasSyntaxTreeBuilder.StringConstSimple;
+begin
+ //TODO support ptAsciiChar
+ FStack.AddValuedChild(ntLiteral, DequoteString(Lexer.Token));
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.StringStatement;
+begin
+ FStack.AddChild(ntType).SetAttribute(anName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.StructuredType;
+begin
+ FStack.Push(ntType).SetAttribute(anType, Lexer.Token);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.SubrangeType;
+begin
+ FStack.Push(ntType).SetAttribute(anName, AttributeValues[atSubRange]);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ThenExpression;
+begin
+ FStack.Push(ntThen);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.ThenStatement;
+begin
+ FStack.Push(ntThen);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.TryStatement;
+begin
+ FStack.Push(ntTry);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.TypeArgs;
+begin
+ FStack.Push(ntTypeArgs);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.TypeDeclaration;
+begin
+ FStack.PushCompoundSyntaxNode(ntTypeDecl).SetAttribute(anName, Lexer.Token);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.TypeId;
+var
+ TypeNode, InnerTypeNode, SubNode: TSyntaxNode;
+ TypeName, InnerTypeName: string;
+ i: integer;
+begin
+ TypeNode := FStack.Push(ntType);
+ try
+ inherited;
+
+ InnerTypeName := '';
+ InnerTypeNode := TypeNode.FindNode(ntType);
+ if Assigned(InnerTypeNode) then
+ begin
+ InnerTypeName := InnerTypeNode.GetAttribute(anName);
+ for SubNode in InnerTypeNode.ChildNodes do
+ TypeNode.AddChild(SubNode.Clone);
+
+ TypeNode.DeleteChild(InnerTypeNode);
+ end;
+
+ TypeName := '';
+ for i := Length(TypeNode.ChildNodes) - 1 downto 0 do
+ begin
+ SubNode := TypeNode.ChildNodes[i];
+ if SubNode.Typ = ntType then
+ begin
+ if TypeName <> '' then
+ TypeName := '.' + TypeName;
+
+ TypeName := SubNode.GetAttribute(anName) + TypeName;
+ TypeNode.DeleteChild(SubNode);
+ end;
+ end;
+
+ if TypeName <> '' then
+ TypeName := '.' + TypeName;
+ TypeName := InnerTypeName + TypeName;
+
+ DoHandleString(TypeName);
+ TypeNode.SetAttribute(anName, TypeName);
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.TypeParamDecl;
+var
+ OriginTypeParamNode, NewTypeParamNode, Constraints, TypeNode: TSyntaxNode;
+ TypeNodeCount: integer;
+ TypeNodesToDelete: TList;
+begin
+ OriginTypeParamNode := FStack.Push(ntTypeParam);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+
+ Constraints := OriginTypeParamNode.FindNode(ntConstraints);
+ TypeNodeCount := 0;
+ TypeNodesToDelete := TList.Create;
+ try
+ for TypeNode in OriginTypeParamNode.ChildNodes do
+ begin
+ if TypeNode.Typ = ntType then
+ begin
+ inc(TypeNodeCount);
+ if TypeNodeCount > 1 then
+ begin
+ NewTypeParamNode := FStack.Push(ntTypeParam);
+ try
+ NewTypeParamNode.AddChild(TypeNode.Clone);
+ if Assigned(Constraints) then
+ NewTypeParamNode.AddChild(Constraints.Clone);
+ TypeNodesToDelete.Add(TypeNode);
+ finally
+ FStack.Pop;
+ end;
+ end;
+ end;
+ end;
+
+ for TypeNode in TypeNodesToDelete do
+ OriginTypeParamNode.DeleteChild(TypeNode);
+ finally
+ TypeNodesToDelete.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.TypeParams;
+begin
+ FStack.Push(ntTypeParams);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.TypeSection;
+begin
+ FStack.Push(ntTypeSection);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.TypeSimple;
+begin
+ FStack.Push(ntType).SetAttribute(anName, Lexer.Token);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.UnaryMinus;
+begin
+ FStack.AddChild(ntUnaryMinus);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.UnitFile;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Peek;
+ AssignLexerPositionToNode(Lexer, Temp);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.UnitId;
+begin
+ FStack.AddChild(ntUnknown).SetAttribute(anName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.UnitName;
+var
+ NamesNode: TSyntaxNode;
+begin
+ NamesNode := TSyntaxNode.Create(ntUnknown);
+ try
+ FStack.Push(NamesNode);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+
+ FStack.Peek.SetAttribute(anName, NodeListToString(NamesNode));
+ finally
+ NamesNode.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.UsedUnitName;
+var
+ NamesNode, UnitNode: TSyntaxNode;
+ Position: TTokenPoint;
+ FileName: string;
+ LineSeq: Integer;
+begin
+ LineSeq := Lexer.PosXY.LineSeq;
+ Position := Lexer.PosXY;
+ FileName := Lexer.FileName;
+
+ NamesNode := TSyntaxNode.Create(ntUnit);
+ try
+ FStack.Push(NamesNode);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+
+ UnitNode := FStack.AddChild(ntUnit);
+ UnitNode.SetAttribute(anName, NodeListToString(NamesNode));
+ UnitNode.Col := Position.X;
+ UnitNode.Line := Position.Y;
+ UnitNode.FileName := FileName;
+ UnitNode.LineSeq := LineSeq;
+ finally
+ NamesNode.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.UsesClause;
+begin
+ FStack.PushCompoundSyntaxNode(ntUses);
+ try
+ inherited;
+ SetCurrentCompoundNodesEndPosition;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VarAbsolute;
+begin
+ FStack.Push(ntAbsolute);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VarDeclaration;
+begin
+ FStack.Push(ntVariables);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VarName;
+begin
+ FStack.AddValuedChild(ntName, Lexer.Token);
+ inherited;
+end;
+
+procedure TPasSyntaxTreeBuilder.VarParameter;
+begin
+ FStack.Push(ntParameters).SetAttribute(anKind, AttributeValues[atVar]);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VarSection;
+var
+ VarSect: TSyntaxNode;
+begin
+ VarSect := TSyntaxNode.Create(ntUnknown);
+ try
+ FStack.Push(ntVariables);
+
+ FStack.Push(VarSect);
+ try
+ inherited VarSection;
+ finally
+ FStack.Pop;
+ end;
+
+ RearrangeVarSection(VarSect);
+ FStack.Pop;
+ finally
+ VarSect.Free;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.RearrangeVarSection(const VarSect: TSyntaxNode);
+var
+ Temp: TSyntaxNode;
+ VarList, Variable, TypeInfo, ValueInfo: TSyntaxNode;
+begin
+ for VarList in VarSect.ChildNodes do
+ begin
+ TypeInfo := VarList.FindNode(ntType);
+ ValueInfo := VarList.FindNode(ntValue);
+ for Variable in VarList.ChildNodes do
+ begin
+ if Variable.Typ <> ntName then
+ Continue;
+ Temp := FStack.Push(ntVariable);
+ try
+ Temp.AssignPositionFrom(Variable);
+ FStack.AddChild(Variable.Clone);
+ if Assigned(TypeInfo) then
+ FStack.AddChild(TypeInfo.Clone);
+ if Assigned(ValueInfo) then
+ FStack.AddChild(ValueInfo.Clone)
+ else
+ begin
+ Temp := VarList.FindNode([ntAbsolute, ntValue, ntExpression, ntIdentifier]);
+ if Assigned(Temp) then
+ FStack.AddChild(ntAbsolute).AddChild(Temp.Clone);
+ end;
+ finally
+ FStack.Pop;
+ end;
+ end;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VisibilityStrictPrivate;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Push(ntStrictPrivate);
+ try
+ Temp.SetAttribute(anVisibility, AttributeValues[atTrue]);
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VisibilityPrivate;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Push(ntPrivate);
+ try
+ Temp.SetAttribute(anVisibility, AttributeValues[atTrue]);
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VisibilityStrictProtected;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Push(ntStrictProtected);
+ try
+ Temp.SetAttribute(anVisibility, AttributeValues[atTrue]);
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VisibilityProtected;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Push(ntProtected);
+ try
+ Temp.SetAttribute(anVisibility, AttributeValues[atTrue]);
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VisibilityPublic;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Push(ntPublic);
+ try
+ Temp.SetAttribute(anVisibility, AttributeValues[atTrue]);
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.VisibilityPublished;
+var
+ Temp: TSyntaxNode;
+begin
+ Temp := FStack.Push(ntPublished);
+ try
+ Temp.SetAttribute(anVisibility, AttributeValues[atTrue]);
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.WhileStatement;
+begin
+ FStack.Push(ntWhile);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.WithExpressionList;
+begin
+ FStack.Push(ntExpressions);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+procedure TPasSyntaxTreeBuilder.WithStatement;
+begin
+ FStack.Push(ntWith);
+ try
+ inherited;
+ finally
+ FStack.Pop;
+ end;
+end;
+
+{ ESyntaxTreeException }
+
+constructor ESyntaxTreeException.Create(Line, Col: Integer; const FileName, Msg: string;
+ SyntaxTree: TSyntaxNode);
+begin
+ inherited Create(Line, Col, FileName, Msg);
+ FSyntaxTree := SyntaxTree;
+end;
+
+destructor ESyntaxTreeException.Destroy;
+begin
+ FSyntaxTree.Free;
+ inherited;
+end;
+
+initialization
+ InitAttributeValues;
+
+end.
\ No newline at end of file
diff --git a/References/DelphiAST/Source/FreePascalSupport/Diagnostics.pas b/References/DelphiAST/Source/FreePascalSupport/Diagnostics.pas
new file mode 100644
index 000000000..a5356b67a
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Diagnostics.pas
@@ -0,0 +1,204 @@
+{$IFDEF FPC}
+ {$mode objfpc}{$H+}
+ {$modeswitch advancedrecords}
+{$ENDIF}
+
+{$IFDEF MSWINDOWS}
+ {$IFNDEF WINDOWS}
+ {$DEFINE WINDOWS}
+ {$ENDIF WINDOWS}
+{$ENDIF MSWINDOWS}
+
+unit Diagnostics;
+
+interface
+uses
+ SysUtils
+ {$IFDEF LINUX}
+ ,unixtype, linux
+ {$ENDIF LINUX}
+ ;
+
+type
+
+ { TStopWatch }
+
+ TStopWatch = record
+ private
+ const
+ C_THOUSAND = 1000;
+ C_MILLION = C_THOUSAND * C_THOUSAND;
+ C_BILLION = C_THOUSAND * C_THOUSAND * C_THOUSAND;
+ {$IFDEF WINDOWS}
+ TicksPerMillisecond = 10000;
+ TicksPerSecond = 10000000;
+ {$ELSE}
+ TicksPerNanoSecond = 100;
+ TicksPerMilliSecond = 10000;
+ TicksPerSecond = C_BILLION div 100;
+ {$ENDIF}
+ Type
+ TBaseMesure =
+ {$IFDEF WINDOWS}
+ Int64;
+ {$ENDIF WINDOWS}
+ {$IFDEF LINUX}
+ TTimeSpec;
+ {$ENDIF LINUX}
+ strict private
+ class var FFrequency : Int64;
+ class var FIsHighResolution : Boolean;
+ class var TickFrequency: Double;
+ strict private
+ FElapsed : Int64;
+ FRunning : Boolean;
+ FStartPosition : TBaseMesure;
+ strict private
+ procedure CheckInitialization();inline;
+ function GetElapsedMilliseconds: Int64;
+ function GetElapsedTicks: Int64;
+ public
+ class function Create() : TStopWatch;static;
+ class function StartNew() : TStopWatch;static;
+ {$IFDEF WINDOWS}class function GetTimeStamp: Int64;static;{$ENDIF}
+ class property Frequency : Int64 read FFrequency;
+ class property IsHighResolution : Boolean read FIsHighResolution;
+ procedure Reset();
+ procedure Start();
+ procedure Stop();
+ property ElapsedMilliseconds : Int64 read GetElapsedMilliseconds;
+ property ElapsedTicks : Int64 read GetElapsedTicks;
+ property IsRunning : Boolean read FRunning;
+ end;
+
+resourcestring
+ sStopWatchNotInitialized = 'The StopWatch is not initialized.';
+
+implementation
+{$IFDEF WINDOWS}
+uses
+ Windows;
+{$ENDIF WINDOWS}
+
+{ TStopWatch }
+
+class function TStopWatch.Create(): TStopWatch;
+{$IFDEF LINUX}
+var
+ r : TBaseMesure;
+{$ENDIF LINUX}
+begin
+ if (FFrequency = 0) then begin
+{$IFDEF WINDOWS}
+ FIsHighResolution := QueryPerformanceFrequency(FFrequency);
+ if FIsHighResolution then begin
+ TickFrequency := 10000000 / FFrequency;
+ end else begin
+ FFrequency := TicksPerSecond;
+ TickFrequency := 1;
+ end;
+{$ENDIF WINDOWS}
+{$IFDEF LINUX}
+ FIsHighResolution := (clock_getres(CLOCK_MONOTONIC,@r) = 0);
+ FIsHighResolution := FIsHighResolution and (r.tv_nsec <> 0);
+ if (r.tv_nsec <> 0) then
+ FFrequency := C_BILLION div r.tv_nsec;
+{$ENDIF LINUX}
+ end;
+ FillChar(Result,SizeOf(Result),0);
+end;
+
+class function TStopWatch.StartNew() : TStopWatch;
+begin
+ Result := TStopWatch.Create();
+ Result.Start();
+end;
+
+procedure TStopWatch.CheckInitialization();
+begin
+ if (FFrequency = 0) then
+ raise Exception.Create(sStopWatchNotInitialized);
+end;
+
+function TStopWatch.GetElapsedMilliseconds: Int64;
+begin
+ {$IFDEF WINDOWS}
+ Result := ElapsedTicks;
+ if FIsHighResolution then
+ Result := Trunc(Result * TickFrequency);
+
+ Result := Result div TicksPerMillisecond;
+ {$ENDIF WINDOWS}
+ {$IFDEF LINUX}
+ Result := FElapsed div C_MILLION;
+ {$ENDIF LINUX}
+end;
+
+function TStopWatch.GetElapsedTicks: Int64;
+begin
+ CheckInitialization();
+{$IFDEF WINDOWS}
+ Result := FElapsed;
+ if FRunning then
+ Result := Result + GetTimeStamp - FStartPosition;
+{$ENDIF WINDOWS}
+{$IFDEF LINUX}
+ Result := FElapsed div TicksPerNanoSecond;
+{$ENDIF LINUX}
+end;
+
+procedure TStopWatch.Reset();
+begin
+ Stop();
+ FElapsed := 0;
+ FillChar(FStartPosition,SizeOf(FStartPosition),0);
+end;
+
+procedure TStopWatch.Start();
+begin
+ if FRunning then
+ exit;
+ FRunning := True;
+{$IFDEF WINDOWS}
+ FStartPosition := GetTimeStamp;
+{$ENDIF WINDOWS}
+{$IFDEF LINUX}
+ clock_gettime(CLOCK_MONOTONIC,@FStartPosition);
+{$ENDIF LINUX}
+end;
+
+procedure TStopWatch.Stop();
+var
+ locEnd : TBaseMesure;
+ s, n : Int64;
+begin
+ if not FRunning then
+ exit;
+ FRunning := False;
+{$IFDEF WINDOWS}
+ FElapsed := FElapsed + GetTimeStamp - FStartPosition;
+{$ENDIF WINDOWS}
+{$IFDEF LINUX}
+ clock_gettime(CLOCK_MONOTONIC,@locEnd);
+ if (locEnd.tv_nsec < FStartPosition.tv_nsec) then begin
+ s := locEnd.tv_sec - FStartPosition.tv_sec - 1;
+ n := C_BILLION + locEnd.tv_nsec - FStartPosition.tv_nsec;
+ end else begin
+ s := locEnd.tv_sec - FStartPosition.tv_sec;
+ n := locEnd.tv_nsec - FStartPosition.tv_nsec;
+ end;
+ FElapsed := FElapsed + (s * C_BILLION) + n;
+{$ENDIF LINUX}
+end;
+
+{$IFDEF WINDOWS}
+class function TStopwatch.GetTimeStamp: Int64;
+begin
+ if FIsHighResolution then
+ QueryPerformanceCounter(Result)
+ else
+ Result := GetTickCount * TicksPerMillisecond;
+end;
+{$ENDIF}
+
+end.
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/.gitignore b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/.gitignore
new file mode 100644
index 000000000..420520be3
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/.gitignore
@@ -0,0 +1,3 @@
+compiled_junk/
+/Compiled
+*.lps
\ No newline at end of file
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/FPC_StringBuilder.lpk b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/FPC_StringBuilder.lpk
new file mode 100644
index 000000000..05393cf54
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/FPC_StringBuilder.lpk
@@ -0,0 +1,39 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/FPC_StringBuilder.pas b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/FPC_StringBuilder.pas
new file mode 100644
index 000000000..72cedea35
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/FPC_StringBuilder.pas
@@ -0,0 +1,20 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit FPC_StringBuilder;
+
+interface
+
+uses
+ StringBuilderUnit, LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+end;
+
+initialization
+ RegisterPackage('FPC_StringBuilder', @Register);
+end.
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.o b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.o
new file mode 100644
index 000000000..6d59c6ab8
Binary files /dev/null and b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.o differ
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.pas b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.pas
new file mode 100644
index 000000000..e526b02af
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.pas
@@ -0,0 +1,171 @@
+unit StringBuilderUnit;
+
+interface
+
+const
+ StringBuilderMemoryBlockLength = 1000;
+
+type
+ PStringBuilderMemoryBlock = ^TStringBuilderMemoryBlock;
+ TStringBuilderMemoryBlock = record
+ Data: array[0..StringBuilderMemoryBlockLength - 1] of byte;
+ Count: Cardinal;
+ Next: PStringBuilderMemoryBlock;
+ end;
+
+ { TStringBuilder }
+
+ TStringBuilder = class
+ protected
+ FHead, FTail: PStringBuilderMemoryBlock;
+ FTotalLength: Cardinal;
+ function Min(const a, b: Cardinal): Cardinal;
+ public
+ property Head: PStringBuilderMemoryBlock read FHead;
+ property Tail: PStringBuilderMemoryBlock read FTail;
+ property TotalLength: Cardinal read FTotalLength;
+ constructor Create;
+ procedure Add(const aString: string); overload;
+ procedure Add(const aStrings: array of string); overload;
+ procedure Append(const aString: string);
+ procedure AppendLine;
+ function ToString: string;
+ procedure Clean;
+ destructor Destroy; override;
+ end;
+
+implementation
+
+function CreateNewBlock: PStringBuilderMemoryBlock;
+begin
+ New(result);
+ result^.Count := 0;
+ result^.Next := nil;
+end;
+
+{ TStringBuilder }
+
+function TStringBuilder.Min(const a, b: Cardinal): Cardinal;
+begin
+ if
+ a < b
+ then
+ result := a
+ else
+ result := b;
+end;
+
+constructor TStringBuilder.Create;
+begin
+ FHead := nil;
+ FTail := nil;
+ FTotalLength := 0;
+end;
+
+procedure TStringBuilder.Add(const aString: string);
+var
+ bytesLeftInString, bytesToWriteInCurrentBlock, bytesLeftInTailBlock: Cardinal;
+ positionInString: PChar;
+begin
+ if
+ nil = Head
+ then
+ begin
+ FHead := CreateNewBlock;
+ FTail := Head;
+ end;
+ bytesLeftInString := Length(aString);
+ Inc(FTotalLength, bytesLeftInString);
+ positionInString := PChar(aString);
+ while
+ bytesLeftInString > 0
+ do
+ begin
+ bytesLeftInTailBlock := StringBuilderMemoryBlockLength - Tail^.Count;
+ bytesToWriteInCurrentBlock := Min(bytesLeftInString, bytesLeftInTailBlock);
+ Move(positionInString^, Tail^.Data[Tail^.Count], bytesToWriteInCurrentBlock);
+ Inc(Tail^.Count, bytesToWriteInCurrentBlock);
+ Dec(bytesLeftInString, bytesToWriteInCurrentBlock);
+ Inc(positionInString, bytesToWriteInCurrentBlock);
+ if
+ bytesLeftInString > 0
+ then
+ begin
+ Tail^.Next := CreateNewBlock;
+ FTail := Tail^.Next;
+ end;
+ end;
+end;
+
+procedure TStringBuilder.Add(const aStrings: array of string);
+var
+ i: Cardinal;
+begin
+ for i := 0 to Length(aStrings) - 1 do
+ Add(aStrings[i]);
+end;
+
+procedure TStringBuilder.Append(const aString: string);
+begin
+ Add(aString);
+end;
+
+procedure TStringBuilder.AppendLine;
+begin
+ Add(#13#10);
+end;
+
+function TStringBuilder.ToString: string;
+var
+ currentBlock: PStringBuilderMemoryBlock;
+ currentCount: Cardinal;
+ currentResultPosition: PChar;
+begin
+ if
+ Head <> nil
+ then
+ begin
+ SetLength(result, Totallength);
+ currentResultPosition := PChar(result);
+ currentBlock := Head;
+ while
+ currentBlock <> nil
+ do
+ begin
+ currentCount := currentBlock^.Count;
+ Move(currentBlock^.Data[0], currentResultPosition^, currentCount);
+ Inc(currentResultPosition, currentCount);
+ currentBlock := currentBlock^.Next;
+ end;
+ currentResultPosition^ := #0;
+ end
+ else
+ result := '';
+end;
+
+procedure TStringBuilder.Clean;
+var
+ current, next: PStringBuilderMemoryBlock;
+begin
+ current := Head;
+ while
+ current <> nil
+ do
+ begin
+ next := current^.Next;
+ Dispose(current);
+ current := next;
+ end;
+ FHead := nil;
+ FTail := nil;
+ FTotalLength := 0;
+end;
+
+destructor TStringBuilder.Destroy;
+begin
+ Clean;
+ inherited Destroy;
+end;
+
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.ppu b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.ppu
new file mode 100644
index 000000000..85f532be2
Binary files /dev/null and b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.ppu differ
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_001/Test_001.lpi b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_001/Test_001.lpi
new file mode 100644
index 000000000..a71c363bd
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_001/Test_001.lpi
@@ -0,0 +1,82 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_001/Test_001.lpr b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_001/Test_001.lpr
new file mode 100644
index 000000000..bf7f8d18c
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_001/Test_001.lpr
@@ -0,0 +1,20 @@
+program Test_001;
+
+uses
+ StringBuilderUnit;
+
+var
+ s: TStringBuilder;
+
+begin
+ s := TStringBuilder.Create;
+ s.Add('Foo');
+ s.Add(' ');
+ s.Add('Bar');
+ s.Clean;
+ s.Add('FFFUUU');
+ s.Add('
');
+ WriteLN('"', s.ToString, '"');
+ s.Free;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_002_Performance/Test_002.lpi b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_002_Performance/Test_002.lpi
new file mode 100644
index 000000000..5e39bebb5
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_002_Performance/Test_002.lpi
@@ -0,0 +1,87 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_002_Performance/Test_002.lpr b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_002_Performance/Test_002.lpr
new file mode 100644
index 000000000..bb18ba70e
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_002_Performance/Test_002.lpr
@@ -0,0 +1,70 @@
+program Test_002;
+
+uses
+ SysUtils,
+ StringBuilderUnit;
+
+const
+ TestString = 'TestString';
+ CountOfTestString = 1013;
+ CountOfTests = 10000;
+
+procedure TestWithConcat;
+var
+ time: TDateTime;
+ testIndex, i: Cardinal;
+ s: string;
+begin
+ WriteLN('Now testing concat...');
+ time := Now;
+ for testIndex := 1 to CountOfTests do
+ begin
+ s := '';
+ for i := 1 to CountOfTestString do
+ s := s + TestString;
+ end;
+ time := Now - time;
+ WriteLN(FormatDateTime('hh:nn:ss.zzz', time));
+end;
+
+{ $Define EnableIntegrityCheck}
+
+procedure TestWithBuilder;
+var
+ time: TDateTime;
+ testIndex, i: Cardinal;
+ resultValid, allValid: Boolean;
+ builder: TStringBuilder;
+ s: string;
+begin
+ WriteLN('Now testing concat...');
+ time := Now;
+ allValid := True;
+ for testIndex := 1 to CountOfTests do
+ begin
+ builder := TStringBuilder.Create;
+ for i := 1 to CountOfTestString do
+ builder.Add(TestString);
+ s := builder.ToString;
+ builder.Free;
+ // integrity check below:
+ {$IfDef EnableIntegrityCheck}
+ resultValid := True;
+ for i := 1 to Length(s) do
+ if s[i] <> TestString[(i - 1) mod Length(TestString) + 1] then
+ resultValid := False;
+ allValid := allValid and resultValid;
+ {$EndIf}
+ end;
+ time := Now - time;
+ {$IfDef EnableIntegrityCheck}
+ WriteLN('All strings are valid: ', allValid);
+ {$EndIf}
+ WriteLN(FormatDateTime('hh:nn:ss.zzz', time));
+end;
+
+begin
+ TestWithConcat;
+ TestWithBuilder;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/README.md b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/README.md
new file mode 100644
index 000000000..c7e5ed471
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/README.md
@@ -0,0 +1,2 @@
+# generics.collections
+FreePascal Generics.Collections library (TList, TDictionary, THashMap and more...)
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArrayDouble/TArrayProjectDouble.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArrayDouble/TArrayProjectDouble.lpi
new file mode 100644
index 000000000..44825e2b3
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArrayDouble/TArrayProjectDouble.lpi
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArrayDouble/TArrayProjectDouble.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArrayDouble/TArrayProjectDouble.lpr
new file mode 100644
index 000000000..8ed5c2bf4
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArrayDouble/TArrayProjectDouble.lpr
@@ -0,0 +1,91 @@
+// Generic types for FreeSparta.com and FreePascal!
+// Original version by keeper89.blogspot.com, 2011
+// FPC version by Maciej Izak (hnb), 2014
+
+program TArrayProjectDouble;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils, Math, Types, Generics.Collections, Generics.Defaults;
+
+type
+ TDoubleIntegerArray = array of TIntegerDynArray;
+
+procedure PrintMatrix(A: TDoubleIntegerArray);
+var
+ i, j: Integer;
+begin
+ for i := Low(A) to High(A) do
+ begin
+ for j := Low(A[0]) to High(A[0]) do
+ Write(A[i, j]: 3, ' ');
+ Writeln;
+ end;
+ Writeln; Writeln;
+end;
+
+function CustomCompare_1(constref Left, Right: TIntegerDynArray): Integer;
+begin
+ Result := TCompare.Integer(Right[0], Left[0]);
+end;
+
+function CustomCompare_2(constref Left, Right: TIntegerDynArray): Integer;
+var
+ i: Integer;
+begin
+ i := 0;
+ repeat
+ Result := TCompare.Integer(Right[i], Left[i]);
+ Inc(i);
+ until ((Result <> 0) or (i = Length(Left)));
+end;
+
+var
+ A: TDoubleIntegerArray;
+ FoundIndex: Integer;
+ i, j: Integer;
+
+begin
+ WriteLn('Working with TArray - a two-dimensional integer array');
+ WriteLn;
+
+ // Fill integer array with random numbers [1 .. 50]
+ SetLength(A, 4, 7);
+ Randomize;
+ for i := Low(A) to High(A) do
+ for j := Low(A[0]) to High(A[0]) do
+ A[i, j] := Math.RandomRange(1, 50);
+
+ // Equate some of the elements for further "cascade" sorting
+ A[1, 0] := A[0, 0];
+ A[2, 0] := A[0, 0];
+ A[1, 1] := A[0, 1];
+
+ // Print out what happened
+ Writeln('The original array:');
+ PrintMatrix(A);
+
+ // ! FPC don't support anonymous methods yet
+ //TArray.Sort(A, TComparer.Construct(
+ // function (const Left, Right: TIntegerDynArray): Integer
+ // begin
+ // Result := Right[0] - Left[0];
+ // end));
+ // Sort descending 1st column, with cutom comparer_1
+ TArrayHelper.Sort(A, TComparer.Construct(
+ CustomCompare_1));
+ Writeln('Descending in column 1:');
+ PrintMatrix(A);
+
+ // Sort descending 1st column "cascade" -
+ // If the line items are equal, compare neighboring
+ TArrayHelper.Sort(A, TComparer.Construct(
+ CustomCompare_2));
+ Writeln('Cascade sorting, starting from the 1st column:');
+ PrintMatrix(A);
+
+ Readln;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArraySingle/TArrayProjectSingle.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArraySingle/TArrayProjectSingle.lpi
new file mode 100644
index 000000000..0793ea1d1
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArraySingle/TArrayProjectSingle.lpi
@@ -0,0 +1,78 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArraySingle/TArrayProjectSingle.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArraySingle/TArrayProjectSingle.lpr
new file mode 100644
index 000000000..49bec2cfc
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArraySingle/TArrayProjectSingle.lpr
@@ -0,0 +1,111 @@
+// Generic types for FreeSparta.com and FreePascal!
+// Original version by keeper89.blogspot.com, 2011
+// FPC version by Maciej Izak (hnb), 2014
+
+program TArrayProjectSingle;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils, Math, Types, Generics.Collections, Generics.Defaults;
+
+function CompareIntReverse(constref Left, Right: Integer): Integer;
+begin
+ Result := TCompare.Integer(Right, Left);
+end;
+
+type
+ TForCompare = class
+ public
+ function CompareIntReverseMethod(constref Left, Right: Integer): Integer;
+ end;
+
+function TForCompare.CompareIntReverseMethod(constref Left, Right: Integer): Integer;
+begin
+ Result := TCompare.Integer(Right, Left);
+end;
+
+procedure PrintMatrix(A: TIntegerDynArray);
+var
+ item: Integer;
+begin
+ for item in A do
+ Write(item, ' ');
+ Writeln; Writeln;
+end;
+
+var
+ A: TIntegerDynArray;
+ FoundIndex: PtrInt;
+ ForCompareObj: TForCompare;
+begin
+ WriteLn('Working with TArray - one-dimensional integer array');
+ WriteLn;
+
+ // Fill a one-dimensional array of integers by random numbers [1 .. 10]
+ A := TIntegerDynArray.Create(1, 6, 3, 2, 9);
+
+ // Print out what happened
+ Writeln('The original array:');
+ PrintMatrix(A);
+
+ // Sort ascending without comparator
+ TArrayHelper.Sort(A);
+ Writeln('Ascending Sort without parameters:');
+ PrintMatrix(A);
+
+ // ! FPC don't support anonymous methods yet
+ // Sort descending, the comparator is constructed
+ // using an anonymous method
+ //TArray.Sort(A, TComparer.Construct(
+ // function (const Left, Right: Integer): Integer
+ // begin
+ // Result := Math.CompareValue(Right, Left)
+ // end));
+
+ // Sort descending, the comparator is constructed
+ // using an method
+ TArrayHelper.Sort(A, TComparer.Construct(
+ ForCompareObj.CompareIntReverseMethod));
+ Writeln('Descending by TComparer.Construct(ForCompareObj.Method):');
+ PrintMatrix(A);
+
+ // Again sort ascending by using defaul
+ TArrayHelper.Sort(A, TComparer.Default);
+ Writeln('Ascending by TComparer.Default:');
+ PrintMatrix(A);
+
+ // Again descending using own comparator function
+ TArrayHelper.Sort(A, TComparer.Construct(CompareIntReverse));
+ Writeln('Descending by TComparer.Construct(CompareIntReverse):');
+ PrintMatrix(A);
+
+ // Searches for a nonexistent element
+ Writeln('BinarySearch nonexistent element');
+ if TArrayHelper.BinarySearch(A, 5, FoundIndex) then
+ Writeln('5 is found, its index ', FoundIndex)
+ else
+ Writeln('5 not found!');
+ Writeln;
+
+ // Search for an existing item with default comparer
+ Writeln('BinarySearch for an existing item ');
+ if TArrayHelper.BinarySearch(A, 6, FoundIndex) then
+ Writeln('6 is found, its index ', FoundIndex)
+ else
+ Writeln('6 not found!');
+ Writeln;
+
+ // Search for an existing item with custom comparer
+ Writeln('BinarySearch for an existing item with custom comparer');
+ if TArrayHelper.BinarySearch(A, 6, FoundIndex,
+ TComparer.Construct(CompareIntReverse)) then
+ Writeln('6 is found, its index ', FoundIndex)
+ else
+ Writeln('6 not found!');
+ Writeln;
+
+ Readln;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TComparer/TComparerProject.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TComparer/TComparerProject.lpi
new file mode 100644
index 000000000..fe598a93f
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TComparer/TComparerProject.lpi
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TComparer/TComparerProject.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TComparer/TComparerProject.lpr
new file mode 100644
index 000000000..b7c12823a
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TComparer/TComparerProject.lpr
@@ -0,0 +1,124 @@
+// Generic types for FreeSparta.com and FreePascal!
+// by Maciej Izak (hnb), 2014
+
+program TComparerProject;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils, Generics.Collections, Generics.Defaults;
+
+type
+
+ { TCustomer }
+
+ TCustomer = record
+ private
+ FName: string;
+ FMoney: Currency;
+ public
+ constructor Create(const Name: string; Money: Currency);
+ property Name: string read FName write FName;
+ property Money: Currency read FMoney write FMoney;
+ function ToString: string;
+ end;
+
+ TCustomerComparer = class(TComparer)
+ function Compare(constref Left, Right: TCustomer): Integer; override;
+ end;
+
+{ TCustomer }
+
+constructor TCustomer.Create(const Name: string; Money: Currency);
+begin
+ FName := Name;
+ FMoney := Money;
+end;
+
+function TCustomer.ToString: string;
+begin
+ Result := Format('Name: %s >>> Money: %m', [Name, Money]);
+end;
+
+// Ascending
+function TCustomerComparer.Compare(constref Left, Right: TCustomer): Integer;
+begin
+ Result := TCompare.&String(Left.Name, Right.Name);
+ if Result = 0 then
+ Result := TCompare.Currency(Left.Money, Right.Money);
+end;
+
+// Descending
+function CustomerCompare(constref Left, Right: TCustomer): Integer;
+begin
+ Result := TCompare.&String(Right.Name, Left.Name);
+ if Result = 0 then
+ Result := TCompare.Currency(Right.Money, Left.Money);
+end;
+
+var
+ CustomersArray: TArray;
+ CustomersList: TList;
+ Comparer: TCustomerComparer;
+ Customer: TCustomer;
+begin
+ CustomersArray := TArray.Create(
+ TCustomer.Create('Derp', 2000),
+ TCustomer.Create('Sheikh', 2000000000),
+ TCustomer.Create('Derp', 1000),
+ TCustomer.Create('Bill Gates', 1000000000));
+
+ Comparer := TCustomerComparer.Create;
+ Comparer._AddRef;
+
+ // create TList with custom comparer
+ CustomersList := TList.Create(Comparer);
+ CustomersList.AddRange(CustomersArray);
+
+ WriteLn('CustomersList before sort:');
+ for Customer in CustomersList do
+ WriteLn(Customer.ToString);
+ WriteLn;
+
+ // default sort
+ CustomersList.Sort; // will use TCustomerComparer (passed in the constructor)
+ WriteLn('CustomersList after ascending sort (default with interface from constructor):');
+ for Customer in CustomersList do
+ WriteLn(Customer.ToString);
+ WriteLn;
+
+ // construct with simple function
+ CustomersList.Sort(TComparer.Construct(CustomerCompare));
+ WriteLn('CustomersList after descending sort (by using construct with function)');
+ WriteLn('CustomersList.Sort(TComparer.Construct(CustomerCompare)):');
+ for Customer in CustomersList do
+ WriteLn(Customer.ToString);
+ WriteLn;
+
+ // construct with method
+ CustomersList.Sort(TComparer.Construct(Comparer.Compare));
+ WriteLn('CustomersList after ascending sort (by using construct with method)');
+ WriteLn('CustomersList.Sort(TComparer.Construct(Comparer.Compare)):');
+ for Customer in CustomersList do
+ WriteLn(Customer.ToString);
+ WriteLn;
+
+ WriteLn('CustomersArray before sort:');
+ for Customer in CustomersArray do
+ WriteLn(Customer.ToString);
+ WriteLn;
+
+ // sort with interface
+ TArrayHelper.Sort(CustomersArray, TCustomerComparer.Create);
+ WriteLn('CustomersArray after ascending sort (by using interfese - no construct)');
+ WriteLn('TArrayHelper.Sort(CustomersArray, TCustomerComparer.Create):');
+ for Customer in CustomersArray do
+ WriteLn(Customer.ToString);
+ WriteLn;
+
+ CustomersList.Free;
+ Comparer._Release;
+ ReadLn;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMap/THashMapProject.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMap/THashMapProject.lpi
new file mode 100644
index 000000000..87cfc4525
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMap/THashMapProject.lpi
@@ -0,0 +1,78 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMap/THashMapProject.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMap/THashMapProject.lpr
new file mode 100644
index 000000000..d9598cab9
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMap/THashMapProject.lpr
@@ -0,0 +1,218 @@
+// Generic types for FreeSparta.com and FreePascal!
+// Original version by keeper89.blogspot.com, 2011
+// FPC version by Maciej Izak (hnb), 2014
+
+program THashMapProject;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils, Generics.Collections, Generics.Defaults;
+
+type
+ TSubscriberInfo = record
+ Name, SName: string;
+ class function Create(const Name, SName: string): TSubscriberInfo; static;
+ function ToString: string;
+ end;
+
+ // Class containing handlers add / remove items in the dictionary
+ THashMapEventsHandler = class
+ public
+ class procedure OnKeyNotify(Sender: TObject; constref Item: string;
+ Action: TCollectionNotification);
+ class procedure OnValueNotify(Sender: TObject; constref Item: TSubscriberInfo;
+ Action: TCollectionNotification);
+ end;
+
+class function TSubscriberInfo.Create(const Name,
+ SName: string): TSubscriberInfo;
+begin
+ Result.Name := Name;
+ Result.SName := SName;
+end;
+
+function TSubscriberInfo.ToString: string;
+begin
+ Result := Format('%s %s', [Name, SName]);
+end;
+
+// Function to generate the dictionary contents into a string
+function PrintTelephoneDirectory(
+ TelephoneDirectory: THashMap): string;
+var
+ PhoneNumber: string;
+begin
+ Result := Format('Content directory (%d):', [TelephoneDirectory.Count]);
+
+ for PhoneNumber in TelephoneDirectory.Keys do
+ Result := Result + Format(LineEnding + '%s: %s',
+ [PhoneNumber, TelephoneDirectory[PhoneNumber].ToString]);
+end;
+
+// Handlers add / remove items dictionary
+class procedure THashMapEventsHandler.OnKeyNotify(Sender: TObject;
+ constref Item: string; Action: TCollectionNotification);
+begin
+ case Action of
+ cnAdded:
+ Writeln(Format('OnKeyNotify! Phone %s added!', [Item]));
+ cnRemoved:
+ Writeln(Format('OnKeyNotify! Number %s deleted!', [Item]));
+ end;
+end;
+
+class procedure THashMapEventsHandler.OnValueNotify(Sender: TObject;
+ constref Item: TSubscriberInfo; Action: TCollectionNotification);
+begin
+ case Action of
+ cnAdded:
+ Writeln(Format('OnValueNotify! Subscriber %s added!', [Item.ToString]));
+ cnRemoved:
+ Writeln(Format('OnValueNotify! Subscriber %s deleted!', [Item.ToString]));
+ end;
+end;
+
+function CustomCompare(constref Left, Right: TPair): Integer;
+begin
+ // Comparable full first names, and then phones if necessary
+ Result := TCompare.&String(Left.Value.ToString, Right.Value.ToString);
+ if Result = 0 then
+ Result := TCompare.&String(Left.Key, Right.Key);
+end;
+
+var
+ // Declare the "dictionary"
+ // key is the telephone number which will be possible
+ // to determine information about the owner
+ TelephoneDirectory: THashMap;
+ TTelephoneArray: array of TPair;
+ TTelephoneArrayItem: TPair;
+ PhoneNumber: string;
+ Subscriber: TSubscriberInfo;
+begin
+ WriteLn('Working with THashMap - phonebook');
+ WriteLn;
+
+ // create a directory
+ // Constructor has several overloaded options which will
+ // enable the capacity of the container, a comparator for values
+ // or the initial data - we use the easiest option
+ TelephoneDirectory := THashMap.Create;
+
+ // ---------------------------------------------------
+ // 1) Adding items to dictionary
+
+ // Add new users to the phonebook
+ TelephoneDirectory.Add('9201111111', TSubscriberInfo.Create('Arnold', 'Schwarzenegger'));
+ TelephoneDirectory.Add('9202222222', TSubscriberInfo.Create('Jessica', 'Alba'));
+ TelephoneDirectory.Add('9203333333', TSubscriberInfo.Create('Brad', 'Pitt'));
+ TelephoneDirectory.Add('9204444444', TSubscriberInfo.Create('Brad', 'Pitt'));
+ TelephoneDirectory.Add('9205555555', TSubscriberInfo.Create('Sandra', 'Bullock'));
+ // Adding a new subscriber if number already exist
+ TelephoneDirectory.AddOrSetValue('9204444444',
+ TSubscriberInfo.Create('Angelina', 'Jolie'));
+ // Print list
+ Writeln(PrintTelephoneDirectory(TelephoneDirectory));
+
+ // ---------------------------------------------------
+ // 2) Working with the elements
+
+ // Set the "capacity" of the dictionary according to the current number of elements
+ TelephoneDirectory.TrimExcess;
+ // Is there a key? - ContainsKey
+ if TelephoneDirectory.ContainsKey('9205555555') then
+ Writeln('Phone 9205555555 registered!');
+ // Is there a subscriber? - ContainsValue
+ Subscriber := TSubscriberInfo.Create('Sandra', 'Bullock');
+ if TelephoneDirectory.ContainsValue(Subscriber) then
+ Writeln(Format('%s is in the directory!', [Subscriber.ToString]));
+ // Try to get information via telephone. TryGetValue
+ if TelephoneDirectory.TryGetValue('9204444444', Subscriber) then
+ Writeln(Format('Number 9204444444 belongs to %s', [Subscriber.ToString]));
+ // Directly access by phone number
+ Writeln(Format('Phone 9201111111 subscribers: %s', [TelephoneDirectory['9201111111'].ToString]));
+ // Number of people in the directory
+ Writeln(Format('Total subscribers in the directory: %d', [TelephoneDirectory.Count]));
+
+ // ---------------------------------------------------
+ // 3) Delete items
+
+ // Schwarzenegger now will not be listed
+ TelephoneDirectory.Remove('9201111111');
+ // Completely clear the list
+ TelephoneDirectory.Clear;
+
+ // ---------------------------------------------------
+ // 4) Events add / remove values
+ //
+ // Events OnKeyNotify OnValueNotify are designed for "tracking"
+ // for adding / removing keys and values ​​respectively
+ TelephoneDirectory.OnKeyNotify := THashMapEventsHandler.OnKeyNotify;
+ TelephoneDirectory.OnValueNotify := THashMapEventsHandler.OnValueNotify;
+
+ Writeln;
+ // Try events
+ TelephoneDirectory.Add('9201111111', TSubscriberInfo.Create('Arnold', 'Schwarzenegger'));
+ TelephoneDirectory.Add('9202222222', TSubscriberInfo.Create('Jessica', 'Alba'));
+ TelephoneDirectory['9202222222'] := TSubscriberInfo.Create('Monica', 'Bellucci');
+ TelephoneDirectory.Clear;
+ WriteLn;
+
+ TelephoneDirectory.Add('9201111111', TSubscriberInfo.Create('Monica', 'Bellucci'));
+ TelephoneDirectory.Add('9202222222', TSubscriberInfo.Create('Sylvester', 'Stallone'));
+ TelephoneDirectory.Add('9203333333', TSubscriberInfo.Create('Bruce', 'Willis'));
+ WriteLn;
+
+ // Show keys (phones)
+ Writeln('Keys (phones):');
+ for PhoneNumber in TelephoneDirectory.Keys do
+ Writeln(PhoneNumber);
+ Writeln;
+
+ // Show values ​​(subscribers)
+ Writeln('Values (subscribers):');
+ for Subscriber in TelephoneDirectory.Values do
+ Writeln(Subscriber.ToString);
+ Writeln;
+
+ // All together now
+ Writeln('Subscribers list with phones:');
+ for PhoneNumber in TelephoneDirectory.Keys do
+ Writeln(Format('%s: %s',
+ [PhoneNumber, TelephoneDirectory[PhoneNumber].ToString]));
+ Writeln;
+
+ // In addition, we can "export" from the dictionary
+ // to TArray
+ // Sort the resulting array and display
+ TTelephoneArray := TelephoneDirectory.ToArray;
+
+ // partial specializations not allowed
+ // same for anonymous methods
+ //TArray.Sort>(
+ // TTelephoneArray, TComparer>.Construct(
+ // function (const Left, Right: TPair): Integer
+ // begin
+ // // Comparable full first names, and then phones if necessary
+ // Result := CompareStr(Left.Value.ToString, Right.Value.ToString);
+ // if Result = 0 then
+ // Result := CompareStr(Left.Key, Right.Key);
+ // end));
+
+ TArrayHelper.Sort(
+ TTelephoneArray, TComparer.Construct(
+ CustomCompare));
+ // Print
+ Writeln('Sorted list of subscribers into TArray (by name, and eventually by phone):');
+ for TTelephoneArrayItem in TTelephoneArray do
+ Writeln(Format('%s: %s',
+ [TTelephoneArrayItem.Value.ToString, TTelephoneArrayItem.Key]));
+
+ Writeln;
+ FreeAndNil(TelephoneDirectory);
+
+ Readln;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapCaseInsensitive/THashMapCaseInsensitive.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapCaseInsensitive/THashMapCaseInsensitive.lpi
new file mode 100644
index 000000000..097b7714e
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapCaseInsensitive/THashMapCaseInsensitive.lpi
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapCaseInsensitive/THashMapCaseInsensitive.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapCaseInsensitive/THashMapCaseInsensitive.lpr
new file mode 100644
index 000000000..377bd69c1
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapCaseInsensitive/THashMapCaseInsensitive.lpr
@@ -0,0 +1,55 @@
+// Generic types for FreeSparta.com and FreePascal!
+// by Maciej Izak (hnb), 2014
+
+program THashMapCaseInsensitive;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ Generics.Collections, Generics.Defaults;
+
+var
+ StringMap: THashMap;
+ AnsiStringMap: THashMap;
+ UnicodeStringMap: THashMap;
+ AdvancedHashMapWithBigLoadFactor: TCuckooD6;
+ k: String;
+begin
+ WriteLn('Working with case insensitive THashMap');
+ WriteLn;
+ // example constructors for different string types
+ StringMap := THashMap.Create(TIStringComparer.Ordinal);
+ StringMap.Free;
+ AnsiStringMap := THashMap.Create(TIAnsiStringComparer.Ordinal);
+ AnsiStringMap.Free;
+ UnicodeStringMap := THashMap.Create(TIUnicodeStringComparer.Ordinal);
+ UnicodeStringMap.Free;
+
+ // standard TI*Comparer is dedicated for MAX_HASHLIST_COUNT = 4 and lower. For example DArrayCuckoo where D = 6
+ // we need to create extra specialized TGIStringComparer type
+ AdvancedHashMapWithBigLoadFactor := TCuckooD6.Create(
+ TGIStringComparer.Ordinal);
+ AdvancedHashMapWithBigLoadFactor.Free;
+
+ // ok lets start
+ // another way to create case insensitive hash map
+ StringMap := THashMap.Create(TGIStringComparer.Ordinal);
+
+ WriteLn('Add Cat and Dog');
+ StringMap.Add('Cat', EmptyRecord);
+ StringMap.Add('Dog', EmptyRecord);
+
+ //
+ WriteLn('Contains CAT = ', StringMap.ContainsKey('CAT'));
+ WriteLn('Contains dOG = ', StringMap.ContainsKey('dOG'));
+ WriteLn('Contains Fox = ', StringMap.ContainsKey('Fox'));
+
+ WriteLn('Enumerate all keys :');
+ for k in StringMap.Keys do
+ WriteLn(' > ', k);
+
+ ReadLn;
+ StringMap.Free;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapExtendedEqualityComparer/THashMapExtendedEqualityComparer.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapExtendedEqualityComparer/THashMapExtendedEqualityComparer.lpi
new file mode 100644
index 000000000..0a8edbe0b
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapExtendedEqualityComparer/THashMapExtendedEqualityComparer.lpi
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapExtendedEqualityComparer/THashMapExtendedEqualityComparer.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapExtendedEqualityComparer/THashMapExtendedEqualityComparer.lpr
new file mode 100644
index 000000000..d3c9116c7
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapExtendedEqualityComparer/THashMapExtendedEqualityComparer.lpr
@@ -0,0 +1,108 @@
+// Generic types for FreeSparta.com and FreePascal!
+// by Maciej Izak (hnb), 2014
+
+program THashMapExtendedEqualityComparer;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils, Generics.Collections, Generics.Defaults;
+
+type
+
+ { TTaxPayer }
+
+ TTaxPayer = record
+ TaxID: Integer;
+ Name: string;
+
+ constructor Create(ATaxID: Integer; const AName: string);
+ function ToString: string;
+ end;
+
+constructor TTaxPayer.Create(ATaxID: Integer; const AName: string);
+begin
+ TaxID := ATaxID;
+ Name := AName;
+end;
+
+function TTaxPayer.ToString: string;
+begin
+ Result := Format('TaxID = %-10d Name = %-17s', [TaxID, Name]);
+end;
+
+function EqualityComparison(constref ALeft, ARight: TTaxPayer): Boolean;
+begin
+ Result := ALeft.TaxID = ARight.TaxID;
+end;
+
+procedure ExtendedHasher(constref AValue: TTaxPayer; AHashList: PUInt32);
+begin
+ // don't work with TCuckooD6 map because default TCuckooD6 needs TDelphiSixfoldHashFactory
+ // and TDefaultHashFactory = TDelphiQuadrupleHashFactory
+ // (TDelphiQuadrupleHashFactory is compatible with TDelphiDoubleHashFactory and TDelphiHashFactory)
+ TDefaultHashFactory.GetHashList(@AValue.TaxID, SizeOf(Integer), AHashList);
+end;
+
+var
+ map: THashMap; // THashMap = TCuckooD4
+ LTaxPayer: TTaxPayer;
+ LSansa: TTaxPayer;
+ LPair: TPair;
+begin
+ WriteLn('program of tax office - ExtendedEqualityComparer for THashMap');
+ WriteLn;
+
+ // to identify the taxpayer need only nip
+ map := THashMap.Create(
+ TExtendedEqualityComparer.Construct(EqualityComparison, ExtendedHasher));
+
+ map.Add(TTaxPayer.Create(1234567890, 'Joffrey Baratheon'), 'guilty');
+ map.Add(TTaxPayer.Create(90, 'Little Finger'), 'swindler');
+ map.Add(TTaxPayer.Create(667, 'John Snow'), 'delinquent tax');
+
+ // useless in this place but we can convert Keys to TArray :)
+ WriteLn(Format('All taxpayers (count = %d)', [Length(map.Keys.ToArray)]));
+ for LTaxPayer in map.Keys do
+ WriteLn(' > ', LTaxPayer.ToString);
+
+ LSansa := TTaxPayer.Create(667, 'Sansa Stark');
+
+ // exist because custom EqualityComparison and ExtendedHasher
+ WriteLn;
+ WriteLn(LSansa.Name, ' exist in map = ', map.ContainsKey(LSansa));
+ WriteLn;
+
+ //
+ WriteLn('All taxpayers');
+ for LPair in map do
+ WriteLn(' > ', LPair.Key.ToString, ' is ', LPair.Value);
+
+ // Add or set sansa? :)
+ WriteLn;
+ WriteLn(Format('AddOrSet(%s, ''innocent'')', [LSansa.ToString]));
+ map.AddOrSetValue(LSansa, 'innocent');
+ WriteLn;
+
+ //
+ WriteLn('All taxpayers');
+ for LPair in map do
+ WriteLn(' > ', LPair.Key.ToString, ' is ', LPair.Value);
+
+ // Add or set sansa? :)
+ WriteLn;
+ LSansa.TaxID := 668;
+ WriteLn(Format('AddOrSet(%s, ''innocent'')', [LSansa.ToString]));
+ map.AddOrSetValue(LSansa, 'innocent');
+ WriteLn;
+
+ //
+ WriteLn('All taxpayers');
+ for LPair in map do
+ WriteLn(' > ', LPair.Key.ToString, ' is ', LPair.Value);
+
+ ReadLn;
+ map.Free;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TObjectList/TObjectListProject.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TObjectList/TObjectListProject.lpi
new file mode 100644
index 000000000..af14cd9a1
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TObjectList/TObjectListProject.lpi
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TObjectList/TObjectListProject.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TObjectList/TObjectListProject.lpr
new file mode 100644
index 000000000..179d88595
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TObjectList/TObjectListProject.lpr
@@ -0,0 +1,194 @@
+// Generic types for FreeSparta.com and FreePascal!
+// Original version by keeper89.blogspot.com, 2011
+// FPC version by Maciej Izak (hnb), 2014
+
+program TObjectListProject;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils, Generics.Collections, Generics.Defaults, DateUtils;
+
+type
+ TPlayer = class
+ public
+ Name, Team: string;
+ BirthDay: TDateTime;
+ NTeamGoals: Byte; // Number of goals for the national team
+ constructor Create(const Name: string; BirthDay: TDateTime;
+ const Team: string; NTeamGoals: Byte = 0);
+ function ToString: string;
+ end;
+
+ // Class containing handlers add / remove list items
+ TListEventsHandler = class
+ public
+ class procedure OnListChanged(Sender: TObject; constref Item: TPlayer;
+ Action: TCollectionNotification);
+ end;
+
+
+constructor TPlayer.Create(const Name: string; BirthDay: TDateTime;
+ const Team: string; NTeamGoals: Byte);
+begin
+ Self.Name := Name;
+ Self.BirthDay := BirthDay;
+ Self.Team := Team;
+ Self.NTeamGoals := NTeamGoals;
+end;
+
+function TPlayer.ToString: string;
+begin
+ Result := Format('%s - Age: %d Team: %s Goals: %d',
+ [Name,
+ DateUtils.YearsBetween(Date, BirthDay),
+ Team, NTeamGoals])
+end;
+
+// Function sort descending goals for the national team
+function ComparePlayersByGoalsDecs(constref Player1, Player2: TPlayer): Integer;
+begin
+ Result := TCompare.UInt8(Player2.NTeamGoals, Player1.NTeamGoals);
+end;
+
+class procedure TListEventsHandler.OnListChanged(Sender: TObject; constref Item: TPlayer;
+ Action: TCollectionNotification);
+var
+ Mes: string;
+begin
+ // Unlike TDictionary we added Action = cnExtracted
+ case Action of
+ cnAdded:
+ Mes := 'added to the list!';
+ cnRemoved:
+ Mes := 'removed from the list!';
+ cnExtracted:
+ Mes := 'extracted from the list!';
+ end;
+ Writeln(Format('Football player %s %s ', [Item.ToString, Mes]));
+end;
+
+var
+ // Declare TObjectList as storage for TPlayer
+ PlayersList: TObjectList;
+ Player: TPlayer;
+ FoundIndex: PtrInt;
+begin
+ WriteLn('Working with TObjectList - football manager');
+ WriteLn;
+
+ PlayersList := TObjectList.Create;
+
+ // ---------------------------------------------------
+ // 1) Adding items
+
+ PlayersList.Add(
+ TPlayer.Create('Zinedine Zidane', EncodeDate(1972, 06, 23), 'France', 31));
+ PlayersList.Add(
+ TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44));
+ PlayersList.Add(
+ TPlayer.Create('Ronaldo', EncodeDate(1976, 09, 22), 'Brazil', 62));
+ // Adding the specified position
+ PlayersList.Insert(0,
+ TPlayer.Create('Luis Figo', EncodeDate(1972, 11, 4), 'Portugal', 33));
+ // Add a few players through InsertRange (AddRange works similarly)
+ PlayersList.InsertRange(0,
+ [TPlayer.Create('David Beckham', EncodeDate(1975, 05, 2), 'England', 17),
+ TPlayer.Create('Alessandro Del Piero', EncodeDate(1974, 11, 9), 'Italy ', 27),
+ TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44)]);
+ Player := TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44);
+ PlayersList.Add(Player);
+
+
+ // ---------------------------------------------------
+ // 2) Access and check the items
+
+ // Is there a player in the list - Contains
+ if PlayersList.Contains(Player) then
+ Writeln('Raul is in the list!');
+ // Player index and count of items in the list
+ Writeln(Format('Raul is %d-th on the list of %d players.',
+ [PlayersList.IndexOf(Player) + 1, PlayersList.Count]));
+ // Index access
+ Writeln(Format('1st in the list: %s', [PlayersList[0].ToString]));
+ // The first player
+ Writeln(Format('1st in the list: %s', [PlayersList.First.ToString]));
+ // The last player
+ Writeln(Format('Last in the list: %s', [PlayersList.Last.ToString]));
+ // "Reverse" elements
+ PlayersList.Reverse;
+ Writeln('List items have been "reversed"');
+ Writeln;
+
+
+ // ---------------------------------------------------
+ // 3) Moving and removing items
+
+ // Changing places players in the list
+ PlayersList.Exchange(0, 1);
+ // Move back 1 player
+ PlayersList.Move(1, 0);
+
+ // Removes the element at index
+ PlayersList.Delete(5);
+ // Or a number of elements starting at index
+ PlayersList.DeleteRange(5, 2);
+ // Remove the item from the list, if the item
+ // exists returns its index in the list
+ Writeln(Format('Removed %d-st player', [PlayersList.Remove(Player) + 1]));
+
+ // Extract and return the item, if there is no Player in the list then
+ // Extract will return = nil, (anyway Raul is already removed via Remove)
+ Player := PlayersList.Extract(Player);
+ if Assigned(Player) then
+ Writeln(Format('Extracted: %s', [Player.ToString]));
+
+ // Clear the list completely
+ PlayersList.Clear;
+ Writeln;
+
+ // ---------------------------------------------------
+ // 4) Event OnNotify, sorting and searching
+
+ PlayersList.OnNotify := TListEventsHandler.OnListChanged;
+
+ PlayersList.Add(
+ TPlayer.Create('Zinedine Zidane', EncodeDate(1972, 06, 23), 'France', 31));
+ PlayersList.Add(
+ TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44));
+ PlayersList.Add(
+ TPlayer.Create('Ronaldo', EncodeDate(1976, 09, 22), 'Brazil', 62));
+ PlayersList.AddRange(
+ [TPlayer.Create('David Beckham', EncodeDate(1975, 05, 2), 'England', 17),
+ TPlayer.Create('Alessandro Del Piero', EncodeDate(1974, 11, 9), 'Italy ', 27),
+ TPlayer.Create('Raul', EncodeDate(1977, 06, 27), 'Spain', 44)]);
+
+ PlayersList.Remove(PlayersList.Last);
+ Player := PlayersList.Extract(PlayersList[0]);
+
+ PlayersList.Sort(TComparer.Construct(ComparePlayersByGoalsDecs));
+ Writeln;
+ Writeln('Sorted list of players:');
+ for Player in PlayersList do
+ Writeln(Player.ToString);
+ Writeln;
+
+ // Find Ronaldo!
+ // TArray BinarySearch requires sorted list
+ // IndexOf does not require sorted list
+ // but BinarySearch is usually faster
+ Player := PlayersList[0];
+ if PlayersList.BinarySearch(Player, FoundIndex,
+ TComparer.Construct(ComparePlayersByGoalsDecs)) then
+ Writeln(Format('Ronaldo is in the sorted list at position %d', [FoundIndex + 1]));
+
+ Writeln;
+
+ // With the destruction of the list remove all elements
+ // OnNotify show it
+ FreeAndNil(PlayersList);
+
+ Readln;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TQueue/TQueueProject.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TQueue/TQueueProject.lpi
new file mode 100644
index 000000000..8d8658b8b
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TQueue/TQueueProject.lpi
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TQueue/TQueueProject.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TQueue/TQueueProject.lpr
new file mode 100644
index 000000000..87e51cd10
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TQueue/TQueueProject.lpr
@@ -0,0 +1,89 @@
+// Generic types for FreeSparta.com and FreePascal!
+// Original version by keeper89.blogspot.com, 2011
+// FPC version by Maciej Izak (hnb), 2014
+
+program TQueueProject;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils, Generics.Collections;
+
+type
+ // This is FreeSpaaarta! versions =)
+ TSpartaVersion = (svFreeSparta, svBasic, svStarter, svProfessional);
+
+ TCustomer = record
+ strict private
+ const
+ SV_NAMES: array [TSpartaVersion] of string =
+ ('FreeSparta', 'Basic', 'Starter', 'Professional');
+ public
+ var
+ SpartaVersion: TSpartaVersion;
+ class function Create(SpartaVersion: TSpartaVersion): TCustomer; static;
+ function ToString: string;
+ end;
+
+class function TCustomer.Create(SpartaVersion: TSpartaVersion): TCustomer;
+begin
+ Result.SpartaVersion := SpartaVersion;
+end;
+
+function TCustomer.ToString: string;
+begin
+ Result := Format('Sparta %s', [SV_NAMES[SpartaVersion]])
+end;
+
+var
+ CustomerQueue: TQueue;
+ Customer: TCustomer;
+begin
+ WriteLn('Working with TQueue - buy FreeSparta.com');
+ WriteLn;
+
+ // "Create" turn in sales
+ CustomerQueue := TQueue.Create;
+
+ // Add a few people in the queue
+ // Enqueue - puts the item in the queue
+ CustomerQueue.Enqueue(TCustomer.Create(svFreeSparta));
+ CustomerQueue.Enqueue(TCustomer.Create(svBasic));
+ CustomerQueue.Enqueue(TCustomer.Create(svBasic));
+ CustomerQueue.Enqueue(TCustomer.Create(svBasic));
+ CustomerQueue.Enqueue(TCustomer.Create(svStarter));
+ CustomerQueue.Enqueue(TCustomer.Create(svStarter));
+ CustomerQueue.Enqueue(TCustomer.Create(svProfessional));
+ CustomerQueue.Enqueue(TCustomer.Create(svProfessional));
+
+ // Part of customers served
+ // Dequeue - remove an element from the queue
+ // btw if TQueue is TObjectQueue also call Free for object
+ Customer := CustomerQueue.Dequeue;
+ Writeln(Format('Sold (Dequeue): %s', [Customer.ToString]));
+ // Extract - similar to Dequeue, but causes in OnNotify
+ // Action = cnExtracted instead cnRemoved
+ Customer := CustomerQueue.Extract;
+ Writeln(Format('Sold (Extract): %s', [Customer.ToString]));
+
+ // For what came next buyer?
+ // Peek - returns the first element, but does not remove it from the queue
+ Writeln(Format('Serves customers come for %s',
+ [CustomerQueue.Peek.ToString]));
+
+ // The remaining buyers
+ Writeln;
+ Writeln(Format('Buyers left: %d', [CustomerQueue.Count]));
+ for Customer in CustomerQueue do
+ Writeln(Customer.ToString);
+
+ // We serve all
+ // Clear - clears the queue
+ CustomerQueue.Clear;
+
+ FreeAndNil(CustomerQueue);
+
+ Readln;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TStack/TStackProject.lpi b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TStack/TStackProject.lpi
new file mode 100644
index 000000000..9348d16d0
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TStack/TStackProject.lpi
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TStack/TStackProject.lpr b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TStack/TStackProject.lpr
new file mode 100644
index 000000000..1a53e1872
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TStack/TStackProject.lpr
@@ -0,0 +1,86 @@
+// Generic types for FreeSparta.com and FreePascal!
+// Original version by keeper89.blogspot.com, 2011
+// FPC version by Maciej Izak (hnb), 2014
+program TStackProject;
+
+{$MODE DELPHI}
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils,
+ Windows,
+ Generics.Collections;
+
+type
+ // We will cook pancakes, put them on a plate and take the last
+ TPancakeType = (ptMeat, ptCherry, ptCurds);
+
+ TPancake = record
+ strict private
+ const
+ PANCAKE_TYPE_NAMES: array [TPancakeType] of string =
+ ('meat', 'cherry', 'curds');
+ public
+ var
+ PancakeType: TPancakeType;
+ class function Create(PancakeType: TPancakeType): TPancake; static;
+ function ToString: string;
+ end;
+
+class function TPancake.Create(PancakeType: TPancakeType): TPancake;
+begin
+ Result.PancakeType := PancakeType;
+end;
+
+function TPancake.ToString: string;
+begin
+ Result := Format('Pancake with %s', [PANCAKE_TYPE_NAMES[PancakeType]])
+end;
+
+var
+ PancakesPlate: TStack;
+ Pancake: TPancake;
+
+begin
+ WriteLn('Working with TStack - pancakes');
+ WriteLn;
+
+ // "Create" a plate of pancakes
+ PancakesPlate := TStack.Create;
+
+ // Bake some pancakes
+ // Push - puts items on the stack
+ PancakesPlate.Push(TPancake.Create(ptMeat));
+ PancakesPlate.Push(TPancake.Create(ptCherry));
+ PancakesPlate.Push(TPancake.Create(ptCherry));
+ PancakesPlate.Push(TPancake.Create(ptCurds));
+ PancakesPlate.Push(TPancake.Create(ptMeat));
+
+ // Eating some pancakes
+ // Pop - removes an item from the stack
+ Pancake := PancakesPlate.Pop;
+ Writeln(Format('Ate a pancake (Pop): %s', [Pancake.ToString]));
+ // Extract - similar to Pop, but causes in OnNotify
+ // Action = cnExtracted instead of cnRemoved
+ Pancake := PancakesPlate.Extract;
+ Writeln(Format('Ate a pancake (Extract): %s', [Pancake.ToString]));
+
+ // What is the last pancake?
+ // Peek - returns the last item, but does not remove it from the stack
+ Writeln(Format('Last pancake: %s', [PancakesPlate.Peek.ToString]));
+
+ // Show the remaining pancakes
+ Writeln;
+ Writeln(Format('Total pancakes: %d', [PancakesPlate.Count]));
+ for Pancake in PancakesPlate do
+ Writeln(Pancake.ToString);
+
+ // Eat up all
+ // Clear - clears the stack
+ PancakesPlate.Clear;
+
+ FreeAndNil(PancakesPlate);
+
+ Readln;
+end.
+
diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.collections.pas b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.collections.pas
new file mode 100644
index 000000000..379a785e1
--- /dev/null
+++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.collections.pas
@@ -0,0 +1,1263 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 2014 by Maciej Izak (hnb)
+ member of the Free Sparta development team (http://freesparta.com)
+
+ Copyright(c) 2004-2014 DaThoX
+
+ It contains the Free Pascal generics library
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit Generics.Collections;
+
+{$MODE DELPHI}{$H+}
+{$MACRO ON}
+{$COPERATORS ON}
+{$DEFINE CUSTOM_DICTIONARY_CONSTRAINTS := TKey, TValue, THashFactory}
+{$DEFINE OPEN_ADDRESSING_CONSTRAINTS := TKey, TValue, THashFactory, TProbeSequence}
+{$DEFINE CUCKOO_CONSTRAINTS := TKey, TValue, THashFactory, TCuckooCfg}
+{$WARNINGS OFF}
+{$HINTS OFF}
+
+interface
+
+uses
+ Classes, SysUtils, Generics.MemoryExpanders, Generics.Defaults,
+ Generics.Helpers, Generics.Strings;
+
+{ FPC BUGS related to Generics.* (54 bugs, 19 fixed)
+ REGRESSION: 26483, 26481
+ FIXED REGRESSION: 26480, 26482
+
+ CRITICAL: 24848(!!!), 24872(!), 25607(!), 26030, 25917, 25918, 25620, 24283, 24254, 24287 (Related to? 24872)
+ IMPORTANT: 23862(!), 24097, 24285, 24286 (Similar to? 24285), 24098, 24609 (RTL inconsistency), 24534,
+ 25606, 25614, 26177, 26195
+ OTHER: 26484, 24073, 24463, 25593, 25596, 25597, 25602, 26181 (or MYBAD?)
+ CLOSED BUT IMO STILL TO FIX: 25601(!), 25594
+ FIXED: 25610(!), 24064, 24071, 24282, 24458, 24867, 24871, 25604, 25600, 25605, 25598, 25603, 25929, 26176, 26180,
+ 26193, 24072
+ MYBAD: 24963, 25599
+}
+
+{ LAZARUS BUGS related to Generics.* (7 bugs, 0 fixed)
+ CRITICAL: 25613
+ OTHER: 25595, 25612, 25615, 25617, 25618, 25619
+}
+
+type
+ TArray = array of T; // for name TArray conflict with TArray record implementation (bug #26030)
+
+ // bug #24254 workaround
+ // should be TArray = record class procedure Sort(...) etc.
+ TCustomArrayHelper = class abstract
+ private
+ type
+ // bug #24282
+ TComparerBugHack = TComparer;
+ protected
+ // modified QuickSort from classes\lists.inc
+ class procedure QuickSort(var AValues: array of T; ALeft, ARight: SizeInt; const AComparer: IComparer);
+ virtual; abstract;
+ public
+ class procedure Sort(var AValues: array of T); overload;
+ class procedure Sort(var AValues: array of T;
+ const AComparer: IComparer); overload;
+ class procedure Sort(var AValues: array of T;
+ const AComparer: IComparer; AIndex, ACount: SizeInt); overload;
+
+ class function BinarySearch(constref AValues: array of T; constref AItem: T;
+ out AFoundIndex: SizeInt; const AComparer: IComparer;
+ AIndex, ACount: SizeInt): Boolean; virtual; abstract; overload;
+ class function BinarySearch(constref AValues: array of T; constref AItem: T;
+ out AFoundIndex: SizeInt; const AComparer: IComparer): Boolean; overload;
+ class function BinarySearch(constref AValues: array of T; constref AItem: T;
+ out AFoundIndex: SizeInt): Boolean; overload;
+ end experimental; // will be renamed to TCustomArray (bug #24254)
+
+ TArrayHelper = class(TCustomArrayHelper)
+ protected
+ // modified QuickSort from classes\lists.inc
+ class procedure QuickSort(var AValues: array of T; ALeft, ARight: SizeInt; const AComparer: IComparer); override;
+ public
+ class function BinarySearch(constref AValues: array of T; constref AItem: T;
+ out AFoundIndex: SizeInt; const AComparer: IComparer;
+ AIndex, ACount: SizeInt): Boolean; override; overload;
+ end experimental; // will be renamed to TArray (bug #24254)
+
+ TCollectionNotification = (cnAdded, cnRemoved, cnExtracted);
+ TCollectionNotifyEvent = procedure(ASender: TObject; constref AItem: T; AAction: TCollectionNotification)
+ of object;
+
+ { TEnumerator }
+
+ TEnumerator = class abstract
+ protected
+ function DoGetCurrent: T; virtual; abstract;
+ function DoMoveNext: boolean; virtual; abstract;
+ public
+ property Current: T read DoGetCurrent;
+ function MoveNext: boolean;
+ end;
+
+ { TEnumerable }
+
+ TEnumerable = class abstract
+ protected
+ function ToArrayImpl(ACount: SizeInt): TArray; overload; // used by descendants
+ protected
+ function DoGetEnumerator: TEnumerator; virtual; abstract;
+ public
+ function GetEnumerator: TEnumerator; inline;
+ function ToArray: TArray; virtual; overload;
+ end;
+
+ // More info: http://stackoverflow.com/questions/5232198/about-vectors-growth
+ // TODO: custom memory managers (as constraints)
+ {$DEFINE CUSTOM_LIST_CAPACITY_INC := Result + Result div 2} // ~approximation to golden ratio: n = n * 1.5 }
+ // {$DEFINE CUSTOM_LIST_CAPACITY_INC := Result * 2} // standard inc
+ TCustomList = class abstract(TEnumerable)
+ protected
+ type // bug #24282
+ TArrayHelperBugHack = TArrayHelper;
+ private
+ FOnNotify: TCollectionNotifyEvent;
+ function GetCapacity: SizeInt; inline;
+ protected
+ FItemsLength: SizeInt;
+ FItems: array of T;
+
+ function PrepareAddingItem: SizeInt; virtual;
+ function PrepareAddingRange(ACount: SizeInt): SizeInt; virtual;
+ procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); virtual;
+ function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; virtual;
+ procedure SetCapacity(AValue: SizeInt); virtual; abstract;
+ function GetCount: SizeInt; virtual;
+ public
+ function ToArray: TArray; override; final;
+
+ property Count: SizeInt read GetCount;
+ property Capacity: SizeInt read GetCapacity write SetCapacity;
+ property OnNotify: TCollectionNotifyEvent read FOnNotify write FOnNotify;
+ end;
+
+ TCustomListEnumerator = class abstract(TEnumerator< T >)
+ private
+ FList: TCustomList;
+ FIndex: SizeInt;
+ protected
+ function DoMoveNext: boolean; override;
+ function DoGetCurrent: T; override;
+ function GetCurrent: T; virtual;
+ public
+ constructor Create(AList: TCustomList);
+ end;
+
+ TList = class(TCustomList)
+ private var
+ FComparer: IComparer;
+ protected
+ // bug #24287 - workaround for generics type name conflict (Identifier not found)
+ // next bug workaround - for another error related to previous workaround
+ // change order (method must be declared before TEnumerator declaration)
+ function DoGetEnumerator: {Generics.Collections.}TEnumerator; override;
+ public
+ // with this type declaration i found #24285, #24285
+ type
+ // bug workaround
+ TEnumerator = class(TCustomListEnumerator);
+
+ function GetEnumerator: TEnumerator; reintroduce;
+ protected
+ procedure SetCapacity(AValue: SizeInt); override;
+ procedure SetCount(AValue: SizeInt);
+ private
+ function GetItem(AIndex: SizeInt): T;
+ procedure SetItem(AIndex: SizeInt; const AValue: T);
+ public
+ constructor Create; overload;
+ constructor Create(const AComparer: IComparer); overload;
+ constructor Create(ACollection: TEnumerable); overload;
+ destructor Destroy; override;
+
+ function Add(constref AValue: T): SizeInt;
+ procedure AddRange(constref AValues: array of T); overload;
+ procedure AddRange(const AEnumerable: IEnumerable); overload;
+ procedure AddRange(AEnumerable: TEnumerable); overload;
+
+ procedure Insert(AIndex: SizeInt; constref AValue: T);
+ procedure InsertRange(AIndex: SizeInt; constref AValues: array of T); overload;
+ procedure InsertRange(AIndex: SizeInt; const AEnumerable: IEnumerable); overload;
+ procedure InsertRange(AIndex: SizeInt; const AEnumerable: TEnumerable); overload;
+
+ function Remove(constref AValue: T): SizeInt;
+ procedure Delete(AIndex: SizeInt); inline;
+ procedure DeleteRange(AIndex, ACount: SizeInt);
+ function ExtractIndex(const AIndex: SizeInt): T; overload;
+ function Extract(constref AValue: T): T; overload;
+
+ procedure Exchange(AIndex1, AIndex2: SizeInt);
+ procedure Move(AIndex, ANewIndex: SizeInt);
+
+ function First: T; inline;
+ function Last: T; inline;
+
+ procedure Clear;
+
+ function Contains(constref AValue: T): Boolean; inline;
+ function IndexOf(constref AValue: T): SizeInt; virtual;
+ function LastIndexOf(constref AValue: T): SizeInt; virtual;
+
+ procedure Reverse;
+
+ procedure TrimExcess;
+
+ procedure Sort; overload;
+ procedure Sort(const AComparer: IComparer); overload;
+ function BinarySearch(constref AItem: T; out AIndex: SizeInt): Boolean; overload;
+ function BinarySearch(constref AItem: T; out AIndex: SizeInt; const AComparer: IComparer): Boolean; overload;
+
+ property Count: SizeInt read FItemsLength write SetCount;
+ property Items[Index: SizeInt]: T read GetItem write SetItem; default;
+ end;
+
+ TQueue = class(TCustomList)
+ protected
+ // bug #24287 - workaround for generics type name conflict (Identifier not found)
+ // next bug workaround - for another error related to previous workaround
+ // change order (function must be declared before TEnumerator declaration}
+ function DoGetEnumerator: {Generics.Collections.}TEnumerator; override;
+ public
+ type
+ TEnumerator = class(TCustomListEnumerator)
+ public
+ constructor Create(AQueue: TQueue);
+ end;
+
+ function GetEnumerator: TEnumerator; reintroduce;
+ private
+ FLow: SizeInt;
+ protected
+ procedure SetCapacity(AValue: SizeInt); override;
+ function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; override;
+ function GetCount: SizeInt; override;
+ public
+ constructor Create(ACollection: TEnumerable); overload;
+ destructor Destroy; override;
+ procedure Enqueue(constref AValue: T);
+ function Dequeue: T;
+ function Extract: T;
+ function Peek: T;
+ procedure Clear;
+ procedure TrimExcess;
+ end;
+
+ TStack = class(TCustomList)
+ protected
+ // bug #24287 - workaround for generics type name conflict (Identifier not found)
+ // next bug workaround - for another error related to previous workaround
+ // change order (function must be declared before TEnumerator declaration}
+ function DoGetEnumerator: {Generics.Collections.}TEnumerator; override;
+ public
+ type
+ TEnumerator = class(TCustomListEnumerator);
+
+ function GetEnumerator: TEnumerator; reintroduce;
+ protected
+ function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; override;
+ procedure SetCapacity(AValue: SizeInt); override;
+ public
+ constructor Create(ACollection: TEnumerable); overload;
+ destructor Destroy; override;
+ procedure Clear;
+ procedure Push(constref AValue: T);
+ function Pop: T; inline;
+ function Peek: T;
+ function Extract: T; inline;
+ procedure TrimExcess;
+ end;
+
+ TObjectList = class(TList)
+ private
+ FObjectsOwner: Boolean;
+ protected
+ procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override;
+ public
+ constructor Create(AOwnsObjects: Boolean = True); overload;
+ constructor Create(const AComparer: IComparer; AOwnsObjects: Boolean = True); overload;
+ constructor Create(ACollection: TEnumerable; AOwnsObjects: Boolean = True); overload;
+ property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner;
+ end;
+
+ TObjectQueue = class(TQueue)
+ private
+ FObjectsOwner: Boolean;
+ protected
+ procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override;
+ public
+ constructor Create(AOwnsObjects: Boolean = True); overload;
+ constructor Create(ACollection: TEnumerable; AOwnsObjects: Boolean = True); overload;
+ procedure Dequeue;
+ property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner;
+ end;
+
+ TObjectStack = class(TStack)
+ private
+ FObjectsOwner: Boolean;
+ protected
+ procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override;
+ public
+ constructor Create(AOwnsObjects: Boolean = True); overload;
+ constructor Create(ACollection: TEnumerable; AOwnsObjects: Boolean = True); overload;
+ procedure Pop;
+ property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner;
+ end;
+
+ PObject = ^TObject;
+
+{$I inc\generics.dictionariesh.inc}
+
+function InCircularRange(ABottom, AItem, ATop: SizeInt): Boolean;
+
+implementation
+
+function InCircularRange(ABottom, AItem, ATop: SizeInt): Boolean;
+begin
+ Result :=
+ (ABottom < AItem) and (AItem <= ATop )
+ or (ATop < ABottom) and (AItem > ABottom)
+ or (ATop < ABottom ) and (AItem <= ATop );
+end;
+
+{ TCustomArrayHelper }
+
+class function TCustomArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T;
+ out AFoundIndex: SizeInt; const AComparer: IComparer): Boolean;
+begin
+ Result := BinarySearch(AValues, AItem, AFoundIndex, AComparer, Low(AValues), Length(AValues));
+end;
+
+class function TCustomArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T;
+ out AFoundIndex: SizeInt): Boolean;
+begin
+ Result := BinarySearch(AValues, AItem, AFoundIndex, TComparerBugHack.Default, Low(AValues), Length(AValues));
+end;
+
+class procedure TCustomArrayHelper.Sort(var AValues: array of T);
+begin
+ QuickSort(AValues, Low(AValues), High(AValues), TComparerBugHack.Default);
+end;
+
+class procedure TCustomArrayHelper.Sort(var AValues: array of T;
+ const AComparer: IComparer);
+begin
+ QuickSort(AValues, Low(AValues), High(AValues), AComparer);
+end;
+
+class procedure TCustomArrayHelper.Sort(var AValues: array of T;
+ const AComparer: IComparer; AIndex, ACount: SizeInt);
+begin
+ if ACount <= 1 then
+ Exit;
+ QuickSort(AValues, AIndex, Pred(AIndex + ACount), AComparer);
+end;
+
+{ TArrayHelper }
+
+class procedure TArrayHelper.QuickSort(var AValues: array of T; ALeft, ARight: SizeInt;
+ const AComparer: IComparer);
+var
+ I, J: SizeInt;
+ P, Q: T;
+begin
+ if ((ARight - ALeft) <= 0) or (Length(AValues) = 0) then
+ Exit;
+ repeat
+ I := ALeft;
+ J := ARight;
+ P := AValues[ALeft + (ARight - ALeft) shr 1];
+ repeat
+ while AComparer.Compare(AValues[I], P) < 0 do
+ I += 1;
+ while AComparer.Compare(AValues[J], P) > 0 do
+ J -= 1;
+ if I <= J then
+ begin
+ if I <> J then
+ begin
+ Q := AValues[I];
+ AValues[I] := AValues[J];
+ AValues[J] := Q;
+ end;
+ I += 1;
+ J -= 1;
+ end;
+ until I > J;
+ // sort the smaller range recursively
+ // sort the bigger range via the loop
+ // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
+ if J - ALeft < ARight - I then
+ begin
+ if ALeft < J then
+ QuickSort(AValues, ALeft, J, AComparer);
+ ALeft := I;
+ end
+ else
+ begin
+ if I < ARight then
+ QuickSort(AValues, I, ARight, AComparer);
+ ARight := J;
+ end;
+ until ALeft >= ARight;
+end;
+
+class function TArrayHelper.BinarySearch(constref AValues: array of T; constref AItem: T;
+ out AFoundIndex: SizeInt; const AComparer: IComparer;
+ AIndex, ACount: SizeInt): Boolean;
+var
+ imin, imax, imid: Int32;
+ LCompare: SizeInt;
+begin
+ // continually narrow search until just one element remains
+ imin := AIndex;
+ imax := Pred(AIndex + ACount);
+
+ // http://en.wikipedia.org/wiki/Binary_search_algorithm
+ while (imin < imax) do
+ begin
+ imid := imin + ((imax - imin) shr 1);
+
+ // code must guarantee the interval is reduced at each iteration
+ // assert(imid < imax);
+ // note: 0 <= imin < imax implies imid will always be less than imax
+
+ LCompare := AComparer.Compare(AValues[imid], AItem);
+ // reduce the search
+ if (LCompare < 0) then
+ imin := imid + 1
+ else
+ begin
+ imax := imid;
+ if LCompare = 0 then
+ begin
+ AFoundIndex := imid;
+ Exit(True);
+ end;
+ end;
+ end;
+ // At exit of while:
+ // if A[] is empty, then imax < imin
+ // otherwise imax == imin
+
+ // deferred test for equality
+
+ LCompare := AComparer.Compare(AValues[imin], AItem);
+ if (imax = imin) and (LCompare = 0) then
+ begin
+ AFoundIndex := imin;
+ Exit(True);
+ end
+ else
+ begin
+ AFoundIndex := -1;
+ Exit(False);
+ end;
+end;
+
+{ TEnumerator }
+
+function TEnumerator.MoveNext: boolean;
+begin
+ Exit(DoMoveNext);
+end;
+
+{ TEnumerable }
+
+function TEnumerable.ToArrayImpl(ACount: SizeInt): TArray;
+var
+ i: SizeInt;
+ LEnumerator: TEnumerator;
+begin
+ SetLength(Result, ACount);
+
+ try
+ LEnumerator := GetEnumerator;
+
+ i := 0;
+ while LEnumerator.MoveNext do
+ begin
+ Result[i] := LEnumerator.Current;
+ Inc(i);
+ end;
+ finally
+ LEnumerator.Free;
+ end;
+end;
+
+function TEnumerable.GetEnumerator: TEnumerator;
+begin
+ Exit(DoGetEnumerator);
+end;
+
+function TEnumerable.ToArray: TArray;
+var
+ LEnumerator: TEnumerator;
+ LBuffer: TList;
+begin
+ LBuffer := TList.Create;
+ try
+ LEnumerator := GetEnumerator;
+
+ while LEnumerator.MoveNext do
+ LBuffer.Add(LEnumerator.Current);
+
+ Result := LBuffer.ToArray;
+ finally
+ LBuffer.Free;
+ LEnumerator.Free;
+ end;
+end;
+
+{ TCustomList }
+
+function TCustomList.PrepareAddingItem: SizeInt;
+begin
+ Result := Length(FItems);
+
+ if (FItemsLength < 4) and (Result < 4) then
+ SetLength(FItems, 4)
+ else if FItemsLength = High(FItemsLength) then
+ OutOfMemoryError
+ else if FItemsLength = Result then
+ SetLength(FItems, CUSTOM_LIST_CAPACITY_INC);
+
+ Result := FItemsLength;
+ Inc(FItemsLength);
+end;
+
+function TCustomList.PrepareAddingRange(ACount: SizeInt): SizeInt;
+begin
+ if ACount < 0 then
+ raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange);
+ if ACount = 0 then
+ Exit(FItemsLength - 1);
+
+ if (FItemsLength = 0) and (Length(FItems) = 0) then
+ SetLength(FItems, 4)
+ else if FItemsLength = High(FItemsLength) then
+ OutOfMemoryError;
+
+ Result := Length(FItems);
+ while Pred(FItemsLength + ACount) >= Result do
+ begin
+ SetLength(FItems, CUSTOM_LIST_CAPACITY_INC);
+ Result := Length(FItems);
+ end;
+
+ Result := FItemsLength;
+ Inc(FItemsLength, ACount);
+end;
+
+function TCustomList.ToArray: TArray;
+begin
+ Result := ToArrayImpl(Count);
+end;
+
+function TCustomList.GetCount: SizeInt;
+begin
+ Result := FItemsLength;
+end;
+
+procedure TCustomList.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification);
+begin
+ if Assigned(FOnNotify) then
+ FOnNotify(Self, AValue, ACollectionNotification);
+end;
+
+function TCustomList.DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T;
+begin
+ if (AIndex < 0) or (AIndex >= FItemsLength) then
+ raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange);
+
+ Result := FItems[AIndex];
+ Dec(FItemsLength);
+
+ FItems[AIndex] := Default(T);
+ if AIndex <> FItemsLength then
+ begin
+ System.Move(FItems[AIndex + 1], FItems[AIndex], (FItemsLength - AIndex) * SizeOf(T));
+ FillChar(FItems[FItemsLength], SizeOf(T), 0);
+ end;
+
+ Notify(Result, ACollectionNotification);
+end;
+
+function TCustomList.GetCapacity: SizeInt;
+begin
+ Result := Length(FItems);
+end;
+
+{ TCustomListEnumerator }
+
+function TCustomListEnumerator.DoMoveNext: boolean;
+begin
+ Inc(FIndex);
+ Result := (FList.FItemsLength <> 0) and (FIndex < FList.FItemsLength)
+end;
+
+function TCustomListEnumerator.DoGetCurrent: T;
+begin
+ Result := GetCurrent;
+end;
+
+function TCustomListEnumerator.GetCurrent: T;
+begin
+ Result := FList.FItems[FIndex];
+end;
+
+constructor TCustomListEnumerator.Create(AList: TCustomList);
+begin
+ inherited Create;
+ FIndex := -1;
+ FList := AList;
+end;
+
+{ TList }
+
+constructor TList.Create;
+begin
+ FComparer := TComparer.Default;
+end;
+
+constructor TList.Create(const AComparer: IComparer);
+begin
+ FComparer := AComparer;
+end;
+
+constructor TList.Create(ACollection: TEnumerable);
+var
+ LItem: T;
+begin
+ Create;
+ for LItem in ACollection do
+ Add(LItem);
+end;
+
+destructor TList.Destroy;
+begin
+ SetCapacity(0);
+end;
+
+procedure TList.SetCapacity(AValue: SizeInt);
+begin
+ if AValue < Count then
+ Count := AValue;
+
+ SetLength(FItems, AValue);
+end;
+
+procedure TList.SetCount(AValue: SizeInt);
+begin
+ if AValue < 0 then
+ raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange);
+
+ if AValue > Capacity then
+ Capacity := AValue;
+ if AValue < Count then
+ DeleteRange(AValue, Count - AValue);
+
+ FItemsLength := AValue;
+end;
+
+function TList.GetItem(AIndex: SizeInt): T;
+begin
+ if (AIndex < 0) or (AIndex >= Count) then
+ raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange);
+
+ Result := FItems[AIndex];
+end;
+
+procedure TList