From 221d56dded6be358972cf9e3acee45514bbb8d90 Mon Sep 17 00:00:00 2001 From: stv Date: Thu, 16 Jul 2026 13:08:25 +0200 Subject: [PATCH 1/9] uPDATE --- Source/Alcinoe.CodeProfiler.pas | 13 +- Source/Alcinoe.inc | 2 + Tools/CodeProfiler/_Source/Main.dfm | 59 +-- Tools/CodeProfiler/_Source/Main.pas | 725 ++++++++++++++++++++-------- 4 files changed, 572 insertions(+), 227 deletions(-) diff --git a/Source/Alcinoe.CodeProfiler.pas b/Source/Alcinoe.CodeProfiler.pas index 21ae9cdcb..bf1d98989 100644 --- a/Source/Alcinoe.CodeProfiler.pas +++ b/Source/Alcinoe.CodeProfiler.pas @@ -413,7 +413,18 @@ TStopwatchAccessPrivate = record //-- ALProcMetricsLock.BeginRead; try - if LProcMetricsHistory.FCount = LProcMetricsHistory.FCapacity then LProcMetricsHistory.Grow; + if (LProcMetricsHistory.FCount = LProcMetricsHistory.FCapacity) then begin + if (LProcMetricsHistory.FCount >= 100_000_000) {100_000_000 * 32 Bytes = 3.2 GB} then begin + ALProcMetricsLock.EndRead; + try + ALCodeProfilerPurgeHistories(ALCodeProfilerEnabled{ASaveHistories}) + finally + ALProcMetricsLock.BeginRead; + end; + end; + if LProcMetricsHistory.FCount = LProcMetricsHistory.FCapacity then + LProcMetricsHistory.Grow; + end; inc(LProcMetricsHistory.FCount); With LProcMetricsHistory.FArray[LProcMetricsHistory.FCount - 1] do begin ExecutionID := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ExecutionID; diff --git a/Source/Alcinoe.inc b/Source/Alcinoe.inc index 9045b4f26..52fce46f7 100644 --- a/Source/Alcinoe.inc +++ b/Source/Alcinoe.inc @@ -68,4 +68,6 @@ {$ZEROBASEDSTRINGS OFF} +{$TYPEDADDRESS OFF} + {.$Define ALUIAutomationEnabled} diff --git a/Tools/CodeProfiler/_Source/Main.dfm b/Tools/CodeProfiler/_Source/Main.dfm index 0a1d08be6..ece4516bd 100644 --- a/Tools/CodeProfiler/_Source/Main.dfm +++ b/Tools/CodeProfiler/_Source/Main.dfm @@ -23,7 +23,6 @@ object MainForm: TMainForm TabOrder = 0 Properties.ActivePage = InstrumentationTabSheet Properties.CustomButtons.Buttons = <> - ExplicitHeight = 768 ClientRectBottom = 863 ClientRectLeft = 5 ClientRectRight = 1075 @@ -32,7 +31,6 @@ object MainForm: TMainForm Caption = 'Source Code Instrumentation' ImageIndex = 0 OnResize = InstrumentationTabSheetResize - ExplicitHeight = 726 object InstructionPanel: TdxPanel Left = 0 Top = 0 @@ -97,7 +95,6 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 2 Transparent = True - ExplicitTop = 74 Width = 1049 end object cxLabel4: TcxLabel @@ -117,7 +114,6 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 3 Transparent = True - ExplicitTop = 107 Width = 1049 end object cxLabel5: TcxLabel @@ -177,7 +173,6 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 6 Transparent = True - ExplicitTop = 206 Width = 1062 end object LastInstructionLabel: TcxLabel @@ -201,7 +196,6 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 7 Transparent = True - ExplicitTop = 239 Width = 1062 end object cxLabel13: TcxLabel @@ -260,8 +254,6 @@ object MainForm: TMainForm Margins.Bottom = 8 Align = alClient TabOrder = 1 - ExplicitTop = 393 - ExplicitHeight = 325 object SourcesPathMemo: TcxMemo AlignWithMargins = True Left = 8 @@ -271,7 +263,6 @@ object MainForm: TMainForm Margins.Bottom = 12 Align = alClient TabOrder = 0 - ExplicitHeight = 147 Height = 208 Width = 1052 end @@ -406,7 +397,6 @@ object MainForm: TMainForm object PerformanceAnalysisTabSheet: TcxTabSheet Caption = 'Performance Analysis' ImageIndex = 1 - ExplicitHeight = 726 object Panelfilter: TPanel Left = 0 Top = 0 @@ -420,30 +410,30 @@ object MainForm: TMainForm TabOrder = 0 OnResize = PanelfilterResize object Label1: TLabel - Left = 152 + Left = 289 Top = 11 Width = 168 Height = 23 Caption = 'Start Timestamp (Min)' end object Label2: TLabel - Left = 520 + Left = 657 Top = 11 Width = 171 Height = 23 Caption = 'Start Timestamp (Max)' end object ProcNameFilterEdit: TcxTextEdit - Left = 152 + Left = 288 Top = 45 TabOrder = 0 TextHint = 'Search for procedure names. Accepts multiple entries separated b' + 'y '#39';'#39 - Width = 913 + Width = 724 end object ApplyFilterBtn: TcxButton - Left = 8 + Left = 143 Top = 45 Width = 124 Height = 31 @@ -462,7 +452,7 @@ object MainForm: TMainForm OnClick = LoadDataBtnClick end object StartTimeStampMinEdit: TcxMaskEdit - Left = 326 + Left = 463 Top = 8 Properties.MaskKind = emkRegExpr Properties.EditMask = '([0-5][0-9]):([0-5][0-9]):([0-9]{3})\.([0-9]{1,4})' @@ -471,7 +461,7 @@ object MainForm: TMainForm Width = 177 end object StartTimeStampMaxEdit: TcxMaskEdit - Left = 698 + Left = 835 Top = 8 Properties.MaskKind = emkRegExpr Properties.EditMask = '([0-5][0-9]):([0-5][0-9]):([0-9]{3})\.([0-9]{1,4})' @@ -479,6 +469,25 @@ object MainForm: TMainForm TextHint = 'mm:ss:zzz.zzzz' Width = 177 end + object ClearDataBtn: TcxButton + Left = 8 + Top = 45 + Width = 124 + Height = 31 + Margins.Right = 8 + Caption = 'Clear Data' + TabOrder = 5 + end + object ExportToCsvBtn: TcxButton + Left = 143 + Top = 8 + Width = 124 + Height = 31 + Margins.Right = 8 + Caption = 'Export to CSV' + TabOrder = 6 + OnClick = ExportToCsvBtnClick + end end object TreeListProcMetrics: TcxTreeList Left = 0 @@ -494,7 +503,6 @@ object MainForm: TMainForm Font.Height = -17 Font.Name = 'Segoe UI Light' Font.Style = [] - Navigator.Buttons.CustomButtons = <> OptionsBehavior.CopyCaptionsToClipboard = False OptionsData.Editing = False OptionsView.ColumnAutoWidth = True @@ -512,8 +520,6 @@ object MainForm: TMainForm Position.ColIndex = 1 Position.RowIndex = 0 Position.BandIndex = 0 - Summary.FooterSummaryItems = <> - Summary.GroupFooterSummaryItems = <> end object TreeListProcMetricsColumnThreadID: TcxTreeListColumn Caption.Text = 'Thread ID' @@ -525,8 +531,6 @@ object MainForm: TMainForm Position.ColIndex = 2 Position.RowIndex = 0 Position.BandIndex = 0 - Summary.FooterSummaryItems = <> - Summary.GroupFooterSummaryItems = <> end object TreeListProcMetricsColumnTimeTaken: TcxTreeListColumn Caption.Text = 'TimeTaken' @@ -538,8 +542,6 @@ object MainForm: TMainForm Position.ColIndex = 4 Position.RowIndex = 0 Position.BandIndex = 0 - Summary.FooterSummaryItems = <> - Summary.GroupFooterSummaryItems = <> end object TreeListProcMetricsColumnStartTimeStamp: TcxTreeListColumn Caption.Text = 'Start Timestamp (mm:ss:zzz)' @@ -550,8 +552,6 @@ object MainForm: TMainForm Position.ColIndex = 3 Position.RowIndex = 0 Position.BandIndex = 0 - Summary.FooterSummaryItems = <> - Summary.GroupFooterSummaryItems = <> OnGetDisplayText = TreeListProcMetricsColumnStartTimeStampGetDisplayText end object TreeListProcMetricsColumnExecutionID: TcxTreeListColumn @@ -564,8 +564,6 @@ object MainForm: TMainForm Position.BandIndex = 0 SortOrder = soDescending SortIndex = 0 - Summary.FooterSummaryItems = <> - Summary.GroupFooterSummaryItems = <> end end object GridProcMetrics: TcxGrid @@ -581,10 +579,7 @@ object MainForm: TMainForm Font.Style = [] ParentFont = False TabOrder = 2 - ExplicitHeight = 485 object GridTableViewProcMetrics: TcxGridTableView - Navigator.Buttons.CustomButtons = <> - ScrollbarAnnotations.CustomAnnotations = <> OnCellDblClick = GridTableViewProcMetricsCellDblClick DataController.Summary.DefaultGroupSummaryItems = < item @@ -603,7 +598,6 @@ object MainForm: TMainForm Kind = skCount Column = GridTableViewProcMetricsColumnProcName end> - DataController.Summary.SummaryGroups = <> DateTimeHandling.Grouping = dtgByDate OptionsBehavior.CellHints = True OptionsBehavior.CopyCaptionsToClipboard = False @@ -678,7 +672,6 @@ object MainForm: TMainForm item PanelStyleClassName = 'TdxStatusBarTextPanelStyle' end> - ExplicitTop = 768 end object dxSkinController: TdxSkinController NativeStyle = False diff --git a/Tools/CodeProfiler/_Source/Main.pas b/Tools/CodeProfiler/_Source/Main.pas index e01ffd582..ed4913944 100644 --- a/Tools/CodeProfiler/_Source/Main.pas +++ b/Tools/CodeProfiler/_Source/Main.pas @@ -90,6 +90,8 @@ TMainForm = class(TForm) MainStatusBar: TdxStatusBar; cxLabel13: TcxLabel; cxLabel14: TcxLabel; + ClearDataBtn: TcxButton; + ExportToCsvBtn: TcxButton; procedure InsertProfilerMarkersBtnClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); @@ -112,6 +114,7 @@ TMainForm = class(TForm) procedure IdHTTPServerException(AContext: TIdContext; AException: Exception); procedure IdHTTPServerListenException(AThread: TIdListenerThread; AException: Exception); procedure IdHTTPServerConnect(AContext: TIdContext); + procedure ExportToCsvBtnClick(Sender: TObject); private const ConfigFilename = 'Config.ini'; private @@ -155,8 +158,13 @@ implementation System.IOUtils, System.Win.Registry, system.IniFiles, + System.Generics.Defaults, winapi.Windows, + DelphiAST, + DelphiAST.Classes, + DelphiAST.Consts, VCL.Dialogs, + VCL.CheckLst, Alcinoe.StringUtils, Alcinoe.FileUtils, Alcinoe.Common; @@ -232,13 +240,11 @@ procedure TMainForm.RemoveMarkers(const AFileName: String); {*****************************************************************} procedure TMainForm.RemoveProfilerMarkersBtnClick(Sender: TObject); begin - if MessageDlg('⚠ WARNING: Make sure to back up your files before continuing! Do you want to continue?', mtWarning, [mbYes, mbCancel], 0) <> mrYes then Exit; var LSourceFilenames := TALStringListW.Create; try ExpandSourcesPath(SourcesPathMemo.Lines, LSourceFilenames); if LSourceFilenames.Count = 0 then Raise Exception.Create('Error: No files have been selected'); - if MessageDlg('Are you REALLY sure you want to update all the files listed below?' + sLineBreak + sLineBreak + LSourceFilenames.Text, mtWarning, [mbYes, mbCancel], 0) <> mrYes then Exit; RemoveProfilerMarkersBtn.Cursor := crHourGlass; Try for var I := 0 to LSourceFilenames.Count - 1 do @@ -363,211 +369,297 @@ procedure TMainForm.IdHTTPServerListenException(AThread: TIdListenerThread; AExc procedure TMainForm.InsertMarkers(const AFileName: String; Const AProcIDMap: TALStringListA); type - TProcStackEntry = record - ProcID: cardinal; - ProcName: AnsiString; - ProcIndent: AnsiString; - MarkerAfterBeginAdded: Boolean; + TMarkerInsertion = record + Line: Integer; + Col: Integer; + Text: AnsiString; end; -begin - RemoveMarkers(AFileName); - var LIsDPR := ALSameTextW(ALExtractFileExt(AFileName), '.dpr'); - var LHttpServerNameAdded := False; - var LUnitName := ALExtractFileName(AnsiString(AFileName), true{RemoveFileExt}); - var LUseAdded := False; - var LAnonymousMethodSequence := 0; - var LProcStack := TStack.Create; - var LSourceCode := TALStringListA.create; - try - LSourceCode.LoadFromFile(AFileName); - var LCurrentProcIndent: AnsiString := ''; - var LAddMarkerAfterNextProcBegin: Boolean := False; - var LAddMarkerBeforeNextProcEnd: Boolean := False; - var LImplementationFound: Boolean := false; - For var I := 0 to LSourceCode.Count - 1 do begin - - var LLine := LSourceCode[i]; - var LTrimedLine := ALTrim(LSourceCode[i]); - - // Handle "uses" - if (not LUseAdded) and - (ALPosIgnoreCaseA(LCurrentProcIndent + 'uses', LLine) = 1) then begin - var LNewLine := LLine; - Insert('{ALCodeProfiler>>}{$DEFINE ALCodeProfiler}Alcinoe.CodeProfiler,{< Length(ALine) then + Exit; + if not ALSameTextA(ALCopyStr(ALine, ACol, Length(AKeyword)), AKeyword) then + Exit; + if ACol > 1 then + if IsIdentifierChar(ALine[ACol - 1]) then + Exit; + if ACol + Length(AKeyword) <= Length(ALine) then + if IsIdentifierChar(ALine[ACol + Length(AKeyword)]) then + Exit; + Result := True; + end; + + {*************************************************************************} + function FindKeywordColumn(const ALine, AKeyword: AnsiString; const APreferredCol: Integer; const ASearchBackwards: Boolean): Integer; + begin + if IsKeywordAt(ALine, AKeyword, APreferredCol) then + Exit(APreferredCol); + if ASearchBackwards then begin + for var I := Length(ALine) - Length(AKeyword) + 1 downto 1 do + if IsKeywordAt(ALine, AKeyword, I) then + Exit(I); + end + else begin + for var I := 1 to Length(ALine) - Length(AKeyword) + 1 do + if IsKeywordAt(ALine, AKeyword, I) then + Exit(I); + end; + Result := 0; + end; + + {***********************************************************************************} + function FindBeginInsertionColumn(const ASourceCode: TALStringListA; const ALine, ACol: Integer): Integer; + begin + if (ALine < 1) or (ALine > ASourceCode.Count) then + raise Exception.Create('Invalid AST begin line: ' + ALIntToStrW(ALine) + ' - Filename: ' + AFileName); + var LLine := ASourceCode[ALine - 1]; + var LBeginCol := FindKeywordColumn(LLine, 'begin', ACol, False); + if LBeginCol <= 0 then + Exit(0); + Result := LBeginCol + Length('begin'); + end; + + {*********************************************************************************} + function FindEndInsertionColumn(const ASourceCode: TALStringListA; const ALine, ACol: Integer): Integer; + begin + if (ALine < 1) or (ALine > ASourceCode.Count) then + raise Exception.Create('Invalid AST end line: ' + ALIntToStrW(ALine) + ' - Filename: ' + AFileName); + var LLine := ASourceCode[ALine - 1]; + Result := FindKeywordColumn(LLine, 'end', ACol - Length('end'), True); + end; + + {***********************************************************************************************************} + procedure AddInsertion(const AInsertions: TList; const ASourceCode: TALStringListA; const ALine, ACol: Integer; const AText: AnsiString); + begin + if (ALine < 1) or (ALine > ASourceCode.Count) then + raise Exception.Create('Invalid insertion line: ' + ALIntToStrW(ALine) + ' - Filename: ' + AFileName); + if (ACol < 1) or (ACol > Length(ASourceCode[ALine - 1]) + 1) then + raise Exception.Create('Invalid insertion column: ' + ALIntToStrW(ACol) + ' - Line: ' + ALIntToStrW(ALine) + ' - Filename: ' + AFileName); + var LInsertion: TMarkerInsertion; + LInsertion.Line := ALine; + LInsertion.Col := ACol; + LInsertion.Text := AText; + AInsertions.Add(LInsertion); + end; + + {*************************************************************************************} + function FindFirstNode(const ANode: TSyntaxNode; const ANodeType: TSyntaxNodeType): TSyntaxNode; + begin + Result := nil; + if not Assigned(ANode) then + Exit; + if ANode.Typ = ANodeType then begin + Result := ANode; + Exit; + end; + for var LChild in ANode.ChildNodes do begin + Result := FindFirstNode(LChild, ANodeType); + if Assigned(Result) then + Exit; + end; + end; + + {*************************************************************************************} + function HasAncestorOfType(const ANode: TSyntaxNode; const ANodeType: TSyntaxNodeType): Boolean; + begin + var LParent := ANode.ParentNode; + while Assigned(LParent) do begin + if LParent.Typ = ANodeType then + Exit(True); + LParent := LParent.ParentNode; + end; + Result := False; + end; + + {*******************************************************************} + function FindRootStatements(const ANode: TSyntaxNode): TCompoundSyntaxNode; + begin + Result := nil; + if not Assigned(ANode) then + Exit; + if (ANode.Typ = ntStatements) and + (ANode is TCompoundSyntaxNode) and + (not HasAncestorOfType(ANode, ntMethod)) and + (not HasAncestorOfType(ANode, ntAnonymousMethod)) then begin + Result := TCompoundSyntaxNode(ANode); + Exit; + end; + for var LChild in ANode.ChildNodes do begin + Result := FindRootStatements(LChild); + if Assigned(Result) then + Exit; + end; + end; + + {****************************************************************} + function GetMethodStatements(const ANode: TSyntaxNode): TCompoundSyntaxNode; + begin + Result := nil; + for var LChild in ANode.ChildNodes do + if (LChild.Typ = ntStatements) and + (LChild is TCompoundSyntaxNode) then begin + Result := TCompoundSyntaxNode(LChild); + Exit; end; + end; - // Handle "begin" in DPR - if (LIsDPR) and - (not LHttpServerNameAdded) and - (ALPosIgnoreCaseA('begin', LLine) = 1) then begin - if (ALTrim(HttpServerNameEdit.Text) <> '') and - (ALTrim(HttpServerPortEdit.Text) <> '') then begin - var LNewLine := LLine; - Insert('{ALCodeProfiler>>}ALCodeProfilerServerName := ''http://'+ALTrim(AnsiString(HttpServerNameEdit.Text))+':'+ALTrim(AnsiString(HttpServerPortEdit.Text))+''';{< '') and + ((Result = '') or (ALPosIgnoreCaseA(LNamePart + '.', Result) <> 1)) then begin + if Result <> '' then + Result := LNamePart + '.' + Result + else + Result := LNamePart; end; - LHttpServerNameAdded := True; - Continue; end; + if Result = '' then begin + inc(AAnonymousMethodSequence); + Result := '$AnonymousMethod' + ALIntToStrA(AAnonymousMethodSequence); + end; + end; - // Ignore Interface section - if ALSameTextA(LTrimedLine, 'implementation') then begin - LImplementationFound := True; - continue; - end; - if not LImplementationFound then continue; - - // Ignore lines like: - // - // TALDynamicListBox = class(TALControl) - // public - // procedure Prepare; virtual; - // end; - if (LAddMarkerAfterNextProcBegin) and - (LTrimedLine <> '') and - (LCurrentProcIndent <> '') and - (ALPosIgnoreCaseA(LCurrentProcIndent, LLine) <> 1) then begin - LProcStack.Pop; - LCurrentProcIndent := ''; - LAddMarkerAfterNextProcBegin := False; - LAddMarkerBeforeNextProcEnd := False; + {*********************************************************************************************************************************************************************} + procedure CollectMethodMarkers(const ANode: TSyntaxNode; const AParentProcName: AnsiString; const AUnitName: AnsiString; const ASourceCode: TALStringListA; const AInsertions: TList; var AAnonymousMethodSequence: Integer); + begin + if not Assigned(ANode) then + Exit; + + var LParentProcName := AParentProcName; + if ANode.Typ in [ntMethod, ntAnonymousMethod] then begin + var LProcName := GetMethodName(ANode, AAnonymousMethodSequence); + if LParentProcName <> '' then + LProcName := LParentProcName + '.' + LProcName; + LParentProcName := LProcName; + + var LStatements := GetMethodStatements(ANode); + if Assigned(LStatements) then begin + var LBeginInsertionCol := FindBeginInsertionColumn(ASourceCode, LStatements.Line, LStatements.Col); + var LEndInsertionCol := FindEndInsertionColumn(ASourceCode, LStatements.EndLine, LStatements.EndCol); + if (LBeginInsertionCol > 0) and (LEndInsertionCol > 0) then begin + inc(FProcIDSequence); + AddInsertion( + AInsertions, + ASourceCode, + LStatements.Line, + LBeginInsertionCol, + '{ALCodeProfiler>>}ALCodeProfilerEnterProc('+ALIntToStrA(FProcIDSequence){$IF defined(debug)}+'{ '+LProcName+' }'{$ENDIF}+'); try{<>}finally ALCodeProfilerExitProc('+ALIntToStrA(FProcIDSequence){$IF defined(debug)}+'{ '+LProcName+' }'{$ENDIF}+'); end;{< '>') do inc(J) + {*****************************************************************************************************} + procedure ApplyInsertions(const ASourceCode: TALStringListA; const AInsertions: TList); + begin + AInsertions.Sort( + TComparer.Construct( + function(const Left, Right: TMarkerInsertion): Integer + begin + if Left.Line <> Right.Line then + Result := Right.Line - Left.Line else - break; - inc(J); - end; - LProcName := ALCopyStr(LProcName, 1, J-1); - If LProcName = '' then begin - inc(LAnonymousMethodSequence); - LProcName := '$AnonymousMethod' + ALIntToStrA(LAnonymousMethodSequence); - end - else LAnonymousMethodSequence := 0; - if LProcStack.Count > 0 then - LProcName := LProcStack.Peek.ProcName + '.' + LProcName; - inc(FProcIDSequence); - var LProcStackEntry: TProcStackEntry; - LProcStackEntry.ProcID := FProcIDSequence; - LProcStackEntry.ProcName := LProcName; - LProcStackEntry.ProcIndent := LCurrentProcIndent; - LProcStackEntry.MarkerAfterBeginAdded := False; - LProcStack.Push(LProcStackEntry); - LAddMarkerAfterNextProcBegin := True; - LAddMarkerBeforeNextProcEnd := False; - end + Result := Right.Col - Left.Col; + end)); - // Handle "begin" - else if (LAddMarkerAfterNextProcBegin) and - (ALPosIgnoreCaseA(LCurrentProcIndent + 'begin', LLine) = 1) then begin - if LProcStack.Count = 0 then - raise Exception.Create( - 'The source code is not properly formatted. '+ - 'CodeProfiler requires all procedures to be perfectly '+ - 'indented to function correctly - ' + - 'Line: ' + ALIntToStrW(I+1) + ' - ' + - 'Filename: ' + AFileName + ' - ' + - 'Error: 75F32B58-8284-493D-BE75-2F9F3DE2DEF4'); - var LNewLine := LLine; - Insert('{ALCodeProfiler>>}ALCodeProfilerEnterProc('+ALIntToStrA(LProcStack.Peek.ProcID){$IF defined(debug)}+'{ '+LProcStack.Peek.ProcName+' }'{$ENDIF}+'); try{<>}finally ALCodeProfilerExitProc('+ALIntToStrA(LProcStack.Peek.ProcID){$IF defined(debug)}+'{ '+LProcStack.Peek.ProcName+' }'{$ENDIF}+'); end;{< 0 then begin - LCurrentProcIndent := LProcStack.Peek.ProcIndent; - LAddMarkerAfterNextProcBegin := not LProcStack.Peek.MarkerAfterBeginAdded; - LAddMarkerBeforeNextProcEnd := LProcStack.Peek.MarkerAfterBeginAdded; - end - else begin - LAddMarkerAfterNextProcBegin := False; - LAddMarkerBeforeNextProcEnd := False; - end; +begin + RemoveMarkers(AFileName); + var LIsDPR := ALSameTextW(ALExtractFileExt(AFileName), '.dpr'); + var LUnitName := ALExtractFileName(AnsiString(AFileName), true{RemoveFileExt}); + var LSyntaxTree := TPasSyntaxTreeBuilder.Run(AFileName); + var LInsertions := TList.Create; + var LSourceCode := TALStringListA.create; + try + LSourceCode.LoadFromFile(AFileName); + + var LUsesNode := FindFirstNode(LSyntaxTree, ntUses); + if Assigned(LUsesNode) then + AddInsertion( + LInsertions, + LSourceCode, + LUsesNode.Line, + LUsesNode.Col + Length('uses'), + '{ALCodeProfiler>>}{$DEFINE ALCodeProfiler}Alcinoe.CodeProfiler,{<>}{$DEFINE ALCodeProfiler}uses Alcinoe.CodeProfiler;{< '') and + (ALTrim(HttpServerPortEdit.Text) <> '') then begin + var LRootStatements := FindRootStatements(LSyntaxTree); + if Assigned(LRootStatements) then begin + var LBeginInsertionCol := FindBeginInsertionColumn(LSourceCode, LRootStatements.Line, LRootStatements.Col); + if LBeginInsertionCol > 0 then + AddInsertion( + LInsertions, + LSourceCode, + LRootStatements.Line, + LBeginInsertionCol, + '{ALCodeProfiler>>}ALCodeProfilerServerName := ''http://'+ALTrim(AnsiString(HttpServerNameEdit.Text))+':'+ALTrim(AnsiString(HttpServerPortEdit.Text))+''';{< mrYes then Exit; var LSourceFilenames := TALStringListW.Create; var LFailedFilenames := TALStringListW.Create; var LProcIDMap := TALStringListA.Create; @@ -590,7 +681,28 @@ procedure TMainForm.InsertProfilerMarkersBtnClick(Sender: TObject); ExpandSourcesPath(SourcesPathMemo.Lines, LSourceFilenames); if LSourceFilenames.Count = 0 then Raise Exception.Create('Error: No files have been selected'); - if MessageDlg('Are you REALLY sure you want to update all the files listed below?' + sLineBreak + sLineBreak + LSourceFilenames.Text, mtWarning, [mbYes, mbCancel], 0) <> mrYes then Exit; + + // Ask whether the previously collected data must be cleared. If it is + // kept, preload the existing proc ID map and continue the ID sequence + // after the highest existing ProcID so that the IDs already present in + // the sources and in the performance file stay valid + var LProcIDMapFilename := TPath.Combine(FDataDir, ALCodeProfilerProcIDMapFilename); + var LClearData := MessageDlg( + 'Do you want to start a fresh profiling session and clear the data collected so far?'+ sLineBreak + sLineBreak + + 'YES – Start fresh: the procedure IDs ('+ALCodeProfilerProcIDMapFilename+') and the collected performance data ('+ALCodeProfilerProcMetricsFilename+') will be discarded, and the ID numbering will restart from 1. '+ + 'Choose this only if the selected files cover ALL the files currently containing profiler markers; any file left instrumented from a previous run would keep old IDs that clash with the new ones.'+ sLineBreak + sLineBreak + + 'NO – Keep the existing data: the procedures of the selected files will be assigned new IDs, following the existing ones, so previously instrumented files and already collected performance data stay valid.', + mtConfirmation, [mbYes, mbNo, mbCancel], 0); + if (LClearData <> mrYes) and (LClearData <> mrNo) then Exit; + if LClearData = mrYes then FProcIDSequence := 0 + else if TFile.Exists(LProcIDMapFilename) then begin + LProcIDMap.LoadFromFile(LProcIDMapFilename); + for var I := 0 to LProcIDMap.Count - 1 do begin + var LProcID := ALStrToInt(LProcIDMap.Names[I]); + if LProcID > FProcIDSequence then FProcIDSequence := LProcID; + end; + end; + InsertProfilerMarkersBtn.Cursor := crHourGlass; Try for var I := 0 to LSourceFilenames.Count - 1 do @@ -600,15 +712,23 @@ procedure TMainForm.InsertProfilerMarkersBtnClick(Sender: TObject); On E: Exception do LFailedFilenames.Add(LSourceFilenames[i]); end; - LProcIDMap.SaveToFile(TPath.Combine(FDataDir, ALCodeProfilerProcIDMapFilename)); + LProcIDMap.SaveToFile(LProcIDMapFilename); finally InsertProfilerMarkersBtn.Cursor := crDefault; End; - var LProcMetricsFilename := TPath.Combine(FDataDir, ALCodeProfilerProcMetricsFilename); - If TFile.Exists(LProcMetricsFilename) then - TFile.Delete(LProcMetricsFilename); + if LClearData = mrYes then begin + var LProcMetricsFilename := TPath.Combine(FDataDir, ALCodeProfilerProcMetricsFilename); + If TFile.Exists(LProcMetricsFilename) then + TFile.Delete(LProcMetricsFilename); + end; if LFailedFilenames.Count > 0 then - MessageDlg('The operation completed successfully, except for the following file(s), which are badly formatted and could not be updated:' + sLineBreak + LFailedFilenames.Text, mtError, [mbOK], 0) + MessageDlg( + 'The operation completed except for the following file(s), which are '+ + 'badly formatted and could not be updated. Now, you must recompile your '+ + 'project and run it. After you close the application (or move it '+ + 'between background and foreground on Android/iOS), a performance '+ + 'file (ALCodeProfilerProcMetrics.dat) will be generated in the user''s '+ + 'document folder.' + sLineBreak + sLineBreak + LFailedFilenames.Text, mtError, [mbOK], 0) else MessageDlg( 'The operation completed successfully. Now, you must recompile your '+ @@ -749,6 +869,225 @@ procedure TMainForm.InstrumentationTabSheetResize(Sender: TObject); InstructionPanel.Height := LastInstructionLabel.Top + LastInstructionLabel.Height + LastInstructionLabel.Margins.Bottom; end; +{*******************************************************} +procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); + +Const + CColumnExecutionID = 0; + CColumnParentExecutionID = 1; + CColumnProcID = 2; + CColumnProcName = 3; + CColumnThreadID = 4; + CColumnStartTimeStamp = 5; + CColumnTimeTaken = 6; + CColumnNames: array[CColumnExecutionID..CColumnTimeTaken] of AnsiString = ( + 'ExecutionID', + 'ParentExecutionID', + 'ProcID', + 'ProcName', + 'ThreadID', + 'StartTimeStamp', + 'TimeTaken'); + +var + LExportColumns: array[CColumnExecutionID..CColumnTimeTaken] of Boolean; + LCsvStream: TFileStream; + LCsvBuffer: AnsiString; + LCsvBufferPos: Integer; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _WriteToCsvBuffer(const AStr: AnsiString); + begin + if LCsvBufferPos + length(AStr) > length(LCsvBuffer) then begin + LCsvStream.WriteBuffer(PAnsiChar(LCsvBuffer)^, LCsvBufferPos); + LCsvBufferPos := 0; + end; + ALMove(PAnsiChar(AStr)^, LCsvBuffer[LCsvBufferPos + 1], length(AStr)); + LCsvBufferPos := LCsvBufferPos + length(AStr); + end; + + {~~~~~~~~~~~~~~~~~~~~~~} + procedure _FlushCsvBuffer; + begin + if LCsvBufferPos > 0 then begin + LCsvStream.WriteBuffer(PAnsiChar(LCsvBuffer)^, LCsvBufferPos); + LCsvBufferPos := 0; + end; + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _TicksToMillisecondsStr(const ATicks: Int64): AnsiString; + begin + // 1 tick equals 0.0001 millisecond (ALCodeProfilerMillisecondsPerTick), + // so use integer arithmetic to avoid any rounding/locale issue + Result := ALIntToStrA(ATicks div 10000) + '.' + ALFormatA('%.4d', [ATicks mod 10000]); + end; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + procedure _AppendToCsvRow(var ARow: AnsiString; var AFirstColumn: Boolean; const AValue: AnsiString); + begin + if not AFirstColumn then ARow := ARow + ','; + AFirstColumn := False; + ARow := ARow + AValue; + end; + +begin + var LProcMetricsFilename := TPath.Combine(FDataDir, ALCodeProfilerProcMetricsFilename); + If not TFile.Exists(LProcMetricsFilename) then + raise Exception.CreateFmt( + 'The required file "%s" is missing. Please make '+ + 'sure it is available in the data subfolder where '+ + 'Alcinoe Code Profiler is located before proceeding.', + [ALCodeProfilerProcMetricsFilename]); + + // Ask which columns to export + var LColumnsForm := TForm.CreateNew(nil); + try + LColumnsForm.Caption := 'Export to CSV'; + LColumnsForm.BorderStyle := bsDialog; + LColumnsForm.Position := poScreenCenter; + LColumnsForm.ClientWidth := 300; + LColumnsForm.ClientHeight := 233; + var LColumnsLabel := TLabel.Create(LColumnsForm); + LColumnsLabel.Parent := LColumnsForm; + LColumnsLabel.Caption := 'Select the columns to export:'; + LColumnsLabel.SetBounds(8, 8, LColumnsForm.ClientWidth - 16, 15); + var LColumnsCheckListBox := TCheckListBox.Create(LColumnsForm); + LColumnsCheckListBox.Parent := LColumnsForm; + LColumnsCheckListBox.SetBounds(8, 29, LColumnsForm.ClientWidth - 16, 161); + for var I := CColumnExecutionID to CColumnTimeTaken do begin + LColumnsCheckListBox.Items.Add(String(CColumnNames[I])); + LColumnsCheckListBox.Checked[I] := True; + end; + var LOkBtn := TButton.Create(LColumnsForm); + LOkBtn.Parent := LColumnsForm; + LOkBtn.Caption := 'OK'; + LOkBtn.ModalResult := mrOk; + LOkBtn.Default := True; + LOkBtn.SetBounds(LColumnsForm.ClientWidth - 170, 198, 75, 27); + var LCancelBtn := TButton.Create(LColumnsForm); + LCancelBtn.Parent := LColumnsForm; + LCancelBtn.Caption := 'Cancel'; + LCancelBtn.ModalResult := mrCancel; + LCancelBtn.Cancel := True; + LCancelBtn.SetBounds(LColumnsForm.ClientWidth - 87, 198, 75, 27); + if LColumnsForm.ShowModal <> mrOk then exit; + for var I := CColumnExecutionID to CColumnTimeTaken do + LExportColumns[I] := LColumnsCheckListBox.Checked[I]; + finally + ALFreeAndNil(LColumnsForm); + end; + var LExportAnyColumn := False; + for var I := CColumnExecutionID to CColumnTimeTaken do + LExportAnyColumn := LExportAnyColumn or LExportColumns[I]; + if not LExportAnyColumn then + Raise Exception.Create('Error: No columns have been selected'); + + // The proc ID map is only needed to resolve the ProcName column + var LProcIDMapFilename := TPath.Combine(FDataDir, ALCodeProfilerProcIDMapFilename); + If (LExportColumns[CColumnProcName]) and (not TFile.Exists(LProcIDMapFilename)) then + raise Exception.CreateFmt('The required file "%s" does not exist. Please ensure it is available before proceeding', [ALCodeProfilerProcIDMapFilename]); + + // Ask where to save the CSV file + var LCsvFilename: String; + var LSaveDialog := TSaveDialog.Create(nil); + try + LSaveDialog.Title := 'Export to CSV'; + LSaveDialog.Filter := 'CSV files (*.csv)|*.csv|All files (*.*)|*.*'; + LSaveDialog.DefaultExt := 'csv'; + LSaveDialog.Options := LSaveDialog.Options + [ofOverwritePrompt]; + LSaveDialog.FileName := ALStringReplaceW(ALCodeProfilerProcMetricsFilename, '.dat', '.csv', [rfIgnoreCase]); + if not LSaveDialog.Execute then exit; + LCsvFilename := LSaveDialog.FileName; + finally + ALFreeAndNil(LSaveDialog); + end; + + ExportToCsvBtn.Cursor := crHourGlass; + var LExportedRecordCount: Int64 := 0; + Try + + // Load ALCodeProfilerProcIDMap.txt in LProcNames + var LProcNames := TDictionary.Create; + var LProcMetricsStream: TFileStream := nil; + LCsvStream := nil; + try + if LExportColumns[CColumnProcName] then begin + var LProcIDMap := TALHashedStringListA.Create; + try + LProcIDMap.LoadFromFile(LProcIDMapFilename); + for var I := 0 to LProcIDMap.Count - 1 do + LProcNames.AddOrSetValue(Cardinal(ALStrToInt(LProcIDMap.Names[I])), LProcIDMap.ValueFromIndex[I]); + finally + ALFreeAndNil(LProcIDMap); + end; + end; + + // Convert ALCodeProfilerProcMetrics.dat to CSV chunk by chunk as the + // file can be very huge and can not be fully loaded in memory + LProcMetricsStream := TFileStream.Create(LProcMetricsFilename, fmOpenRead or fmShareDenyWrite); + if LProcMetricsStream.Size mod SizeOf(TALProcMetrics) <> 0 then + raise Exception.CreateFmt('The file "%s" is corrupted', [ALCodeProfilerProcMetricsFilename]); + var LTotalRecordCount: Int64 := LProcMetricsStream.Size div SizeOf(TALProcMetrics); + LCsvStream := TFileStream.Create(LCsvFilename, fmCreate); + var LProcMetrics: TArray; + Setlength(LProcMetrics, 65536); // 65536 * SizeOf(TALProcMetrics) = 2 MB + Setlength(LCsvBuffer, 4194304); // 4 MB + LCsvBufferPos := 0; + var LCsvHeader: AnsiString := ''; + var LFirstColumn := True; + for var I := CColumnExecutionID to CColumnTimeTaken do + if LExportColumns[I] then + _AppendToCsvRow(LCsvHeader, LFirstColumn, CColumnNames[I]); + _WriteToCsvBuffer(LCsvHeader + #13#10); + While True do begin + var LBytesRead := LProcMetricsStream.Read(LProcMetrics[0], length(LProcMetrics) * SizeOf(TALProcMetrics)); + if LBytesRead <= 0 then break; + if LBytesRead mod SizeOf(TALProcMetrics) <> 0 then + raise Exception.CreateFmt('The file "%s" is corrupted', [ALCodeProfilerProcMetricsFilename]); + for var I := 0 to (LBytesRead div SizeOf(TALProcMetrics)) - 1 do begin + var LCsvRow: AnsiString := ''; + LFirstColumn := True; + if LExportColumns[CColumnExecutionID] then + _AppendToCsvRow(LCsvRow, LFirstColumn, ALIntToStrA(LProcMetrics[I].ExecutionID)); + if LExportColumns[CColumnParentExecutionID] then + _AppendToCsvRow(LCsvRow, LFirstColumn, ALIntToStrA(LProcMetrics[I].ParentExecutionID)); + if LExportColumns[CColumnProcID] then + _AppendToCsvRow(LCsvRow, LFirstColumn, ALIntToStrA(LProcMetrics[I].ProcID)); + if LExportColumns[CColumnProcName] then begin + var LProcName: AnsiString; + if not LProcNames.TryGetValue(LProcMetrics[I].ProcID, LProcName) then LProcName := ''; + _AppendToCsvRow(LCsvRow, LFirstColumn, LProcName); + end; + if LExportColumns[CColumnThreadID] then + _AppendToCsvRow(LCsvRow, LFirstColumn, ALIntToStrA(LProcMetrics[I].ThreadID)); + if LExportColumns[CColumnStartTimeStamp] then + _AppendToCsvRow(LCsvRow, LFirstColumn, _TicksToMillisecondsStr(LProcMetrics[I].StartTimeStamp)); + if LExportColumns[CColumnTimeTaken] then + _AppendToCsvRow(LCsvRow, LFirstColumn, _TicksToMillisecondsStr(LProcMetrics[I].ElapsedTicks)); + _WriteToCsvBuffer(LCsvRow + #13#10); + inc(LExportedRecordCount); + end; + if LTotalRecordCount > 0 then begin + MainStatusBar.Panels[1].Text := 'Exporting to CSV: ' + ALIntToStrW(Round((LExportedRecordCount / LTotalRecordCount) * 100)) + '%'; + MainStatusBar.Update; + end; + end; + _FlushCsvBuffer; + finally + ALFreeAndNil(LProcNames); + ALFreeAndNil(LProcMetricsStream); + ALFreeAndNil(LCsvStream); + end; + + Finally + ExportToCsvBtn.Cursor := crDefault; + MainStatusBar.Panels[1].Text := ''; + End; + + MessageDlg(ALIntToStrW(LExportedRecordCount) + ' records have been exported successfully.', mtInformation, [mbOK], 0); +end; + {**********************************************} procedure TMainForm.FormCreate(Sender: TObject); begin From a0da81e1f82e34eb549fcecf00d13ceed140b5da Mon Sep 17 00:00:00 2001 From: stv Date: Wed, 9 Sep 2026 11:55:27 +0200 Subject: [PATCH 2/9] Update CodeProfiler --- Source/Alcinoe.CodeProfiler.inc | 39 ++ Source/Alcinoe.CodeProfiler.pas | 426 +++++++++++-- Tools/CodeProfiler/_Source/Main.dfm | 248 ++++++-- Tools/CodeProfiler/_Source/Main.pas | 944 ++++++++++++++++++++++------ 4 files changed, 1369 insertions(+), 288 deletions(-) create mode 100644 Source/Alcinoe.CodeProfiler.inc diff --git a/Source/Alcinoe.CodeProfiler.inc b/Source/Alcinoe.CodeProfiler.inc new file mode 100644 index 000000000..7938af677 --- /dev/null +++ b/Source/Alcinoe.CodeProfiler.inc @@ -0,0 +1,39 @@ +var + ALCodeProfilerEnabled: Boolean = True; + ALCodeProfilerServerName: String = ''; + +// Do not group calls. Each function/procedure call generates one row. +// The result will be displayed as a call tree, for example: +// procedure A - 1 call - 310 ms +// procedure B - 1 call - 215 ms +// procedure C - 1 call - 14 ms +// procedure C - 1 call - 11 ms +// procedure D - 1 call - 85 ms +// procedure C - 1 call - 21 ms +// procedure B - 1 call - 35 ms +// procedure B - 1 call - 41 ms +// procedure C - 1 call - 22 ms +// +// NOTE: This option can use a lot of memory. If you enable it, it is recommended +// to limit profiling to the specific code you want to measure by using +// ALCodeProfilerStart and ALCodeProfilerStop. +{.$DEFINE ALCodeProfilerHistoryGroupNone} + +// Group calls by procedure ID. +// The result will be displayed as a flat grid, for example: +// procedure A - 1 call - 310 ms +// procedure B - 3 calls - 291 ms +// procedure C - 4 calls - 68 ms +// procedure D - 1 call - 85 ms +// +// NOTE: This is the fastest option and has the lowest impact on each function call. +{.$DEFINE ALCodeProfilerHistoryGroupByProcID} + +// Group calls by call stack. +// The result will be displayed as a grouped call tree, for example: +// procedure A - 1 call - 310 ms +// procedure B - 3 calls - 291 ms +// procedure C - 3 calls - 46 ms +// procedure D - 1 call - 85 ms +// procedure C - 1 call - 22 ms +{$DEFINE ALCodeProfilerHistoryGroupByCallStack} diff --git a/Source/Alcinoe.CodeProfiler.pas b/Source/Alcinoe.CodeProfiler.pas index bf1d98989..1cd97d22a 100644 --- a/Source/Alcinoe.CodeProfiler.pas +++ b/Source/Alcinoe.CodeProfiler.pas @@ -3,17 +3,34 @@ interface {$I Alcinoe.inc} +{$I Alcinoe.CodeProfiler.inc} type TALProcMetrics = record public + {$IF defined(ALCodeProfilerHistoryGroupNone)} ExecutionID: Cardinal; ParentExecutionID: Cardinal; ProcID: Cardinal; ThreadID: Cardinal; StartTimeStamp: Int64; ElapsedTicks: Int64; + {$ELSEIF defined(ALCodeProfilerHistoryGroupByProcID)} + ProcID: Cardinal; + ThreadID: Cardinal; + CallCount: Cardinal; + ElapsedTicks: Int64; + {$ELSEIF defined(ALCodeProfilerHistoryGroupByCallStack)} + HashCode: Integer; + ProcID: Cardinal; + MetricsID: Cardinal; + ParentMetricsID: Cardinal; + ThreadID: Cardinal; + CallCount: Cardinal; + ElapsedTicks: Int64; + {$ENDIF} end; + PALProcMetrics = ^TALProcMetrics; procedure ALCodeProfilerEnterProc(const aProcID : Cardinal); procedure ALCodeProfilerExitProc(const aProcID : Cardinal); @@ -22,19 +39,28 @@ procedure ALCodeProfilerStop(Const ASaveHistories: Boolean = True); function ALCodeProfilerIsrunning: Boolean; const - ALCodeProfilerProcMetricsFilename = 'ALCodeProfilerProcMetrics.dat'; ALCodeProfilerProcIDMapFilename = 'ALCodeProfilerProcIDMap.txt'; + {$IF defined(ALCodeProfilerHistoryGroupNone)} + ALCodeProfilerProcMetricsFilename: String = 'ALCodeProfilerProcMetrics.None.dat'; + {$ELSEIF defined(ALCodeProfilerHistoryGroupByProcID)} + ALCodeProfilerProcMetricsFilename: String = 'ALCodeProfilerProcMetrics.ByProcID.dat'; + {$ELSEIF defined(ALCodeProfilerHistoryGroupByCallStack)} + ALCodeProfilerProcMetricsFilename: String = 'ALCodeProfilerProcMetrics.ByCallStack.dat'; + {$ENDIF} ALCodeProfilerRegistryPath = 'Software\MagicFoundation\Alcinoe\CodeProfiler'; ALCodeProfilerDataStoragePathKey = 'DataStoragePath'; ALCodeProfilerMillisecondsPerTick = 0.0001; var ALCodeProfilerAppStartTimeStamp: Int64; - ALCodeProfilerServerName: String; + implementation uses + {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} + System.Hash, + {$ENDIF} {$IF defined(MSWindows)} System.Win.Registry, Winapi.Windows, @@ -59,19 +85,24 @@ implementation System.Classes, System.Generics.Collections, System.Diagnostics, - System.IOUtils, - Alcinoe.FileUtils, - Alcinoe.Common; + System.IOUtils; {**} Type TALStopWatchProcMetrics = record private + {$IF defined(ALCodeProfilerHistoryGroupNone)} class var ExecutionIDSequence: cardinal; + {$ENDIF} public + {$IF defined(ALCodeProfilerHistoryGroupNone)} ExecutionID: Cardinal; ParentExecutionID: Cardinal; + {$ENDIF} ProcID: Cardinal; + {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} + ParentMetricsID: Cardinal; + {$ENDIF} ThreadID: Cardinal; StopWatch: TStopWatch; end; @@ -82,10 +113,8 @@ TALProcMetricsStack = class(TObject) FArray: TALStopWatchProcMetricsArray; FCount: NativeInt; FCapacity: NativeInt; - procedure Grow; virtual; + procedure Grow; procedure SetCapacity(NewCapacity: NativeInt); - public - destructor Destroy; override; end; TALProcMetricsArray = array of TALProcMetrics; @@ -95,23 +124,25 @@ TALProcMetricsHistory = class(TObject) FCount: NativeInt; FCapacity: NativeInt; FIsOrphaned: Boolean; - procedure Grow; virtual; + {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} + FGrowThreshold: NativeInt; + procedure Rehash(NewCapPow2: NativeInt); + function GetBucketIndex(const AProcID, AParentMetricsID: Cardinal; const AHashCode: Integer): NativeInt; + function Hash(const AProcID, AParentMetricsID: Cardinal): Integer; + {$ENDIF} + procedure Grow; procedure SetCapacity(NewCapacity: NativeInt); - public - constructor Create; virtual; - destructor Destroy; override; + procedure Clear; end; {*******} threadvar ALProcMetricsStack: TALProcMetricsStack; ALProcMetricsHistory: TALProcMetricsHistory; - ALIsInCodeProfiler: Boolean; {*} var ALProcMetricsHistories: TList; - ALCodeProfilerEnabled: Boolean; ALProcMetricsLock: TLightweightMREW; ALProcMetricsFilename: String; {$IF defined(IOS) or defined(ANDROID)} @@ -122,6 +153,12 @@ TALProcMetricsHistory = class(TObject) Type TALCodeProfilerLogType = (VERBOSE, DEBUG, INFO, WARN, ERROR, ASSERT); +{**************************************************} +{$IF defined(ALCodeProfilerHistoryGroupByCallStack)} +const + EMPTY_HASH = -1; +{$ENDIF} + {**************************} procedure ALCodeProfilerLog( Const Tag: String; @@ -175,12 +212,6 @@ procedure ALCodeProfilerLog( {$ENDIF} end; -{*************************************} -destructor TALProcMetricsStack.Destroy; -begin - SetCapacity(0); -end; - {*********************************} procedure TALProcMetricsStack.Grow; begin @@ -196,38 +227,194 @@ procedure TALProcMetricsStack.SetCapacity(NewCapacity: NativeInt); end; end; -{***************************************} -constructor TALProcMetricsHistory.Create; -begin - inherited; - FIsOrphaned := False; -end; - -{***************************************} -destructor TALProcMetricsHistory.Destroy; -begin - SetCapacity(0); -end; - {***********************************} procedure TALProcMetricsHistory.Grow; begin + {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} + + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.Grow was not updated and adjust the IFDEF'} + {$ENDIF} + + var LNewCap: NativeInt := Length(FArray) * 2; + if LNewCap = 0 then + LNewCap := 4; + Rehash(LNewCap); + + {$ELSE} + SetCapacity(GrowCollection(FCapacity, FCount + 1)); + + {$ENDIF} end; {******************************************************************} procedure TALProcMetricsHistory.SetCapacity(NewCapacity: NativeInt); begin + {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} + + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.SetCapacity was not updated and adjust the IFDEF'} + {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.InternalSetCapacity was not updated and adjust the IFDEF'} + {$ENDIF} + + // Ensure at least one empty slot for GetBucketIndex to terminate. + Inc(NewCapacity); + if FCapacity <> NewCapacity then begin + if NewCapacity < FCount then + ErrorArgumentOutOfRange; + + if NewCapacity = 0 then Rehash(0) + else begin + var LNewCap: NativeInt := 4; + while LNewCap shr 1 <= NewCapacity do // 50% + LNewCap := LNewCap shl 1; + Rehash(LNewCap); + end + end; + + {$ELSE} + if NewCapacity <> FCapacity then begin SetLength(FArray, NewCapacity); FCapacity := NewCapacity; end; + + {$ENDIF} +end; + +{************************************} +procedure TALProcMetricsHistory.Clear; +begin + + {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} + + FCount := 0; + SetLength(FArray, 0); + FCapacity := 0; + FGrowThreshold := 0; + + {$ELSE} + + FCount := 0; + + {$ENDIF} + +end; + +{**************************************************} +{$IF defined(ALCodeProfilerHistoryGroupByCallStack)} +procedure TALProcMetricsHistory.Rehash(NewCapPow2: NativeInt); +begin + + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.Rehash was not updated and adjust the IFDEF'} + {$ENDIF} + + if NewCapPow2 = Length(FArray) then + Exit + else if NewCapPow2 < 0 then + OutOfMemoryError; + + var LOldArray: TALProcMetricsArray := FArray; + var LNewArray: TALProcMetricsArray; + + SetLength(LNewArray, NewCapPow2); + var P: PALProcMetrics := PALProcMetrics(LNewArray); + for var i := 0 to Length(LNewArray) - 1 do begin + P^.HashCode := EMPTY_HASH; + Inc(P); + end; + FArray := LNewArray; + FGrowThreshold := NewCapPow2 shr 1; // 50% + + P := PALProcMetrics(LOldArray); + for var i := 0 to Length(LOldArray) - 1 do begin + raise Exception.Create( + 'Rehash is not implemented right now because MetricsID and ParentMetricsID ' + + 'reference positions in the array, which would become invalid after rehashing. ' + + 'The array is currently sized large enough to avoid calling Rehash.'); + if P^.HashCode <> EMPTY_HASH then begin + var j := not GetBucketIndex(P^.ProcID, P^.ParentMetricsID, P^.HashCode); + FArray[j] := P^; + end; + Inc(P); + end; + end; +{$ENDIF} + +{********************************************************} +{$IF defined(ALCodeProfilerHistoryGroupByCallStack)} +function TALProcMetricsHistory.GetBucketIndex(const AProcID, AParentMetricsID: Cardinal; const AHashCode: Integer): NativeInt; +begin + + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.GetBucketIndex was not updated and adjust the IFDEF'} + {$ENDIF} + + var L: NativeInt := Length(FArray); + if L = 0 then + Exit(not High(NativeInt)); + + Result := AHashCode and (L - 1); + var P: PALProcMetrics := @FArray[Result]; + while True do begin + var LHashCode := P^.HashCode; + + // Not found: return complement of insertion point. + if LHashCode = EMPTY_HASH then + Exit(not Result); + + // Found: return location. + if (LHashCode = AHashCode) and (P^.ProcID = AProcID) and (P^.ParentMetricsID = AParentMetricsID) then + Exit(Result); + + Inc(Result); + Inc(P); + if Result >= L then begin + Result := 0; + P := @FArray[0]; + end; + end; + +end; +{$ENDIF} + +{********************************************************} +{$IF defined(ALCodeProfilerHistoryGroupByCallStack)} +function TALProcMetricsHistory.Hash(const AProcID, AParentMetricsID: Cardinal): Integer; +const + PositiveMask = Integer.MaxValue; +begin + + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.GetBucketIndex was not updated and adjust the IFDEF'} + {$ENDIF} + + {$IFOPT Q+} + {$DEFINE Q_ON} + {$Q-} + {$ENDIF} + var LKey: UInt64 := (UInt64(AProcID) shl 32) or UInt64(AParentMetricsID); + // Double-Abs to avoid -MaxInt and MinInt problems. + // Not using compiler-Abs because we *must* get a positive integer; + // for compiler, Abs(Low(Integer)) is a null op. + Result := PositiveMask and ((PositiveMask and THashFNV1a32.GetHashValue(LKey, SizeOf(LKey))) + 1); + {$IFDEF Q_ON} + {$Q+} + {$UNDEF Q_ON} + {$ENDIF} + +end; +{$ENDIF} {**********************************************************************************************} procedure ALCodeProfilerSaveHistory(const AProcMetricsHistory: TALProcMetricsHistory); overload; begin + {$IF defined(ALCodeProfilerHistoryGroupNone) or defined(ALCodeProfilerHistoryGroupByCallStack)} if AProcMetricsHistory.FCount = 0 then exit; + {$ENDIF} //-- If ALProcMetricsFilename = '' then begin {$IF defined(MSWindows)} @@ -248,7 +435,7 @@ procedure ALCodeProfilerSaveHistory(const AProcMetricsHistory: TALProcMetricsHis end else {$ENDIF} - ALProcMetricsFilename := TPath.Combine(ALGetTempPathW, ALCodeProfilerProcMetricsFilename); + ALProcMetricsFilename := TPath.Combine(System.IOUtils.TPath.GetTempPath, ALCodeProfilerProcMetricsFilename); if TFile.Exists(ALProcMetricsFilename) then TFile.Delete(ALProcMetricsFilename); end; //-- @@ -257,12 +444,22 @@ procedure ALCodeProfilerSaveHistory(const AProcMetricsHistory: TALProcMetricsHis else LfileStream := TFileStream.Create(ALProcMetricsFilename, fmCreate); try LfileStream.Position := LfileStream.Size; + {$IF defined(ALCodeProfilerHistoryGroupNone)} LfileStream.WriteBuffer(AProcMetricsHistory.FArray[0], AProcMetricsHistory.FCount * SizeOf(TALProcMetrics)); + {$ELSEIF defined(ALCodeProfilerHistoryGroupByProcID)} + for var I := Low(AProcMetricsHistory.FArray) to High(AProcMetricsHistory.FArray) do + if AProcMetricsHistory.FArray[I].CallCount <> 0 then + LfileStream.WriteBuffer(AProcMetricsHistory.FArray[I], SizeOf(TALProcMetrics)); + {$ELSEIF defined(ALCodeProfilerHistoryGroupByCallStack)} + for var I := Low(AProcMetricsHistory.FArray) to High(AProcMetricsHistory.FArray) do + if AProcMetricsHistory.FArray[I].HashCode <> EMPTY_HASH then + LfileStream.WriteBuffer(AProcMetricsHistory.FArray[I], SizeOf(TALProcMetrics)); + {$ENDIF} finally LFileStream.Free; end; //-- - AProcMetricsHistory.FCount := 0; + AProcMetricsHistory.Clear; end; {********************************************************************} @@ -273,7 +470,7 @@ procedure ALCodeProfilerPurgeHistories(const ASaveHistories: boolean); for var I := ALProcMetricsHistories.Count - 1 downto 0 do begin if ASaveHistories then ALCodeProfilerSaveHistory(ALProcMetricsHistories[i]); if ALProcMetricsHistories[i].FIsOrphaned then ALProcMetricsHistories.ExtractAt(i).Free - else ALProcMetricsHistories[i].FCount := 0; + else ALProcMetricsHistories[i].Clear; end; finally ALProcMetricsLock.EndWrite; @@ -325,9 +522,6 @@ procedure ALCodeProfilerPurgeHistories(const ASaveHistories: boolean); {**********************************************************} procedure ALCodeProfilerEnterProc(const aProcID : Cardinal); begin - if ALIsInCodeProfiler then exit; - ALIsInCodeProfiler := True; - //-- if ALCodeProfilerEnabled then begin var LProcMetricsStack := ALProcMetricsStack; if LProcMetricsStack = nil then begin @@ -339,13 +533,64 @@ procedure ALCodeProfilerEnterProc(const aProcID : Cardinal); if LProcMetricsStack.FCount = LProcMetricsStack.FCapacity then LProcMetricsStack.Grow; inc(LProcMetricsStack.FCount); With LProcMetricsStack.FArray[LProcMetricsStack.FCount - 1] do begin + {$IF defined(ALCodeProfilerHistoryGroupNone)} ExecutionID := AtomicIncrement(TALStopWatchProcMetrics.ExecutionIDSequence); + {$ENDIF} if LProcMetricsStack.FCount > 1 then begin + {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} + var LProcMetricsHistory := ALProcMetricsHistory; + if LProcMetricsHistory = nil then begin + ALProcMetricsHistory := TALProcMetricsHistory.Create; + ALProcMetricsHistory.SetCapacity(1000000); {1 000 000 * 32 Bytes = 32 MB or with gap = 2 097 152 * 32 Bytes = 67.11 MB} + LProcMetricsHistory := ALProcMetricsHistory; + ALProcMetricsLock.BeginWrite; + try + ALProcMetricsHistories.Add(LProcMetricsHistory); + finally + ALProcMetricsLock.EndWrite; + end; + end; + ALProcMetricsLock.BeginRead; + try + var LParentProcID: Cardinal := LProcMetricsStack.FArray[LProcMetricsStack.FCount - 2].ProcID; + var LParentParentMetricsID := LProcMetricsStack.FArray[LProcMetricsStack.FCount - 2].ParentMetricsID; + var LHashCode: Integer := LProcMetricsHistory.Hash(LParentProcID, LParentParentMetricsID); + var LParentMetricsID: NativeInt := LProcMetricsHistory.GetBucketIndex(LParentProcID, LParentParentMetricsID, LHashCode); + if LParentMetricsID < 0 then begin + if LProcMetricsHistory.FCount >= LProcMetricsHistory.FGrowThreshold then begin + LProcMetricsHistory.Grow; + LParentMetricsID := LProcMetricsHistory.GetBucketIndex(LParentProcID, LParentParentMetricsID, LHashCode); + end; + inc(LProcMetricsHistory.FCount); + LParentMetricsID := not LParentMetricsID; + With LProcMetricsHistory.FArray[LParentMetricsID] do begin + HashCode := LHashCode; + ProcID := LParentProcID; + MetricsID := LParentMetricsID; + ParentMetricsID := LParentParentMetricsID; + ThreadID := LProcMetricsStack.FArray[LProcMetricsStack.FCount - 2].ThreadID; + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Diagnostics.TStopwatch.InitStopwatchType was not updated and adjust the IFDEF'} + {$ENDIF} + CallCount := 0; + ElapsedTicks := 0; + end; + end; + ParentMetricsID := LParentMetricsID; + finally + ALProcMetricsLock.EndRead; + end; + {$ELSEIF defined(ALCodeProfilerHistoryGroupNone)} ParentExecutionID := LProcMetricsStack.FArray[LProcMetricsStack.FCount - 2].ExecutionID; + {$ENDIF} ThreadID := LProcMetricsStack.FArray[LProcMetricsStack.FCount - 2].ThreadID; end else begin + {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} + ParentMetricsID := 0; + {$ELSEIF defined(ALCodeProfilerHistoryGroupNone)} ParentExecutionID := 0; + {$ENDIF} var LCurrentThreadID := TThread.CurrentThread.ThreadID; if LCurrentThreadID = MainThreadID then ThreadID := 0 else begin @@ -357,8 +602,6 @@ procedure ALCodeProfilerEnterProc(const aProcID : Cardinal); StopWatch := TStopWatch.StartNew; end; end; - //-- - ALIsInCodeProfiler := False; end; {*********************************************************} @@ -376,9 +619,6 @@ TStopwatchAccessPrivate = record end; begin - if ALIsInCodeProfiler then exit; - ALIsInCodeProfiler := True; - //-- var LProcMetricsStack := ALProcMetricsStack; if LProcMetricsStack <> nil then begin if not ALCodeProfilerEnabled then begin @@ -401,7 +641,7 @@ TStopwatchAccessPrivate = record var LProcMetricsHistory := ALProcMetricsHistory; if LProcMetricsHistory = nil then begin ALProcMetricsHistory := TALProcMetricsHistory.Create; - ALProcMetricsHistory.SetCapacity(1000000); {1 000 000 * 32 Bytes = 32 MB} + ALProcMetricsHistory.SetCapacity(1000000); {1 000 000 * 32 Bytes = 32 MB or with gap = 2 097 152 * 32 Bytes = 67.11 MB} LProcMetricsHistory := ALProcMetricsHistory; ALProcMetricsLock.BeginWrite; try @@ -413,6 +653,7 @@ TStopwatchAccessPrivate = record //-- ALProcMetricsLock.BeginRead; try + {$IF defined(ALCodeProfilerHistoryGroupNone)} if (LProcMetricsHistory.FCount = LProcMetricsHistory.FCapacity) then begin if (LProcMetricsHistory.FCount >= 100_000_000) {100_000_000 * 32 Bytes = 3.2 GB} then begin ALProcMetricsLock.EndRead; @@ -447,6 +688,84 @@ TStopwatchAccessPrivate = record Raise Exception.create('Error 55533349-EC72-404D-B113-CA32C518012F') {$ENDIF} end; + {$ELSEIF defined(ALCodeProfilerHistoryGroupByProcID)} + var LProcID: Cardinal := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ProcID; + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.TryAdd was not updated and adjust the IFDEF'} + {$ENDIF} + With LProcMetricsHistory.FArray[LProcID] do begin + ProcID := LProcID; + ThreadID := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ThreadID; + Inc(CallCount); + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Diagnostics.TStopwatch.InitStopwatchType was not updated and adjust the IFDEF'} + {$ENDIF} + {$IF defined(MSWINDOWS)} + var LTickFrequency: Double; + if not TStopwatch.IsHighResolution then LTickFrequency := 1.0 + else LTickFrequency := 10000000.0 / LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.Frequency; + ElapsedTicks := ElapsedTicks + Trunc(LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.ElapsedTicks * LTickFrequency); + {$ELSEIF defined(POSIX)} + ElapsedTicks := ElapsedTicks + LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.ElapsedTicks; + {$ELSE} + Raise Exception.create('Error 8CB28339-29A0-4276-80AA-F8CD5E447CE5') + {$ENDIF} + end; + {$ELSEIF defined(ALCodeProfilerHistoryGroupByCallStack)} + var LProcID: Cardinal := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ProcID; + var LParentMetricsID: Cardinal := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ParentMetricsID; + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.TryAdd was not updated and adjust the IFDEF'} + {$ENDIF} + var LHashCode: Integer := LProcMetricsHistory.Hash(LProcID, LParentMetricsID); + var LIndex: NativeInt := LProcMetricsHistory.GetBucketIndex(LProcID, LParentMetricsID, LHashCode); + if LIndex >= 0 then begin + With LProcMetricsHistory.FArray[LIndex] do begin + Inc(CallCount); + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Diagnostics.TStopwatch.InitStopwatchType was not updated and adjust the IFDEF'} + {$ENDIF} + {$IF defined(MSWINDOWS)} + var LTickFrequency: Double; + if not TStopwatch.IsHighResolution then LTickFrequency := 1.0 + else LTickFrequency := 10000000.0 / LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.Frequency; + ElapsedTicks := ElapsedTicks + Trunc(LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.ElapsedTicks * LTickFrequency); + {$ELSEIF defined(POSIX)} + ElapsedTicks := ElapsedTicks + LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.ElapsedTicks; + {$ELSE} + Raise Exception.create('Error 8CB28339-29A0-4276-80AA-F8CD5E447CE5') + {$ENDIF} + end; + end + else begin + if LProcMetricsHistory.FCount >= LProcMetricsHistory.FGrowThreshold then begin + LProcMetricsHistory.Grow; + LIndex := LProcMetricsHistory.GetBucketIndex(LProcID, LParentMetricsID, LHashCode); + end; + inc(LProcMetricsHistory.FCount); + With LProcMetricsHistory.FArray[not LIndex] do begin + HashCode := LHashCode; + ProcID := LProcID; + MetricsID := not LIndex; + ParentMetricsID := LParentMetricsID; + ThreadID := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ThreadID; + CallCount := 1; + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Diagnostics.TStopwatch.InitStopwatchType was not updated and adjust the IFDEF'} + {$ENDIF} + {$IF defined(MSWINDOWS)} + var LTickFrequency: Double; + if not TStopwatch.IsHighResolution then LTickFrequency := 1.0 + else LTickFrequency := 10000000.0 / LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.Frequency; + ElapsedTicks := Trunc(LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.ElapsedTicks * LTickFrequency); + {$ELSEIF defined(POSIX)} + ElapsedTicks := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.ElapsedTicks; + {$ELSE} + Raise Exception.create('Error 8CB28339-29A0-4276-80AA-F8CD5E447CE5') + {$ENDIF} + end; + end; + {$ENDIF} dec(LProcMetricsStack.FCount); finally ALProcMetricsLock.EndRead; @@ -467,8 +786,6 @@ TStopwatchAccessPrivate = record end; end; end; - //-- - ALIsInCodeProfiler := False; end; {****************************} @@ -505,19 +822,19 @@ procedure ALCodeProfilerApplicationEventHandler(const Sender: TObject; const M: {$ENDIF} initialization - {$IF defined(DEBUG)} - ALLog('Alcinoe.CodeProfiler','initialization'); - {$ENDIF} - ALIsInCodeProfiler := False; ALCodeProfilerAppStartTimeStamp := TStopWatch.GetTimeStamp; + {$IF defined(ALCodeProfilerHistoryGroupNone)} TALStopWatchProcMetrics.ExecutionIDSequence := 0; + {$ENDIF} //ALProcMetricsLock := ?? There is no TLightweightMREW.Create; initialization is done through the TLightweightMREW.Initialize class operator instead - ALCodeProfilerEnabled := True; ALProcMetricsFilename := ''; - ALCodeProfilerServerName := ''; //-- ALProcMetricsHistory := TALProcMetricsHistory.Create; + {$IF defined(ALCodeProfilerHistoryGroupNone)} ALProcMetricsHistory.SetCapacity(25000000); {25 000 000 * 32 Bytes = 800MB} + {$ELSE} + ALProcMetricsHistory.SetCapacity(1000000); {1 000 000 = 2 097 152 (with gap) * 32 Bytes = 67.11 MB} + {$ENDIF} //-- ALProcMetricsHistories := TList.Create; ALProcMetricsHistories.Add(ALProcMetricsHistory); @@ -528,9 +845,6 @@ initialization {$ENDIF} finalization - {$IF defined(DEBUG)} - ALLog('Alcinoe.CodeProfiler','finalization'); - {$ENDIF} {$IF (not defined(IOS)) and (not defined(ANDROID))} // At this point, all background threads must have completed. ALCodeProfilerPurgeHistories(ALCodeProfilerEnabled{ASaveHistories}); diff --git a/Tools/CodeProfiler/_Source/Main.dfm b/Tools/CodeProfiler/_Source/Main.dfm index ece4516bd..156ccaead 100644 --- a/Tools/CodeProfiler/_Source/Main.dfm +++ b/Tools/CodeProfiler/_Source/Main.dfm @@ -21,7 +21,7 @@ object MainForm: TMainForm Height = 868 Align = alClient TabOrder = 0 - Properties.ActivePage = InstrumentationTabSheet + Properties.ActivePage = PerformanceAnalysisTabSheet Properties.CustomButtons.Buttons = <> ClientRectBottom = 863 ClientRectLeft = 5 @@ -84,7 +84,9 @@ object MainForm: TMainForm Top = 107 Margins.Left = 16 Align = alTop - Caption = '2. Add Alcinoe profiler markers to your code.' + Caption = + '2. Click the "Insert Markers" button below to add profiler marke' + + 'rs to your code.' ParentFont = False Style.Font.Charset = DEFAULT_CHARSET Style.Font.Color = clWindowText @@ -124,8 +126,9 @@ object MainForm: TMainForm Align = alTop Caption = '4. If you are using Android or iOS, send the app to the backgrou' + - 'nd and then bring it back to the foreground to generate the perf' + - 'ormance file.' + 'nd and bring it back to the foreground to generate the performan' + + 'ce file. On Windows and macOS, the performance file will be gene' + + 'rated when you close the app.' ParentFont = False Style.Font.Charset = DEFAULT_CHARSET Style.Font.Color = clWindowText @@ -144,7 +147,9 @@ object MainForm: TMainForm Top = 285 Margins.Left = 16 Align = alTop - Caption = '6. Perform the performance analysis.' + Caption = + '6. Go to the Performance Analysis tab, click the Load Data butto' + + 'n, and run the analysis.' ParentFont = False Style.Font.Charset = DEFAULT_CHARSET Style.Font.Color = clWindowText @@ -204,7 +209,9 @@ object MainForm: TMainForm Top = 74 Margins.Left = 16 Align = alTop - Caption = '1. Specify the server IP and port for the listening process.' + Caption = + '1. If you run the program on a remote device (such as Android or' + + ' iOS), specify the server IP and port for the listening process.' ParentFont = False Style.Font.Charset = DEFAULT_CHARSET Style.Font.Color = clWindowText @@ -225,10 +232,10 @@ object MainForm: TMainForm Align = alTop Caption = '5. If you specified the server IP and port in step 1, the perfor' + - 'mance file will be received automatically. After receiving it, s' + - 'imply reload the data; otherwise, download the data from the use' + - 'r'#39's document folder and place it in the CodeProfiler data folder' + - '.' + 'mance file will be received automatically. Otherwise, if you are' + + ' running the program on a remote device, download the data from ' + + 'the user'#39's documents folder and place it in the CodeProfiler dat' + + 'a folder.' ParentFont = False Style.Font.Charset = DEFAULT_CHARSET Style.Font.Color = clWindowText @@ -257,21 +264,21 @@ object MainForm: TMainForm object SourcesPathMemo: TcxMemo AlignWithMargins = True Left = 8 - Top = 164 + Top = 254 Margins.Left = 8 Margins.Right = 8 - Margins.Bottom = 12 + Margins.Bottom = 0 Align = alClient TabOrder = 0 - Height = 208 + Height = 78 Width = 1052 end object cxLabel9: TcxLabel AlignWithMargins = True Left = 8 - Top = 134 + Top = 224 Margins.Left = 8 - Margins.Top = 8 + Margins.Top = 0 Margins.Right = 8 Margins.Bottom = 0 Align = alTop @@ -284,7 +291,7 @@ object MainForm: TMainForm end object dxPanel3: TdxPanel Left = 0 - Top = 95 + Top = 148 Width = 1068 Height = 31 Align = alTop @@ -329,6 +336,7 @@ object MainForm: TMainForm Margins.Right = 8 Margins.Bottom = 0 Align = alLeft + Properties.OnChange = HttpServerNameEditPropertiesChange TabOrder = 2 Width = 358 end @@ -347,28 +355,104 @@ object MainForm: TMainForm Width = 71 end end + object cxLabel15: TcxLabel + AlignWithMargins = True + Left = 8 + Top = 8 + Margins.Left = 8 + Margins.Top = 8 + Margins.Right = 8 + Margins.Bottom = 8 + Align = alTop + Caption = + 'Path to Alcinoe.CodeProfiler.inc, the include file where the opt' + + 'ions below are stored' + Properties.WordWrap = True + TabOrder = 6 + Width = 1052 + end + object dxPanel5: TdxPanel + Left = 0 + Top = 43 + Width = 1068 + Height = 31 + Align = alTop + Frame.Borders = [] + LookAndFeel.NativeStyle = False + LookAndFeel.SkinName = 'Foggy' + TabOrder = 7 + object BrowseCodeProfilerIncFilenameBtn: TcxButton + AlignWithMargins = True + Left = 1020 + Top = 0 + Width = 40 + Height = 31 + Margins.Left = 8 + Margins.Top = 0 + Margins.Right = 8 + Margins.Bottom = 0 + Align = alRight + Caption = '...' + TabOrder = 0 + OnClick = BrowseCodeProfilerIncFilenameBtnClick + end + object CodeProfilerIncFilenameEdit: TcxTextEdit + AlignWithMargins = True + Left = 8 + Top = 0 + Margins.Left = 8 + Margins.Top = 0 + Margins.Right = 8 + Margins.Bottom = 0 + Align = alClient + Properties.OnChange = CodeProfilerIncFilenameEditPropertiesChange + TabOrder = 1 + Width = 996 + end + end + object dxPanel6: TdxPanel + Left = 0 + Top = 74 + Width = 1068 + Height = 31 + Align = alTop + Frame.Borders = [] + LookAndFeel.NativeStyle = False + LookAndFeel.SkinName = 'Foggy' + TabOrder = 8 + object CodeProfilerEnabledCheckBox: TcxCheckBox + AlignWithMargins = True + Left = 8 + Top = 3 + Margins.Left = 8 + Align = alLeft + Caption = 'Start profiling as soon as the application starts' + Properties.OnChange = CodeProfilerEnabledCheckBoxPropertiesChange + TabOrder = 0 + end + end object cxLabel10: TcxLabel AlignWithMargins = True Left = 8 - Top = 60 + Top = 113 Margins.Left = 8 Margins.Top = 8 Margins.Right = 8 Margins.Bottom = 8 Align = alTop Caption = - 'Specify the IP address and port to automatically receive the per' + - 'formance file, then update the markers in your code.' + '(Optional) Specify the IP address and port of this computer to a' + + 'utomatically receive the performance file' Properties.WordWrap = True TabOrder = 3 Width = 1052 end object dxPanel1: TdxPanel Left = 0 - Top = 0 + Top = 332 Width = 1068 Height = 52 - Align = alTop + Align = alBottom Frame.Borders = [] LookAndFeel.NativeStyle = False LookAndFeel.SkinName = 'Foggy' @@ -392,6 +476,53 @@ object MainForm: TMainForm OnClick = RemoveProfilerMarkersBtnClick end end + object dxPanel4: TdxPanel + AlignWithMargins = True + Left = 3 + Top = 182 + Width = 1062 + Height = 39 + Align = alTop + Frame.Borders = [] + LookAndFeel.NativeStyle = False + LookAndFeel.SkinName = 'Foggy' + TabOrder = 5 + object DoNotGroupRadioButton: TcxRadioButton + AlignWithMargins = True + Left = 8 + Top = 3 + Margins.Left = 8 + Align = alLeft + Caption = 'Do not group (Huge memory usage!)' + TabOrder = 0 + OnClick = HistoryGroupModeRadioButtonClick + AutoSize = True + end + object GroupCallsByProcIDRadioButton: TcxRadioButton + AlignWithMargins = True + Left = 347 + Top = 3 + Margins.Left = 32 + Align = alLeft + Caption = 'Group by procedure ID' + TabOrder = 1 + OnClick = HistoryGroupModeRadioButtonClick + AutoSize = True + end + object GroupCallsByCallStackRadioButton: TcxRadioButton + AlignWithMargins = True + Left = 579 + Top = 3 + Margins.Left = 32 + Align = alLeft + Caption = 'Group by call stack (recommended)' + Checked = True + TabOrder = 2 + TabStop = True + OnClick = HistoryGroupModeRadioButtonClick + AutoSize = True + end + end end end object PerformanceAnalysisTabSheet: TcxTabSheet @@ -477,6 +608,7 @@ object MainForm: TMainForm Margins.Right = 8 Caption = 'Clear Data' TabOrder = 5 + OnClick = ClearDataBtnClick end object ExportToCsvBtn: TcxButton Left = 143 @@ -511,6 +643,19 @@ object MainForm: TMainForm Styles.Background = cxStyleTreeListProcMetricsBackground TabOrder = 1 OnDblClick = TreeListProcMetricsDblClick + object TreeListProcMetricsColumnExecutionID: TcxTreeListColumn + Caption.Text = '_ExecutionID' + DataBinding.ValueType = 'Integer' + Options.Moving = False + Width = 120 + Position.ColIndex = 0 + Position.RowIndex = 0 + Position.BandIndex = 0 + SortOrder = soDescending + SortIndex = 0 + Summary.FooterSummaryItems = <> + Summary.GroupFooterSummaryItems = <> + end object TreeListProcMetricsColumnProcName: TcxTreeListColumn Caption.Text = 'Name' Options.Filtering = False @@ -520,6 +665,8 @@ object MainForm: TMainForm Position.ColIndex = 1 Position.RowIndex = 0 Position.BandIndex = 0 + Summary.FooterSummaryItems = <> + Summary.GroupFooterSummaryItems = <> end object TreeListProcMetricsColumnThreadID: TcxTreeListColumn Caption.Text = 'Thread ID' @@ -531,17 +678,8 @@ object MainForm: TMainForm Position.ColIndex = 2 Position.RowIndex = 0 Position.BandIndex = 0 - end - object TreeListProcMetricsColumnTimeTaken: TcxTreeListColumn - Caption.Text = 'TimeTaken' - DataBinding.ValueType = 'Float' - Options.Filtering = False - Options.Moving = False - Options.Sorting = False - Width = 150 - Position.ColIndex = 4 - Position.RowIndex = 0 - Position.BandIndex = 0 + Summary.FooterSummaryItems = <> + Summary.GroupFooterSummaryItems = <> end object TreeListProcMetricsColumnStartTimeStamp: TcxTreeListColumn Caption.Text = 'Start Timestamp (mm:ss:zzz)' @@ -552,18 +690,35 @@ object MainForm: TMainForm Position.ColIndex = 3 Position.RowIndex = 0 Position.BandIndex = 0 + Summary.FooterSummaryItems = <> + Summary.GroupFooterSummaryItems = <> OnGetDisplayText = TreeListProcMetricsColumnStartTimeStampGetDisplayText end - object TreeListProcMetricsColumnExecutionID: TcxTreeListColumn - Caption.Text = '_ExecutionID' - DataBinding.ValueType = 'Integer' + object TreeListProcMetricsColumnCallCount: TcxTreeListColumn + Caption.Text = 'Call Count' + DataBinding.ValueType = 'LargeInt' + Options.Filtering = False Options.Moving = False + Options.Sorting = False Width = 120 - Position.ColIndex = 0 + Position.ColIndex = 4 Position.RowIndex = 0 Position.BandIndex = 0 - SortOrder = soDescending - SortIndex = 0 + Summary.FooterSummaryItems = <> + Summary.GroupFooterSummaryItems = <> + end + object TreeListProcMetricsColumnTimeTaken: TcxTreeListColumn + Caption.Text = 'TimeTaken' + DataBinding.ValueType = 'Float' + Options.Filtering = False + Options.Moving = False + Options.Sorting = False + Width = 150 + Position.ColIndex = 5 + Position.RowIndex = 0 + Position.BandIndex = 0 + Summary.FooterSummaryItems = <> + Summary.GroupFooterSummaryItems = <> end end object GridProcMetrics: TcxGrid @@ -638,6 +793,11 @@ object MainForm: TMainForm SortOrder = soAscending Width = 250 end + object GridTableViewProcMetricsColumnCallCount: TcxGridColumn + Caption = 'Call Count' + DataBinding.ValueType = 'LargeInt' + Width = 120 + end object GridTableViewProcMetricsColumnTimeTaken: TcxGridColumn Caption = 'Time Taken' DataBinding.ValueType = 'Float' @@ -676,12 +836,12 @@ object MainForm: TMainForm object dxSkinController: TdxSkinController NativeStyle = False SkinName = 'Foggy' - Left = 768 - Top = 120 + Left = 808 + Top = 152 end object cxStyleRepository: TcxStyleRepository - Left = 888 - Top = 120 + Left = 920 + Top = 152 PixelsPerInch = 96 object cxStyleTreeListProcMetricsBackground: TcxStyle AssignedValues = [svColor] @@ -694,7 +854,7 @@ object MainForm: TMainForm OnException = IdHTTPServerException OnListenException = IdHTTPServerListenException OnCommandGet = IdHTTPServerCommandGet - Left = 661 - Top = 118 + Left = 693 + Top = 150 end end diff --git a/Tools/CodeProfiler/_Source/Main.pas b/Tools/CodeProfiler/_Source/Main.pas index ed4913944..7708b09ff 100644 --- a/Tools/CodeProfiler/_Source/Main.pas +++ b/Tools/CodeProfiler/_Source/Main.pas @@ -2,6 +2,9 @@ interface +{$I Alcinoe.inc} +{$SCOPEDENUMS OFF} + uses Vcl.Forms, dxBarBuiltInMenu, cxGraphics, dxUIAClasses, cxControls, cxLookAndFeels, cxLookAndFeelPainters, cxContainer, cxEdit, Vcl.Menus, @@ -31,7 +34,7 @@ interface dxSkinXmas2008Blue, cxTL, cxTLdxBarBuiltInMenu, cxInplaceContainer, cxTreeView, cxTLData, cxSplitter, IdBaseComponent, IdComponent, IdCustomTCPServer, IdCustomHTTPServer, IdHTTPServer, IdContext, dxStatusBar, System.SysUtils, - System.SyncObjs; + System.SyncObjs, cxRadioGroup, cxCheckBox; type @@ -55,6 +58,7 @@ TMainForm = class(TForm) GridTableViewProcMetricsColumnProcName: TcxGridColumn; GridTableViewProcMetricsColumnThreadID: TcxGridColumn; GridTableViewProcMetricsColumnTimeTaken: TcxGridColumn; + GridTableViewProcMetricsColumnCallCount: TcxGridColumn; GridLevelProcMetrics: TcxGridLevel; LoadDataBtn: TcxButton; InstructionPanel: TdxPanel; @@ -72,6 +76,7 @@ TMainForm = class(TForm) cxSplitter1: TcxSplitter; cxStyleTreeListProcMetricsBackground: TcxStyle; TreeListProcMetricsColumnStartTimeStamp: TcxTreeListColumn; + TreeListProcMetricsColumnCallCount: TcxTreeListColumn; GridTableViewProcMetricsColumnStartTimestamp: TcxGridColumn; LastInstructionLabel: TcxLabel; StartTimeStampMinEdit: TcxMaskEdit; @@ -92,10 +97,21 @@ TMainForm = class(TForm) cxLabel14: TcxLabel; ClearDataBtn: TcxButton; ExportToCsvBtn: TcxButton; + dxPanel4: TdxPanel; + DoNotGroupRadioButton: TcxRadioButton; + GroupCallsByProcIDRadioButton: TcxRadioButton; + GroupCallsByCallStackRadioButton: TcxRadioButton; + cxLabel15: TcxLabel; + dxPanel5: TdxPanel; + BrowseCodeProfilerIncFilenameBtn: TcxButton; + CodeProfilerIncFilenameEdit: TcxTextEdit; + dxPanel6: TdxPanel; + CodeProfilerEnabledCheckBox: TcxCheckBox; procedure InsertProfilerMarkersBtnClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure LoadDataBtnClick(Sender: TObject); + procedure ClearDataBtnClick(Sender: TObject); procedure GridTableViewProcMetricsCellDblClick( Sender: TcxCustomGridTableView; ACellViewInfo: TcxGridTableDataCellViewInfo; @@ -110,11 +126,16 @@ TMainForm = class(TForm) procedure TreeListProcMetricsColumnStartTimeStampGetDisplayText(Sender: TcxTreeListColumn; ANode: TcxTreeListNode; var Value: string); procedure PanelfilterResize(Sender: TObject); procedure HttpServerPortEditPropertiesChange(Sender: TObject); + procedure HttpServerNameEditPropertiesChange(Sender: TObject); procedure IdHTTPServerCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); procedure IdHTTPServerException(AContext: TIdContext; AException: Exception); procedure IdHTTPServerListenException(AThread: TIdListenerThread; AException: Exception); procedure IdHTTPServerConnect(AContext: TIdContext); procedure ExportToCsvBtnClick(Sender: TObject); + procedure HistoryGroupModeRadioButtonClick(Sender: TObject); + procedure CodeProfilerIncFilenameEditPropertiesChange(Sender: TObject); + procedure BrowseCodeProfilerIncFilenameBtnClick(Sender: TObject); + procedure CodeProfilerEnabledCheckBoxPropertiesChange(Sender: TObject); private const ConfigFilename = 'Config.ini'; private @@ -125,24 +146,104 @@ TGoBackStackItem = record SortColumnIndex: Integer; SortOrder: TcxGridSortOrder; end; + // Mirrors the ALCodeProfilerHistoryGroupXXX modes selected via the + // radio buttons at runtime, so this tool never needs to be recompiled + // just because Alcinoe.CodeProfiler.inc's active mode changed. + TALCodeProfilerHistoryGroupMode = (hgmNone, hgmByProcID, hgmByCallStack); + // Raw, on-disk layouts. These intentionally mirror the field lists of + // Alcinoe.CodeProfiler.TALProcMetrics for each mode so the compiler + // computes the exact same size/offsets that the profiled app used + // when writing the .dat file. + TALProcMetricsNone = record + ExecutionID: Cardinal; + ParentExecutionID: Cardinal; + ProcID: Cardinal; + ThreadID: Cardinal; + StartTimeStamp: Int64; + ElapsedTicks: Int64; + end; + TALProcMetricsByProcID = record + ProcID: Cardinal; + ThreadID: Cardinal; + CallCount: Cardinal; + ElapsedTicks: Int64; + end; + TALProcMetricsByCallStack = record + HashCode: Integer; + ProcID: Cardinal; + MetricsID: Cardinal; + ParentMetricsID: Cardinal; + ThreadID: Cardinal; + CallCount: Cardinal; + ElapsedTicks: Int64; + end; + // In-memory, mode-agnostic representation decoded from whichever raw + // layout above matches FHistoryGroupMode. Fields not meaningful for + // the current mode are left at 0. + TALProcMetrics = record + ExecutionID: Cardinal; + ParentExecutionID: Cardinal; + ProcID: Cardinal; + MetricsID: Cardinal; + ParentMetricsID: Cardinal; + ThreadID: Cardinal; + StartTimeStamp: Int64; + ElapsedTicks: Int64; + CallCount: Cardinal; + end; + // CSV columns available across the three modes (CSV export). + TALProcMetricsColumnKind = ( + colkExecutionID, colkParentExecutionID, colkProcID, colkMetricsID, colkParentMetricsID, + colkProcName, colkThreadID, colkStartTimeStamp, colkCallCount, colkTimeTaken); private FDataDir: String; + // Set while the UI is being populated from Config.ini or from + // Alcinoe.CodeProfiler.inc, so that the change events raised by that + // population do not write the settings back to Alcinoe.CodeProfiler.inc. + FLoadingSettings: Boolean; FProcIDSequence: Integer; + FHistoryGroupMode: TALCodeProfilerHistoryGroupMode; FProcMetrics: TArray; FProcIDMap: TALHashedStringListA; FTreeListProcMetricsTailNode: TcxTreeListNode; + FTreeListProcMetricsRootNode: TcxTreeListNode; FFilterProcIDs: THashSet; FFilterExecutionIDs: THashSet; FFilterParentExecutionIDs: THashSet; FFilterStartTimeStampMin: Int64; FFilterStartTimeStampMax: Int64; FOverrideFilterParentExecutionID: Cardinal; + FOverrideFilterThreadID: Cardinal; // High(Cardinal) means "no thread filter" FGoBackStack: TDictionary; FHttpServerCriticalSection: TCriticalSection; procedure ResetFilters; + procedure ResetTreeListProcMetrics; Procedure RemoveMarkers(const AFileName: String); Procedure InsertMarkers(const AFileName: String; Const AProcIDMap: TALStringListA); procedure Refresh; + function GetSelectedHistoryGroupModeEnum: TALCodeProfilerHistoryGroupMode; + function GetSelectedHistoryGroupMode: AnsiString; + procedure SelectHistoryGroupMode(const AHistoryGroupMode: String); + procedure UpdateHistoryGroupModeUI; + function GetSelectedProcMetricsFilename: String; + function GetProcMetricsRawRecordSize(const AHistoryGroupMode: TALCodeProfilerHistoryGroupMode): Integer; + procedure DecodeProcMetricsRaw( + const AHistoryGroupMode: TALCodeProfilerHistoryGroupMode; + const ARawBuffer: TBytes; + const AOffset: Integer; + out ARec: TALProcMetrics); + function GetProcMetricsColumnsForMode(const AHistoryGroupMode: TALCodeProfilerHistoryGroupMode): TArray; + function GetProcMetricsColumnName(const AKind: TALProcMetricsColumnKind): AnsiString; + function GetProcMetricsColumnValue( + const AKind: TALProcMetricsColumnKind; + const ARec: TALProcMetrics; + const AProcNames: TDictionary): AnsiString; + function GetSelectedServerName: AnsiString; + procedure SelectServerName(const AServerName: String); + function GetCodeProfilerIncFilename: String; + procedure SaveCodeProfilerIncFile; + procedure LoadCodeProfilerIncFile; + procedure SaveConfigFile; public end; @@ -220,6 +321,389 @@ procedure TMainForm.ResetFilters; FFilterStartTimeStampMin := 0; FFilterStartTimeStampMax := 0; FOverrideFilterParentExecutionID := 0; + FOverrideFilterThreadID := High(Cardinal); +end; + +{*******************************************************************} +procedure TMainForm.ResetTreeListProcMetrics; +begin + TreeListProcMetrics.Clear; + // Always keep a "..." root node visible so the user has an obvious, + // clickable way back to the root instead of having to guess that + // double-clicking empty space resets the drill-down. + FTreeListProcMetricsTailNode := TreeListProcMetrics.Add; + FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnProcName.ItemIndex] := '...'; + FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnExecutionID.ItemIndex] := '0'; + // Leave the ThreadID cell blank for the root node (there is no single + // thread to show); FTreeListProcMetricsRootNode is used instead of this + // column's value to detect the root node and clear the thread filter. + FTreeListProcMetricsRootNode := FTreeListProcMetricsTailNode; +end; + +{*******************************************************************} +function TMainForm.GetSelectedHistoryGroupModeEnum: TALCodeProfilerHistoryGroupMode; +begin + if DoNotGroupRadioButton.Checked then Result := hgmNone + else if GroupCallsByProcIDRadioButton.Checked then Result := hgmByProcID + else Result := hgmByCallStack; +end; + +{*******************************************************************} +function TMainForm.GetSelectedHistoryGroupMode: AnsiString; +begin + case GetSelectedHistoryGroupModeEnum of + hgmNone: Result := 'ALCodeProfilerHistoryGroupNone'; + hgmByProcID: Result := 'ALCodeProfilerHistoryGroupByProcID'; + else Result := 'ALCodeProfilerHistoryGroupByCallStack'; + end; +end; + +{*******************************************************************************} +procedure TMainForm.SelectHistoryGroupMode(const AHistoryGroupMode: String); +begin + if ALSameTextW(AHistoryGroupMode, 'ALCodeProfilerHistoryGroupNone') then DoNotGroupRadioButton.Checked := True + else if ALSameTextW(AHistoryGroupMode, 'ALCodeProfilerHistoryGroupByProcID') then GroupCallsByProcIDRadioButton.Checked := True + else GroupCallsByCallStackRadioButton.Checked := True; +end; + +{*******************************************************************} +procedure TMainForm.UpdateHistoryGroupModeUI; +begin + case GetSelectedHistoryGroupModeEnum of + hgmNone: begin + TreeListProcMetricsColumnStartTimeStamp.Visible := True; + GridTableViewProcMetricsColumnStartTimestamp.Visible := True; + TreeListProcMetricsColumnCallCount.Visible := False; + GridTableViewProcMetricsColumnCallCount.Visible := False; + // The start-timestamp filter only makes sense for individual calls, + // which only exist in hgmNone; grouped modes have no StartTimeStamp. + StartTimeStampMinEdit.Enabled := True; + StartTimeStampMaxEdit.Enabled := True; + end; + else begin + TreeListProcMetricsColumnStartTimeStamp.Visible := False; + GridTableViewProcMetricsColumnStartTimestamp.Visible := False; + TreeListProcMetricsColumnCallCount.Visible := True; + GridTableViewProcMetricsColumnCallCount.Visible := True; + StartTimeStampMinEdit.Enabled := False; + StartTimeStampMaxEdit.Enabled := False; + end; + end; +end; + +{*******************************************************************} +function TMainForm.GetSelectedProcMetricsFilename: String; +begin + case GetSelectedHistoryGroupModeEnum of + hgmNone: Result := 'ALCodeProfilerProcMetrics.None.dat'; + hgmByProcID: Result := 'ALCodeProfilerProcMetrics.ByProcID.dat'; + else Result := 'ALCodeProfilerProcMetrics.ByCallStack.dat'; + end; +end; + +{*******************************************************************} +function TMainForm.GetProcMetricsRawRecordSize(const AHistoryGroupMode: TALCodeProfilerHistoryGroupMode): Integer; +begin + case AHistoryGroupMode of + hgmNone: Result := SizeOf(TALProcMetricsNone); + hgmByProcID: Result := SizeOf(TALProcMetricsByProcID); + else Result := SizeOf(TALProcMetricsByCallStack); + end; +end; + +{*******************************************************************} +procedure TMainForm.DecodeProcMetricsRaw( + const AHistoryGroupMode: TALCodeProfilerHistoryGroupMode; + const ARawBuffer: TBytes; + const AOffset: Integer; + out ARec: TALProcMetrics); +begin + FillChar(ARec, SizeOf(ARec), 0); + case AHistoryGroupMode of + hgmNone: begin + var LRaw: TALProcMetricsNone; + Move(ARawBuffer[AOffset], LRaw, SizeOf(LRaw)); + ARec.ExecutionID := LRaw.ExecutionID; + ARec.ParentExecutionID := LRaw.ParentExecutionID; + ARec.ProcID := LRaw.ProcID; + ARec.ThreadID := LRaw.ThreadID; + ARec.StartTimeStamp := LRaw.StartTimeStamp; + ARec.ElapsedTicks := LRaw.ElapsedTicks; + end; + hgmByProcID: begin + var LRaw: TALProcMetricsByProcID; + Move(ARawBuffer[AOffset], LRaw, SizeOf(LRaw)); + ARec.ProcID := LRaw.ProcID; + ARec.ThreadID := LRaw.ThreadID; + ARec.CallCount := LRaw.CallCount; + ARec.ElapsedTicks := LRaw.ElapsedTicks; + end; + hgmByCallStack: begin + var LRaw: TALProcMetricsByCallStack; + Move(ARawBuffer[AOffset], LRaw, SizeOf(LRaw)); + ARec.ProcID := LRaw.ProcID; + ARec.MetricsID := LRaw.MetricsID; + ARec.ParentMetricsID := LRaw.ParentMetricsID; + ARec.ThreadID := LRaw.ThreadID; + ARec.CallCount := LRaw.CallCount; + ARec.ElapsedTicks := LRaw.ElapsedTicks; + end; + end; +end; + +{*******************************************************************} +function TMainForm.GetProcMetricsColumnsForMode(const AHistoryGroupMode: TALCodeProfilerHistoryGroupMode): TArray; +begin + case AHistoryGroupMode of + hgmNone: Result := [colkExecutionID, colkParentExecutionID, colkProcID, colkProcName, colkThreadID, colkStartTimeStamp, colkTimeTaken]; + hgmByProcID: Result := [colkProcID, colkProcName, colkThreadID, colkCallCount, colkTimeTaken]; + else Result := [colkProcID, colkMetricsID, colkParentMetricsID, colkProcName, colkThreadID, colkCallCount, colkTimeTaken]; + end; +end; + +{*******************************************************************} +function TMainForm.GetProcMetricsColumnName(const AKind: TALProcMetricsColumnKind): AnsiString; +begin + case AKind of + colkExecutionID: Result := 'ExecutionID'; + colkParentExecutionID: Result := 'ParentExecutionID'; + colkProcID: Result := 'ProcID'; + colkMetricsID: Result := 'MetricsID'; + colkParentMetricsID: Result := 'ParentMetricsID'; + colkProcName: Result := 'ProcName'; + colkThreadID: Result := 'ThreadID'; + colkStartTimeStamp: Result := 'StartTimeStamp'; + colkCallCount: Result := 'CallCount'; + else Result := 'TimeTaken'; + end; +end; + +{*******************************************************************} +function TMainForm.GetProcMetricsColumnValue( + const AKind: TALProcMetricsColumnKind; + const ARec: TALProcMetrics; + const AProcNames: TDictionary): AnsiString; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _TicksToMillisecondsStr(const ATicks: Int64): AnsiString; + begin + // 1 tick equals 0.0001 millisecond (ALCodeProfilerMillisecondsPerTick), + // so use integer arithmetic to avoid any rounding/locale issue + Result := ALIntToStrA(ATicks div 10000) + '.' + ALFormatA('%.4d', [ATicks mod 10000]); + end; + +begin + case AKind of + colkExecutionID: Result := ALIntToStrA(ARec.ExecutionID); + colkParentExecutionID: Result := ALIntToStrA(ARec.ParentExecutionID); + colkProcID: Result := ALIntToStrA(ARec.ProcID); + colkMetricsID: Result := ALIntToStrA(ARec.MetricsID); + colkParentMetricsID: Result := ALIntToStrA(ARec.ParentMetricsID); + colkProcName: begin + var LProcName: AnsiString; + if not AProcNames.TryGetValue(ARec.ProcID, LProcName) then LProcName := ''; + Result := LProcName; + end; + colkThreadID: Result := ALIntToStrA(ARec.ThreadID); + colkStartTimeStamp: Result := _TicksToMillisecondsStr(ARec.StartTimeStamp); + colkCallCount: Result := ALIntToStrA(ARec.CallCount); + else Result := _TicksToMillisecondsStr(ARec.ElapsedTicks); + end; +end; + +{*******************************************************************} +function TMainForm.GetSelectedServerName: AnsiString; +begin + if (ALTrim(HttpServerNameEdit.Text) <> '') and (ALTrim(HttpServerPortEdit.Text) <> '') then + Result := AnsiString('http://'+ALTrim(HttpServerNameEdit.Text)+':'+ALTrim(HttpServerPortEdit.Text)) + else + Result := ''; +end; + +{*******************************************************************} +procedure TMainForm.SelectServerName(const AServerName: String); +begin + var LServerName := AServerName; + if ALPosW('http://', LServerName) = 1 then Delete(LServerName, 1, Length('http://')); + var LColonPos := LastDelimiter(':', LServerName); + if LColonPos > 0 then begin + HttpServerNameEdit.Text := ALCopyStr(LServerName, 1, LColonPos - 1); + HttpServerPortEdit.Text := ALCopyStr(LServerName, LColonPos + 1, MaxInt); + end + else begin + HttpServerNameEdit.Text := LServerName; + HttpServerPortEdit.Text := '8080'; + end; +end; + +{*****************************************************************************} +procedure TMainForm.HistoryGroupModeRadioButtonClick(Sender: TObject); +begin + UpdateHistoryGroupModeUI; + SaveCodeProfilerIncFile; +end; + +{**********************************************************} +function TMainForm.GetCodeProfilerIncFilename: String; +begin + Result := ALTrim(CodeProfilerIncFilenameEdit.Text); + if Result = '' then exit; + // A relative path is relative to the folder of this tool, so that the + // default value (..\..\Source\Alcinoe.CodeProfiler.inc) keeps working + // whatever the location of the Alcinoe repository. + if TPath.IsRelativePath(Result) then Result := ALGetModulePathW + Result; + Result := ExpandFileName(Result); +end; + +{*******************************************} +procedure TMainForm.SaveCodeProfilerIncFile; +var + LHistoryGroupMode: AnsiString; + + {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} + function _DefineLine(const AHistoryGroupModeName: AnsiString): AnsiString; + begin + if ALSameTextA(AHistoryGroupModeName, LHistoryGroupMode) then Result := '{$DEFINE ' + AHistoryGroupModeName + '}' + else Result := '{.$DEFINE ' + AHistoryGroupModeName + '}'; + end; + +begin + // Never write Alcinoe.CodeProfiler.inc while the UI is still being populated + // from Config.ini / Alcinoe.CodeProfiler.inc, else the values just loaded + // would be written back, possibly to a file that is not the selected one yet. + if FLoadingSettings then exit; + var LIncFilename := GetCodeProfilerIncFilename; + if LIncFilename = '' then exit; + LHistoryGroupMode := GetSelectedHistoryGroupMode; + var LContent: AnsiString := + 'var'#10 + + ' ALCodeProfilerEnabled: Boolean = '+ALIfThenA(CodeProfilerEnabledCheckBox.Checked, 'True', 'False')+';'#10 + + ' ALCodeProfilerServerName: String = '''+GetSelectedServerName+''';'#10 + + #10 + + '// Do not group calls. Each function/procedure call generates one row.'#10 + + '// The result will be displayed as a call tree, for example:'#10 + + '// procedure A - 1 call - 310 ms'#10 + + '// procedure B - 1 call - 215 ms'#10 + + '// procedure C - 1 call - 14 ms'#10 + + '// procedure C - 1 call - 11 ms'#10 + + '// procedure D - 1 call - 85 ms'#10 + + '// procedure C - 1 call - 21 ms'#10 + + '// procedure B - 1 call - 35 ms'#10 + + '// procedure B - 1 call - 41 ms'#10 + + '// procedure C - 1 call - 22 ms'#10 + + '//'#10 + + '// NOTE: This option can use a lot of memory. If you enable it, it is recommended'#10 + + '// to limit profiling to the specific code you want to measure by using'#10 + + '// ALCodeProfilerStart and ALCodeProfilerStop.'#10 + + _DefineLine('ALCodeProfilerHistoryGroupNone') + #10 + + #10 + + '// Group calls by procedure ID.'#10 + + '// The result will be displayed as a flat grid, for example:'#10 + + '// procedure A - 1 call - 310 ms'#10 + + '// procedure B - 3 calls - 291 ms'#10 + + '// procedure C - 4 calls - 68 ms'#10 + + '// procedure D - 1 call - 85 ms'#10 + + '//'#10 + + '// NOTE: This is the fastest option and has the lowest impact on each function call.'#10 + + _DefineLine('ALCodeProfilerHistoryGroupByProcID') + #10 + + #10 + + '// Group calls by call stack.'#10 + + '// The result will be displayed as a grouped call tree, for example:'#10 + + '// procedure A - 1 call - 310 ms'#10 + + '// procedure B - 3 calls - 291 ms'#10 + + '// procedure C - 3 calls - 46 ms'#10 + + '// procedure D - 1 call - 85 ms'#10 + + '// procedure C - 1 call - 22 ms'#10 + + _DefineLine('ALCodeProfilerHistoryGroupByCallStack') + #10; + ALSaveStringToFile(LContent, LIncFilename); +end; + +{*******************************************} +procedure TMainForm.LoadCodeProfilerIncFile; +begin + var LIncFilename := GetCodeProfilerIncFilename; + var LContent: AnsiString := ''; + if (LIncFilename <> '') and TFile.Exists(LIncFilename) then LContent := ALGetStringFromFile(LIncFilename); + // Populating the controls below raises their OnChange event, which would + // otherwise save these very same values back to Alcinoe.CodeProfiler.inc. + FLoadingSettings := True; + try + //-- + if ALPosA('{$DEFINE ALCodeProfilerHistoryGroupNone}', LContent) > 0 then SelectHistoryGroupMode('ALCodeProfilerHistoryGroupNone') + else if ALPosA('{$DEFINE ALCodeProfilerHistoryGroupByProcID}', LContent) > 0 then SelectHistoryGroupMode('ALCodeProfilerHistoryGroupByProcID') + else SelectHistoryGroupMode('ALCodeProfilerHistoryGroupByCallStack'); + //-- + var LServerName: String := ''; + var LMarker: AnsiString := 'ALCodeProfilerServerName: String = '''; + var LValueStart := ALPosA(LMarker, LContent); + if LValueStart > 0 then begin + inc(LValueStart, Length(LMarker)); + var LValueEnd := ALPosA('''', LContent, LValueStart); + if LValueEnd > LValueStart then + LServerName := String(ALCopyStr(LContent, LValueStart, LValueEnd - LValueStart)); + end; + SelectServerName(LServerName); + //-- + var LEnabled := True; + LMarker := 'ALCodeProfilerEnabled: Boolean = '; + LValueStart := ALPosA(LMarker, LContent); + if LValueStart > 0 then begin + inc(LValueStart, Length(LMarker)); + LEnabled := not ALSameTextA(ALCopyStr(LContent, LValueStart, Length('False')), 'False'); + end; + CodeProfilerEnabledCheckBox.Checked := LEnabled; + finally + FLoadingSettings := False; + end; +end; + +{*********************************} +procedure TMainForm.SaveConfigFile; +begin + var LIniFile := TIniFile.Create(TPath.Combine(FDataDir, ConfigFilename)); + try + LIniFile.WriteString('General','SourcesPath',ALStringReplaceW(ALTrim(SourcesPathMemo.Text), #13#10, ';', [RfReplaceALL])); + LIniFile.WriteString('General','CodeProfilerIncFilename',ALTrim(CodeProfilerIncFilenameEdit.Text)); + finally + ALFreeAndNil(LIniFile); + end; +end; + +{*******************************************************************************} +procedure TMainForm.CodeProfilerIncFilenameEditPropertiesChange(Sender: TObject); +begin + if FLoadingSettings then exit; + SaveConfigFile; + // Reload the options only once the typed path points to an existing file, + // else every intermediate keystroke would reset them to their defaults. + if TFile.Exists(GetCodeProfilerIncFilename) then LoadCodeProfilerIncFile; +end; + +{***************************************************************************} +procedure TMainForm.BrowseCodeProfilerIncFilenameBtnClick(Sender: TObject); +begin + var LOpenDialog := TOpenDialog.Create(nil); + try + LOpenDialog.Title := 'Select Alcinoe.CodeProfiler.inc'; + LOpenDialog.Filter := 'Alcinoe.CodeProfiler.inc|Alcinoe.CodeProfiler.inc|Include files (*.inc)|*.inc|All files (*.*)|*.*'; + LOpenDialog.DefaultExt := 'inc'; + LOpenDialog.Options := LOpenDialog.Options + [ofFileMustExist, ofPathMustExist]; + var LIncFilename := GetCodeProfilerIncFilename; + if LIncFilename <> '' then begin + LOpenDialog.InitialDir := ALExtractFilePath(LIncFilename); + LOpenDialog.FileName := LIncFilename; + end; + if LOpenDialog.Execute(Handle) then + CodeProfilerIncFilenameEdit.Text := LOpenDialog.FileName; + finally + ALFreeAndNil(LOpenDialog); + end; +end; + +{*******************************************************************************} +procedure TMainForm.CodeProfilerEnabledCheckBoxPropertiesChange(Sender: TObject); +begin + SaveCodeProfilerIncFile; end; {*********************************************************} @@ -252,7 +736,7 @@ procedure TMainForm.RemoveProfilerMarkersBtnClick(Sender: TObject); finally RemoveProfilerMarkersBtn.Cursor := crDefault; End; - var LProcMetricsFilename := TPath.Combine(FDataDir, ALCodeProfilerProcMetricsFilename); + var LProcMetricsFilename := TPath.Combine(FDataDir, GetSelectedProcMetricsFilename); If TFile.Exists(LProcMetricsFilename) then TFile.Delete(LProcMetricsFilename); var LProcIDMapFilename := TPath.Combine(FDataDir, ALCodeProfilerProcIDMapFilename); @@ -272,8 +756,16 @@ procedure TMainForm.IdHTTPServerCommandGet(AContext: TIdContext; ARequestInfo: T // We're only handling POST requests here. if ARequestInfo.CommandType = hcPOST then begin - // Define the file path where the POST content will be saved. - var LProcMetricsTmpFilename := TPath.Combine(FDataDir, ALCodeProfilerProcMetricsFilename + '~tmp'); + // Define the file path where the POST content will be saved. The + // filename depends on the currently selected radio button, so it + // must be read on the main thread. + var LProcMetricsFilename: String; + TThread.Synchronize(nil, + procedure + begin + LProcMetricsFilename := TPath.Combine(FDataDir, GetSelectedProcMetricsFilename); + end); + var LProcMetricsTmpFilename := LProcMetricsFilename + '~tmp'; If TFile.Exists(LProcMetricsTmpFilename) then TFile.Delete(LProcMetricsTmpFilename); if Assigned(ARequestInfo.PostStream) then @@ -297,7 +789,6 @@ procedure TMainForm.IdHTTPServerCommandGet(AContext: TIdContext; ARequestInfo: T procedure begin Try - var LProcMetricsFilename := TPath.Combine(FDataDir, ALCodeProfilerProcMetricsFilename); If TFile.Exists(LProcMetricsFilename) then TFile.Delete(LProcMetricsFilename); TFile.Move(LProcMetricsTmpFilename, LProcMetricsFilename); @@ -469,38 +960,6 @@ TMarkerInsertion = record end; end; - {*************************************************************************************} - function HasAncestorOfType(const ANode: TSyntaxNode; const ANodeType: TSyntaxNodeType): Boolean; - begin - var LParent := ANode.ParentNode; - while Assigned(LParent) do begin - if LParent.Typ = ANodeType then - Exit(True); - LParent := LParent.ParentNode; - end; - Result := False; - end; - - {*******************************************************************} - function FindRootStatements(const ANode: TSyntaxNode): TCompoundSyntaxNode; - begin - Result := nil; - if not Assigned(ANode) then - Exit; - if (ANode.Typ = ntStatements) and - (ANode is TCompoundSyntaxNode) and - (not HasAncestorOfType(ANode, ntMethod)) and - (not HasAncestorOfType(ANode, ntAnonymousMethod)) then begin - Result := TCompoundSyntaxNode(ANode); - Exit; - end; - for var LChild in ANode.ChildNodes do begin - Result := FindRootStatements(LChild); - if Assigned(Result) then - Exit; - end; - end; - {****************************************************************} function GetMethodStatements(const ANode: TSyntaxNode): TCompoundSyntaxNode; begin @@ -559,13 +1018,13 @@ TMarkerInsertion = record ASourceCode, LStatements.Line, LBeginInsertionCol, - '{ALCodeProfiler>>}ALCodeProfilerEnterProc('+ALIntToStrA(FProcIDSequence){$IF defined(debug)}+'{ '+LProcName+' }'{$ENDIF}+'); try{<>}ALCodeProfilerEnterProc('+ALIntToStrA(FProcIDSequence)+'); try{<>}finally ALCodeProfilerExitProc('+ALIntToStrA(FProcIDSequence){$IF defined(debug)}+'{ '+LProcName+' }'{$ENDIF}+'); end;{<>}finally ALCodeProfilerExitProc('+ALIntToStrA(FProcIDSequence)+'); end;{<>}{$DEFINE ALCodeProfiler}uses Alcinoe.CodeProfiler;{< '') and - (ALTrim(HttpServerPortEdit.Text) <> '') then begin - var LRootStatements := FindRootStatements(LSyntaxTree); - if Assigned(LRootStatements) then begin - var LBeginInsertionCol := FindBeginInsertionColumn(LSourceCode, LRootStatements.Line, LRootStatements.Col); - if LBeginInsertionCol > 0 then - AddInsertion( - LInsertions, - LSourceCode, - LRootStatements.Line, - LBeginInsertionCol, - '{ALCodeProfiler>>}ALCodeProfilerServerName := ''http://'+ALTrim(AnsiString(HttpServerNameEdit.Text))+':'+ALTrim(AnsiString(HttpServerPortEdit.Text))+''';{< 0 then begin - if FProcMetrics[i].ParentExecutionID <> FOverrideFilterParentExecutionID then - continue; - //-- - if (FFilterStartTimeStampMin > 0) and - (FProcMetrics[i].StartTimeStamp + FProcMetrics[i].ElapsedTicks < FFilterStartTimeStampMin) then - continue; - //-- - if (FFilterStartTimeStampMax > 0) and - (FProcMetrics[i].StartTimeStamp > FFilterStartTimeStampMax) then - continue; - end - else begin - if (FFilterParentExecutionIDs.Count > 0) and - (not FFilterParentExecutionIDs.Contains(FProcMetrics[i].ParentExecutionID)) then - continue; - //-- - if (FFilterExecutionIDs.Count > 0) and - (not FFilterExecutionIDs.Contains(FProcMetrics[i].ExecutionID)) then - continue; - //-- - if (FFilterProcIDs.Count > 0) and - (not FFilterProcIDs.Contains(FProcMetrics[i].ProcID)) then - continue; + case FHistoryGroupMode of + hgmNone: begin + if FOverrideFilterParentExecutionID <> 0 then begin + if FProcMetrics[i].ParentExecutionID <> FOverrideFilterParentExecutionID then + continue; + //-- + if (FOverrideFilterThreadID <> High(Cardinal)) and + (FProcMetrics[i].ThreadID <> FOverrideFilterThreadID) then + continue; + //-- + if (FFilterStartTimeStampMin > 0) and + (FProcMetrics[i].StartTimeStamp + FProcMetrics[i].ElapsedTicks < FFilterStartTimeStampMin) then + continue; + //-- + if (FFilterStartTimeStampMax > 0) and + (FProcMetrics[i].StartTimeStamp > FFilterStartTimeStampMax) then + continue; + end + else begin + if (FFilterParentExecutionIDs.Count > 0) and + (not FFilterParentExecutionIDs.Contains(FProcMetrics[i].ParentExecutionID)) then + continue; + //-- + if (FFilterExecutionIDs.Count > 0) and + (not FFilterExecutionIDs.Contains(FProcMetrics[i].ExecutionID)) then + continue; + //-- + if (FFilterProcIDs.Count > 0) and + (not FFilterProcIDs.Contains(FProcMetrics[i].ProcID)) then + continue; + end; + end; + hgmByCallStack: begin + if FOverrideFilterParentExecutionID <> 0 then begin + if FProcMetrics[i].ParentMetricsID <> FOverrideFilterParentExecutionID then + continue; + //-- + if (FOverrideFilterThreadID <> High(Cardinal)) and + (FProcMetrics[i].ThreadID <> FOverrideFilterThreadID) then + continue; + end + else begin + if (FFilterParentExecutionIDs.Count > 0) and + (not FFilterParentExecutionIDs.Contains(FProcMetrics[i].ParentMetricsID)) then + continue; + //-- + if (FFilterProcIDs.Count > 0) and + (not FFilterProcIDs.Contains(FProcMetrics[i].ProcID)) then + continue; + end; + end; + hgmByProcID: begin + if (FFilterProcIDs.Count > 0) and + (not FFilterProcIDs.Contains(FProcMetrics[i].ProcID)) then + continue; + end; end; var LRecordCount := GridTableViewProcMetrics.DataController.RecordCount; inc(LRecordCount); GridTableViewProcMetrics.DataController.RecordCount := LRecordCount; - GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnExecutionID.Index, FProcMetrics[i].ExecutionID); + // No per-call ExecutionID exists in grouped modes, so a mode-specific + // surrogate is reused as the row identity: ProcID is unique enough in + // hgmByProcID (there is only ever one row per ProcID), but in + // hgmByCallStack the same ProcID can appear under different + // parents, so MetricsID (unique per row, and also the drill-down key + // matched against ParentMetricsID above) must be used instead. + case FHistoryGroupMode of + hgmNone: GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnExecutionID.Index, FProcMetrics[i].ExecutionID); + hgmByProcID: GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnExecutionID.Index, FProcMetrics[i].ProcID); + hgmByCallStack: GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnExecutionID.Index, FProcMetrics[i].MetricsID); + end; GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnThreadID.Index, FProcMetrics[i].ThreadID); GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnProcName.Index, String(FProcIDMap.Values[ALIntToStrA(FProcMetrics[i].ProcID)])); - GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnStartTimeStamp.Index, FProcMetrics[i].StartTimeStamp * ALCodeProfilerMillisecondsPerTick); + if FHistoryGroupMode = hgmNone then + GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnStartTimestamp.Index, FProcMetrics[i].StartTimeStamp * ALCodeProfilerMillisecondsPerTick) + else + GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnCallCount.Index, FProcMetrics[i].CallCount); GridTableViewProcMetrics.DataController.SetValue(LRecordCount-1, GridTableViewProcMetricsColumnTimeTaken.Index, FProcMetrics[i].ElapsedTicks * ALCodeProfilerMillisecondsPerTick); end; finally @@ -795,37 +1277,63 @@ procedure TMainForm.Refresh; {****************************************************} procedure TMainForm.LoadDataBtnClick(Sender: TObject); begin - var LProcMetricsFilename := TPath.Combine(FDataDir, ALCodeProfilerProcMetricsFilename); + FHistoryGroupMode := GetSelectedHistoryGroupModeEnum; + var LProcMetricsFilenameOnly := GetSelectedProcMetricsFilename; + var LProcMetricsFilename := TPath.Combine(FDataDir, LProcMetricsFilenameOnly); If not TFile.Exists(LProcMetricsFilename) then raise Exception.CreateFmt( 'The required file "%s" is missing. Please make '+ 'sure it is available in the data subfolder where '+ 'Alcinoe Code Profiler is located before proceeding.', - [ALCodeProfilerProcMetricsFilename]); + [LProcMetricsFilenameOnly]); LoadDataBtn.Cursor := crHourGlass; Try // Load ALCodeProfilerProcMetrics.dat in FProcMetrics + var LRawRecordSize := GetProcMetricsRawRecordSize(FHistoryGroupMode); Var LfileStream := TfileStream.Create(LProcMetricsFilename, fmOpenRead); try - setlength(FProcMetrics, LfileStream.Size div SizeOf(TALProcMetrics)); - if length(FProcMetrics) > 0 then - LfileStream.ReadBuffer(FProcMetrics[0], length(FProcMetrics) * SizeOf(TALProcMetrics)); + if LfileStream.Size mod LRawRecordSize <> 0 then + raise Exception.CreateFmt('The file "%s" is corrupted', [LProcMetricsFilenameOnly]); + var LRawBytes: TBytes; + SetLength(LRawBytes, LfileStream.Size); + if Length(LRawBytes) > 0 then + LfileStream.ReadBuffer(LRawBytes[0], Length(LRawBytes)); + setlength(FProcMetrics, Length(LRawBytes) div LRawRecordSize); + for var I := low(FProcMetrics) to high(FProcMetrics) do + DecodeProcMetricsRaw(FHistoryGroupMode, LRawBytes, I * LRawRecordSize, FProcMetrics[i]); finally ALFreeandNil(LfileStream); end; // Update orphan node - Var LDictionary := TDictionary.Create; - try - For var I := low(FProcMetrics) to High(FProcMetrics) do - LDictionary.Add(FProcMetrics[i].ExecutionID, true); - var LBool: Boolean; - For var I := low(FProcMetrics) to High(FProcMetrics) do - if not LDictionary.TryGetValue(FProcMetrics[i].ParentExecutionID, LBool) then - FProcMetrics[i].ParentExecutionID := 0; - finally - AlFreeAndNil(LDictionary); + case FHistoryGroupMode of + hgmNone: begin + Var LDictionary := TDictionary.Create; + try + For var I := low(FProcMetrics) to High(FProcMetrics) do + LDictionary.Add(FProcMetrics[i].ExecutionID, true); + var LBool: Boolean; + For var I := low(FProcMetrics) to High(FProcMetrics) do + if not LDictionary.TryGetValue(FProcMetrics[i].ParentExecutionID, LBool) then + FProcMetrics[i].ParentExecutionID := 0; + finally + AlFreeAndNil(LDictionary); + end; + end; + hgmByCallStack: begin + Var LDictionary := TDictionary.Create; + try + For var I := low(FProcMetrics) to High(FProcMetrics) do + LDictionary.AddOrSetValue(FProcMetrics[i].MetricsID, true); + var LBool: Boolean; + For var I := low(FProcMetrics) to High(FProcMetrics) do + if not LDictionary.TryGetValue(FProcMetrics[i].ParentMetricsID, LBool) then + FProcMetrics[i].ParentMetricsID := 0; + finally + AlFreeAndNil(LDictionary); + end; + end; end; // Load ALCodeProfilerProcIDMap.txt in FProcIDMap @@ -840,8 +1348,7 @@ procedure TMainForm.LoadDataBtnClick(Sender: TObject); FFilterParentExecutionIDs.Add(0); // Reset TreeListProcMetrics - FTreeListProcMetricsTailNode := nil; - TreeListProcMetrics.Clear; + ResetTreeListProcMetrics; FGoBackStack.Clear; // Reset the grid @@ -857,6 +1364,66 @@ procedure TMainForm.LoadDataBtnClick(Sender: TObject); MessageDlg(ALIntToStrW(Length(FProcMetrics)) + ' records have been loaded successfully.', mtInformation, [mbOK], 0); end; +{*****************************************************} +procedure TMainForm.ClearDataBtnClick(Sender: TObject); +begin + if MessageDlg( + 'Do you want to delete all the performance data collected so far? ' + + 'Every performance file of the CodeProfiler data folder will be deleted and the grid will be emptied. ' + + 'The procedure IDs (' + ALCodeProfilerProcIDMapFilename + ') are kept, so the sources already instrumented stay valid ' + + 'and the next run will simply collect fresh data.', + mtConfirmation, [mbYes, mbNo], 0) <> mrYes then exit; + + var LDeletedCount := 0; + ClearDataBtn.Cursor := crHourGlass; + try + + // Delete every performance file, whatever the history group mode they + // were collected with. This must not run while the HTTP server is + // receiving a new performance file in FDataDir. + FHttpServerCriticalSection.Acquire; + try + if TDirectory.Exists(FDataDir) then begin + var LFilenames := TDirectory.GetFiles(FDataDir, '*', TSearchOption.soTopDirectoryOnly); + for var I := low(LFilenames) to high(LFilenames) do begin + // '.dat~tmp' is the temporary file the HTTP server writes the + // incoming performance file to before renaming it to '.dat'. + var LExtension := TPath.GetExtension(LFilenames[I]); + if (not ALSameTextW(LExtension, '.dat')) and + (not ALSameTextW(LExtension, '.dat~tmp')) then continue; + TFile.Delete(LFilenames[I]); + inc(LDeletedCount); + end; + end; + finally + FHttpServerCriticalSection.Release; + end; + + // Drop the data loaded in memory + setlength(FProcMetrics, 0); + FProcIDMap.Clear; + + // Reset Filter + ResetFilters; + FFilterParentExecutionIDs.Add(0); + + // Reset TreeListProcMetrics + ResetTreeListProcMetrics; + FGoBackStack.Clear; + + // Empty the grid + Refresh; + + // Clear the StatusBar + MainStatusBar.Panels[1].Text := ''; + + finally + ClearDataBtn.Cursor := crDefault; + end; + + MessageDlg(ALIntToStrW(LDeletedCount) + ' performance file(s) have been deleted successfully.', mtInformation, [mbOK], 0); +end; + {*****************************************************} procedure TMainForm.PanelfilterResize(Sender: TObject); begin @@ -872,25 +1439,7 @@ procedure TMainForm.InstrumentationTabSheetResize(Sender: TObject); {*******************************************************} procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); -Const - CColumnExecutionID = 0; - CColumnParentExecutionID = 1; - CColumnProcID = 2; - CColumnProcName = 3; - CColumnThreadID = 4; - CColumnStartTimeStamp = 5; - CColumnTimeTaken = 6; - CColumnNames: array[CColumnExecutionID..CColumnTimeTaken] of AnsiString = ( - 'ExecutionID', - 'ParentExecutionID', - 'ProcID', - 'ProcName', - 'ThreadID', - 'StartTimeStamp', - 'TimeTaken'); - var - LExportColumns: array[CColumnExecutionID..CColumnTimeTaken] of Boolean; LCsvStream: TFileStream; LCsvBuffer: AnsiString; LCsvBufferPos: Integer; @@ -915,14 +1464,6 @@ procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); end; end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} - function _TicksToMillisecondsStr(const ATicks: Int64): AnsiString; - begin - // 1 tick equals 0.0001 millisecond (ALCodeProfilerMillisecondsPerTick), - // so use integer arithmetic to avoid any rounding/locale issue - Result := ALIntToStrA(ATicks div 10000) + '.' + ALFormatA('%.4d', [ATicks mod 10000]); - end; - {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~} procedure _AppendToCsvRow(var ARow: AnsiString; var AFirstColumn: Boolean; const AValue: AnsiString); begin @@ -932,15 +1473,21 @@ procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); end; begin - var LProcMetricsFilename := TPath.Combine(FDataDir, ALCodeProfilerProcMetricsFilename); + var LHistoryGroupMode := GetSelectedHistoryGroupModeEnum; + var LRawRecordSize := GetProcMetricsRawRecordSize(LHistoryGroupMode); + var LColumns := GetProcMetricsColumnsForMode(LHistoryGroupMode); + var LProcMetricsFilenameOnly := GetSelectedProcMetricsFilename; + var LProcMetricsFilename := TPath.Combine(FDataDir, LProcMetricsFilenameOnly); If not TFile.Exists(LProcMetricsFilename) then raise Exception.CreateFmt( 'The required file "%s" is missing. Please make '+ 'sure it is available in the data subfolder where '+ 'Alcinoe Code Profiler is located before proceeding.', - [ALCodeProfilerProcMetricsFilename]); + [LProcMetricsFilenameOnly]); // Ask which columns to export + var LExportColumns: TArray; + SetLength(LExportColumns, Length(LColumns)); var LColumnsForm := TForm.CreateNew(nil); try LColumnsForm.Caption := 'Export to CSV'; @@ -955,8 +1502,8 @@ procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); var LColumnsCheckListBox := TCheckListBox.Create(LColumnsForm); LColumnsCheckListBox.Parent := LColumnsForm; LColumnsCheckListBox.SetBounds(8, 29, LColumnsForm.ClientWidth - 16, 161); - for var I := CColumnExecutionID to CColumnTimeTaken do begin - LColumnsCheckListBox.Items.Add(String(CColumnNames[I])); + for var I := 0 to High(LColumns) do begin + LColumnsCheckListBox.Items.Add(String(GetProcMetricsColumnName(LColumns[I]))); LColumnsCheckListBox.Checked[I] := True; end; var LOkBtn := TButton.Create(LColumnsForm); @@ -972,20 +1519,23 @@ procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); LCancelBtn.Cancel := True; LCancelBtn.SetBounds(LColumnsForm.ClientWidth - 87, 198, 75, 27); if LColumnsForm.ShowModal <> mrOk then exit; - for var I := CColumnExecutionID to CColumnTimeTaken do + for var I := 0 to High(LColumns) do LExportColumns[I] := LColumnsCheckListBox.Checked[I]; finally ALFreeAndNil(LColumnsForm); end; var LExportAnyColumn := False; - for var I := CColumnExecutionID to CColumnTimeTaken do + for var I := 0 to High(LColumns) do LExportAnyColumn := LExportAnyColumn or LExportColumns[I]; if not LExportAnyColumn then Raise Exception.Create('Error: No columns have been selected'); // The proc ID map is only needed to resolve the ProcName column + var LNeedProcNames := False; + for var I := 0 to High(LColumns) do + if (LColumns[I] = colkProcName) and LExportColumns[I] then LNeedProcNames := True; var LProcIDMapFilename := TPath.Combine(FDataDir, ALCodeProfilerProcIDMapFilename); - If (LExportColumns[CColumnProcName]) and (not TFile.Exists(LProcIDMapFilename)) then + If LNeedProcNames and (not TFile.Exists(LProcIDMapFilename)) then raise Exception.CreateFmt('The required file "%s" does not exist. Please ensure it is available before proceeding', [ALCodeProfilerProcIDMapFilename]); // Ask where to save the CSV file @@ -996,7 +1546,7 @@ procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); LSaveDialog.Filter := 'CSV files (*.csv)|*.csv|All files (*.*)|*.*'; LSaveDialog.DefaultExt := 'csv'; LSaveDialog.Options := LSaveDialog.Options + [ofOverwritePrompt]; - LSaveDialog.FileName := ALStringReplaceW(ALCodeProfilerProcMetricsFilename, '.dat', '.csv', [rfIgnoreCase]); + LSaveDialog.FileName := ALStringReplaceW(LProcMetricsFilenameOnly, '.dat', '.csv', [rfIgnoreCase]); if not LSaveDialog.Execute then exit; LCsvFilename := LSaveDialog.FileName; finally @@ -1012,7 +1562,7 @@ procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); var LProcMetricsStream: TFileStream := nil; LCsvStream := nil; try - if LExportColumns[CColumnProcName] then begin + if LNeedProcNames then begin var LProcIDMap := TALHashedStringListA.Create; try LProcIDMap.LoadFromFile(LProcIDMapFilename); @@ -1026,45 +1576,33 @@ procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); // Convert ALCodeProfilerProcMetrics.dat to CSV chunk by chunk as the // file can be very huge and can not be fully loaded in memory LProcMetricsStream := TFileStream.Create(LProcMetricsFilename, fmOpenRead or fmShareDenyWrite); - if LProcMetricsStream.Size mod SizeOf(TALProcMetrics) <> 0 then - raise Exception.CreateFmt('The file "%s" is corrupted', [ALCodeProfilerProcMetricsFilename]); - var LTotalRecordCount: Int64 := LProcMetricsStream.Size div SizeOf(TALProcMetrics); + if LProcMetricsStream.Size mod LRawRecordSize <> 0 then + raise Exception.CreateFmt('The file "%s" is corrupted', [LProcMetricsFilenameOnly]); + var LTotalRecordCount: Int64 := LProcMetricsStream.Size div LRawRecordSize; LCsvStream := TFileStream.Create(LCsvFilename, fmCreate); - var LProcMetrics: TArray; - Setlength(LProcMetrics, 65536); // 65536 * SizeOf(TALProcMetrics) = 2 MB + var LRawBuffer: TBytes; + SetLength(LRawBuffer, 65536 * LRawRecordSize); // ~2 MB chunk Setlength(LCsvBuffer, 4194304); // 4 MB LCsvBufferPos := 0; var LCsvHeader: AnsiString := ''; var LFirstColumn := True; - for var I := CColumnExecutionID to CColumnTimeTaken do + for var I := 0 to High(LColumns) do if LExportColumns[I] then - _AppendToCsvRow(LCsvHeader, LFirstColumn, CColumnNames[I]); + _AppendToCsvRow(LCsvHeader, LFirstColumn, GetProcMetricsColumnName(LColumns[I])); _WriteToCsvBuffer(LCsvHeader + #13#10); While True do begin - var LBytesRead := LProcMetricsStream.Read(LProcMetrics[0], length(LProcMetrics) * SizeOf(TALProcMetrics)); + var LBytesRead := LProcMetricsStream.Read(LRawBuffer[0], Length(LRawBuffer)); if LBytesRead <= 0 then break; - if LBytesRead mod SizeOf(TALProcMetrics) <> 0 then - raise Exception.CreateFmt('The file "%s" is corrupted', [ALCodeProfilerProcMetricsFilename]); - for var I := 0 to (LBytesRead div SizeOf(TALProcMetrics)) - 1 do begin + if LBytesRead mod LRawRecordSize <> 0 then + raise Exception.CreateFmt('The file "%s" is corrupted', [LProcMetricsFilenameOnly]); + for var I := 0 to (LBytesRead div LRawRecordSize) - 1 do begin + var LRec: TALProcMetrics; + DecodeProcMetricsRaw(LHistoryGroupMode, LRawBuffer, I * LRawRecordSize, LRec); var LCsvRow: AnsiString := ''; LFirstColumn := True; - if LExportColumns[CColumnExecutionID] then - _AppendToCsvRow(LCsvRow, LFirstColumn, ALIntToStrA(LProcMetrics[I].ExecutionID)); - if LExportColumns[CColumnParentExecutionID] then - _AppendToCsvRow(LCsvRow, LFirstColumn, ALIntToStrA(LProcMetrics[I].ParentExecutionID)); - if LExportColumns[CColumnProcID] then - _AppendToCsvRow(LCsvRow, LFirstColumn, ALIntToStrA(LProcMetrics[I].ProcID)); - if LExportColumns[CColumnProcName] then begin - var LProcName: AnsiString; - if not LProcNames.TryGetValue(LProcMetrics[I].ProcID, LProcName) then LProcName := ''; - _AppendToCsvRow(LCsvRow, LFirstColumn, LProcName); - end; - if LExportColumns[CColumnThreadID] then - _AppendToCsvRow(LCsvRow, LFirstColumn, ALIntToStrA(LProcMetrics[I].ThreadID)); - if LExportColumns[CColumnStartTimeStamp] then - _AppendToCsvRow(LCsvRow, LFirstColumn, _TicksToMillisecondsStr(LProcMetrics[I].StartTimeStamp)); - if LExportColumns[CColumnTimeTaken] then - _AppendToCsvRow(LCsvRow, LFirstColumn, _TicksToMillisecondsStr(LProcMetrics[I].ElapsedTicks)); + for var J := 0 to High(LColumns) do + if LExportColumns[J] then + _AppendToCsvRow(LCsvRow, LFirstColumn, GetProcMetricsColumnValue(LColumns[J], LRec, LProcNames)); _WriteToCsvBuffer(LCsvRow + #13#10); inc(LExportedRecordCount); end; @@ -1092,10 +1630,11 @@ procedure TMainForm.ExportToCsvBtnClick(Sender: TObject); procedure TMainForm.FormCreate(Sender: TObject); begin FDataDir := ALGetModulePathW + 'data\'; + FLoadingSettings := True; FProcIDSequence := 0; Setlength(FProcMetrics, 0); FProcIDMap := TALHashedStringListA.Create; - FTreeListProcMetricsTailNode := nil; + ResetTreeListProcMetrics; FFilterProcIDs := THashSet.Create; FFilterExecutionIDs := THashSet.Create; FFilterParentExecutionIDs := THashSet.Create; @@ -1103,6 +1642,7 @@ procedure TMainForm.FormCreate(Sender: TObject); FFilterStartTimeStampMin := 0; FFilterStartTimeStampMax := 0; FOverrideFilterParentExecutionID := 0; + FOverrideFilterThreadID := High(Cardinal); FGoBackStack := TDictionary.Create; FHttpServerCriticalSection := TCriticalSection.Create; //-- @@ -1123,12 +1663,17 @@ procedure TMainForm.FormCreate(Sender: TObject); end; var LIniFile := TIniFile.Create(TPath.Combine(FDataDir, ConfigFilename)); try - HttpServerNameEdit.Text := LIniFile.ReadString('General','ServerName', ''); - HttpServerPortEdit.Text := LIniFile.ReadString('General','ServerPort', '8080'); SourcesPathMemo.Text := ALStringReplaceW(LIniFile.ReadString('General','SourcesPath', '..\..\Source\;..\..\Embarcadero\Florence\fmx\;..\..\Demos\ALFmxDynamicListBox\_Source\'), ';', #13#10, [RfReplaceALL]); + CodeProfilerIncFilenameEdit.Text := LIniFile.ReadString('General','CodeProfilerIncFilename', '..\..\Source\Alcinoe.CodeProfiler.inc'); finally ALFreeAndNil(LIniFile); end; + FLoadingSettings := False; + // Must be done after Config.ini has been read, as the location of + // Alcinoe.CodeProfiler.inc is one of its settings. + LoadCodeProfilerIncFile; + FHistoryGroupMode := GetSelectedHistoryGroupModeEnum; + UpdateHistoryGroupModeUI; InstrumentationTabSheetResize(nil); PanelfilterResize(nil); end; @@ -1153,6 +1698,9 @@ procedure TMainForm.GridTableViewProcMetricsCellDblClick( AShift: TShiftState; var AHandled: Boolean); begin + // In hgmByProcID, calls are grouped by ProcID only, with no parent/child + // relationship recorded, so there is nothing to drill into. + if FHistoryGroupMode = hgmByProcID then Exit; if ACellViewInfo.GridRecord <> nil then begin var LGoBackStackItem: TGoBackStackItem; LGoBackStackItem.TopRowIndex := GridTableViewProcMetrics.Controller.TopRowIndex; @@ -1171,12 +1719,15 @@ procedure TMainForm.GridTableViewProcMetricsCellDblClick( FGoBackStack.add(FOverrideFilterParentExecutionID, LGoBackStackItem); //-- FOverrideFilterParentExecutionID := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnExecutionID.Index]; - if FTreeListProcMetricsTailNode = nil then FTreeListProcMetricsTailNode := TreeListProcMetrics.Add - else FTreeListProcMetricsTailNode := TreeListProcMetrics.AddChild(FTreeListProcMetricsTailNode); + FOverrideFilterThreadID := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnThreadID.Index]; + FTreeListProcMetricsTailNode := TreeListProcMetrics.AddChild(FTreeListProcMetricsTailNode); FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnExecutionID.ItemIndex] := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnExecutionID.Index]; FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnThreadID.ItemIndex] := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnThreadID.Index]; FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnProcName.ItemIndex] := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnProcName.Index]; - FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnStartTimeStamp.ItemIndex] := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnStartTimeStamp.Index]; + if FHistoryGroupMode = hgmNone then + FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnStartTimeStamp.ItemIndex] := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnStartTimestamp.Index] + else + FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnCallCount.ItemIndex] := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnCallCount.Index]; FTreeListProcMetricsTailNode.Texts[TreeListProcMetricsColumnTimeTaken.ItemIndex] := ACellViewInfo.GridRecord.Values[GridTableViewProcMetricsColumnTimeTaken.Index]; TreeListProcMetrics.FullExpand; TreeListProcMetrics.TopVisibleNode := FTreeListProcMetricsTailNode; @@ -1203,14 +1754,26 @@ procedure TMainForm.GridTableViewProcMetricsColumnStartTimestampGetDisplayText(S {**********************************************************************} procedure TMainForm.HttpServerPortEditPropertiesChange(Sender: TObject); begin + MainStatusBar.Panels[1].Text := ''; + SaveCodeProfilerIncFile; IdHTTPServer.Active := False; - if ALTrim(HttpServerPortEdit.Text) <> '' then begin + if GetSelectedServerName <> '' then begin IdHTTPServer.DefaultPort := ALStrToInt(ALTrim(HttpServerPortEdit.Text)); - IdHTTPServer.Active := True; - MainStatusBar.Panels[0].Text := 'Listening on port ' + HttpServerPortEdit.Text; + try + IdHTTPServer.Active := True; + MainStatusBar.Panels[0].Text := 'Listening on port ' + HttpServerPortEdit.Text; + except + MainStatusBar.Panels[0].Text := 'Not listening'; + Raise; + end; end else MainStatusBar.Panels[0].Text := 'Not listening'; - MainStatusBar.Panels[1].Text := ''; +end; + +{**********************************************************************} +procedure TMainForm.HttpServerNameEditPropertiesChange(Sender: TObject); +begin + SaveCodeProfilerIncFile; end; {**********************************************************************************************************************************************} @@ -1236,14 +1799,17 @@ procedure TMainForm.TreeListProcMetricsDblClick(Sender: TObject); var LfocusedNode := TreeListProcMetrics.focusedNode; if Assigned(LClickedNode) and Assigned(LfocusedNode) then begin FOverrideFilterParentExecutionID := LfocusedNode.Values[TreeListProcMetricsColumnExecutionID.ItemIndex]; + if LfocusedNode = FTreeListProcMetricsRootNode then + FOverrideFilterThreadID := High(Cardinal) + else + FOverrideFilterThreadID := LfocusedNode.Values[TreeListProcMetricsColumnThreadID.ItemIndex]; FTreeListProcMetricsTailNode := LfocusedNode; FTreeListProcMetricsTailNode.DeleteChildren; end else begin - if FTreeListProcMetricsTailNode = nil then exit; FOverrideFilterParentExecutionID := 0; - FTreeListProcMetricsTailNode := nil; - TreeListProcMetrics.Clear; + FOverrideFilterThreadID := High(Cardinal); + ResetTreeListProcMetrics; end; var LGoBackStackItem: TGoBackStackItem; @@ -1314,8 +1880,11 @@ procedure TMainForm.ApplyFilterBtnClick(Sender: TObject); FFilterProcIDs.Add(ALMaxUInt); end; - if (FFilterStartTimeStampMin > 0) or - (FFilterStartTimeStampMax > 0) then begin + // The start-timestamp filter only makes sense for individual calls, + // which only exist in hgmNone; grouped modes have no StartTimeStamp. + if (FHistoryGroupMode = hgmNone) and + ((FFilterStartTimeStampMin > 0) or + (FFilterStartTimeStampMax > 0)) then begin var LExecutionDict := TDictionary.create; Try for var I := low(FProcMetrics) to high(FProcMetrics) do begin @@ -1351,8 +1920,7 @@ procedure TMainForm.ApplyFilterBtnClick(Sender: TObject); (FFilterExecutionIDs.Count = 0) then FFilterParentExecutionIDs.Add(0); - FTreeListProcMetricsTailNode := nil; - TreeListProcMetrics.Clear; + ResetTreeListProcMetrics; FGoBackStack.Clear; Refresh; From adf78e6635685d79434ed742b225ce74b88bb865 Mon Sep 17 00:00:00 2001 From: stv Date: Mon, 21 Sep 2026 12:49:11 +0200 Subject: [PATCH 3/9] Update --- Source/Alcinoe.CodeProfiler.inc | 28 +++ Source/Alcinoe.CodeProfiler.pas | 80 ++++--- Tools/CodeProfiler/_Source/CodeProfiler.dpr | 2 +- Tools/CodeProfiler/_Source/Main.dfm | 226 ++++++++++++-------- Tools/CodeProfiler/_Source/Main.pas | 92 +++++++- 5 files changed, 306 insertions(+), 122 deletions(-) diff --git a/Source/Alcinoe.CodeProfiler.inc b/Source/Alcinoe.CodeProfiler.inc index 7938af677..3cb3e4c89 100644 --- a/Source/Alcinoe.CodeProfiler.inc +++ b/Source/Alcinoe.CodeProfiler.inc @@ -29,6 +29,19 @@ var // NOTE: This is the fastest option and has the lowest impact on each function call. {.$DEFINE ALCodeProfilerHistoryGroupByProcID} +{$IF defined(ALCodeProfilerHistoryGroupByProcID)} +// Ignore the thread ID. The calls made from every thread are merged together +// instead of producing one row per procedure and per thread, for example: +// procedure A - 3 calls - 310 ms = 1 call from the main thread + 2 calls from a background thread +// +// NOTE: This option is only available with ALCodeProfilerHistoryGroupByProcID. +// All the threads then share the same metrics, which are updated atomically, +// so it slightly increases the cost of each function call, but it also greatly +// reduces the memory usage as only one history is allocated for the whole +// process instead of one per thread. +{.$DEFINE ALCodeProfilerIgnoreThreadID} +{$ENDIF} + // Group calls by call stack. // The result will be displayed as a grouped call tree, for example: // procedure A - 1 call - 310 ms @@ -37,3 +50,18 @@ var // procedure D - 1 call - 85 ms // procedure C - 1 call - 22 ms {$DEFINE ALCodeProfilerHistoryGroupByCallStack} + +// Capacity of the history, in number of rows. +// +// NOTE: With ALCodeProfilerHistoryGroupByProcID the history is a flat array +// indexed by the procedure ID, so it only needs to be big enough to hold the +// highest procedure ID of ALCodeProfilerProcIDMap.txt. The value below is +// updated by the Alcinoe Code Profiler GUI each time the markers are inserted +// or removed, so there is no reason to edit it by hand. +{$IF defined(ALCodeProfilerHistoryGroupByProcID)} +const + ALCodeProfilerHistoryCapacity = 1000000; +{$ELSE} +const + ALCodeProfilerHistoryCapacity = 1000000; {1 000 000 * 32 Bytes = 32 MB or with gap = 2 097 152 * 32 Bytes = 67.11 MB} +{$ENDIF} diff --git a/Source/Alcinoe.CodeProfiler.pas b/Source/Alcinoe.CodeProfiler.pas index 1cd97d22a..04d86127e 100644 --- a/Source/Alcinoe.CodeProfiler.pas +++ b/Source/Alcinoe.CodeProfiler.pas @@ -5,6 +5,10 @@ interface {$I Alcinoe.inc} {$I Alcinoe.CodeProfiler.inc} +{$IF defined(ALCodeProfilerIgnoreThreadID) and (not defined(ALCodeProfilerHistoryGroupByProcID))} + {$MESSAGE ERROR 'ALCodeProfilerIgnoreThreadID is only available with ALCodeProfilerHistoryGroupByProcID'} +{$ENDIF} + type TALProcMetrics = record public @@ -17,6 +21,8 @@ TALProcMetrics = record ElapsedTicks: Int64; {$ELSEIF defined(ALCodeProfilerHistoryGroupByProcID)} ProcID: Cardinal; + // Always 0 when ALCodeProfilerIgnoreThreadID is defined. The field is kept + // in all cases so that the layout of the .dat file never changes. ThreadID: Cardinal; CallCount: Cardinal; ElapsedTicks: Int64; @@ -35,7 +41,7 @@ TALProcMetrics = record procedure ALCodeProfilerEnterProc(const aProcID : Cardinal); procedure ALCodeProfilerExitProc(const aProcID : Cardinal); procedure ALCodeProfilerStart; -procedure ALCodeProfilerStop(Const ASaveHistories: Boolean = True); +procedure ALCodeProfilerStop; function ALCodeProfilerIsrunning: Boolean; const @@ -103,7 +109,9 @@ TALStopWatchProcMetrics = record {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} ParentMetricsID: Cardinal; {$ENDIF} + {$IF not defined(ALCodeProfilerIgnoreThreadID)} ThreadID: Cardinal; + {$ENDIF} StopWatch: TStopWatch; end; @@ -123,7 +131,6 @@ TALProcMetricsHistory = class(TObject) FArray: TALProcMetricsArray; FCount: NativeInt; FCapacity: NativeInt; - FIsOrphaned: Boolean; {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} FGrowThreshold: NativeInt; procedure Rehash(NewCapPow2: NativeInt); @@ -138,7 +145,17 @@ TALProcMetricsHistory = class(TObject) {*******} threadvar ALProcMetricsStack: TALProcMetricsStack; + +{*******} +{$IF defined(ALCodeProfilerIgnoreThreadID)} +// All the threads share the same history, so that the metrics of a procedure +// are merged together whatever the thread it was called from. +var + ALProcMetricsHistory: TALProcMetricsHistory; +{$ELSE} +threadvar ALProcMetricsHistory: TALProcMetricsHistory; +{$ENDIF} {*} var @@ -469,7 +486,6 @@ procedure ALCodeProfilerPurgeHistories(const ASaveHistories: boolean); try for var I := ALProcMetricsHistories.Count - 1 downto 0 do begin if ASaveHistories then ALCodeProfilerSaveHistory(ALProcMetricsHistories[i]); - if ALProcMetricsHistories[i].FIsOrphaned then ALProcMetricsHistories.ExtractAt(i).Free else ALProcMetricsHistories[i].Clear; end; finally @@ -541,7 +557,7 @@ procedure ALCodeProfilerEnterProc(const aProcID : Cardinal); var LProcMetricsHistory := ALProcMetricsHistory; if LProcMetricsHistory = nil then begin ALProcMetricsHistory := TALProcMetricsHistory.Create; - ALProcMetricsHistory.SetCapacity(1000000); {1 000 000 * 32 Bytes = 32 MB or with gap = 2 097 152 * 32 Bytes = 67.11 MB} + ALProcMetricsHistory.SetCapacity(ALCodeProfilerHistoryCapacity); {with the default capacity: 1 000 000 * 32 Bytes = 32 MB or with gap = 2 097 152 * 32 Bytes = 67.11 MB} LProcMetricsHistory := ALProcMetricsHistory; ALProcMetricsLock.BeginWrite; try @@ -583,7 +599,9 @@ procedure ALCodeProfilerEnterProc(const aProcID : Cardinal); {$ELSEIF defined(ALCodeProfilerHistoryGroupNone)} ParentExecutionID := LProcMetricsStack.FArray[LProcMetricsStack.FCount - 2].ExecutionID; {$ENDIF} + {$IF not defined(ALCodeProfilerIgnoreThreadID)} ThreadID := LProcMetricsStack.FArray[LProcMetricsStack.FCount - 2].ThreadID; + {$ENDIF} end else begin {$IF defined(ALCodeProfilerHistoryGroupByCallStack)} @@ -591,12 +609,14 @@ procedure ALCodeProfilerEnterProc(const aProcID : Cardinal); {$ELSEIF defined(ALCodeProfilerHistoryGroupNone)} ParentExecutionID := 0; {$ENDIF} + {$IF not defined(ALCodeProfilerIgnoreThreadID)} var LCurrentThreadID := TThread.CurrentThread.ThreadID; if LCurrentThreadID = MainThreadID then ThreadID := 0 else begin ThreadID := LCurrentThreadID mod 4294967295; if ThreadID = 0 then ThreadID := 1; end; + {$ENDIF} end; ProcID := AProcID; StopWatch := TStopWatch.StartNew; @@ -624,24 +644,16 @@ TStopwatchAccessPrivate = record if not ALCodeProfilerEnabled then begin ALProcMetricsStack.Free; ALProcMetricsStack := nil; - if ALProcMetricsHistory <> nil then begin - ALProcMetricsLock.BeginRead; - try - ALProcMetricsHistory.FIsOrphaned := true; - ALProcMetricsHistory := nil; - finally - ALProcMetricsLock.EndRead; - end; - end; end else if LProcMetricsStack.FCount <> 0 then begin var LProcMetricsStackLastIndex: integer := LProcMetricsStack.FCount - 1; LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.Stop; //-- var LProcMetricsHistory := ALProcMetricsHistory; + {$IF not defined(ALCodeProfilerIgnoreThreadID)} if LProcMetricsHistory = nil then begin ALProcMetricsHistory := TALProcMetricsHistory.Create; - ALProcMetricsHistory.SetCapacity(1000000); {1 000 000 * 32 Bytes = 32 MB or with gap = 2 097 152 * 32 Bytes = 67.11 MB} + ALProcMetricsHistory.SetCapacity(ALCodeProfilerHistoryCapacity); {with the default capacity: 1 000 000 * 32 Bytes = 32 MB or with gap = 2 097 152 * 32 Bytes = 67.11 MB} LProcMetricsHistory := ALProcMetricsHistory; ALProcMetricsLock.BeginWrite; try @@ -650,6 +662,7 @@ TStopwatchAccessPrivate = record ALProcMetricsLock.EndWrite; end; end; + {$ENDIF} //-- ALProcMetricsLock.BeginRead; try @@ -693,6 +706,28 @@ TStopwatchAccessPrivate = record {$IFNDEF ALCompilerVersionSupported131} {$MESSAGE WARN 'Check if System.Generics.Collections.TDictionary.TryAdd was not updated and adjust the IFDEF'} {$ENDIF} + {$IF defined(ALCodeProfilerIgnoreThreadID)} + // All the threads update the very same record, so the metrics must be + // updated atomically. + With LProcMetricsHistory.FArray[LProcID] do begin + ProcID := LProcID; + ThreadID := 0; + AtomicIncrement(CallCount); + {$IFNDEF ALCompilerVersionSupported131} + {$MESSAGE WARN 'Check if System.Diagnostics.TStopwatch.InitStopwatchType was not updated and adjust the IFDEF'} + {$ENDIF} + {$IF defined(MSWINDOWS)} + var LTickFrequency: Double; + if not TStopwatch.IsHighResolution then LTickFrequency := 1.0 + else LTickFrequency := 10000000.0 / LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.Frequency; + AtomicIncrement(ElapsedTicks, Trunc(LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.ElapsedTicks * LTickFrequency)); + {$ELSEIF defined(POSIX)} + AtomicIncrement(ElapsedTicks, LProcMetricsStack.FArray[LProcMetricsStackLastIndex].StopWatch.ElapsedTicks); + {$ELSE} + Raise Exception.create('Error 5FE96C7E-ABFA-4AE2-84E5-39EFF2E83BBB') + {$ENDIF} + end; + {$ELSE} With LProcMetricsHistory.FArray[LProcID] do begin ProcID := LProcID; ThreadID := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ThreadID; @@ -711,6 +746,7 @@ TStopwatchAccessPrivate = record Raise Exception.create('Error 8CB28339-29A0-4276-80AA-F8CD5E447CE5') {$ENDIF} end; + {$ENDIF} {$ELSEIF defined(ALCodeProfilerHistoryGroupByCallStack)} var LProcID: Cardinal := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ProcID; var LParentMetricsID: Cardinal := LProcMetricsStack.FArray[LProcMetricsStackLastIndex].ParentMetricsID; @@ -774,15 +810,6 @@ TStopwatchAccessPrivate = record (TThread.CurrentThread.ThreadID <> MainThreadID) then begin ALProcMetricsStack.Free; ALProcMetricsStack := nil; - If ALProcMetricsHistory <> nil then begin - ALProcMetricsLock.BeginRead; - try - ALProcMetricsHistory.FIsOrphaned := true; - ALProcMetricsHistory := nil; - finally - ALProcMetricsLock.EndRead; - end; - end; end; end; end; @@ -794,11 +821,10 @@ procedure ALCodeProfilerStart; ALCodeProfilerEnabled := True; end; -{*****************************************************************} -procedure ALCodeProfilerStop(Const ASaveHistories: Boolean = True); +{***************************} +procedure ALCodeProfilerStop; Begin ALCodeProfilerEnabled := False; - ALCodeProfilerPurgeHistories(ASaveHistories); End; {****************************************} @@ -833,7 +859,7 @@ initialization {$IF defined(ALCodeProfilerHistoryGroupNone)} ALProcMetricsHistory.SetCapacity(25000000); {25 000 000 * 32 Bytes = 800MB} {$ELSE} - ALProcMetricsHistory.SetCapacity(1000000); {1 000 000 = 2 097 152 (with gap) * 32 Bytes = 67.11 MB} + ALProcMetricsHistory.SetCapacity(ALCodeProfilerHistoryCapacity); {with the default capacity: 1 000 000 = 2 097 152 (with gap) * 32 Bytes = 67.11 MB} {$ENDIF} //-- ALProcMetricsHistories := TList.Create; diff --git a/Tools/CodeProfiler/_Source/CodeProfiler.dpr b/Tools/CodeProfiler/_Source/CodeProfiler.dpr index 8b033bf0c..51fa04346 100644 --- a/Tools/CodeProfiler/_Source/CodeProfiler.dpr +++ b/Tools/CodeProfiler/_Source/CodeProfiler.dpr @@ -8,7 +8,7 @@ uses {$R *.res} begin - ALCodeProfilerStop(False{ASaveHistory}); + ALCodeProfilerStop; Application.Initialize; Application.CreateForm(TMainForm, MainForm); Application.Run; diff --git a/Tools/CodeProfiler/_Source/Main.dfm b/Tools/CodeProfiler/_Source/Main.dfm index 156ccaead..374553807 100644 --- a/Tools/CodeProfiler/_Source/Main.dfm +++ b/Tools/CodeProfiler/_Source/Main.dfm @@ -2,8 +2,8 @@ object MainForm: TMainForm Left = 377 Top = 296 Caption = 'Alcinoe CodeProfiler' - ClientHeight = 900 - ClientWidth = 1080 + ClientHeight = 985 + ClientWidth = 1264 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -17,15 +17,15 @@ object MainForm: TMainForm object MainPageControl: TcxPageControl Left = 0 Top = 0 - Width = 1080 - Height = 868 + Width = 1264 + Height = 953 Align = alClient TabOrder = 0 - Properties.ActivePage = PerformanceAnalysisTabSheet + Properties.ActivePage = InstrumentationTabSheet Properties.CustomButtons.Buttons = <> - ClientRectBottom = 863 + ClientRectBottom = 948 ClientRectLeft = 5 - ClientRectRight = 1075 + ClientRectRight = 1259 ClientRectTop = 37 object InstrumentationTabSheet: TcxTabSheet Caption = 'Source Code Instrumentation' @@ -34,8 +34,8 @@ object MainForm: TMainForm object InstructionPanel: TdxPanel Left = 0 Top = 0 - Width = 1070 - Height = 424 + Width = 1254 + Height = 353 Align = alTop Color = 16448250 TabOrder = 0 @@ -58,7 +58,7 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 0 Transparent = True - Width = 1062 + Width = 1246 end object cxLabel2: TcxLabel AlignWithMargins = True @@ -76,7 +76,7 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 1 Transparent = True - Width = 1062 + Width = 1246 end object cxLabel3: TcxLabel AlignWithMargins = True @@ -97,7 +97,7 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 2 Transparent = True - Width = 1049 + Width = 1233 end object cxLabel4: TcxLabel AlignWithMargins = True @@ -116,7 +116,7 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 3 Transparent = True - Width = 1049 + Width = 1233 end object cxLabel5: TcxLabel AlignWithMargins = True @@ -139,13 +139,14 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 4 Transparent = True - Width = 1049 + Width = 1233 end - object cxLabel6: TcxLabel + object LastInstructionLabel: TcxLabel AlignWithMargins = True Left = 16 - Top = 285 + Top = 308 Margins.Left = 16 + Margins.Bottom = 16 Align = alTop Caption = '6. Go to the Performance Analysis tab, click the Load Data butto' + @@ -160,48 +161,8 @@ object MainForm: TMainForm Properties.WordWrap = True TabOrder = 5 Transparent = True - Width = 1049 - end - object cxLabel8: TcxLabel - AlignWithMargins = True - Left = 3 - Top = 318 - Align = alTop - Caption = 'Note:' - ParentFont = False - Style.Font.Charset = DEFAULT_CHARSET - Style.Font.Color = clWindowText - Style.Font.Height = -17 - Style.Font.Name = 'Segoe UI' - Style.Font.Style = [fsBold] - Style.IsFontAssigned = True - Properties.WordWrap = True - TabOrder = 6 - Transparent = True - Width = 1062 - end - object LastInstructionLabel: TcxLabel - AlignWithMargins = True - Left = 3 - Top = 351 - Margins.Bottom = 8 - Align = alTop - Caption = - 'On Windows, the performance file is stored in the CodeProfiler d' + - 'ata folder if the app is running locally; otherwise, it is saved' + - ' in the user'#39's document folder. On macOS, iOS, and Android, it i' + - 's always stored in the user'#39's document folder.' - ParentFont = False - Style.Font.Charset = DEFAULT_CHARSET - Style.Font.Color = clWindowText - Style.Font.Height = -17 - Style.Font.Name = 'Segoe UI' - Style.Font.Style = [] - Style.IsFontAssigned = True - Properties.WordWrap = True - TabOrder = 7 - Transparent = True - Width = 1062 + ExplicitTop = 285 + Width = 1233 end object cxLabel13: TcxLabel AlignWithMargins = True @@ -220,9 +181,9 @@ object MainForm: TMainForm Style.Font.Style = [] Style.IsFontAssigned = True Properties.WordWrap = True - TabOrder = 8 + TabOrder = 6 Transparent = True - Width = 1049 + Width = 1233 end object cxLabel14: TcxLabel AlignWithMargins = True @@ -235,7 +196,9 @@ object MainForm: TMainForm 'mance file will be received automatically. Otherwise, if you are' + ' running the program on a remote device, download the data from ' + 'the user'#39's documents folder and place it in the CodeProfiler dat' + - 'a folder.' + 'a folder. Note: On Windows, the performance file is directly sto' + + 'red in the CodeProfiler data folder if the app is running locall' + + 'y; otherwise, it is saved in the user'#39's document folder.' ParentFont = False Style.Font.Charset = DEFAULT_CHARSET Style.Font.Color = clWindowText @@ -244,39 +207,43 @@ object MainForm: TMainForm Style.Font.Style = [] Style.IsFontAssigned = True Properties.WordWrap = True - TabOrder = 9 + TabOrder = 7 Transparent = True - Width = 1049 + Width = 1233 end end object dxPanel2: TdxPanel AlignWithMargins = True Left = 0 - Top = 432 - Width = 1070 - Height = 386 + Top = 361 + Width = 1254 + Height = 542 Margins.Left = 0 Margins.Top = 8 Margins.Right = 0 Margins.Bottom = 8 Align = alClient TabOrder = 1 + ExplicitTop = 432 + ExplicitHeight = 471 object SourcesPathMemo: TcxMemo AlignWithMargins = True Left = 8 - Top = 254 + Top = 362 Margins.Left = 8 Margins.Right = 8 Margins.Bottom = 0 Align = alClient TabOrder = 0 - Height = 78 - Width = 1052 + ExplicitTop = 299 + ExplicitHeight = 118 + Height = 126 + Width = 1236 end object cxLabel9: TcxLabel AlignWithMargins = True Left = 8 - Top = 224 + Top = 332 Margins.Left = 8 Margins.Top = 0 Margins.Right = 8 @@ -287,12 +254,13 @@ object MainForm: TMainForm ' or filename per line. Prefix a name with '#39'!'#39' to ignore the file' Properties.WordWrap = True TabOrder = 1 - Width = 1052 + ExplicitTop = 269 + Width = 1236 end object dxPanel3: TdxPanel Left = 0 Top = 148 - Width = 1068 + Width = 1252 Height = 31 Align = alTop Frame.Borders = [] @@ -369,12 +337,12 @@ object MainForm: TMainForm 'ions below are stored' Properties.WordWrap = True TabOrder = 6 - Width = 1052 + Width = 1236 end object dxPanel5: TdxPanel Left = 0 Top = 43 - Width = 1068 + Width = 1252 Height = 31 Align = alTop Frame.Borders = [] @@ -383,7 +351,7 @@ object MainForm: TMainForm TabOrder = 7 object BrowseCodeProfilerIncFilenameBtn: TcxButton AlignWithMargins = True - Left = 1020 + Left = 1204 Top = 0 Width = 40 Height = 31 @@ -407,19 +375,21 @@ object MainForm: TMainForm Align = alClient Properties.OnChange = CodeProfilerIncFilenameEditPropertiesChange TabOrder = 1 - Width = 996 + Width = 1180 end end object dxPanel6: TdxPanel Left = 0 Top = 74 - Width = 1068 + Width = 1252 Height = 31 Align = alTop Frame.Borders = [] LookAndFeel.NativeStyle = False LookAndFeel.SkinName = 'Foggy' TabOrder = 8 + ExplicitLeft = 16 + ExplicitTop = 59 object CodeProfilerEnabledCheckBox: TcxCheckBox AlignWithMargins = True Left = 8 @@ -429,6 +399,8 @@ object MainForm: TMainForm Caption = 'Start profiling as soon as the application starts' Properties.OnChange = CodeProfilerEnabledCheckBoxPropertiesChange TabOrder = 0 + ExplicitLeft = -1 + ExplicitTop = 19 end end object cxLabel10: TcxLabel @@ -442,21 +414,23 @@ object MainForm: TMainForm Align = alTop Caption = '(Optional) Specify the IP address and port of this computer to a' + - 'utomatically receive the performance file' + 'utomatically receive the performance file. Not required for loca' + + 'l execution.' Properties.WordWrap = True TabOrder = 3 - Width = 1052 + Width = 1236 end object dxPanel1: TdxPanel Left = 0 - Top = 332 - Width = 1068 + Top = 488 + Width = 1252 Height = 52 Align = alBottom Frame.Borders = [] LookAndFeel.NativeStyle = False LookAndFeel.SkinName = 'Foggy' TabOrder = 4 + ExplicitTop = 417 object InsertProfilerMarkersBtn: TcxButton Left = 8 Top = 12 @@ -479,14 +453,16 @@ object MainForm: TMainForm object dxPanel4: TdxPanel AlignWithMargins = True Left = 3 - Top = 182 - Width = 1062 + Top = 217 + Width = 1246 Height = 39 + Margins.Bottom = 0 Align = alTop Frame.Borders = [] LookAndFeel.NativeStyle = False LookAndFeel.SkinName = 'Foggy' TabOrder = 5 + ExplicitTop = 182 object DoNotGroupRadioButton: TcxRadioButton AlignWithMargins = True Left = 8 @@ -523,6 +499,76 @@ object MainForm: TMainForm AutoSize = True end end + object dxPanel7: TdxPanel + AlignWithMargins = True + Left = 3 + Top = 256 + Width = 1246 + Height = 39 + Margins.Top = 0 + Align = alTop + Frame.Borders = [] + LookAndFeel.NativeStyle = False + LookAndFeel.SkinName = 'Foggy' + TabOrder = 9 + ExplicitTop = 227 + object IgnoreThreadIDCheckBox: TcxCheckBox + AlignWithMargins = True + Left = 8 + Top = 3 + Margins.Left = 8 + Align = alLeft + Caption = + 'Ignore thread ID (This option is only available with Group by pr' + + 'ocedure ID)' + Properties.OnChange = IgnoreThreadIDCheckBoxPropertiesChange + Style.TransparentBorder = False + TabOrder = 0 + end + end + object cxLabel7: TcxLabel + AlignWithMargins = True + Left = 8 + Top = 302 + Margins.Left = 8 + Margins.Top = 4 + Margins.Right = 8 + Align = alTop + Caption = 'Source Code Paths' + ParentFont = False + Style.Font.Charset = DEFAULT_CHARSET + Style.Font.Color = clWindowText + Style.Font.Height = -17 + Style.Font.Name = 'Segoe UI' + Style.Font.Style = [fsBold] + Style.IsFontAssigned = True + Properties.WordWrap = True + TabOrder = 10 + ExplicitTop = 349 + Width = 1236 + end + object cxLabel16: TcxLabel + AlignWithMargins = True + Left = 8 + Top = 187 + Margins.Left = 8 + Margins.Top = 8 + Margins.Right = 8 + Margins.Bottom = 0 + Align = alTop + Caption = 'Call Grouping (Help is available in Alcinoe.CodeProfiler.inc)' + ParentFont = False + Style.Font.Charset = DEFAULT_CHARSET + Style.Font.Color = clWindowText + Style.Font.Height = -17 + Style.Font.Name = 'Segoe UI' + Style.Font.Style = [fsBold] + Style.IsFontAssigned = True + Properties.WordWrap = True + TabOrder = 11 + ExplicitTop = 195 + Width = 1236 + end end end object PerformanceAnalysisTabSheet: TcxTabSheet @@ -531,7 +577,7 @@ object MainForm: TMainForm object Panelfilter: TPanel Left = 0 Top = 0 - Width = 1070 + Width = 1254 Height = 89 Margins.Left = 8 Align = alTop @@ -624,7 +670,7 @@ object MainForm: TMainForm object TreeListProcMetrics: TcxTreeList Left = 0 Top = 89 - Width = 1070 + Width = 1254 Height = 145 Align = alTop Bands = < @@ -724,8 +770,8 @@ object MainForm: TMainForm object GridProcMetrics: TcxGrid Left = 0 Top = 241 - Width = 1070 - Height = 585 + Width = 1254 + Height = 670 Align = alClient Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -813,7 +859,7 @@ object MainForm: TMainForm object cxSplitter1: TcxSplitter Left = 0 Top = 234 - Width = 1070 + Width = 1254 Height = 7 AlignSplitter = salTop end @@ -821,8 +867,8 @@ object MainForm: TMainForm end object MainStatusBar: TdxStatusBar Left = 0 - Top = 868 - Width = 1080 + Top = 953 + Width = 1264 Height = 32 Panels = < item diff --git a/Tools/CodeProfiler/_Source/Main.pas b/Tools/CodeProfiler/_Source/Main.pas index 7708b09ff..38a15932b 100644 --- a/Tools/CodeProfiler/_Source/Main.pas +++ b/Tools/CodeProfiler/_Source/Main.pas @@ -67,8 +67,7 @@ TMainForm = class(TForm) cxLabel3: TcxLabel; cxLabel4: TcxLabel; cxLabel5: TcxLabel; - cxLabel6: TcxLabel; - cxLabel8: TcxLabel; + LastInstructionLabel: TcxLabel; dxPanel2: TdxPanel; SourcesPathMemo: TcxMemo; cxLabel9: TcxLabel; @@ -78,7 +77,6 @@ TMainForm = class(TForm) TreeListProcMetricsColumnStartTimeStamp: TcxTreeListColumn; TreeListProcMetricsColumnCallCount: TcxTreeListColumn; GridTableViewProcMetricsColumnStartTimestamp: TcxGridColumn; - LastInstructionLabel: TcxLabel; StartTimeStampMinEdit: TcxMaskEdit; Label1: TLabel; StartTimeStampMaxEdit: TcxMaskEdit; @@ -107,6 +105,10 @@ TMainForm = class(TForm) CodeProfilerIncFilenameEdit: TcxTextEdit; dxPanel6: TdxPanel; CodeProfilerEnabledCheckBox: TcxCheckBox; + dxPanel7: TdxPanel; + IgnoreThreadIDCheckBox: TcxCheckBox; + cxLabel7: TcxLabel; + cxLabel16: TcxLabel; procedure InsertProfilerMarkersBtnClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); @@ -136,8 +138,13 @@ TMainForm = class(TForm) procedure CodeProfilerIncFilenameEditPropertiesChange(Sender: TObject); procedure BrowseCodeProfilerIncFilenameBtnClick(Sender: TObject); procedure CodeProfilerEnabledCheckBoxPropertiesChange(Sender: TObject); + procedure IgnoreThreadIDCheckBoxPropertiesChange(Sender: TObject); private const ConfigFilename = 'Config.ini'; + // Default value of ALCodeProfilerHistoryCapacity, used for every history + // group mode but ALCodeProfilerHistoryGroupByProcID, where the capacity + // is deduced from ALCodeProfilerProcIDMap.txt instead. + const DefaultHistoryCapacity = 1000000; private Type TGoBackStackItem = record @@ -241,6 +248,7 @@ TALProcMetrics = record function GetSelectedServerName: AnsiString; procedure SelectServerName(const AServerName: String); function GetCodeProfilerIncFilename: String; + function GetHistoryCapacity: Integer; procedure SaveCodeProfilerIncFile; procedure LoadCodeProfilerIncFile; procedure SaveConfigFile; @@ -389,6 +397,9 @@ procedure TMainForm.UpdateHistoryGroupModeUI; StartTimeStampMaxEdit.Enabled := False; end; end; + // ALCodeProfilerIgnoreThreadID is only supported by + // ALCodeProfilerHistoryGroupByProcID. + IgnoreThreadIDCheckBox.Enabled := GetSelectedHistoryGroupModeEnum = hgmByProcID; end; {*******************************************************************} @@ -543,6 +554,12 @@ procedure TMainForm.HistoryGroupModeRadioButtonClick(Sender: TObject); SaveCodeProfilerIncFile; end; +{*************************************************************************} +procedure TMainForm.IgnoreThreadIDCheckBoxPropertiesChange(Sender: TObject); +begin + SaveCodeProfilerIncFile; +end; + {**********************************************************} function TMainForm.GetCodeProfilerIncFilename: String; begin @@ -555,6 +572,34 @@ function TMainForm.GetCodeProfilerIncFilename: String; Result := ExpandFileName(Result); end; +{****************************************} +function TMainForm.GetHistoryCapacity: Integer; +begin + // With ALCodeProfilerHistoryGroupByProcID the history is a flat array + // indexed by the procedure ID, so it only needs to be big enough to hold the + // highest procedure ID of ALCodeProfilerProcIDMap.txt. When that file does + // not exist (no markers inserted yet, or markers just removed) fall back to + // the default capacity. + Result := DefaultHistoryCapacity; + var LProcIDMapFilename := TPath.Combine(FDataDir, ALCodeProfilerProcIDMapFilename); + if not TFile.Exists(LProcIDMapFilename) then exit; + var LProcIDMap := TALStringListA.Create; + try + LProcIDMap.LoadFromFile(LProcIDMapFilename); + if LProcIDMap.Count = 0 then exit; + var LMaxProcID := 0; + for var I := 0 to LProcIDMap.Count - 1 do begin + var LProcID := ALStrToInt(LProcIDMap.Names[I]); + if LProcID > LMaxProcID then LMaxProcID := LProcID; + end; + // The procedure IDs start at 1, so the array must have LMaxProcID + 1 + // items for FArray[LMaxProcID] to be valid. + Result := LMaxProcID + 1; + finally + ALFreeAndNil(LProcIDMap); + end; +end; + {*******************************************} procedure TMainForm.SaveCodeProfilerIncFile; var @@ -607,6 +652,22 @@ procedure TMainForm.SaveCodeProfilerIncFile; '// NOTE: This is the fastest option and has the lowest impact on each function call.'#10 + _DefineLine('ALCodeProfilerHistoryGroupByProcID') + #10 + #10 + + '{$IF defined(ALCodeProfilerHistoryGroupByProcID)}'#10 + + '// Ignore the thread ID. The calls made from every thread are merged together'#10 + + '// instead of producing one row per procedure and per thread, for example:'#10 + + '// procedure A - 3 calls - 310 ms = 1 call from the main thread + 2 calls from a background thread'#10 + + '//'#10 + + '// NOTE: This option is only available with ALCodeProfilerHistoryGroupByProcID.'#10 + + '// All the threads then share the same metrics, which are updated atomically,'#10 + + '// so it slightly increases the cost of each function call, but it also greatly'#10 + + '// reduces the memory usage as only one history is allocated for the whole'#10 + + '// process instead of one per thread.'#10 + + ALIfThenA( + IgnoreThreadIDCheckBox.Checked, + '{$DEFINE ALCodeProfilerIgnoreThreadID}', + '{.$DEFINE ALCodeProfilerIgnoreThreadID}') + #10 + + '{$ENDIF}'#10 + + #10 + '// Group calls by call stack.'#10 + '// The result will be displayed as a grouped call tree, for example:'#10 + '// procedure A - 1 call - 310 ms'#10 + @@ -614,7 +675,22 @@ procedure TMainForm.SaveCodeProfilerIncFile; '// procedure C - 3 calls - 46 ms'#10 + '// procedure D - 1 call - 85 ms'#10 + '// procedure C - 1 call - 22 ms'#10 + - _DefineLine('ALCodeProfilerHistoryGroupByCallStack') + #10; + _DefineLine('ALCodeProfilerHistoryGroupByCallStack') + #10 + + #10 + + '// Capacity of the history, in number of rows.'#10 + + '//'#10 + + '// NOTE: With ALCodeProfilerHistoryGroupByProcID the history is a flat array'#10 + + '// indexed by the procedure ID, so it only needs to be big enough to hold the'#10 + + '// highest procedure ID of ' + AnsiString(ALCodeProfilerProcIDMapFilename) + '. The value below is'#10 + + '// updated by the Alcinoe Code Profiler GUI each time the markers are inserted'#10 + + '// or removed, so there is no reason to edit it by hand.'#10 + + '{$IF defined(ALCodeProfilerHistoryGroupByProcID)}'#10 + + 'const'#10 + + ' ALCodeProfilerHistoryCapacity = '+ALIntToStrA(GetHistoryCapacity)+';'#10 + + '{$ELSE}'#10 + + 'const'#10 + + ' ALCodeProfilerHistoryCapacity = '+ALIntToStrA(DefaultHistoryCapacity)+'; {1 000 000 * 32 Bytes = 32 MB or with gap = 2 097 152 * 32 Bytes = 67.11 MB}'#10 + + '{$ENDIF}'#10; ALSaveStringToFile(LContent, LIncFilename); end; @@ -633,6 +709,8 @@ procedure TMainForm.LoadCodeProfilerIncFile; else if ALPosA('{$DEFINE ALCodeProfilerHistoryGroupByProcID}', LContent) > 0 then SelectHistoryGroupMode('ALCodeProfilerHistoryGroupByProcID') else SelectHistoryGroupMode('ALCodeProfilerHistoryGroupByCallStack'); //-- + IgnoreThreadIDCheckBox.Checked := ALPosA('{$DEFINE ALCodeProfilerIgnoreThreadID}', LContent) > 0; + //-- var LServerName: String := ''; var LMarker: AnsiString := 'ALCodeProfilerServerName: String = '''; var LValueStart := ALPosA(LMarker, LContent); @@ -742,6 +820,9 @@ procedure TMainForm.RemoveProfilerMarkersBtnClick(Sender: TObject); var LProcIDMapFilename := TPath.Combine(FDataDir, ALCodeProfilerProcIDMapFilename); If TFile.Exists(LProcIDMapFilename) then TFile.Delete(LProcIDMapFilename); + // ALCodeProfilerHistoryCapacity was deduced from the procedure IDs just + // deleted, so Alcinoe.CodeProfiler.inc must be reset as well. + SaveCodeProfilerIncFile; MessageDlg('The operation completed successfully', mtInformation, [mbOK], 0); Finally ALFreeAndNil(LSourceFilenames); @@ -1150,6 +1231,9 @@ procedure TMainForm.InsertProfilerMarkersBtnClick(Sender: TObject); LFailedFilenames.Add(LSourceFilenames[i]); end; LProcIDMap.SaveToFile(LProcIDMapFilename); + // ALCodeProfilerHistoryCapacity depends on the procedure IDs just + // assigned, so Alcinoe.CodeProfiler.inc must be updated as well. + SaveCodeProfilerIncFile; finally InsertProfilerMarkersBtn.Cursor := crDefault; End; From f8f6a66db50a42d4c41f682cd978463a48480983 Mon Sep 17 00:00:00 2001 From: stv Date: Mon, 21 Sep 2026 12:59:11 +0200 Subject: [PATCH 4/9] update --- Source/Alcinoe.CodeProfiler.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Source/Alcinoe.CodeProfiler.pas b/Source/Alcinoe.CodeProfiler.pas index 04d86127e..d2eba9d14 100644 --- a/Source/Alcinoe.CodeProfiler.pas +++ b/Source/Alcinoe.CodeProfiler.pas @@ -485,7 +485,7 @@ procedure ALCodeProfilerPurgeHistories(const ASaveHistories: boolean); ALProcMetricsLock.BeginWrite; try for var I := ALProcMetricsHistories.Count - 1 downto 0 do begin - if ASaveHistories then ALCodeProfilerSaveHistory(ALProcMetricsHistories[i]); + if ASaveHistories then ALCodeProfilerSaveHistory(ALProcMetricsHistories[i]) else ALProcMetricsHistories[i].Clear; end; finally From a7941af04d47da618cec4dc5951667cee74acaab Mon Sep 17 00:00:00 2001 From: stv Date: Mon, 21 Sep 2026 15:30:56 +0200 Subject: [PATCH 5/9] update --- Source/Alcinoe.CodeProfiler.pas | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/Source/Alcinoe.CodeProfiler.pas b/Source/Alcinoe.CodeProfiler.pas index d2eba9d14..dcc410091 100644 --- a/Source/Alcinoe.CodeProfiler.pas +++ b/Source/Alcinoe.CodeProfiler.pas @@ -479,15 +479,13 @@ procedure ALCodeProfilerSaveHistory(const AProcMetricsHistory: TALProcMetricsHis AProcMetricsHistory.Clear; end; -{********************************************************************} -procedure ALCodeProfilerPurgeHistories(const ASaveHistories: boolean); +{*************************************} +procedure ALCodeProfilerPurgeHistories; begin ALProcMetricsLock.BeginWrite; try - for var I := ALProcMetricsHistories.Count - 1 downto 0 do begin - if ASaveHistories then ALCodeProfilerSaveHistory(ALProcMetricsHistories[i]) - else ALProcMetricsHistories[i].Clear; - end; + for var I := ALProcMetricsHistories.Count - 1 downto 0 do + ALCodeProfilerSaveHistory(ALProcMetricsHistories[i]); finally ALProcMetricsLock.EndWrite; end; @@ -671,7 +669,7 @@ TStopwatchAccessPrivate = record if (LProcMetricsHistory.FCount >= 100_000_000) {100_000_000 * 32 Bytes = 3.2 GB} then begin ALProcMetricsLock.EndRead; try - ALCodeProfilerPurgeHistories(ALCodeProfilerEnabled{ASaveHistories}) + ALCodeProfilerPurgeHistories; finally ALProcMetricsLock.BeginRead; end; @@ -840,7 +838,7 @@ procedure ALCodeProfilerApplicationEventHandler(const Sender: TObject; const M: if (M is TApplicationEventMessage) and ((M as TApplicationEventMessage).value.Event = TApplicationEvent.BecameActive) then begin if ALCodeProfilerAppActivatedBefore then - ALCodeProfilerPurgeHistories(ALCodeProfilerEnabled{ASaveHistories}) + ALCodeProfilerPurgeHistories; else ALCodeProfilerAppActivatedBefore := True; end; @@ -873,7 +871,7 @@ initialization finalization {$IF (not defined(IOS)) and (not defined(ANDROID))} // At this point, all background threads must have completed. - ALCodeProfilerPurgeHistories(ALCodeProfilerEnabled{ASaveHistories}); + ALCodeProfilerPurgeHistories; {$ENDIF} ALCodeProfilerEnabled := False; //-- From f3b21a2f6e00133b96c5203cfec3643f9bfbcc33 Mon Sep 17 00:00:00 2001 From: stv Date: Tue, 22 Sep 2026 10:11:19 +0200 Subject: [PATCH 6/9] update --- Source/Alcinoe.CodeProfiler.pas | 99 ++++++++++++++++++--------------- 1 file changed, 54 insertions(+), 45 deletions(-) diff --git a/Source/Alcinoe.CodeProfiler.pas b/Source/Alcinoe.CodeProfiler.pas index dcc410091..402390096 100644 --- a/Source/Alcinoe.CodeProfiler.pas +++ b/Source/Alcinoe.CodeProfiler.pas @@ -457,8 +457,13 @@ procedure ALCodeProfilerSaveHistory(const AProcMetricsHistory: TALProcMetricsHis end; //-- var LfileStream: TFileStream; + {$IF defined(ALCodeProfilerHistoryGroupByProcID) or defined(ALCodeProfilerHistoryGroupByCallStack)} + if Tfile.Exists(ALProcMetricsFilename) then Tfile.Delete(ALProcMetricsFilename); + LfileStream := TFileStream.Create(ALProcMetricsFilename, fmCreate); + {$ELSE} if Tfile.Exists(ALProcMetricsFilename) then LfileStream := TFileStream.Create(ALProcMetricsFilename, fmOpenWrite) else LfileStream := TFileStream.Create(ALProcMetricsFilename, fmCreate); + {$ENDIF} try LfileStream.Position := LfileStream.Size; {$IF defined(ALCodeProfilerHistoryGroupNone)} @@ -475,8 +480,6 @@ procedure ALCodeProfilerSaveHistory(const AProcMetricsHistory: TALProcMetricsHis finally LFileStream.Free; end; - //-- - AProcMetricsHistory.Clear; end; {*************************************} @@ -484,52 +487,58 @@ procedure ALCodeProfilerPurgeHistories; begin ALProcMetricsLock.BeginWrite; try - for var I := ALProcMetricsHistories.Count - 1 downto 0 do + + for var I := ALProcMetricsHistories.Count - 1 downto 0 do begin ALCodeProfilerSaveHistory(ALProcMetricsHistories[i]); - finally - ALProcMetricsLock.EndWrite; - end; - //-- - if ALCodeProfilerServerName <> '' then begin - var LGuid: TGUID; - if CreateGUID(LGuid) <> S_OK then RaiseLastOSError; - var LGuidStr: String; - SetLength(LGuidStr, 32); - StrLFmt( - PChar(LGuidStr), 32,'%.8x%.4x%.4x%.2x%.2x%.2x%.2x%.2x%.2x%.2x%.2x', - [LGuid.D1, LGuid.D2, LGuid.D3, LGuid.D4[0], LGuid.D4[1], LGuid.D4[2], LGuid.D4[3], - LGuid.D4[4], LGuid.D4[5], LGuid.D4[6], LGuid.D4[7]]); - var LTmpProcMetricsFilename := ALProcMetricsFilename + '~' + LGuidStr; - TFile.Move(ALProcMetricsFilename, LTmpProcMetricsFilename); - {$IF defined(IOS) or defined(ANDROID)} - TThread.CreateAnonymousThread( - procedure - begin + {$IF defined(ALCodeProfilerHistoryGroupNone)} + ALProcMetricsHistories[i].Clear; {$ENDIF} - var LHTTPClient := TNetHTTPClient.Create(nil); - try - Try - var LFileStream := TFileStream.Create(LTmpProcMetricsFilename, fmOpenRead or fmShareDenyWrite); - try - var LHeaders: TNetHeaders; - setlength(LHeaders, 1); - LHeaders[0].Name := 'Content-Type'; - LHeaders[0].Value := 'application/octet-stream'; - LHTTPClient.Post(ALCodeProfilerServerName, LFileStream, nil{AResponseContent}, LHeaders); - finally - LFileStream.Free; - end; - Except - On E: Exception do - ALCodeProfilerLog('ALCodeProfiler', E.Message, TALCodeProfilerLogType.ERROR); - End; - finally - TFile.Delete(LTmpProcMetricsFilename); - LHTTPClient.Free; - end; + end; + + if ALCodeProfilerServerName <> '' then begin + var LGuid: TGUID; + if CreateGUID(LGuid) <> S_OK then RaiseLastOSError; + var LGuidStr: String; + SetLength(LGuidStr, 32); + StrLFmt( + PChar(LGuidStr), 32,'%.8x%.4x%.4x%.2x%.2x%.2x%.2x%.2x%.2x%.2x%.2x', + [LGuid.D1, LGuid.D2, LGuid.D3, LGuid.D4[0], LGuid.D4[1], LGuid.D4[2], LGuid.D4[3], + LGuid.D4[4], LGuid.D4[5], LGuid.D4[6], LGuid.D4[7]]); + var LTmpProcMetricsFilename := ALProcMetricsFilename + '~' + LGuidStr; + TFile.Move(ALProcMetricsFilename, LTmpProcMetricsFilename); {$IF defined(IOS) or defined(ANDROID)} - end).Start; - {$ENDIF} + TThread.CreateAnonymousThread( + procedure + begin + {$ENDIF} + var LHTTPClient := TNetHTTPClient.Create(nil); + try + Try + var LFileStream := TFileStream.Create(LTmpProcMetricsFilename, fmOpenRead or fmShareDenyWrite); + try + var LHeaders: TNetHeaders; + setlength(LHeaders, 1); + LHeaders[0].Name := 'Content-Type'; + LHeaders[0].Value := 'application/octet-stream'; + LHTTPClient.Post(ALCodeProfilerServerName, LFileStream, nil{AResponseContent}, LHeaders); + finally + LFileStream.Free; + end; + Except + On E: Exception do + ALCodeProfilerLog('ALCodeProfiler', E.Message, TALCodeProfilerLogType.ERROR); + End; + finally + TFile.Delete(LTmpProcMetricsFilename); + LHTTPClient.Free; + end; + {$IF defined(IOS) or defined(ANDROID)} + end).Start; + {$ENDIF} + end; + + finally + ALProcMetricsLock.EndWrite; end; end; From 984b3799edb3591a78b3328229f1dd221ae7ac69 Mon Sep 17 00:00:00 2001 From: stv Date: Tue, 22 Sep 2026 11:16:05 +0200 Subject: [PATCH 7/9] update --- .../DelphiAST/Demo/Parser/ParserDemo.dpr | 18 + .../DelphiAST/Demo/Parser/ParserDemo.dproj | 547 ++ .../DelphiAST/Demo/Parser/ParserDemo.lpi | 98 + .../DelphiAST/Demo/Parser/ParserDemo.lpr | 16 + .../DelphiAST/Demo/Parser/ParserDemo.lps | 178 + .../DelphiAST/Demo/Parser/ParserDemo.or | Bin 0 -> 90712 bytes .../Demo/Parser/StringUsageLogging.pas | 94 + .../DelphiAST/Demo/Parser/uMainForm.dfm | 124 + .../DelphiAST/Demo/Parser/uMainForm.lfm | 61 + .../DelphiAST/Demo/Parser/uMainForm.pas | 195 + .../ProjectIndexer/ProjectIndexerResearch.dpr | 65 + .../ProjectIndexerResearch.dproj | 499 ++ .../Demo/ProjectIndexer/TestUnit.pas | 17 + .../Demo/ProjectIndexer/demo/DemoProject.dpr | 27 + .../ProjectIndexer/demo/DemoProject.otares | Bin 0 -> 96 bytes .../Demo/ProjectIndexer/demo/UnitAa.pas | 10 + .../Demo/ProjectIndexer/demo/sub1/Unit1.pas | 16 + .../Demo/ProjectIndexer/demo/sub1/UnitA.pas | 10 + .../ProjectIndexer/demo/sub1inc/include.inc | 2 + .../Demo/ProjectIndexer/demo/sub2/Unit1.pas | 10 + .../Demo/ProjectIndexer/demo/sub2/Unit2.pas | 21 + .../Demo/ProjectIndexer/demo/sub2/UnitA.pas | 12 + .../ProjectIndexer/demo/sub2inc/include.inc | 2 + .../ProjectIndexer/demo/subinc/include.inc | 2 + References/DelphiAST/LICENSE | 373 ++ References/DelphiAST/README.md | 91 + .../DelphiAST/Source/DelphiAST.Classes.pas | 587 ++ .../DelphiAST/Source/DelphiAST.Consts.pas | 323 + .../Source/DelphiAST.ProjectIndexer.pas | 615 ++ .../Source/DelphiAST.Serialize.Binary.pas | 335 + .../Source/DelphiAST.SimpleParserEx.pas | 422 ++ .../DelphiAST/Source/DelphiAST.Writer.pas | 158 + References/DelphiAST/Source/DelphiAST.pas | 2828 ++++++++ .../Source/FreePascalSupport/Diagnostics.pas | 204 + .../FPC_StringBuilder/.gitignore | 3 + .../FPC_StringBuilder/FPC_StringBuilder.lpk | 39 + .../FPC_StringBuilder/FPC_StringBuilder.pas | 20 + .../FPC_StringBuilder/Src/StringBuilderUnit.o | Bin 0 -> 17690 bytes .../Src/StringBuilderUnit.pas | 171 + .../Src/StringBuilderUnit.ppu | Bin 0 -> 10881 bytes .../Src/Test/Test_001/Test_001.lpi | 82 + .../Src/Test/Test_001/Test_001.lpr | 20 + .../Test/Test_002_Performance/Test_002.lpi | 87 + .../Test/Test_002_Performance/Test_002.lpr | 70 + .../Generics.Collection/README.md | 2 + .../TArrayDouble/TArrayProjectDouble.lpi | 73 + .../TArrayDouble/TArrayProjectDouble.lpr | 91 + .../TArraySingle/TArrayProjectSingle.lpi | 78 + .../TArraySingle/TArrayProjectSingle.lpr | 111 + .../examples/TComparer/TComparerProject.lpi | 73 + .../examples/TComparer/TComparerProject.lpr | 124 + .../examples/THashMap/THashMapProject.lpi | 78 + .../examples/THashMap/THashMapProject.lpr | 218 + .../THashMapCaseInsensitive.lpi | 73 + .../THashMapCaseInsensitive.lpr | 55 + .../THashMapExtendedEqualityComparer.lpi | 73 + .../THashMapExtendedEqualityComparer.lpr | 108 + .../TObjectList/TObjectListProject.lpi | 73 + .../TObjectList/TObjectListProject.lpr | 194 + .../examples/TQueue/TQueueProject.lpi | 73 + .../examples/TQueue/TQueueProject.lpr | 89 + .../examples/TStack/TStackProject.lpi | 73 + .../examples/TStack/TStackProject.lpr | 86 + .../src/generics.collections.pas | 1263 ++++ .../src/generics.defaults.pas | 3372 ++++++++++ .../src/generics.hashes.pas | 913 +++ .../src/generics.helpers.pas | 157 + .../src/generics.memoryexpanders.pas | 236 + .../src/generics.strings.pas | 34 + .../src/inc/generics.dictionaries.inc | 1859 ++++++ .../src/inc/generics.dictionariesh.inc | 533 ++ .../Source/FreePascalSupport/IOUtils.pas | 22 + .../SimpleParser/SimpleParser.Lexer.Types.pas | 327 + .../SimpleParser/SimpleParser.Lexer.pas | 3076 +++++++++ .../SimpleParser/SimpleParser.Types.pas | 330 + .../Source/SimpleParser/SimpleParser.inc | 332 + .../Source/SimpleParser/SimpleParser.pas | 5918 +++++++++++++++++ .../Source/SimpleParser/SimpleParser.rsj | 4 + References/DelphiAST/Source/StringPool.pas | 118 + References/DelphiAST/Test/DelphiASTTest.dpr | 16 + References/DelphiAST/Test/DelphiASTTest.dproj | 520 ++ References/DelphiAST/Test/DelphiASTTest.lpr | 16 + .../Test/Snippets/DeprecatedOnConst.pas | 11 + .../Snippets/VariantRecordFieldAttributes.pas | 17 + .../Test/Snippets/alignedrecords.pas | 26 + .../DelphiAST/Test/Snippets/constset.pas | 21 + .../Test/Snippets/deprecatedtype.pas | 20 + .../DelphiAST/Test/Snippets/dottedtypes.pas | 37 + .../DelphiAST/Test/Snippets/endtoken.pas | 32 + .../DelphiAST/Test/Snippets/experimentals.pas | 18 + .../Test/Snippets/externalfunction.pas | 9 + .../finalizationinitializationexports.pas | 53 + .../Test/Snippets/forwardoverloaded.pas | 19 + .../Test/Snippets/forwardwithoutsemicolon.pas | 20 + .../Test/Snippets/genericconstraints.pas | 26 + .../genericinterfacemethoddelegation.pas | 28 + .../Test/Snippets/implementsgenerictype.pas | 18 + .../DelphiAST/Test/Snippets/include file2.inc | 1 + .../DelphiAST/Test/Snippets/includefile.inc | 1 + .../DelphiAST/Test/Snippets/includefile.pas | 17 + .../DelphiAST/Test/Snippets/isnotnotin.pas | 18 + .../Test/Snippets/managedrecords.pas | 25 + .../DelphiAST/Test/Snippets/messagemethod.pas | 13 + .../DelphiAST/Test/Snippets/multiline.pas | 24 + .../Test/Snippets/nonalignedrecords.pas | 25 + .../DelphiAST/Test/Snippets/noreturn.pas | 18 + .../DelphiAST/Test/Snippets/numbers.pas | 20 + .../DelphiAST/Test/Snippets/pointerchars.pas | 28 + .../DelphiAST/Test/Snippets/properties.pas | 24 + .../Test/Snippets/strictvisibility.pas | 13 + .../DelphiAST/Test/Snippets/ternaryop.pas | 17 + .../DelphiAST/Test/Snippets/tryexcept.pas | 54 + .../DelphiAST/Test/Snippets/umlauts.pas | Bin 0 -> 308 bytes .../whitespacearoundifdefcondition.pas | 23 + References/DelphiAST/Test/uMainForm.dfm | 44 + References/DelphiAST/Test/uMainForm.pas | 102 + 116 files changed, 30065 insertions(+) create mode 100644 References/DelphiAST/Demo/Parser/ParserDemo.dpr create mode 100644 References/DelphiAST/Demo/Parser/ParserDemo.dproj create mode 100644 References/DelphiAST/Demo/Parser/ParserDemo.lpi create mode 100644 References/DelphiAST/Demo/Parser/ParserDemo.lpr create mode 100644 References/DelphiAST/Demo/Parser/ParserDemo.lps create mode 100644 References/DelphiAST/Demo/Parser/ParserDemo.or create mode 100644 References/DelphiAST/Demo/Parser/StringUsageLogging.pas create mode 100644 References/DelphiAST/Demo/Parser/uMainForm.dfm create mode 100644 References/DelphiAST/Demo/Parser/uMainForm.lfm create mode 100644 References/DelphiAST/Demo/Parser/uMainForm.pas create mode 100644 References/DelphiAST/Demo/ProjectIndexer/ProjectIndexerResearch.dpr create mode 100644 References/DelphiAST/Demo/ProjectIndexer/ProjectIndexerResearch.dproj create mode 100644 References/DelphiAST/Demo/ProjectIndexer/TestUnit.pas create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/DemoProject.dpr create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/DemoProject.otares create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/UnitAa.pas create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/sub1/Unit1.pas create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/sub1/UnitA.pas create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/sub1inc/include.inc create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/sub2/Unit1.pas create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/sub2/Unit2.pas create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/sub2/UnitA.pas create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/sub2inc/include.inc create mode 100644 References/DelphiAST/Demo/ProjectIndexer/demo/subinc/include.inc create mode 100644 References/DelphiAST/LICENSE create mode 100644 References/DelphiAST/README.md create mode 100644 References/DelphiAST/Source/DelphiAST.Classes.pas create mode 100644 References/DelphiAST/Source/DelphiAST.Consts.pas create mode 100644 References/DelphiAST/Source/DelphiAST.ProjectIndexer.pas create mode 100644 References/DelphiAST/Source/DelphiAST.Serialize.Binary.pas create mode 100644 References/DelphiAST/Source/DelphiAST.SimpleParserEx.pas create mode 100644 References/DelphiAST/Source/DelphiAST.Writer.pas create mode 100644 References/DelphiAST/Source/DelphiAST.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/Diagnostics.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/.gitignore create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/FPC_StringBuilder.lpk create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/FPC_StringBuilder.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.o create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/StringBuilderUnit.ppu create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_001/Test_001.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_001/Test_001.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_002_Performance/Test_002.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/FPC_StringBuilder/Src/Test/Test_002_Performance/Test_002.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/README.md create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArrayDouble/TArrayProjectDouble.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArrayDouble/TArrayProjectDouble.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArraySingle/TArrayProjectSingle.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TArraySingle/TArrayProjectSingle.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TComparer/TComparerProject.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TComparer/TComparerProject.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMap/THashMapProject.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMap/THashMapProject.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapCaseInsensitive/THashMapCaseInsensitive.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapCaseInsensitive/THashMapCaseInsensitive.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapExtendedEqualityComparer/THashMapExtendedEqualityComparer.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/THashMapExtendedEqualityComparer/THashMapExtendedEqualityComparer.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TObjectList/TObjectListProject.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TObjectList/TObjectListProject.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TQueue/TQueueProject.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TQueue/TQueueProject.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TStack/TStackProject.lpi create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/examples/TStack/TStackProject.lpr create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.collections.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.defaults.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.hashes.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.helpers.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.memoryexpanders.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.strings.pas create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/inc/generics.dictionaries.inc create mode 100644 References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/inc/generics.dictionariesh.inc create mode 100644 References/DelphiAST/Source/FreePascalSupport/IOUtils.pas create mode 100644 References/DelphiAST/Source/SimpleParser/SimpleParser.Lexer.Types.pas create mode 100644 References/DelphiAST/Source/SimpleParser/SimpleParser.Lexer.pas create mode 100644 References/DelphiAST/Source/SimpleParser/SimpleParser.Types.pas create mode 100644 References/DelphiAST/Source/SimpleParser/SimpleParser.inc create mode 100644 References/DelphiAST/Source/SimpleParser/SimpleParser.pas create mode 100644 References/DelphiAST/Source/SimpleParser/SimpleParser.rsj create mode 100644 References/DelphiAST/Source/StringPool.pas create mode 100644 References/DelphiAST/Test/DelphiASTTest.dpr create mode 100644 References/DelphiAST/Test/DelphiASTTest.dproj create mode 100644 References/DelphiAST/Test/DelphiASTTest.lpr create mode 100644 References/DelphiAST/Test/Snippets/DeprecatedOnConst.pas create mode 100644 References/DelphiAST/Test/Snippets/VariantRecordFieldAttributes.pas create mode 100644 References/DelphiAST/Test/Snippets/alignedrecords.pas create mode 100644 References/DelphiAST/Test/Snippets/constset.pas create mode 100644 References/DelphiAST/Test/Snippets/deprecatedtype.pas create mode 100644 References/DelphiAST/Test/Snippets/dottedtypes.pas create mode 100644 References/DelphiAST/Test/Snippets/endtoken.pas create mode 100644 References/DelphiAST/Test/Snippets/experimentals.pas create mode 100644 References/DelphiAST/Test/Snippets/externalfunction.pas create mode 100644 References/DelphiAST/Test/Snippets/finalizationinitializationexports.pas create mode 100644 References/DelphiAST/Test/Snippets/forwardoverloaded.pas create mode 100644 References/DelphiAST/Test/Snippets/forwardwithoutsemicolon.pas create mode 100644 References/DelphiAST/Test/Snippets/genericconstraints.pas create mode 100644 References/DelphiAST/Test/Snippets/genericinterfacemethoddelegation.pas create mode 100644 References/DelphiAST/Test/Snippets/implementsgenerictype.pas create mode 100644 References/DelphiAST/Test/Snippets/include file2.inc create mode 100644 References/DelphiAST/Test/Snippets/includefile.inc create mode 100644 References/DelphiAST/Test/Snippets/includefile.pas create mode 100644 References/DelphiAST/Test/Snippets/isnotnotin.pas create mode 100644 References/DelphiAST/Test/Snippets/managedrecords.pas create mode 100644 References/DelphiAST/Test/Snippets/messagemethod.pas create mode 100644 References/DelphiAST/Test/Snippets/multiline.pas create mode 100644 References/DelphiAST/Test/Snippets/nonalignedrecords.pas create mode 100644 References/DelphiAST/Test/Snippets/noreturn.pas create mode 100644 References/DelphiAST/Test/Snippets/numbers.pas create mode 100644 References/DelphiAST/Test/Snippets/pointerchars.pas create mode 100644 References/DelphiAST/Test/Snippets/properties.pas create mode 100644 References/DelphiAST/Test/Snippets/strictvisibility.pas create mode 100644 References/DelphiAST/Test/Snippets/ternaryop.pas create mode 100644 References/DelphiAST/Test/Snippets/tryexcept.pas create mode 100644 References/DelphiAST/Test/Snippets/umlauts.pas create mode 100644 References/DelphiAST/Test/Snippets/whitespacearoundifdefcondition.pas create mode 100644 References/DelphiAST/Test/uMainForm.dfm create mode 100644 References/DelphiAST/Test/uMainForm.pas 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 + + +
MainForm
+ + + + 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 @@ + + + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="4"> + <Unit0> + <Filename Value="ParserDemo.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="uMainForm.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="MainForm"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + </Unit1> + <Unit2> + <Filename Value="..\..\Source\DelphiAST.Classes.pas"/> + <IsPartOfProject Value="True"/> + </Unit2> + <Unit3> + <Filename Value="..\..\Source\DelphiAST.pas"/> + <IsPartOfProject Value="True"/> + </Unit3> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <IncludeFiles Value="..\..\Source;..\..\Source\SimpleParser;..\..\Source\FreePascalSupport\Generics.Collections\src;$(ProjOutDir)"/> + <OtherUnitFiles Value="..\..\Source;..\..\Source\FreePascalSupport\FPC_StringBuilder\Src;..\..\Source\FreePascalSupport\Generics.Collection\src;..\..\Source\FreePascalSupport;..\..\Source\SimpleParser"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <SyntaxMode Value="Delphi"/> + </SyntaxOptions> + </Parsing> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CustomOptions Value="-dBorland -dVer150 -dDelphi7 -dCompiler6_Up -dPUREPASCAL"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="9"> + <Unit0> + <Filename Value="ParserDemo.lpr"/> + <IsPartOfProject Value="True"/> + <IsVisibleTab Value="True"/> + <CursorPos X="53" Y="16"/> + <UsageCount Value="33"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit0> + <Unit1> + <Filename Value="uMainForm.pas"/> + <IsPartOfProject Value="True"/> + <HasResources Value="True"/> + <EditorIndex Value="1"/> + <TopLine Value="22"/> + <CursorPos X="58" Y="48"/> + <UsageCount Value="33"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit1> + <Unit2> + <Filename Value="..\Source\DelphiAST.Classes.pas"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="2"/> + <TopLine Value="49"/> + <CursorPos X="29" Y="68"/> + <UsageCount Value="33"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit2> + <Unit3> + <Filename Value="..\Source\DelphiAST.pas"/> + <IsPartOfProject Value="True"/> + <EditorIndex Value="4"/> + <CursorPos X="22" Y="8"/> + <UsageCount Value="33"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit3> + <Unit4> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <EditorIndex Value="3"/> + <TopLine Value="684"/> + <CursorPos X="42" Y="661"/> + <UsageCount Value="16"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit4> + <Unit5> + <Filename Value="..\..\Generics.Collections\src\inc\generics.dictionaries.inc"/> + <EditorIndex Value="-1"/> + <TopLine Value="143"/> + <CursorPos X="92" Y="158"/> + <UsageCount Value="9"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit5> + <Unit6> + <Filename Value="..\..\Generics.Collections\src\generics.defaults.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="59"/> + <CursorPos X="48" Y="85"/> + <UsageCount Value="15"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit6> + <Unit7> + <Filename Value="..\Source\DelphiAST.Writer.pas"/> + <EditorIndex Value="5"/> + <TopLine Value="65"/> + <CursorPos X="15" Y="74"/> + <UsageCount Value="15"/> + <Loaded Value="True"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit7> + <Unit8> + <Filename Value="..\..\FPC_StringBuilder\Src\StringBuilderUnit.pas"/> + <EditorIndex Value="-1"/> + <TopLine Value="98"/> + <CursorPos X="95" Y="124"/> + <UsageCount Value="14"/> + <DefaultSyntaxHighlighter Value="Delphi"/> + </Unit8> + </Units> + <JumpHistory Count="22" HistoryIndex="21"> + <Position1> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="702" Column="29" TopLine="675"/> + </Position1> + <Position2> + <Filename Value="..\Source\DelphiAST.Classes.pas"/> + </Position2> + <Position3> + <Filename Value="..\Source\DelphiAST.pas"/> + <Caret Line="1528" Column="14" TopLine="1492"/> + </Position3> + <Position4> + <Filename Value="..\Source\DelphiAST.pas"/> + <Caret Line="1518" Column="26" TopLine="1492"/> + </Position4> + <Position5> + <Filename Value="..\Source\DelphiAST.pas"/> + <Caret Line="231" Column="22" TopLine="188"/> + </Position5> + <Position6> + <Filename Value="..\Source\DelphiAST.pas"/> + <Caret Line="234" Column="34" TopLine="190"/> + </Position6> + <Position7> + <Filename Value="..\Source\DelphiAST.pas"/> + <Caret Line="216" Column="48" TopLine="198"/> + </Position7> + <Position8> + <Filename Value="..\Source\DelphiAST.pas"/> + <Caret Line="231" Column="49" TopLine="201"/> + </Position8> + <Position9> + <Filename Value="..\Source\DelphiAST.pas"/> + <Caret Line="52" Column="131" TopLine="31"/> + </Position9> + <Position10> + <Filename Value="..\Source\DelphiAST.Writer.pas"/> + </Position10> + <Position11> + <Filename Value="..\Source\DelphiAST.Writer.pas"/> + <Caret Line="7" Column="23"/> + </Position11> + <Position12> + <Filename Value="..\Source\DelphiAST.Writer.pas"/> + <Caret Line="22" Column="48"/> + </Position12> + <Position13> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="662" Column="35" TopLine="637"/> + </Position13> + <Position14> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="647" Column="34" TopLine="637"/> + </Position14> + <Position15> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="678" TopLine="637"/> + </Position15> + <Position16> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="677" Column="11" TopLine="637"/> + </Position16> + <Position17> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="676" TopLine="637"/> + </Position17> + <Position18> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="693" Column="58" TopLine="686"/> + </Position18> + <Position19> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="667" TopLine="646"/> + </Position19> + <Position20> + <Filename Value="..\Source\SimpleParser\SimpleParser.pas"/> + <Caret Line="676" Column="24" TopLine="648"/> + </Position20> + <Position21> + <Filename Value="..\Source\DelphiAST.pas"/> + <Caret Line="239" Column="8" TopLine="201"/> + </Position21> + <Position22> + <Filename Value="ParserDemo.lpr"/> + </Position22> + </JumpHistory> + </ProjectSession> +</CONFIG> diff --git a/References/DelphiAST/Demo/Parser/ParserDemo.or b/References/DelphiAST/Demo/Parser/ParserDemo.or new file mode 100644 index 0000000000000000000000000000000000000000..682f1845106f6da4dc7817e8be2c134d76f17f16 GIT binary patch literal 90712 zcmc$_1zc6lw>Q2I-62vUDXFxGbcaYvr-0H@0uoY(1{FbR0RfRl0qIT!1Ox=6B$Spe zsRQRfM<0KW`g?ruz5n;V_pZ-p`Q7U~Yi7@^nOS?!=BNULK`4>A0fW9@VZgXuTwQK{ zW556N+!O|hfy-%tC=mxL1wl;!eiEE-^)(;}jt<yq7zD=z7>x$O@c=dfBmk&^1;L3> z<=7CM1Rx0x1g8Qh1rWebLh!A<CeR)lU`PIHcLN{>uyOusp8+5iu!R6(1JnSB1JDK_ zE<iXy)cq3y;sY!Oi0VfNKmb3<_pvRaoPLq-{Qe(!98_b!$ajCLKk)2-;D!FcU-<*C z{|DaY54`6e`0zjQiT}o9ewz;}FpsGD;01`9=PLkF^I--MHQ$~90sJH|2p2fy{#$$B z`Kmwg9e?0Q{=hH(#-nDz8LX+?f9MaYbNj#fp9Nex@GnM(;B^2y0KNw}4R8_QKEM-z zBp49<6fOj32Y4Q!6hIk(`T%tSIs>!<7!J?}U^>8PfK>pW0qg@<1#l7I8-Nfd1Rn%Q z1#l4{FTj0(R{&DsL2xsGf&e`M8Ul<47zi*IU<$w{fGq$=08Rtk00`lOJplF@2|xyb zOaO%dqQ?EVe2+g4;or>ntM5G3A9(gZ@Irs!ul#}6{{wIH4?L=0o`2xO|G+2yfzSN| zU-bvR;}87EANa*T@cVz@aZt(d7x^oH{DEix126Ok{>mSC{Xg(Ff8ag;fyV{=I{Y7a z)Nm62z~}yfulkKgZBJgXZkxcm6$3Z|@G8I!fcgM&!1KcjAOk=*fI<KR0crq@251BD zDM0X0fENNx1Xu&G7+?p$4uGhB{w?3*-tk*Mpl?|ZJb(VcFaCkw{{xRh{P!KdU;Q=T zf8g2wzzh9>zw!rO{|~&)A9&B-cvLSxfVl1dL)^ZtgWvp7aYNN%2RZZmIDh>6J-;OW z!C(Im{<*-P5>kPrAw$R%(twm8S%7i?r2(rBDFRCyl80158OjTFO$f;VR0EzUAK7n+ zvgCn<_gk3~sHymGtSV?<?H^bj&;ssnEvQ4vAo2csM^s;QAgzDkzqkCO4O7rV888Y> z&|mDo+CXtCKlRk~m;V1<Qx^EBgL}wBIRC17<=YrF{?&6+Fb+j964V{!A*_G-p_sod z)Cm4=7v-r9{0)BUkpbYeAYu@A8PJ|4XjKmM3UxPGP*?t&B?A%tQjYSI2Ce)kCH<vT z=iB`J-U1o$`FUn#K|j?X1;A;7c|y&u(l>_SH$Qn$uK8`0r+zCz&7;D%lAr6NdiwKy z^g!F1z!T-I2*&wiE&Zse{jFRPj71y70UPM|Ig<ugvLOCHY&qb8Vz7YUkGg!|Q7;Qt zgC<z1e4ym-Yu;Zh{$H$%zgPmlSeJgW1b?wE|6&RKWbs2k-;e*7zVJi*U=*kbp(23V zW2m@SfxRd2JxzVv#4F&%{b!ru)UUQS*{^o^>0j+S@?Y%@ieGJJa3J`(eSPX*?FVOm zwVP;uwRgbF+|Tvd=^$t!|404-XO2$rKFad9U9|>m)M4Z=F++mq8tU-ymn?$Ah7EYu z{SXa87>Lu~5)ACWjz-_eSt1z3h<X|ROK?uZAoZW(r%w)pq<^wgC}7Z?pX}3AFw{Bb zUt&T1t6g>mhB{aMOXO%_(6gWHMS2(%^pkDR1cR)8YH#oy3|jrEyp0tG75!wpaljyf zpX}TVFo^mmyNwG59sbl_6Auj9{i(c)9|kr5RPF;Nqv<DGOb`aO{$!&LZ%n8|+h4*g z1%ohAhq}LnQvsBt4tIZvhAIp?^;3K;G-1$Bw})(iUHcQktOJ7zezN=YV9@=aY-2+h z1eWN(#Q8Tn_%}Q8H@omRyXiN3@Hcz$HyiPrO=9$Gf0%!>g?_VDfUWYc-h+29V1p3; zOGb=g(A%HJiz;9T$^cXf=#P^>xcEmwBEg3EUl!1Z|5ZUPxBuywq0XeJb@?CZ9vpn< z04fc9nf~%eZKwa+fX#pg{xb^sg9QQ<4*Z+{s<Q_Wbm6}}X5`x7+YeaFsC4}e;Q(78 zh&&d8a6yhoeUp#{Y6aBqFZFMNAb&W}zic0Xo<N;}ngNvp`a?js|0rMbk;rKn61ji? zdJNPDiJYeedKU1ENTdabxR5^*Nd*)Y{BKGOkRGTc(7$-l1QH!6Hc(KEqz5Vq)E_7s z$YlSt&fq^f_#1*MzcK$c6MY(j2!tSr3LLn=Hv)(g#8v?WQ5NI^=>QO$W}xOEPJAF= zfafkRIM<+jiNG@&RTm|o5C6XeL61akfFMkRV6=jT6SRRu2J9n|B>VnIDj$F3SuuYk z-C2JmJ%K-xIM^Q<)r3TbO@lS|>3bbiT~r$+;EnVDNz70KL`(l$&lEz?d9cW?=0VWI zDmV-+T?&QYY!r_w|JnaXfKWmDP5x5>Lk;d{oh3se+enefU=q}<`=3ByRRR2Fqj*&L z&;F?EKL`;-@E^tuEQNmwXy#wn|KSCyA}V3xz`;h90t<%$d^Dc^#-SrmzzRo$e#URU zsB)Aa${$q^RsZJ>0P_z+`F9%ZO(a-H$PIt6P$ZGaCi?FRI0OXyH~r@O!w2P$s)wqN zYUd{bUHHeC{a2rxFdZq7uo+OzLFC#Df8{e2N<k#>^#7;%>?FSk%m6*|#J?B$C4UO! zvtE$Tra(Re=tB?k8S#H>K0}T1pZ4Z|HD;)G{xd?q@!ji8F$58sK@fHm$W!niUva)8 z47i{;tfuciKkEFzpQilR%PA!CDK8S~Ac#axR3ee}KplWS_4w`v2YKv=Hi6uP(rJ+3 zH|W7~k_2nd|GT2DQ5>r5hu@ESD8z=a|3_m6{UoS(odpj@UXb4zz{HuUfczf}o&^}- zZ$v;X2*7;ed@o1&q5M&T{BICcTz<qPC<uv+0!j=XmUMhb<k{Qcxw?r&!a(j1ngI&R ze#94557meN$#sUh-~X-rH-zk469?emgI*+Z8>lO|W&?=b4q^i01OqWc7X~&dh$V;_ zJt&t1>JJnfY{Gwx*>8FG$2dWiAD90*1P>?(C=8{bD*88tL)b`^HbI0yX@OFoG(oV6 z9}0ZI-i5(`)gLzmefU2MST84FHU6v!U?ad|a{rr3A~(Qea|7hSX`oGiX&XQUN@0>n z1TOFgdlMn~x1RWazwQ6l-bCdrG!PREsqc9Ub<Lj$L54fvQ3B@cIzW_-;<1{(`=PE; z_5RNR`_Gl005??rLhUt_qOQBG!K(;5SQH@UsJw-;fA>Mvi_lP0B*Z&|2f9M2bVW|{ zd#_*+_!|`j8N1|KK~VlnB{^wr&#@H~Y_rpMKKPFtxes`&<79XgUmh$?dFtWf@nvDc z;N3v&K<S0R8}hN-IwJ2y-Q`I%NMzRQE2ZvETyI1k^}bu{Ua^0rB*-ZBlv^|@HML^f zuc(nNK+rBzu*OQsrCL2bax6EJo4y<-MN{5?NyP!`Q*dx2)S`imo6Bx2y|)i*eYAYL z*0nQD*s;<mU$?;NZBK9el+Nc(&-a7pb?mg=+=BK@bPRAQ3U--B6*E*=UFju#s2;Em zP`p}k8CkV{p}V|fn7KJ?<kaXJXurn5(>vEd?=a|WhYr60kLNNOn_6-%J4f&|`ANLH ztDBn}miZTfEE(Jy9NG>G7Y+8)vn)<uU2hAe%+5gxUAU~7xGO}Wu?cY|oIE@{V&3yA z0Ru~7suGe1jS1Hcl?5vwB`mv4H45UXfq}fW8GX!hY@%jOA0hX?)HjT1;>L{|B1^ki z8u_v5Lw2q1XJ7eGy$XA~wt?eZI!fT4Olx=RR{Hbjvm>8^u!&Ep-e~N!`FQ+=#;K4o zSwDmDv>{<RtjUtq!n3mLj-IaCJBQ#=rw0*{Sr1-n=E+qSMHy5-nCR;je_A7*-q0Jg zI&M{Z%`BIlCrmkkdsXc2Y{&fDw{J}+eU@Jg&ECW>gSA*@3PLvKhBY?Vc%HqTic5^$ z(XcZ-jKqz=O&?g2Iv<B+-(@MZ_A0u+%6}LeYOctOs$LeMr-<E{XuO4MLLo{~?Z=y> zqM>PwmZP5f(QB(MLWd<QYk3m6(aP0igR^FJLOs@@3<7~xX0iDh7Hod#u{yR&TvEbk zyBHhOMIQJ<EH*EY?}o3+BngQP0pxs%ID?`E6Do0_GK=m@(7t*cQ|Bw1O7z8z^Za@4 zu?pYuCu3t{rl#Jj<(9MOF8X~mZd9fL3#YXIvHX3k=*lqBJ8K9j7nfJfB-EWTTb!k? zNe$erjuX%{ZcU_rr4QV!N$LwaR=kF2Zr;n#mKK?ThpXemy4u=4dvBTolsgq!ZP0^? z!O{zUM8RV`a$l@l-DB<J0Wq$U($b^gB}>hub=S&vRr(E$!Gi*PsBQR@s9(Ym0SQUf zUe}zv^d(pj{=&OB`|$?fp3ze41)r^@oaBH_nzAHZ^K=ktCa%QGJcg_>gjcSp_~glk z5t-bW`Mm#la&?nWA|a4(r5p!pS?xGx-qTQ+Jl-Q+H}x{0UYV%fn+-TVvZk;fePuD1 zV0s;1aW<Is8Vw}yINT&nm1?Q=<wVUfBNtas)9%=eELZG~On%f74H~q2Y%*L@y<kjv z=>vA31~mPI;0g|gOZ5Znd@3CwkF^xr?QGR$d_26+o+skoJiLa|G$aDiV^Dg4oc+<s zCN3`h?CktxN@C({j3&Xr4EhR1`BKPfHNt5-Oi00Y%hOa75484i`3f^@U>D)**Yd?t zxtK;3_SC{FG3pKH3L^U`bP1BiAO<<Z3X9Hx&d$#Dx%oNEwzjtY52Y%-I-5a!d<kQa z6aiGV(2NZsE2h!W1jzOCb93Rc*u?SnQxy&fqabW`#)ABe9$S4LFwNq@57Oe|j;}k` zx>HjXDQ-dMRwo>9OOp{nICq3&8<#}{l?gl1t3E<a3Tl0vW?JbilZw>a_(XI<8a20P zLUDtpysY`lVA83BSdg?0hb4kjVkRc+-JHwN((8qnweAA&4PjV_x$N443}jX*tJx8k zu6<sLi5#u@4X#rqOj^SZ9fEP0)a@^ILvOGR5rLX%bE!3nb%apMI(jZXG_vYU8wiP5 zjNY;cn7)h=$S6Aomy&XTrn6q-Q+|!QfB&dZvFN%<^{J^Pw`+O5&&#hSlS3~*vP-p| z3V1>Ws*~UhV&FW#&gP)1bIE?9X0E%4M$m`%Zg*l)N4}wrD@6qiGDq0gUzdF8n(&hN z#&wBPZ`L?wYE33pE?F5#g5Q0>;mR3pvqfAGP9xT|KP5KQP1dq|KJL_@T^!GY@Lg;g zzhlcTV#$;J51(0--JuvqpPo?SA_FK<)LN}fGtZ~osM2x$xwS<fc5vMO{tbMCs_stg zpu<aWv$Wyzp7I2o;I1_VVc6(ul~mx=Cp4%>fEk&0={z2m=PFf+u>aawpS=kWS3l!& zySBsKW%b8ABcIM-1l~FYQE=(^NnW^c%l!y}Ac!+m9sVS1UMcER8G;Y_<xTNIHhJt) z>}lBJ@mcd&aI<VFlWTB|RQMfR=w#hH7b|DLPAbC!uf$&W!aPar3;pV?)rc5YF6=jw z&Z<e6!>6I{<IndO6B84KX+=H!c=;F~y==v9wW>Ti>qFog4ue+_!*3B4501g$;!ctw zbZDo!U6GEfP?P;ac82T=1zA_z=zGfdK2;LZRQO0(zV)xPpSXMaWkzAkEi8!QU792V z504Y;qr*p<PG}K9SA3EuaBb*bb#q}sI|`UKuojPZst#6AE^@ue)s7Qa%Qa{Y!Z32A zf&{n;IxwO5&VzXfc~S6|R_3)JwH(WCv;_Q2%y{w(x;{d8S4OBUTF+NuJ;T%!hq@Ux z)A~}b*WZ;4AM(1gI8>=`5TouQ4?*6iQq+U!5{`{GhN6`|p4q^F1=UDw58`6T&@@Uw zW?z>BYEt0Fti*#@h%`Rxly2V$fko*&?f1Snc0YX?l5|LxDGP8IucQwxFs7->hnY3k zd7+PaWl3a5K1+2f9c}*Pe31AQ21(w;hruVANhPIRMPaf><HTqx3A7i5Qq^*EbDu94 z+swCw+@D<M8>fzB74q44ZaQ#V86jn2O59+RSle&Q$;#R{jFBH;Wpz2v7cy~wpH<o< zL-M5N5K8B}23f4sG&Lb<-D$V06<!45_+r!xCg{=VSG&xG-F)fdFrAM97cRBV97Go1 z%u(ZEX63JFnD~TIFf?Cl-#C~64S!g;D5ytf*4S>104E&NSF)*(C+#bwR8_eKKb-m0 zope#4f3D+E<_@E~(29UKHN9E9z2N=!PtHQPR6@pnE-|Z{bDvV8g2fPRB9E1DGrKyJ zUk)j-hg-;bD+La7#h8zA%_#Nu_U63kepOm3T{IlfYzDp1C2P|oG0b;Lf4<;P2NG3x z4+N3vOb5a|XpmjR5U0GneBj$<W=?MIP<nsFW-X=Z-6i=gHl{qnm;5zfAhVN?)%BX1 znvIJet6lZTOExzS_>4HUznnYA_x}EcT^2E&wBBhS2*;WZzG#ic(3Fe8f0(5#uc7Zr zdh3(z5vPUo{DgExN$mrL%-0qIhB3-rt3y_$vL;%~B{jyU5(Zcjs#5Wy<nkXYvz#w~ zz$;ko7pI*a{rIMmaJxr9yR=rSI9)=|YQ^}3BaK0YFs~Tvqbdu$q=Ah7yB3C#-KQxF zbZ-fq5&z^<FQHkWozI+WZk}AaHsLL0XNSkk#&*gqJUzdhiangK$}^mIhnIm8s`@Ia zH-=xiuy&tov84`%&WFFTS7K0DY}pmReWB6#;4lS@6Q<?hIV5ndIv+CYZwXOfn4632 zdDqF;(Gj%9{6NMts9J-E3?J51L>NALvf{zq6nC-<gFJle>AbkfL`*a^4Y4Tk@js1} zkd08>=dFso>K@jrAV5_xaox~LlRQB`YmQv){!qSK%>=2O{xX4_&M+yt$+E94cvmCK z*1l?)&a~eBDwe<g!LG-CQ7DBFV|CtPl&T6l6+H5zEKUD;d+y8nCTfS3A$9o?n%Cxw zb&^fqov&2+!f;snoK^UmtUy3VVj@+LZb1T>8G~6g*6Mg=P;Bh!D_6p|bvACp7!tD? z5MlyQy51+tyAo75umFRv+x)fN?i}|b9zF|E;C^+oUvg9T#wislK9^bjS4telEUe8s z=+J!%PO7O&(?;a$H*fkIaa~D5OO6sRlRyXwh&yJx)!#TL?X><tB_pFSH?Fu+hbL<( z^;?{Q^@&P)wNx>AZTE|oo=l@KmfDj+>X?G65jA^{I9arQk*up{l%Ct2Hs=nKk-mPl zk1Xy|;1yE~cTC+5FH?RORTq~?{-Ux3Jk`j%IK7n8km#A}I=B=RRwri0mOd?&h6f8W zd=@!)$|38G`QGVK2OSn7?`jj)%i}jP$)ic=<G{$tNHg^Ev<*9YdO{p0YGjO!3!UD< z&L!2i7s|@wh!ZSQ3}GeietvIS)$K#c!2dW=@C>Wo^SU~McrK%_$LY;M{mksa1x?IV zpJCJY4N9Lyq$2O^(TO`U+Ho9js>pp2O;HQ@@-E@fFFOGbl4=>Rc*)H0$;G!#tXE~S z`8LxhVp<WI=LpQQfzGabL}CeBJ4t8S5AX%GbRyrJ59zRpJM+2YLg<x!sx3PCL{oLD zwA^jESIT*AdS*w3So|JUI7PV9uyTxAuysgMG?tyEvU;#yyC)x%P2BBdilH{yEU`1t z)bw$2xmtEL>ruLUU!E4*GsfA&x{Vu<MjDoe2OZp$W`k$j0ol}nwhzHYaBv|x1%B3m zxWt%(2IR@&zEaH7u^_=waypi(XE3wL6ydf>^@GPFsnq&A0kk*l>{L(g$6N`tgJhI? zb+*y78uj;k{U4akdgns99(1ew=tsoO5oB!at(j$t3&w*P=gP}NC@1Cwlch7Y*~tda zH0g<Xk={z?7t7x*ygH?!H2J>Gj>v{zKf>T9>#$lGI(xaHc#cE-`}=Cv5nOMfr)7it zgM$w+A{8z$X4AMWy-!Lc=p0l5FW1FS0uyKVE<0{w*g&6;to>!JrbdF9MMO@`QmHca z8b~+K-^0YGY^d|>eC*VTb;&v85YuqmRhz9RS=2+y?+B4pz3O7?Jf+4=G<MX2@MVN} z*B@~ATDm*l|5Ec@k{&{I6}nkRNXX6B=jWeMJ2m8YR6%Pdm>g~wMWhsF)VOYTXYOFz zvE}r&M|N?XN|_-RTUVKRV!x7J&(`yzKDo-u&7hA%rA<bd8)$>g#yP)Lsy2>!%dJc$ zKIu{H<HvM4LtoNO8~vhVVpNBmURn?nVXa(4yp#R#seK47Q6loh61gW1JHqdFw|Gb@ z5671cy`o4&U&3u%wlSa-!*&z<nM)PgF`C|NOu6$3A}8Xl<V8M?h!Y1vgFHi39`<y2 zyAvA2W~x5{Rfk2!RpcRy1Y!H5u)4D61cDCd;otxjIAr&XIOTAMI%ckq^wu?p7j!eX zINGq(hUGQhDDF;5*?YN7X5^gQLzv4j&$5W}k*i4bG@-R~&VMd-9LBt9_li+aT>O%t zpmg%%$9R`NI*Z?-yWy(wA)<Zq7E*j~J*l_pqyuW*ucB*xu5y`;j~<dVg*bRE&kTeU zJ|cCiuFA#9R!tT(|G2+-t|Lv}IV7Nod@qG`o_?xUJq?vpG}SM?d42l^mp8{}XgcAr zkh&@EaG%@4Z>^y%tI_n!fFfb)&Dj8nJBOV1Qw`{EyRJ6f;5#?t&E&E2l3UDGL19PE zm;aG-5-Dl4%;dG6sFsX0aNyAs9>6|V=Rwr+Kw*nUcg(@L-`;(t;)$BB;$rt&VRzYs z2i?I{RTzr{Im8y0mhV{$Z=9NHy!?`aVIF_u7PO+Aa!`E+LMAl#mb@Y<hYh}a+tp=$ z@XAuMLENGP-#J7WyC~Ost!u7p;p^h)^16sG#*5L*r1N`h^%!W-sj1BckQSDB=4^0D z9<TQDOKfjIp$pR(*S7c8$JNDOQ{2bhA=hyqe`%6Ez>;N{bu~{$DUH?~E|5y}EaG02 zyST{u%Ut^OBwQG6Y6R6a_ELjS>7#B-LRIe!TwEW!x{PJDzkaP;<Gy;e2i-!dVMp;) zC{{=|{C-2`&R#M`x9DM1Rd;V4cD9ylR1R|^qX>3C(jxy-%Vksl@}(?2Q{PY@w=*xn z+3&{F#<<{vh*@N9Xl~a?F1q+J9ce5D8oZCViMOsz)RT#qn!Rduo$b6ZFSEk)5B-_# zX5$qOZig?1?653t^M(wHCtT{X$4H6>-oC;au$EtBOv*j#*w6jk_0l=Hfu$p2EHws# z!G>p8wT9?w=c+DUILBJ<8>SM}%+R=$oy>UgVr#Nq(^dPg4TsC5Z7qQ|XyLYK1UOal z@Ym`Ad83-)kq<GFj1?|5fLG4bb%$fOaL`6>rVj;475JaB?nxx2rKUbmUT^TNwH>rO z%%oPm@rZKs^n{saTCJKsG0B62;|J?-t(<o)?@~oGo;^zm-5g}e($#9#9nTvxl(mx! zX4dQFl@Qq@xXMB}Tz;55ffw<_i<^y*<EcQhs;GT7`h2$v8itqf=BCoCr{dnyx>hwj z%^d|R2kgA(rz!R^#U^)bC2=s8zpk)lL_d;oi+!qq$BVQ$9xJDO^MLkf<OChtUG~Dd z&|rR=68-kx(txUJBK^f9&iI-$l~?3oO}!iZQv@P!PWEmQ$Y=!=ta;Zxi29VKEH7WY zREhTNOG2N<(}q{?&Buy6-HL0@^Q%%acHVywc(y)all*PLWX7;&a3i_`X}-O?khvgr z<rwD?t*}8v-ob%zNeQlV>+UdY{Jkp9<c$-E8>hIt7Zdu#UMYo#5pX5wp%u|Hr7FkO zvHRx~9{POl=+86?P@;E?W9YL>Q?)n=4h}Z0abKS#jFC$rqSSZTwbc%=f?5%p4>Q$u z!-mt4nJ%=7aXLeCpVvdT7v4!ZI1nyI9IhMGHr!S0XECYMW$R^oF!hc^Db+hMgN;(V zyZo9bPBl(Uq{cZRD?weS+oF4-+uPv3g={^($j_glxaT;?jZKtz)Nlb0jdR-@!w^28 zr_vU!?^Vv+#LT;RCtaJP*{-6g=FTmi$g`Ke(7&L@Fl2$c<vN|h5m|cc*Czzd5OU3$ zxB6rl6Lobwi0mCZG$x70B0S*ZLAHX!n(gOz?^3;SX7u{*L?l;!a1?c+I#MqXl~a(# zZb2;0ww^YTr<tk5DLEruJ%lBy`eqwj`&H?f8m*|c#jL_Pob*f*9T(R9Rs}e-w6s(% zX7Lla<W1gUPEjhH#a%;<N7l_Z7#WJ)C$b)8Djv_+T)+&_#fC2Cs7DD>5d<H2lO?C| zN=keC7d7;8hgrI13@!x0qYtQW*elFSvvYBUP5F%z#KmQ4Pee(2y}7$msrv9nlu;Tb zHEsuDRBobO+r%<C(%&F_mo!$taE)+&ENDUVRO+Znjr;vb)yEUgvZhUZj)|8!KAraQ zYUDUW-IROE^qey$?b3BN961}?*rpruB>LV<roG~OY_AR>uOykOLW)e?y>4!!R~C-F z*XvInKAu`~xePx@>e_7o%JM8<GMQ|;^58g_IHtV^de`8KJw4rwK3H1B_$7Px=+Y2P z*FA#KyFt&jv;}nb$U1~?5FoGi4%VK*xk#w0hMmHn^kDgH#p>G2)UAvBuQWwwJ%YjZ z({zA58$~mhZpQ>s`NP8~S!V+wBYF+JQYvowMI0RVIc+li2A_k6l~{x=i%q09^8Eq2 zyR%H&H&f`7rsSzh7?pG$i|F_ZBHC4t<+nV$OvNYZskA&U+mA@4`Xr9TI8PUQ?aiY_ zDRB(niMSWQ-OncwPai<kAo#}VPH>1)qE%g|zU!8mip6ciJxAYDWCO96C!J{>3|nFY z_e&+Kh0y{S7~BZ>4FmMI6Vso7oK+nN3n*$hbm^jTYB*50k!Nht-NxtzFBCpg622#t zq@>dQA068@RC4DZr)9`$9cMvJRvQPdZ6#R#!!IYy1c%{o9I;3BrgVym*rViZr&vVJ zY!O_O`%+*ltwvLRy=96VKl+^!SA~w?0IPcCOIrSmu3CxA&p4gfsp_sV&Wk3hzez-= zODnUMZd#`&!47D$zvf4GPeMlaqIjgjIZop`&($z`zi{fH7fc4ZI#5#`PlIR8t-ZC2 z{nuq9>^%fjwo1F{jdv5a4B-cw5_z+GByJTgUsuOJeXK4O$WHS-O!4himmIx7z7_7+ zU((0L8h_O{)wn;t%@vcBl}v}!!7Qly>qf@&{V~MT`Xh5(mngak+ag&GJgg#kQ`*ov z*@pA;#tThK9hb1HPMDebRH1}(Zf9z^9`dD$*}gBdy=dj5A|ZmEQ0+ebO0vhaJ4HBM zdH7}5jBT19(*Z4EQdg6;A8T(K&GN$daUo@*r4NF!tLuXKc*Tp^FpjMA{-1jr2NBLY z;j9KldTwmpQ;$ZD95j({SuC^)rNqqnh6=Iv+-29V*O$I>$-KL>C@p$&1p_SzAI)#x zdP-ajZgw1)k%-QTGwp4w#HW(TYrd1>wJj0UWh~`p05kjAomBtI)#ZbwwYB2=CthJj z(UV4ddH6|bch(LZ{E)=Um3s)uN$?>w;%#G0E<)kU;zfVH#=FU_bfZZl2jVwwGAcTy zcZ#7p#I{2iJ5spj)Ki}Pz(j<l+-Zuj$aR4`IzE2h*J?!IHZ_}M)9Y<)=W+-s=%Wg8 zP~mihll0r^?389IMvW;%p1EYR`{WXSfGwZ9!6B}31)KL_EJuGQ2Zwj~PH(zo^uPf7 ze2%};epWrfOqUNe{EG3L_RuF`M6{vj6d%G{%|muvL*7lr7Zrb46d)D9@i`s)+JRQY z+b9!{F@5A0#s^zeoleN)PEUJ185N}*iQ$Qq<Z+^{t+D?21p=Ioy54v;sZ~YQCey1c z^T7|q8AY*fBMk`$j%}2srFX$cOvyX*-ATJm4_Iz(o(<^w>ceALY$n_2ckI|q^I2w| z;NU%ak}3P~XoAX{yNBWu#5@&PQ}y1&DU$wAPSQC<-IE(kD%B{+$zH6{(h##Bm#9>7 zWh{JQuApo-FQ`TsRo=WcNn1G;7nfAf_QB$O`C|!1m+HacxQ;a1j!3-XV@w)sG`tXk z!K;`P3m#Mc{_|N0rhX3!C$Uu~r0&1Bgu$yzt)tclD%X*`AHyC@QO#2dE={AuyW0`= zA(SUl`X!ZjmfdfxCp>DTjV}9K@P(y4ie`(9jHLsydhVQUX^&tW@(Y^)?z?f$3QS8D z$?OS__0^=L>T46V9$7sS(HD4g(rjf~LUAV0F2XmloyQ;HOEVN#bt8@QVqKzRtWUQF zZ7=jr@vaQ0r?C}8$>J+w86uR}x{+?}YN^(5+TQfFhP^|yNYf#@x&8a2DC+|_Ce3yH zSBiSI*W&^|tU-H}+voKX5)}5XsD?<~#udmUu17c&`md5G;GVY^9A0tFX^c8NuCL$P z63M=^^pTorM<k6Q16K|b3rkP?G<qHV<MkktQ_!?X`BjBsomjo5!8|Ri-o#6{*vp(P z(&f|kk_K}2z+X<TgOAS<J(D=w%CeP*@^)XVUo?#1Kt>dA5gOgZTDrPKM_*TAF?ke& zf;8HyPp?;(SBTU&Sy7mucs^+_iZ_|K?$?^>4->BVpqU@&6s*P@C$hiLar%jfM7wI; ziw2HIQ*F1`&|)K-bPod>-DYQ^0-4Uyb{ka$+!-fwPBxTKrZ`3$`QX#sf9}@m-elbS zJgv%yv|FN5D)s_H?4*zdzc7w3nsHw5C2ajj1|i7#$xw7-+|_Kuosp86uh%ja>r34y zY7S<5Z`d&AnB7Nf((6iCUmnR)))UF;ZEd7}DiRIvKYU$(^3kzz|3+;Szxx^UllLwo z%8B$xTUoI>O$|$>=Od0OeN7xirOGAA2QC$Dk)#Q{hd8v@n&yi4uTCD}tSCld7wX+v zM%xUU+9_gCu@ra1;KU%{#KF3BiOc<=y?OtZxHsOtHDu~5@4ct>+oTxJGO1r^vhGHn z+Peil1oyH&-fVw<kr@j@Jk)9X7=3XY=Q8rEQKwd~*tWmLuDh8C;bqbC5wd_F(Hgha zL&?JBJx}LTsy1O17l!8U9w#NUZ}LlSqr-MDR7K1dr9Y-0cgl&^Yl)9Y(@QNk%6#dR zMqD2;7G-kxC8l-S*9s$sc}b+*=FF21NW3^LYplWq1v#nDx#kS_@0~(2y`vU#4}>@C z7TZt2UcP-xA#7UE3Nv*YubDykdW_ea_|HThtcvz!<R)?kOEuY`K_Af=Kc&D*`~m~E zSr0I67GJhlQyt-O8oaU?=!=q6@RzzjNKl3Ykqr4ufy@)n#>}koW>0ESh0@+HO|lxh z?%f$4ChtepDI+@AL~EI^#cavrHkPX*h7#;QbkJ;%$re37edWE)%cLjABYLJ7s*Ms{ zcU3$bxK7t2vU3fm(zlz-HfGpzb>Z281%-76z2kQLtx=*CtD*--Q#u~Cn;(p}B8tQB zJ=~hZEoNn<hXQ-4q)x@0e6)c*)_&_OucU;_imQ6P&TWZ(Yr)IL%3rD!y(zX=GU{D- zhfr$r_(RqsPyDiF<`0irbW#IhP)z-t!}_ewQ5SA2y+~PF_HOnm27Tmc+ZU!}maXhT zw?$cPq^HHnt=9wU+QYHbG1B?EmwinM)9>}>1RV@V!j{V`r||fYe%bv;<!M5=@vEZL zyzJbz@vfIm>o6qKgxsh1(f4$As+O{i#^)+>7~qz#`Ky_6aNyxPd%e^aSL$AiZNCdw zFcxu{EnaQpsoUrd!KZYlvK1D%=_gg{+8pS$-LN!Tx)78r;Z;|<FC)VD=w;o<Kzc_z zp1rVKhHn3zMRU7tusoVWd*A4p6hFyy41XBnXHsi&r<>;zm6W2kPuH6Gbe#s(h8O(B z1e(RU3ZJF0H26k!91E+|=kO@$e9cRa?PxA366jXXsP!uxvDwVWoF8v)T+=tvEJGq% zi3i<kPqLF;Ub!wUI&bJEyM(2@!nJCaf@erA(f661Zd5$hQ`?_Uc6w<3n8ctS`w5?9 zx`D9yn=)H;a44-2<LAF8e7b#9H(?+uDjG3)aw@_UeLD2I#_r`as?LiW(jvZWd1YrS zB56&%y6qpV<@7h-nW&LvDiJOsnooe|D=UUq6-eeroabU}^4v7-)hai-a!vghooTJQ z;Pt!i85ilz<aKzd2Ba{1mTb}=J9c&aQrB(T1s-^{*#&)%mFJJbvL7dp%)CJloA$oB z`*4emKEZAIL#apYN3p&yWhztb95K9dMZ!|}>9+#9t~V!|?hD<u;R~e6FDNjZ&AoOp zzDPd+U9s4u*gz$~Y6eUD_~QEk^_x#6TM_p{Q}v}3$dRwht2gFn`re#VjDo+u5!_*S zF6E4Hjf=O#9XH8xqQk5lSv$3N<h=+@rT{m&kPo|!gtNG~4ZDlXwL57Ea*Z(p<^&xx zGlnZ?Z#5iJ*irD{>le{)u!SSK(hO(Mo=xE9>ksA<ZMyx{er8Wr;JoWKzQV#6A7{Nz zsuPK5MLfDYZ56Fg6<=e=fcfvM<3LveWbLZ_T`SEyS1ry=(TU$3JZZVl^NeHToIngm zpZ!@r|Fw@!;4NvBL1&y}`{-KlOx}@5Ti;`YIlZIfo9SY0A1Y&#U-LHJWAK<ujEK9% z^E7Hrnc3eom5$$g7vpu@nFY4t`*uEUsUGkeb)NHH!4?yx#BU{N$&0T)jmJ~Ul&~$) zx)UEO)4%LwE`Hgmo}Y*Elmu1F8&{*)6c!c?oC>YgrrT$l8Qkb(Z0*NAAbT~o?)>vd z9CtR7P5Aj=X^~>^rcy=_N)D`gx#CqbuZVHQB4h-2;9cgK*{>_7{Jib^#+@!FbM$dS zQrgH9FE6iKGoNPy_+MyW-;4ZO{33pztA3P*#SP76q3LGj^nkURtg0#tVeg`%dhS!# zEqx367DVo$wUuQ6D@Tbicd3CA1ufy2sAEX@No5cxcf~u0psN#MbnuS$ld&5M#)3Wq z`X1|ZFIwB4wUNq7KTYiGs1J=Yo+BUh3jZX3w5dgcN5znv;bqQ3{4sIt-s{W0h)>73 zxOt%u9=Ms-2z%@p^B$#5sEyp?uA-QRD%&wFv$A->-<IDX%kJ)azB(kht{}9oGy*ew zJKNdM5uxPmGPYo;F?*}{3(v}OFD6EXf#g6}kNgP-XB|XN&T{&+CMDP9DE&s=aih!- z8UfO1>B-%RS}Y+WL#{_*vJ;u2mUr(I(J?A_-@6@?8%(Cz5+)nolRC_l^YCHSRtXu} z2Sv#}^}dPQM)y->Wjo~U?YEtb((g7u6S;paH&m$%BJM|f;F#cAH7<w@h>}1U`S?5& z6BefS>3J^wxj<}=4Q+G4|Fsl+RL#>k-4MzyTc4;d`1*ozUCiSIagf%bn0T60P>W$D zh0pbHC#uF{`Q+glEd`bl4<)+3J9;~E7#XB%{OD-iOD?5FZ@b>6=k7BNVT=_`Oe1VI zWjr2gX4T0Tgc)byxyfPb8pGb3QqagIVK{gjsHg-rn(n+!p03kwGYabz<QQPB2p@|i zD*dd7g~hyLbNDrMWca$>?Dgb>lt=}3nqBIVsIvtgMvB+?gz$MZUtYK^@}l&WR%6}X zRIhk^bhHXth(5_iW&B>u{`Lxw7NujWsA5hG#R~&2-TfPDDW<GyPj*CjQ$t$g8BXg$ zi4vAq-4(3n^I`|Jtrp&ghIqHlWS;Cw6iIp&y?7CVAF^O0ulsc~hSze?CKHXBw9@We zddyXH!|JnxCbc98+pG#na~0L~r?Hzu;x(6^ToZ4b<o4N0f;h74=UBtRPNt}i%@@XR z+MiLcyOTH<HtL5X_agGFb+7DbN69o38uRHbArrF+f4CL<XA=qg(s;zzrit33W&dGu zj!s+fD;FxLDKZFxnY6k>S24#N7)bhDEW+aGwr`j-)_px(cA^vVjLzkBL%XeC1}{cy z`Z!wJxb&g^C`fZmTbfk!J@KAE)i96B<0i%;m2t<*BeX<gJ?*O%(q~Kh1^vb9wu(yx z4=Gv@;)90a%<T#7azXr}7g7=^DIULm9kBLpoP7pcHN*iLReu`%xKa{FAG~Ver&l+a zmYPP*bW^j_AtVMgdKFKF)9i@kMjQ-{b=0_0#zv)~(IuBlPnD)gpufaZXubVt;dW$+ zRpVS7C9{`TYR&VUtRUl0;HM$?GNWiUE}TArz4%gs)^Cem*%d<693wmFO<bB=tjoX| zr)7=~F&!UO_V$|IKTo>a$gL&#MY~O^iGD4Ua6EjrQA*LdU{$b~m|m}bda%D^xn8Z& zlj-2LTo`{5Z3n@jv&r>=aOiQi2T#j>TgCbZmcHp*Xw<_m!}6C((H|<7B8w~Pg(DCY zEbBf}Qj4dZ?zGi62IaCLKh(85Vhs6hi)-^38hV_%O5!p!_&(MmzBtzNs_Ma>uR>Iv zu%IC0sbkpS8|)1`*yot6kcl9Jg^a43ectvtK{yg@v80i61D{&i3a^)9(FP{c^jU<N zjXZ6`+@4=ueh=PhzYsjSAUj#!r^HkTQ)%m!z3;tIUs#8hUvL2`U@4_6DsJ3v_1L;@ z7rA4_bUZMtQsjpVgAt^bV=bh~6$H$doRd03J<54hlyV7MrC@mLL!O97;69_%rK57{ z;lhyoBv;Sn**1hSVn;Tb{meYVK}`mmj)EoWvZEbBLg<}Te777eZRR7M!vRHlaYtS` zSphpYiHo}36$v;PXB(fJaNZ7QNtlqK4Wzm3$m#v*H6<VCK8=^orQONk5Lqjg)I+x; zB3i36J9n85$OjLGN#@DWVaUk6c!N_k!xj}%O17k2DIJsb^a>BC9qz@xb@N!<iO$gu zdRt5Hmd{bj-+J3tl?_e7cH8>W_}c5Y4w)yLLUJGd)l09(*VdfjuIDEavr@BpVtng! z`+5-5#Y}^!iQ?_TfLHx9O@1q$F?*JhuJNI#s@>k07a6)DO)xJ{c_V!{Z{wza9yGop zhk)Ji$G>1wpSH2zvg$&j+C+4zynN$ewzG?p%V0~w!1wf%L`EtKNWZ~tY1F;Cnp%4| zA#80Qe+}9kJGQ?=?)3@Yrz{_0A$oZ+Ki|C9NcOzP2W|PO?3*io=xjau(ut;Y<IYZZ zU9Y_@%wrf5j1sxNKU+Fovb8$;yjLNxE-90qoJ<0HI~#3M#C{{gf8)eT+)=jU_Sdtq zkqAx;Yg6A@=I(W&)?QAz-uC>lFTP_@laW`Hl)9Qb;IXv0Jg|p1lfA6*CfcB;BTSOR zM#Q*C1O@zE@r3tRs<gue$u!o253m@<5gR*xD1E1QedM-Pu&!dFsWdO#QZ6*&c>Qx2 zAr{(+w&~@nRJq+E_Douz+ot`QZ<0furk>RX<Q`upsg(>ko3QMteP?at^N`b>Yp#6E zR@LP7`yx)MVl32;-w-%`ST0$U#IU6Ie`}=J^Uwn;bf~fabj!Wwdl8E(_@+wYp`s4h z#Mp(3{!KQ@J@>-0Rs61Ge(221tdB5yY?ckBwJoC~7-i%8h^Jjfnr#G|+akys4PUt} zd0Xr<+5}Sc&6?t8`KzfBsUAM!&?eM4UVa#Km^d{DEA1p0DvuM;jIZ^gsoNg4j&}=@ zaTUFGT-wP;ZcK9Ry!1r5s}|3N!q|;|Zvk4tkHMF==5D^({*Zy8p!Csr_O?*^Vq|5r z&TOw}^rBm|z}Aey9IpU2U(%zl4B>p67e~Z_iWb_wSzWe9Za35D{rC2#PHg%Vy;WiU zp|_^b(Iw)vt-5wzrbmp|oTYe6<Gr^=c%Pz=8A|+mu%Pa-GH9EvTfkD$c&|b&e-F;| zkaW$uK?LTcY?Uy8$zu7stu7Xx{R*$5{zP}~WbBJg*->p?Svpx;Z^?07zR7;l3y#x! z^93qaripoXN3Z6ZY?3>fAZml8hw@}gO_Y1Kc$V%f^YKU!kI@v}s<;_?6-N!6`rrqZ zf!XVvIHPJQ&;3H+H)Do*vd3<2Wvq8Tj?r?Rxj}~Ly$h#kDmrbUWJ44lM|e|+q&0Bl z(_OTFw0Lf#56oQYN>H(V=i}1R(NXHMb44;Uwc*i3X9qXiS&w+R>TlWQH-ECwMpj*$ z;i5l{$gYmaJ-KYhWYeMUDWqLap2wkDUHB$OlT-sIXwZ16II+`eqNK~8GJ;txRU&Wn z6_R(nc(JE4;`VCen|KwW{QG?zN*9kFrrCd(5yImMEX~#5xp>x2^rQLplaZY~^w_I} z2f`z~Wnnp(gC=<NBLZ@{(&;>qm&H_r@0*-7uWThlsZ1D@<?k0pq<z>m%YHn^=&R28 zZe5aGa{H#T)5;@V6C=#4Sp@Ih*FrwEhEiu*yuyh+5k?zIV^KMI^jhxn*H>p$HG}9r zV>J-5$V!kfzlP*arp~1!Ti09tx|MnA-nu&5I@Q2#ob07p)xLS3(c0`joxbj*Vt17} z-@kN$W>9u9QFh*G&E5P;B0;c{bo1il0rSJ%j3dF_`n{7W>YZ!pW~~{gPD*=IFDznX zC|opC9NiSXexwSk>{=Q?V^w|n5rn)SDz<4xOIt8~X_4hGTXQVc<lz%ZUUx3BApbmc zTi&r;y7PXKj<12?>5%RztrwWS(P|AN&NA6fqZkYrDf^5;QcqJbUI&GGcBvf?o^`Jt zw-30lzRlv)eILn~zfaiX5;@<4slj*Rip1NJdee9$m@87|6h9MkwG790OZ!>!cydE2 zNr#RR{@0sqfqoA;5qDIF-hCZlwYpUvn%L1{GsPCb(c;G@-1s1o7_H?xT2<<R<E}i$ z)8oBHnirS?c#uSzP>FwSU0wMjEc7enc1~As9@pky7{`sU^z*6I?<q^>i8r=-iTH5* zHpO7=>G>B3!DlCI7h<Ky@8yfk25IMn#52VPCc3r8*Xq98M^lk3nsLai-?a)qST8jf zf4RDGjs1A~Cg^<AbCqO*_c$gaMWoHyi$j;2O>|a`a*#7YBnOM8Eq;Ze8a)Z7vOSOE z`W~O#{m8myOebu(ASk#+qOPKDc#z;RNte#laxHIG?m601Z!C<e9=T&&nQqG9ZQeyM z60RoIGWeG#XQ&Q0+e`f?ip>RhQ-f(@X-C+>4+_1%Dm*)xdSI%Ti|E!hZ6(f-1>cp8 z=M~#cBTG(cpU2F7d*Rctzoe<xN5{wpunpDDU&>w1<<q$HMSp$cp7SG4KGIW@G~E}4 z+YHSMyxrO6n{SzmSKJ=5%RRi&u<m5pPPAkEBq(?^^xg{RmHmC+{&{9D>A}&x1A_dx zGJ$F?-C|l1<8^mY&iU<^>XOCGELmky;o)0DWef*jj6CgI*4ddS3H091@FfH(wH$&U z)^Zb`6~JL3a5sPPa&J~>&<tXDFDZIK^yu^ekBRiE|9o(L!Zr0G$&ze(<01O(W4>N` zX2%-emhjsZ0gW$p%rkl;XUUCv+a}}R!lH9>WDx0>(Gi3rV$b#oCC;69b!Bf2jya!A zg0*iMw7x!nwWV3izk6@*xcEE^v!BT6(`_HC&juUf=x*UI6C1AVOS`~=gE3`qTCNq* zrwQ&d+TY96bU`qSnZm;=IX|cwugLelw#}JqnVXy2*eWO@67@p}QG}#Zmca%DX|BYu zsXiI5H>zyxbjC`PnNdc3VoIUH3BR<z;jz2Bx82@MH!`N25i7m3<jT7jH=NH&=P_s^ zceuczv-@>di&SaE*uaC6ga3VQ4-fhFC9{~vIZtO;(mOuSFnYBt7C)8UO!u(WGmbyi zPQ<2?baoP-WmpsO)mto0Veq25beoAs@SYIkDP6kHiF_63*Ih`S$X2u}%8Y$2Y`yOK zWoRL4;m*>e(Tjesn7e36vO>xXi4-Iw)b}?Yw93%T6oMajb|jYEyq(@bVI#F%j0J0| zD!G}drKQyyodDwrr9ULox+R2-_Z~NnwrFKD5Z>dMq0?3s>ArYnySRs@tn$`w*?XSz z!3}<kv5&vBIANDQw@<*o?Nom~=Y`4EiN^Iz+=#1~d9K-E>&zX#H5*aZP+bVeh@+_2 z$6VGmf#~8l^tX-;T8y!}ZL7{&aE##1X=PU?mhw=2N+&bIQI(61CTAUgaEtD#<Q})% zdv@My4{c9+`V+;ar>bAeAoBG62Jp#(Hm>BTr@7Z5-d;dgzN*ZJ{sk>K7gGQSVtq)D zR7rT3nsY(tyy2QMzCT0N&H|A<&e?SqGe6>sUgR*T7rHVn?<ROZ)f4A;W+^;dP0Q2> z6{w)0)~2w<X;tTXwO;2=a(O@UZtL|Sd<xmsO3956S?`jmEAWKdF>hGatzEvzv{sA# z?5U?%;qbi)-+R}6@x>_ck7*W&&4R8iS+bW{J&xl2lsA{+E4{9Khmcn7)Oi!Pu}ExF z&#zKBlfFfI>8&ZdrV)uSghvAf$s)my9n6uf%EY~xEYcMbj4N4)_;SIXD1cB-R^~03 zo0X)Cdkd9LQz4-o8po7ZcEB%zkT>eaGso69Jr1Pj+XcH84~FY@vJYm?VV6;Tm0fbe zxed=@5(gi0HVLZ>qj6j(`X8}f`_S7q-(!?<1Hn95Gut`S5}yW_7t(*ws`*jWDWFC< zr}(<l!AOMJXid*iLa_1Ch4eM*6Z<zcIJLAoeiEu>Q=jITDwJ$GhNZ3#*uUBJHx@z) zCUl*XC&`^6AbCfD<A~L_IXihKiOZ-`x9;$8IT0t2Zai8hkP*Epcyq>k&cb^A!9AI% z>~6hn`ogKS#2xE|(O&Vh^Bx0glDd6MgCvc<lq#Nk^>z_@ht^^2$B&+5o~AN#f8B7X zd8Io_Zv19r$KD|u(GkgMVFPpFv@e*-;h~%2u9D?vt|V=G>5Ff*2+q{h9?I@qR1bAP zW<(d{<GqcjcapqQBOhf%9}$N!toT|jXQ{6XDKXOEUF2tjwLi-3{D3OqVDuvt;qgqD z_hOT*0AwGjC%-lty*HU$d~5h+r^Tf)j@^e;#MDsup=617rDLzMO)XE>UI2dl<l<(W zI9A*Vox-k%cb9Lf8g>V{rbv{D=!Wm|ktqJ)al}sh<jEsKs;S8BB^}yrnjQ2Z`7e|8 zINL~KX2O&U&YPnP%_cKxgF)FrHAbF>7I8#0(#cv3=Hoo}NOJCHuO*7=F}cxhTuJ;G zD}<PdZss{VD|9DxX>=I;1cOE<(f^a+<w9}ES8v=Z9VXJ|dzRMSYNX$+#&T_7@*3gG z27Y{RM#=?u@2nWeQ^BX;8oO-yMLSl4>fDP;2mKDH*z;41tF5i=lBeLvikAMoe!`CR z6#DZ<r|c)##<OTlOl2guw*)xvp1gj0HR0mn8V>sGsWt+gLoKHHpc-Y*CjmEfO?I|> z1rrY*X#_rFw#3zP<I}l()@`$z(g%~HAL&csRylb#{+LOJ=Q>uosc#oT`laaYMQ?$% zDNVVaoV<joQ8tA#;l%*-k*J2|De;-&q0_{^d-e(nx_Wsw1wOYWp)S1>-OoNG8@}U~ znd9^lE^RwS)@i;;hyb<R`@5-nS5oAkBcW#}Ji|0hwj)urJEZ3!48i>!Wxx3z+^cbc zSCLg2nP-a%O;{RrXc(IV(=^18GI)w2#b4)X80H&$FVz%h-yKcRsBJO5MER0iTz|)9 zvl_|g-?!4JWWHQ?KZN@=`qZX8B|+2)CV{^XFXs`_(o-%ISowv<fDh9vWSNKW;mb^C zNW(RdJN{a1Q#VV6bE#=PQxP1kg}6;a*$0R=iR8s=?F|9kxi9iUalw!2k8cm<o6n+i ze#|YEU|@zAz9Iu1O=?f*FU~7>78ra@ttq-!DY3LZ?{=7x5LQXCbBGhIr`__VJ+1KL ztxJkivd{e+G$(Ss{6<b^azvc3sa+3V^q1&gTtD|I_-smSt7es^^^2pgvZKY1+zgV^ z+8=zxBa8FlC0LoHs(dBueZ|wm`F=OKl(p&W=XqyyZZ0#oXFX$8Wt_ZKdU`2at$2Ai zlwc#BWcRA~TBEc8#O$XEb!nwU$T?c2jJz#s5D|3zC?tUXrH6nZq89vL1C7-9CwA$u zyBwEy7Q_XLo^&=EF+$EpK3+{>RC0%1OHHq14YogJ@mLwu=3V+?RDRcRZJeq_4E}~9 zFSsC+YYe%FZH6m~riff#VqH&guP~_!=AIehIg2DG;y<n-JuhkPLf%)BD7WHgfKNdF z`uWpWk8Yyj<r<zdN6>FWXOwM(x>x&cdt{yJ{3?4w1Cyq>E>LZ6lLak4mZCAk$2e<) z-;_6yL#r;fJ9xo@aLi@li%8C0m|08JZS+^Aui|Nn3tq^n8Ts8OmcWs_kg@Q7csi!~ zyp?wZ4b!<@hI0Ms_hh|8-8>CuReIKNZadXfVdO5UJ7&w86k&#Q@B5kfWxK<#0pPQq z{gy;^{r)LMqD=E%$fdf;M2G0<lk*#cx<T#wvf9}Ao*no@-cbWirpmKd@!nLNYj3u! z2n@^3d6MjirPJug5b+?R^!Ukr-qgyo-d}YtRaZNdlDWfL9HmsV)*~;4y+pd$X19KN z?<E${50#`q{#oh%h(vaXWS&iudywSfZA4qd1-&AJi?M|h#CH;5yJ$`Oy%NcCgGl7F z!*#~@lDsMHDQD9Tl1%WE&+v;h>K$H0YSo$+4a@9QnDAOnH`ztXo$<<1Beun}jH!t; z(~1t=`E(I6XU<Eof0OJX)s?w4)#o?!AGKt?q^uXjNeKxl!{hV%OjYyF#02*AnT#`K zj9w?phS|8AN8*aj3nGh%JcbB$G+WIxS313gy3w}hxikWje3=Nf!OW47>^u^PQ*lhl zoIdbhUAf(=I(#$JD3m_BO$u(%`+{`C8cT)&GVADb$gygA_WC|CIHA#cx87{NqFTJ2 zm(V`no9rPW&cziO&*?Ic;5#+p|JgY9R6fT_=WPdnD|)%P56kR0i<6%161irXuOuIx z_+DyWK9*&PP$2xGMk_lh;n+uGo@Nm=3Qr^tKmE`umFn3ApU<YT)r5_;<N~z(&3D!W zgf)Wjnw}_JCGU9uO6tiY{P%_K4A%tQAOafOeImnxQuPOgVMIag?~83^nr;3+iq68X z$*&FL&qnv?kQ4+&Qt2EGk|K&fkP_)eLUN-K6p)aR?i8e(0V*Kf-AH%C*!J%I51#Yc z**W*Q@9X+r5zkxJ#(Y1xR91>1Z~tslSVfK8V`Z{$L_R@B{qTg+LGKr^gO~Iy<aOs5 z1)PXe@mb0qF5EpkaQX?ST%fJCr>JERBitgIh^<sohE`PK!g;`~z{fxBE%Dgc*PN1y zkQLTj|9^tzkMEWVaq1lHc7zB^qbA9wlyz-qVHakJas7{6hUDqU3$?Q+3s7^{$9NMp zsyWZ2!KHcb=&#iY+T=B#ndAR?al_+Zx++M<4UyAQD-^T%S8;VK<~8K&WIsWSTYj%M zl-d8#YFw%1CG{UHmErsY3bg(zBuH@}XpW5P9loLA>uw}lkfihRa=T;=V=LaLKZ5)B zzyHLtqHJaaO(O<qi9Lwl0;_%~P?*NB5BleV`yejG6I6W;M}o9v|8oXO%Z$fHx#LUA zxZBzB!mg&tGlH9kJxguWTI%*QtX0xk4JR=X<s*_0js}U`SZ6_5>qX@`Lu!6FeKMW| zjJ}#Ge}9VjlPCIz1zuL+*03maY3(`iaqt9rVKN^a-}NfEh%i+$_eyH54+_10#6So% z{Q>Fb3Fv+ov6>jS9#{^S=EL2`h1+MtI!XhPR}$+rBv>+;P=z&J9IAGsJz!hiXjS-k z2`|nN(nsOE?O&oYQk3DYhl4GhTM`pC8IR8)sn2yf5!dbQRFF6GX(%W+Ua(j@Q=^qG zQl;;vmmF?2GX3q<>G$U<Z~CM!aeW&*a0yfM9`k2)Wd$zADj5-n&jSUyq9gW8r`uIV zS3gR{pEK(geWF+?pi{$@1p(~ov>F<FmKkmT?^Lp$p^<j@6&zJmKhI03fp7fAo0{4h zz{TqpC|0a@lSq5R)3-F+n(6aj{wqaoZ5m!dvyg07Sj~FL5Y-1g6|POlgJ&6Ew<8*e z;`~w8`q#U(4I4-%pLj=IW)u<cxWPUeY@?bb4IXCsUP7-BAQ5uUiu?A_CK@c!{P$m8 z2Uat<>oH3hoa1QjmMW(&;!IbSc#^ErH4m3a)}3>v6?Rto(gn%1uAfEG0?hXPwn0EA z8(arWMM3bqOY_^JTWJX)tN;CJ@cSuZ3#M>feSPdT2g5854%SP*Yi;Qllmj==JXKgq zD>;vwi?F(zP>M)R)zB}01yP^GG|E4);_`<55|GYAN6wlyaZEzYp-uI`#>jq-!yUb+ z6uP~||EhH$x~tij<#J0RJ?VKoH&-Z^IAy_@JN6*OC$e!X+dod+`MH3ws(6HW3CiL- z;}ZfIojw9yZcLe{41tQMRV{=Z0)0`JFPfZTf*eASXRD3=SwVML->z}d<5+ea{Y9G9 z2HM1EFc9td*f-6=aczT=^BWxv&1axUMG{yG1tV;&{*Yo@-~;UMU#F-uRokNg#L;rk zON{#$rBe9K4MS1h?k?tyf^3t~67yc?@xuoUlu?0~s-qYC)ZeTY^s*unx{jYB1OLJ5 zKJvgb$lVSWNd@0+OGpN&bIFj66mG*s1rmh=17>?a_-d=U(Px3KZzon;+#=o@_VhZ> zJ^5@Q8vt6Io=(|d``o>IOP{a0x~Mt`H~VM(%ECuD*Uuetf}4sPL=7c=w+2o7rP&kw zVS9K<3_AmB3{K;AqRCPo<*~+&z_DZVTGxV4Ev!Krg7LS%yJ3q$Znn7^(DDhWk`lkh z6F$p{p19X8jSTt6kM>|LsZ%gPF)krM{VmTICOSH`?vUc{P6g#O**)`F-ExKF4?gyk zlG8AXti1?L4f}V*eP`0aqQ#*fYsky41bOn$A`^xCqu}uUO-r{-sb%)st__dS(;L-l zTJegED-Zpqb+p$Q$M<@E?=`1L?ILaQ@6LJNohQdoApWEd^lg)hXUXM*qGG?yaYu{| z0{gpC{eK++Yi+(+1qECW<D-<;PF=Z&?}5b^YKxuWgK^otztxph!pKSY#Su|mq2+n+ zYj`ivJb%A8ZW>O73xDPljUe1^dcsWiPQee1t@0R2DHMJ!Yq%XP=sKak<Z1<yw*K?U z)fIm%15Z$9{Z6~MtsA_5@#5jnk$1;-V470){ZX>_husUpVXPw#pqa0MtFqd4T2?zY zA(aK`4mhl~gsU7WA%ZeQ+Px-%;Pr+%g!iicIa}mnw|UkrGIsx{x!Bd$SAgf`H`ntR zM^LvNzy`dhde@X_^x_5O{mKd^mPm1jfUx8}6&`%#PwZj#*Q^flgxOeKiQf;FgBj0o z!vNLo43aEoC!UCLbIn0`)QgR`Rf1-l&881HdRs72HiEL0hqMT`q4j(>2hgk9?U2)6 zF^K!h66A7H0kKgXx-rAn6)3HOH276}#CcGrV)$YECo1e#?+k%^2)ieDARZ;{pv6cv zA-vWhl0L3vbMCt}v$-}SjOjtlpEt*(M}7VRX~rPh?{V;j@uyqLRu1R~TIb_b#H?wO zrx7(Z&#M<0O9kp~f8PV$#ER3*7Mgsg`jC<zr4e8A)dU1)Yg8vG*zY{!SVh){Vl$=5 zj2<Uj_z-Phi5y>;D|&#hml_9qNk@0R;!_#)Zui!gD5i%i`6e)CY(y-{d(~W+Np(p? z=>DgfWp9#8eJh8u_---#-ZuAVLu<WM8#~1q{42JUmpmrzDhK|b%Ln{dXb?BNho+I& z(a+5_wVC_;mk4Vr+NzN_dt6|(VP*d)>((^47pR73>A3X-!@=#^tJXX-l|wpU=ZMaF zlOc4ig^)d3IB!FVLo!Ayy(1rDUpeHtzQxv|Q~pD|Y{<q@PFqNum>3su*{W2EmJ>e| zcATyV`S--AL+`Z<STPYYR%|sGMH$m_y`yOR-<+g1?){HP99U*W1lVfBid|3;KdE>a z@wZd%Kld)nxLeaO(D?UM<O*bcm_jA4lb-_={gWg%2ZxLtt-&hO*57;_tCf;-Qy83c zxP(_{?-xRNX_S=vMX2-ECH~I|@`2x=8ul{9`=Q*5qvS}XOamh6zG-GL`F4sIwz|34 z@fB>yYv{ijG9tu2;Rs!M#IkAJVcrwafIG+&tu$|LRoc-E8&agzEv|R?Ya1>ia@x#5 z2ARKG4+6oA-Asdk!q1dfPmF%ZirN3A;aBMjfEyg0s%9r(g?wy-gMB+;^97;B!lL>( zkOMRBWX0#kR6Cx=!U3(s@^`DDdxqf;&upA=e~A@G^Kp5^N-98?Y9Da5VaQFbmteqO zc~&B&?~m>jFklu3A{`Eo?B`}dX(hGx>|dvQQa$kcs#?i5Sz6Ci8I(PT0~ZkWu;MDq z$T(4BzSDodrd>bXq4fI$cfpe46~z7g!kKL<*(}cF(hfMsU)#qC#ah!{83=W5y37c( z@YO8SH9po&#mUxfT&c6|zkK^vG02!cDir=E6{1qmiCKPJAo;d8^c<&rg+UU+2?G7= z%G2YN2B@P9J*jZrTEdF=Z37x-mfvSJ-~GR_q-^Z>G&8k~<>}<*osYS{%gpY-z)9oL zhLg}IUk5m>w`j8RtM+1iE#B5gG@44*0oT7jSRjM!+nHjyVpDlgY=HfH((P~l2(R}- zlHT`f`p<J-=YJY4l<4zch6K67QVA13XLMHL&wMJfo@nk5eRJwKG2kAWnSVG+c_R5h z_N@eeov@t!g4Ijz%hr!SX{t>iD_FJP35g<{5qh{rN|}5n3g)KKFf(`<@cj8GWz^4| z!p+|goET2DV_BqXU|1Ewd|#i&Llh-&qbBQbfvI5wnxF{&(-g9=ej1uOMIn_t6fm*j zHaG6PM~5)MTp{-TnW?rQ*bTdd7Qf|8N|7DtO_n3ZosrVgOQ!n$t*N5>M5e55W@{UE zCR+*8)3l&xa(KAt5oafwBbKl~8{{FNAn|yiT8cS%R)ab-Xi-yFK&L#TA^-XZTE4iT zK*>_nSn{*bB<>EQKVH=e1$ze9;2HbV&WyIQ@={K>xo^%3qm&v>>Ybdz@O`zQyWLur z`Nr(BX$R~Kk?!7%HG9%lmsoFng*}V}Ffd=GC@JW^z6txNp&d;y_xs@+%yuu|)f*jA zlteAwA?({bbKl_ITORfU4HMZ-oaIoyn3(Va_k5;BtWx3?=&Fi-GE-97CF}kVn*De( z@my6x(%Tg@lNEx1aExWq%q;0D`=?9{yOK7?2!#X=83Et^_|Enm5*A>EaBph4kzq=< zELRSP-E-XGN|^>`u`|8)X>9Dbs36I=Hfh-;V0l(9SK_n>6*kWT<elfM6e^6v3rlwh zFHitTZ<MDeg6w#reCB(TQ$urrL6%&}%8?JrQ{a}Iu;IfeHbSoW<nKg&?c|~h-iS>M zx=Km#>#x<O<E>Z>36Tt*wd=jqP7b-v!3FVhOT_T6^EcWSNI%P^aM@p^FRoyaf;6-- zp2W`-md<;2<69mbU7X*}*TG?SI!1h!kq;LnNR&Ooh#zOfLI)MA*<^G@i3k35JTm-z zgtj=z{juclDGlr3g`eIIj!Xgfp~~?qH|&UjyrgH^(vHI!?J;x$-Q<drt;_WPPjL7| z&F%DeWFVgwUT?$0qdojQNWv{G`{<Vu_d#Iq((_sGaH_i>hEF)2@FZ?w_UVNpIeH>z zww_GgJ*Ym0aY|#v!-W}n+;2vugD54E+O8>Q<B<D2Oa*vNpWffPXfFM0#SKgH!B7@F zW<*zI%HUmHuHdDUY(^$ucQ9@)Ax+&4vb98|t9NbPGD)4AisHNf5f+FmSO&#io|U4M z?zVgy4+BmLQ~a`JjBv>#L-RqxMeyv~U0R?~II0|^QFvb$SRZ0JN%mblIpAVUT~d#H zAsp%S7hY_?RcF7AbqS5X-GtkeuRQLS=49BS7{u6qlj0XTMFRRHqv~o<H5(=!z@P*5 z_56!#XIQHz<=NI>OjXRdkzkP=&i+GfJONh8F!?(E@G?9}@x;jc)vVPAIh&oBs>#@E z7T05OCTWrrrTvFd-%fy`>&^tCiO9oF^ek`x@q#)7bFkzR{Xn8zWrei6y>a)jdXe6- z>6<sWPV&HaMqch)oLaZrB4EGv^<M_IrCjC6L810LKJT{wG|l8`$gnXcAGSWOi-1=> zLVwd?DJijqXe`v|=pI;|A$+&-kO(Mv8O9g5I#SfXt-C82i38~kC=@b*j5qwro>89q zJlD}_{o+NusHJD7vb<?=Y>3riW0wzKV#wLD0`if<Jn}&hc;*yAV4?&l`CcotkBP3- zZP@Ved(K}uF2VcSZIo%6%>*v#qh7pZ4*v0%PkLU<Vy1!kPH|7_Y*cUMpLvr$e`%>= z{3Z@CaF33L!ouJR(t|6KG@6f#<Cv4aB_THSWP=@!A6iJ`imd$0`qlT9^Vx)f!SJs? zzaRpWc(2KyM?d1i-9(Wr1pCVYA45v*`{R=`2o1iIT`l>VPdQlWOa@Zo_ZgHKPl8fK zy(M?pniMt<e>N&y-PjTppR9|TiJYZ6bT!<^NM{B`%N$*A|D%4{g+7;9m4EQ2Ou%u5 zlBRKaplYeJn~;+|^^DnIn$zq<FKbTIk+>V{62)+cSKfl?H02IEQ)X>ijDNZk0oGBR zaomwa-4P@BxD+DXsqhdHAGr}`%W@h3v3TPCiuj#;f_h0?9{B$_p|tIh?A{Jfe?+<b z$;ac3TxFzB--vm6Tok~m_#b^QwczUleR@FS4Gyr8xQY9$78~Ni1;3wUyt(??JD|7V z{L_aL&~R2H$dQ$2tr4#%k^*w6ynjCSvl4D{O!Hi5sRNJ{1E~))*tzz-IC=e6c9z^( z23O9d^)Kw-osIqDV*1Ss%w!4V(n{NV<#1W>=#1EOn7t*ua;5v^GOw@BE{&`vODk{j z^5HCVZ#}4g#zW6YD#EC$S}4y3JXPp40?I+vOwHf1%R7X1a_Z~8E={5;5o21zDvUap zJFEzF1Ao7sGW@a*LR9A}XCGk&_1c-QNyOAho^`~ue^msrM_phYMkGLH>(&G@bZXjE z_;zLF6)%)(B5957OYUq+R%9wYdTI4|jBa{^2Z^Se0PBbQ+@D#E23kyL|2szin$_-O z-|xVg*|h>K^dp!4N+N&gcaQQ2xC%ZYxA*@~SH91+<@<_yyj|9`)P`#98PhtU=hS4# z#(~uQ1m<~8d(X1mbftgXRc~B&dE~8}ysd22^fxe|zzL!Ea(J9NXp<`KJRk8&0d+y- z=7&QFTJ1S9Z6)vG&UsaDvm(kC5%ws0a7Hx{kl#wt-%6q8KAvrs(*aFmOQMK&xh6i- z+|S)}Fahj*>Qg3ae@{)X^)ZWdMiI%x*dV^#82Hc4^O&(0b|%uC!Y|_<nc|k<%kGvh z_~h{1>*wh3ckb#2$s>|g-Yf^W(MvWu6AH{lrUpfSKYq7Ir_$H(j{GCvbDZhOb;4iU z6TTggjKV^<M`JCWvUQ!9mwMiE?(57`9sezur!s81o(y1p!6qb#H2R%F!Y@hUM46p# zYs;!y-%gZ*Wr3TW9*W4T{Rx5(5sv{vSBGjUiz~Ri@ah#`5B2DNZeWm%G+Il>OPrKR zVR%+6|I<$XbnuUG1NbGy@=8I+y(HD%J-oL>lQTvXx`~kk-znT@1#R)Zq4<HLXl$D3 zpVP*c8I*RRXDpx&Ks98~SBW_@WK{;f3uRH*``bHkCywNhEEkbE624WZhzfe0!a4d% zXSlHXq=x5OG@_&JvSkUz^0Z*P^yRia7rY$g=8t#d3=47vU<RxTG*JLtbU#Ljod3TT znpzMH?3$?03Vddezqic;Eq)q!3qY*U2#y@3T?%=2MBVy*tS>v~xY_Ad<d0x;L7%1E zi6<hsB@VfS(7Q9doTKGRO(Y`diXMF>3W96sd-X+b?oxj$seuR14dyfmdO1;QMs5l= z6J8zD5qwVh=Jjx4(bFhqG14t@|AxcO$?Spgci}vur{TJCdqcK__(>Y?Vxdm!Yy53A z`eVM2#*F6d{aG`m+I#yGZM*D5KZpXuP*WkGnkl%NH_9?7$bgjuP^dC7lJ=P7tqAI| z<fuF4IyOpuYT4a#u(&8AjQhrM-Btt7`w8B1aPv5u<X{};5jPLi+nbvVG~FTIcefk2 zQpz@}u2@V*3@U5&3csKw>8YuzS+mNaQVxCkn5zvbZkJfsMQu_it&h6Q_VgoveV%Jf zq84;0^IZ8~JC5-yT65m8B{;SorM$F?qKu{MAtbCCEhWzrqcM+(bZm}=mL1Wjz-vo* zfj3p6ck;%t9U*hUeb1`{RV?g=m>38^nx~Sm<Czm@r8J82Jto6*dCbe}f1DrZ=5%AU z>6Ly<7b(xC5EQ7}>fJ~JVi&$&<#|C3-^Q^3vBwMpydAfK6O++YEMRCWb_sbK6fE#H zc5QYk%t^kdK?R=}=-u%S*x;b$0p;v*_JgyY3$vtevQ#(tKWOq8V;;bW1xg8O8T^-l zGu9ai(#;Ir>S0Envj2X@LT&$((wS|^2$x+e$WA_^ra)gfw_=@givRtWTyi%;fjI@i z(E~Ujo6Oe&8~}T8$k6wJ6*g%a$K}Aou8;Q;zT*W}&2w|U|KCqR9ZQshxE5vxXU}yt zBL?}oiFP)>_)PLw{SaNOl7N283xEFRg)s#q?$<a4rf*A@<#xEieXMEAcV0QV0;O3% zu<pnr!NXHS3OU_Zrs;Us8y;xgQHc|zx?K<^S*fnhXTWcsK$s>$<u`o&3Yiw1_a(<7 z7HahB5zUav1mD?Bk0u_rJ~4s)$725W?T_wdKxy|l<sRS%ZhXI@NrH!=xWHpPIEsM6 z*bKHo<_Q+$tlBt`2oMe2Gqh6kYas{a{OR)oN2>xi1hmQM<$oF8b6CTmlH7OXkIu?H zTPq!!2GEGzFN^*n{mB*9P^^42Ty^P3x-{A5wl|*m4dSnwhx48~T5}S~zem|9_?=dt zhHHPEght|m0tHV=TU4b-#99tRifP97_kA1_{U|+Hf|DrSY(VMy<T5m{Mx3{Qo{Wqc z(X)8J8IZ0(o7symkiMbTX9L`NLhiZPrzsFl{b0l`3H@rCZT3HFoU^RuTk`<R&oOZ` zQU|)i9>kA+`6WN&A`%9L4aOZe`!>g?r<3ZNlHs9_s}>zZ)K+x3tQ|;jfOf{lWzzl) zwFp^WE(Xhrg^nYcv61&_hfvg@qvu?+?UTff5gDRR*PJP8kZ|v?&gy)lT%C&)rJw$? zca_lI7>$xTd*x@*sqs17)wALvBNu7#w{z<h<WX3%pft;$RM&5Fi!Pc6bG0dZ03f0F zZ2L9d-R;;hi3I@Uv{jH!1gj^$`p_R!<}M4QYGL;j08bO{ocbg1ZS`4aCuLMM2}J#J zo4;|uk>GKuCcE4R@@e^djo*sjrSN;<#dU6s!did5o8zBaJ<X&Y<$Wm8BYVekVi;50 zRED`SpI^mcvHm7<EPNd<jK9^iQM3MSMdb3nGGkE%RYdxR)mWBgBITdN5^ckgO6n{7 zw6oG3+u7G`HpgiLfid0Br(9BWYCO&Am2#g;eo!L>T(VIkallC+@NO7dpCS9<IZ+Z7 zaD$}Q3s8GK1mb3q6a`k*fO}faMSS*kZg>(N{OYg-AN$R8K{p%b1A23nKYbu%?4@`h zpcu#9s%Msj-S<p#^up!iIvL&l8(SFnU7DykNK~j@?~s%KESF69O~Qa;dJ=g$tbMtq z9X-3`gCTdL>Sr@Bh%+XO{!Ub4-AHllE6HrZbXQ|{8e7>!{C9@U?w78K(0_|A#rEjW zPcw((J+}r`UjT%kfog$ncM7yL@Ph&>kRk>F_;G;)EEVw;nTrHfMBBfP#cwJZ{m=uC zNZs4`j11g_3EQ>(Nc<$~S3GnC!CZ9~Om1gkV-|w5_){b)H`A6@@xLtD;OJZeraGa8 z84|=NxjPj?Wk1oPW6u!ZP4@ZUDc83snEh0Pg7^U<$)@gBnM2$C^`f6%?JIs`ZgSep z<Q;Ashq1o`UuLcLAK}91n<t*<<-Ie|&1!>E2RH30^uPju6B1iX4hR(vm@oYEG!9ne z!Y}SpM2ns2fpKAfIY@vDq1R_0>frJ-m$_a5RUW9~z6V}oP|SJMK=%Vj!(5teQm!@h zv{+1EcE{9h#*Z;E!+a2iR^7e|SJ_k-f!*PcajVQ5Q<nY+{2)2x)^iuMa5i^8(tqhd z5KG8>H1@m?>lKo$CKgIE_I1+nMzIXJ{GIK{AQ?8r%gZ+X5{uA!#zSjkV^fF)TTK!G zZ*|}rbc7eZ?tuWXXa^XCf&gXsL3KAmkgI91>^-_0XPUX>0WjPZO~5Aj#7An~#koim z(Z%aH<l}iJl(2D+$LqK2RgEpMlhhZlWi*&XJ`39}T|F7@sU2qKykq=xKcy!O4OtkS z^JPx(*~KeUM^C+*Vdk?$KJAT|8hoD%A?*Fq@7hUG5K&^IAkjN*o_3%~*}}&X{EVB< z#@f30XgSbO1*QH$dk00ZN{4%z8H{DZzc&~yDa^%zdQ~!Jm@ULD1SgqC0SITpzYgHH z3)$bmU#~l6u0dFp$9Sz7HW2{&;R~2TtyxAqSadwQB2*wpq`b;uI3U~SK`U;dcIF$~ zu6WdTRoCf0-`I#D1tyfcJ?F!y?A{?_gv~bs4n3x8-O}&#+G3Ct|G^POtE6qpZM8+= zxxesEo|M_&CQV%FqPBdDG75;#%*<?YOpyd|rGe(Jj6_klp!b`N<Mv7*_+0H5A|j#| zhx|F2oE%nQ^$JM3lfxJgVcL(q0_`8=Tpak`oOLO@pw4*&0+2WLG7p!({%NvdNrEK8 zr(+Ta5{tPgA*oP;$S6v`LRCk!d&zIankXe<IqIPNMn|>OSJ=+5`~}8cKKH|f@tCek z-nB3{IZfjd#duTLH@Pv#K}rp6xRwfz#&Yd8VK2ezmM3mEa+R2abY}+GRKY>$TiDw_ zzDM=*>=VHC0|3M+NTcAsn(fIgiW_SF4s2ISbaKdspJeJeyKY=V4~Sn3KE8RhvpuY( z>PDm!VyeB(R;q@hnN3Eplo^7Ch1qK>n^Oid{QRA=r4YJP<25}CXZE!>rnAd>F#B-E zgsoXH1Js*dRnjA5A;~A`&nAmlNo#v@x2WBIKN=$cK+sex7BMdMGG=`IX~NZk6tgG= z^bH}G4cM&~l<YyYfrCw2+kyZZq+sA8qBWe4KzOK^L;vnWij4OWF4nlo&cTEzBVa4C zL@by<fF$2T_VY-g{Y8BLUny}+1j!S&&t^2ZycfS$L9q&?+XlrVwJkc%-$Op3XIYVq z@i#Y9@DoNqv<TSkzy4hSnO?=HZceBvmr(LXA9bslKI<v9YwV8ujt0^3Ubj$<ni6(* zfu}1aOpkl>6>y<}+965Kf#-z4Jtr5i`VSQK2;|Ggs(TFc7X7M^gD?u}y^2pr&<0tc z*zgURtJAGqT)SietbH}U!NOZ(Azk7gU$u$?-$*KP)9T}UfGa>Utby`_lUc9!EhWb# z2KC@QODlmFRSi0LK-E)r?rd&VkgPJ3ZvKw&O=YhB|G(@ZfJlicvwr&OV0U6W5Ct@U zW=kc-Mc@GuO^025wLGCk0Pq1=dvC$^^B)4jdpmc1#d1aja0PEJ;_=?}!2ed#z4U~E zfqns8U}sH_RY4m2wr;E2`6q#>`C@;T+nmc*pnXTm?AQt3c5&A%2t0o&UETB3U2N8f zz~Mo<?FwM;ryKKDD6Y*ka<?rQ(z2FEp?ulfSzo68+wnK$n?sMeONAhN_hzoIgh0jN z2nEhrJscqm1U+J>632f9v2IlaENY)wLS5)Apz7>w=l;mAW0vd&!H?O)@5vAC`GoW4 z(906z?{Z{JsyXa7tzd-)ZHg+x^#P0TOHyUO{0yyq#<A8FwECDVV<J*hc)lxtr^fj= zy(q?9gCAPQwdSOFU~tgkCS7p&BJ_paMWeLL<y*QIHRfR3B|$6XW%+yV#8*84)WS+1 z<|yo<1W9-!1Vps|6#J+F2wR`Mw|Z@3Gy0DG*gRz7n?5^a0!X#Sg$HQpY8KFY)Eo=c zKXK%{@YyGgUsn1pEQtfL1&K!tekYF76efII_%B{`)i0h82Sry?A*+u$f7Rl2drw{F zLZW%yRq#y<^Qbe$3W;A`Wvm%UbxB!v`zD?L*f($>!<=)+*bVoH6Mx<r4=a67ex;$8 z*#fB(YpNDYRiI6Mf|8mDP8xKA*KQAYeZbu6xd99cE{msEhx7Fxq?hy^xBi5OXTm?e zRAivf$pP#0S)#xOeSdW$FFuRTQ{*(QRBkaQ7aB7Yr%x#X@JEOjn2&8^D?Z7|%BTA{ z98XQ(S}Fc{A$N~!Dh|8jt~A@Aia^)7#+6=6uCeRs&|)tbf*;h8O7pDe*Qbj=y*pn~ zJ?~tPu|RrLis1cf1(^%PB8H5u*Kqb<7n?Qd<A#UNzWUEel5mD*^&0^)Et`#41vt_7 zS;`7TR=AQeg?#}1DhKt(GM+p3-rt*00-u+=)1V708^{z!Imj#yyc|8?#;f7S2MX3s z=Y8*crHbskbS${uBRxBy+asJDwPb&{Dfk35&~&Y$@N)6gU%G?j9HYaATSQ|80|qJW zT)M%m$i^6Z8}s(Cjs7D)LK=zXxw0*?chO=`TlN<pJ0M#}14@fmR;Shp?;lC6UBIip zS!c_c5H8LEi?{G#>X0UYofPlsFEGOOyZ9?o7I9MKLd-P|gM|0N-Tl>}t4}UIV!w<@ z1?Qv;<N3)5pTDq7;ao7d?t(^|fkq6tU8PuEDvTLyw7;AuSGjZ|DwOoPG8|oAtcz`( zo$7u1D&tc!h3s>ld5a<GX(B?R0eF3=vX7E@QoQ|viqb<MOlf@66MGgt#!l2F7No+x z*IAj8Ef~;T);Ie3G;dpsnS=M|ZL@C%+JxpaWg-E6?mqDQd^Z;mp>Sd_12HpYY=Hqg za1ZmJ0Wqkip;oREmPt53V6HH3mV)S#65AP>@RxC&hr`{aGZm5lWcN!m@P5~()MoKo z<Pweh3lRy#$7eYu99ny0R**I}KHlCoJ`>b~dXbgS<}x#{k!CP?F1Vi(P!j#z2iNZ% zR?hb)j!j4r061cym@E$_Yz(7=hk}S0Q3UB@i&n70^;6lOH$#8M@U7O}GC`u5)pwgg zD8`)#+WK7v?S4hKfSa;S$Js??xd8qfrhWTtKty^R7y4@Dwv%GEAWMUNo2mDU{ii?U zw4A+eL11aFpT+E<-MY9d^g6^IxEa{J=S81o<S|7ZM<yR|!|;ZGn*Ei+DkO=CG8SS4 zj-WzZufWVZPo|9i`Ge7iRj|OTw%rL#G^}xsDVzdofTMpGZvOkLqLP6u4IS-xKceiP z0wU&m**v>^tO!E2lhltu%~XNCY}CHTc45Wev3kq#0bfQy@tlCHx`<vI`5|#5$y)_< z+@HSu;HOewOfQ>HO)^2Qred@o%Z4{zzoaxZ%Ke7Uto=pVbUbVltA{*vJ=c1!dq>3n zkv&Q%jIf{<m_zP-P+Q5>9pWx*|M}7VG{LpQmwK}WtZ;$A!DNUA-G?$|#zLUgL=ahs z%4E38&LzRxUR8m8H`5m;wa-jM_@U%U`x0ILji`>-mGHXL2!<#l@B8PXC#$-~$Q8QP z$p_oTu9_W1**-!n?vJzp+&=_au8k*5#I$6`Q!^@;K?g(XwKNN*FXOlfIYexA$D);5 zTBw8Rua$Nn7Qgbxo{Irh0~1#pUL3le_fEH?B32*BS@_l*+?6&kU58zvwE*S2OSatC z9}$P1-7;(eZae#rwCF+>-@-fZclBVY!a?`@KY#wT@M^lh#dyR*>7udW3Q88p+AoB( zZ^KthM7H5$cI+!Pq_0gqRF^bUo_R%!&?U&^vh#Xhg~z+0>Mdk_-j%bMC0wGIFEBoA zmqqzZF8)WL{%ZyojALs>$B!v3``W>h1iy7EsL#}w9465^mJx0eE}71J@<Sgd_HiPs z#ut62UN$vip{-eq2}9eT@*H1Kz%OGc_MbhgH6Ul^rL;!>B&nuhJRzhD0CB`y@pdVT z5|gww*o{qRPyhJM3%_`ub9=sR{uJ9&_(yblYT@H||EP;UK=B$6W()z-l%O+C&e8C$ z@KAOE0ot~qAvcS^6-8pxTVcc61ZsA7ThRM@Bc*#UqY2F}0mV01T9!|6nFT|=yYm}< zE|6j8g4Is3lUN?%P9k)>pnH})(@&Q5<aO2-Zr0_f`o9l$1Rv9#3};`An${1kie#Hs zB77%7l4lY>UK{g!3vh!zS)tdXpl&X)bwmjCK3@0;nU2a)mfzhjEf&+FEcV(@e6_N1 z*;vx+Y_o@PcX##bW7jTSnc=!-*Zm4n*!@iaKogW)A^~{g>u&5FJouwi+c~Chg_vH= zOeW>R{YLO$<U2l5X9xbfBE2tsiah+FMK=PL<M3*E`E0tSs9;MaQu+p3jzIk1D>|;g zp|wP{7_t(VSmHRjxKZ*vZujFQlaWVD%Z$W?$=fym7GpL6Z^p~1T9{e#i<d76tgW3I zO5aSSL=#s-BycEYw=Y*eg=3vIA5YdI70OFWK2mHJ;ZWPHn6=H$73;An-O0P*m%i@m zAw<PPf(oD3@j)U(FNO{W5_**N5LVei?>U*^?(wfz9ybFX`nJ|e_hLp$U<bUpGfR=J zNfEbub?KzY=JP#~#N9w-cW=qL7U^K+%m_;PyMmDSUVZ0<&n~?flkhSUm)Cf_l%VH% zvUTtji`@Aava#b8{8fixVriZeo#|1P33I|}GFE-R!(O%vnGZ!&4vzb(${$0p{P1@W z9~^v0bp6PF5trN6AY;?NtA$%;xbyoDc%6w0=PQ^yqubT)ZYNO;i(sx!FEzYxc*7|O z4>wGKizT(~o6>8THoj71&e<2A)#mMNN8a(>#K_&g=qaLH==>f@Z{~o`m)}3I-u9R0 z021I;v3#2G$`<yIsNb}n-b~dbkh8!KG}@_W=<bQzpg#WPZHoxlpUT1&EM@TnEVLua z>{BG#!U}f|i#xq@_AVQz4!)L_K_6ey95n6TQPVGZZNtybh=tQe+o*Kc!GuS|{H$Ze z@y)7pKBFDvtv-hyvNt>VF?}!Dz~Au?NP>7GVe*%g4KJ{8sUD+H7#q4r0|FS)RlFuP z2nl}`yg9;P^|_A!P5D&FI~4cL&a{lfr>Md&&pd~t+zQ7CQ9iD?+YP1`C|}N5aVPNh z*Y(kA8sC!Vdf{P?Z_I-u>;x|CwVuspCA;hd4~f*LpwpKrW<+L%VT$Fw?};dfNudvw zl=2W$nUIvmgQgWrdgslYN{b5J*U44Zhdzz{^Bf$ATD)W-g_k0p>%W|s$&TD+l_O5W z=x{VkF%XYz_qiSU^63iuo0%9Pd}~njb>7WDHm1#O>oeo|X-5oY2mc-(w9AHL><6M` z{s|W$bo7D6jZ{yU#VC%&e<zQOL=U`X6GW)u$2BXv?%K}r8H#nuGcxY*t1DLsr@wsP z6?n;G82I1iUrAr^FU*~BRQpLlHR?QQ4??Y6vfSE;(yl!#fHz37q)e%WJ;M<$W+QO- zyH)va_s6@DQr^S8MTd^>z{Mrp_TXzwyk8d>DY$DSP|Ns5MCAAH+0<9YDEeuz1|>B9 zaHPxHcHe-m{nn<xQ7a`6=LGitoc>i91cAC<_CGH8L~Y)!pVQkbP20A-N(je<CT{!I zv(W_aDU|L)Z`RHT$l*zoG<R!`f3$ygI+lqI?)|E<kbdCSrCd`bL&3(OQvJz+;EJUc z(d(o7kd2k#Q-OH^Id5C8L-|v&P!@dfn&XVSM=W~l_VCQKI}OA_M&lxJoYw31HZ(aN zI>I`%lq^{>lV;;$_I+~HB99#EK5z^_q<F|<0SzcTfK{b{8hidm0Oqj3h52llnRXUB z)(M?{1p(h|Ecuv=Ti)NeCMF~XpFVyR@H7_}l0?YG1>mhbfd?)Y>xsX=v}AGKlR1v; zg}re}v-$kxutH?b;p`e&g%T;d&Z|N+c*#tW#zWrr>MEUGJRH6LT9V$Q-KkD*z{5=U zWAvMa0XTS!K%3AZ@=wm!JkTM&b{)rF>!`PFg<R*^4;jmilkSO`HjJ)|mzTigWDeb4 zViXXy5JJRZjUTTSe+rL*z)N#MS-$97>}h*UK@5sG>gvA9mRPBK#|4j)P@}{X!porQ zPOu2Kd+DL8D9xg=N}{2y4G+S(3pTFA{|)O5nPCkqXs9wy6jyRRpiyUk=(B5-^Tg?v z@QI%4quI_oNRrt2kXZE^k2qSzq7KN%H?XS;fLD)U(=ldt*Vd1M^_itl{KnjQJB}%= zUv3TV##ke|#DD;yVdyoR{iOm!h4^az9LyypR1I)x-yo+6;s?)bh+_;Nlya7s1spXi zD@RA;zq~Z(xQNh#0C4C{GQ^l_@H<ZGr?Sv4l^aiK0cgL-8?S#}Ubc%rCW-zqXzYX~ zS*ZL)o$qqxOatYI8QGlzx9L~wj&tM2QNmImp&%U=7mB(@#?=zLoWlBc@Jh4Ax1h14 zZ{M=uui%0yGQ59A8u3Uxajz8ZxXd`xDf+rCAI&q3fg7BboqX?0i{k-#js=(dM08-G z{3s3#wT~&%`>tl%FJCw+Pmgwg!IYOlv^qkCd-rj5RS}X6Q9p3xG1N)5L^hQ!OV(09 z17B``hIg0;ES3d|$h#nCdJ?KiW7L9=A{OS@F0gaKw#&8y_s`b~MA2NgYn)?woP&Vj z<%1yk$p?A+TuJtmTSN;IztV<m-eHWwE71I)C~W7f!$4PI&C0R%)6w-9Pj<%bO`={k z;m(H|TCGkKIP$pt`m}#L3+a<Trcv;EBhHjyfz@CRzJ>xmD##R56ciSZDVL$$6l8CE zo(?4GUf@`?!4O5+(B$zJa>>+vp=5k5tsu65;32+Wr)!c7hTNufk@gNkO*KR2h53Vk z_Gs5S)1T>6$}n^3hOB25_t8Gfe@m-e;VsgMc9+-T5V+^P!o|;#ebAHXqFJYtEfd#6 zlb;@sq=A%#L(woP@bBZ}rj5U)i9E2(4DB!#%>yr8xs*o$T%Q_RN@{?))qom!P;Fie z<+g)pvQZSv{+na-xXFCZT$JpAJW2SRPqR=2zsv(w%ddWiu=A59fUod=q2YuxH6w_2 zugXniJU=PSmx<<3KXY3Gr|+j>;F;aFr4uxyu-iGfcOBmH%D-!WX9`!E%34p}KxAuu zZf*w<{qD?xiy-baTE!*xse?=AA0Ai#my?VAHw7IvW65C5i02K-@5_^yIT=J^%>0KE zQod`2o98ANj1&^GL&3SY2y{Mo?*my}6tKB2q=3_EV{SRWTg{#67!_Wi>tGNpf~uG? zbD8SMk~2ZvP9YPjh^Rxl3&}a_=*<bzKP<>|XVBrVNevGYmDyK!-ex#SSXg(tolqWj z(dQz`>DDJJ=T;oaJt4B2+gfu?^Odj5y%^9|snC=a=s`B+6oAVX+K8D$25&plJ!{JF zo+rGZ@L3AK!lWRifzZ3({gm*%UD&<VK2`$JJIc_c<{%knsDrKKp_*`{g_1ec3=<^! z5N;mTyyLMIp772_O}m1QBviVG6j6Zy$%w<1COkTE#P16jgQ*NZ|7%pMsX5<hIKTwG ztr3KGNN^B+zLqB+RqTj!Ly=T}Y2Nw~*;RY-@`Ub~1jfu2oPBle0A_*9G1`lz+&77~ zH_wqyO?fFYHDuh4NFyI=X(pDEw~^vtrI8}-C*xYjz;{s8V}xS;M2&h2W*G~?Sgy0b zE{TdSsmK4s>`esHKU-6HePeG55N3n{Z%v`Z@2~rdki08?Y-avfY4d0%(|P^OtOm$F zX;dxPB*e{9o|z)ns+%%FSqaZhNB~N;6ZvuXc=eg4#DHO9XC;#Yt*n9o!PfRkGiB=Z zLNyxV+%^_-rF_bAK0J7XIt+Ah*!y%B_uIF7%6td7h)y`|#=-0SYWMN;0-0+E%Dcbj z-@sSk-Wd@VpWLwE()@2P4NDMBj!)GP1z32M$GsjAvi~AL_@PlBaNv({JO$q+>JJjY z^Ls7NlRJM1xzD}i_B4oOS1G7KxScp*7&BI$7bA)DLGs^|rEv=XhVI@z{SyM>1ha?+ zJz3Nc$UqinVtkATx}3}@vX12`{P{`A#1ExG4I2Wk^K&u!IROu*1Gb~$;v_6c+~Rha zEWg8|i*eL(@S5Iw3rnQul>Vg5^4m%iBOqt}1!m8%H>bUG@%`0--Yee<^7YMm=)ji% z?K6U~@&BUabzu108M$~h!Ul-^RJ+4lqBk3E3pj|nmbJ>@ZcQA7e|wJ?9bEatX+)0K zlrzo>aqK_7f{on*6DgA`{+2l;Yb0?Jl2!Snapr1%4a?yQ3%3xj0*yphak5fjp;*o` z_-5Ba`MRC?)d~WI-dAPE;}x%;90L4D4UaPLX&8vR7w)@Na#jo2-?|EHaaWrN==<%_ zEc#wAVL;xO*Vh2#VMawMt9iA>{_Iby-c^SmQzSA2xFnszM2fuk&#f)=gB7R{)`T|i zZS-HlI~s1Vj=qE1dS51I;}<;Xpi+u^Mnlat$8C4Rrh=-~Q5*RD)BZqV4nnMBjN(&n zOL$y=<A6aa!fj+lF)d-4V`Z%V&cv+>Wp*Z}>dk8Bimb)_v>keCF|E$6s*NY^ELfBl z(r(8RyA<gEZ_;GT+H%+RC3Tj1E{cr-pDGIXM#%|-z2o_r_R6|+CNWqncq(1TS#$+T z@0#SA<G6YM2P{Lv>Q9e!C7q{;JKA@nD}I0wR{?ZG9U{4gEto2?=u@d@tFuJ2K2xsR zGKbRzpMH^Q?1X%qO30yPRNSUjm`fPRPR4z_O_sPE7a*|_s5ctS9_5y+9OeM!*nvrO zD&u?V7yl!n7)a+x_q`5zDzSn|{qI`t<8%=H@8H1Ewqu&Z{*{<-!5X;|&gXip_1FLu z5Ibu}_vH45pwt>a)C?!;Y*yt-WqBD;Jb+i#dHSd8Rk_gy4f`YztJSV>KzqH={J}O0 zw(MIzF)<F!e+GHR9)SD-Z!}i{-iksWvx5T6b<NDNThnUpFv9ob;2T*(=^sfe7oIc_ zrJ|e&RED_xLycl$rm7AB*<5vE{GKG`p3Ux&RJ!J~-H*<=Q(!bo5-nW=d+sx(lf$|s zveDCX$*WJ!il6@Ah|q7?--4&9U*4mD((|B9t&Hp<f;hjoLlMV85PjCUn|f_-GGMOI z)vusLhS-i-2HA0jtvEU4ghI1F?v)<vWyyZBuVTQYIN?%i4u2MEKj}X03dOh1qt>^j zX{;yTCV)`F!x-Z;5=eK`b`SPfs^BAAE9R9ip?}=kDLpeKe>`V=pcR%*=p)Xv_)*~r ziKyXDtzt5FX2XLYFNNdJty3{R^Kop!oUMxsoBlWXoTF~noRd;B%Lsk0N9_G1nxOes zR(w^5lSN!}YsRL2pPqnV4aDcJ2(rkorBNbh#0Xfl<4g$^|2Xj_6BARH6WyI{fHODz zE}hS<HN%s9wI@zKnx5wm#@#MNXAkwYK->3N?z&BV5dPrBs~PI#*OcNWBlKB72y-xT z9=bfoJP2mYyjlMy$MOvCO7HtV*(?`VePVhTJJt3Qt~~{+@ShCT)MxAfiIU1PAL99I z&fHJ*fQ$Ln5iq)PR!pAu@H3gt&!456D=dM6B|@zn7kC~V%_)Jz%e-o_mM`Or4to*a zHPY+;u>KN*awjVvXYrP(XtV$R>+!oTrT*fI`VFrJX=sIIa}=rQSWAgL{(pMiI7Z;V zkUfRhz&iqVO__)5PyKtb%>s|3&3=rgrY?TvGQcFjR+FHs^?u6VI$jE*0)%w4-wScd zgccD@1ZJBMR`L6_|Inz?V<{OMyIRi-AKb<exf_{HucKs<4WZ{TKJU%9i}5-1aiBWv z%%T%Q_=gn(3n-+ek9n_&kVdCQ-|HCpm{iH#z)wXR|Dpdg%>OeK`4@|)_E<PG=ZhU| zZaBN|L_I3U!j-hihC(=6*`MEj$pStSu=`=YN8OpPi~?0{cY8(HIIM@DRS4uibsbSE zI!qP4SqX37NZbntQH!Wg6z8w6_D_5<>ys9+IA}08gqj*>E)c2jjHtI&NV@kn+t6(l zbI<6SwU+{2s9<qF=PTEW3T@%aqQV;#=ci8!Il-wcQSE>|HRQ~!cR}bcH>G7bd&7BA zVuTEoq*^G*%==e^!=7r+pUx-OV*8E=ov2}>K<@RGpUKnEiH3Z`Cp)UZY_`OQ4F@$x zQ3v7M-d$3`24buV(gdy=mtOX4)mw7a!u{vAD}^llcJB>ew8)N4b6_3^a2W`@-!Pge z(rtem%Hq79X!pllvX2U`AeQP%ueJ+5!`}?<va`qxp23it&9?N*jzOp+hY`b%Db_pe z)TB2BZ<!5C1!{ZJ#`6uUt>a_@_*vMa5xb37Guda?bSfeG6l}^X`GdQ&&4F2=tzEaf z?{?{l*7lD46H3@EncF`T$SMSpX{WZ~v&KG~HCc5NA|kAIJt*1JTK0X`<Klx2rK+Bb zB56+rjPua>^X9L-i5E$6vV+jRziqQ&vE>RjK8FOx-t1pWJP%B^hgzNYk{-v5kwVpT zxSh6`s_^<C(D-NZ?K;>A=I091Y1?XBwu*Li(Y*1WWbfEv!U)|R2L7<1NsYeSO*#D% zldVwbGhhfLwHhUOY3HrdY>V`>i24Ip(kmyB8JJXb{`U{BMxI1mPSRt-;JC}wDTzHq zb5sl5H5!C$788?@DC+2-JP;q|=^Z&fxtmu3Y(6{_otiSZ#H>`cH&}1~Fl7r?xvgRt zGxH@HQ9wFruH`81@_lyi{iD9ffqewjfXBLK8_mrdltxtr%e1P_+YLSX++DOQI7}*c zFXGvCNuR^^e$pL=qOJ}xLE7T`<S{{{jVLLn5%e%rQXx!OPICRavJ_WhjC<38?Bnbw zDT{dns?(3QGUVG=rLAta35Jn9MD=2M-E2P&eR9sKth?h%O3Q%ADPsStV;|WT3lK3z z;=PGpL-n)8ykvpPC7-3s<w3@0TX~ESEvG3BT1^jJc28Vl<q)i|)>5$yFQAhtsOh?c zDKbTqZTeFnI7|a}fTa=n2gY2TV%=`Kdmodfc!)IXeAvrSV+a#-ios9Rt8&4dExMtN zWlRA>I;+m&p;e_s0b8ruvZ_v`m)5)qeZE}t=^=Kn|0dDs7Ze8b6;p_actDf0$Qx4F zzVOLOQVBnrKVSJ>W8Et|h|~+dwfN7lSJtE};4Z7#)zXsL24$II#$or0f8uV6tv~;M zQ=|+HI~h|i)atm!|9}y>-DVGafuVdM^rN%msD(r@L(EYXzd3c3bX09@?pqb!s&eod z7cfaQD<MSh>Br(sztz5JeEg)BqLt^tJ1<7l9K0N&(d|$S+;TBB>e!1#hFk}OVop!t z4-d<ov*=4?lZ|GAuYE%ns(Vq>j@CL#GzFPaWU<J=rKUj3o*w9_p1a_uQ@p5l)!i;i z#X;bDh7E4S{i_d0hE%Hj!2$+(0npgmiVfbKF1+`=Tiesi^k2jqB9U1kfsfod5`jc5 z*YpBe3}>dhmE+`F+KP(sTe~dKKGp?+CJ&87u(ZsR<)2o6Hp^-FqBOOmn?kGEH8j9{ zg-zBB<#+`)1&Rg+50OE-ByM+YyKlG`X^nwla3AXKS$|rv{JXL@9p)gN>>x#3!V`Um z$#}mpshrs4>%>)FchnajJZ2Xc3CT_~aO_AY;95B7szzwQs2-~sOX1+nMD4u1%UvEZ zK_<`qi}Enl$%FK86D&QbdS?B?&rKyhxfgW{Lzs9#(E^+2Q|Rg#Zx(bR$OzMx_ps(p zLiq!ARsE@br#x&z&+Nt|;V!0xS3&3FES}>`Wo=uX8;2jp{c?r)DfXJL3j>lc60XZD zQFJGIp=J~jvmZTBYA*Kwst9S~fd-tH#OjgmjmDYy9v&Zd@1e|p*IF-_R-W{d%M6SC zVro$$f$l^{KvzcO-`kQ<HR)!BY>jllw}euF39gBAArX87AqFDiWLf()Nq3a13r+;{ z$l1=yCngrAvR7OTifO?P0nEIlUyFH>Z&}|l%_3&(9&O=>P&=LJN_#1a^CC5_Rg<1m z#76OItfuTx@E$D`2Tl8E87#U`7#ht0J&AQn*!8_bn+VvXqilU7E!Lh?9W1q357;7f zF<sOwry2qYr5|{7nA{G<W)239R}|EA!dBQ5C8;h5R0_Lpc)kL5dQdooN<&90eADo# zo68t+hr}3~Y`Yid3L!@EjDd$oM)b;q6={Y;jjjunQ=es&UHG^%O&G4^{wB$<zP)<( zUwddR4s95866YC|(lx9BVe1b0(v7Q4%fa{J_D6RK&d@K#r~c223Dj{nK-e}{-xd>l zkbM!{ufMoq5QOvj%NL!|#aU+2uZa|>+;fU95}4K`W`6Iv+iZn?z(vXSC!Xy4@ptv_ zbgmt0rqpX;TJ*0D<*pacr!Gog!otDK53)6IWddq+Pe$XRe!|!X6dE9efbOtY%>}11 zJmQ<E!`3pGq|sSiZ}h=NjkJ_dPGuBJ0?sKXvcKa<$^f)XtSCa+VE!P9sEqkm7T55y zv?Z=wZVng%-o6Te>}<!8zcE81&MOi3IC+#&+;=6B+aXVNr1SEb#E2$SM(j_0{^<4{ zsp=(;@E*Ru5M9XGLN0YiDdzs>jGP|2+i5p!i+%E>EYuJQzZ<z32)zBpCITX4IqII# zKdh?Y<@`&JlO1@f`kUT7Ab1&Oi1~RTQMUG3;1Tc}uhvGV?XIj`+}h^7zIx6wgxZ&f zhzhX-XVL+^Z~>?k9sHQ4z;@@Ma>%ul#g()xDJRYCoiCYBHJjwV3Ujl)!`HllFuS<9 z3KCJ_zQTC6;I+riUYpf~yiCp_q^PsfX3-%XN(GGzC9J6VV}lf%A3-D8({Vfy!%EW$ z(cVZ_Y>eMs+uQ>q|4VoGJ++tAt6S!`9Ktu$;VG^lx-W-9T<|{;(!vrFim$xH_&?sC z9y>ZX2wz0jFaCps-^JN|`Oi6E#}&39>ay7Mm3Qc8DkFmkS4lh<Xp*($f7HDPR20kB z20COAkz^!i5fni{K?H^*pd=Lm5dl$=oE6C#3?xxekSIuwN(RZ2bIw6>P6G^S>UED7 zj~>st_x$(&-&^a=TAP|~x~smuYgg5-z4vr0Bge^Aj5`AROBfBZX*Nj3Q9`FNs8<Ed znoeB$M343TkPb|i<xIRA<ZAIJSP%+!y6fuG0#P9XHIcaUpM~9oZ;=j##vQtI<|QJK zI5sNOo;l%RPLUYyC}#f5GQ&$Vq1i`yQT8+bpY3t4&8&BKC^@0s1hn?J>$snNnDmOO zDN*j3$J^CJW+5A+KkW((ns?52#&ttKI7$>Z*r`{;$VUqX#iG|AbvNc)bfpAXn7K0W z<FN|id6fq&Z<3D7yHYzcpJ0n)lhV9Q<J6?CLmn6M_F^&Ldz-*dBeUbb2O%f-!T zH)kqj=irw_Ap=46V-v3D_+KWW8di*Sn*?m0hx&3LLUDsiKh5t%1RlC|*)_cuKTSRI z^}?x^q8&Dk=d9gFP|_WVuQ#qa<j|-H&CSsu3NeJ?w8X?E8RNO^__~4@q@<kAEbIX2 zQP^geu50<`h#Mi?w!U49%D!q?evkC%Yv1GNPt(ugs*pY<ykho<)QtA10s^yhzrKD+ z*%*IXerMNMV`DkyCJn*;Lv6Dnrtb_K+%FKli@7huNs2Z&Y)RPSTTf)}LGZ5PVM5=q zp~}c5kFrnK2-m-MyBqDI)ad)x+Ryd+R~$c-qFq4m*y_#WKtY#|Nw#Z28LqrrbBUu< zq#x}gXYO=9b7zmT^P!SQ|Crl?i0wrvbw4D5A5<Eo9!@kXo{1xBiWFXB%;e)!B~>BW z?qB2nlJ_vAqiXX|<t<#v(dwyhRNtmK`D}!?pK^VC=fHisFQ@iW7X|fOC5(3SDq+S` z?rFRNeUZ7Mu_%U4Mn^JzU8T<K(VA2uZ#=%!oCGFjNnajH%q3BWAF?>(sL;jSQ<RHJ zF+Qbs?uqW+md@S<0@Iz@I+~0F)|hKO1RKQ`69LkQ@^1Rav;rNSu3wG5=IHF?nDn|U zimU92<5D?+^5`@526f^L4)e=_A3g|l;QD61Y`^`rJb;*uDATZl>m^6v-~}S8ASw-? zk<2lR)w;R&xxHsrL|d7kK7A%gk;)NueQo1H)l%WX9@G(P4}rG0H<NvKQFIpzZu;n- zPr+}VHD}j}DRwo_jTHPUIeyHByr)1Z@%-_dii(OVH|}uPZM{9Z8+;KMB{#LqmO!ua z5W%dV+K+EmhXO&02h++=b0}Q5tMaWGAycG_I)PyN;ANF0_iV%|wXrXlT?hAB{MSW{ z$eC{3EE=+Lat1kikHgJh4(goN)_U{d`ooQG1Cdk@3kO7rv6YcyM!RZHZ$2sW5w~TR z%6YApp|0ot^2BecwbC!)h`q3pw;#)i(G{_LY(sfY6q8|C*{RMEZ4n%CiGbk(tHH*? ztHYS!G>no@IK1HMcqW6c)V$T0y?{F|nqm6AYBTb7RN1b~Qqy@lU-)>EGG*H0kW7m2 zsBo$(^UWlWQ%T=I3{P?BXjy+HTb^8Doy^>RmnV>2;2=QZhg)@Abg+QEW;Q)si!+j8 zw@}>uoVjlDA$qe(L?bEMOr12KXV2o&+4#FvpVD7l(}1R61hvbP{393laK}oRXFGLz zcn?#%INpyGb=b(VTbIqc`B>wO?qtJBJ-t?Pq}n*=rK+}TIFuyI7#xC~C#6x2PyNP1 zgBZkdCe*dfhYa|u{pOkDT*qgJ8!66<K50>DY1nd_JEV|>n0gTqG;y_nQLm!er}SED zOS#8mMgfoJn|V$injgElGuxLEU&Z&nxf8f_mSLIsAc42X@*|O3yBP~_JN4XTUL4DX z!Bls?TSdDQ_`GO2hGa;{;#0NQO5tG7{XpDLo0(M1QhB&kk(~)AlqcoBAWoPfZ(f3H zIIAlf8qX^=!^t(2=ZGlUW)`pEcwAGS2WAD^)+)!d1z4DfpsmK|o7EdBTDT2yok8is zTne7}haRtYn+p!SI2uX>Ju%QH3ABE@C*W~Y32lep0cxtJhF{=`FCR4pE@Ep6@6}zT z9pwD%7sG_fwMz|grioM%SdOJFQzASwbU8io(U)1qMc>)Bm?Oo5g=*xz9WV!$QqgHS zD#^<Al`9VhU*k{DMp7x4NZHED#uBkQHu?#$AhZon3UUzgeNdf<aD6qUm>P+xyLyUq zB>rlBsq{^kNS)5jwtnQhX7i(28B>w;)vdQ0T${e;4mmpvcbWG06>YQj%{^DxT8qSF zneFCTN*R8Qyhwwqvi;s`c|;H|bNPk~LXlRj)OFWU?#k%uA;>LaxnM3D8O*Te+eN$n zOv~+>EuQ^e>&`HB%e9#@;!X9X)@au2r4~%y1P)Y6)l~wDy`Ok+yn3b6WNdZ`R9zyO z=8tjhx=pdXLa32KKOY%>F;+aRQFNSuac<AW{d@}M=|<48^*8ETe4FJV{KHojm8-8D zUUjh%T}P)$%sXwUeZ1bLSZj=@A<D_*Im+tOUd4QP=aA&gz_8##&TZ=FHiW#7`CSms zC9$uCT&PrSi8$C#9r!Fke^ODyRGxezLhR6@txm9W<EZzndG7kVK&HOEt@qtY2Q4kR zd@68=HW;ad(0LjqNNOa0Kc-cE?`~IQ|AcEnD2)cX&zSbb)hoPd1qXYAhR+LX7&H^` zk46+OVK4(E)EuW;mDH1BE*7<%IG*<)8_(}DyWt_-o=l4#idpiglPfRSGZtG3I?W<4 z#FWH2Y~i5@=_{+&eLES;VyivAv>vFv;a%ex-4##7s-<yCgY^!vXS)~OgsEoBMFP&8 zB-`Pv318ZK(uJTVnku8;G(~f1tO(OH);vYVf+$EQ|6qk#Sw6?WOTAWm71OlJ=$x=O zJr<DJNB-W)%=4)Jo_w?@yNuw2)$vp6I*&U0#Cm&CE!r{`de2nNTmup4>fJMOBr$=> zH|v;KO8Zk%PWLH=iO20U?Tqvv;ZADnoNb`Xj&m3%8bN;^fAXOW1;N&{QE^G~j%Y?* zt*SA?fkdmHlTOrZ8+o<Z`;I4V7vt>gX9`L|m!fuojT~^be9a~aC7`O_iN5KQu6%rz zlx(H;&2C+p5l4A5uSMJkTzFAqG@6@LS+9OBZc^DZd1-bdIOyGbv!a!3$kjiPa^bjz z%JJUVv(EX@mdl#>JWbS!F`gt#DSmVoN+1|t%gkc<38`a&lkpulwa8E<g}}7O2WHnb zpPEYDAdi0g&iqr~OWxb_BUzahTzZ81lI0pRc`p5J9<{@P@6{BFO*$|1CkVIPu{45S z1d+H@^v1p9s;T0cFd^r*v#1opk%{MyxaH|8a{Yi(`Ax;;sa@gu$LQ%-%Kqt^iZ{3{ zD==$a35Td~7Mx^Gd6UzgA5Y>=(@<Acl|E@y@TK(*o1-*R0oT#l^|?NQkuX5I9`p{N zlkoIyBwrSMS8BcBH>9k@knP_>`z?r=#Ac%J{c9>^adRQv7o6m3h@jgAcio6>apdou zlsNIqXi;lK_*(MrREA(_@J+=yWUi(OXOQKVkjkt;(31I8`;4hMa@Ut3(JfhPLK*>= z=O6U4b2irTD&EcyvyVEXPdY#Bz{Iqx6~{Ps%o&`v1DIBO%$A*-l26ExURyJFdP#AE zQTDgGfLG4VNRf$v$CW`J3ZHDuzkjG>)B1h}N+-Ivqecj>g$UfuJj%pIAa)k%QG0n7 zK{Ea5;&Cw}{9C5I$3=pWYn|3~!*Ab|tAuL@jD0PLeam!fZ%jH_T=3@8sJqWOA<1)P zSRk*L`d=|3D>UT2dhW_~1A&m4DM}VI4W7Z+sG3>QzJAb`)I1}43wM!R`=w*!O>^&p zHx9R-RQk)_3d^)xZB8D0#&uvC)nD>ZT<BR>ZQqt#m$uwwnK18sRG7g{7XjK9F!5M( zX2r<JXe7H^XIRS$#Tk4PnsVOrT#OEHq5R}ltxzyW?xG>~5~;{@g$*J6jZ~1pU0oqs z*;RXh3q@)mQITq&FnP~=1bPGJZgQ&mutY+LNOM7%S?i(JSwX%5xlc{f*RAOG9P^S2 zYrMW$*&A%>Kb+bd6K*x=%xdKtx+24>rF22yf|t?jyzQ8yOx**j)@zO`8?WZLj}uC3 zgeiktIqJyuPxPf41<FcDKTT8mFOR~nCAOc+aM~Oibim=q?4J1|oIR{aBKjnIted}U z>zLR=HzN(3dvhM$2y^xBs1Ku&IA+O(Z!#bm5Pk}YqEG+eA4J+YBH?j)_i<C0A0E*m zftHu5i#4YL%EzNhNe&y~=Oty5$-E>M;37*9I8CA()Y9^@V)vL(5OOB${re3O6H5Zk zFQ52jeVMNrX3?-{@T3hpY~ln_1-Yr!Q{hGoR}p^NuJ4#Q>D%b@&h1uEdiHtIcehG# zFBu2d6>FDxr=$s*KDNjur9senalcJkzje##u+_oMkf*_?vNlfy1P~`zi}#-F@%2iO zbT02caqRuMJJ+v&vs=^wnr5GS)o^Gx&w4$!*d=LwNgA{Ash;P(OYMBG^2y4tFR91z ze7H4^d!DNJHf6^zF^~Rm4X5ZSA0M&2>x;ut@uK|v)ZPb4J<|j6ubAZ}j(XO=6hJ25 zu(_!|x_I!?+X!AoVP2|0=fqu$!wcc$ZY*a=KX~O99UfRJmWGTw-D=%=x&itYInNSc z3vN_ROtv-TRQNoPE=UT!xs!j(xx+;Y@}&2L56>RE^Z5*=GxYQOLhcJ8jT&<$)&R4Y zuzj!Y?D=hz&CnHpHpHdJb&O^u&}LQsRaMNX5sS|!PbY;x@H|qBQ{hgdu(xiEXLJQ$ z;D&{YnBuX?YwL?dEz7&*+c(S}UMW`VXUDs2f06ej@@#vehM*Bk!r4gLPD@8M{=8xP zh#b;a&K~4O&OKxiY4d)iI9}rBy>Fj;I`0{j<LPfjS4Wbs*d6ac9H)uj<i*kPSB>Q` z5+|p6Q7v;591+K8?5xB`etWXS=t{rhM?$q=hJ2i5n8LwPT9a=*nZo!kGQd(IgYve9 z$!2{xQ+~#=NH$OR<{g3rJcZhegitJ#cyARiCg&wS4GGEXf^hl0Y|RJh94+SzZj3QM z>LQ*wRtv>ij>*_(^b@3QV#taQY*{{>#EYNl>NG$^#(+=Y6!rE*>l;QdfX<}GFgPDH zooG}E5U=26?*2^CDq=?x{iH`}NY<Zj1$HteVKhX&@Ll=9p%aN6CyM#T9+Yf%?uJZ- zZ`v4LIY9QlC%ld8VFI3vw#uz|Xa`&H5+BWp^Ij~)y^O#k3Y0o7$KR#uU#MKa5aORl zXNmU=$2SytLGH*b9}*YI66kJJ=M^O;u3(?hE^(5?;c7r#@mJGNDoZZv@wnYVf=0`> zI>z6uc8pXmDMfI4jmZYIE}sq`nOj3wIC1VuG6wYcbOz}$E*B&aszTe>rJ_x3pJWWC zd4Oc<btvwdS@G5&^y+g=oi48{t?1a|a<Q)k*Bc5Nzu=36GqdT3Vh@dxUsKT_-tt(* zt7c_Wajs}=6rn%Apqr{>KJPw_RQ4)XKES5@<|_Gl*Tv$K?Cl;->w+Vg)jP{KYd0|! z8zb4=8#ei~I*EvS;pE~A)BNp*2j-sLI|;py^Z1>tgo@^B^ee{}bC!mUG1C6n?Yoyf zo25Ek3I`9>2cH%HV$*vLg-%E0)IRh{z+AdGw_RQCTD&=IJ6td-<+C9(6<#qDm(s^W zq;4#cd~GWRA9Fxb64y&cikKwhgegi^*n)U=v7k9;QQ^dmsLronKP*MPQj!cH%)ee9 zN7P(Qs7kGmAF&)bY}-z=oC2<$AE>U#N<2OvZ(N9)d&6ESsHmNLP9pj)b)-M_=vgtV z*Wvxuq+;g4;dn`PB$2j*6}4k|d36g}yHoDcfT5jJE6e<1;nAKIZJ`@qq~a4FPvR!L zhaS{&r1J2S5*@QN2IYVrMv9dRZ+WKci5*cBA8@8=Rkq&yb4D9XQydo(qDZg0&)hF) zJun=8(U2jblYK1AZSj`ez!%+yX3t8?b2DWmwNc?Eu1T2<n1#|^6g@grkuso{ejd|4 zlNguC9n9{ggH|qmSs|OJ64_ib>yXbkbdWXlGbg8>l=SmWB4pZwD#i37>W?2IY=@j| zoo?9)>u*OBy3#xMpBa@s6z<entz)@05zz2XZ11f6vuESd+ofe>sfT@b$MHo6j8&KO zzcJsxe}tW|i>{`z-UE6>7vU;CWM!}Kh?j4Q<f=bN?hHvBjCveZ$a>vA!wRjj{DuK9 zQn+9=vg_WPmaMTSZ=K_x8%~9CoU!+c+x*a2?6Ty{$<0m5HG9|8*?FD(sB?59V^j1Q zJFzb*`uB}Y@L6_6HW`In2c23rsxQq<CXja!+H4#NXnV`Ixji==dhXHe$9Gk8P}1;` zyF&O>1d<=G*A#n4ohr|AarM?eaNX23QaGyoK)J$kaYI}YQ(_m+T-vZTfIFw2n$*F4 z_?D1+k;oe=TiHso1yak3wLV9>umhg$ZUqM(r#Fv%nR;y88eXD|ERz`>Dt<&1{<%7M z)#_fM<<}|iC*PnqH=A=&y;i-d`}EYjCzSTFfg%^j)J$#N3pv{-6&@tfbwpic8_&wT zWFcp%D&WKoSKK)yl|^pzrc97-AyMY2gf^bash*wMT6tc}RW?nL5#=wtMkI8O<0}RH zX6lX+YRL<J6g7|>As4vyP}UTi#*0ETA%kq(6uYIO=!P)fh>HSrhfbOd7Lh5$A-x$D zS0+e5I}S08nsXcYrF1K@lFXeq;dMf{%1$rnkeaxZ9LnAC5Wm`u>^^(e93|MT^*JRW zBQPiWQQnCU+Sv>Eq=NW4?kZo+xQgBV{irIBuk+e%t3C~QSfMEpzf*cQp>R#R-<$tI z6Aq2(b-FGZRGTZ?I0u6)ZVtkH!2b2oU7I6HA2}{4?QGOb6Yxn;Ha0e9*zFz7xM<>b zIsEwC=6i&KNWAsVZW0*U+o1<`I}41a=V>{%qq-T#V(HB`Nn78j=dBFLze)>%Tp8a6 z!ss;Xrffc+P)qgdktU`Qdw#+L70gcPX!dRVS<A`z0I(-^gY^lc7J^$XE#-=8VuB8` z-I&S~NuTV4((&`#-qX${I!#nREw`NZd`-kjyUKAzW-_x`^bN7rL&LEC+(-52U51^t z*QYvN7^hIi;!*7ZiW{dyo%+^>c9zUfpFLY$>};?(#yO!B;PH5()6Yd@^aCjmdJJXQ z&Tv)vYRu(;!QO3Zo(b0FW?GeH8l0=RMXxe+<!}ztiwPuLY1)~f5|UPMw+d)~m)u1| z_GJr~SuR40c)K|9?y!f4cxKM9RczQHyag^*t|ODq=3mn4LIvEq9>#oLYH^cN(bAIi z5=(eReiFSq()5^M?0$Q=vGM3DW${5fD5>zUv({GYj8CU>c$5Dfr#mqnAMc!V*r?!d z5?P9<^u*tm61sCnoZPCsS@zgrOmqy_6+)vX`KQtEJ6_*^ch2cbpib$d)x&v{gQJ>G z+p6~%{WwIQvHEIfw8T|P%o4D&>)e~?Dd_9>S9j~~eB>S=bc44=U~6pi)nPspbHbE~ z;pH`si)yrA8|%|C2+YkAC~IO)qH&1GPf>BX_hBS`Prh-trtZDH_tDV9y7X*(xM|ii z8-}%P2fsm!jJAmYjp0^o``{-=*OQ2RJ>Mw4`vVl$3C^(T@#k5fYfvHW%&hzsB>~m? zcoTEx6~(zjX{q`HnfXS362r-4Xl4cSDig7=#e3qn@cggbh$2!u7A=W0nNrPg4OOx@ ztAPnkNK5m6WZd;RS#&4yRy5Ic-c81gyk?1JqRjQoVt@+ZR{u~Ja7a95DcxPkX8T#| zowNruC-PRRXvL578+F{*de*9HlRJ{dg!8oj8Nr)d2g)x<nj*h?5pPkA@9yI8KHlv? z79+GzOVegxW|%h%z7*0zJI;e0gatC~tvud5{FJEPTGf#|f{L&43up}HE*w50sJuNL z&gS*9QL~a_*xyuSwDQ??VAM=Lr+acEC*|71tEGW&7-=1&CNrTo!#-ypcJzoAv)N8% zr`1P3N_^fCo~Eb3wgmcxt%pvC=r^#@->fDf;ca!1ZorGu;Zl(2=p@YB<isz=d5j<8 zK15UN#lN;25*YZ7qNjO*aOpyQH2P)rta3qET``R!RTmZN@__>Ky4TO+++|3!PqfEf zuZ?e1qIo|O-)UTCW{a=pkhHVoZnJoZ(mB`TGG$oNvdhky^BX<VIgd)!(2tU;bq)+J z%*s&JfIZXPJq;C&cOK6qwO1)cuLU8DaCYm?s0W{#ud6f0ExHvozD@KYhGJ|$%I9d= zQ|rt4R6Z6iRuXoRPA77lw;p6S&iOTWC6Ilw!@Ki>tLmP7-Xn$^Ho(z^M?7uYVRPO` ziiq4zXLQPID4oED?vgax$=8Qtd%nN0dv%eBQJ0iWb*npwtevq?3r#t=QqZ}+&~G~c zJw8F4_PR=-BE7XI;?gxo)d&R314ELjPdiR{2)Yv%l(<c7yj90X2Tr{*$c>KLyQ=KA zfFT;B-CRrzxXF3rMu$<hw}{f&i$r7x$Cmw1JYd{xqLm&b7tl>jN^w`D%~5&ZpT2DC z-m<owXECv<lI^lo>=b;qc-KmB>-4)(9|oXQyAp78aNXXowy7@EX6EBtXWrNh-m9`2 zgR-wpITQvNmhgy8tk#H&+;>czFDN6*o$RWamS~R)aWXcYaPlwN;l+(FJvVn=a?CwG zrI4#WHIeJ4=7;Mar`O4CPKSQ+tv_e;^ig>-DYbypr(N-^PCYN^am5vxR5`_^+}c|* z23Khx2}AFRST49T!q)ALMCanpp(?Z=F0?h5d}+CpuDYw0>50#wWxw*3@h}UCK{m?p zGV`6MEF1{@wDIf2@9>6nUm@HJDY(%FILi3rTYO{HNQt`=DnqW#3ph&!WGY*mF7GyP zMr6h(swR?fz4`Q(xbK*vc9o(0)zAKR4%dn@GfKrBspNNSM)jb)4fWFKDcg0N)NG<w z_m;(SWlUOqBS}d;0hEoN>$uXX4te}v${w9|*KiTCnc{vOggmN@OF(do#vdPf;-Ztr z6+9JUPxXQDuTyJv)HvyNG3JP#bIK)lNQUalucc^`F=mmI?^#c{#RMAQ3re&0sNXW< z<9btT$dw(}Enq-9dm>=asY$MS`fWr&_tgCxYSqKUBCBDil3mZ-&T(%v+62zpW?$Y0 z325`1sN*tq2e%I?IBex#LzB~GIQHUsMn(jrVG!3G#prf!*zB1*ugy-k##Da_Md;qV z(n8Bh>6-UiLyi~+7YactBb?h2lFv#hj6F%HtEJ4e%~~>NR><jb)>xH=Hs=TXr#H6r zK6T7$gkSINcZ?-SSboyrP1>~S>%9Atjo<>Ve|2Kpxt=Td!$z3|_}X=^&bF0%#@%%Y zL}<(M+~yA_bL9r!WVBqxcM72Q3>UhQZ9cj^8b1}2ERK8~Nhx{>Z)(7zg0{kk?EO>I zuhXP*xVs0-IH4a?lzp`vE*(QqE`J{M>_aHy7F7hwUNJi7`=0mExpU{-SBWT~SHd87 zphxO~$=i=^n!RPY5hL$^lk>=zTV8D$+eM3-*;Szq)n}62avNVzU))^2P<B6J;kK=$ zsVP1FVJG`zj_2Y9gv4X_h!M0NLMHm#x9^FhH{Q;PTE3S+uI_BJO^<iJq~!JiaZ$!Q zdpMd18kVB%I&R?9RP%DG+VYL#fj9oyoiS{P#5h(-N!`z7=+`P7(zFy*5+iJ%?o-lI zlTtT_<2zYfyF1~_agF1ym<|zko-NToBle`_8%`wO)sOyjod+~#gvKl{%vJe4@CFOY zmQ|xtod?o%ebm?M>zhg^{ce})WoLMt$2Svwj1DF)ACAW(E*-OU8`O_xma(?xPZ`b_ zMb&jC^W`$$aL9bClS{JhC8f-Qz*jta(Y(sHL?PnR76^J}z<R6?A)VTq^AzEE%)N!N zG~T1_P=+?gGL6}8G1D89!xn5bewn;_<Gh@wPsdWb_mnW#NF^i^EPY}et^Aftd(}8e z%Sh#TyI`fX%C1!nqS@eMwW(W!f-Qz|sq5k1tR8D*es$#S+<LOFU%%QA$9Ec$j?a-E zRV`WexwhW_9x=c}#J!78#zB2rr+Bw?QPe?YIT!JMy8TR$;|B?4Rs?<!GBWW-+<>rU zxo06i|G5Ny<g<^37d^zunP_lFYFPr0m8Nkyt`S9_FMUs-XUZfrHFzv`e$-jY`><qd z28-O)tEBc3CF|i_cuTX7R0`1HRX4J4@~n2-%y2y_a&zqYe5RhFaJhreEICe>w;l8) zuixs{HdJL}vnY`rDeR(L$1F#)TA-Kj5{IUdQsr+`u}<{vyd**T8W5Km8R7=Kc(d@l z?n?8f_-@8#%V-7XZo;ZL-eW8C019V&v4U;9EUGM519ZmSZb}x7z_)MTy84M_<jKZg zXd{dsC3Y<##vQB1E5?bQZMJx&{Z&bFg(S9Fu7e&?5ghu>m@ku$_ih{hbay)AG}(6G zX4}{WK@amOh6J!o-Cs*ao9gE)8-0WGV4_j>O9LWNv#@6`!ZPfu?pf0wOdAj3f4$YM zO-;>j_WJT&V(l5qcLLUs_t#`NC%kISOP#|-e{bpl)9a_v3;3l{PehkDTMuSx(v;1u zv?z(4R0^{=eY@CkF68-v(-ShI!#H=edfI7Fs<=odlGxafaS<XrA6{smKFv8D-)fLR z7}fd}(M1KNp?F@yRa>5rcXf%Rz*O(b)Meax(DR(%`yt8pIW;<^@QVa({B07@uQeE| zeLhdtahDbvlXs-tHb0|-`SPW9uIz0#^!5@liH~iGh1Z@?8a7q(D!q7X$)$HsRDMcP zeWEGUQ0^VCTD*etW~4bY@5`j%cT%)n=I*nznmkjI%wjyG2Qj0<6N~Ow5*oA5;t;!a z6DIAdSyNxY=^@)8r{i@hw3%r>Uq~;ym#}(|pL~9JIObn-p(#ElbeimR(e9`E2zoxf z%B;M1$G6?p;)$dbF5L!<>^RHE4lLl-zjO@~cBM!gD!+}9BpAvnm32qmTmB^N+GT=q z#qj1uxvDWA5X58N#XJk8S$-4jwgbI!&}fj*c#vGYpi#SOj)U~bOCmps=#EP6Hy6W$ z?&MzlR{aQF#E{%PmBXh^9xWGep1Yn_omVczvR0-5m3hyv&R3xHh&B&Bt-5_!rft^v z@qAH<7wO9$pQd!!KQksj++t#Ckc>|Ucg{H@WR3$QTThDONY-aR`vx^`lcAz5)U2Q} zZ&5X=c-)2_(Qw*XFB1a$i#W@}IFIUZ_~VpIK-f#xskr!$hM8^TL{F<KPX^vpJ0^)J zzbOSp+4GmE*jxj8H=lTP+AbECT;+>&SiC2QD2a4SmX7Je={6p!R(vnRfA?GLGf1_s zR)@dH#^dXmcK6T<Il3IdgQsKtIen#tQntN})hxMUF*8+XiQPyj&#B{K(>6~pSxKgH z^zy0v3Qk9N(&OYW{H*v!66K!~4Q8--NyMvH1<=MkZ?0|qO3s*clj76$*pHVJ3Yn7Q z`w7U%I5=4&&3A(7bu;zEk&C<B`P-xq5_mtW5Zs9_A68(G#_=37KY=r{#5BKPZg|eE zej(ORBH7qjbj}&G)e<4<(9-H-Bt8_uMBB8wm~*#SPKcJ+mFUqS=&jwTP<hB>ly4p> zHp7XO!?z@n*X6C0PQ_tjdFlENfxaDqK-b`;VK7_E?#0&gsc+edBxq+#=McS4=kAV_ zx&?~!G6n?&F)=fXO)q8Ri@m3JG`RhO?#=u&V&^D1C48}i$IhUwyE{4#`f*UxolF)v z)RT~saG&HDX|^k?PQmQG>qjg$WtcUaYRGezZc3EgV#B2%wPT~A@JE+BV)R*d#grz* zuW1_H$~WrVc>er(c<IIM<s4bzopFovlnC5(O`F_fcPx7!1ROhZMA3gj0ar@lG-cHN zi{csVP?F-oPdDxs1%-G>k}+xUk94>+Vd8~}FioFNL%&@eHJ3QUMuc<9qLSCffSK77 zCom}NfZ>dxF57GlU)Aw-lIPM4ts8~8w@gPi@}j>fuy<VOxbX<nQpSo|tap5t4R(_f z(4R?E=}20{+3Px_pZb_`;<GV1($yXeT*D*QId;tFRw!-RjP6Zm(ra6`^F3}WPQG)D z_-bgr&*ZnCtP45l9C%2J!?dhkjT*&JpH#?mYM5@#y&oGtr$SwtC?PL@N?P|@&)H#I z+!1+Kf1eEz61)>0qr}kTVH_mhSyZ<0Ty&JW;!S(L_E7j?4z`zmql^wxS;TCw(VqBy zC5UJGmCK{3qx>B0*YW&B>{^u-6o`cldxSh9sLQOgA3Yk$=%4xg@#NJqz0A@w51**S z{E#DNA0?y8x%U#=u9zW{Bk@&tcV4GVMI>h;Bx-`4ju(9(@-g*r!k0XQyh5$Z=+lks z*`6?Ph^SSYM&ld%R7p|+lv>i4?Lf{b>^>`&hJNy5#Yq7%{c@xDaMNYn5jPHr^O+w{ zHeUq0vd_3gHJUpqr~NL=$v4KHf6Ru9tTDtn&5TcsOu!JyxstF@V;&8?CMFhnsL8vU zT+&?)?nDcheNmTmh;n(c<EVZ2U0Z#3je{FGPn&t#IR1^}cPI{gI>%HK-Mqq9ntfN@ zYU#$O2c09fm0Wntmt-seAv5JudE^yRgJ*<Hj(1WB1Vd)`l8Y-Q+@*XDbz<`LzH$@} z`X`HdZ(2xSP&zlW!sSx4H9bq-QignmIEg&S06hw&Xl1N=_;t|h*ok%<>R0W|!t64^ z2z0-NCW4X2<P?ssR>+bp#jZw}<9N(iBDyp3*>&`c&Z_+$y~VU2a(U(+u@=IaWkl_6 z1aZ%lCiG+R<xMSBACCK(J~xS}awO%M&`xcdh;Zn2TDWQK43N|Gfc}Too#Vkz=V)jy zLBF3WyXkVw&Q3go+l8dpqG$A0^y&-C9BKrh=eyE!QuvhNx2>s2Ag8T8G;*Bhgv`|} zci)C$U0=Z~Nl&db5ofb5;bcTt=;B6gh<k=o@2+^#AbD|kRTEC62Rh;=iyNOOF6{O8 z=1SCOkqg5a(xMO}RBCy1;1-K+<e0j(gxrzwrxFvks8a;gp)-6^tLMsJxxPLcrJ5Au zkGov0=i=e&GdyGCe#F!%K3pt^ihl~SuCpO;&bYeMVMjKE4Qk!stP9&N6|t+24()O1 z85-ss3h#K&in6mSHQE)9jZrgk$ETM(dzu$x!KULHi0_Hd^ilpP!ObgpBfy(?mcq>C z)abDT7cD%Q9UCel?{P}tQ?R7eQBWbu)*PXSS(f4?sCpaW>fuJYTq!@v)PehClw1~Z zJz%edRru^A2en4334^%Oc4|_h<u0mSxllPcSnnM9<N2~qkfOcr(R5SY#gzwLoQHbI ze)41hqo_S<p~Cx6IOV<j>MjZ=m6Yl|Q7BZ)IKzm#snU^$?gZ-7MN(9{OR~xc96w2+ z;OCU{V=KeQ-jiRiCZ%*F=5d%@ByKYlj*bCOBS>X&ujIcre(+u%$!^fiqXwWSA`8Ts z=ctg2o3q?9J>OG&uX<$=|NMJ00!C^Fi}iHR&yJns7u6vfyMQ>aA%?pMdg(Cq)4{Q- zL5T);N708zrv)_S>KoiED`P48!%L1pJN4&{q@SwC$XanVlW?ArxUz?jY|1ULau7&A z9g*VAB&hEH%CIF@-c+K~$%U)CNp_yVv-*0X=cE)b4t~Vjhyz|3FFT79GjT2*H1@x% zItKmRDx3DaX<u(ki)-iQgxRs#04QYQ<r#U?C3y7h6~wM>bp~RR>>!<(Nl&Mg&%yjS z<>BI9O&&aQeq#PlpPt&4Dg}`}UL^3AB}|^dIpeC6FY+8wiF+1xN{$i%^0$`0iBnS5 z^0!hTO42)$8kcBOp_f(0UeERLVx&~UL-v>)H4qR)jNQ$C^0uEW{>oKF5!)p(o7Hjo z!}f=r4?CLlxmh}e^=-Y-SocD+QzOWW$0(W#87>)qs~jdfb-GCCl(4W`s@@(BP3oa@ z?Ie_J>|PWIcQUeb&W%i(XOMJ+hu<Tf&<ZJ)l5i?q4myX29$Sv2W{xM2^J?_OZ4f_7 zS}?G7rWIG?6S2vBU0Tq=#=2BY`EC43E&;(VkLpJMk*YT((Zxd&_$BZwfRDFv6LxjU ziZFKWnGI&f$FyEW;6!EJ!=-E@JsZk<w|pSl%j+}Mt029bVKFLKpE3ywlGRvi9lcc= zbGC^raFsxs1yM{aPe*tk|1L6rZz2m<T8L_dx%2dAR$^qW3`wk~PF_jatg;IyC63Db zArtR7eQL!)nUOkkBLnC?GM|YE7#AE=S6Zv86~s`BF(;RgeO$a6{T3nV*5;4FVROfo z#JBclqGaQ!TBXFZIm*HDQPS!P7c+rhWfENy!EzkZm>5|{$$9jNaH^}U5LMufJ+J2M zV8oL*+MK%rno(3~(_GJ-JZ`#d@DotGR#&K`7k?e7e53t2!s%7*cn|$)G$#s53>%3F zcj<E2jFCBuQ^Wd>xGEs>hK33+w-__CS~6J{yR7Wp>yqaT$f_uCDU5NRa338(9*#D} zXL>-$6pOEo4%2#((nW<VwN8KigpOj@HHpz^lc=hY;DD=V?jaw)s+Cl&5T5c0D+y}K zUD2J5H}m}^CF;vD(r0m`FH=w+K6+I9l4DOs?~I|LjS|i<y~f8@m2+}(a<Rv345XP_ zbYnl_Gd;wWt|Oob<s?3JhKUNNMtG+@6~lFn0jZl!o`BIir;_-Z*`0?C;ce;BsYl44 zwh?xZ{4--Fxyyr_ZwxP7+`MwNHPeUMHuEyvE)r^&Jc8IlP8T%z`pU=11{7Z`RE~7? zP>R1sQh=bncaQlz59PP9F%drmdXwn`JA$uI5>eJvsN1Q7)=0s@H)H48Y{|*hG^|T& z)Y~ZWm$~uSr^0%+BQZ2w#CFk?Hzb3HQGHi$@#t;q^#jg_r`cVDJ#3Hap?TjDZ`HV$ zc|4q$no?G{a^*_gOFTFAi|08G`SNAzjs*EtIuWpJAvCE8h)?d8PgOqc!UQ~Cuhw!B z?$j~aT*G&bq`kNK_`RPoLpe_NDaqjV_4Q!raT;{u_VYb=;l)q%0Jx^B?tE}+{o<yk zt2VBIC_1J5u&&h8z3t7p3+yhXt~0lKd$%$#-#e&1&eU@7AR#NWyGF~*)0wCa>4SLB z*AVD~l{pCjYCG@%$PAbuL2}{9)vcUV-TR8~I@~^E<Jzddp4&eu#_7~(l6|qRzAovC zKf{^Cgp^9>od=~GgJ%iOzxLTfJM;BAEIfk%h%D3TO;VgcflOucG1<H9f80_+O|47# z{#<&yk>ET2vtb;b7(72UWvLfNk8~fqs-8h+Jwuu@y9OtKvhoIp^{q}ZoAqN$9u^l( zN31T^PDVvIfQMsAwDd~x@kK>N-X`$@hmYMGU?8AZ-@5+k4PIei%yU=E674c`c6*X2 zCka_X+&OOKx#_DpMWYoy%?ei)&(t(EEk0xmbt@6}MjY4cNO%<0Mxob|U=Zq@M~oPL z&l`FPA)STKL{IhlK&Q;omh6*DX3KeZMy!NqoS4y8`rK)#iHVz?f`Uh+8)bbM4hSFE zIi;)a<mj6tnzr#!@rHjIq}MidErw6`Y61_oD3o$aMivbWv{p(V4-F3y=4BTa_DGMT zR!_YrL+?*`jY?0~i{uXZb0t<p^kpX0H(4tTL0j|*-Gr7xnTi{w!!ZbglAN?ARp&_s zf-=JoLvL}p$9o*d4(3MN2S^5xkvW9hFZgQXPSY`+&@JG5yk1$3Yw|k4*+a~O@DSar zke7VC>}SqE#>J`d3)Gb~xa2tt!OuGd4J1l}=B~uf3*aLC-rwonI#gpa#Ztw6CbB$D z8q%t`zR=LVx}>DlS06u4mr9MM;i&a+=kI7df03HQ*D}nFqJIiC=@{iXia_|XMGYfJ za2g2?p4F$2JRTkvHgJJiOpKM8kB^;)r)juUd0HwEudv|Lrjvy7s;yllazvP5p(T~r z@gl~qEZjh3hV*s-^qZ^Op$c(vRdF0Fo9lwoBYe_6?taOR(8DY)76sr2Y+SNO(6=NH z+0sD0I_Fj(x=p5+?|0!u#`}{>;))!xyqC_OKQCHkprD|r*w{9=o=JG{lnr&y{9~U% zv)s<Et}aTE;#QMPfrv|XR11#}8&LPs<lPRNX-q~PHIs5EzF^WV1C7!}A~yUE3YAi_ z0dFWjTmm<@b;pw;2t_CbS+yS8@fDk=g#6ridNfnj;;$uV3L7OmKYZK2V3j}3roeb@ z%c=3c%*k2z?iq_7`a|0RgO?F0CmGDIWhf4uabZ+{ERs9wVBxiN1a0OH$?gR5I#Qy` zI+t*<SS>3$U7}*};TP}udyd6|pJlEck);hI&yF4`$g5^pEVhsuy)0pCwHe;RJwHhE z1;6F9TM6TVoag<o-K(#Z&F$_5<9ZF%o9;SYUZ!JxGC=!c$qnK~8};p&FCh9-_pHPk zp9vtKkGzbMbeg2DJAxBB;DtyRBIs>)(BJ>}K0-o5M?^)%L?t97bT3OwTU?fr36PPJ z3XqbJ2#^wo2rA)Yxy!NvmoHzokdTnng|CP2`+pDBf38_x{)(TGq0zj%iyQEAa|dpY zj=<L18kid!1B3hb!F?Saa92wU=xJ*MeLX$wdHDbEb>8mo0KV_R1O0ipp8wq1|J@Zg zZm4Fsxw>tKy?X~jf`h?Je}C}I%j-A%Fm9dOw}0R_F)#o&78bz4))wN|4fs8K2Hpe) zg4Y27z|p~R8?N{N4(0DPDJm-6cXDt-eT<F<aUVW_@Q@G?{PHCT@b$&wcX4n4kF2bI z$X`!e2f`1_UkBSCaKFI+cec03;(zY#4FdiAz}wfaLFn7J;O(0?z`@=g1-J8i>;Jnm zckk*Ihd^z>xD(^zz=z04tn6X@Fos|VL&=vfpu4jZG}JAC`kHxAQM&VkiVNpKBXqvI zs|%EVDF*K#tp3k^v3<9XAC?DJCQw~>@7^o^-y!~f_l+AjX&*m&JP+$hba*&`We;PA z<rNbA7L*p3fUb@y2-^-YH|k$zXZSS0LKi>GN|!LjN|!v(N}oK>LYFwjLK_F2OYPxe zX`D8Du#U+}+lF|Zg6@ZT3C7k3V~-3C1yNyP*wWVa$voWtf6IrOng*?lv&%dzV;C=7 zH(bJ0UQ!DBdzXNV{opDqUD5~#L;m_{wm$Gr=p<9=77OjiZ`>?R(=K*s(9*O7%1g_z zvWKz%OkSQ|^DvJ8DG#@9-KO<)_rPL@@x%QM_d$HjN6_0l3c}tEud&c2O#TzR|Lz)A zx|BICmioznXJ|+s-#}7)0=A!j=E2+BdmhH~KjFdI+4%={7(a|XDIpOI_OF0T=d(sn zv-M#99j-tBPw?CjxNETtE?=DhJSY2q>nB*hE{mWrwN=X?Eji^k9$Z}9=l>~w3k$2_ z@A@5##SQCa2{h(vsy4tW)`XcqWBVt^*Kf}PD=!o<aY2E5)+^xLnZe(9U}wl(<6$30 z)k5u*my}?~8a&=$ih;<|(&|5sX=t9g9~~Km)%E@HnwOmi%_B>DZ1kU2{t4DUU&D8L z02n%=Kv^vsEG%sUC;xSzYqkVVv;RI`xLBHZPqTF|)_h$DMS1xkB{2~|4_?F)tXnX? zf7cI?=M9w<9}nqaJk*cL;7dUf80cRHoGhPL|BMSh7UY`*g1i%ek9!pGo*D+cT*E-< z{5TL3n+2kx3qVA88Yo<!0#=?Vu(7!Vc6W9_Wjz`gK>YA=5B$~#aGhK%otW?aunftq z4CLqJfV}K%EQP!aMg1LqD=V9ftn_pM6MTJ1(HAg0I0eq0N|^pD?C?20t`TtQ;^N<u zxcDM4bXWsfU(jF&!VXhl#0I$iaN#ep@3(W3@yoi*r43AP*A%F#sDSt=#p)Ei#=toL ziU%kmal0r#9~2iBf{L<o(9_uip4b#k?AQ5srHJqxfN}m6AIfSgSe;*9-Ns@c8Q;dr zUR3Pczr_!?1<kR;b{3n^oG}2J>g%C3u?9<-8JXLE#&2wF=2ucw1j?ZGq_VsmT94{M zYx5+ei@pE09TDLXp!skGD5)-kYqwT_w9FDfBEOT^rA6@24h7;eH-E_fW#k6Xvt0hS zb^a_TZkFbms){85g+@SYQxldN>goWD_h%m72EUz$`v|7msw&Xe(+jT3CXN4G*Z%kL z&_!r2S_f7Z)4;%f4TQ#{L3Gq6xc6`ssOzkN8=5QN+KpxK&}0o5I-$VS?04Cx=5AtT ze^F@UALD0d%w5&j-T<Q`BcQXr9kjQ$Vkt5r^2dA%?WhFvbMvsWFUR7q28|8<TU@N2 zzs>QFEvLZ#=hcTz;1;w2lCrlzdchXJVD|s>z4Upz0Yc(7z#3`?Tf$>jLTc<EW8aq- zw7yN%Rn1}X@Am<$-*R&Dhu}UiH@EaFDkuQOkp5utSJwb1hpe&v`}fO>`~$$<c?P_D zy#U^auV7_aQuAG(bIZ1W0pCBei~WC1^A>RMU5E5&6<iV-{U2k8+h(DQ8xQnFfi6h? z%?%BZZr6dj>T1}=<AU*fd3iVF=jH;KzCdHQy{!$Jb266qaqpL&E;Bzc#(&-dZZ9`L zcoG`ey;ui3yFdN~M#lHRYp8Fmz1P7bpLKB8d>O!Nz<xdd(~^s=6C-_bb+5m-7mK^P zvJ${#Y-}P8;}3ZoGM1g039>(b1_clgjSY?HziOkR6omyjJ+%X#JVk-D{4HSNu@3Tn zlKt$$9#-zK-kZ9jzysS=ASE*n_<4R`Z~v-|zdOgtR5sMoFao|pa|=AjltW}=ZKDF? zPlW86w3HNxl0kNQCWs6xoBykNyxnHObMIMD4Xur^9gtJ{U3aGE_I?N-=Ed9{1?pON zu;aq>^#*nf!@B?Q2{gX%&SPyL;R_?+49D+w&|kF+pM&h9&iri1-iGv}FfR`jL2|Y< zw=jV5r>CVuwpjv}(jh)P-BNzjeJ!<bU~%COC4uqelxzbNNX9>p+scL=EN?GDH^JQE z_W`{P4Gnla<d<)Q;Mh%I39ZHO{V>6H1XAK3tpy`5eP=--w611D>nlu;tZlIPQz3gV z{^Lh1r6eYSTdMKD&71nV<3D8F(~ZVrOo#Nx(sTXC`TZ~BQ+vPzk~`cFFh76wf%UAm zWe3|g(sC33acr>ACCx^MErUD=cP1obm~1Squ=tZ9{fUc-!4houC|!yB&0bJb8O6d# zNnC;Ue<%RYjj<V9z{nW|Q0sr1IH4<dp{|1E?HsTHKBS?cIrR5y;QoR8K<NDNf5Z>l zj*%ftAREG+3fXipS(}?<@u#Jvf`os`KN+&|6y-nuh94<B2>BOgp#3Wv%ST4x7O;J` zj@1WPj(_(VgZd&geiOiJMc?or;{?9GxpN1LpXVQp0~mkU+eMI*nhMgAlCZQd|ID;Z zti72C$vzd*A6>2J-)tTku^})!`v=a9j5XjAxB<RG`Vj)*+uZzJzWY3FZ)3210gnlI z%xpo&@TaVH8+Zh)f%827d2WUE$Jb*L<ff&8bjU8o>W|fT{ZC0s#@fm$5MSxgSa5t2 z|J(TG=k5nfOW()u+}sXGj)!#dU*oZ+c?ZOQ+5+gUzvltQJ21M3?XP!no8a5z9!SjE z0*>y>;EwtjxGMecbqKQMMv^`bf7gGg53(RWEdHfG??c{W=l{>}xQ5n>(-?oIk@u z7GW45;KdwRUfRRr4NF90^}D`p2gIbq`;%XF1bf3ze>R|gg4aH{FMPu`fw|Qj7C+2` zs^Ta(^A~#>?EFa=*Oi^t4)U|Iuo&Ue+R7R`|NHv-H59_@FSJj9*RR~{?5)3=ht-rv zL0--ph>cqMfoNtHl4;B)R>#|VcCl+3tQUXP7kdzEFrU8fH-WqFDtHFX0s0Rnf8d9C zP`UEgwjDor*)Y6zVR1rp=oe@WurRm4uD`an_I{<%UZoVapP~H$ytZ99m->tSz<;_Q z+s-}hF|6$O8R+grgW=(Ake2sdrm$?Q8h1cL`wq0<!hlUQ229TE0a(XEAiaUHTR)k{ z)}^OC0kk#7e!&m(Aa!Zzm-z_Zk3BM*-YbW&6~lHKMDTY517ocHbNjZIAnb>N_c<_+ z)lli?9P!H<Ad4Kvwi6$_ybm2)W_?-(sI~7pGcvIU-hEgH0TG*6{eX33pWt<?xOy8b zE<^KC@WOAHVch$qdE*-pIP=Ha46VImAHw=TCA<fNa95U<L4L1Npr)pdwLjrCI5y_v zd_82-)kC&_Bec(f`eK`#wPO#~BN6^VaO?UvZ2eEHr+!(7Uk5Jy!cSV#GIoA}*C%+4 zmQ`$mnwrgDu7MA7vsQujtv@jDW8W_&MgHi6O9FK>wXn?w$+ZfSFN_h!3*+AZI6J%e zHNkr>$UbdrYy@r4UPoIq6x#>;vfr=U#%%Hj56*VezhHxHqxQC6@rH#gfYsIC$8}57 zCV<!V{d#{c<t4w*N9+vQE5U&SpaGI?-Pf<!vI(-EVZ8g;;S$mzTF8gD-O<tlVCsZy z=-SG!d)%y@dvX%rb?4{$EsZB3f7uqaKmKDs12ZxK?Qdfu{}|u!IoNJ`9XJnv{p~Y8 zwhgRIejUSbJNx)0FV)Z1LGo^a_P;Q}a)ojJjD7#RpPzpQjJpe>ZfLL21MN9|pN36} z3JwBTCx6Bdf7jC*13n(JzhHvr7;Cd%d4ey1=dI$xwO_8?KUjmt54^Ydxqf&Iv(SAU zPD^S9ZOzS~1KKyj`xkg04CCC#{O7W$pa|6qT?11e<m-k@IqA@8SROyuzyJM_#T4j( z^yOz8)Wv=Vz;gZh1M}tPFaxG0|5(F+`9D-a*t_rJT2u8KILleQ?(5wJ+96$larZ)4 z`g?l7m!dC!>;HjyadUIO-`Cv(`n$Wa*AMsi1DM2w;+OX^|5a&aItf0duYhG}eu3Ay ztjyJ);bFfI4r~Dzh=;ws-`DAxnH}ss4|K+X^rfCXEwvU@4-`v)bpR$9JG}pb@%>rm ze?ATmk0>7O>jN+i4-A0u(NV|;(+^~ji7S7F{pWMKnqyELU=n!zwAcKZk*M%Rkdp9y z4xXIc1{rB9z~RyKkG@rw>)2ISu3mz%!<b>cfpxmKvkSnu{*3kSjtlY&pdWGcV{wlR z4uYxiaWFeI1yofc=YGcfci-W;(c5k2H*$J1jh#2)dHB!wUPcz993GdUU|$K`HjI5= zfAaG3ewi=-4)^|fZ*L#ks;^Z)co-cX#^Rr!n+2Zk(GwasdiVa^{{QCq()pzE&uML# z@v$)g%L|q{JZ|B#qP%<_#<P#@pO(*_J)^CuuEFxKuSfH<vyhH2gSNJ|O>NES+5Zh@ z_+BZ|%tbq!yt#fzSEr!<g=G)xP6vb=#$NUH>pYC(pJM*=b-up7v=!wQ^P@vU*l{oe zwXwJWuSct3ZEX$I)zz=sSjJ2!$(3&YQ(kT;v~EjYikb9%S}-#L)w?i14`!#Q!T7gt zSiR|m<_?&kd43*l|Ie8Io8y#}l;UX!J3I#9_TWB%@k1$(U}IwgD%T)8p>`$YZQ8^= zoyaj&m6UlIWb(>oiIi1o@wmm?>ha^&=5gPW6Dk%42L^W6VE!RmURwH&AF6j>cfLXM zMM`qYKOU?9l%F@R-`t1dpQxq9#ozF6Zf=6Dtu3$(IU9DN&F>yG;bZ=_D8MBKI)=}~ z|3{<IU}Js#SNxFtVf|@uZ9~EB{8LQ-&2^A$GN5POY{RmLGHI~#|1*9p=6{GEmd7MC znZot{H+cS=d-U}UXrrT}{o2~v=VASUWeUq5j!*m(`ESBHw}t|3t!?vgJ#c;h4UYed zdkhVY1!H1j{7Oqp8#+5X$2K=$djeWx|0RF8gpXl9;s3+e!Pmq0{a>{I|K~aYa76&H z(giRGgg9KH5eRa)96=!P;Ib6TAA(DmNtcx_=rZWSm9Aa5Wc;IqZi8-I=~{+MqCd(J z_!w`cYriaok8xJI_Dfgz7_rjz|8-dkH~SL~?D0=H|IEiee}CqCUmpAN`5~{7f5~rO zp3sequpIa0jWw!Px;P;iOb{U<`oGH4f^w|XRFsswt|_aeUQ<#kzA7(YEH5jIEw3pn z7hhMo2Ax;&g0F*`{XhALh+Lx8*3!;+@$A|58z^4@&dqVOvjY|;Cg8!{yVyLW`%pfW zsi7gTv$28pEgsms8BaI2ZOvP^GvNFGTOjIc>UIJC{@bt*6V8c(^P#@CZx3Lf;D@Ma z5C!GFz$JVP<AU?I{GUI^<_^KR4L;u9+t;tF+Wk*4=s(cM<{H2;emGta=hRe`H9~&K zZ##B24Fl59W53xMK4(Cb&cTqIFU<F~{e|ZYIxZT{4{E^X&cK+lxh+s>Xkhq{*IjE% zn}+?|7&zadsGthkr?$_YIT>5POdH$G$y~MeN1jFx20mt`Pitp59`uTt_JbFc|1ui( z7Ty<D|HyfX3=IQNzEHz|k^|&>Du&yJDePSc#LK`AKTlLS7fb8TU-{1dd=9>ji6$b0 zi6-0}d46QAq-Y$(L`D6;VQy;vw{m!J|AAc?l+yvr4bH1bP8dLOFeUurFZy$P@Ufox zBDia^@JsFnC)3we`eVNLxmX&8vNPwgesDO)3-;&hKX~|?KFG*iri~1X*oJe!(jmWj zZcg*+Ddvj5jCcKv;ex<0uz!vM<#lLa?6CSv4h%PI`!3xvKYb|9IaE<P1^ITeKn@g3 zi;MlZ4Y&7mUpUx1WWc!zaGbxfu5*u@J#*>jb_96Fzy<zkh$f*p_#BXuS_I-^i$Kq8 z5mYyAL9@;du<}^@MF#Nw-!VMDC4S-CT1Q*|cV8UjFLHKr{>3KANK4;_<7ahHj8*M= z?C{TR!{5(v3;^VxatS0Pmw=5o3bHG9AfNvhcwo8si+^yx4!AFvXu=Hqyw|Yye+%S? zD$FnV;VXG$^Vkp0tAX<aO1@P8l1~Erua)ISfXdBjpsNqX(6v^8vib^;ky`@VhO3bO z9t}_%JHXaw?cc^rV4Z|=+=e^a#z7n8JAlc=*hB&D1K;P+kF_8lE1XlJuNU`2-{83N z*tcyk3i%&h0@tx|ztPcM$Tr%6?2TRU<oP-jlidamFHk^Pb?Ps9-<JVAE|_T|9;L)D zVsj1PSTU5F`3P<wirJ$e-!$Z>&fVkVF8q=22K!53f8dLE-`fs^{Ga=uf{Ja(2f6_) zpjeoM<UfnOGoE<kXMBHb9rjyQK)y~_7uWZ2`<al>AC8kI#wY&bTZVmRuy4Z#iZ=&@ zZ(?JGaQmr{PZ^F8!7=D7%2Pmq_Ya@sKEHoe!gJI~rsC?x+FB?FDG&H~dZoba!*P;? z_&D$~AoNGx92}QQj9Ug16Fb;=xTD|t53|qX)du+dWeYTRK=F}GG;oCEZ|b}T9$GH} zr5jU!s|WBr3D4QEpY$`tvxl=QwtYDN?PJUbU}qcnqkSF7&j5cqI-oc_)X(0*8`xv` z&*BOOgeIV&I3F6UZ+!RpK;|_V8ruU2Q0zq?!tq!9!*ezpeR^~?r01znOvugA=@0&) zdB@)N<&XB2WJf?I<bxR=+QQ~_!Lc3GzuJN^z$S156mx)m_i(%WpN95bpz~n%Z`$tz zZ1ibSu&)@-;c|C&#<rgc#hGC|&%A?v<j}!>!u_~Zc<lF>cyZOQzB{;0IIa^7#WCTS z6|{u|Sw&k={=f`Skskr)xc>09f0suO29|#rG}f^4cXPwGANwH|1<#Gp{QG0<^PKF1 ze6~B-nEdqgE;b(m_Va&*Vi^18|31&K53#ag8yl;61I29aLh%cD&kx6D;rQBqU%>sZ ze5I%cj<M%K?YTNRWA#5M@MQxWWBHPwzsJv$yRm=0|8wY-lri6ZV*LY9{R!V=4dr#) zU}E|YnZq&00*L<?Zy`MiT>HiUbQ6j#!MwnALV36Cmd2eMaI7Defup?xcKo}#y7|>W ze*9X<5B~p9_ZDzjG~eIwMRy}2pfn;NA|PPU-3`)RlG4%*N=t*1QX(lxr_x;_NVjx1 zT<<Q3asTf7_xHJ<_<Y{cWv`i?IWu$i?94f5zO!p#8htJU;M${(+6-XBU#tywwC+K7 zfqKr@>VZDyd^m&_0c*9HMF&u@&pAbVP|(NtcfJn32N%yL>9x3=$`4)V>m4n?9AIl} zCjmZxV5qODJp$JVDoV?CZ&QCclN6dfufMC~V$6A8@YC;ES-uTmmrkKyMo*ws)w_UA ze{m<k^(G6G|MZ!I<2N||X()f3?f~W&a6P5Iy5`6D57r+Q75&3UZm1i(0Lnku7mx?- zK;M%RF4h>qn(}fsFK_)h_HzmFv0etyPwN4!XaC9vP!=gk;wow@`k?*aeP=JjU;Z}# zX=rE>x3{()4Ff(Zz(;>7$ep)+Ndxpbh6eszC#WdhhOYjCxd7J<FL?mA<K*NF8XfU- zE$Y#|n)Sed_Fd3lJp%ZTI@;Th!1};`{~7{c1U>_O!JvN^z{%}OinJYGwgKcr1h7^y z*uM|pvkw5B@Tbpz0r1xr75wB0*oK3n)AMzGC7IDvYm35Zu-<cjEpP_w`L*6(e<vp= z*Ng)`QqV6rI54=cqEPgM50`DRFrJ4#_gR82FP;22!28qN4Ll#fS_JTEZz$+*mJt55 z>+M!K2l_29{H+7fwA8eJ)c-EqQB+jaF%HxZ`c?to+sQMB^gr?qU$zfCO9*GrS5<WE zp5x;Hf8%Gs*ACzlJ1*<^pU%LXR0I0g7w6}ppdY8FyKl?MF>^^-uJ!2GdVc+_Ak}-U zD4X*wH>YZ81@Ps~1HNt0-#iN3&-Ao6|6{-Z+NQYJxM!0SlSg3vpidC=bF8ke9(Q*1 ztfeFuErkT<E(HhWE+r)v&ezv{S^~ns9^kv$0(^*I{h)7sWO(EVcni!w-tWKG`PaCi zp&@a8e*U>%46GmYhh6&e&V4a}tbu3Hw*>l`&g%#Kk8`uLM@5B21z`EV()_pa%#6(7 z`uh5gsi~=*zxoluIG7IlfHE>Nep^HQxApzMC<mQ{g91JV_cOrz0=g1Fw*ug!K$-;H z40V9(;PUW*Kp=m5T$TaPlK>r%9!M9Y57q<LcU~`W??68VA#gAO$G`Pc0Q;mUb+mOn zbTqXx)m2n#6=h|c<)oyWA1f+0YiVc{YiVdkDl0$M1giL73c!A!Yrq_t9UB>S76I&M z^6~J1T3cA0`yI5^HK0!n4S{uDTWElf4`3gMK|S2um-O}Y|H${DuW!H?{338Y9k2-# z0DCk4T_N;MO6#$cebbtqRo9NSMc<CCW&3KN-{9f9th#eQ1DFrAO<kQ`-U9nykp8JN zfPE<v78G;@+U~h;bAh>_bB~L?YX_JE0o?QN*nB$5{<B-;ty@MqLpw!zo#%Uaz&#!w z?(S8<-j4sM1K0z>6doFS6btMnDk`XgswuSsI@8}{sg<;sp)xAp0Nd@NPDYxxorIXt zlegeLr^H04pRfPhzxE+4B=j?ACs$Y0L#0I8f7rhuexLE?7=Ys+1N8lA=zX>+K>yu? zw)Gr9MWyC{=vctI{83{3#7S{s5um^3L0w(ke%z1XppYk^-u0>eBh<{O74TvF<i$Ov zSpbLo6RZAMZxg_$96^g~_JQ=@u``S`9Xr+K6X#gfob0ztmwf>CSB!%gj)FW8r+UE? z5F?-u=tTxr>ri9!EvUHk22@gN0~+&Y?;L;qPd2O8<B>gZ&sPtyuJ7yPrwPp0Ow|>Y z&_+OSGS=%p*AedkdR-bY_owIWo#S%9j9=(#MSu?czIq>OVz>T}dl|rcUSBhHjvEdR z3JwVk2{i+C;Kom%P8q1X&wVXMI<vr-dIpV1*+0j=oa_7meh0L@w9M9kweX+1?XSE9 zf74Taf%>|C-2-tq@v*UQfHeq@cW<+yDTzft`0nnsc#i1+?Me`{3kFb^1Z_)D&x}pK z=z}C+dvkIACq`ONqj|Lguv?>EzAOgtogNu)-T>?1nLl*+yqpbS-rR?VC+(lxYao3P zKb2i_VK0Ds5*R>TQeI>EhYVfzMMte`uL!V9!-Ip1^K<h(vH-dDbj|qDeiw%Y=<d!b zG%95m3SvfoU4I_~?DTh~htOpJZ!@!S0+m<(Py1X=q2q#nNN90dN}6K<fPYI(%=tmz z$!-BUK6VK08@SN3Kehul&hbT?!FGc<sv^J+1#LbP<3*?#|L<5kW8K=-l7a$YYzoiw z^z>E&><iGwIAgrob$)*ZIL84W*M)u2*>ecs_70$>b%*CzCXn_JpkGHN1N#Z=SD;#e zJ_YI;!aNtcJU!(XXrN!)9%x5LMMNe5I2jB;K94{=kfC<N9w?ij{d0-U?&<{QZUFQ3 zzI^W-mz|lv4;>ge2IkBo09W!;X9w}bAg1g#b?a7jSqrogc%C9&M!JE|SbS_;7Kn3s zpI>`$pZV(<*d7q8($%pCj29RBD7gOt4AWDGz?$!cOl<=gA#lz9Qda`~Do@Q?_CP#U zdvnVffcc>W=>zx^hMtbj6A%~SWLLhe4749C17gwM7jB;0eW2}eaByL8fOQ@MeF6h0 zONj}qP_X?Xyp20;%{}LsmXhL<Y>@V4$jZzL7zOYPlYo9{`Q+olWt+gWgY^P52GH9( z+b?YWy}i?O><3t1TgxsW=POWoiNT}t4+AG4mZ!a?bsfNMT)U)wc`hq0s{-{tQ2z?> z{kWs1G<nXe%estoXMz6DpC6#jrl)yfx9Mv(@3u64IRWhiz(;nJl$6AGN%Pk;ux^f2 zT~$>z4d}-!%gex+@%g~bsdHCFe&j!}2dWC=XS(Vw+o_2id*C`YXkYYpbsr@rCW`z@ z^Y4BG{Rmi?n>*Ru+&o_oU0z;3sjBSRN>3fwPf6-OD9Z2M93PuK0@s_twf6-;S8i)* z{S1sXpgQqK0m#cxUS6KHva)&vu2q8Tl$W~Q>35xS7tm=3`Ul2=d-wE@i2h9`U`-IC zu&_{Res10o&{sVGVe$a<SdX^0HZuT2@jtfr4C2mv03qewfFSWsLg0Ao&JP$~4+wZb zc!4Va>jCBg^VR_eSbh?qa{$5OJ%MoZLLpFIP!Gcf4l>~QQ$0*lLV_09>(C0U%`7Cu zW~|#-R_%B?_wTqlc5Rp$7cTmE#?5-UyU*G_ecCD`C4G*`1jwHUX(_3DVS$0bTbXiz zd14vLd~4_IHr3a)+f>7=%(R=Qk2v<BEVuT7=XM3y=a>hLjfgmsla-~vEFbjz#Y#!x zd#Jql;07g0_A(u1&oLck-}zx`J9q5h^nQhnwQCKep{29~`0`4i?k;X0!SaCLGZ@^< z_SCd~9>kD>`z1IZE<?q{)}S)->%gA6eW-8f=J|X;Lt4HF(g^Wi1N5_$aj^XBgoK&W zlG^ie8pNLgTX~^&uG>&ki!G>6=q|Lb`2eb@{8J}kpd8o)X=J9CjDh7p0Q0PfKx`j4 z&wxJ0xb!_JIA@Pc06tw{ZdF$MeXgLoQLq7)cXh0t2FqsyzDfqFjswuY^{HVO`V!dp zHw*ZKKs<js;E#M6zXNpw@Yl+!mvn~D?$WLuyE%5Og5{GF6OX{U@80?f`1`k^(W!fY z4-dpfK%teNj-Z!*HV5|$KO*SEzfJXJ#l^mR6D*(m?%fd`Mb8oFR|0YSAA!A2p#N!o z^I}{CalN2#(!%y)FXBb{;T31wrt|V|Qc`DblIM+p<9u|)3V^|YLfg6ltnh~eXnFl1 z;KMtB28RM`Du5r2<1UDSzi5A2;`{UV2L}cRKec$CCND7sePS>N?9bYU9s%<@IQH-F zp8|U;L0=%?0|{S+g8nb68~Gcy=1b7R{QPtNfqlr&%^i`Ksu{i<6F=7P{J=4SI>X`N zMPEQnxsp`(dS~kZaQ{=!<p(TpZ*PCExTxrhhDy~B8layBtP{imgSba401K+3P(0Ps zF$4wXl_Ogl8yc|eWpK22xCh|BK1YOSyw_I!IIXVq74T8b0CUKfBNKz{k;;nZC2&jw zbiNfkTf2Y66l7;*g>-dw%>h`Cy@iE^UC<sr2ArY5*fR5f+7_LJc?XOk7l#LM{%^-+ zKCsLI(mP%#^c^oeJVXKPKg>B37+}ILnE`>7x%}Az35RIGL!n;Z6YkKFJ(iIqqq~EF zYGbQoYobS{XRKpQMyID^rl+T4p=V&Gra{I@=8S;~<kYh?vop7_A+xr0umK~M*1!qK zZgbnp!1}h8iKBtpIVFm_cggOukTH|prC`87r642IBhxk0(K9`daRD(YOA7-q0?<4! zWph!C>u0#g`qwxa*?9_Z`cCRRf$T?|3;YQl->-9lk@Gx1=v_qr={k7zJjdVDKPLqe z{Zan1g+J(jPoTg+b$y6|3i)sRH8D5(H_YW=1)0n8x6Gvnm`lmQ#KgqG^t}gv!tBdV z{BNKC%7uR*_??aaaP{w!FA4v=0l(z>N$%&bUoQXcPkQ=`<e!8=(fTeN-%I=w`-Sj% z$;;yZN&E83CE;_Lzfk(M79jaNTu`A0ih{>Kgv%>G2!oV=Y1gl<Kfm(xB0%-BG#6OK zdH7N3W$Y*6pL{r{|C10{=C>+=vOk)8LH07?m)K9j=j}Q#0Mh)O?r(%I+w_C@Z$B>U z_(AwrYCr3^Eb~i?!S;g3KZMIGmxM1`c-hX&^WPOdFL_z~KQmlj`APUZ&t=OlhPCg- z&O7km>iSReKgYYjyLOrOe~s{E1^-Lu%MlXtU&lyu6N`T{M&4!mbpirM#s9?#=<-H= z@6x}B{&)Z`%Kjz#gH`{6@;{dSgE`0C?q5yl_y70U`Fkh-E_V6+{9xAkWBNVkIq!bT z_{9VKch|rx;BiR>;M9-UCD*=}`yTyE>^lelyG&Y|{wt9LX6*kxo#-bAF8lHyDZqg8 zdyl|z<hPXbf#uhfi;?Cc<$OH4Ncdg~jC@bHqyt3H^8t;xr1K-;M+(=EA?-5HKeid9 z^GAHQGPAS!SDgR9H5i-=?awa%m*}|!|0<am34c@;;Ll$uU$F8ojQwl$f~EgW|Frr) zGPwQ=?fyqoFXZS?qUS;firGcxzeE9s{5h!$?g4-QmehYz{?6?Sem<9x62?F!LIunx z3{epQIp7SscCe8Vfxo2NP#p*aR#{YlSHV#;Jwi*QUlzZ)`?CVAS`KYIL2#U@U?`^# zCqr<u0H6AuksxMq=7!9~qBq4*Do@~Z4Ohfz7jM%E!S7-ViJBu1@90?gnfK3~l&p?B zOI1cpn70dKxsa}TcJDi5j_Q$7JeG_*L;92(ctr$wLw+XqQ#GZq!R~j6vXcRGUD`~f zw6PvzW)66A6E9P~sHzvDNf>ThLmgm?pQA86d9EVx)Wmds(dPBtC98}DFJj+~j1Oj| zdHD~JX~JRAgXR=I$rtq6A)`OMuGCb<KA^d-lx^)bu*+8Y*^aSlBP$`+GBVoYRi|iv zqp6W`;Wlf!R&dX#H$Cg1DsiIO{U<SI7O>=H!Yt8|xi%bR+fyaB2z+wnEjaKudtC0+ zuZ*H8RFns?%*)bSbtQ<?(erjlEb!pNe=4kl#6iM&MWhjQylqICn&P)H+5#B}CR0pM z-U?Jx(SEV!-laqqjFzmsc4r7<7EUA#^R2+%7}OHs0|P#C*p&tJEgJ19TUJb=Whs=m zpSagu!(286(kc0wRtr1{g4=qm&fxjc&hiT~I%s&Kj4i%-^c^*k(CSN*MSfXfV&|e6 zx*>-cR5&HUfE$N(pkv;7*8q1N_zYo9C2mLc?Gn3<c5ck=lvd;gm&d1Y*&dlqr@6gR z=)39}vn+Q6*ByE#68!lVr29r!b0Qrd@YHu<IypN^_bFF@&9%W*I<ih}JI$Wr`7|-Y z^B&8Y_N**P7w!~)Z8f92({47$UTD0G1T|XqX)tN%dOpu58vLzTfvLOXAtcY(%eP{c z<lSL#5xxvX$E(2slJ?`Jp?@NeCKvJ;)vqBUZ%Kl*vEGGh^9%s1zW&zNWvGGZ`HY;8 zms%k9N@Uzl20ShSLn?CW{?*&w$%7hKKSM2*J#FO$949KH1HQ&t*bs@1*=DM7S-xJV z3qs|u-B5qz-5p9g!P!jhQzzFqQu<H|`E=ZU=TH$PGJWzCy8godMChG5dmiifS0^bi zgTThy(AA)r<&-Z(EMCJdFo!NF&Nj-`MOheooKId5t1>B7KY(q!)`zDuOOwGfzj(a` zbM`)0&u6QZ#*~ohYRA33wEzb$bG%Z2#=yiB@#)DKPTk|N+wabFS5d#c!jM8QwtVBW z`z`$pY4!B>%_(?HwqhQJC-K@|I*zvR72Tmr0olg9>$glaUf&5d(~H~{@-{SR-NHpz z{TPJn6pyWXWecfGfI=3TIFt$x`3cOslJz3*O*2Hi;a0S~5F;e9`&Zt>C^pkk2F0B) z)VL)0sXe9CC&Wf&iWec9>^E1(zzp$;dP!)*Et0*BiOFrUM{8jqwENCSMaRp=@4gg7 zXXcHshq{^ttmm6xmT#{{i&h3pun-n3caGZGWZG(+IG+g8J@m`E1~Ws_Du4>p8LEpE zeUB|vON*3&VE_gm0hyfbv&>4JSTJQmqU}ZkF+c9Zr$fbg3G)g&w2TN`gGiEtJcORg zia415^%^9%+UsB8D(!s`pVo?7_h8|o419~KeD;}_E=q`zlNvcC(P51A`pFO^Zr)$= zhSVx~1!n&{Yt7NJC|*Vu>a0)f-1i;pVVHyWiC>ZX;lQWBN5pkwy1AQ{dH8NE^p|jB zcV{fyrLMVPWOG*52%PQZZ{u06yM&`hz#9B2p%BQQ$f(%&F|$unTtNpPX~QPz;RA;z zXJHy7@@&NSS&jtc<}cb_F$4!ZF}m}lMv*mzP>IG*An<eU8^NA^WGb%!B{{3o`xzlD z5kYwI<IAp^QdkZ>hELQ5kj^&hKCai^7v>i@h#6iXMn{^c8vg?O2K|u}u5!x5>2a7B z9hKF+&(aJklhK!tNN{!A!)1@I)(lGXp5nAS-MS{8r%~hd=?-lpHaaXJq6ghnYsxBa zX=bQb#&CrS++ZQ0f*{4~KD|}n5B72lJRK<uqO&B$GFgvdwVhAB2Uge8;~PFPlWPms zX*`CoN8t2rXQcL9rWY*=qjNJIoa!*%2qEWk_jK90TXE{WXuF>pL&8Urv@zkkef2;r zweyQL*EnjWbN3gLvX8?($kVedpPq{%BvFI}r}Ynd``TQ0N#A`ZtJ_wJ?RamFLXW0> zfg1Sw1Upig7z{Fu1r0s*cE@6+N$CLgfgY8fWIQ4~Jd!rLhYfeURKU*Th<tlGt2_tU zp1RNcI==W8#xldJSK&=fd9fDl^9~7f9~V4b%?O1<RaPP35Eqv@*ixA_GMqgsea2)j zNKP31_N7O)ZERl=tewi)+ZSbsuWX4%&6Gq!<60hfIz71k*-#!kWRO>6j5oQWP1DRQ z^((^5LZ?VrNP5FHD{DdZ{i$l=<DFhb=)AOI(UBbiGI?@#GWPC^GtHUMkih4I;>t`D zeRR>%ueOvG<9F)$o2Jj;PL6vGUri88D^z)(d}Db&H*?cf{TAA$ke*w2jX-uUz7I4` z>$&37SJ(o!zP}0KAIKog?aO()Pz;_I-4A+2u)Bf3p05$9uxR5MfjFtYvv_+>>E;!N z+xYNkvb+TEK7XB+_R+tJxsy@u8TRIIK7lmD+QH2FL&4Orrp67+{IQNnsW2ZEf^7NF ziYgTaC~QZ-Odx$73cGM!5RZqoTaDJcd&m_L2ZwIn3#*04#sv;mu!AYcBIb0XumtbJ z3nOqnO32@ejc35hBcz2=!>J=sAVBWJ(lT9dYP<FUJ)#ef?@pva%YIIS#8cLFEBhng zq5Wr%2_P>$R!sDUD=qxo%H_MrFyJLlS11lnzBIP?b4lbHW5Y<2KcMc<%m|*7Ky5>e zzb5gG<p}xSZDI-O*z1WO#~PYCi(csnENSt4{V=}o3b`@zFpQ|=2+P{gW2wR(VjQ0_ za_|reTUFq4cz~f(@f(}}=vgoR&S!ZI5d{-Mw|Ul=I_ZY9L3q&_$b$MZl?2q|0)pb$ za2j6}Y;o%4#IHWPD$83^$$(%#Cl|&ou{we!_u@@DpORQ?|2vELDTOYrGq&0Vmj#!J zulM<HFyC>VJRIMzbR6G*rsa5Bz{j`l1!)gw!)KIKG4jQL8|Hk-R=nh#pTG51=d*5e z)_f#Edd)AI$yilG)BL0q8)<<AkxCSHrf%{vMT;+ooz>U3&hLp#*i1+R9$v{9B*=?g zDRd;M=8tgfnQ0!os<(J@$LCHsJllNcS3KsN>fy8A`<Xm}H|1zqN-8*p;&EQRNXxzx zL@O_&l8B`&$fd-f79^ZV#^sZGkZt@-NZoL7DBcgP^Lh)aP1Nk|)`aJD#;aKT;ff?j z>Bt@ki1sn_4a*4vL)wJSY!3^{$yoB+iLGJEVy(l%20xnM*0VhDe$$bR8j?-R@6YZt z?l6<hJV&ggOG6+$u?Sxjt%@UE^l={fNF5Umxn>iYwX2@hZ(@CyANT@?YC^CGUt@Fk zT`S4DtFQbNUt){XVcPfz$id(wf76doL=!u8cvq_PAY(GWX(%iX5jI%`zJ<>ZE*4=Y zH0i14Y>SvMRlEmwyp$)4yTeC_@;wiDWcbS4NTP!G;*UCED_$SfIiB#D@UjUtWz?a= zc(gaSkp;*o_V4B<)O~)bj_w}I)|AKYko?ft*olj%K&)>3c22lq2~WSm=r_ke_lN%4 zJh*iBQ1zf<L0pRxO!%Ef_Bseoy5mmh%`SfB5#4S?uYt`b>6lSY+vz9t*P-uyyN2xh zXOy{|Mxf8>q}ZG6&-OxXl#CwHV7)T6U*kSzl9|}!-o^B9ok<YcocoGBX1v$87f}jl zP+K8cSpRIOENAKL0b`IJt}w?{HgaV3fH1PR{WkkKL_;Tfs>n649VkW5_ch0eei!#Y zl6U(HdH0RrG*$)efqs7_*Mo2w^s-phTe|lUVtC+WeQ^CTF>J-J`t#8<_G0?J%%vWX ziYrp2^?i|>l`KA#%4>^<FUrhXI6aB9N&h_ls}18^FQzDTqj^7M;ni{FLRKB2H#A#@ zwn{E%(Bb&>>}Kr*6z=RLY@RGDkw%~Z#rod<J~3OuYW0|fdreu{!Sxx^hN+DaNsKH< zwAN{2V&Z&Pt|X0@RAg!l(Q2MNWPB68d?~r6DEO$2?VX*H#EGbmbm;#4z=|3qN(_N9 z2CYgnKiC>VooZmfd`*Wd>7#38|2KGEZ0$!k;KoV2y1RKZ`+@&3q0Mm3&COW)US@1L z5}ExDhVO^@i@UX%MEw2zdEh=9vwFNtxXr*&S6>g~%gS62?DXY)bcjLV+>4t?BcoHT z>EEi~5O|j{;&HAL1td>_j+#26)g@O+Z_FYF0}=Q%qIJX8;UjS>+;{4X@5Ry^#L{s; z+R43gHZt;0;Srb>Hhh1-pt$%GjtQbu^$jIu<@-y$y*R+Od<Yw2t`eFfw#=IC1B92b zq?*8|toyAT`-X?FNxm*Hc|71@$eRF@E{6iZYj+sgu{Wna(7t%otIv!B!`^Dly5(1` z89I?9fI%xvQ&-pBYYdO+52u<-ppc`eDR38mHA%voMxNYtE9Iqtz)_zu>kR;9>-}{# z<Gz&uJ~bXjc*~+AM!c^?op)trrIt-O$pla3*t{ACC+A#0fX~+JG>oX7St7(Oa(vX~ zRj(akIn`aAND$a)8E^)VbTe%_G*I*<)hFG%d^C8y_@`*AFazA~3jlc7=<xvop4uYJ z(Y7%DX!1nb<J@;iUDIp7N$j7@gU6Tiprk3DEWY1FoXfxyQ?loB?{3Gx&{c%@t&lJ9 zDlRUrPwy$2Y!a*wPT;%BsQ!2ZYi9;&M>)V&M*}~efr6Iyc2}0DNMCuJvzC!mEcw%D z*D0n2>n@wM^8Kztk!e=3n~-*E2tGv}I&7XK0aBmn-p5+2WhWdgBM2@o3k}=$Cd=c~ z5s8R}8BE-bG$fwYn~R?jbdgOl=DT269C*@%rM*U3W)UC-cvjVDRjx=9QeH5~6G(6q zZcvz$nfeNL4Cg1QUohijsCYeGHebzuV<@kcW=nXp+^6+8nVVbs0p_rA&&sOo*y{{B zZbNw)F{G#D9PT=wKSR<z%m}hOCEt7~ZOoM0P*&CnQUBJlGv>*_kW1~Mis58{kez#* zEW(r4qjHY<aV~059mQ~=QP8UxPf@-kWaLjAYd6sfV#s1*Mux-3QX-2j5ZnwMuF^(L zV@SBes1O1jXwcM(Vd>vaj*d<yxZ2p<gIz>ST(Fh4ReX@|k;Cl@lNZ8U`wYXzF<@<r zSt6aHhMgVh1_@8K6UuUvfi3+6-#kZ!Ya!;OqdcBMcVbWFv*6b*iL2@%x#2h;{QQTB zYFoNiTt7Dl+Ipr15EEwDb08@*Ug;|pPY!X@!61TVl^I;$aOY@#X3cOHEu84N4$;9G z<|LnPtW=u&^HZTt{zrGaeifQOkQoTP5w9cwlF4sjM|klKD16OU@UgADrJ=2Zj<o@V zSKm_CfK1d}$H+j=Ku7=C(^i8=z&dpfC}<q*)e*yt{5tr)&I=stx)y_k@_cXo6mBjp z-V(eOO#C)8S1E^I481v>@JYxg{75p~7}Y^PBkVgV6(>=~4Zei9SD|CIpU02Cnxa9F z&$i&97Rj2X(`wO6uWOlQa@n>r^f-^O9*Z2%tqCKxX~S_l4)_i`vsbYzEq)lt+Q1*K zp;me)@@ysrv;XPUjA<!bi_+9SwIE#oFfn&#&7ymLEEx;$AJ;I<$={Z4dWHOn#4@UV zY+7LRF-+8rddK?c-9%>T(GrxEJnKab3GGeSV^#RIrpem(-eU?W9g4BEMGNx4CubH$ zM#g21)9!TWJYd7@jAr1~#%Lv=miOaCtjW4Qu7-J?7&S5^5LZ|2#;#5<=goMDQyt<C zWw==9jXL5F4UTWTzX^msFF;sRLyNV$FZQY-hHqK;sS~`RuvA1FlkbkD%~2X#8HHh4 zgQ4+fRk?zf6pS%P%p&jvx7EUuolCE;wa}8Ve>6sG<Ix5_tw*w?CK}nH+;7Jc^~L~U zfWDKg;AKOv*^;m<&2f7B%}-<niD(_e*J>*eU<12ITiXs|OkEIaQnMe)p~9U5%YJ;Z z<d1B-e<vG37qX!Tyt<Mbjyg8kYt&UVhuNX&ZiG2cQ^*(bTM22H*akeUo9O<jlqN`9 zSX9vN@rVs>SLYRI27eTEc`xcLRGpvzFCV6{nVAF?D>E_9#-t4@S*irpa<^%Omas>k zY1x_gLgxVZ=$+x0+Y^=*U$4JH#3vDZegD*D0vgP&d}_(1zRUg8^#IuO%?qXf0A_r3 zI$`v7*`kWEWjNsgvN!?dfu4nG5!)lv++b>-dAX0jz;98#ClRu$^hyAMqNjF4W<P$m zxT&N$dgn3Z$N{7E8<|TusZkG!G)=NQR{8!zb+6}Y3dGl$83#}EWAYER=*4$oG_OKV zD<7H~^g#!x3!%Bh63_(2YiFUcHx6p|1^S`0zP(UId3>X3R-gef*V^&Uq`AKyySIJI zgW^e-K-V7*Z`Cdc%(#b@i4`?mYjjjWs$wiK{qW@)JNt_J0PsrPBVSeE)xU#hIhnVh z%2IM1$=LpHuNjfSo;m{r#r2J7#vWl9c1jE?DzpasFhTC+d?<CnOMdg~sPISk9=7Uo zE-?jl{bu0(*ajH*cgU?nW*m7_ncD(9@wfZT8_7(v8f8%IpDzk|$&e}$*ncTe^kICH zf-)B@V5OoIZWp79d)M&OHCEx<2}Q4FW@R2fOiR4KP$iwYJ(cXX>r1+RJhy+mvB5=x zqr+m<E;NNCtmBv3Vx$nID7N(kR}Zx=mK5Fm#asJR73SS1uXzLzjfA(%45V{)cl(*2 zBt3aEJ}mXxKe5twYF&<QsW3orjNq$ka~Qq9jd|wTSJJBcdn_0or@XoSrLA1{tMo^e z?s+jwNgA21x%0^-gJuFd*A&p_-iW_=6iKYsU_`T0Z#9X6pYen#7Gg!DR)#!FL!jHY zz|-s)gX~we8Mt0W1ChB>u0F|pu!`br_e?PyN6CPeNQWBToQ9(zrf!OqFIrpBo{!*8 zD=iX)lPpJ0(7uni<4)}$6#|`nU2%e*gtryNE-Pw8;8Qn;d-L42LT>ZqKGX_?o>xS1 zbtz}2&^k?uUab4faMZpRi;$$1Jic+*Aj^3)WXA3yuK7uj+ABA#fDIx9uZ!M`)7v6S zR~J$?mQ^^;!@G4?!@{0j`=}c24YL&)4`L7m|8^CLN5NoF@(xPy+62x^sPIYY*Sdg| zXYX#v2Qs?Gx=5hHila>ux(M+^XS;qm#yX&7snMy^75Q{K^ZFewiRqdgm_!dXJdRk_ zj=Ls{&RodYBf%cUeAlIVZ%Z8{PC?uW!-GCH_rS&rx%)P+^TEeqo4nw0bGrL#oV<*a zg`#2c@jjlznAnH(&nUddGwlP=Eu1mp-1K<&?p|qc?mo^1%K`R&(R*+UEiTWoRNumX z9Z50{Q;IQr{{>-l)|=vq{eWDz0NQR)smx5k>k#%i*|sa1#p?I;Uk85;7|`mtCi4v) zU*V;Is0>WV%n4+KEN!{-^`TvR@i)6OSRsqda-l0M48M#0Kdx7k>FXL<o9OEq8|axD z=<DhJtF@~0RYJB)a1Y8)_zndl5CO0~;J@>g3wkgPyblBj=W!k|&dLP-JC9R>aRF8V zCVr0dI29NNpg}+Y<A1?kG5!+h&+{|#{0NknDVOV5^nXpE`fCc+uPIbOIjY}NsLm69 zDFs{ya?t;ha*^Y=6nZen?<waAKT1*l3>R&_xcvPuu+Df3L}mT+`tJ98Xk@MP?EiPS z@MqU4zuz9ppEvbK%FkRE45DQGo&ubIPhtEu1<VCd`y~$$IZyam>by3P+D|$cIetyK ztnX)@@AY4nx{Usy^VeGl0_*;1UGw|>v$Oa={1jSzM=bvRQwZ#Y1j6}K^S4i-KC3>H z-v5KA@V`A7JU`g@ozaZ{_fr1HTX_By{*7Hh20WT%=WD4pz(>J=y^Y^4^oP#qXJ%K1 zt~Av?+-|bG>!vyWvFVG)RkJ!aLL?HhffALDc*F?&H?(51FXj5OawCy(QdxIUP!S?) zUlJgP$&4VvMt;hwuSd{DiqK|*gW<1hVuL3p-ma>(i~IIEEe?l3E=4wdPb{fxQM2>V z)n<+DK#P5^%;P0)O!j?MI$dq?vKRPuC}c`-JIs?@-g0=J)?{ONZ?p64eWCP-eQoMb z8MM!C6Gn&LxR1|*#-fM1EmWY>MaZ$D1Z%r{*t53QTz>ShZSy_*F|q0z45~fteBHWQ zn+7NM7oL$Sj9MIl4;JG)g`cl*zos(?wdGRkB&v1LJFf3f`FJz$NMFz~Gkv;q|BMpO zgqkr>_r1%jgg91*F;kmVn?5{6ChD`JK6CXlx2tPhcPgAtwb8AbRHg!gg?R0m6XTg+ zuVtgamyP#5clbcEt8QVI@6)``CtlJH6@e=kSC_pJdMGg*RQ1$UspCbFkf`zG<ZJ(~ zsnJ0t<Wz_(Hb*QkHX&hbxS%Y4-|W*{k3U#ZFqh-FGX?EFtU<r=$n7w`bKbq^%!B^G z5}lU8b*gDgkY#J$;$TqyJ?gFeiWj$$q_;nzr=kv_W4{UyVvvEv5r-KdxDd8qm27Ar zHIRqKn+wCabK7SZ9c~XAK;&&xH^{hL>zktbxB3n9T}vV-*ViBV?(Yp*2S7xb$?0AM zrqZ>BsYFp_pFXnQq_v9piuJlVWNTaBs&h+aKGiE|I8NG969s~GO+=*%a4F@um+F3y zWPbj|c^0=VCm$zvG9I;wYRdP1`Qzhl3NwxSNY3irlWC;{lUVr#dfz&p1_Tx^(cDsc z_2g5g;-gT}x_GUQ4}zl8PomOoBvpOz^%JzzPXtz4-f*a!EY<l#v%H@ZhqK19<~r42 zr_#PWP<~03aIN<<?HlUm>1I6n!f!MEi;G(n3@zA?;hjS?g)Ew6g09bfY7a!yD_!F* zxmHIngkUYM&R_O1{SK!*EuBokT%8HB1X(iUTc1|_j>-`)owzsGQqFt`(V{yD)0Bf# zX#>949Z=vy?l3y?%^pU-mH6l}WT?XAs#_7JT{>;8hh#BoZ<Cd*>`{kLjWZPxWV!UU z@G#=RyQ4{}@lhpjeys_rvb<Nam>5#)G9mMyZ>XD=hjLgHILi4YGh@J^%13v)F}EWk z4yae9=i1}YFy26l8!p?2<$5^mbL<ME>Vi8osHRbTx<iB9L(i7=!e~j&q{{ZmhhP-5 zxI)C_WHL)zTu!!8`(?G@)aT;jJSa%8IQPm8Lq1TxXvz$O(QtUcsc>5iqXet?Uc#C^ z9_39+*?a2Rgb;7ayE*|+^U#P!!*m23jb){}ult$Y7e#zT(SERGjiiW%nicx-mhd_c zL>rxdCRI@lQx7#6vN_V&w~p~7@I^fnpDY#5V>NZ^!;g1axK+Gc0t6@yrq$_3DqNg= z5f%HFvG6GE1Fo6%+^_Rk<4R&P_N@Ct7LMbI@m9#q2{w^vnW_LYpTqs?klJzUo0jzY z;OwI9QCkORSonMBObBaT7Fc#1Gv<>LJue7EuxaIRDW@XuV!|%Jt?mt0d(DN}U*C~M z)z3v$FNHX{w&}GA`3S*d9AF<ytG`S68XoB?Wl|&$y8+dEH9^<$RvtZn<$UaV!hVY9 zWG#d@q=QUvzg|MpU_#%ZstirC*nzFvL7_yPkdwd?!lM4FIvn)6*-~%+IonEZHIfRs z_Xv}yWz*M)W*YhC-Vwxnl5hv&%DVYo<$-~Ft(>QBBNQr>*UJXS#Tm@0BNngi1Q|4D zA4N$7oR+*+KzSQ*hN&Qn`yk`J99|DQHqT%jqKX00m8^Vw44;o%HML3uf`lG1NsP&} zkwKG@J!MbIokb`_XgqziX@g`q_->}Z6H^jFEr*HjA`~7xnN5m0aEjW`mKgJ}&lAtF zceVeJS@J$fiwN_PRy>kd`v^flB@(v4jd$9#J~9EsWOz7MFYfL|d`k<D1H9e)5H1dx zuQOO;IX5ao))i`cub>OE<&L?H5>I;w3J%9Uq{hR!p6dBb*XzJron#TsZ)yS6O7==w zi;rQkF(2JLen#(h#cM66Q_minsCz9Qc?n7RPW$>A{e`=vN(lH6?gVa6(?`L*%DyO4 z>26Rf$}@#tA9LaO!rUSR-a&|>XNFfB)J&Ejk-jU#uE1pfInVBJlOEj+Zw87tkvxOa z(96@PtF<spXSp$AsfLnLnT_(AHgH1+>2QeVk^xmjFFtgWo?MRze@zs6DBl-8P2vT~ z@2hmrL0QYrs?=q3j>!rVKD&}B<vd15&9Ogklo_1|-E~PgvJvgK&BvM;UlHIpWk2F1 z-#PZiCQR#R`E1x^%+>wu8z%aKcFDbo)%vgQkEU~SERWt+@7-y4)d;qL)Cd!j4VSIl zYP75}EPSZtZlUBk7iEMdndaB%In}%BY_XHZztC`8%R#zP4!nzvv&8(WhnwV>`c@ix zY`Lz23LcC9L+duTTY?YUwwNP^t5Qjp-#oo#W?Y3)*h}Ey32cefyt7neDo-ahaGcLt zeCzD&gV=s)(%Jo<{?B=yNM#jek3wZ(^gM-Zh6iayKM*?Ge^XG?Rm#>cS%A}h*8opU z?YZKO`wh*hBH!_0P0o_(ySHfmr*u7;p3bazIwy5B)+%MwWiQKwo*GyO&$adHMt@G~ zxRNiKh5}t*)k<7_56jm5lIwS4>ko7UgpLaxVK7F+j70fLv%3S=UVEkH`h&_3-gx+U zL!>B;qGVYLE<Q0Cn2N~=wLN^}be^i&u=V`mj&m?6uzavL!n_1z`DN)z)R7Xg@#*4N z?-oXUX}gJH|C!jbYWelpaNO&1$2Yxn39b51Cl17gjrNS~y4Sh)yH-@rELqWpx$Ds0 z$M1ESQCXV{DYp0Xu~xeX4dr*eUHWEnuw>FwfPwPBn8@#*;^}j=r1st2a=7CryjD-Q z)HsH4Thtu&dWI+_rS*ae$3i6rd<F8kB=cKZ_c4{ZnCfl?P+gg8u6tgMge9;?;wmPa zz&3i@Q-|jx?E3o*eg*$L#>LJ_V<KgvuCk#syA;pJo0jEk?RUJYZ+l#8A^#M2{qW?= zjFvMO!P9uFQ<{NJNS4dS0~~)WEZuC>?OL}nhAZog6>>LR5!cS7A>%ht$r;gugLi{n z=I#flQ-8^NRFoabER%T?gOZ=2_RxNNK0W=RU*vIS@`;Ftd~$}*!Ew*xV*S)YO;({5 zPKQuW`ovDk?lG^f?57%?yc)Zav;Dcba>-lVEC^Dxb?;J7w1wHWx9Tmc2xGPbdyF6T zrK6j=Ozb~jq{W-*fSxFq$bB0(jmSG*;)ij=f)f=ix1EiO>1)fql4XV%j~I`Tfav+g zXN}6bAk_V2Cx#ef=sG7Rf{V$47;RhV4PsJpy69lFJfAXjvyUG=Z@g1}OWUbwAIcS7 z_3YW9f7u$EIV6*8RqUC|0*iD`*EFte834UOwOMa3FKp<_<j&WqEZ$i`cd@~xyY0b2 zvfOD%GR47xLEn*{#IKHu^9~Kht*NNjm#^aCTy$GhrpH7{SKT}8e#)eigR4jTtHNhS zSFWi)njFtZB0J@QPmx7Brmcc<4RznCag}JhQ}ThQ!B}^naa6T4Z5Ou6aVEHqh5k$8 zlDzy4GGtFROKfNlWcp<K@z-ls<X2l4!hG%Cq!tHUdC=mpUSYAUitL$6tBGiwi!?bR zxifx)YIX$Xjl|M0`dXVRTJrl1B4-?kH3?E3@GewDQrKI){i6BNPvB&HvQ+)Tm3EN( zHpd`zQ(N&Ow;sZN?n)FSCF1K`;2pY)Cg_8mATkWgQ>R+}Si+%^qAa+HP2C|{KBrgx zF%K2)qBG*%^k9!^?>njOgY-lGm6#G_?7^SEu}Qz$Q1^;tMMGF2W)Ji0-5Wi|aWp_$ z^7DK`G(e}QUiJmCCvvOQ*EdkuI*B99>>=wQom8QSjX|R`AD?DPeY_SH5ACT+oA?m> zSgxBngr-A*E$6M>GSMFQ9dhb%B{E5t#iIAeWMPrC&uQh9nL7LsI}qnRx#`+0?J;LF zxA-erZQM{A2%sKoGkDIoG|B-v{;b7~sD*Vx7?*dvIvCZUZ=w4}Sij<_*qqfqIU~wp zO}r#8MZ=M5_EMb#--2gc?lUr+z#3MUomQXCA)B&{lH2=`qU+c=p)Z}RN!g*SMvtRc zJK-kakVj!W-Y(bBEzcWSLRUvqJa2NnC0@Th`MG05?dz0;<MFtiqfeB>oyUeBA818v z9bY$UC`}gj_BCUSAU)ZE8RKw{n;)|dXy3Ri*`EF_{s1{=o$*V;^4#EqM>m-95bt3; zgzspYDcl?r#%wg`d{g5H*PP{Go1cOENf-%d6S)-1tW_$x?1d1~-Ej2b?CJ^Zj@v;T z#i#AK8Z%aRNA-HMo-+B=a-GR|4E3)t8iLOSW&2Tf&d|jK49qRcRWvJ&)U39sTuh0c z_=xxnyyS_AsYM@0-ygH!APE$Hy>@2y==0a$Xt89w#)9An!PXc#3OX}g)wi25?BM3d zeTJkyGRq(YDXpRNG$4tLB{}dysUF>hNm}wdqoukRz*^6iQUTLwvoZdVsT3BWc8bPr zZ{|jd-ZSjf<C=%z8#be%wAe5TJV${e9w-Bzs`MvKZuVa?d?siSW<AI1G_^?%2(5r` z)Og}(V-?^n!svR4A)Q`jsMWHcmJO5qeH!??b@sp7iiqEB#ldJbGlgatKWN<jg_Taz zDvn7sKh@aCGVD@pR9q8sSz}Q-MHI1I8Vm~U0tC^>X`hTYiqxvSa`z+^O5`G<Uu-GW zSr5{Bpv2;Pqr`fVV^0)pj#ZkjH;$L=Tj%xP|HgGd-O@gnlC-nhv8K{_a@4(o0997_ z{JDZnd5BA^<TN+*gV_XUQM!|I+vmiu`NKmi`($Xyh9ZL>*q`tWTcU}@&{7**No??f zEgM6n64Q=*&@jbxRAEVV{2(uTl+~W};H$HH^-UN$`h8kWtqMkV_cgpLIZ2y5UA$J0 zJdG((#(E&SywM&MNyKy1T#ova5ou5{M1Mr0o6WDI?ChLbM-fp<{T*GOjKQUgf4<{7 z>l`xPi!Z?y(#LlV>rO`_L#SD6kcvs?BpyoV5{giHijC6Y3EEmyKh&)#ZCCEPhmr3| z2vOEsH=D}R<elml!t7<0r?(>Sgvlta_<Yiq<&)skHhqdVI!mJdWrVo*W`^zF%3I&W zk9NCD8=ZSYSS!#m{{vLo8n4a-hk4K5>Oj(GBV)u8dULur2|C}i`-|S{rS%l@p$HJ8 zm8~T~8Q3~}7Hty0*`I{fnDlic$XmoVzgp=tOctNktM`)$7K1NkUr93!-SmVYA`hY9 zz!1t_D`fX0438!hy(`vdAt<+PP14#L$#yrJXz9hE>FA!S3KGPwN}*tqT-lZ`IR6S= zfp(nFi%wov*gPEA!SOJ;cwC*n*>-H!Rsn2(iOg51k~>H<g;&~R#FN{^he`R`8QM4J zbvR-@`0XKNh#bAQyfsRjkOu|GyuB7741u^^w=osjC7*K6D^Lvy@KJBiM|QxlUp2h$ zVbf3FiYt*vkscQ>A1$!kvx1oA+I?#P>Pv>mBY{$2Yk~6=!Y_q1L*WzECrQgpIa*Yu zf<&h9!aL_Ml86wMy6@SIM))j^>M@>puQzeXe6)kNJnL@*Jv@pvBz!BM%E*U&l^OFf zg%!mz3lFksLXa@i*Bs-N=eEqa;?l4(C;_hP@{#0?grZ{j^6@%|P1D)LCLak8j~-2! z$wDI|`V@N2O7VjwGj2sW6<O4=%9ElyXsPXOEZOz(aOCa!<IPCt(H;sxjjQgENFQHm zY9c4^!njeA5Y`AM4o{aU<UNO3zQNyhUrk|={)tI>7*p99)+o%IC&z0aY6rAlJ+RHN zJP0K%)mXy#gcxzloH<S`6Y+Fvd9~CpRHMAtZc+8PGxTd^#aARGq+qldMh8~cDfi4= z_Rn7)l91+%Z*GUj#}l!y`Q)mZUVV;0u^T+}u~}7UB;?gHCr(KE(H#c_EG$I+PQ58( zBU=0$gj+~X6%|fhSRn^co9a7q&h1GDMr4twgJ&!3;gW-upT`D6do#?rbFFUWNhf_R zzSn9X-CZ?|DMg6(f@b6qqsi#1_EX<h(YQr%6dTpeVwimXXU`^TO6MFIKFrje?Jqwq zRZv`adD8vR9aDYnM(v2B!R&hO>(l1^Q4-hp&icAJ+^<Hl1DX=gR;C-d;VB}xiHL_V z6FH&Jx}(i2_jD0uIv~2?(X!ADhSCmoME3r(@H&0{fh1|#dsz*;^Zmh%XFSQm;j_1d zjHl}Au&0<*pWewHFFc;ko)5`uf3259V!~lJJ+|*YVgL5q!E>7=SB27rAxoE$k&y!@ z){Gh^ocD;D&sJlm;^SWn?(dL>yAnLgd-Y!JgSquJA--~_ITA7Pg@$ZM+8Ly#dP#P6 zo~tGF#>4wAg>!9%r=(StGl_@=&z|;Ug?4R4K_?4KOl37|2+K9G2qSn<u%G)`oqQ23 zE_K)mMTqhzB077cizw3K<#m5%LZed1xA9g8$$cLYTFfz~@Q4`?1{1>2@xIh4srM-< z{Eg@-EwIoQ{NvPIJbLAd&9;yz$K|V`GlMb8liBOt^?0ERdM3{jr)?j!la<|pk?41P z$Qu1Aj%6W*1OLF~y$rKEW7`de`r-GtjhD+1G={JyN+ChvuI<sC!Ul6WVX^4Mk}N&L z_XA$MKxMdf$Ge>xdQgKPqews8kH^FRQB%Fv?Mhl2xle=aEcc|KmOJT#N~ds<H^)l3 z@vqT5#&Y;+4I+hwXF}8EoH|QPr;;F}orDMr(LFa*e70v>#bdl`iHHO5!?f^e80!n^ z?2+<Qr#&)XQz^C30A767Yf8*+Vap?<rIl}QXLsHB$&&}LWN}Z$vQSGTAh)+)br-`h zOU8$zfG-P3TOP{Sve}rdpTnlYeZGfwm5~+33bnJt&)QJ_f%)rq<Z+1BK3r4kI)w!a z0II6&;GwUtuPKa+_+xU0tBm+vcm&AXzM3g6LlZvz@nOu8JtiZM`&oSq4ZEHapP>yL zh|!oq!$^OhB>%uxf*-!Hl~$unjpdC<n%oyS7pQKEn(OvAsVJ-UJ<h+vZ-$e*+sBi0 zDtFUtI(@YcOO;k4aQe#fXcJGkg&X!Klk3EA+;jm~tGto}0$wOIVh9!!@QTV072jQ0 zxyNvi5LNZ7Iq6>AM`$&PV<PbGo{9ZAy$$XVuMt!tD59HJG$ppVzh<k(NrbWg2!O;M z+D}NxJ(iUGY-!;D)p^{7P39+OFDN^bk^h+d-9v}Tdbo_wgC?+hC&+s^>^*S1<JtwZ z;)+p=huZ?(iH)x#()5vF#~F-?WZ{JCQ{FD^Q{TI%y1zLSFsdFFl=z_Wjnx+#e1ip@ zji6Xh?v!U{f{n)2Ie}a%PI~PGBo7^Mmlx|6mp>}2K2g@*4j??ZB9!A-$XTH6Iqo_Q zzf^3pSW@z(L8my5<$2<L{-=VzlEx#-{>j>3Fm^tE@On#Ed5ieY`0(?>r<5<SAslSx zsnAxuflTREEMI(>35*<1_G`mqYxAi^%$!a~tVdPP7T+7C(TcrvVhS+trAWPcM~)DE zsbT7|8=;tgr-#S-i?=yZXY|S<0%?TAY*fCUo{N!J!kuFs*5w{68KQo9$bg91z}g&p zw|!e&tT++vYQf-Oie#b$MR;;$Wr7Hmmq~n<uP=vE?)2bb&MXpa{Jj00NAPIeBOZv( zfu^Rpv5&T+4W=HKVtPmoBh_m&iQbn|Y8W03N`L#wa<ooMGX&9`fR>-F2Qx~=&0R5X zD5tHXfSr|WYdb=hF(wdymZO}eN>g1DFhFV~Eu=yU4qYNfrUJ>Y74U=~=uA&HR=o_) z)Hl$1rxJ0ra1BxJbW**VC_F}Z<;d;@f6D9?S9~*4vq@x^`8cj>)^=9G^<1?tLwSOZ zkKp(K^qit%1S`7UqyTazp0YTaYb`WH4Y~22Th;oNcc)}<xydMsWAeC|fr$|}BMjJ= zmgOldA8Nf2rCIo9>vnek=+pC^Ho60GaXZC;e0R^4eKr~79M|`T!SA`<^L9=*kwSKt zas0yD+{g@#j40!DB#eoMzka}R-$NIs^7^{Yj$3e8jedg8ILK79tE{xN70#Q$jF6Vc z$gj>^4SUTw#ES6v)%{Pi>-6zV^%;vtN0dyA+mY39c&ey$^uj35Qa)8yw2W61`?LU3 zV88OXN!97zqlflAiW<R^n!V3FAsW}OPe8OVRXzE`jBF~|ulVs*xGeM<ARdjDUz^T; zs;5T@e3Itc@vRY~j=B<k6xaQ=yNuiuH0WtH*E2Am@c6FI<h*6w9=V6h$;mNCN$HE2 zp0|ul-q*+?;q<{mQd7GvO*jZZd5@Q;MisA|VkWJ-J>&N#8ZO1E&hV2pH}^J7x=-q| z>TA}r28UG88Q++jz~1R7-R&h*7C8==RghzR=0fjw$ZW{qS7>|7)<G{lUfNpwm6XUT z#*yUbA_IZF^=6lYuoExX<)^~UH<BNXc@!jnR#tx}*!>!gjDj?JN@#jc{1F1e5<hZ@ z7x^{uYgRRWMz3QSgO6<I#K>*0GoaCjL;59zM8k?_A6@Hjj&qJPWo~QRTG`ZV_qv*! z{AS-H2Zg|IG8sZjiHw&x;djs6iX?!($`^@{6NO8*o{3j4mTdA~G8LKq)kIhgo;&(A zgLK*udmePl=}(?#wI-Wd^;*oSi3txlPqlv^6Tx?({LQ%d*FAd>7#lfZK1f~{2?$<8 z)D;&NfB>&<f<Tk2Gb4Z$6e|%G8wdmq4?JKX@vp%5Y9iT+N(v%<ML@oaON06?1sT}- z_YfRjIogBeyTuh`@z2&O_iOg!H--BnL#Vune6QTnVYEi|vcHx~rwad~I7^bxa8e8V z5Sg8qDm;OVgci3Q=c<JZ9G+}y3GFCy9LtmPYc6d2V-Bjw-rP+YSY6YaHOH@Qx(_ia zDa-_qUE^R<h#Kp{?2r`9mZQE1QYcK+jB9ZyMGf&15|okmKzHUDbv!x4VxJ*HIGh&I zDN=}DnN}%98YRPTIl+x$PX<A2AuMcZWOW>b^oio1j^BvGbP?cFvz6(8D8_*2^0a|r zLPSJtD(oGnHxW;bOon{yZK;nYR<7Wei-pwFz)B?W=RoFCP?<g)YHxI9b(Z^Jx;&B^ z-6n{x!D6A{JMolYP2zAZ&n@YU*K|S2y;m&VLswULx_~n;i~ObF8DX>DQwdkM2<Z%A zp)nY{K?tO8G5+-ER%KCzSmqN(o)JW!Rx)^h>f0U&$jLZ4#&r!_>|z<h%w)D#;ujy# zT{X6?5)W~bl?{zAqGaOmHduqZi-F;bx(tz^47#cpg2d;)oHhF4R#`}VdyY%@a^WW@ z`8mNaRU{cYAF*5rgVGqSar0@C9LJN?LzlD4Q}t|-24w8#795ZC=q7Nh;W5!_@_PtP z1fST;b>8W!cDR0TN17C#=ryUKTwKY@gTbhKGgc~iZn>u!&uw*|Bfq8&o_#<kOmuxl z-m)4wUpPIhvE>sBmVmFjCCgZsIfI!&ewCuyAd_(dIU97Qee8953_ireG06oJ(jTg@ zulcHW@nnj;uxD`@kgOlu`~DxuE*{nC$tJL43zq&ucB3MsMF81ts<oM@T<>&dVTzVw z!Nc&x6`&I&Fz6<@f|wDR9v4VK<*W2z5yxVLAQsJ^zycLf72&oja;_?Tg|WPhk6`$z zN@T!`2OKk14(leee&``{8so=fq1(q@_dj)H*{WK!`a_uRlBnmr!HK%@NDFi2ZT9lm z>(Q^vht}HSh>3TI&D%Q@_a2Px&2U-_JU8OhVzYRYZVlfZa~Icf=;^c^qIDDr3#MB0 zVek9niF$SJ`?$00xgO}V@k9yon?x}gSGA_vPly#1%`@fwAM^{fn7^1jv?f!je!nUr z|9;oWo`i|@P4TAAJaq`$tH_dXu10O!*vsYV2EmEzi}sn(Nt8S{$WaR<&|dIMbk_<> zFWWU2>ZL7jW1EgP)Ex}(*+^-+eN_L(B7!Ye0qGA5YiO{3iiuF-LvQYli9C~dN6#Ij zg~!7EW4%6IRC2cO)gE*Ym_}4jOl@S8{;-3>1C+Sy&RM$~z5}W^Y*#XdwW@E2SC0;^ zk9<IY^t{;IIpvI0!tb-^eA)Y;c)<Q6HZEdZ4++Jwe%8kBLNjj!{Lwst;n<3IB?R)3 zZ?kFeYk0w%6j-6en6MW(0q`e<c@*>lXOj=9dW@vdku+6qKK2c=Qlw-sdAEg%3=dm} z8r~Z2ad!VXoi@B6#uaAxYuZeX^l9&4{ZQTApSRG)Uh8n;hkM`mQvDGVJVfLZb3rHV zjyo~7VbhHXQHv~^j!3OjST5LRMQ?1ZnBQboK}LuPQ9;Pk+WaoU`CoVm14CO_2%LhY z6)XgaU&qSU#L@!s;u<=?nTdggt%!k%k+ChDFAUm6T-ik5))+1x7J(mpy%Z9Po*AF5 zg^-S(0lJW-g)JjL__iqnTfiMID8#EMp`gVt!Yd~)sDOHL^}Gzao|&?Vg}$YOf`Owg z+WCcxT3~lk&SO$K<_3s}3OdG?<~kPz<!zst8K6PnB@Ha>kWeIbOf0}(cQK{S^!cp~ zbZiZzt@RD8kuhYzS6tc17+8w}_!3xcRIrBcv@swE3X%rqmI&aVyTA1u;j&YRKYEM6 zYi43(frPAMcF}EAc|B`OGc!J*cSwjfHhh-0#>fgfy64rx0!&6xxNOwV)}7Y@2fT0) zWUn@u1!%LVt${g~w3UH{fPtBnv5BIEiS6AVoW}z%kX>9M11|yS93*KApb2`WNcev# zb)E`TjizvZ!9>T*(g^M6&%201CT6w<)`$;(q31%!Xr*K0@;yZcc;y#>_y!X7txSI; zT3bFb(6c>Hv__IX7YQ3QOiM!%6a8~=xU_}Yv;VJ=bJ=Ygh{Es*1QG5mSy~oI6;gA7 zv<k=pDky5it)ivs4!O>xv54*Bu|tA*fILE%EF+$v8}@yKJ^&KkvF!@+j}!k5p$i<@ z{^rb_%N#o=UO00j>a4p-_f@Ks)q$@QwBb#$jp3`IyVFw}{%1ejl}RdY7N)5%ccq-m z)>?dmV?pY83@}du^D>j#d71fp^}MWjhU~%_GP4N4ysla1d0vJ`g@0t1&XAcm)#i1t zoFTgkSwT!h=4{E&Z{}RBPFmwT#)@T4TX^<4FSqajV@8hPwkS6tGp#NrdO@BP>aepV z8}c5<Re1|)$s2i%b_>VnV6%NM{`zh7CcBXs#v<g|(b&x;Qvpt2GuehD5{oaP?82Ha zJyEb6N=G8}f62yFrH+-$A7HN|1`|<LO7M`6--1po8rl&w%~q2##^k#|$BbXcs7Tt9 ziU+UrTJt*3V5fjlF0^t_r;&-=&StfVUKd_9B6nf+G=@vXA4TW!Am~|r6>F5crd=yn zZA*n-)W)sawBKz$Uu@VGR@)2P_)dkYX%CgQA3wTw*>Sa2!A@^z!9b{+b{dBdHQr<k zT)i0hC=nX}s95x(;GwI7a=&I<fgAcArIW2$Z!l$9PFvyI-iG60)}E0hD^owy4s_+7 zTTn>+WN0i*wq&@65I_0h{d;(QGM9#^p-uZ$9#eTzadr7=6a-PY_!Pw&1x?RrFdxh1 zs`<=x?WH>?K`+#BGy0&AvE`))OFPT;TD|Uhom#syGqmT1yD5rF)4n?+-HRhnX&uEY zvDftz)R#2QhE(#YSMqH9J$HxlX_lNMM$u`7o#;QW!F@Y-p_P}$NZn~tWA!n`wNdT$ z*zco$?JCVq<ec5B1E`wc#+RzEdZ$UYtez1xZCAI#K5`S!%-OP1f5kJ?ZrUBUr<I*g z)?6c}LhJuHcPf8{>Qp#qMCVlUTLBG`V^eOhU6d12$&{N+c8jz?YLM1Q+oUdOKpK(u zNn_Fh>5z0pIwqZvO4k@4X@S%rt&z4#UDALwBJGpLqyy3+>4<bpIw6&=Gd|J+sX<yJ zZIimB0ck|qCyhx5q(jmX>6mmvD&1gwqy<ugv_{${bx8x#h_p`{lghD<y@|u@_v3t4 GVgCTMdU2Ql literal 0 HcmV?d00001 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<string,Integer>; + +function LogStringUsage: TArray<TStringUsage>; +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<string,Integer>; + count: Integer; +begin + items := TDictionary<string,Integer>(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<TStringUsage>; +var + items: TDictionary<string,Integer>; + comparer: TComparison<TStringUsage>; +begin + items := TDictionary<string,Integer>.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<TStringUsage>(Result, IComparer<TStringUsage>(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) + ' <project.dpr>') + 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 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{CDE040EC-B3A5-4860-9B08-7B0867F04597}</ProjectGuid> + <MainSource>ProjectIndexerResearch.dpr</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>1</TargetedPlatforms> + <AppType>Console</AppType> + <FrameworkType>None</FrameworkType> + <ProjectVersion>18.2</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win32</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> + <Cfg_2_Win32>true</Cfg_2_Win32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_UnitSearchPath>..\..\source;..\..\source\simpleparser;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> + <Icns_MainIcns>$(BDS)\bin\delphi_PROJECTICNS.icns</Icns_MainIcns> + <DCC_K>false</DCC_K> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon> + <DCC_N>false</DCC_N> + <SanitizedProjectName>ProjectIndexerResearch</SanitizedProjectName> + <DCC_E>false</DCC_E> + <DCC_F>false</DCC_F> + <DCC_S>false</DCC_S> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(ModuleName)</VerInfo_Keys> + <BT_BuildType>Debug</BT_BuildType> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Locale>1033</VerInfo_Locale> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> + <DCC_Define>FullDebugMode;$(DCC_Define)</DCC_Define> + <Debugger_RunParams>demo\DemoProject.dpr</Debugger_RunParams> + <Manifest_File>(None)</Manifest_File> + <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName)</VerInfo_Keys> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="TestUnit.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType/> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">ProjectIndexerResearch.dpr</Source> + </Source> + <Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dcloffice2k240.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dclofficexp240.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> + </Excluded_Packages> + </Delphi.Personality> + <Platforms> + <Platform value="Win32">True</Platform> + </Platforms> + <Deployment Version="3"> + <DeployFile LocalName="ProjectIndexerResearch.exe" Configuration="Debug" Class="ProjectOutput"> + <Platform Name="Win32"> + <RemoteName>ProjectIndexerResearch.exe</RemoteName> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployFile LocalName="$(BDS)\Redist\osx32\libcgunwind.1.0.dylib" Class="DependencyModule"> + <Platform Name="OSX32"> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployFile LocalName="$(BDS)\Redist\iossimulator\libcgunwind.1.0.dylib" Class="DependencyModule"> + <Platform Name="iOSSimulator"> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployFile LocalName="$(BDS)\Redist\iossimulator\libPCRE.dylib" Class="DependencyModule"> + <Platform Name="iOSSimulator"> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployFile LocalName="$(BDS)\Redist\osx32\libcgsqlite3.dylib" Class="DependencyModule"> + <Platform Name="OSX32"> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployClass Name="ProjectiOSDeviceResourceRules"/> + <DeployClass Name="ProjectOSXResource"> + <Platform Name="OSX32"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidClassesDexFile"> + <Platform Name="Android"> + <RemoteDir>classes</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AdditionalDebugSymbols"> + <Platform Name="Win32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch768"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon144"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeMipsFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="ProjectOutput"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="Linux64"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyFramework"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="ProjectUWPManifest"> + <Platform Name="Win32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1024"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceDebug"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch320"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSInfoPList"/> + <DeployClass Name="AndroidLibnativeArmeabiFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DebugSymbols"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1536"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage470"> + <Platform Name="Android"> + <RemoteDir>res\drawable-normal</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage640"> + <Platform Name="Android"> + <RemoteDir>res\drawable-large</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640x1136"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="UWP_DelphiLogo44"> + <Platform Name="Win32"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSEntitlements"/> + <DeployClass Name="Android_LauncherIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidGDBServer"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXInfoPList"/> + <DeployClass Name="ProjectOSXEntitlements"/> + <DeployClass Name="UWP_DelphiLogo150"> + <Platform Name="Win32"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch2048"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStyles"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage426"> + <Platform Name="Android"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDef"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSResource"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectAndroidManifest"> + <Platform Name="Android"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_DefaultAppIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="File"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>0</Operation> + </Platform> + <Platform Name="Android"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidServiceOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="DependencyPackage"> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.bpl</Extensions> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage960"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xlarge</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyModule"> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.dll;.bpl</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Linux64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> + </Deployment> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> + <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/> +</Project> 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 0000000000000000000000000000000000000000..743599575b02e97248bade49ed2e3eabafe25a0a GIT binary patch literal 96 zcmZQzU|>)H;{X347|28cOhBFu5dZ(r#Sp;Y!{Epe!r;c>&k)4m3uHM0X?F%!AS)QE O%YcEC1!e#vkO2UW7YiT& literal 0 HcmV?d00001 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://tokei.rs/b1/github/RomanYankovsky/DelphiAST?category=lines)](https://github.com/RomanYankovsky/DelphiAST) [![](https://tokei.rs/b1/github/RomanYankovsky/DelphiAST?category=code)](https://github.com/RomanYankovsky/DelphiAST) [![](https://tokei.rs/b1/github/RomanYankovsky/DelphiAST?category=files)](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 +<UNIT line="1" col="1" name="Unit1"> + <INTERFACE begin_line="3" begin_col="1" end_line="10" end_col="1"> + <USES begin_line="5" begin_col="1" end_line="8" end_col="1"> + <UNIT line="6" col="3" name="Unit2"/> + </USES> + <METHOD begin_line="8" begin_col="1" end_line="10" end_col="1" kind="function" name="Sum"> + <PARAMETERS line="8" col="13"> + <PARAMETER line="8" col="14"> + <NAME line="8" col="14" value="A"/> + <TYPE line="8" col="20" name="Integer"/> + </PARAMETER> + <PARAMETER line="8" col="17"> + <NAME line="8" col="17" value="B"/> + <TYPE line="8" col="20" name="Integer"/> + </PARAMETER> + </PARAMETERS> + <RETURNTYPE line="8" col="30"> + <TYPE line="8" col="30" name="Integer"/> + </RETURNTYPE> + </METHOD> + </INTERFACE> + <IMPLEMENTATION begin_line="10" begin_col="1" end_line="17" end_col="1"> + <METHOD begin_line="12" begin_col="1" end_line="17" end_col="1" kind="function" name="Sum"> + <PARAMETERS line="12" col="13"> + <PARAMETER line="12" col="14"> + <NAME line="12" col="14" value="A"/> + <TYPE line="12" col="20" name="Integer"/> + </PARAMETER> + <PARAMETER line="12" col="17"> + <NAME line="12" col="17" value="B"/> + <TYPE line="12" col="20" name="Integer"/> + </PARAMETER> + </PARAMETERS> + <RETURNTYPE line="12" col="30"> + <TYPE line="12" col="30" name="Integer"/> + </RETURNTYPE> + <STATEMENTS begin_line="13" begin_col="1" end_line="15" end_col="4"> + <ASSIGN line="14" col="3"> + <LHS line="14" col="3"> + <IDENTIFIER line="14" col="3" name="Result"/> + </LHS> + <RHS line="14" col="13"> + <EXPRESSION line="14" col="13"> + <ADD line="14" col="15"> + <IDENTIFIER line="14" col="13" name="A"/> + <IDENTIFIER line="14" col="17" name="B"/> + </ADD> + </EXPRESSION> + </RHS> + </ASSIGN> + </STATEMENTS> + </METHOD> + </IMPLEMENTATION> +</UNIT> +``` + +#### 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<TAttributeName, string>; + 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<TAttributeEntry>; + FChildNodes: TArray<TSyntaxNode>; + 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. + // <VARIABLE line="9" col="3"> + // <NAME line="9" col="3" value="ValueRec"/> + // <TYPE line="9" col="13" name="LongInt"/> + // <ABSOLUTE line="9" col="21"> + // <VALUE line="9" col="30"> + // <EXPRESSION line="9" col="30"> + // <IDENTIFIER line="9" col="30" name="AValue"/> + // </EXPRESSION> + // </VALUE> + // </ABSOLUTE> + // </VARIABLE>. + function FindNode(const TypesPath: array of TSyntaxNodeType): TSyntaxNode; overload; + property Attributes: TArray<TAttributeEntry> read FAttributes; + property ChildNodes: TArray<TSyntaxNode> 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<TSyntaxNode>): TList<TSyntaxNode>; static; + class procedure NodeListToTree(Expr: TList<TSyntaxNode>; Root: TSyntaxNode); static; + class function PrepareExpr(ExprNodes: TList<TSyntaxNode>): TList<TSyntaxNode>; static; + class procedure RawNodeListToTree(RawParentNode: TSyntaxNode; RawNodeList: TList<TSyntaxNode>; 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<TSyntaxNode>): TList<TSyntaxNode>; +var + Stack: TStack<TSyntaxNode>; + Node: TSyntaxNode; +begin + Result := TList<TSyntaxNode>.Create; + try + Stack := TStack<TSyntaxNode>.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<TSyntaxNode>; Root: TSyntaxNode); +var + Stack: TStack<TSyntaxNode>; + Node, SecondNode: TSyntaxNode; +begin + Stack := TStack<TSyntaxNode>.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<TSyntaxNode>): TList<TSyntaxNode>; +var + Node, PrevNode: TSyntaxNode; +begin + Result := TList<TSyntaxNode>.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<TSyntaxNode>; + NewRoot: TSyntaxNode); +var + PreparedNodeList, ReverseNodeList: TList<TSyntaxNode>; +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<string,TSyntaxNode>; + TUnitPathsCache = TDictionary<string,string>; + + TIncludeInfo = record + FileName: string; + Content : string; + end; + + TIncludeCache = TDictionary<string,TIncludeInfo>; + + 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<TUnitInfo>) + protected + procedure Initialize(parsedUnits: TParsedUnitsCache; unitPaths: TUnitPathsCache); + end; + + TIncludeFileInfo = record + Name: string; + Path: string; + end; + + TIncludeFiles = class(TList<TIncludeFileInfo>) + protected + procedure Initialize(includeCache: TIncludeCache); + end; + + TProblemType = (ptCantFindFile, ptCantOpenFile, ptCantParseFile); + TProblemInfo = record + ProblemType: TProblemType; + FileName : string; + Description: string; + end; + + TProblems = class(TList<TProblemInfo>) + 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<string,TSyntaxNode>; + 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<TUnitInfo>.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<string,TIncludeInfo>; + 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<TIncludeFileInfo>.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<string,integer>; + 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<string,integer>.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<TNameItemToken>; + 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<TNameItemToken> read FTokenList; + property LastNameItemToken: TNameItemToken read GetLastNameItemToken; + property EndNameCalled: Boolean read FEndNameCalled write FEndNameCalled; + end; + strict private + FParser: TmwSimplePasParEx; + FNameItems: TObjectList<TNameItem>; + 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<TNameList>; + 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<TNameList>; 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<TNameItemToken>.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<TNameItem>.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<TNameList>.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<TNameList>; +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<TAttributeName, string>; + 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('</' + UpperCase(SyntaxNodeNames[Node.Typ]) + '>'); + 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 := '<?xml version="1.0"?>' + 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<TSyntaxNode>; + + 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<TCommentNode>; + 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<TCommentNode> 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<TSyntaxNode>.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<TSyntaxNode>; + 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<TSyntaxNode>.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<TCommentNode>.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<TSyntaxNode>; + 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<TSyntaxNode>.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<TSyntaxNode>.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<TSyntaxNode>; +begin + OriginTypeParamNode := FStack.Push(ntTypeParam); + try + inherited; + finally + FStack.Pop; + end; + + Constraints := OriginTypeParamNode.FindNode(ntConstraints); + TypeNodeCount := 0; + TypeNodesToDelete := TList<TSyntaxNode>.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 @@ +<?xml version="1.0"?> +<CONFIG> + <Package Version="4"> + <PathDelim Value="\"/> + <Name Value="FPC_StringBuilder"/> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <OtherUnitFiles Value="Src"/> + <UnitOutputDirectory Value="Compiled\$(TargetCPU)-$(TargetOS)\"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Files Count="1"> + <Item1> + <Filename Value="Src\StringBuilderUnit.pas"/> + <UnitName Value="StringBuilderUnit"/> + </Item1> + </Files> + <Type Value="RunAndDesignTime"/> + <RequiredPkgs Count="1"> + <Item1> + <PackageName Value="FCL"/> + </Item1> + </RequiredPkgs> + <UsageOptions> + <UnitPath Value="$(PkgOutDir)"/> + </UsageOptions> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + </Package> +</CONFIG> 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 0000000000000000000000000000000000000000..6d59c6ab8b7068ab140a368dfc7373a46059cb4c GIT binary patch literal 17690 zcmeHOeQ;dWb-#;@FvfrhP6B~Y1#eOiLfY?7lxVg4WG&Wem)(^=ps<#uwIw4<%IeA3 zAy5~G0Y!CjI&G6CbmFuG(w4LdlO~i&TTPQfhcHZr5@s^PG%7==TRa`LqhUO)Q}=hy zz3;vI_DM#D@l5~V!ru3L=l$-v=bn4+$J4tW@O?~BiggGv!DyqebH*Ir!&qi#E)~MR zPKdUf<^8p|^oT$&^JdJ3MJ<0AoGXO*Si2=5-lpD8vwp~QL^jfSZKAZhD;x?W?WYb{ zfftE8k8Py$dPHdf`r={xDcK^#ku8pWKHSTC!;y%_3ji;G=hxaHd67_5<1GR&X}k@% zSG=Td-xB0M^$YQ+(s!}Vi^hV$Rw@B3d{T(#6wk3Q7S`=+18>u(g!r+C7Z2$Ah!+6w zWyQM)_tL(&tKQ>~m%w{N@zB+Zmk8_nc0;}h-iBKMkR1CGiI@~|PVMOVbs;t@o>Ol! zqW8xbc*nuJN%5|taw5>v6;38~-X_RTgZGN!;a2h@fq?F3;;p}FMP5j6$7b-Z(RgGZ z*Bc4MLcmtK4WI+Ow^Y3?xR<<OsJTDJz*~ngM2Y;OcrL#n1jM7@U7>iymAp_SK{qP3 z;rg`3y9oD+mkcNlU9Q3JCGc+a=nF^m_EMQQHJ+m{oYdP(Iw{dyU?qwdYL5`F3L4*p zNBLfeE)5?BKBDADHT)$FKdIrDHT=4Umo?mq%8uZk(q;`OG+fm1qZ)op!#~mRs~Ub& z!@tt-1~}*l*NQnn!+*Bkk$(>uF6H#1CVz5+!}$wfi}RW$|4$9KUgq$x)39H|Q4Qa% z;r$xEU&CM3@Ly_pQN!<OIJVKTp{(J38veY7zog+~mpf&@rr|8sfg{R4Pigq?H2j)| zufEdZ-vaCxtz5doax6ed(~RLfq~BruA;#ZeY%=~XuwP)ZK>88z3E(ql&z^mWv0(hq z8a@g91!l`EXZM&8IdQYNL_N!ic0uz7rJT4$+#n%v2kvBAP*=Jv;zwgEgh|OS<fzR9 z_lS=O8h?YpCxFSevXUbN#SSGu4f$P+g;)k2W*iVp!26Y)@MkrAKd`$k&Mc4<VS&e- zaw5ue2i@dET(q&2a6({u=d_@%bXmmjR{Z_}3j87kB*ZU(d&G6zmbZXU08?8|F~)oi z{9nLsd(vE%vYbc@gbSyf_>ArKoahz<w*1p#yNy31b}PJ~u5?+%?=}2xyNYbf00~h6 z?h)6sZTA4504CeU7)#qG8E4tI4=GIk{JO%YfWOZ;Cr$#t2<&c)!F5rV6I->m+>TzA zDJQmxPuRG?KBU{67*t*)TohTGQxatxSH(^n4~a<|Zx_F5;~nC08}Af<ZsT3zyEeW{ z{J_Tdh`+IMO}uR5J>uULUQk!MEaLYc_-)28^Q&3^7T^=&<Lu7_a1TZT#ciJDH*ml2 zVl3mf#&|Es?Fg{jhx<@crkofPa51Nx7*`{P{Ig&5DfxoB(q$39ZTNi~I{j+r`T{W7 za}ngPaJ@IMov$;N{r(29+lB*R%antcotT^wSnfD2s4HC-@uU53$JJEtXMu#c9ry&U z6k{b|xBdoEIOW8Qkh2%H%M>3~@&$FJ%OZZ);rCV6e-KEB?`!&h$oL@p`FX~NIEH`5 z_%QqVO~#)S6vMw_EZe>T6W9spqp|s6V7Hz3Q&pUD;sMPMN3?kUEp41WB&@x9P8=1z zcG*YJHcQW=qGaPaagU9^Xzw9%;<trtCHdqr@u1B)F6I?pP*=Jv;`bPSHQ4VLzY8S9 zA=NJO|AUNwkK6dD!Zd$A2JCL{?{itoa^erPe)+OCPkv3C^B>pd$v@Kk@O2SUnsV^& zr)~TV(Qo5Fw#W5?lF?-mzwP+_9Jcwz6F?X<z&+wdj^Y0SJ^@Va@*x;c;5qf(CBW{s ze3OcD%874kefK10K1==->ag&)L{Q-cb*0N9e%9PON&-sRRM*f<y)o03?aED!%pRyu znloL~jj8?h5rABMVtQ;mQ>g+SnCf~Lc3&x5tC)@P$$h=E;}fIxM%PSZq{}54njAMf zr-x_6!Kv}ll$q#Gh*B{>ST)KiGv3{v5Cg@*tvib4T*{1fH)82P`qp5Yg&?KOV5qwh z45e=k1talDA{>h((l(5zMYcZ!J;8AIt)W0#^zNz}xQlf6%p}r{U<ArS(P&y^1}phW zwVWT^nlh8!?ZL1pse%E%s}wQ=1G2g($_8U798KSfx6N20O*v|U-dOi=gEZq=Ae~Gm z)4_;HRn1WMOfV2g<TBMvDj4esbR+_SKss9-g8ebR=?I6?gT~HkDu~-~h;B(=cY8=w z`iteNWm_=bJrjz?ChC*>%&}B3Lb}p3W@?z)66Cf7!ySo^P#_XWvx)@lkCUz>Y=fTy z_%AMMwS(rKiQ2T;sF{bS>ttg9n$u$X-~lsbhN$L%AkJ{3F?<-3kX0PD1Vy#jd%KaX zQn_&VOvHb1Zz!A!g*woxvXOz0Q=w@0mMx)3I#sKUn6+A5m58gZO@}g_>70Rf6?cIg z135w5(UrOF=%;WRF4~bFtW-0DS*jtfY6u2rCntvw)JLf)P}~j^LGCLXhQ?0FDl9{Y z7h+x|(`RJSy~fV0QL5&PgHW9WIUGo*EVg}h%x@2K>73D*85*eeX9jZvh}cv(=&mPx zaJWHrMQoeE3As7!jQn7}>X;i2gF^0eHO}R|?0}IO94cvLA}grP4rD5o>aG$T7N#x< z$C`9<<;=<t_7%Y*x5if`4Q2|Yio6+YW(9*<usV9FNWOwX<W<C_yG^SUDrL$BhDRzw z{#@B;tL2saoiHgvPDOybwJX>58|8ep(pN4PKqS|C%!pOl2h5kFtzc9tnXN`O(>p-w z$+?l}O6m(nwZE9l<Z@+{0F#3G-CZL~Nq0ub=N@-jz3uf-U)~tdDx}Upg;tPy`I$b< zrr9EfPI)LRLp(yAfgxuVLc`mm9HYHPU$JcP*tE#efR`LwA^f2~m5Q!10^+hjzEa9m zv;E*TjRI?=VE)GF%_*K#NnNHHYf+O-MIZ5U(U+lVA<7-4jooN<>rg%yo|-keb9Hv_ zE~%ad21SJB43`I2EV;wTY(rht)q25m)P-m+W2%c%S4Ytn*T9zLJoa%J%Sh@lPeGTZ zp7JVoW7K`IU{jsU9>T06V=zYDk!<1w1J26GeB+Lx%m9KsW(^|CW!4p}_Mn`t;pzTN zr9WHDp<80qEi^n`L^)Gei|7Vgds8v$2^e9Kn(A+d0t$}wgP+8Om(~bYs<6PSRjZ&g zje@l@Rj_`kWwUoEKaj)RTs5&)1!JEGb_7C!4k+mBH!`_YS1^e6mX_SUY9>Fx_pyk) zFIH(`7~ERzhd9=ejFGsI#}W~vuBW*);;toO?N)5SezTUv7<IqBDmE9kMm!h6go0|+ zvenFNa!hABQz{vQR6vdEH5S082AvaE<GZ;K+u`(1oJKZ<NK>0V#_-YvwQ7Vn^I5IE z_{Y`YmWzKgS91wA0j|DB*Q=iA=uzEF5$*1h6vcwvK*nk3N4vK;ZT(`=Xc(Knk+I=M zZF*{a(yTYI<&5%<55V5d(XJ_!#-<P<6h#Q}#wuuSh_D+?ihj)f*aoD`aG<+^ox^I| zQP=*ew^*b#JY_}#*q%ZyFQ2^4jK}2`H6F)qH-sH!2s_M@w!FeVxwWenDqAsp<WR4g z@nrW*f=6^bf!!g6D=$x}I56E}FPI4MJ~b9eLp^T@lh#;qEqYZm5kzxCa;F-^_Kx*w z^(9Es0Y$KlJHb`njKG(PAk|3QN7@;4g>l{&n~CsB!iX-65|ig|xIRI?kI^nVh;1|5 zLN}pQoJMO0x|MFjbQ?)nw~<tW3?v(KPBFcVUI6T{VpsD8qc%|7VO7QVg?!GbjV1m0 z8n%A5?MAsmTSvR@>_9QQtyVGas3`^l#3*k!a<prQJ&Cl#pjse}haerK*)oCW0W<<` zrL_zGi@}jm;jDAKGVrzzeu;P24TL=G$lxt0&|y@!=gU=0)UxYUXa*q%shZEa#36`z zKe0VCFl3~{&82x;l!`PJmeQ!Jtdzw%(#>{K-zD&R5y+!03DtGmWyD%xnJ@PBRSbF` zl5;Ppv^FD%<)oYE#wOw&7!4f8*!W^oLu<ZVS<NWMLn1-JMz1<F%<-lp;~Qefb=F8p z(i=~N3tO*Z98)C88<kWdDWeLnjZR&%uo=S(5<bkxm{$`|!6+2VyLzeL)sivNJ&yN2 zD!&>L?`77=^J;<HLQPL0iiqLKnQ?rBZPZ6XxQ`0Cw&2}}>rV9rMWa45J7K1R&5w2l zg$f3sbHC=F&x^Zzx~<h{f$WQkOsY&-O!N}y1@N1x>4;@rOb~Bp%r+@@0ZmftZ(oGA z3aN6OFL7nih4Tch;e82#zn1X+rku24Qq@g=k*Ew9ef;jnB)E!X)#47kv)~OjJ5;7u zA=$a=p)5e#6-!(yR`C8<9Hf^bRuc?dKzF*^RY@HT2F2L;zA@F%N~#<TxdphFy`M)M zTtJ7*ZP2-Wexa-9O%+U#4Zd)-**mj7E1J~6KbRD*sKH>DL8K-+>sC$%R_LS<GPcT{ z?MZuJ0$#XA$i1TDEoms`F8TMc3s|$Y14Z2zbW)IiRkib>xnCX|^`Cim35N?#l61~E z^TLsnxT7>rH>aGNxl?!lNItQ0S$=8GSe_d?Ggml`5^3Y~%z9ksjHS0*=Z(|2&Kpar zsN{cZ4&tFRNB`S5yAh1}q0?u}5y*}{a9UjXg{PqWS^B7RZ0OZvg;Q)6XQhW1W~1Q0 z(6f%}XSCi%_$n*}X)v!k`oI}sUM4lqf9PyE$HjL(ykHJ0#ZMnA{MfCyjSFo;q37^7 z?z8h~%cW=U2sk8L$Hk5eY`0Hj`%cRC;px#s>%{Cwxd2)@*Siim+10adu9utylUn9` z;HzbRu<YxFLm-{K_*rVsoN@Bs=5RgEW!BFhr=EG1vYUT8XPlZZoSGk6#xt&f9esMf z1ih$WeG8N4jg#|*C20VQ=ZBVj>dDg0sMc8W87GfEuq+O4vCNz=ub+E}x?R-@lQ{}t zG7+zQWD*XN?N<F?(E{M~(FNbJoo8P#mZ$~kyO$bmM-MFd=H5Aqs?azXFuxfMTITBT z{JyvDvYjaPA!aB(?1njEC!fP#XP%?}hC11Fiy@z%!t*(D^cnKMIYzaXDAM-+wF+}; znb6#PiYVw5WBKh4m^RNtfE+r6C(Dip;Vc$Ne;CW;kJ*>!jZ@DH@%H7=`W!Xdu}Rvq z40~An>9?<+dxz?_$^%QUV*ttcpIwA0c7y}1CygxQ2)A8DV&U@F!>>H31%1DxTeE8A z0g|w^;*&Xl!(-(aFuS7a`s{+5e1e7@eLKAzA1OBq3UX^6qR9aAYu$wk_~g?#+&eKf zaxYC^_}`VR!aRR{{MwSMLai(pdKcZy*|;Ht&8}3V*CeeI;>xB*@gxOev)n0rmCGjj z_T)U12%q2t1wbo*{gdc=RG4L14^SJU@4;~t9<Aa{8|B~;9C3l{J2u(`qo|Kt1<j!n zJq?7<(vWSu*h1@Z{Dtan6(t)z0YqmDTE(k2y8aS*4y;u~Z1i~`I@Q@KUboTXFrB^y zwu+Z*G=^g}bdIG}e8onmfg&uUFX1)(HuL>%M)bvZn9(8Rdl(%<zMBz!jg?QI0g_MY z?7;{>{h=*;9%z(hKS5q+MBl>6f1CNM{$8L~L3NP-HjA$y-^b{0kxO1T5P5AgpBs?q zGTi&|YZdtHt)9~T7=D}iJdV_SC+?-bM}WrpDe?9*YC}%G+RP_5?qx(hpT!S-g#1QE z#0fFF3Aw>2fL!{Nyx7OG1oEwnZbRPBs0VqTQ4aa-jOfWWMgz#{hu%kCU{pmu$Y>|> zBBS3xPK;LWfjbz{34;nF9BmR*s#R=3{wYScAg6E6tvC-PaHfe6oj0Hsw4%jAkZ)S~ zjKf`wC`Q{D(bKybb?zOXpnjwDzh~h~pJyO->Zgc(;I;VZ95J1paFTw47{dk}I%DWg z`sv{o=D43*ck2|OYYSDlLZbFk!Z2HvL;XRi6~7i=4|1=vc}OW;f?tb|`rMmdSEBW} zw)hs2Q_r}QU#W&;z*$00mbufY;!x=pAN97^o^LDBWz1<?k+Y;Y6u&J#;*iJPsY8iq z?6>%iBe%Tj@EVFkBeTV~8@bn>KUExxKxwlQ;ND7aDA6VeT6|;3t@A$?10#?+9EqN^ z_=xFEH!2Rz0IP8VibJzPi;v>iYtJslp{FfA8mUSEWTh`F5d~?BuMN4k?LSi-nyFiS ze&pVCwQ?)XdQy+qo^HjthB=gb)3oBysFHE$)$=EcLo32+<KhLyp^Mb;OC_Orl#+{7 zXwtZll8lnjD3FpbDhb8Bl)R`U6yZt_DL|rlmXfTJQ1nX4gGxfNDkaY-2}P!qEGY@a zp_Kd@8G=MnCnY5%p~#Vv!%9LtDLJkr<U=WW&cpdfk7U^+xrQ38lGJmjNAieA@*R)l z=N`$W<UE(=fJbttM>6M;{FO)YFG@n=LfY)pCMhZTh)2?;B+fV*^>7|g5*jH|&ofFw z<3dXQRY_<RNXdE%0hOd=i${`H5*iVbQ}=KlP!fuH$@xPM=LwJG2Oi1adnEtlk^I6V zS@K9OqCi$j+Ox?ciFzd4Jd%4nlKn2p047RaFFW_taz^hEz6E8<)tcY+7ian=COSul z&Ed|;+6qtTU+dt>3?J0mBM)lLVryLU`)ebO`mkA_tlzhXcKv?;w2O6sUkLb-GGhfb z{+i!(m8$t`r24@4q<>;+a^HPZjZp{K==>E*Tm4P7oxh&p(NVwpD?3iEy~px&aH=-7 zxAwjiO;6V+-={6CVq$!<e*Wz+r)0PJ-<LN=ChEhJ=U@3~9hFZV7M%?hxZ4XW#We+z z`vZhiqH|z0<hlzwcjam|zrrvfbvV<d6*~vfU9a{5Xie3u`c=p&O^3o(G4lP@jV9vD zs_oh}*W(mfvs+Zpe@;$MIHa&bgT%R~E`CbK(^e|#na`*T-QUFg{?&c$DUR97?OQcl z;cJ!OI^5v^8@WFQ(u}*BB59kysg|{u$Hy1Hb1dil%JFednw8#@0{*!2-s<L}^kHP} z_FCT}{O_qo{;sh0%GAdIvF1re68X##PeJlTtXTW7pf9XOp;X<457~V}o?fDmk&0B% zX(wJ0FshDKxcY(D)%1A|yIM;9>SU|mua2^;ronyS)xUSDabS32HL~a6;c7(Bp~KaP z?&>jk-^Bv!9N`*i@2*gufV17^SBH33vsXI==jXWsy}cTD#ehFYK=C@Ip4)*)ACIjl zw1w9Bb?X6tBGwK}c^6TAF>9{Eng!3LZS@Iv&1=mHCah$)T*{hl)aJM5M`S+r!kP`S z+G)Gf8i>3ut+Jx+ogS&}tDD#$3xd<LGh_8bBlT$$o681^X6okt1Jm;9)HI3lukc6i zWkI9f7#^RgOH8OXiS1B*lm(+xlXa<Ud}>nI^9cQm1r=J<pM~OfLq)xHv06?BscmTu zR>*%&z^X0j@XXBkzDXACZPe@3idAMEYvTOiB}7fxAH0OnKlf2@k;*5-AH0O9ml(W~ SeDD&&Z#Dd$_5bQ6<o^KvpS!OB literal 0 HcmV?d00001 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 0000000000000000000000000000000000000000..85f532be24237483202c8cb1531e4c857115ba78 GIT binary patch literal 10881 zcmb_i3viUx6~6c1-DC+N@<^1x62h{8uz<*0Kp-z5l2?;3m{J=TvOq8-m;{At6%=GD zwNsy+X?;vbJGLF`W2TNXb*$Lhj?;FuzD8ST+ELqDN82jxv}nrE@4JtG@6Rq|DY?v^ zd+xp8J@=e*&wuX!-_X*s>C$CO4<3^uA`XlViH<o!Y?TY2{Nulmg=>TmNAT--?~QxM zqn2`9+hBip?~dxd-926D{!P8zgJJe>0uhtQd1YCM`Fm0W@7@0Rx|tjg6}0Ui7)<Ye zVezrAJzxE7$CYn2_80VR-383?;=^zM_NN=~{l?w%HcliqG9g=5pNA0^S)gd4qESUh zDO#jxm!hK;ZDl1VNYH||j<)u?#v_<4$3-YB48ublSFMN?{1*k5oe|4K6~?p8QK~7_ zlu;TES<yl>?mgoQ8RgH)2*xBOB4leNY7D38emlpi7X+5N@<SF|ZYSGX3B4$QbsOb& zVv$<2B%@xDm0;@}lI-N%t4?tj3gxi1(gl=TK$cLoaNNb_5;h|MutIYCZkAe0yV>7p zy`f<}L}4(T(E&#o7pOkdJK9|iTj|4#efVf4s#wu6ie8}TSVhMvI$qHUni{3OS1t3p zW!|vNo0j>9Wj?XYr<OTxnSUB4WNi#d+vA6^j%pkK40wcDCJGpHbiy3pDmsHbNeAXV z<us5Yh@q$wg{;kpvrmWcnIfZ+@R{jq>MU1cnGbS%*SQUBbY>aEW2TXNa_(MV3H><C zRjMqptB22%QPP$wx=hjKie9GZ3Po2cx=PW@6<w|98b#MCTBT^UuMCY<T?<{a{gmK5 z0?xSijG6Df#@>v(>^z;oGX3i<9*NCa+Ud<Dg~2ck<n)Ekq=4<uL*)5E#yAQ)tZSZ) zlhbv#>6HCus<6qiRP9ljqBDKDs>x?X$p5NybPIXKonZHc9GT5NTS~#G!%nOKC+G1@ zD=~wsP?xs{j?BjN?!Ny0)jfUNuF;?{gnyz|B=NSO$>ltMVebS*CfGNJPdZg#;le!N zr?Y|bffABETaRM)XG-qpetU?V?d9ZYY{z(thig-VDIrHkB51J8)s>=gP%p+~K2p=S zw|7v;Vjs8A;Qk7ES{!{7Zc6V1Y>W?EX<#24oxPz$=#dN9tTJP(QI`arCt6B`C&gHe z2#b0!tp+{@^%3|datFzMBoC2%pX4c$pOE~V<ToU5lKg?>1CmcbRG|(zw}CG+-{D}A zj#T@DnxzxJC=Jztz^)wS)G6;abbp;gazQzT*djNywYSzct*_ox-%wlEx~ZwYJ<*wH z4|H}WIy)1I&c^ztL_>4a`pwO)wHe0e)E+C{6nDa|;O_Hubb4_Hsl+B<I8kjfGQ&;- zz7{p!*+NnSFCcI$fRin7zyNPVjW7(!Szx?4_a%}TNcU_9xI~AJ6gLrEEyN*I@U3>U zH*^=8UXt&D<ZQVQOgJA;J^|p<oF!MpY>=wvnt;>J=E<7Yx~lfN#A$9G&Vkf_CVpPL z3^bg$ZZ{%(@;Gbl{Zyh>i0`37pLGo%TI-q&_)&u4njfKpYYO?G3vcLl(qu8{v+OYC zdDMkbabVaWdk4UGIZ0Mc3b<xj-ma;ttxZ%lwbknh+9li-#bw15UBaB`#rcs?n9>PP z$XK~r9+CAD`dMDZPeqmvm~u3&S7H}vU8Q)PNO<LUsNfa6^PqS`catXhn18?yQ$9kS zmsjvY%9kW~r7P%_wddrORDXYJe`nwJ&NI7*izM*#=I{~w7k(^E*Yq5`p~@)~GTOO5 zm*rdq2Jwc-xsUN2w&OekqQ>O|LQXM05A#J?m9eOm&o5E<$)IBrJG*!6tkQ<J30a{N zGgKQ7@PV~LOh%1o(}r&hlk7%K@iz)z6l$ZUqjomx4)l6SW{pb;Fl7mNY}D{M@(TcN z=0w>O+^7}#Z&XW5UDN*;!4+6I6TuZax4<#0jVbF<I}tn;aO;=~-!b(BBZ8YzJC0%Y z_ma$#R~czwMGAagj_C(*A1BIdgN|8rj*e-lZ>k$E?6{78NT-3bCQkKD+(iIP+=JRN z@tf%NlH)*cBEXbez~^;7J_z6=oG7o;acl(0%kws|y;(yO=a|5>vD2}jHMY_}!j4iU z7<(sbWvtG2e8>wE{po?dJval5#$H(7O?Z_M_oF^}%1`SD(d#A0gZ_{JQyvGO*Y-aT z;4e5)-WA;b`FZ=MrlGE?DgT}4F=w4I&EI*vODktQhuYcsThZ$!CxHH%08?H8ABolu z^VDPJM*x1xiSiNsnqdUU1$kRnTL)-!$8h#}kgN~zi@})#JU-T*K5tVADEuxphlS?d zhC6P3kpaI?FaqO4)Q&IE>1S%50dcltNE;%uZbLfNC1h!YYO?%?B2d`YIKC4_*0ra) zdw?spxRVCQ6sp26#utR*b?tqFsh);(?~cKpLYDbrLo|~B{4T=JE91!-YV7Xy-_4{b z251cjC-aF7Yt<&|u;)7CjS#R0CW4>Db__&TkV}xvB+)_`+F`ACc}B>^1n6>LKKKP} zF9eZ`$*mw+MY0Y*Z!#ljbik-d8Ck1|)8)W=@bzqO1d)y8+DJB$@Kp55c;*(=^rusU zY5yHfip>D<6!gmIm{3(0_5*JpYuP2P!r(Uiw16q-E2!GDC*2E-$?sBhW1Q!NS5^sH zq{kb&d$EW~kW%ngl&7Xw76*;C_t}>slU1bH3j|+)ys{afk(!=#3VUOoGbwJsu-1~9 zsjxOZFxcO>Uq};tQXB+;MZXwG^>rsdFGLRyB}vsq_T?~cRiz4b`bMe~ykJ1x|DHBN z>E;?3BL!;C3eLF*fi5b}^igXgu^^;o$j=~0@@tTVZy>Ui5nbMLCILc@nyRLHfl2H- z%cry~(vzZQQbMgX3iR|(NIAY#i7zooK!hCP!zCHNsMLTwNj2pb_9*TIH{-kPOVV|v z&h&}kJv=XCx!xJeq|U5N#_zdq+}NKwC8t5gbjp;tYIBM=v0i@+W=%eeJSyy7AXs_! z?a^-!-3eAE`6V;kF=!t6yw2-I04~v57nyKWvgPV5b!n^q;%chfT;0%IvoVoq37{J5 z8k<`?)KLBg=nEM>X)7HA)+k<&@oCuLj5Ro8ag1$p#yS)~55008&xlTEtT>VC9q7hW z*q`3E5M#iErIgH9D*40XXb-1(0l<~`d9gZ9OKe{tr22~uT0-n_)~iI@i!mtzb*YQm zV^H+CMy=PVg)VBpK~W=(+MrR3T+}TF#dNPx^%}L<MIALLo+cV~g+?uLQTG^>xt~F1 zN&qG2FoAvBjDZyof`8PsZPZXp_h}=J#pX5LLVHN>Y7!k!Ix>H(cs({3W6wEbFF0e| z+g~|jFDqW_$z6TR8G8r(pG@0c>E*AdmbnNr|K`a26#VC=%@dg=f0-(Q&RdK*Ax<)- zBvIcxnC|aQ^|Yq9Ezz+VMllyUTn(`qR_mNCE%3~%BsjJiRLACH;B+Z;R;)yq7rPQv z$7TjK)}UBvREI_(HZv%D`IU*fFKQHGGlQCHWEK0en2xa`Vl#u9VNi^^O8mUomoy5o znL*7rDCTaBx=N##x~OFa#d{2m`m#nXb5UyzidjdaIyGv!i>fy$A~fo1aM1oT7u9M| z35-p{&x@r%!+7G67&7YfTA1Zx{4{JUIKq$_GO#WKo9n~U1{QGtZUbB3!*&>0!2bgV z#(2|<b{kk=1NIx(av!$azydpPvw^MhVS5ZLumy(=Y^@LLH?Y7S95t|7A2w)Uflav6 zz?k~93D+A~U>Ck+U=2R(D;l;iunP|uSc?z)s(}S|;b8-7_hAPNEU*hdFfcwwTDMya zEU*ht7#O2k!wwr*U>BY?u&aI8Z3Y(Dg=Y<{3xh14$)`)ezi7tT|B~XDfs>1tg1+pG zy#~H8`l7z5B{*mCIOA;ThN+*2tQX$~YCgms<3|^Y6z_0;Eiy1_^m*nwq6@wDLo5US z3&GVwe2g0Tj-o+_wEm=jC%}~B;G@yo&R2g4aXi|*_;%22ora7~VQ8PF6CW1+QVj;B z2%y5~p^?*RCxm9}G=biQpLnm8rPE~?t02IXIQZ!K>x6a0eEhulF3{rizHR9}gZK|7 z>1~6|U3x(&l4j+_sPU=nslPdS@oO-rNY6=ib@jV5mYNxBP$RF~2<gF$Y|E<%hUHhF z&a#{zHVsA^SkVH01a^aAI2%7N-V0i|J3TOv+JUb`V>E_4%%WRSE2DKl^#Pu3LKnd> zVK?e56INoZ&qxC+2EdPi37H_j7DBUiy3y!#IG0XL^+z0?j*hfW137iN$LRDxE}bsN zl!qLh9v&H;GF!bD3*_4B$IPNnqjt9Xx|}9FLol}b80xI8UX8Jz8EIg}FTsz%R%cAu z2cfx4c*QLGHfqO&{eWjj#_tJ+3GbuMGJzLHe>T#<iVwk$s0lYfXf6|un?;9EJ0{!+ zc(w^A35E#;1vyMui?JvMY$*mm0@;$gFatj?eiLY@dFw7eU*J$IGYeLrcGSNa&}{W9 z35NQ!QD^Ny6~>ZA8dz}&_z_S)lP?ZJXtqwvjZRg$bb_v;#?fj0x#+}i37)v#2@qB6 zbq8Il^XjeOvUO@PI(1l`bk05maOQeHle4!F4)=AT#`Qie#;QZ4_G=a1R!5#Jn*(lA zB5=>aze(GhAA##06_HYGhqyRpl=0iPL|<DrrLWijS47U@8v@^pdMvKA7VY4z1g;Vk ds-G&FBK22zn{BhENA>~3db>DiIBkhM^*@Xm`7Hnd literal 0 HcmV?d00001 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 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="Test_001"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="FPC_StringBuilder"/> + </Item1> + </RequiredPackages> + <Units Count="1"> + <Unit0> + <Filename Value="Test_001.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Test_001"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="..\..\..\Bin\Test\Test_001"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="compiled_junk\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Debugging> + <UseHeaptrc Value="True"/> + </Debugging> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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('<BR>'); + 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 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="Test_002"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="FPC_StringBuilder"/> + </Item1> + </RequiredPackages> + <Units Count="1"> + <Unit0> + <Filename Value="Test_002.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Test_002"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="..\..\..\Bin\Test\Test_002"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="compiled_junk\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <CodeGeneration> + <Optimizations> + <OptimizationLevel Value="3"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <UseHeaptrc Value="True"/> + </Debugging> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="TArrayProjectDouble"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="TArrayProjectDouble.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="TArrayProjectDouble"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="TArrayProjectDouble"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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<TIntegerDynArray>(A, TComparer<TIntegerDynArray>.Construct( + // function (const Left, Right: TIntegerDynArray): Integer + // begin + // Result := Right[0] - Left[0]; + // end)); + // Sort descending 1st column, with cutom comparer_1 + TArrayHelper<TIntegerDynArray>.Sort(A, TComparer<TIntegerDynArray>.Construct( + CustomCompare_1)); + Writeln('Descending in column 1:'); + PrintMatrix(A); + + // Sort descending 1st column "cascade" - + // If the line items are equal, compare neighboring + TArrayHelper<TIntegerDynArray>.Sort(A, TComparer<TIntegerDynArray>.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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="TArrayProjectSingle"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="TArrayProjectSingle.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="TArrayProjectSingle"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="TArrayProjectSingle"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <SyntaxMode Value="Delphi"/> + </SyntaxOptions> + </Parsing> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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<Integer>.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<Integer>(A, TComparer<Integer>.Construct( + // function (const Left, Right: Integer): Integer + // begin + // Result := Math.CompareValue(Right, Left) + // end)); + + // Sort descending, the comparator is constructed + // using an method + TArrayHelper<Integer>.Sort(A, TComparer<Integer>.Construct( + ForCompareObj.CompareIntReverseMethod)); + Writeln('Descending by TComparer<Integer>.Construct(ForCompareObj.Method):'); + PrintMatrix(A); + + // Again sort ascending by using defaul + TArrayHelper<Integer>.Sort(A, TComparer<Integer>.Default); + Writeln('Ascending by TComparer<Integer>.Default:'); + PrintMatrix(A); + + // Again descending using own comparator function + TArrayHelper<Integer>.Sort(A, TComparer<Integer>.Construct(CompareIntReverse)); + Writeln('Descending by TComparer<Integer>.Construct(CompareIntReverse):'); + PrintMatrix(A); + + // Searches for a nonexistent element + Writeln('BinarySearch nonexistent element'); + if TArrayHelper<Integer>.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<Integer>.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<Integer>.BinarySearch(A, 6, FoundIndex, + TComparer<Integer>.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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="TComparerProject"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="TComparerProject.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="TComparerProject"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="TComparerProject"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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<TCustomer>) + 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<TCustomer>; + CustomersList: TList<TCustomer>; + Comparer: TCustomerComparer; + Customer: TCustomer; +begin + CustomersArray := TArray<TCustomer>.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<TCustomer>.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<TCustomer>.Construct(CustomerCompare)); + WriteLn('CustomersList after descending sort (by using construct with function)'); + WriteLn('CustomersList.Sort(TComparer<TCustomer>.Construct(CustomerCompare)):'); + for Customer in CustomersList do + WriteLn(Customer.ToString); + WriteLn; + + // construct with method + CustomersList.Sort(TComparer<TCustomer>.Construct(Comparer.Compare)); + WriteLn('CustomersList after ascending sort (by using construct with method)'); + WriteLn('CustomersList.Sort(TComparer<TCustomer>.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<TCustomer>.Sort(CustomersArray, TCustomerComparer.Create); + WriteLn('CustomersArray after ascending sort (by using interfese - no construct)'); + WriteLn('TArrayHelper<TCustomer>.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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="THashMapProject"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="THashMapProject.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="THashMapProject"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="THashMapProject"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <SyntaxMode Value="Delphi"/> + </SyntaxOptions> + </Parsing> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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, TSubscriberInfo>): 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<string, TSubscriberInfo>): 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<string, TSubscriberInfo>; + TTelephoneArray: array of TPair<string, TSubscriberInfo>; + TTelephoneArrayItem: TPair<string, TSubscriberInfo>; + 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<string, TSubscriberInfo>.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<TPair<string, TSubscriberInfo>>( + // TTelephoneArray, TComparer<TPair<string, TSubscriberInfo>>.Construct( + // function (const Left, Right: TPair<string, TSubscriberInfo>): 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<TelephoneDirectory.TDictionaryPair>.Sort( + TTelephoneArray, TComparer<TelephoneDirectory.TDictionaryPair>.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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="THashMapCaseInsensitive"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="THashMapCaseInsensitive.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="THashMapCaseInsensitive"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="THashMapCaseInsensitive"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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<String, TEmptyRecord>; + AnsiStringMap: THashMap<AnsiString, TEmptyRecord>; + UnicodeStringMap: THashMap<UnicodeString, TEmptyRecord>; + AdvancedHashMapWithBigLoadFactor: TCuckooD6<RawByteString, TEmptyRecord>; + k: String; +begin + WriteLn('Working with case insensitive THashMap'); + WriteLn; + // example constructors for different string types + StringMap := THashMap<String, TEmptyRecord>.Create(TIStringComparer.Ordinal); + StringMap.Free; + AnsiStringMap := THashMap<AnsiString, TEmptyRecord>.Create(TIAnsiStringComparer.Ordinal); + AnsiStringMap.Free; + UnicodeStringMap := THashMap<UnicodeString, TEmptyRecord>.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<RawByteString, TEmptyRecord>.Create( + TGIStringComparer<RawByteString, TDelphiSixfoldHashFactory>.Ordinal); + AdvancedHashMapWithBigLoadFactor.Free; + + // ok lets start + // another way to create case insensitive hash map + StringMap := THashMap<String, TEmptyRecord>.Create(TGIStringComparer<String>.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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="THashMapExtendedEqualityComparer"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="THashMapExtendedEqualityComparer.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="THashMapExtendedEqualityComparer"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="THashMapExtendedEqualityComparer"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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<TTaxPayer, string>; // THashMap = TCuckooD4 + LTaxPayer: TTaxPayer; + LSansa: TTaxPayer; + LPair: TPair<TTaxPayer, string>; +begin + WriteLn('program of tax office - ExtendedEqualityComparer for THashMap'); + WriteLn; + + // to identify the taxpayer need only nip + map := THashMap<TTaxPayer, string>.Create( + TExtendedEqualityComparer<TTaxPayer>.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<TKey> :) + 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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="TObjectListProject"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="TObjectListProject.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="TObjectListProject"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="TObjectListProject"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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<TPlayer>; + Player: TPlayer; + FoundIndex: PtrInt; +begin + WriteLn('Working with TObjectList - football manager'); + WriteLn; + + PlayersList := TObjectList<TPlayer>.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<TPlayer>.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<TPlayer>.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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="TQueueProject"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="TQueueProject.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="TQueueProject"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="TQueueProject"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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<TCustomer>; + Customer: TCustomer; +begin + WriteLn('Working with TQueue - buy FreeSparta.com'); + WriteLn; + + // "Create" turn in sales + CustomerQueue := TQueue<TCustomer>.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 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="TStackProject"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="TStackProject.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="TStackProject"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="TStackProject"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\.."/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> 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<TPancake>; + Pancake: TPancake; + +begin + WriteLn('Working with TStack - pancakes'); + WriteLn; + + // "Create" a plate of pancakes + PancakesPlate := TStack<TPancake>.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<T> = array of T; // for name TArray<T> conflict with TArray record implementation (bug #26030) + + // bug #24254 workaround + // should be TArray = record class procedure Sort<T>(...) etc. + TCustomArrayHelper<T> = class abstract + private + type + // bug #24282 + TComparerBugHack = TComparer<T>; + protected + // modified QuickSort from classes\lists.inc + class procedure QuickSort(var AValues: array of T; ALeft, ARight: SizeInt; const AComparer: IComparer<T>); + virtual; abstract; + public + class procedure Sort(var AValues: array of T); overload; + class procedure Sort(var AValues: array of T; + const AComparer: IComparer<T>); overload; + class procedure Sort(var AValues: array of T; + const AComparer: IComparer<T>; AIndex, ACount: SizeInt); overload; + + class function BinarySearch(constref AValues: array of T; constref AItem: T; + out AFoundIndex: SizeInt; const AComparer: IComparer<T>; + AIndex, ACount: SizeInt): Boolean; virtual; abstract; overload; + class function BinarySearch(constref AValues: array of T; constref AItem: T; + out AFoundIndex: SizeInt; const AComparer: IComparer<T>): 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<T> = class(TCustomArrayHelper<T>) + protected + // modified QuickSort from classes\lists.inc + class procedure QuickSort(var AValues: array of T; ALeft, ARight: SizeInt; const AComparer: IComparer<T>); override; + public + class function BinarySearch(constref AValues: array of T; constref AItem: T; + out AFoundIndex: SizeInt; const AComparer: IComparer<T>; + AIndex, ACount: SizeInt): Boolean; override; overload; + end experimental; // will be renamed to TArray (bug #24254) + + TCollectionNotification = (cnAdded, cnRemoved, cnExtracted); + TCollectionNotifyEvent<T> = procedure(ASender: TObject; constref AItem: T; AAction: TCollectionNotification) + of object; + + { TEnumerator } + + TEnumerator<T> = 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<T> = class abstract + protected + function ToArrayImpl(ACount: SizeInt): TArray<T>; overload; // used by descendants + protected + function DoGetEnumerator: TEnumerator<T>; virtual; abstract; + public + function GetEnumerator: TEnumerator<T>; inline; + function ToArray: TArray<T>; 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<T> = class abstract(TEnumerable<T>) + protected + type // bug #24282 + TArrayHelperBugHack = TArrayHelper<T>; + private + FOnNotify: TCollectionNotifyEvent<T>; + 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<T>; override; final; + + property Count: SizeInt read GetCount; + property Capacity: SizeInt read GetCapacity write SetCapacity; + property OnNotify: TCollectionNotifyEvent<T> read FOnNotify write FOnNotify; + end; + + TCustomListEnumerator<T> = class abstract(TEnumerator< T >) + private + FList: TCustomList<T>; + FIndex: SizeInt; + protected + function DoMoveNext: boolean; override; + function DoGetCurrent: T; override; + function GetCurrent: T; virtual; + public + constructor Create(AList: TCustomList<T>); + end; + + TList<T> = class(TCustomList<T>) + private var + FComparer: IComparer<T>; + 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<T>; override; + public + // with this type declaration i found #24285, #24285 + type + // bug workaround + TEnumerator = class(TCustomListEnumerator<T>); + + 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<T>); overload; + constructor Create(ACollection: TEnumerable<T>); overload; + destructor Destroy; override; + + function Add(constref AValue: T): SizeInt; + procedure AddRange(constref AValues: array of T); overload; + procedure AddRange(const AEnumerable: IEnumerable<T>); overload; + procedure AddRange(AEnumerable: TEnumerable<T>); 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<T>); overload; + procedure InsertRange(AIndex: SizeInt; const AEnumerable: TEnumerable<T>); 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<T>); overload; + function BinarySearch(constref AItem: T; out AIndex: SizeInt): Boolean; overload; + function BinarySearch(constref AItem: T; out AIndex: SizeInt; const AComparer: IComparer<T>): Boolean; overload; + + property Count: SizeInt read FItemsLength write SetCount; + property Items[Index: SizeInt]: T read GetItem write SetItem; default; + end; + + TQueue<T> = class(TCustomList<T>) + 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<T>; override; + public + type + TEnumerator = class(TCustomListEnumerator<T>) + public + constructor Create(AQueue: TQueue<T>); + 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<T>); overload; + destructor Destroy; override; + procedure Enqueue(constref AValue: T); + function Dequeue: T; + function Extract: T; + function Peek: T; + procedure Clear; + procedure TrimExcess; + end; + + TStack<T> = class(TCustomList<T>) + 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<T>; override; + public + type + TEnumerator = class(TCustomListEnumerator<T>); + + function GetEnumerator: TEnumerator; reintroduce; + protected + function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; override; + procedure SetCapacity(AValue: SizeInt); override; + public + constructor Create(ACollection: TEnumerable<T>); 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<T: class> = class(TList<T>) + private + FObjectsOwner: Boolean; + protected + procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override; + public + constructor Create(AOwnsObjects: Boolean = True); overload; + constructor Create(const AComparer: IComparer<T>; AOwnsObjects: Boolean = True); overload; + constructor Create(ACollection: TEnumerable<T>; AOwnsObjects: Boolean = True); overload; + property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner; + end; + + TObjectQueue<T: class> = class(TQueue<T>) + private + FObjectsOwner: Boolean; + protected + procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override; + public + constructor Create(AOwnsObjects: Boolean = True); overload; + constructor Create(ACollection: TEnumerable<T>; AOwnsObjects: Boolean = True); overload; + procedure Dequeue; + property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner; + end; + + TObjectStack<T: class> = class(TStack<T>) + private + FObjectsOwner: Boolean; + protected + procedure Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); override; + public + constructor Create(AOwnsObjects: Boolean = True); overload; + constructor Create(ACollection: TEnumerable<T>; 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<T> } + +class function TCustomArrayHelper<T>.BinarySearch(constref AValues: array of T; constref AItem: T; + out AFoundIndex: SizeInt; const AComparer: IComparer<T>): Boolean; +begin + Result := BinarySearch(AValues, AItem, AFoundIndex, AComparer, Low(AValues), Length(AValues)); +end; + +class function TCustomArrayHelper<T>.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<T>.Sort(var AValues: array of T); +begin + QuickSort(AValues, Low(AValues), High(AValues), TComparerBugHack.Default); +end; + +class procedure TCustomArrayHelper<T>.Sort(var AValues: array of T; + const AComparer: IComparer<T>); +begin + QuickSort(AValues, Low(AValues), High(AValues), AComparer); +end; + +class procedure TCustomArrayHelper<T>.Sort(var AValues: array of T; + const AComparer: IComparer<T>; AIndex, ACount: SizeInt); +begin + if ACount <= 1 then + Exit; + QuickSort(AValues, AIndex, Pred(AIndex + ACount), AComparer); +end; + +{ TArrayHelper<T> } + +class procedure TArrayHelper<T>.QuickSort(var AValues: array of T; ALeft, ARight: SizeInt; + const AComparer: IComparer<T>); +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<T>.BinarySearch(constref AValues: array of T; constref AItem: T; + out AFoundIndex: SizeInt; const AComparer: IComparer<T>; + 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<T> } + +function TEnumerator<T>.MoveNext: boolean; +begin + Exit(DoMoveNext); +end; + +{ TEnumerable<T> } + +function TEnumerable<T>.ToArrayImpl(ACount: SizeInt): TArray<T>; +var + i: SizeInt; + LEnumerator: TEnumerator<T>; +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<T>.GetEnumerator: TEnumerator; +begin + Exit(DoGetEnumerator); +end; + +function TEnumerable<T>.ToArray: TArray<T>; +var + LEnumerator: TEnumerator<T>; + LBuffer: TList<T>; +begin + LBuffer := TList<T>.Create; + try + LEnumerator := GetEnumerator; + + while LEnumerator.MoveNext do + LBuffer.Add(LEnumerator.Current); + + Result := LBuffer.ToArray; + finally + LBuffer.Free; + LEnumerator.Free; + end; +end; + +{ TCustomList<T> } + +function TCustomList<T>.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<T>.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<T>.ToArray: TArray<T>; +begin + Result := ToArrayImpl(Count); +end; + +function TCustomList<T>.GetCount: SizeInt; +begin + Result := FItemsLength; +end; + +procedure TCustomList<T>.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); +begin + if Assigned(FOnNotify) then + FOnNotify(Self, AValue, ACollectionNotification); +end; + +function TCustomList<T>.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<T>.GetCapacity: SizeInt; +begin + Result := Length(FItems); +end; + +{ TCustomListEnumerator<T> } + +function TCustomListEnumerator<T>.DoMoveNext: boolean; +begin + Inc(FIndex); + Result := (FList.FItemsLength <> 0) and (FIndex < FList.FItemsLength) +end; + +function TCustomListEnumerator<T>.DoGetCurrent: T; +begin + Result := GetCurrent; +end; + +function TCustomListEnumerator<T>.GetCurrent: T; +begin + Result := FList.FItems[FIndex]; +end; + +constructor TCustomListEnumerator<T>.Create(AList: TCustomList<T>); +begin + inherited Create; + FIndex := -1; + FList := AList; +end; + +{ TList<T> } + +constructor TList<T>.Create; +begin + FComparer := TComparer<T>.Default; +end; + +constructor TList<T>.Create(const AComparer: IComparer<T>); +begin + FComparer := AComparer; +end; + +constructor TList<T>.Create(ACollection: TEnumerable<T>); +var + LItem: T; +begin + Create; + for LItem in ACollection do + Add(LItem); +end; + +destructor TList<T>.Destroy; +begin + SetCapacity(0); +end; + +procedure TList<T>.SetCapacity(AValue: SizeInt); +begin + if AValue < Count then + Count := AValue; + + SetLength(FItems, AValue); +end; + +procedure TList<T>.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<T>.GetItem(AIndex: SizeInt): T; +begin + if (AIndex < 0) or (AIndex >= Count) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + Result := FItems[AIndex]; +end; + +procedure TList<T>.SetItem(AIndex: SizeInt; const AValue: T); +begin + if (AIndex < 0) or (AIndex >= Count) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + FItems[AIndex] := AValue; +end; + +function TList<T>.GetEnumerator: TEnumerator; +begin + Result := TEnumerator.Create(Self); +end; + +function TList<T>.DoGetEnumerator: {Generics.Collections.}TEnumerator<T>; +begin + Result := GetEnumerator; +end; + +function TList<T>.Add(constref AValue: T): SizeInt; +begin + Result := PrepareAddingItem; + FItems[Result] := AValue; + Notify(AValue, cnAdded); +end; + +procedure TList<T>.AddRange(constref AValues: array of T); +begin + InsertRange(Count, AValues); +end; + +procedure TList<T>.AddRange(const AEnumerable: IEnumerable<T>); +var + LValue: T; +begin + for LValue in AEnumerable do + Add(LValue); +end; + +procedure TList<T>.AddRange(AEnumerable: TEnumerable<T>); +var + LValue: T; +begin + for LValue in AEnumerable do + Add(LValue); +end; + +procedure TList<T>.Insert(AIndex: SizeInt; constref AValue: T); +begin + if (AIndex < 0) or (AIndex > Count) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + if AIndex <> PrepareAddingItem then + begin + System.Move(FItems[AIndex], FItems[AIndex + 1], ((Count - AIndex) - 1) * SizeOf(T)); + FillChar(FItems[AIndex], SizeOf(T), 0); + end; + + FItems[AIndex] := AValue; + Notify(AValue, cnAdded); +end; + +procedure TList<T>.InsertRange(AIndex: SizeInt; constref AValues: array of T); +var + i: SizeInt; + LLength: SizeInt; + LValue: ^T; +begin + if (AIndex < 0) or (AIndex > Count) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + LLength := Length(AValues); + if LLength = 0 then + Exit; + + if AIndex <> PrepareAddingRange(LLength) then + begin + System.Move(FItems[AIndex], FItems[AIndex + LLength], ((Count - AIndex) - LLength) * SizeOf(T)); + FillChar(FItems[AIndex], SizeOf(T) * LLength, 0); + end; + + LValue := @AValues[0]; + for i := AIndex to Pred(AIndex + LLength) do + begin + FItems[i] := LValue^; + Notify(LValue^, cnAdded); + Inc(LValue); + end; +end; + +procedure TList<T>.InsertRange(AIndex: SizeInt; const AEnumerable: IEnumerable<T>); +var + LValue: T; + i: SizeInt; +begin + if (AIndex < 0) or (AIndex > Count) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + i := 0; + for LValue in AEnumerable do + begin + Insert(Aindex + i, LValue); + Inc(i); + end; +end; + +procedure TList<T>.InsertRange(AIndex: SizeInt; const AEnumerable: TEnumerable<T>); +var + LValue: T; + i: SizeInt; +begin + if (AIndex < 0) or (AIndex > Count) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + i := 0; + for LValue in AEnumerable do + begin + Insert(Aindex + i, LValue); + Inc(i); + end; +end; + +function TList<T>.Remove(constref AValue: T): SizeInt; +begin + Result := IndexOf(AValue); + if Result >= 0 then + DoRemove(Result, cnRemoved); +end; + +procedure TList<T>.Delete(AIndex: SizeInt); +begin + DoRemove(AIndex, cnRemoved); +end; + +procedure TList<T>.DeleteRange(AIndex, ACount: SizeInt); +var + LDeleted: array of T; + i: SizeInt; + LMoveDelta: SizeInt; +begin + if ACount = 0 then + Exit; + + if (ACount < 0) or (AIndex < 0) or (AIndex + ACount > Count) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + SetLength(LDeleted, Count); + System.Move(FItems[AIndex], LDeleted[0], ACount * SizeOf(T)); + + LMoveDelta := Count - (AIndex + ACount); + + if LMoveDelta = 0 then + FillChar(FItems[AIndex], ACount * SizeOf(T), #0) + else + begin + System.Move(FItems[AIndex + ACount], FItems[AIndex], LMoveDelta * SizeOf(T)); + FillChar(FItems[Count - ACount], ACount * SizeOf(T), #0); + end; + + FItemsLength -= ACount; + + for i := 0 to High(LDeleted) do + Notify(LDeleted[i], cnRemoved); +end; + +function TList<T>.ExtractIndex(const AIndex: SizeInt): T; +begin + Result := DoRemove(AIndex, cnExtracted); +end; + +function TList<T>.Extract(constref AValue: T): T; +var + LIndex: SizeInt; +begin + LIndex := IndexOf(AValue); + if LIndex < 0 then + Exit(Default(T)); + + Result := DoRemove(LIndex, cnExtracted); +end; + +procedure TList<T>.Exchange(AIndex1, AIndex2: SizeInt); +var + LTemp: T; +begin + LTemp := FItems[AIndex1]; + FItems[AIndex1] := FItems[AIndex2]; + FItems[AIndex2] := LTemp; +end; + +procedure TList<T>.Move(AIndex, ANewIndex: SizeInt); +var + LTemp: T; +begin + if ANewIndex = AIndex then + Exit; + + if (ANewIndex < 0) or (ANewIndex >= Count) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + LTemp := FItems[AIndex]; + FItems[AIndex] := Default(T); + + if AIndex < ANewIndex then + System.Move(FItems[Succ(AIndex)], FItems[AIndex], (ANewIndex - AIndex) * SizeOf(T)) + else + System.Move(FItems[ANewIndex], FItems[Succ(ANewIndex)], (AIndex - ANewIndex) * SizeOf(T)); + + FillChar(FItems[ANewIndex], SizeOf(T), #0); + FItems[ANewIndex] := LTemp; +end; + +function TList<T>.First: T; +begin + Result := Items[0]; +end; + +function TList<T>.Last: T; +begin + Result := Items[Pred(Count)]; +end; + +procedure TList<T>.Clear; +begin + SetCount(0); + SetCapacity(0); +end; + +procedure TList<T>.TrimExcess; +begin + SetCapacity(Count); +end; + +function TList<T>.Contains(constref AValue: T): Boolean; +begin + Result := IndexOf(AValue) >= 0; +end; + +function TList<T>.IndexOf(constref AValue: T): SizeInt; +var + i: SizeInt; +begin + for i := 0 to Count - 1 do + if FComparer.Compare(AValue, FItems[i]) = 0 then + Exit(i); + Result := -1; +end; + +function TList<T>.LastIndexOf(constref AValue: T): SizeInt; +var + i: SizeInt; +begin + for i := Count - 1 downto 0 do + if FComparer.Compare(AValue, FItems[i]) = 0 then + Exit(i); + Result := -1; +end; + +procedure TList<T>.Reverse; +var + a, b: SizeInt; + LTemp: T; +begin + a := 0; + b := Count - 1; + while a < b do + begin + LTemp := FItems[a]; + FItems[a] := FItems[b]; + FItems[b] := LTemp; + Inc(a); + Dec(b); + end; +end; + +procedure TList<T>.Sort; +begin + TArrayHelperBugHack.Sort(FItems, FComparer, 0, Count); +end; + +procedure TList<T>.Sort(const AComparer: IComparer<T>); +begin + TArrayHelperBugHack.Sort(FItems, AComparer, 0, Count); +end; + +function TList<T>.BinarySearch(constref AItem: T; out AIndex: SizeInt): Boolean; +begin + Result := TArrayHelperBugHack.BinarySearch(FItems, AItem, AIndex); +end; + +function TList<T>.BinarySearch(constref AItem: T; out AIndex: SizeInt; const AComparer: IComparer<T>): Boolean; +begin + Result := TArrayHelperBugHack.BinarySearch(FItems, AItem, AIndex, AComparer); +end; + +{ TQueue<T>.TEnumerator } + +constructor TQueue<T>.TEnumerator.Create(AQueue: TQueue<T>); +begin + inherited Create(AQueue); + + FIndex := Pred(AQueue.FLow); +end; + +{ TQueue<T> } + +function TQueue<T>.GetEnumerator: TEnumerator; +begin + Result := TEnumerator.Create(Self); +end; + +function TQueue<T>.DoGetEnumerator: {Generics.Collections.}TEnumerator<T>; +begin + Result := GetEnumerator; +end; + +function TQueue<T>.DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; +begin + Result := FItems[AIndex]; + FItems[AIndex] := Default(T); + Notify(Result, ACollectionNotification); + FLow += 1; + if FLow = FItemsLength then + begin + FLow := 0; + FItemsLength := 0; + end; +end; + +procedure TQueue<T>.SetCapacity(AValue: SizeInt); +begin + if AValue < Count then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + if AValue = FItemsLength then + Exit; + + if (Count > 0) and (FLow > 0) then + begin + Move(FItems[FLow], FItems[0], Count * SizeOf(T)); + FillChar(FItems[Count], (FItemsLength - Count) * SizeOf(T), #0); + end; + + SetLength(FItems, AValue); + FItemsLength := Count; + FLow := 0; +end; + +function TQueue<T>.GetCount: SizeInt; +begin + Result := FItemsLength - FLow; +end; + +constructor TQueue<T>.Create(ACollection: TEnumerable<T>); +var + LItem: T; +begin + for LItem in ACollection do + Enqueue(LItem); +end; + +destructor TQueue<T>.Destroy; +begin + Clear; +end; + +procedure TQueue<T>.Enqueue(constref AValue: T); +var + LIndex: SizeInt; +begin + LIndex := PrepareAddingItem; + FItems[LIndex] := AValue; + Notify(AValue, cnAdded); +end; + +function TQueue<T>.Dequeue: T; +begin + Result := DoRemove(FLow, cnRemoved); +end; + +function TQueue<T>.Extract: T; +begin + Result := DoRemove(FLow, cnExtracted); +end; + +function TQueue<T>.Peek: T; +begin + if (Count = 0) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + Result := FItems[FLow]; +end; + +procedure TQueue<T>.Clear; +begin + while Count <> 0 do + Dequeue; + FLow := 0; + FItemsLength := 0; +end; + +procedure TQueue<T>.TrimExcess; +begin + SetCapacity(Count); +end; + +{ TStack<T> } + +function TStack<T>.GetEnumerator: TEnumerator; +begin + Result := TEnumerator.Create(Self); +end; + +function TStack<T>.DoGetEnumerator: {Generics.Collections.}TEnumerator<T>; +begin + Result := GetEnumerator; +end; + +constructor TStack<T>.Create(ACollection: TEnumerable<T>); +var + LItem: T; +begin + for LItem in ACollection do + Push(LItem); +end; + +function TStack<T>.DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): T; +begin + if AIndex < 0 then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + Result := FItems[AIndex]; + FItems[AIndex] := Default(T); + FItemsLength -= 1; + Notify(Result, ACollectionNotification); +end; + +destructor TStack<T>.Destroy; +begin + Clear; +end; + +procedure TStack<T>.Clear; +begin + while Count <> 0 do + Pop; +end; + +procedure TStack<T>.SetCapacity(AValue: SizeInt); +begin + if AValue < Count then + AValue := Count; + + SetLength(FItems, AValue); +end; + +procedure TStack<T>.Push(constref AValue: T); +var + LIndex: SizeInt; +begin + LIndex := PrepareAddingItem; + FItems[LIndex] := AValue; + Notify(AValue, cnAdded); +end; + +function TStack<T>.Pop: T; +begin + Result := DoRemove(FItemsLength - 1, cnRemoved); +end; + +function TStack<T>.Peek: T; +begin + if (Count = 0) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + Result := FItems[FItemsLength - 1]; +end; + +function TStack<T>.Extract: T; +begin + Result := DoRemove(FItemsLength - 1, cnExtracted); +end; + +procedure TStack<T>.TrimExcess; +begin + SetCapacity(Count); +end; + +{ TObjectList<T> } + +procedure TObjectList<T>.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); +begin + inherited Notify(AValue, ACollectionNotification); + + if FObjectsOwner and (ACollectionNotification = cnRemoved) then + TObject(AValue).Free; +end; + +constructor TObjectList<T>.Create(AOwnsObjects: Boolean); +begin + inherited Create; + + FObjectsOwner := AOwnsObjects; +end; + +constructor TObjectList<T>.Create(const AComparer: IComparer<T>; AOwnsObjects: Boolean); +begin + inherited Create(AComparer); + + FObjectsOwner := AOwnsObjects; +end; + +constructor TObjectList<T>.Create(ACollection: TEnumerable<T>; AOwnsObjects: Boolean); +begin + inherited Create(ACollection); + + FObjectsOwner := AOwnsObjects; +end; + +{ TObjectQueue<T> } + +procedure TObjectQueue<T>.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); +begin + inherited Notify(AValue, ACollectionNotification); + if FObjectsOwner and (ACollectionNotification = cnRemoved) then + TObject(AValue).Free; +end; + +constructor TObjectQueue<T>.Create(AOwnsObjects: Boolean); +begin + inherited Create; + + FObjectsOwner := AOwnsObjects; +end; + +constructor TObjectQueue<T>.Create(ACollection: TEnumerable<T>; AOwnsObjects: Boolean); +begin + inherited Create(ACollection); + + FObjectsOwner := AOwnsObjects; +end; + +procedure TObjectQueue<T>.Dequeue; +begin + inherited Dequeue; +end; + +{ TObjectStack<T> } + +procedure TObjectStack<T>.Notify(constref AValue: T; ACollectionNotification: TCollectionNotification); +begin + inherited Notify(AValue, ACollectionNotification); + if FObjectsOwner and (ACollectionNotification = cnRemoved) then + TObject(AValue).Free; +end; + +constructor TObjectStack<T>.Create(AOwnsObjects: Boolean); +begin + inherited Create; + + FObjectsOwner := AOwnsObjects; +end; + +constructor TObjectStack<T>.Create(ACollection: TEnumerable<T>; AOwnsObjects: Boolean); +begin + inherited Create(ACollection); + + FObjectsOwner := AOwnsObjects; +end; + +procedure TObjectStack<T>.Pop; +begin + inherited Pop; +end; + +{$I inc\generics.dictionaries.inc} + +end. diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.defaults.pas b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.defaults.pas new file mode 100644 index 000000000..14ec05753 --- /dev/null +++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.defaults.pas @@ -0,0 +1,3372 @@ +{ + 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.Defaults; + +{$MODE DELPHI}{$H+} +{$POINTERMATH ON} +{$MACRO ON} +{$COPERATORS ON} +{$HINTS OFF} +{$WARNINGS OFF} +{$NOTES OFF} + +interface + +uses + Classes, SysUtils, Generics.Hashes, TypInfo, Variants, Math, Generics.Strings, Generics.Helpers; + +type + IComparer<T> = interface + function Compare(constref Left, Right: T): Integer; overload; + end; + + TOnComparison<T> = function(constref Left, Right: T): Integer of object; + TComparisonFunc<T> = function(constref Left, Right: T): Integer; + + TComparer<T> = class(TInterfacedObject, IComparer<T>) + public + class function Default: IComparer<T>; static; + function Compare(constref ALeft, ARight: T): Integer; virtual; abstract; overload; + + class function Construct(const AComparison: TOnComparison<T>): IComparer<T>; overload; + class function Construct(const AComparison: TComparisonFunc<T>): IComparer<T>; overload; + end; + + TDelegatedComparerEvents<T> = class(TComparer<T>) + private + FComparison: TOnComparison<T>; + public + function Compare(constref ALeft, ARight: T): Integer; override; + constructor Create(AComparison: TOnComparison<T>); + end; + + TDelegatedComparerFunc<T> = class(TComparer<T>) + private + FComparison: TComparisonFunc<T>; + public + function Compare(constref ALeft, ARight: T): Integer; override; + constructor Create(AComparison: TComparisonFunc<T>); + end; + + IEqualityComparer<T> = interface + function Equals(constref ALeft, ARight: T): Boolean; + function GetHashCode(constref AValue: T): UInt32; + end; + + IExtendedEqualityComparer<T> = interface(IEqualityComparer<T>) + procedure GetHashList(constref AValue: T; AHashList: PUInt32); // for double hashing and more + end; + + ShortString1 = string[1]; + ShortString2 = string[2]; + ShortString3 = string[3]; + + { TAbstractInterface } + + TInterface = class + public + function QueryInterface(constref {%H-}IID: TGUID;{%H-} out Obj): HResult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; + function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; abstract; + function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; virtual; abstract; + end; + + { TRawInterface } + + TRawInterface = class(TInterface) + public + function _AddRef: Integer; override; + function _Release: Integer; override; + end; + + { TComTypeSizeInterface } + + // INTERNAL USE ONLY! + TComTypeSizeInterface = class(TInterface) + public + // warning ! self as PSpoofInterfacedTypeSizeObject + function _AddRef: Integer; override; + // warning ! self as PSpoofInterfacedTypeSizeObject + function _Release: Integer; override; + end; + + { TSingletonImplementation } + + TSingletonImplementation = class(TRawInterface, IInterface) + public + function QueryInterface(constref IID: TGUID; out Obj): HResult; override; + end; + + TCompare = class + protected + // warning ! self as PSpoofInterfacedTypeSizeObject + class function _Binary(constref ALeft, ARight): Integer; + // warning ! self as PSpoofInterfacedTypeSizeObject + class function _DynArray(constref ALeft, ARight: Pointer): Integer; + public + class function Integer(constref ALeft, ARight: Integer): Integer; + class function Int8(constref ALeft, ARight: Int8): Integer; + class function Int16(constref ALeft, ARight: Int16): Integer; + class function Int32(constref ALeft, ARight: Int32): Integer; + class function Int64(constref ALeft, ARight: Int64): Integer; + class function UInt8(constref ALeft, ARight: UInt8): Integer; + class function UInt16(constref ALeft, ARight: UInt16): Integer; + class function UInt32(constref ALeft, ARight: UInt32): Integer; + class function UInt64(constref ALeft, ARight: UInt64): Integer; + class function Single(constref ALeft, ARight: Single): Integer; + class function Double(constref ALeft, ARight: Double): Integer; + class function Extended(constref ALeft, ARight: Extended): Integer; + class function Currency(constref ALeft, ARight: Currency): Integer; + class function Comp(constref ALeft, ARight: Comp): Integer; + class function Binary(constref ALeft, ARight; const ASize: SizeInt): Integer; + class function DynArray(constref ALeft, ARight: Pointer; const AElementSize: SizeInt): Integer; + class function ShortString1(constref ALeft, ARight: ShortString1): Integer; + class function ShortString2(constref ALeft, ARight: ShortString2): Integer; + class function ShortString3(constref ALeft, ARight: ShortString3): Integer; + class function &String(constref ALeft, ARight: string): Integer; + class function ShortString(constref ALeft, ARight: OpenString): Integer; + class function AnsiString(constref ALeft, ARight: AnsiString): Integer; + class function WideString(constref ALeft, ARight: WideString): Integer; + class function UnicodeString(constref ALeft, ARight: UnicodeString): Integer; + class function Method(constref ALeft, ARight: TMethod): Integer; + class function Variant(constref ALeft, ARight: PVariant): Integer; + class function Pointer(constref ALeft, ARight: PtrUInt): Integer; + end; + + { TEquals } + + TEquals = class + protected + // warning ! self as PSpoofInterfacedTypeSizeObject + class function _Binary(constref ALeft, ARight): Boolean; + // warning ! self as PSpoofInterfacedTypeSizeObject + class function _DynArray(constref ALeft, ARight: Pointer): Boolean; + public + class function Integer(constref ALeft, ARight: Integer): Boolean; + class function Int8(constref ALeft, ARight: Int8): Boolean; + class function Int16(constref ALeft, ARight: Int16): Boolean; + class function Int32(constref ALeft, ARight: Int32): Boolean; + class function Int64(constref ALeft, ARight: Int64): Boolean; + class function UInt8(constref ALeft, ARight: UInt8): Boolean; + class function UInt16(constref ALeft, ARight: UInt16): Boolean; + class function UInt32(constref ALeft, ARight: UInt32): Boolean; + class function UInt64(constref ALeft, ARight: UInt64): Boolean; + class function Single(constref ALeft, ARight: Single): Boolean; + class function Double(constref ALeft, ARight: Double): Boolean; + class function Extended(constref ALeft, ARight: Extended): Boolean; + class function Currency(constref ALeft, ARight: Currency): Boolean; + class function Comp(constref ALeft, ARight: Comp): Boolean; + class function Binary(constref ALeft, ARight; const ASize: SizeInt): Boolean; + class function DynArray(constref ALeft, ARight: Pointer; const AElementSize: SizeInt): Boolean; + class function &Class(constref ALeft, ARight: TObject): Boolean; + class function ShortString1(constref ALeft, ARight: ShortString1): Boolean; + class function ShortString2(constref ALeft, ARight: ShortString2): Boolean; + class function ShortString3(constref ALeft, ARight: ShortString3): Boolean; + class function &String(constref ALeft, ARight: String): Boolean; + class function ShortString(constref ALeft, ARight: OpenString): Boolean; + class function AnsiString(constref ALeft, ARight: AnsiString): Boolean; + class function WideString(constref ALeft, ARight: WideString): Boolean; + class function UnicodeString(constref ALeft, ARight: UnicodeString): Boolean; + class function Method(constref ALeft, ARight: TMethod): Boolean; + class function Variant(constref ALeft, ARight: PVariant): Boolean; + class function Pointer(constref ALeft, ARight: PtrUInt): Boolean; + end; + + TComparerFactoryClass = class of TComparerFactory; + + THashFactoryClass = class of THashFactory; + + TExtendedHashFactoryClass = class of TExtendedHashFactory; + + { TComparerFactory } + +{$DEFINE STD_RAW_INTERFACE_METHODS := + QueryInterface: @TRawInterface.QueryInterface; + _AddRef : @TRawInterface._AddRef; + _Release : @TRawInterface._Release +} + +{$DEFINE STD_COM_TYPESIZE_INTERFACE_METHODS := + QueryInterface: @TComTypeSizeInterface.QueryInterface; + _AddRef : @TComTypeSizeInterface._AddRef; + _Release : @TComTypeSizeInterface._Release +} + +{$DEFINE STD_COM_INTERFACE_METHODS := + QueryInterface: @QueryInterface; + _AddRef : @AddRef; + _Release : @Release +} + + TGetHashListOptions = set of (ghloHashListAsInitData); + + TComparerFactory = class abstract + protected + class function GetID: Integer; virtual; abstract; // any hash factory must have + private + function LookupEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; virtual; abstract; + function LookupExtendedEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; virtual; abstract; + + function SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; + function SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; + function SelectShortStringEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; + function SelectBinaryEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; + function SelectDynArrayEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; virtual; abstract; + private type + PSpoofInterfacedTypeSizeObject = ^TSpoofInterfacedTypeSizeObject; + TSpoofInterfacedTypeSizeObject = record + VMT: Pointer; + RefCount: Integer; + Size: SizeInt; + end; + + PInstance = ^TInstance; + TInstance = record + Selector: Boolean; + Instance: Pointer; + + class function Create(ASelector: Boolean; AInstance: Pointer): TComparerFactory.TInstance; static; + end; + + PComparerVMT = ^TComparerVMT; + TComparerVMT = packed record + QueryInterface: Pointer; + _AddRef: Pointer; + _Release: Pointer; + Compare: Pointer; + end; + + TSelectFunc = function(ATypeData: PTypeData; ASize: SizeInt): Pointer; + + private + class function CreateInterface(AVMT: Pointer; ASize: SizeInt): PSpoofInterfacedTypeSizeObject; static; + + class function SelectIntegerComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; + class function SelectInt64Comparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; + class function SelectFloatComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; + class function SelectShortStringComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; + class function SelectBinaryComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; + class function SelectDynArrayComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; static; + + private const + // IComparer VMT + Comparer_Int8_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Int8); + Comparer_Int16_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Int16 ); + Comparer_Int32_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Int32 ); + Comparer_Int64_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Int64 ); + Comparer_UInt8_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UInt8 ); + Comparer_UInt16_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UInt16); + Comparer_UInt32_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UInt32); + Comparer_UInt64_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UInt64); + + Comparer_Single_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Single ); + Comparer_Double_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Double ); + Comparer_Extended_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Extended); + + Comparer_Currency_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Currency); + Comparer_Comp_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Comp ); + + Comparer_Binary_VMT : TComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Compare: @TCompare._Binary ); + Comparer_DynArray_VMT: TComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Compare: @TCompare._DynArray); + + Comparer_ShortString1_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.ShortString1 ); + Comparer_ShortString2_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.ShortString2 ); + Comparer_ShortString3_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.ShortString3 ); + Comparer_ShortString_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.ShortString ); + Comparer_AnsiString_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.AnsiString ); + Comparer_WideString_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.WideString ); + Comparer_UnicodeString_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.UnicodeString); + + Comparer_Method_VMT : TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Method ); + Comparer_Variant_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Variant); + Comparer_Pointer_VMT: TComparerVMT = (STD_RAW_INTERFACE_METHODS; Compare: @TCompare.Pointer); + + // Instances + Comparer_Int8_Instance : Pointer = @Comparer_Int8_VMT ; + Comparer_Int16_Instance : Pointer = @Comparer_Int16_VMT ; + Comparer_Int32_Instance : Pointer = @Comparer_Int32_VMT ; + Comparer_Int64_Instance : Pointer = @Comparer_Int64_VMT ; + Comparer_UInt8_Instance : Pointer = @Comparer_UInt8_VMT ; + Comparer_UInt16_Instance: Pointer = @Comparer_UInt16_VMT; + Comparer_UInt32_Instance: Pointer = @Comparer_UInt32_VMT; + Comparer_UInt64_Instance: Pointer = @Comparer_UInt64_VMT; + + Comparer_Single_Instance : Pointer = @Comparer_Single_VMT ; + Comparer_Double_Instance : Pointer = @Comparer_Double_VMT ; + Comparer_Extended_Instance: Pointer = @Comparer_Extended_VMT; + + Comparer_Currency_Instance: Pointer = @Comparer_Currency_VMT; + Comparer_Comp_Instance : Pointer = @Comparer_Comp_VMT ; + + //Comparer_Binary_Instance : Pointer = @Comparer_Binary_VMT ; // dynamic instance + //Comparer_DynArray_Instance: Pointer = @Comparer_DynArray_VMT; // dynamic instance + + Comparer_ShortString1_Instance : Pointer = @Comparer_ShortString1_VMT ; + Comparer_ShortString2_Instance : Pointer = @Comparer_ShortString2_VMT ; + Comparer_ShortString3_Instance : Pointer = @Comparer_ShortString3_VMT ; + Comparer_ShortString_Instance : Pointer = @Comparer_ShortString_VMT ; + Comparer_AnsiString_Instance : Pointer = @Comparer_AnsiString_VMT ; + Comparer_WideString_Instance : Pointer = @Comparer_WideString_VMT ; + Comparer_UnicodeString_Instance: Pointer = @Comparer_UnicodeString_VMT; + + Comparer_Method_Instance : Pointer = @Comparer_Method_VMT ; + Comparer_Variant_Instance: Pointer = @Comparer_Variant_VMT; + Comparer_Pointer_Instance: Pointer = @Comparer_Pointer_VMT; + + ComparerInstances: array[TTypeKind] of TInstance = + ( + // tkUnknown + (Selector: True; Instance: @TComparerFactory.SelectBinaryComparer), + // tkInteger + (Selector: True; Instance: @TComparerFactory.SelectIntegerComparer), + // tkChar + (Selector: False; Instance: @Comparer_UInt8_Instance), + // tkEnumeration + (Selector: True; Instance: @TComparerFactory.SelectIntegerComparer), + // tkFloat + (Selector: True; Instance: @TComparerFactory.SelectFloatComparer), + // tkSet + (Selector: True; Instance: @TComparerFactory.SelectBinaryComparer), + // tkMethod + (Selector: False; Instance: @Comparer_Method_Instance), + // tkSString + (Selector: True; Instance: @TComparerFactory.SelectShortStringComparer), + // tkLString - only internal use / deprecated in compiler + (Selector: False; Instance: @Comparer_AnsiString_Instance), // <- unsure + // tkAString + (Selector: False; Instance: @Comparer_AnsiString_Instance), + // tkWString + (Selector: False; Instance: @Comparer_WideString_Instance), + // tkVariant + (Selector: False; Instance: @Comparer_Variant_Instance), + // tkArray + (Selector: True; Instance: @TComparerFactory.SelectBinaryComparer), + // tkRecord + (Selector: True; Instance: @TComparerFactory.SelectBinaryComparer), + // tkInterface + (Selector: False; Instance: @Comparer_Pointer_Instance), + // tkClass + (Selector: False; Instance: @Comparer_Pointer_Instance), + // tkObject + (Selector: True; Instance: @TComparerFactory.SelectBinaryComparer), + // tkWChar + (Selector: False; Instance: @Comparer_UInt16_Instance), + // tkBool + (Selector: True; Instance: @TComparerFactory.SelectIntegerComparer), + // tkInt64 + (Selector: False; Instance: @Comparer_Int64_Instance), + // tkQWord + (Selector: False; Instance: @Comparer_UInt64_Instance), + // tkDynArray + (Selector: True; Instance: @TComparerFactory.SelectDynArrayComparer), + // tkInterfaceRaw + (Selector: False; Instance: @Comparer_Pointer_Instance), + // tkProcVar + (Selector: False; Instance: @Comparer_Pointer_Instance), + // tkUString + (Selector: False; Instance: @Comparer_UnicodeString_Instance), + // tkUChar - WTF? ... http://bugs.freepascal.org/view.php?id=24609 + (Selector: False; Instance: @Comparer_UInt16_Instance), // <- unsure maybe Comparer_UInt32_Instance + // tkHelper + (Selector: False; Instance: @Comparer_Pointer_Instance), + // tkFile + (Selector: True; Instance: @TComparerFactory.SelectBinaryComparer), // <- unsure what type? + // tkClassRef + (Selector: False; Instance: @Comparer_Pointer_Instance), + // tkPointer + (Selector: False; Instance: @Comparer_Pointer_Instance) + ); + public + constructor Create; virtual; + class function LookupComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; static; + + class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; virtual; abstract; reintroduce; + class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); virtual; abstract; + //class function GetHashCodeEx(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; virtual; abstract; + //class procedure GetHashListEx(AKey: Pointer; ASize: SizeInt; AHashListAndInitValues: PUInt32; ACount: Integer); virtual; abstract; + + class function Register(const AComparerFactory: TComparerFactoryClass): Integer; + end; + + { THashCode } + + THashCode = class(TComparerFactory) + private type + PPEqualityComparerVMT = ^PEqualityComparerVMT; + PEqualityComparerVMT = ^TEqualityComparerVMT; + TEqualityComparerVMT = packed record + QueryInterface: Pointer; + _AddRef: Pointer; + _Release: Pointer; + Equals: Pointer; + GetHashCode: Pointer; + __Reserved: Pointer; // initially or TExtendedEqualityComparerVMT compatibility + // (important when ExtendedEqualityComparer is calling Binary method) + __ClassRef: THashFactoryClass; // hidden field in VMT. For class ref THashFactoryClass + end; + + { TInstance } + TSelectMethod = function(ATypeData: PTypeData; ASize: SizeInt): Pointer of object; + private +(*********************************************************************************************************************** + Hashes +(**********************************************************************************************************************) + + class function Int8 (constref AValue: Int8 ): UInt32; overload; + class function Int16 (constref AValue: Int16 ): UInt32; overload; + class function Int32 (constref AValue: Int32 ): UInt32; overload; + class function Int64 (constref AValue: Int64 ): UInt32; overload; + class function UInt8 (constref AValue: UInt8 ): UInt32; overload; + class function UInt16 (constref AValue: UInt16 ): UInt32; overload; + class function UInt32 (constref AValue: UInt32 ): UInt32; overload; + class function UInt64 (constref AValue: UInt64 ): UInt32; overload; + class function Single (constref AValue: Single ): UInt32; overload; + class function Double (constref AValue: Double ): UInt32; overload; + class function Extended (constref AValue: Extended ): UInt32; overload; + class function Currency (constref AValue: Currency ): UInt32; overload; + class function Comp (constref AValue: Comp ): UInt32; overload; + // warning ! self as PSpoofInterfacedTypeSizeObject + class function Binary (constref AValue ): UInt32; overload; + // warning ! self as PSpoofInterfacedTypeSizeObject + class function DynArray (constref AValue: Pointer ): UInt32; overload; + class function &Class (constref AValue: TObject ): UInt32; overload; + class function ShortString1 (constref AValue: ShortString1 ): UInt32; overload; + class function ShortString2 (constref AValue: ShortString2 ): UInt32; overload; + class function ShortString3 (constref AValue: ShortString3 ): UInt32; overload; + class function ShortString (constref AValue: OpenString ): UInt32; overload; + class function AnsiString (constref AValue: AnsiString ): UInt32; overload; + class function WideString (constref AValue: WideString ): UInt32; overload; + class function UnicodeString(constref AValue: UnicodeString): UInt32; overload; + class function Method (constref AValue: TMethod ): UInt32; overload; + class function Variant (constref AValue: PVariant ): UInt32; overload; + class function Pointer (constref AValue: Pointer ): UInt32; overload; + public + const MAX_HASHLIST_COUNT = 1; + const HASH_FUNCTIONS_COUNT = 1; + const HASHLIST_COUNT_PER_FUNCTION: array[1..HASH_FUNCTIONS_COUNT] of Integer = (1); + const HASH_FUNCTIONS_MASK_SIZE = 1; + end; + + TExtendedHashCode = class(THashCode) + private type + PPExtendedEqualityComparerVMT = ^PExtendedEqualityComparerVMT; + PExtendedEqualityComparerVMT = ^TExtendedEqualityComparerVMT; + TExtendedEqualityComparerVMT = packed record + QueryInterface: Pointer; + _AddRef: Pointer; + _Release: Pointer; + Equals: Pointer; + GetHashCode: Pointer; + GetHashList: Pointer; + __ClassRef: TExtendedHashFactoryClass; // hidden field in VMT. For class ref THashFactoryClass + end; + private +(*********************************************************************************************************************** + Hashes 2 +(**********************************************************************************************************************) + + class procedure Int8 (constref AValue: Int8 ; AHashList: PUInt32); overload; + class procedure Int16 (constref AValue: Int16 ; AHashList: PUInt32); overload; + class procedure Int32 (constref AValue: Int32 ; AHashList: PUInt32); overload; + class procedure Int64 (constref AValue: Int64 ; AHashList: PUInt32); overload; + class procedure UInt8 (constref AValue: UInt8 ; AHashList: PUInt32); overload; + class procedure UInt16 (constref AValue: UInt16 ; AHashList: PUInt32); overload; + class procedure UInt32 (constref AValue: UInt32 ; AHashList: PUInt32); overload; + class procedure UInt64 (constref AValue: UInt64 ; AHashList: PUInt32); overload; + class procedure Single (constref AValue: Single ; AHashList: PUInt32); overload; + class procedure Double (constref AValue: Double ; AHashList: PUInt32); overload; + class procedure Extended (constref AValue: Extended ; AHashList: PUInt32); overload; + class procedure Currency (constref AValue: Currency ; AHashList: PUInt32); overload; + class procedure Comp (constref AValue: Comp ; AHashList: PUInt32); overload; + // warning ! self as PSpoofInterfacedTypeSizeObject + class procedure Binary (constref AValue ; AHashList: PUInt32); overload; + // warning ! self as PSpoofInterfacedTypeSizeObject + class procedure DynArray (constref AValue: Pointer ; AHashList: PUInt32); overload; + class procedure &Class (constref AValue: TObject ; AHashList: PUInt32); overload; + class procedure ShortString1 (constref AValue: ShortString1 ; AHashList: PUInt32); overload; + class procedure ShortString2 (constref AValue: ShortString2 ; AHashList: PUInt32); overload; + class procedure ShortString3 (constref AValue: ShortString3 ; AHashList: PUInt32); overload; + class procedure ShortString (constref AValue: OpenString ; AHashList: PUInt32); overload; + class procedure AnsiString (constref AValue: AnsiString ; AHashList: PUInt32); overload; + class procedure WideString (constref AValue: WideString ; AHashList: PUInt32); overload; + class procedure UnicodeString(constref AValue: UnicodeString; AHashList: PUInt32); overload; + class procedure Method (constref AValue: TMethod ; AHashList: PUInt32); overload; + class procedure Variant (constref AValue: PVariant ; AHashList: PUInt32); overload; + class procedure Pointer (constref AValue: Pointer ; AHashList: PUInt32); overload; + end; + + { THashFactory } + +{$DEFINE HASH_FACTORY := PPEqualityComparerVMT(Self)^.__ClassRef} +{$DEFINE EXTENDED_HASH_FACTORY := PPExtendedEqualityComparerVMT(Self)^.__ClassRef} + + THashFactory = class(THashCode) + private + function SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + function SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + function SelectShortStringEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + function SelectBinaryEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + function SelectDynArrayEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + private const + // IEqualityComparer VMT templates +{$WARNINGS OFF} + EqualityComparer_Int8_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int8 ; GetHashCode: @THashCode.Int8 ); + EqualityComparer_Int16_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int16 ; GetHashCode: @THashCode.Int16 ); + EqualityComparer_Int32_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int32 ; GetHashCode: @THashCode.Int32 ); + EqualityComparer_Int64_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int64 ; GetHashCode: @THashCode.Int64 ); + EqualityComparer_UInt8_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt8 ; GetHashCode: @THashCode.UInt8 ); + EqualityComparer_UInt16_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt16; GetHashCode: @THashCode.UInt16); + EqualityComparer_UInt32_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt32; GetHashCode: @THashCode.UInt32); + EqualityComparer_UInt64_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt64; GetHashCode: @THashCode.UInt64); + + EqualityComparer_Single_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Single ; GetHashCode: @THashCode.Single ); + EqualityComparer_Double_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Double ; GetHashCode: @THashCode.Double ); + EqualityComparer_Extended_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Extended; GetHashCode: @THashCode.Extended); + + EqualityComparer_Currency_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Currency; GetHashCode: @THashCode.Currency); + EqualityComparer_Comp_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Comp ; GetHashCode: @THashCode.Comp ); + + EqualityComparer_Binary_VMT : TEqualityComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Equals: @TEquals._Binary ; GetHashCode: @THashCode.Binary ); + EqualityComparer_DynArray_VMT: TEqualityComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Equals: @TEquals._DynArray; GetHashCode: @THashCode.DynArray); + + EqualityComparer_Class_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.&Class; GetHashCode: @THashCode.&Class); + + EqualityComparer_ShortString1_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString1 ; GetHashCode: @THashCode.ShortString1 ); + EqualityComparer_ShortString2_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString2 ; GetHashCode: @THashCode.ShortString2 ); + EqualityComparer_ShortString3_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString3 ; GetHashCode: @THashCode.ShortString3 ); + EqualityComparer_ShortString_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString ; GetHashCode: @THashCode.ShortString ); + EqualityComparer_AnsiString_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.AnsiString ; GetHashCode: @THashCode.AnsiString ); + EqualityComparer_WideString_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.WideString ; GetHashCode: @THashCode.WideString ); + EqualityComparer_UnicodeString_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UnicodeString; GetHashCode: @THashCode.UnicodeString); + + EqualityComparer_Method_VMT : TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Method ; GetHashCode: @THashCode.Method ); + EqualityComparer_Variant_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Variant; GetHashCode: @THashCode.Variant); + EqualityComparer_Pointer_VMT: TEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Pointer; GetHashCode: @THashCode.Pointer); +{$WARNINGS ON} + private var + // IEqualityComparer VMT + FEqualityComparer_Int8_VMT : TEqualityComparerVMT; + FEqualityComparer_Int16_VMT : TEqualityComparerVMT; + FEqualityComparer_Int32_VMT : TEqualityComparerVMT; + FEqualityComparer_Int64_VMT : TEqualityComparerVMT; + FEqualityComparer_UInt8_VMT : TEqualityComparerVMT; + FEqualityComparer_UInt16_VMT: TEqualityComparerVMT; + FEqualityComparer_UInt32_VMT: TEqualityComparerVMT; + FEqualityComparer_UInt64_VMT: TEqualityComparerVMT; + + FEqualityComparer_Single_VMT : TEqualityComparerVMT; + FEqualityComparer_Double_VMT : TEqualityComparerVMT; + FEqualityComparer_Extended_VMT: TEqualityComparerVMT; + + FEqualityComparer_Currency_VMT: TEqualityComparerVMT; + FEqualityComparer_Comp_VMT : TEqualityComparerVMT; + + FEqualityComparer_Binary_VMT : TEqualityComparerVMT; + FEqualityComparer_DynArray_VMT: TEqualityComparerVMT; + + FEqualityComparer_Class_VMT: TEqualityComparerVMT; + + FEqualityComparer_ShortString1_VMT : TEqualityComparerVMT; + FEqualityComparer_ShortString2_VMT : TEqualityComparerVMT; + FEqualityComparer_ShortString3_VMT : TEqualityComparerVMT; + FEqualityComparer_ShortString_VMT : TEqualityComparerVMT; + FEqualityComparer_AnsiString_VMT : TEqualityComparerVMT; + FEqualityComparer_WideString_VMT : TEqualityComparerVMT; + FEqualityComparer_UnicodeString_VMT: TEqualityComparerVMT; + + FEqualityComparer_Method_VMT : TEqualityComparerVMT; + FEqualityComparer_Variant_VMT: TEqualityComparerVMT; + FEqualityComparer_Pointer_VMT: TEqualityComparerVMT; + + FEqualityComparer_Int8_Instance : Pointer; + FEqualityComparer_Int16_Instance : Pointer; + FEqualityComparer_Int32_Instance : Pointer; + FEqualityComparer_Int64_Instance : Pointer; + FEqualityComparer_UInt8_Instance : Pointer; + FEqualityComparer_UInt16_Instance : Pointer; + FEqualityComparer_UInt32_Instance : Pointer; + FEqualityComparer_UInt64_Instance : Pointer; + + FEqualityComparer_Single_Instance : Pointer; + FEqualityComparer_Double_Instance : Pointer; + FEqualityComparer_Extended_Instance : Pointer; + + FEqualityComparer_Currency_Instance : Pointer; + FEqualityComparer_Comp_Instance : Pointer; + + //FEqualityComparer_Binary_Instance : Pointer; // dynamic instance + //FEqualityComparer_DynArray_Instance : Pointer; // dynamic instance + + FEqualityComparer_ShortString1_Instance : Pointer; + FEqualityComparer_ShortString2_Instance : Pointer; + FEqualityComparer_ShortString3_Instance : Pointer; + FEqualityComparer_ShortString_Instance : Pointer; + FEqualityComparer_AnsiString_Instance : Pointer; + FEqualityComparer_WideString_Instance : Pointer; + FEqualityComparer_UnicodeString_Instance: Pointer; + + FEqualityComparer_Method_Instance : Pointer; + FEqualityComparer_Variant_Instance : Pointer; + FEqualityComparer_Pointer_Instance : Pointer; + + + FEqualityComparerInstances: array[TTypeKind] of TInstance; + public + function LookupEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; override; + + constructor Create; override; + + //class function Hash(AKey: Pointer; ASize: SizeInt): UInt32; virtual; overload; abstract; + //class function Hash(AKey: Pointer; ASize: SizeInt; out AHash: UInt32): UInt32; virtual; overload; + end; + + { TExtendedHashFactory } + + TExtendedHashFactory = class(TExtendedHashCode) + private + function SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + function SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + function SelectShortStringEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + function SelectBinaryEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + function SelectDynArrayEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; override; + private const + // IExtendedEqualityComparer VMT templates +{$WARNINGS OFF} + ExtendedEqualityComparer_Int8_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int8 ; GetHashCode: @THashCode.Int8 ; GetHashList: @TExtendedHashCode.Int8 ); + ExtendedEqualityComparer_Int16_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int16 ; GetHashCode: @THashCode.Int16 ; GetHashList: @TExtendedHashCode.Int16 ); + ExtendedEqualityComparer_Int32_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int32 ; GetHashCode: @THashCode.Int32 ; GetHashList: @TExtendedHashCode.Int32 ); + ExtendedEqualityComparer_Int64_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Int64 ; GetHashCode: @THashCode.Int64 ; GetHashList: @TExtendedHashCode.Int64 ); + ExtendedEqualityComparer_UInt8_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt8 ; GetHashCode: @THashCode.UInt8 ; GetHashList: @TExtendedHashCode.UInt8 ); + ExtendedEqualityComparer_UInt16_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt16; GetHashCode: @THashCode.UInt16; GetHashList: @TExtendedHashCode.UInt16); + ExtendedEqualityComparer_UInt32_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt32; GetHashCode: @THashCode.UInt32; GetHashList: @TExtendedHashCode.UInt32); + ExtendedEqualityComparer_UInt64_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UInt64; GetHashCode: @THashCode.UInt64; GetHashList: @TExtendedHashCode.UInt64); + + ExtendedEqualityComparer_Single_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Single ; GetHashCode: @THashCode.Single ; GetHashList: @TExtendedHashCode.Single ); + ExtendedEqualityComparer_Double_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Double ; GetHashCode: @THashCode.Double ; GetHashList: @TExtendedHashCode.Double ); + ExtendedEqualityComparer_Extended_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Extended; GetHashCode: @THashCode.Extended; GetHashList: @TExtendedHashCode.Extended); + + ExtendedEqualityComparer_Currency_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Currency; GetHashCode: @THashCode.Currency; GetHashList: @TExtendedHashCode.Currency); + ExtendedEqualityComparer_Comp_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Comp ; GetHashCode: @THashCode.Comp ; GetHashList: @TExtendedHashCode.Comp ); + + ExtendedEqualityComparer_Binary_VMT : TExtendedEqualityComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Equals: @TEquals._Binary ; GetHashCode: @THashCode.Binary ; GetHashList: @TExtendedHashCode.Binary ); + ExtendedEqualityComparer_DynArray_VMT: TExtendedEqualityComparerVMT = (STD_COM_TYPESIZE_INTERFACE_METHODS; Equals: @TEquals._DynArray; GetHashCode: @THashCode.DynArray; GetHashList: @TExtendedHashCode.DynArray); + + ExtendedEqualityComparer_Class_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.&Class; GetHashCode: @THashCode.&Class; GetHashList: @TExtendedHashCode.&Class); + + ExtendedEqualityComparer_ShortString1_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString1 ; GetHashCode: @THashCode.ShortString1 ; GetHashList: @TExtendedHashCode.ShortString1 ); + ExtendedEqualityComparer_ShortString2_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString2 ; GetHashCode: @THashCode.ShortString2 ; GetHashList: @TExtendedHashCode.ShortString2 ); + ExtendedEqualityComparer_ShortString3_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString3 ; GetHashCode: @THashCode.ShortString3 ; GetHashList: @TExtendedHashCode.ShortString3 ); + ExtendedEqualityComparer_ShortString_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.ShortString ; GetHashCode: @THashCode.ShortString ; GetHashList: @TExtendedHashCode.ShortString ); + ExtendedEqualityComparer_AnsiString_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.AnsiString ; GetHashCode: @THashCode.AnsiString ; GetHashList: @TExtendedHashCode.AnsiString ); + ExtendedEqualityComparer_WideString_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.WideString ; GetHashCode: @THashCode.WideString ; GetHashList: @TExtendedHashCode.WideString ); + ExtendedEqualityComparer_UnicodeString_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.UnicodeString; GetHashCode: @THashCode.UnicodeString; GetHashList: @TExtendedHashCode.UnicodeString); + + ExtendedEqualityComparer_Method_VMT : TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Method ; GetHashCode: @THashCode.Method ; GetHashList: @TExtendedHashCode.Method ); + ExtendedEqualityComparer_Variant_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Variant; GetHashCode: @THashCode.Variant; GetHashList: @TExtendedHashCode.Variant); + ExtendedEqualityComparer_Pointer_VMT: TExtendedEqualityComparerVMT = (STD_RAW_INTERFACE_METHODS; Equals: @TEquals.Pointer; GetHashCode: @THashCode.Pointer; GetHashList: @TExtendedHashCode.Pointer); +{$WARNINGS ON} + private var + // IExtendedEqualityComparer VMT + FExtendedEqualityComparer_Int8_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_Int16_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_Int32_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_Int64_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_UInt8_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_UInt16_VMT: TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_UInt32_VMT: TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_UInt64_VMT: TExtendedEqualityComparerVMT; + + FExtendedEqualityComparer_Single_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_Double_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_Extended_VMT: TExtendedEqualityComparerVMT; + + FExtendedEqualityComparer_Currency_VMT: TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_Comp_VMT : TExtendedEqualityComparerVMT; + + FExtendedEqualityComparer_Binary_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_DynArray_VMT: TExtendedEqualityComparerVMT; + + FExtendedEqualityComparer_Class_VMT: TExtendedEqualityComparerVMT; + + FExtendedEqualityComparer_ShortString1_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_ShortString2_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_ShortString3_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_ShortString_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_AnsiString_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_WideString_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_UnicodeString_VMT: TExtendedEqualityComparerVMT; + + FExtendedEqualityComparer_Method_VMT : TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_Variant_VMT: TExtendedEqualityComparerVMT; + FExtendedEqualityComparer_Pointer_VMT: TExtendedEqualityComparerVMT; + + FExtendedEqualityComparer_Int8_Instance : Pointer; + FExtendedEqualityComparer_Int16_Instance : Pointer; + FExtendedEqualityComparer_Int32_Instance : Pointer; + FExtendedEqualityComparer_Int64_Instance : Pointer; + FExtendedEqualityComparer_UInt8_Instance : Pointer; + FExtendedEqualityComparer_UInt16_Instance : Pointer; + FExtendedEqualityComparer_UInt32_Instance : Pointer; + FExtendedEqualityComparer_UInt64_Instance : Pointer; + + FExtendedEqualityComparer_Single_Instance : Pointer; + FExtendedEqualityComparer_Double_Instance : Pointer; + FExtendedEqualityComparer_Extended_Instance : Pointer; + + FExtendedEqualityComparer_Currency_Instance : Pointer; + FExtendedEqualityComparer_Comp_Instance : Pointer; + + //FExtendedEqualityComparer_Binary_Instance : Pointer; // dynamic instance + //FExtendedEqualityComparer_DynArray_Instance : Pointer; // dynamic instance + + FExtendedEqualityComparer_ShortString1_Instance : Pointer; + FExtendedEqualityComparer_ShortString2_Instance : Pointer; + FExtendedEqualityComparer_ShortString3_Instance : Pointer; + FExtendedEqualityComparer_ShortString_Instance : Pointer; + FExtendedEqualityComparer_AnsiString_Instance : Pointer; + FExtendedEqualityComparer_WideString_Instance : Pointer; + FExtendedEqualityComparer_UnicodeString_Instance: Pointer; + + FExtendedEqualityComparer_Method_Instance : Pointer; + FExtendedEqualityComparer_Variant_Instance : Pointer; + FExtendedEqualityComparer_Pointer_Instance : Pointer; + + // all instances + FExtendedEqualityComparerInstances: array[TTypeKind] of TInstance; + public + function LookupExtendedEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; override; + + constructor Create; override; + end; + + TOnEqualityComparison<T> = function(constref ALeft, ARight: T): Boolean of object; + TEqualityComparisonFunc<T> = function(constref ALeft, ARight: T): Boolean; + + TOnHasher<T> = function(constref AValue: T): UInt32 of object; + TOnExtendedHasher<T> = procedure(constref AValue: T; AHashList: PUInt32) of object; + THasherFunc<T> = function(constref AValue: T): UInt32; + TExtendedHasherFunc<T> = procedure(constref AValue: T; AHashList: PUInt32); + + TEqualityComparer<T> = class(TInterfacedObject, IEqualityComparer<T>) + public + class function Default: IEqualityComparer<T>; static; overload; + class function Default(AHashFactoryClass: TComparerFactoryClass): IEqualityComparer<T>; static; overload; + + class function Construct(const AEqualityComparison: TOnEqualityComparison<T>; + const AHasher: TOnHasher<T>): IEqualityComparer<T>; overload; + class function Construct(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AHasher: THasherFunc<T>): IEqualityComparer<T>; overload; + + function Equals(constref ALeft, ARight: T): Boolean; virtual; overload; abstract; + function GetHashCode(constref AValue: T): UInt32; virtual; overload; abstract; + end; + + { TDelegatedEqualityComparerEvent } + + TDelegatedEqualityComparerEvents<T> = class(TEqualityComparer<T>) + private + FEqualityComparison: TOnEqualityComparison<T>; + FHasher: TOnHasher<T>; + public + function Equals(constref ALeft, ARight: T): Boolean; override; + function GetHashCode(constref AValue: T): UInt32; override; + + constructor Create(const AEqualityComparison: TOnEqualityComparison<T>; + const AHasher: TOnHasher<T>); + end; + + TDelegatedEqualityComparerFunc<T> = class(TEqualityComparer<T>) + private + FEqualityComparison: TEqualityComparisonFunc<T>; + FHasher: THasherFunc<T>; + public + function Equals(constref ALeft, ARight: T): Boolean; override; + function GetHashCode(constref AValue: T): UInt32; override; + + constructor Create(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AHasher: THasherFunc<T>); + end; + + { TExtendedEqualityComparer } + + TExtendedEqualityComparer<T> = class(TEqualityComparer<T>, IExtendedEqualityComparer<T>) + public + class function Default: IExtendedEqualityComparer<T>; static; overload; reintroduce; + class function Default(AExtenedHashFactoryClass: TExtendedHashFactoryClass): IExtendedEqualityComparer<T>; static; overload; reintroduce; + + class function Construct(const AEqualityComparison: TOnEqualityComparison<T>; + const AHasher: TOnHasher<T>; const AExtendedHasher: TOnExtendedHasher<T>): IExtendedEqualityComparer<T>; overload; reintroduce; + class function Construct(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AHasher: THasherFunc<T>; const AExtendedHasher: TExtendedHasherFunc<T>): IExtendedEqualityComparer<T>; overload; reintroduce; + class function Construct(const AEqualityComparison: TOnEqualityComparison<T>; + const AExtendedHasher: TOnExtendedHasher<T>): IExtendedEqualityComparer<T>; overload; reintroduce; + class function Construct(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AExtendedHasher: TExtendedHasherFunc<T>): IExtendedEqualityComparer<T>; overload; reintroduce; + + procedure GetHashList(constref AValue: T; AHashList: PUInt32); virtual; abstract; + end; + + TDelegatedExtendedEqualityComparerEvents<T> = class(TExtendedEqualityComparer<T>) + private + FEqualityComparison: TOnEqualityComparison<T>; + FHasher: TOnHasher<T>; + FExtendedHasher: TOnExtendedHasher<T>; + + function GetHashCodeMethod(constref AValue: T): UInt32; + public + function Equals(constref ALeft, ARight: T): Boolean; override; + function GetHashCode(constref AValue: T): UInt32; override; + procedure GetHashList(constref AValue: T; AHashList: PUInt32); override; + + constructor Create(const AEqualityComparison: TOnEqualityComparison<T>; + const AHasher: TOnHasher<T>; const AExtendedHasher: TOnExtendedHasher<T>); overload; + constructor Create(const AEqualityComparison: TOnEqualityComparison<T>; + const AExtendedHasher: TOnExtendedHasher<T>); overload; + end; + + TDelegatedExtendedEqualityComparerFunc<T> = class(TExtendedEqualityComparer<T>) + private + FEqualityComparison: TEqualityComparisonFunc<T>; + FHasher: THasherFunc<T>; + FExtendedHasher: TExtendedHasherFunc<T>; + public + function Equals(constref ALeft, ARight: T): Boolean; override; + function GetHashCode(constref AValue: T): UInt32; override; + procedure GetHashList(constref AValue: T; AHashList: PUInt32); override; + + constructor Create(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AHasher: THasherFunc<T>; const AExtendedHasher: TExtendedHasherFunc<T>); overload; + constructor Create(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AExtendedHasher: TExtendedHasherFunc<T>); overload; + end; + + { TDelphiHashFactory } + + TDelphiHashFactory = class(THashFactory) + strict private class var + FID: Integer; + class constructor Create; + protected + class function GetID: Integer; override; + public + class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; + end; + + { TAdler32HashFactory } + + TAdler32HashFactory = class(THashFactory) + strict private class var + FID: Integer; + class constructor Create; + protected + class function GetID: Integer; override; + public + class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; + end; + + { TSdbmHashFactory } + + TSdbmHashFactory = class(THashFactory) + strict private class var + FID: Integer; + class constructor Create; + protected + class function GetID: Integer; override; + public + class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; + end; + + { TSdbmHashFactory } + + TSimpleChecksumFactory = class(THashFactory) + strict private class var + FID: Integer; + class constructor Create; + protected + class function GetID: Integer; override; + public + class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; + end; + + { TDelphiDoubleHashFactory } + + TDelphiDoubleHashFactory = class(TExtendedHashFactory) + strict private class var + FID: Integer; + + class constructor Create; + protected + class function GetID: Integer; override; + public + const MAX_HASHLIST_COUNT = 2; + const HASH_FUNCTIONS_COUNT = 1; + const HASHLIST_COUNT_PER_FUNCTION: array[1..HASH_FUNCTIONS_COUNT] of Integer = (2); + const HASH_FUNCTIONS_MASK_SIZE = 1; + const HASH_FUNCTIONS_MASK = 1; // 00000001b + + class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; + class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); override; + end; + + TDelphiQuadrupleHashFactory = class(TExtendedHashFactory) + strict private class var + FID: Integer; + + class constructor Create; + protected + class function GetID: Integer; override; + public + const MAX_HASHLIST_COUNT = 4; + const HASH_FUNCTIONS_COUNT = 2; + const HASHLIST_COUNT_PER_FUNCTION: array[1..HASH_FUNCTIONS_COUNT] of Integer = (2, 2); + const HASH_FUNCTIONS_MASK_SIZE = 2; + const HASH_FUNCTIONS_MASK = 3; // 00000011b + + class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; + class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); override; + end; + + TDelphiSixfoldHashFactory = class(TExtendedHashFactory) + strict private class var + FID: Integer; + + class constructor Create; + protected + class function GetID: Integer; override; + public + const MAX_HASHLIST_COUNT = 6; + const HASH_FUNCTIONS_COUNT = 3; + const HASHLIST_COUNT_PER_FUNCTION: array[1..HASH_FUNCTIONS_COUNT] of Integer = (2, 2, 2); + const HASH_FUNCTIONS_MASK_SIZE = 3; + const HASH_FUNCTIONS_MASK = 7; // 00000111b + + class function GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32 = 0): UInt32; override; + class procedure GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; AOptions: TGetHashListOptions = []); override; + end; + + TDefaultHashFactory = TDelphiQuadrupleHashFactory; + + TDefaultGenericInterface = (giComparer, giEqualityComparer, giExtendedEqualityComparer); + + TCustomComparer<T> = class(TSingletonImplementation, IComparer<T>, IEqualityComparer<T>, IExtendedEqualityComparer<T>) + protected + function Compare(constref Left, Right: T): Integer; virtual; abstract; + function Equals(constref Left, Right: T): Boolean; reintroduce; overload; virtual; abstract; + function GetHashCode(constref Value: T): UInt32; reintroduce; overload; virtual; abstract; + procedure GetHashList(constref Value: T; AHashList: PUInt32); virtual; abstract; + end; + + TOrdinalComparer<T, THashFactory> = class(TCustomComparer<T>) + protected class var + FComparer: IComparer<T>; + FEqualityComparer: IEqualityComparer<T>; + FExtendedEqualityComparer: IExtendedEqualityComparer<T>; + + class constructor Create; + public + class function Ordinal: TCustomComparer<T>; virtual; abstract; + end; + + // TGStringComparer will be renamed to TStringComparer -> bug #26030 + // anyway class var can't be used safely -> bug #24848 + + TGStringComparer<T, THashFactory> = class(TOrdinalComparer<T, THashFactory>) + private class var + FOrdinal: TCustomComparer<T>; + class destructor Destroy; + public + class function Ordinal: TCustomComparer<T>; override; + end; + + TGStringComparer<T> = class(TGStringComparer<T, TDelphiQuadrupleHashFactory>); + TStringComparer = class(TGStringComparer<string>); + TAnsiStringComparer = class(TGStringComparer<AnsiString>); + TUnicodeStringComparer = class(TGStringComparer<UnicodeString>); + + { TGOrdinalStringComparer } + + // TGOrdinalStringComparer will be renamed to TOrdinalStringComparer -> bug #26030 + // anyway class var can't be used safely -> bug #24848 + TGOrdinalStringComparer<T, THashFactory> = class(TGStringComparer<T, THashFactory>) + public + function Compare(constref ALeft, ARight: T): Integer; override; + function Equals(constref ALeft, ARight: T): Boolean; overload; override; + function GetHashCode(constref AValue: T): UInt32; overload; override; + procedure GetHashList(constref AValue: T; AHashList: PUInt32); override; + end; + + TGOrdinalStringComparer<T> = class(TGOrdinalStringComparer<T, TDelphiQuadrupleHashFactory>); + TOrdinalStringComparer = class(TGOrdinalStringComparer<string>); + + TGIStringComparer<T, THashFactory> = class(TOrdinalComparer<T, THashFactory>) + private class var + FOrdinal: TCustomComparer<T>; + class destructor Destroy; + public + class function Ordinal: TCustomComparer<T>; override; + end; + + TGIStringComparer<T> = class(TGIStringComparer<T, TDelphiQuadrupleHashFactory>); + TIStringComparer = class(TGIStringComparer<string>); + TIAnsiStringComparer = class(TGIStringComparer<AnsiString>); + TIUnicodeStringComparer = class(TGIStringComparer<UnicodeString>); + + TGOrdinalIStringComparer<T, THashFactory> = class(TGIStringComparer<T, THashFactory>) + public + function Compare(constref ALeft, ARight: T): Integer; override; + function Equals(constref ALeft, ARight: T): Boolean; overload; override; + function GetHashCode(constref AValue: T): UInt32; overload; override; + procedure GetHashList(constref AValue: T; AHashList: PUInt32); override; + end; + + TGOrdinalIStringComparer<T> = class(TGOrdinalIStringComparer<T, TDelphiQuadrupleHashFactory>); + TOrdinalIStringComparer = class(TGOrdinalIStringComparer<string>); + +// Delphi version of Bob Jenkins Hash +function BobJenkinsHash(const AData; ALength, AInitData: Integer): Integer; // same result as HashLittle_Delphi, just different interface +function BinaryCompare(const ALeft, ARight: Pointer; ASize: PtrUInt): Integer; inline; + +function _LookupVtableInfo(AGInterface: TDefaultGenericInterface; ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; inline; +function _LookupVtableInfoEx(AGInterface: TDefaultGenericInterface; ATypeInfo: PTypeInfo; ASize: SizeInt; + AFactory: TComparerFactoryClass): Pointer; + +implementation + +var + ComparerFactory: array of TComparerFactory; + +{ TComparer<T> } + +class function TComparer<T>.Default: IComparer<T>; +begin + Result := _LookupVtableInfo(giComparer, TypeInfo(T), SizeOf(T)); +end; + +class function TComparer<T>.Construct(const AComparison: TOnComparison<T>): IComparer<T>; +begin + Result := TDelegatedComparerEvents<T>.Create(AComparison); +end; + +class function TComparer<T>.Construct(const AComparison: TComparisonFunc<T>): IComparer<T>; +begin + Result := TDelegatedComparerFunc<T>.Create(AComparison); +end; + +function TDelegatedComparerEvents<T>.Compare(constref ALeft, ARight: T): Integer; +begin + Result := FComparison(ALeft, ARight); +end; + +constructor TDelegatedComparerEvents<T>.Create(AComparison: TOnComparison<T>); +begin + FComparison := AComparison; +end; + +function TDelegatedComparerFunc<T>.Compare(constref ALeft, ARight: T): Integer; +begin + Result := FComparison(ALeft, ARight); +end; + +constructor TDelegatedComparerFunc<T>.Create(AComparison: TComparisonFunc<T>); +begin + FComparison := AComparison; +end; + +{ TInterface } + +function TInterface.QueryInterface(constref IID: TGUID; out Obj): HResult; +begin + Result := E_NOINTERFACE; +end; + +{ TRawInterface } + +function TRawInterface._AddRef: Integer; +begin + Result := -1; +end; + +function TRawInterface._Release: Integer; +begin + Result := -1; +end; + +{ TComTypeSizeInterface } + +function TComTypeSizeInterface._AddRef: Integer; +var + _self: TComparerFactory.PSpoofInterfacedTypeSizeObject absolute Self; +begin + Result := InterLockedIncrement(_self.RefCount); +end; + +function TComTypeSizeInterface._Release: Integer; +var + _self: TComparerFactory.PSpoofInterfacedTypeSizeObject absolute Self; +begin + Result := InterLockedDecrement(_self.RefCount); + if _self.RefCount = 0 then + Dispose(_self); +end; + +{ TSingletonImplementation } + +function TSingletonImplementation.QueryInterface(constref IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + +{ TCompare } + +(*********************************************************************************************************************** + Comparers +(**********************************************************************************************************************) + +{----------------------------------------------------------------------------------------------------------------------- + Comparers Int8 - Int32 and UInt8 - UInt32 +{----------------------------------------------------------------------------------------------------------------------} + +class function TCompare.Integer(constref ALeft, ARight: Integer): Integer; +begin + Result := Math.CompareValue(ALeft, ARight); +end; + +class function TCompare.Int8(constref ALeft, ARight: Int8): Integer; +begin + Result := ALeft - ARight; +end; + +class function TCompare.Int16(constref ALeft, ARight: Int16): Integer; +begin + Result := ALeft - ARight; +end; + +class function TCompare.Int32(constref ALeft, ARight: Int32): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.Int64(constref ALeft, ARight: Int64): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.UInt8(constref ALeft, ARight: UInt8): Integer; +begin + Result := System.Integer(ALeft) - System.Integer(ARight); +end; + +class function TCompare.UInt16(constref ALeft, ARight: UInt16): Integer; +begin + Result := System.Integer(ALeft) - System.Integer(ARight); +end; + +class function TCompare.UInt32(constref ALeft, ARight: UInt32): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.UInt64(constref ALeft, ARight: UInt64): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +{----------------------------------------------------------------------------------------------------------------------- + Comparers for Float types +{----------------------------------------------------------------------------------------------------------------------} + +class function TCompare.Single(constref ALeft, ARight: Single): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.Double(constref ALeft, ARight: Double): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.Extended(constref ALeft, ARight: Extended): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +{----------------------------------------------------------------------------------------------------------------------- + Comparers for other number types +{----------------------------------------------------------------------------------------------------------------------} + +class function TCompare.Currency(constref ALeft, ARight: Currency): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.Comp(constref ALeft, ARight: Comp): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +{----------------------------------------------------------------------------------------------------------------------- + Comparers for binary data (records etc) and dynamics arrays +{----------------------------------------------------------------------------------------------------------------------} + +class function TCompare._Binary(constref ALeft, ARight): Integer; +var + _self: TComparerFactory.PSpoofInterfacedTypeSizeObject absolute Self; +begin + Result := CompareMemRange(@ALeft, @ARight, _self.Size); +end; + +class function TCompare._DynArray(constref ALeft, ARight: Pointer): Integer; +var + _self: TComparerFactory.PSpoofInterfacedTypeSizeObject absolute Self; + LLength, LLeftLength, LRightLength: Integer; +begin + LLeftLength := DynArraySize(ALeft); + LRightLength := DynArraySize(ARight); + if LLeftLength > LRightLength then + LLength := LRightLength + else + LLength := LLeftLength; + + Result := CompareMemRange(ALeft, ARight, LLength * _self.Size); + + if Result = 0 then + Result := LLeftLength - LRightLength; +end; + +class function TCompare.Binary(constref ALeft, ARight; const ASize: SizeInt): Integer; +begin + Result := CompareMemRange(@ALeft, @ARight, ASize); +end; + +class function TCompare.DynArray(constref ALeft, ARight: Pointer; const AElementSize: SizeInt): Integer; +var + LLength, LLeftLength, LRightLength: Integer; +begin + LLeftLength := DynArraySize(ALeft); + LRightLength := DynArraySize(ARight); + if LLeftLength > LRightLength then + LLength := LRightLength + else + LLength := LLeftLength; + + Result := CompareMemRange(ALeft, ARight, LLength * AElementSize); + + if Result = 0 then + Result := LLeftLength - LRightLength; +end; + +{----------------------------------------------------------------------------------------------------------------------- + Comparers for string types +{----------------------------------------------------------------------------------------------------------------------} + +class function TCompare.ShortString1(constref ALeft, ARight: ShortString1): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.ShortString2(constref ALeft, ARight: ShortString2): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.ShortString3(constref ALeft, ARight: ShortString3): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.ShortString(constref ALeft, ARight: OpenString): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +class function TCompare.&String(constref ALeft, ARight: String): Integer; +begin + Result := CompareStr(ALeft, ARight); +end; + +class function TCompare.AnsiString(constref ALeft, ARight: AnsiString): Integer; +begin + Result := AnsiCompareStr(ALeft, ARight); +end; + +class function TCompare.WideString(constref ALeft, ARight: WideString): Integer; +begin + Result := WideCompareStr(ALeft, ARight); +end; + +class function TCompare.UnicodeString(constref ALeft, ARight: UnicodeString): Integer; +begin + Result := UnicodeCompareStr(ALeft, ARight); +end; + +{----------------------------------------------------------------------------------------------------------------------- + Comparers for Delegates +{----------------------------------------------------------------------------------------------------------------------} + +class function TCompare.Method(constref ALeft, ARight: TMethod): Integer; +begin + Result := CompareMemRange(@ALeft, @ARight, SizeOf(System.TMethod)); +end; + +{----------------------------------------------------------------------------------------------------------------------- + Comparers for Variant +{----------------------------------------------------------------------------------------------------------------------} + +class function TCompare.Variant(constref ALeft, ARight: PVariant): Integer; +var + LLeftString, LRightString: string; +begin + try + case VarCompareValue(ALeft^, ARight^) of + vrGreaterThan: + Exit(1); + vrLessThan: + Exit(-1); + vrEqual: + Exit(0); + vrNotEqual: + if VarIsEmpty(ALeft^) or VarIsNull(ALeft^) then + Exit(1) + else + Exit(-1); + end; + except + try + LLeftString := ALeft^; + LRightString := ARight^; + Result := CompareStr(LLeftString, LRightString); + except + Result := CompareMemRange(ALeft, ARight, SizeOf(System.Variant)); + end; + end; +end; + +{----------------------------------------------------------------------------------------------------------------------- + Comparers for Pointer +{----------------------------------------------------------------------------------------------------------------------} + +class function TCompare.Pointer(constref ALeft, ARight: PtrUInt): Integer; +begin + if ALeft > ARight then + Exit(1) + else if ALeft < ARight then + Exit(-1) + else + Exit(0); +end; + +{ TEquals } + +(*********************************************************************************************************************** + Equality Comparers +(**********************************************************************************************************************) + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers Int8 - Int32 and UInt8 - UInt32 +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals.Integer(constref ALeft, ARight: Integer): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.Int8(constref ALeft, ARight: Int8): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.Int16(constref ALeft, ARight: Int16): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.Int32(constref ALeft, ARight: Int32): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.Int64(constref ALeft, ARight: Int64): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.UInt8(constref ALeft, ARight: UInt8): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.UInt16(constref ALeft, ARight: UInt16): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.UInt32(constref ALeft, ARight: UInt32): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.UInt64(constref ALeft, ARight: UInt64): Boolean; +begin + Result := ALeft = ARight; +end; + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers for Float types +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals.Single(constref ALeft, ARight: Single): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.Double(constref ALeft, ARight: Double): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.Extended(constref ALeft, ARight: Extended): Boolean; +begin + Result := ALeft = ARight; +end; + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers for other number types +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals.Currency(constref ALeft, ARight: Currency): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.Comp(constref ALeft, ARight: Comp): Boolean; +begin + Result := ALeft = ARight; +end; + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers for binary data (records etc) and dynamics arrays +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals._Binary(constref ALeft, ARight): Boolean; +var + _self: TComparerFactory.PSpoofInterfacedTypeSizeObject absolute Self; +begin + Result := CompareMem(@ALeft, @ARight, _self.Size); +end; + +class function TEquals._DynArray(constref ALeft, ARight: Pointer): Boolean; +var + _self: TComparerFactory.PSpoofInterfacedTypeSizeObject absolute Self; + LLength: Integer; +begin + LLength := DynArraySize(ALeft); + if LLength <> DynArraySize(ARight) then + Exit(False); + + Result := CompareMem(ALeft, ARight, LLength * _self.Size); +end; + +class function TEquals.Binary(constref ALeft, ARight; const ASize: SizeInt): Boolean; +begin + Result := CompareMem(@ALeft, @ARight, ASize); +end; + +class function TEquals.DynArray(constref ALeft, ARight: Pointer; const AElementSize: SizeInt): Boolean; +var + LLength: Integer; +begin + LLength := DynArraySize(ALeft); + if LLength <> DynArraySize(ARight) then + Exit(False); + + Result := CompareMem(ALeft, ARight, LLength * AElementSize); +end; + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers for classes +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals.&class(constref ALeft, ARight: TObject): Boolean; +begin + if ALeft <> nil then + Exit(ALeft.Equals(ARight)) + else + Exit(ARight = nil); +end; + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers for string types +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals.ShortString1(constref ALeft, ARight: ShortString1): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.ShortString2(constref ALeft, ARight: ShortString2): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.ShortString3(constref ALeft, ARight: ShortString3): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.&String(constref ALeft, ARight: String): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.ShortString(constref ALeft, ARight: OpenString): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.AnsiString(constref ALeft, ARight: AnsiString): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.WideString(constref ALeft, ARight: WideString): Boolean; +begin + Result := ALeft = ARight; +end; + +class function TEquals.UnicodeString(constref ALeft, ARight: UnicodeString): Boolean; +begin + Result := ALeft = ARight; +end; + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers for Delegates +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals.Method(constref ALeft, ARight: TMethod): Boolean; +begin + Result := (ALeft.Code = ARight.Code) and (ALeft.Data = ARight.Data); +end; + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers for Variant +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals.Variant(constref ALeft, ARight: PVariant): Boolean; +begin + Result := VarCompareValue(ALeft^, ARight^) = vrEqual; +end; + +{----------------------------------------------------------------------------------------------------------------------- + Equality Comparers for Pointer +{----------------------------------------------------------------------------------------------------------------------} + +class function TEquals.Pointer(constref ALeft, ARight: PtrUInt): Boolean; +begin + Result := ALeft = ARight; +end; + +{ TComparerFactory } + +class function TComparerFactory.CreateInterface(AVMT: Pointer; ASize: SizeInt): PSpoofInterfacedTypeSizeObject; +begin + Result := New(PSpoofInterfacedTypeSizeObject); + Result.VMT := AVMT; + Result.RefCount := 0; + Result.Size := ASize; +end; + +class function TComparerFactory.SelectIntegerComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + case ATypeData.OrdType of + otSByte: + Exit(@Comparer_Int8_Instance); + otUByte: + Exit(@Comparer_UInt8_Instance); + otSWord: + Exit(@Comparer_Int16_Instance); + otUWord: + Exit(@Comparer_UInt16_Instance); + otSLong: + Exit(@Comparer_Int32_Instance); + otULong: + Exit(@Comparer_UInt32_Instance); + else + System.Error(reRangeError); + Exit(nil); + end; +end; + +class function TComparerFactory.SelectInt64Comparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + if ATypeData.MaxInt64Value > ATypeData.MinInt64Value then + Exit(@Comparer_Int64_Instance) + else + Exit(@Comparer_UInt64_Instance); +end; + +class function TComparerFactory.SelectFloatComparer(ATypeData: PTypeData; + ASize: SizeInt): Pointer; +begin + case ATypeData.FloatType of + ftSingle: + Exit(@Comparer_Single_Instance); + ftDouble: + Exit(@Comparer_Double_Instance); + ftExtended: + Exit(@Comparer_Extended_Instance); + ftComp: + Exit(@Comparer_Comp_Instance); + ftCurr: + Exit(@Comparer_Currency_Instance); + else + System.Error(reRangeError); + Exit(nil); + end; +end; + +class function TComparerFactory.SelectShortStringComparer(ATypeData: PTypeData; + ASize: SizeInt): Pointer; +begin + case ASize of + 2: Exit(@Comparer_ShortString1_Instance); + 3: Exit(@Comparer_ShortString2_Instance); + 4: Exit(@Comparer_ShortString3_Instance); + else + Exit(@Comparer_ShortString_Instance); + end; +end; + +class function TComparerFactory.SelectBinaryComparer(ATypeData: PTypeData; + ASize: SizeInt): Pointer; +begin + case ASize of + 1: Exit(@Comparer_UInt8_Instance); + 2: Exit(@Comparer_UInt16_Instance); + 4: Exit(@Comparer_UInt32_Instance); +{$IFDEF CPU64} + 8: Exit(@Comparer_UInt64_Instance) +{$ENDIF} + else + Result := CreateInterface(@Comparer_Binary_VMT, ASize); + end; +end; + +class function TComparerFactory.SelectDynArrayComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + Result := CreateInterface(@Comparer_DynArray_VMT, ATypeData.elSize); +end; + +constructor TComparerFactory.Create; +begin +end; + +class function TComparerFactory.LookupComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; +var + LInstance: PInstance; +begin + if ATypeInfo = nil then + Exit(SelectBinaryComparer(GetTypeData(ATypeInfo), ASize)) + else + begin + LInstance := @ComparerInstances[ATypeInfo.Kind]; + Result := LInstance.Instance; + if LInstance.Selector then + Result := TSelectFunc(Result)(GetTypeData(ATypeInfo), ASize); + end; +end; + +class function TComparerFactory.Register(const AComparerFactory: TComparerFactoryClass): Integer; +begin + Result := Length(ComparerFactory); + SetLength(ComparerFactory, Result + 1); + ComparerFactory[Result] := AComparerFactory.Create; +end; + +{ TComparerFactory.TInstance } + +class function TComparerFactory.TInstance.Create(ASelector: Boolean; + AInstance: Pointer): THashCode.TInstance; +begin + Result.Selector := ASelector; + Result.Instance := AInstance; +end; + +{ THashCode } + +(*********************************************************************************************************************** + Hashes +(**********************************************************************************************************************) + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode Int8 - Int32 and UInt8 - UInt32 +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.Int8(constref AValue: Int8): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int8), 0); +end; + +class function THashCode.Int16(constref AValue: Int16): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int16), 0); +end; + +class function THashCode.Int32(constref AValue: Int32): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int32), 0); +end; + +class function THashCode.Int64(constref AValue: Int64): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int64), 0); +end; + +class function THashCode.UInt8(constref AValue: UInt8): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.UInt8), 0); +end; + +class function THashCode.UInt16(constref AValue: UInt16): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.UInt16), 0); +end; + +class function THashCode.UInt32(constref AValue: UInt32): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.UInt32), 0); +end; + +class function THashCode.UInt64(constref AValue: UInt64): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.UInt64), 0); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for Float types +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.Single(constref AValue: Single): UInt32; +var + LMantissa: Float; + LExponent: Integer; +begin + Frexp(AValue, LMantissa, LExponent); + + if LMantissa = 0 then + LMantissa := Abs(LMantissa); + + Result := HASH_FACTORY.GetHashCode(@LMantissa, SizeOf(Math.Float), 0); + Result := HASH_FACTORY.GetHashCode(@LExponent, SizeOf(System.Integer), Result); +end; + +class function THashCode.Double(constref AValue: Double): UInt32; +var + LMantissa: Float; + LExponent: Integer; +begin + Frexp(AValue, LMantissa, LExponent); + + if LMantissa = 0 then + LMantissa := Abs(LMantissa); + + Result := HASH_FACTORY.GetHashCode(@LMantissa, SizeOf(Math.Float), 0); + Result := HASH_FACTORY.GetHashCode(@LExponent, SizeOf(System.Integer), Result); +end; + +class function THashCode.Extended(constref AValue: Extended): UInt32; +var + LMantissa: Float; + LExponent: Integer; +begin + Frexp(AValue, LMantissa, LExponent); + + if LMantissa = 0 then + LMantissa := Abs(LMantissa); + + Result := HASH_FACTORY.GetHashCode(@LMantissa, SizeOf(Math.Float), 0); + Result := HASH_FACTORY.GetHashCode(@LExponent, SizeOf(System.Integer), Result); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for other number types +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.Currency(constref AValue: Currency): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int64), 0); +end; + +class function THashCode.Comp(constref AValue: Comp): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Int64), 0); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for binary data (records etc) and dynamics arrays +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.Binary(constref AValue): UInt32; +var + _self: PSpoofInterfacedTypeSizeObject absolute Self; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, _self.Size, 0); +end; + +class function THashCode.DynArray(constref AValue: Pointer): UInt32; +var + _self: PSpoofInterfacedTypeSizeObject absolute Self; +begin + Result := HASH_FACTORY.GetHashCode(AValue, DynArraySize(AValue) * _self.Size, 0); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for classes +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.&Class(constref AValue: TObject): UInt32; +begin + if AValue = nil then + Exit($2A); + + Result := AValue.GetHashCode; +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for string types +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.ShortString1(constref AValue: ShortString1): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue), 0); +end; + +class function THashCode.ShortString2(constref AValue: ShortString2): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue), 0); +end; + +class function THashCode.ShortString3(constref AValue: ShortString3): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue), 0); +end; + +class function THashCode.ShortString(constref AValue: OpenString): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue), 0); +end; + +class function THashCode.AnsiString(constref AValue: AnsiString): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue) * SizeOf(System.AnsiChar), 0); +end; + +class function THashCode.WideString(constref AValue: WideString): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue) * SizeOf(System.WideChar), 0); +end; + +class function THashCode.UnicodeString(constref AValue: UnicodeString): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue[1], Length(AValue) * SizeOf(System.UnicodeChar), 0); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for Delegates +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.Method(constref AValue: TMethod): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.TMethod), 0); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for Variant +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.Variant(constref AValue: PVariant): UInt32; +begin + try + Result := HASH_FACTORY.UnicodeString(AValue^); + except + Result := HASH_FACTORY.GetHashCode(AValue, SizeOf(System.Variant), 0); + end; +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for Pointer +{----------------------------------------------------------------------------------------------------------------------} + +class function THashCode.Pointer(constref AValue: Pointer): UInt32; +begin + Result := HASH_FACTORY.GetHashCode(@AValue, SizeOf(System.Pointer), 0); +end; + +{ TExtendedHashCode } + +(*********************************************************************************************************************** + Hashes 2 +(**********************************************************************************************************************) + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode Int8 - Int32 and UInt8 - UInt32 +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.Int8(constref AValue: Int8; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int8), AHashList, []); +end; + +class procedure TExtendedHashCode.Int16(constref AValue: Int16; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int16), AHashList, []); +end; + +class procedure TExtendedHashCode.Int32(constref AValue: Int32; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int32), AHashList, []); +end; + +class procedure TExtendedHashCode.Int64(constref AValue: Int64; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int64), AHashList, []); +end; + +class procedure TExtendedHashCode.UInt8(constref AValue: UInt8; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.UInt8), AHashList, []); +end; + +class procedure TExtendedHashCode.UInt16(constref AValue: UInt16; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.UInt16), AHashList, []); +end; + +class procedure TExtendedHashCode.UInt32(constref AValue: UInt32; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.UInt32), AHashList, []); +end; + +class procedure TExtendedHashCode.UInt64(constref AValue: UInt64; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.UInt64), AHashList, []); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for Float types +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.Single(constref AValue: Single; AHashList: PUInt32); +var + LMantissa: Float; + LExponent: Integer; +begin + Frexp(AValue, LMantissa, LExponent); + + if LMantissa = 0 then + LMantissa := Abs(LMantissa); + + EXTENDED_HASH_FACTORY.GetHashList(@LMantissa, SizeOf(Math.Float), AHashList, []); + EXTENDED_HASH_FACTORY.GetHashList(@LExponent, SizeOf(System.Integer), AHashList, [ghloHashListAsInitData]); +end; + +class procedure TExtendedHashCode.Double(constref AValue: Double; AHashList: PUInt32); +var + LMantissa: Float; + LExponent: Integer; +begin + Frexp(AValue, LMantissa, LExponent); + + if LMantissa = 0 then + LMantissa := Abs(LMantissa); + + EXTENDED_HASH_FACTORY.GetHashList(@LMantissa, SizeOf(Math.Float), AHashList, []); + EXTENDED_HASH_FACTORY.GetHashList(@LExponent, SizeOf(System.Integer), AHashList, [ghloHashListAsInitData]); +end; + +class procedure TExtendedHashCode.Extended(constref AValue: Extended; AHashList: PUInt32); +var + LMantissa: Float; + LExponent: Integer; +begin + Frexp(AValue, LMantissa, LExponent); + + if LMantissa = 0 then + LMantissa := Abs(LMantissa); + + EXTENDED_HASH_FACTORY.GetHashList(@LMantissa, SizeOf(Math.Float), AHashList, []); + EXTENDED_HASH_FACTORY.GetHashList(@LExponent, SizeOf(System.Integer), AHashList, [ghloHashListAsInitData]); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for other number types +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.Currency(constref AValue: Currency; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int64), AHashList, []); +end; + +class procedure TExtendedHashCode.Comp(constref AValue: Comp; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Int64), AHashList, []); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for binary data (records etc) and dynamics arrays +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.Binary(constref AValue; AHashList: PUInt32); +var + _self: PSpoofInterfacedTypeSizeObject absolute Self; +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, _self.Size, AHashList, []); +end; + +class procedure TExtendedHashCode.DynArray(constref AValue: Pointer; AHashList: PUInt32); +var + _self: PSpoofInterfacedTypeSizeObject absolute Self; +begin + EXTENDED_HASH_FACTORY.GetHashList(AValue, DynArraySize(AValue) * _self.Size, AHashList, []); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for classes +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.&Class(constref AValue: TObject; AHashList: PUInt32); +var + LValue: PtrInt; +begin + if AValue = nil then + begin + LValue := $2A; + EXTENDED_HASH_FACTORY.GetHashList(@LValue, SizeOf(LValue), AHashList, []); + Exit; + end; + + LValue := AValue.GetHashCode; + EXTENDED_HASH_FACTORY.GetHashList(@LValue, SizeOf(LValue), AHashList, []); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for string types +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.ShortString1(constref AValue: ShortString1; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue), AHashList, []); +end; + +class procedure TExtendedHashCode.ShortString2(constref AValue: ShortString2; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue), AHashList, []); +end; + +class procedure TExtendedHashCode.ShortString3(constref AValue: ShortString3; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue), AHashList, []); +end; + +class procedure TExtendedHashCode.ShortString(constref AValue: OpenString; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue), AHashList, []); +end; + +class procedure TExtendedHashCode.AnsiString(constref AValue: AnsiString; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue) * SizeOf(System.AnsiChar), AHashList, []); +end; + +class procedure TExtendedHashCode.WideString(constref AValue: WideString; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue) * SizeOf(System.WideChar), AHashList, []); +end; + +class procedure TExtendedHashCode.UnicodeString(constref AValue: UnicodeString; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue[1], Length(AValue) * SizeOf(System.UnicodeChar), AHashList, []); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for Delegates +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.Method(constref AValue: TMethod; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.TMethod), AHashList, []); +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for Variant +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.Variant(constref AValue: PVariant; AHashList: PUInt32); +begin + try + EXTENDED_HASH_FACTORY.UnicodeString(AValue^, AHashList); + except + EXTENDED_HASH_FACTORY.GetHashList(AValue, SizeOf(System.Variant), AHashList, []); + end; +end; + +{----------------------------------------------------------------------------------------------------------------------- + GetHashCode for Pointer +{----------------------------------------------------------------------------------------------------------------------} + +class procedure TExtendedHashCode.Pointer(constref AValue: Pointer; AHashList: PUInt32); +begin + EXTENDED_HASH_FACTORY.GetHashList(@AValue, SizeOf(System.Pointer), AHashList, []); +end; + +{ THashFactory } + +function THashFactory.SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + case ATypeData.OrdType of + otSByte: + Exit(@FEqualityComparer_Int8_Instance); + otUByte: + Exit(@FEqualityComparer_UInt8_Instance); + otSWord: + Exit(@FEqualityComparer_Int16_Instance); + otUWord: + Exit(@FEqualityComparer_UInt16_Instance); + otSLong: + Exit(@FEqualityComparer_Int32_Instance); + otULong: + Exit(@FEqualityComparer_UInt32_Instance); + else + System.Error(reRangeError); + Exit(nil); + end; +end; + +function THashFactory.SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + case ATypeData.FloatType of + ftSingle: + Exit(@FEqualityComparer_Single_Instance); + ftDouble: + Exit(@FEqualityComparer_Double_Instance); + ftExtended: + Exit(@FEqualityComparer_Extended_Instance); + ftComp: + Exit(@FEqualityComparer_Comp_Instance); + ftCurr: + Exit(@FEqualityComparer_Currency_Instance); + else + System.Error(reRangeError); + Exit(nil); + end; +end; + +function THashFactory.SelectShortStringEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + case ASize of + 2: Exit(@FEqualityComparer_ShortString1_Instance); + 3: Exit(@FEqualityComparer_ShortString2_Instance); + 4: Exit(@FEqualityComparer_ShortString3_Instance); + else + Exit(@FEqualityComparer_ShortString_Instance); + end +end; + +function THashFactory.SelectBinaryEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + case ASize of + 1: Exit(@FEqualityComparer_UInt8_Instance); + 2: Exit(@FEqualityComparer_UInt16_Instance); + 4: Exit(@FEqualityComparer_UInt32_Instance); +{$IFDEF CPU64} + 8: Exit(@FEqualityComparer_UInt64_Instance) +{$ENDIF} + else + Result := CreateInterface(@FEqualityComparer_Binary_VMT, ASize); + end; +end; + +function THashFactory.SelectDynArrayEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + Result := CreateInterface(@FEqualityComparer_DynArray_VMT, ATypeData.elSize); +end; + +function THashFactory.LookupEqualityComparer(ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; +var + LInstance: PInstance; + LSelectMethod: TSelectMethod; +begin + if ATypeInfo = nil then + Exit(SelectBinaryEqualityComparer(GetTypeData(ATypeInfo), ASize)) + else + begin + LInstance := @FEqualityComparerInstances[ATypeInfo.Kind]; + Result := LInstance.Instance; + if LInstance.Selector then + begin + TMethod(LSelectMethod).Code := Result; + TMethod(LSelectMethod).Data := Self; + Result := LSelectMethod(GetTypeData(ATypeInfo), ASize); + end; + end; +end; + +constructor THashFactory.Create; +begin + inherited; + + FEqualityComparer_Int8_VMT := EqualityComparer_Int8_VMT ; + FEqualityComparer_Int16_VMT := EqualityComparer_Int16_VMT ; + FEqualityComparer_Int32_VMT := EqualityComparer_Int32_VMT ; + FEqualityComparer_Int64_VMT := EqualityComparer_Int64_VMT ; + FEqualityComparer_UInt8_VMT := EqualityComparer_UInt8_VMT ; + FEqualityComparer_UInt16_VMT := EqualityComparer_UInt16_VMT ; + FEqualityComparer_UInt32_VMT := EqualityComparer_UInt32_VMT ; + FEqualityComparer_UInt64_VMT := EqualityComparer_UInt64_VMT ; + FEqualityComparer_Single_VMT := EqualityComparer_Single_VMT ; + FEqualityComparer_Double_VMT := EqualityComparer_Double_VMT ; + FEqualityComparer_Extended_VMT := EqualityComparer_Extended_VMT ; + FEqualityComparer_Currency_VMT := EqualityComparer_Currency_VMT ; + FEqualityComparer_Comp_VMT := EqualityComparer_Comp_VMT ; + FEqualityComparer_Binary_VMT := EqualityComparer_Binary_VMT ; + FEqualityComparer_DynArray_VMT := EqualityComparer_DynArray_VMT ; + FEqualityComparer_Class_VMT := EqualityComparer_Class_VMT ; + FEqualityComparer_ShortString1_VMT := EqualityComparer_ShortString1_VMT ; + FEqualityComparer_ShortString2_VMT := EqualityComparer_ShortString2_VMT ; + FEqualityComparer_ShortString3_VMT := EqualityComparer_ShortString3_VMT ; + FEqualityComparer_ShortString_VMT := EqualityComparer_ShortString_VMT ; + FEqualityComparer_AnsiString_VMT := EqualityComparer_AnsiString_VMT ; + FEqualityComparer_WideString_VMT := EqualityComparer_WideString_VMT ; + FEqualityComparer_UnicodeString_VMT := EqualityComparer_UnicodeString_VMT; + FEqualityComparer_Method_VMT := EqualityComparer_Method_VMT ; + FEqualityComparer_Variant_VMT := EqualityComparer_Variant_VMT ; + FEqualityComparer_Pointer_VMT := EqualityComparer_Pointer_VMT ; + + ///// + FEqualityComparer_Int8_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Int16_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Int32_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Int64_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_UInt8_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_UInt16_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_UInt32_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_UInt64_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Single_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Double_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Extended_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Currency_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Comp_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Binary_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_DynArray_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Class_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_ShortString1_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_ShortString2_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_ShortString3_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_ShortString_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_AnsiString_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_WideString_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_UnicodeString_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Method_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Variant_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + FEqualityComparer_Pointer_VMT.__ClassRef := THashFactoryClass(Self.ClassType); + + /////// + FEqualityComparer_Int8_Instance := @FEqualityComparer_Int8_VMT ; + FEqualityComparer_Int16_Instance := @FEqualityComparer_Int16_VMT ; + FEqualityComparer_Int32_Instance := @FEqualityComparer_Int32_VMT ; + FEqualityComparer_Int64_Instance := @FEqualityComparer_Int64_VMT ; + FEqualityComparer_UInt8_Instance := @FEqualityComparer_UInt8_VMT ; + FEqualityComparer_UInt16_Instance := @FEqualityComparer_UInt16_VMT ; + FEqualityComparer_UInt32_Instance := @FEqualityComparer_UInt32_VMT ; + FEqualityComparer_UInt64_Instance := @FEqualityComparer_UInt64_VMT ; + FEqualityComparer_Single_Instance := @FEqualityComparer_Single_VMT ; + FEqualityComparer_Double_Instance := @FEqualityComparer_Double_VMT ; + FEqualityComparer_Extended_Instance := @FEqualityComparer_Extended_VMT ; + FEqualityComparer_Currency_Instance := @FEqualityComparer_Currency_VMT ; + FEqualityComparer_Comp_Instance := @FEqualityComparer_Comp_VMT ; + //FEqualityComparer_Binary_Instance := @FEqualityComparer_Binary_VMT ; // dynamic instance + //FEqualityComparer_DynArray_Instance := @FEqualityComparer_DynArray_VMT ; // dynamic instance + FEqualityComparer_ShortString1_Instance := @FEqualityComparer_ShortString1_VMT ; + FEqualityComparer_ShortString2_Instance := @FEqualityComparer_ShortString2_VMT ; + FEqualityComparer_ShortString3_Instance := @FEqualityComparer_ShortString3_VMT ; + FEqualityComparer_ShortString_Instance := @FEqualityComparer_ShortString_VMT ; + FEqualityComparer_AnsiString_Instance := @FEqualityComparer_AnsiString_VMT ; + FEqualityComparer_WideString_Instance := @FEqualityComparer_WideString_VMT ; + FEqualityComparer_UnicodeString_Instance := @FEqualityComparer_UnicodeString_VMT; + FEqualityComparer_Method_Instance := @FEqualityComparer_Method_VMT ; + FEqualityComparer_Variant_Instance := @FEqualityComparer_Variant_VMT ; + FEqualityComparer_Pointer_Instance := @FEqualityComparer_Pointer_VMT ; + + ////// + FEqualityComparerInstances[tkUnknown] := TInstance.Create(True, @THashFactory.SelectBinaryEqualityComparer); + FEqualityComparerInstances[tkInteger] := TInstance.Create(True, @THashFactory.SelectIntegerEqualityComparer); + FEqualityComparerInstances[tkChar] := TInstance.Create(False, @FEqualityComparer_UInt8_Instance); + FEqualityComparerInstances[tkEnumeration] := TInstance.Create(True, @THashFactory.SelectIntegerEqualityComparer); + FEqualityComparerInstances[tkFloat] := TInstance.Create(True, @THashFactory.SelectFloatEqualityComparer); + FEqualityComparerInstances[tkSet] := TInstance.Create(True, @THashFactory.SelectBinaryEqualityComparer); + FEqualityComparerInstances[tkMethod] := TInstance.Create(False, @FEqualityComparer_Method_Instance); + FEqualityComparerInstances[tkSString] := TInstance.Create(True, @THashFactory.SelectShortStringEqualityComparer); + FEqualityComparerInstances[tkLString] := TInstance.Create(False, @FEqualityComparer_AnsiString_Instance); + FEqualityComparerInstances[tkAString] := TInstance.Create(False, @FEqualityComparer_AnsiString_Instance); + FEqualityComparerInstances[tkWString] := TInstance.Create(False, @FEqualityComparer_WideString_Instance); + FEqualityComparerInstances[tkVariant] := TInstance.Create(False, @FEqualityComparer_Variant_Instance); + FEqualityComparerInstances[tkArray] := TInstance.Create(True, @THashFactory.SelectBinaryEqualityComparer); + FEqualityComparerInstances[tkRecord] := TInstance.Create(True, @THashFactory.SelectBinaryEqualityComparer); + FEqualityComparerInstances[tkInterface] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); + FEqualityComparerInstances[tkClass] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); + FEqualityComparerInstances[tkObject] := TInstance.Create(True, @THashFactory.SelectBinaryEqualityComparer); + FEqualityComparerInstances[tkWChar] := TInstance.Create(False, @FEqualityComparer_UInt16_Instance); + FEqualityComparerInstances[tkBool] := TInstance.Create(True, @THashFactory.SelectIntegerEqualityComparer); + FEqualityComparerInstances[tkInt64] := TInstance.Create(False, @FEqualityComparer_Int64_Instance); + FEqualityComparerInstances[tkQWord] := TInstance.Create(False, @FEqualityComparer_UInt64_Instance); + FEqualityComparerInstances[tkDynArray] := TInstance.Create(True, @THashFactory.SelectDynArrayEqualityComparer); + FEqualityComparerInstances[tkInterfaceRaw] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); + FEqualityComparerInstances[tkProcVar] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); + FEqualityComparerInstances[tkUString] := TInstance.Create(False, @FEqualityComparer_UnicodeString_Instance); + FEqualityComparerInstances[tkUChar] := TInstance.Create(False, @FEqualityComparer_UInt16_Instance); + FEqualityComparerInstances[tkHelper] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); + FEqualityComparerInstances[tkFile] := TInstance.Create(True, @THashFactory.SelectBinaryEqualityComparer); + FEqualityComparerInstances[tkClassRef] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); + FEqualityComparerInstances[tkPointer] := TInstance.Create(False, @FEqualityComparer_Pointer_Instance); +end; + +{ TExtendedHashFactory } + +function TExtendedHashFactory.SelectIntegerEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + case ATypeData.OrdType of + otSByte: + Exit(@FExtendedEqualityComparer_Int8_Instance); + otUByte: + Exit(@FExtendedEqualityComparer_UInt8_Instance); + otSWord: + Exit(@FExtendedEqualityComparer_Int16_Instance); + otUWord: + Exit(@FExtendedEqualityComparer_UInt16_Instance); + otSLong: + Exit(@FExtendedEqualityComparer_Int32_Instance); + otULong: + Exit(@FExtendedEqualityComparer_UInt32_Instance); + else + System.Error(reRangeError); + Exit(nil); + end; +end; + +function TExtendedHashFactory.SelectFloatEqualityComparer(ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + case ATypeData.FloatType of + ftSingle: + Exit(@FExtendedEqualityComparer_Single_Instance); + ftDouble: + Exit(@FExtendedEqualityComparer_Double_Instance); + ftExtended: + Exit(@FExtendedEqualityComparer_Extended_Instance); + ftComp: + Exit(@FExtendedEqualityComparer_Comp_Instance); + ftCurr: + Exit(@FExtendedEqualityComparer_Currency_Instance); + else + System.Error(reRangeError); + Exit(nil); + end; +end; + +function TExtendedHashFactory.SelectShortStringEqualityComparer(ATypeData: PTypeData; + ASize: SizeInt): Pointer; +begin + case ASize of + 2: Exit(@FExtendedEqualityComparer_ShortString1_Instance); + 3: Exit(@FExtendedEqualityComparer_ShortString2_Instance); + 4: Exit(@FExtendedEqualityComparer_ShortString3_Instance); + else + Exit(@FExtendedEqualityComparer_ShortString_Instance); + end +end; + +function TExtendedHashFactory.SelectBinaryEqualityComparer(ATypeData: PTypeData; + ASize: SizeInt): Pointer; +begin + case ASize of + 1: Exit(@FExtendedEqualityComparer_UInt8_Instance); + 2: Exit(@FExtendedEqualityComparer_UInt16_Instance); + 4: Exit(@FExtendedEqualityComparer_UInt32_Instance); +{$IFDEF CPU64} + 8: Exit(@FExtendedEqualityComparer_UInt64_Instance) +{$ENDIF} + else + Result := CreateInterface(@FExtendedEqualityComparer_Binary_VMT, ASize); + end; +end; + +function TExtendedHashFactory.SelectDynArrayEqualityComparer( + ATypeData: PTypeData; ASize: SizeInt): Pointer; +begin + Result := CreateInterface(@FExtendedEqualityComparer_DynArray_VMT, ATypeData.elSize); +end; + +function TExtendedHashFactory.LookupExtendedEqualityComparer( + ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; +var + LInstance: PInstance; + LSelectMethod: TSelectMethod; +begin + if ATypeInfo = nil then + Exit(SelectBinaryEqualityComparer(GetTypeData(ATypeInfo), ASize)) + else + begin + LInstance := @FExtendedEqualityComparerInstances[ATypeInfo.Kind]; + Result := LInstance.Instance; + if LInstance.Selector then + begin + TMethod(LSelectMethod).Code := Result; + TMethod(LSelectMethod).Data := Self; + Result := LSelectMethod(GetTypeData(ATypeInfo), ASize); + end; + end; +end; + +constructor TExtendedHashFactory.Create; +begin + inherited Create; + + FExtendedEqualityComparer_Int8_VMT := ExtendedEqualityComparer_Int8_VMT ; + FExtendedEqualityComparer_Int16_VMT := ExtendedEqualityComparer_Int16_VMT ; + FExtendedEqualityComparer_Int32_VMT := ExtendedEqualityComparer_Int32_VMT ; + FExtendedEqualityComparer_Int64_VMT := ExtendedEqualityComparer_Int64_VMT ; + FExtendedEqualityComparer_UInt8_VMT := ExtendedEqualityComparer_UInt8_VMT ; + FExtendedEqualityComparer_UInt16_VMT := ExtendedEqualityComparer_UInt16_VMT ; + FExtendedEqualityComparer_UInt32_VMT := ExtendedEqualityComparer_UInt32_VMT ; + FExtendedEqualityComparer_UInt64_VMT := ExtendedEqualityComparer_UInt64_VMT ; + FExtendedEqualityComparer_Single_VMT := ExtendedEqualityComparer_Single_VMT ; + FExtendedEqualityComparer_Double_VMT := ExtendedEqualityComparer_Double_VMT ; + FExtendedEqualityComparer_Extended_VMT := ExtendedEqualityComparer_Extended_VMT ; + FExtendedEqualityComparer_Currency_VMT := ExtendedEqualityComparer_Currency_VMT ; + FExtendedEqualityComparer_Comp_VMT := ExtendedEqualityComparer_Comp_VMT ; + FExtendedEqualityComparer_Binary_VMT := ExtendedEqualityComparer_Binary_VMT ; + FExtendedEqualityComparer_DynArray_VMT := ExtendedEqualityComparer_DynArray_VMT ; + FExtendedEqualityComparer_Class_VMT := ExtendedEqualityComparer_Class_VMT ; + FExtendedEqualityComparer_ShortString1_VMT := ExtendedEqualityComparer_ShortString1_VMT ; + FExtendedEqualityComparer_ShortString2_VMT := ExtendedEqualityComparer_ShortString2_VMT ; + FExtendedEqualityComparer_ShortString3_VMT := ExtendedEqualityComparer_ShortString3_VMT ; + FExtendedEqualityComparer_ShortString_VMT := ExtendedEqualityComparer_ShortString_VMT ; + FExtendedEqualityComparer_AnsiString_VMT := ExtendedEqualityComparer_AnsiString_VMT ; + FExtendedEqualityComparer_WideString_VMT := ExtendedEqualityComparer_WideString_VMT ; + FExtendedEqualityComparer_UnicodeString_VMT := ExtendedEqualityComparer_UnicodeString_VMT; + FExtendedEqualityComparer_Method_VMT := ExtendedEqualityComparer_Method_VMT ; + FExtendedEqualityComparer_Variant_VMT := ExtendedEqualityComparer_Variant_VMT ; + FExtendedEqualityComparer_Pointer_VMT := ExtendedEqualityComparer_Pointer_VMT ; + + ///// + FExtendedEqualityComparer_Int8_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Int16_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Int32_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Int64_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_UInt8_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_UInt16_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_UInt32_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_UInt64_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Single_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Double_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Extended_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Currency_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Comp_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Binary_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_DynArray_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Class_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_ShortString1_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_ShortString2_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_ShortString3_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_ShortString_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_AnsiString_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_WideString_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_UnicodeString_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Method_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Variant_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + FExtendedEqualityComparer_Pointer_VMT.__ClassRef := TExtendedHashFactoryClass(Self.ClassType); + + /////// + FExtendedEqualityComparer_Int8_Instance := @FExtendedEqualityComparer_Int8_VMT ; + FExtendedEqualityComparer_Int16_Instance := @FExtendedEqualityComparer_Int16_VMT ; + FExtendedEqualityComparer_Int32_Instance := @FExtendedEqualityComparer_Int32_VMT ; + FExtendedEqualityComparer_Int64_Instance := @FExtendedEqualityComparer_Int64_VMT ; + FExtendedEqualityComparer_UInt8_Instance := @FExtendedEqualityComparer_UInt8_VMT ; + FExtendedEqualityComparer_UInt16_Instance := @FExtendedEqualityComparer_UInt16_VMT ; + FExtendedEqualityComparer_UInt32_Instance := @FExtendedEqualityComparer_UInt32_VMT ; + FExtendedEqualityComparer_UInt64_Instance := @FExtendedEqualityComparer_UInt64_VMT ; + FExtendedEqualityComparer_Single_Instance := @FExtendedEqualityComparer_Single_VMT ; + FExtendedEqualityComparer_Double_Instance := @FExtendedEqualityComparer_Double_VMT ; + FExtendedEqualityComparer_Extended_Instance := @FExtendedEqualityComparer_Extended_VMT ; + FExtendedEqualityComparer_Currency_Instance := @FExtendedEqualityComparer_Currency_VMT ; + FExtendedEqualityComparer_Comp_Instance := @FExtendedEqualityComparer_Comp_VMT ; + //FExtendedEqualityComparer_Binary_Instance := @FExtendedEqualityComparer_Binary_VMT ; // dynamic instance + //FExtendedEqualityComparer_DynArray_Instance := @FExtendedEqualityComparer_DynArray_VMT ; // dynamic instance + FExtendedEqualityComparer_ShortString1_Instance := @FExtendedEqualityComparer_ShortString1_VMT ; + FExtendedEqualityComparer_ShortString2_Instance := @FExtendedEqualityComparer_ShortString2_VMT ; + FExtendedEqualityComparer_ShortString3_Instance := @FExtendedEqualityComparer_ShortString3_VMT ; + FExtendedEqualityComparer_ShortString_Instance := @FExtendedEqualityComparer_ShortString_VMT ; + FExtendedEqualityComparer_AnsiString_Instance := @FExtendedEqualityComparer_AnsiString_VMT ; + FExtendedEqualityComparer_WideString_Instance := @FExtendedEqualityComparer_WideString_VMT ; + FExtendedEqualityComparer_UnicodeString_Instance := @FExtendedEqualityComparer_UnicodeString_VMT; + FExtendedEqualityComparer_Method_Instance := @FExtendedEqualityComparer_Method_VMT ; + FExtendedEqualityComparer_Variant_Instance := @FExtendedEqualityComparer_Variant_VMT ; + FExtendedEqualityComparer_Pointer_Instance := @FExtendedEqualityComparer_Pointer_VMT ; + + ////// + FExtendedEqualityComparerInstances[tkUnknown] := TInstance.Create(True, @TExtendedHashFactory.SelectBinaryEqualityComparer); + FExtendedEqualityComparerInstances[tkInteger] := TInstance.Create(True, @TExtendedHashFactory.SelectIntegerEqualityComparer); + FExtendedEqualityComparerInstances[tkChar] := TInstance.Create(False, @FExtendedEqualityComparer_UInt8_Instance); + FExtendedEqualityComparerInstances[tkEnumeration] := TInstance.Create(True, @TExtendedHashFactory.SelectIntegerEqualityComparer); + FExtendedEqualityComparerInstances[tkFloat] := TInstance.Create(True, @TExtendedHashFactory.SelectFloatEqualityComparer); + FExtendedEqualityComparerInstances[tkSet] := TInstance.Create(True, @TExtendedHashFactory.SelectBinaryEqualityComparer); + FExtendedEqualityComparerInstances[tkMethod] := TInstance.Create(False, @FExtendedEqualityComparer_Method_Instance); + FExtendedEqualityComparerInstances[tkSString] := TInstance.Create(True, @TExtendedHashFactory.SelectShortStringEqualityComparer); + FExtendedEqualityComparerInstances[tkLString] := TInstance.Create(False, @FExtendedEqualityComparer_AnsiString_Instance); + FExtendedEqualityComparerInstances[tkAString] := TInstance.Create(False, @FExtendedEqualityComparer_AnsiString_Instance); + FExtendedEqualityComparerInstances[tkWString] := TInstance.Create(False, @FExtendedEqualityComparer_WideString_Instance); + FExtendedEqualityComparerInstances[tkVariant] := TInstance.Create(False, @FExtendedEqualityComparer_Variant_Instance); + FExtendedEqualityComparerInstances[tkArray] := TInstance.Create(True, @TExtendedHashFactory.SelectBinaryEqualityComparer); + FExtendedEqualityComparerInstances[tkRecord] := TInstance.Create(True, @TExtendedHashFactory.SelectBinaryEqualityComparer); + FExtendedEqualityComparerInstances[tkInterface] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); + FExtendedEqualityComparerInstances[tkClass] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); + FExtendedEqualityComparerInstances[tkObject] := TInstance.Create(True, @TExtendedHashFactory.SelectBinaryEqualityComparer); + FExtendedEqualityComparerInstances[tkWChar] := TInstance.Create(False, @FExtendedEqualityComparer_UInt16_Instance); + FExtendedEqualityComparerInstances[tkBool] := TInstance.Create(True, @TExtendedHashFactory.SelectIntegerEqualityComparer); + FExtendedEqualityComparerInstances[tkInt64] := TInstance.Create(False, @FExtendedEqualityComparer_Int64_Instance); + FExtendedEqualityComparerInstances[tkQWord] := TInstance.Create(False, @FExtendedEqualityComparer_UInt64_Instance); + FExtendedEqualityComparerInstances[tkDynArray] := TInstance.Create(True, @TExtendedHashFactory.SelectDynArrayEqualityComparer); + FExtendedEqualityComparerInstances[tkInterfaceRaw] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); + FExtendedEqualityComparerInstances[tkProcVar] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); + FExtendedEqualityComparerInstances[tkUString] := TInstance.Create(False, @FExtendedEqualityComparer_UnicodeString_Instance); + FExtendedEqualityComparerInstances[tkUChar] := TInstance.Create(False, @FExtendedEqualityComparer_UInt16_Instance); + FExtendedEqualityComparerInstances[tkHelper] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); + FExtendedEqualityComparerInstances[tkFile] := TInstance.Create(True, @TExtendedHashFactory.SelectBinaryEqualityComparer); + FExtendedEqualityComparerInstances[tkClassRef] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); + FExtendedEqualityComparerInstances[tkPointer] := TInstance.Create(False, @FExtendedEqualityComparer_Pointer_Instance); +end; + +{ TEqualityComparer<T> } + +class function TEqualityComparer<T>.Default: IEqualityComparer<T>; +begin + Result := _LookupVtableInfo(giEqualityComparer, TypeInfo(T), SizeOf(T)); +end; + +class function TEqualityComparer<T>.Default(AHashFactoryClass: TComparerFactoryClass): IEqualityComparer<T>; +begin + if AHashFactoryClass.InheritsFrom(THashFactory) then + Result := _LookupVtableInfoEx(giEqualityComparer, TypeInfo(T), SizeOf(T), AHashFactoryClass) + else if AHashFactoryClass.InheritsFrom(TExtendedHashFactory) then + Result := _LookupVtableInfoEx(giExtendedEqualityComparer, TypeInfo(T), SizeOf(T), AHashFactoryClass) +end; + +class function TEqualityComparer<T>.Construct(const AEqualityComparison: TOnEqualityComparison<T>; + const AHasher: TOnHasher<T>): IEqualityComparer<T>; +begin + Result := TDelegatedEqualityComparerEvents<T>.Create(AEqualityComparison, AHasher); +end; + +class function TEqualityComparer<T>.Construct(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AHasher: THasherFunc<T>): IEqualityComparer<T>; +begin + Result := TDelegatedEqualityComparerFunc<T>.Create(AEqualityComparison, AHasher); +end; + +{ TDelegatedEqualityComparerEvents<T> } + +function TDelegatedEqualityComparerEvents<T>.Equals(constref ALeft, ARight: T): Boolean; +begin + Result := FEqualityComparison(ALeft, ARight); +end; + +function TDelegatedEqualityComparerEvents<T>.GetHashCode(constref AValue: T): UInt32; +begin + Result := FHasher(AValue); +end; + +constructor TDelegatedEqualityComparerEvents<T>.Create(const AEqualityComparison: TOnEqualityComparison<T>; + const AHasher: TOnHasher<T>); +begin + FEqualityComparison := AEqualityComparison; + FHasher := AHasher; +end; + +{ TDelegatedEqualityComparerFunc<T> } + +function TDelegatedEqualityComparerFunc<T>.Equals(constref ALeft, ARight: T): Boolean; +begin + Result := FEqualityComparison(ALeft, ARight); +end; + +function TDelegatedEqualityComparerFunc<T>.GetHashCode(constref AValue: T): UInt32; +begin + Result := FHasher(AValue); +end; + +constructor TDelegatedEqualityComparerFunc<T>.Create(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AHasher: THasherFunc<T>); +begin + FEqualityComparison := AEqualityComparison; + FHasher := AHasher; +end; + +{ TDelegatedExtendedEqualityComparerEvents<T> } + +function TDelegatedExtendedEqualityComparerEvents<T>.GetHashCodeMethod(constref AValue: T): UInt32; +var + LHashList: array[0..1] of Int32; + LHashListParams: array[0..3] of Int16 absolute LHashList; +begin + LHashListParams[0] := -1; + FExtendedHasher(AValue, @LHashList[0]); + Result := LHashList[1]; +end; + +function TDelegatedExtendedEqualityComparerEvents<T>.Equals(constref ALeft, ARight: T): Boolean; +begin + Result := FEqualityComparison(ALeft, ARight); +end; + +function TDelegatedExtendedEqualityComparerEvents<T>.GetHashCode(constref AValue: T): UInt32; +begin + Result := FHasher(AValue); +end; + +procedure TDelegatedExtendedEqualityComparerEvents<T>.GetHashList(constref AValue: T; AHashList: PUInt32); +begin + FExtendedHasher(AValue, AHashList); +end; + +constructor TDelegatedExtendedEqualityComparerEvents<T>.Create(const AEqualityComparison: TOnEqualityComparison<T>; + const AHasher: TOnHasher<T>; const AExtendedHasher: TOnExtendedHasher<T>); +begin + FEqualityComparison := AEqualityComparison; + FHasher := AHasher; + FExtendedHasher := AExtendedHasher; +end; + +constructor TDelegatedExtendedEqualityComparerEvents<T>.Create(const AEqualityComparison: TOnEqualityComparison<T>; + const AExtendedHasher: TOnExtendedHasher<T>); +begin + Create(AEqualityComparison, GetHashCodeMethod, AExtendedHasher); +end; + +{ TDelegatedExtendedEqualityComparerFunc<T> } + +function TDelegatedExtendedEqualityComparerFunc<T>.Equals(constref ALeft, ARight: T): Boolean; +begin + Result := FEqualityComparison(ALeft, ARight); +end; + +function TDelegatedExtendedEqualityComparerFunc<T>.GetHashCode(constref AValue: T): UInt32; +var + LHashList: array[0..1] of Int32; + LHashListParams: array[0..3] of Int16 absolute LHashList; +begin + if not Assigned(FHasher) then + begin + LHashListParams[0] := -1; + FExtendedHasher(AValue, @LHashList[0]); + Result := LHashList[1]; + end + else + Result := FHasher(AValue); +end; + +procedure TDelegatedExtendedEqualityComparerFunc<T>.GetHashList(constref AValue: T; AHashList: PUInt32); +begin + FExtendedHasher(AValue, AHashList); +end; + +constructor TDelegatedExtendedEqualityComparerFunc<T>.Create(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AHasher: THasherFunc<T>; const AExtendedHasher: TExtendedHasherFunc<T>); +begin + FEqualityComparison := AEqualityComparison; + FHasher := AHasher; + FExtendedHasher := AExtendedHasher; +end; + +constructor TDelegatedExtendedEqualityComparerFunc<T>.Create(const AEqualityComparison: TEqualityComparisonFunc<T>; + const AExtendedHasher: TExtendedHasherFunc<T>); +begin + Create(AEqualityComparison, nil, AExtendedHasher); +end; + +{ TExtendedEqualityComparer<T> } + +class function TExtendedEqualityComparer<T>.Default: IExtendedEqualityComparer<T>; +begin + Result := _LookupVtableInfo(giExtendedEqualityComparer, TypeInfo(T), SizeOf(T)); +end; + +class function TExtendedEqualityComparer<T>.Default( + AExtenedHashFactoryClass: TExtendedHashFactoryClass + ): IExtendedEqualityComparer; +begin + Result := _LookupVtableInfoEx(giExtendedEqualityComparer, TypeInfo(T), SizeOf(T), AExtenedHashFactoryClass); +end; + +class function TExtendedEqualityComparer<T>.Construct( + const AEqualityComparison: TOnEqualityComparison<T>; const AHasher: TOnHasher<T>; + const AExtendedHasher: TOnExtendedHasher<T>): IExtendedEqualityComparer<T>; +begin + Result := TDelegatedExtendedEqualityComparerEvents<T>.Create(AEqualityComparison, AHasher, AExtendedHasher); +end; + +class function TExtendedEqualityComparer<T>.Construct( + const AEqualityComparison: TEqualityComparisonFunc<T>; const AHasher: THasherFunc<T>; + const AExtendedHasher: TExtendedHasherFunc<T>): IExtendedEqualityComparer<T>; +begin + Result := TDelegatedExtendedEqualityComparerFunc<T>.Create(AEqualityComparison, AHasher, AExtendedHasher); +end; + +class function TExtendedEqualityComparer<T>.Construct( + const AEqualityComparison: TOnEqualityComparison<T>; + const AExtendedHasher: TOnExtendedHasher<T>): IExtendedEqualityComparer<T>; +begin + Result := TDelegatedExtendedEqualityComparerEvents<T>.Create(AEqualityComparison, AExtendedHasher); +end; + +class function TExtendedEqualityComparer<T>.Construct( + const AEqualityComparison: TEqualityComparisonFunc<T>; + const AExtendedHasher: TExtendedHasherFunc<T>): IExtendedEqualityComparer<T>; +begin + Result := TDelegatedExtendedEqualityComparerFunc<T>.Create(AEqualityComparison, AExtendedHasher); +end; + +{ TDelphiHashFactory } + +class constructor TDelphiHashFactory.Create; +begin + FID := Register(TDelphiHashFactory); +end; + +class function TDelphiHashFactory.GetID: Integer; +begin + Result := FID; +end; + +class function TDelphiHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; +begin + Result := DelphiHashLittle(AKey, ASize, AInitVal); +end; + +{ TAdler32HashFactory } + +class constructor TAdler32HashFactory.Create; +begin + FID := Register(TAdler32HashFactory); +end; + +class function TAdler32HashFactory.GetID: Integer; +begin + Result := FID; +end; + +class function TAdler32HashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; + AInitVal: UInt32): UInt32; +begin + Result := Adler32(AKey, ASize); +end; + +{ TSdbmHashFactory } + +class constructor TSdbmHashFactory.Create; +begin + FID := Register(TSdbmHashFactory); +end; + +class function TSdbmHashFactory.GetID: Integer; +begin + Result := FID; +end; + +class function TSdbmHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; + AInitVal: UInt32): UInt32; +begin + Result := sdbm(AKey, ASize); +end; + +{ TSimpleChecksumFactory } + +class constructor TSimpleChecksumFactory.Create; +begin + FID := Register(TSimpleChecksumFactory); +end; + +class function TSimpleChecksumFactory.GetID: Integer; +begin + Result := FID; +end; + +class function TSimpleChecksumFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; + AInitVal: UInt32): UInt32; +begin + Result := SimpleChecksumHash(AKey, ASize); +end; + +{ TDelphiDoubleHashFactory } + +class constructor TDelphiDoubleHashFactory.Create; +begin + FID := Register(TDelphiDoubleHashFactory); +end; + +class function TDelphiDoubleHashFactory.GetID: Integer; +begin + Result := FID; +end; + +class function TDelphiDoubleHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; +begin + Result := DelphiHashLittle(AKey, ASize, AInitVal); +end; + +class procedure TDelphiDoubleHashFactory.GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; + AOptions: TGetHashListOptions); +var + LHash: UInt32; + AHashListParams: PUInt16 absolute AHashList; +begin +{$WARNINGS OFF} + case AHashListParams[0] of + -2: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); + Exit; + end; + -1: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + 0: Exit; + 1: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + 2: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[1] := 0; + AHashList[2] := 0; + end; + DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); + Exit; + end; + else + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + end; +{$WARNINGS ON} +end; + +{ TDelphiQuadrupleHashFactory } + +class constructor TDelphiQuadrupleHashFactory.Create; +begin + FID := Register(TDelphiQuadrupleHashFactory); +end; + +class function TDelphiQuadrupleHashFactory.GetID: Integer; +begin + Result := FID; +end; + +class function TDelphiQuadrupleHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; +begin + Result := DelphiHashLittle(AKey, ASize, AInitVal); +end; + +class procedure TDelphiQuadrupleHashFactory.GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; + AOptions: TGetHashListOptions); +var + LHash: UInt32; + AHashListParams: PInt16 absolute AHashList; +begin + case AHashListParams[0] of + -4: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 1988; + LHash := 2004; + DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); + Exit; + end; + -3: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 2004; + LHash := 1988; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + -2: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); + Exit; + end; + -1: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + 0: Exit; + 1: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + 2: + begin + case AHashListParams[1] of + 0, 1: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[1] := 0; + AHashList[2] := 0; + end; + DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); + Exit; + end; + 2: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[1] := 2004; + AHashList[2] := 1988; + end; + DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); + Exit; + end; + else + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + end; + end; + 4: + case AHashListParams[1] of + 1: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[1] := 0; + AHashList[2] := 0; + end; + DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); + Exit; + end; + 2: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[3] := 2004; + AHashList[4] := 1988; + end; + DelphiHashLittle2(AKey, ASize, AHashList[3], AHashList[4]); + Exit; + end; + else + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + end; + else + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + end; +end; + +{ TDelphiSixfoldHashFactory } + +class constructor TDelphiSixfoldHashFactory.Create; +begin + FID := Register(TDelphiSixfoldHashFactory); +end; + +class function TDelphiSixfoldHashFactory.GetID: Integer; +begin + Result := FID; +end; + +class function TDelphiSixfoldHashFactory.GetHashCode(AKey: Pointer; ASize: SizeInt; AInitVal: UInt32): UInt32; +begin + Result := DelphiHashLittle(AKey, ASize, AInitVal); +end; + +class procedure TDelphiSixfoldHashFactory.GetHashList(AKey: Pointer; ASize: SizeInt; AHashList: PUInt32; + AOptions: TGetHashListOptions); +var + LHash: UInt32; + AHashListParams: PInt16 absolute AHashList; +begin + case AHashListParams[0] of + -6: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 2; + LHash := 1; + DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); + Exit; + end; + -5: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 1; + LHash := 2; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + -4: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 1988; + LHash := 2004; + DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); + Exit; + end; + -3: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 2004; + LHash := 1988; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + -2: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, LHash, AHashList[1]); + Exit; + end; + -1: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + 0: Exit; + 1: + begin + if not (ghloHashListAsInitData in AOptions) then + AHashList[1] := 0; + LHash := 0; + DelphiHashLittle2(AKey, ASize, AHashList[1], LHash); + Exit; + end; + 2: + begin + case AHashListParams[1] of + 0, 1: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[1] := 0; + AHashList[2] := 0; + end; + DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); + Exit; + end; + 2: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[1] := 2004; + AHashList[2] := 1988; + end; + DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); + Exit; + end; + else + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + end; + end; + 6: + case AHashListParams[1] of + 1: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[1] := 0; + AHashList[2] := 0; + end; + DelphiHashLittle2(AKey, ASize, AHashList[1], AHashList[2]); + Exit; + end; + 2: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[3] := 2004; + AHashList[4] := 1988; + end; + DelphiHashLittle2(AKey, ASize, AHashList[3], AHashList[4]); + Exit; + end; + 3: + begin + if not (ghloHashListAsInitData in AOptions) then + begin + AHashList[5] := 1; + AHashList[6] := 2; + end; + DelphiHashLittle2(AKey, ASize, AHashList[5], AHashList[6]); + Exit; + end; + else + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + end; + else + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + end; +end; + +{ TOrdinalComparer<T, THashFactory> } + +class constructor TOrdinalComparer<T, THashFactory>.Create; +begin + if THashFactory.InheritsFrom(TExtendedHashFactory) then + begin + FExtendedEqualityComparer := TExtendedEqualityComparer<T>.Default(TExtendedHashFactoryClass(THashFactory)); + FEqualityComparer := IEqualityComparer<T>(FExtendedEqualityComparer); + end + else + FEqualityComparer := TEqualityComparer<T>.Default(THashFactory); + FComparer := TComparer<T>.Default; +end; + +{ TGStringComparer<T, THashFactory> } + +class destructor TGStringComparer<T, THashFactory>.Destroy; +begin + if Assigned(FOrdinal) then + FOrdinal.Free; +end; + +class function TGStringComparer<T, THashFactory>.Ordinal: TCustomComparer<T>; +begin + if not Assigned(FOrdinal) then + FOrdinal := TGOrdinalStringComparer<T, THashFactory>.Create; + Result := FOrdinal; +end; + +{ TGOrdinalStringComparer<T, THashFactory> } + +function TGOrdinalStringComparer<T, THashFactory>.Compare(constref ALeft, ARight: T): Integer; +begin + Result := FComparer.Compare(ALeft, ARight); +end; + +function TGOrdinalStringComparer<T, THashFactory>.Equals(constref ALeft, ARight: T): Boolean; +begin + Result := FEqualityComparer.Equals(ALeft, ARight); +end; + +function TGOrdinalStringComparer<T, THashFactory>.GetHashCode(constref AValue: T): UInt32; +begin + Result := FEqualityComparer.GetHashCode(AValue); +end; + +procedure TGOrdinalStringComparer<T, THashFactory>.GetHashList(constref AValue: T; AHashList: PUInt32); +begin + FExtendedEqualityComparer.GetHashList(AValue, AHashList); +end; + +{ TGIStringComparer<T, THashFactory> } + +class destructor TGIStringComparer<T, THashFactory>.Destroy; +begin + if Assigned(FOrdinal) then + FOrdinal.Free; +end; + +class function TGIStringComparer<T, THashFactory>.Ordinal: TCustomComparer<T>; +begin + if not Assigned(FOrdinal) then + FOrdinal := TGOrdinalIStringComparer<T, THashFactory>.Create; + Result := FOrdinal; +end; + +{ TGOrdinalIStringComparer<T, THashFactory> } + +function TGOrdinalIStringComparer<T, THashFactory>.Compare(constref ALeft, ARight: T): Integer; +begin + Result := FComparer.Compare(ALeft.ToLower, ARight.ToLower); +end; + +function TGOrdinalIStringComparer<T, THashFactory>.Equals(constref ALeft, ARight: T): Boolean; +begin + Result := FEqualityComparer.Equals(ALeft.ToLower, ARight.ToLower); +end; + +function TGOrdinalIStringComparer<T, THashFactory>.GetHashCode(constref AValue: T): UInt32; +begin + Result := FEqualityComparer.GetHashCode(AValue.ToLower); +end; + +procedure TGOrdinalIStringComparer<T, THashFactory>.GetHashList(constref AValue: T; AHashList: PUInt32); +begin + FExtendedEqualityComparer.GetHashList(AValue.ToLower, AHashList); +end; + +function BobJenkinsHash(const AData; ALength, AInitData: Integer): Integer; +begin + Result := DelphiHashLittle(@AData, ALength, AInitData); +end; + +function BinaryCompare(const ALeft, ARight: Pointer; ASize: PtrUInt): Integer; +begin + Result := CompareMemRange(ALeft, ARight, ASize); +end; + +function _LookupVtableInfo(AGInterface: TDefaultGenericInterface; ATypeInfo: PTypeInfo; ASize: SizeInt): Pointer; +begin + Result := _LookupVtableInfoEx(AGInterface, ATypeInfo, ASize, nil); +end; + +function _LookupVtableInfoEx(AGInterface: TDefaultGenericInterface; ATypeInfo: PTypeInfo; ASize: SizeInt; + AFactory: TComparerFactoryClass): Pointer; +begin + case AGInterface of + giComparer: + Exit( + THashFactory.LookupComparer(ATypeInfo, ASize)); + giEqualityComparer: + begin + if AFactory = nil then + AFactory := TDelphiHashFactory; + + Exit( + ComparerFactory[AFactory.GetID].LookupEqualityComparer(ATypeInfo, ASize)); + end; + giExtendedEqualityComparer: + begin + if AFactory = nil then + AFactory := TDelphiDoubleHashFactory; + + Exit( + ComparerFactory[AFactory.GetID].LookupExtendedEqualityComparer(ATypeInfo, ASize)); + end; + else + System.Error(reRangeError); + Exit(nil); + end; +end; + +procedure FreeComparerFactory; +var + i: Integer; +begin + for i := 0 to High(ComparerFactory) do + ComparerFactory[i].Free; + + SetLength(ComparerFactory, 0); + ComparerFactory := nil; +end; + +finalization + FreeComparerFactory; +end. + diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.hashes.pas b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.hashes.pas new file mode 100644 index 000000000..73a9b3c91 --- /dev/null +++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.hashes.pas @@ -0,0 +1,913 @@ +{ + 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.Hashes; + +{$MODE DELPHI}{$H+} +{$POINTERMATH ON} +{$MACRO ON} +{$COPERATORS ON} + +interface + +uses + Classes, SysUtils; + +// Original version of Bob Jenkins Hash +// http://burtleburtle.net/bob/c/lookup3.c +function HashWord( + AKey: PLongWord; //* the key, an array of uint32_t values */ + ALength: SizeInt; //* the length of the key, in uint32_ts */ + AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */ +procedure HashWord2 ( + AKey: PLongWord; //* the key, an array of uint32_t values */ + ALength: SizeInt; //* the length of the key, in uint32_ts */ + var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */ + var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */ + +function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32; +procedure HashLittle2( + AKey: Pointer; //* the key to hash */ + ALength: SizeInt; //* length of the key */ + var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */ + var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */ + +function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32; +procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32); + +// hash function from fstl +function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32; + +// some other hashes +// http://stackoverflow.com/questions/14409466/simple-hash-functions +// http://www.partow.net/programming/hashfunctions/ +// http://en.wikipedia.org/wiki/List_of_hash_functions +// http://www.cse.yorku.ca/~oz/hash.html + +// https://code.google.com/p/hedgewars/source/browse/hedgewars/adler32.pas +function Adler32(AKey: Pointer; ALength: SizeInt): UInt32; +function sdbm(AKey: Pointer; ALength: SizeInt): UInt32; + +implementation + +function SimpleChecksumHash(AKey: Pointer; ALength: SizeInt): UInt32; +var + i: Integer; + ABuffer: PUInt8 absolute AKey; +begin + Result := 0; + for i := 0 to ALength - 1 do + Inc(Result,ABuffer[i]); +end; + +function Adler32(AKey: Pointer; ALength: SizeInt): UInt32; +const + MOD_ADLER = 65521; +var + ABuffer: PUInt8 absolute AKey; + a: UInt32 = 1; + b: UInt32 = 0; + n: Integer; +begin + for n := 0 to ALength -1 do + begin + a := (a + ABuffer[n]) mod MOD_ADLER; + b := (b + a) mod MOD_ADLER; + end; + Result := (b shl 16) or a; +end; + +function sdbm(AKey: Pointer; ALength: SizeInt): UInt32; +var + c: PUInt8 absolute AKey; + i: Integer; +begin + Result := 0; + c := AKey; + for i := 0 to ALength - 1 do + begin + Result := c^ + (Result shl 6) + (Result shl 16) {%H-}- Result; + Inc(c); + end; +end; + +{ BobJenkinsHash } + +{$define mix_abc := + a -= c; a := a xor (((c)shl(4)) or ((c)shr(32-(4)))); c += b; + b -= a; b := b xor (((a)shl(6)) or ((a)shr(32-(6)))); a += c; + c -= b; c := c xor (((b)shl(8)) or ((b)shr(32-(8)))); b += a; + a -= c; a := a xor (((c)shl(16)) or ((c)shr(32-(16)))); c += b; + b -= a; b := b xor (((a)shl(19)) or ((a)shr(32-(19)))); a += c; + c -= b; c := c xor (((b)shl(4)) or ((b)shr(32-(4)))); b += a +} + +{$define final_abc := + c := c xor b; c -= (((b)shl(14)) or ((b)shr(32-(14)))); + a := a xor c; a -= (((c)shl(11)) or ((c)shr(32-(11)))); + b := b xor a; b -= (((a)shl(25)) or ((a)shr(32-(25)))); + c := c xor b; c -= (((b)shl(16)) or ((b)shr(32-(16)))); + a := a xor c; a -= (((c)shl(4)) or ((c)shr(32-(4)))); + b := b xor a; b -= (((a)shl(14)) or ((a)shr(32-(14)))); + c := c xor b; c -= (((b)shl(24)) or ((b)shr(32-(24)))) +} + +function HashWord( + AKey: PLongWord; //* the key, an array of uint32_t values */ + ALength: SizeInt; //* the length of the key, in uint32_ts */ + AInitVal: UInt32): UInt32; //* the previous hash, or an arbitrary value */ +var + a,b,c: UInt32; +label + Case0, Case1, Case2, Case3; +begin + //* Set up the internal state */ + a := $DEADBEEF + (UInt32(ALength) shl 2) + AInitVal; + b := a; + c := b; + + //*------------------------------------------------- handle most of the key */ + while ALength > 3 do + begin + a += AKey[0]; + b += AKey[1]; + c += AKey[2]; + mix_abc; + ALength -= 3; + AKey += 3; + end; + + //*------------------------------------------- handle the last 3 uint32_t's */ + case ALength of //* all the case statements fall through */ + 3: goto Case3; + 2: goto Case2; + 1: goto Case1; + 0: goto Case0; + end; + Case3: c+=AKey[2]; + Case2: b+=AKey[1]; + Case1: a+=AKey[0]; + final_abc; + Case0: //* case 0: nothing left to add */ + //*------------------------------------------------------ report the result */ + Result := c; +end; + +procedure HashWord2 ( +AKey: PLongWord; //* the key, an array of uint32_t values */ +ALength: SizeInt; //* the length of the key, in uint32_ts */ +var APrimaryHashAndInitVal: UInt32; //* IN: seed OUT: primary hash value */ +var ASecondaryHashAndInitVal: UInt32); //* IN: more seed OUT: secondary hash value */ +var + a,b,c: UInt32; +label + Case0, Case1, Case2, Case3; +begin + //* Set up the internal state */ + a := $deadbeef + (UInt32(ALength shl 2)) + APrimaryHashAndInitVal; + b := a; + c := b; + c += ASecondaryHashAndInitVal; + + //*------------------------------------------------- handle most of the key */ + while ALength > 3 do + begin + a += AKey[0]; + b += AKey[1]; + c += AKey[2]; + mix_abc; + ALength -= 3; + AKey += 3; + end; + + //*------------------------------------------- handle the last 3 uint32_t's */ + case ALength of //* all the case statements fall through */ + 3: goto Case3; + 2: goto Case2; + 1: goto Case1; + 0: goto Case0; + end; + Case3: c+=AKey[2]; + Case2: b+=AKey[1]; + Case1: a+=AKey[0]; + final_abc; + Case0: //* case 0: nothing left to add */ + //*------------------------------------------------------ report the result */ + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; +end; + +function HashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): UInt32; +var + a, b, c: UInt32; + u: record case byte of + 0: (ptr: Pointer); + 1: (i: PtrUint); + end absolute AKey; + + k32: ^UInt32 absolute AKey; + k16: ^UInt16 absolute AKey; + k8: ^UInt8 absolute AKey; + +label _10, _8, _6, _4, _2; +label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1; + +begin + a := $DEADBEEF + UInt32(ALength) + AInitVal; + b := a; + c := b; + +{$IFDEF ENDIAN_LITTLE} + if (u.i and $3) = 0 then + begin + while (ALength > 12) do + begin + a += k32[0]; + b += k32[1]; + c += k32[2]; + mix_abc; + ALength -= 12; + k32 += 3; + end; + + case ALength of + 12: begin c += k32[2]; b += k32[1]; a += k32[0]; end; + 11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end; + 10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end; + 9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end; + 8 : begin b += k32[1]; a += k32[0]; end; + 7 : begin b += k32[1] and $ffffff; a += k32[0]; end; + 6 : begin b += k32[1] and $ffff; a += k32[0]; end; + 5 : begin b += k32[1] and $ff; a += k32[0]; end; + 4 : begin a += k32[0]; end; + 3 : begin a += k32[0] and $ffffff; end; + 2 : begin a += k32[0] and $ffff; end; + 1 : begin a += k32[0] and $ff; end; + 0 : Exit(c); // zero length strings require no mixing + end + end + else + if (u.i and $1) = 0 then + begin + while (ALength > 12) do + begin + a += k16[0] + (UInt32(k16[1]) shl 16); + b += k16[2] + (UInt32(k16[3]) shl 16); + c += k16[4] + (UInt32(k16[5]) shl 16); + mix_abc; + ALength -= 12; + k16 += 6; + end; + + case ALength of + 12: + begin + c+=k16[4]+((UInt32(k16[5])) shl 16); + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 11: + begin + c+=(UInt32(k8[10])) shl 16; //* fall through */ + goto _10; + end; + 10: + begin _10: + c+=k16[4]; + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 9 : + begin + c+=k8[8]; //* fall through */ + goto _8; + end; + 8 : + begin _8: + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 7 : + begin + b+=(UInt32(k8[6])) shl 16; //* fall through */ + goto _6; + end; + 6 : + begin _6: + b+=k16[2]; + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 5 : + begin + b+=k8[4]; //* fall through */ + goto _4; + end; + 4 : + begin _4: + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 3 : + begin + a+=(UInt32(k8[2])) shl 16; //* fall through */ + goto _2; + end; + 2 : + begin _2: + a+=k16[0]; + end; + 1 : + begin + a+=k8[0]; + end; + 0 : Exit(c); //* zero length requires no mixing */ + end; + end + else +{$ENDIF} + begin + while ALength > 12 do + begin + a += k8[0]; + a += (UInt32(k8[1])) shl 8; + a += (UInt32(k8[2])) shl 16; + a += (UInt32(k8[3])) shl 24; + b += k8[4]; + b += (UInt32(k8[5])) shl 8; + b += (UInt32(k8[6])) shl 16; + b += (UInt32(k8[7])) shl 24; + c += k8[8]; + c += (UInt32(k8[9])) shl 8; + c += (UInt32(k8[10])) shl 16; + c += (UInt32(k8[11])) shl 24; + mix_abc; + ALength -= 12; + k8 += 12; + end; + + case ALength of + 12: goto Case12; + 11: goto Case11; + 10: goto Case10; + 9 : goto Case9; + 8 : goto Case8; + 7 : goto Case7; + 6 : goto Case6; + 5 : goto Case5; + 4 : goto Case4; + 3 : goto Case3; + 2 : goto Case2; + 1 : goto Case1; + 0 : Exit(c); + end; + + Case12: c+=(UInt32(k8[11])) shl 24; + Case11: c+=(UInt32(k8[10])) shl 16; + Case10: c+=(UInt32(k8[9])) shl 8; + Case9: c+=k8[8]; + Case8: b+=(UInt32(k8[7])) shl 24; + Case7: b+=(UInt32(k8[6])) shl 16; + Case6: b+=(UInt32(k8[5])) shl 8; + Case5: b+=k8[4]; + Case4: a+=(UInt32(k8[3])) shl 24; + Case3: a+=(UInt32(k8[2])) shl 16; + Case2: a+=(UInt32(k8[1])) shl 8; + Case1: a+=k8[0]; + end; + + final_abc; + Result := c; +end; + +(* + * hashlittle2: return 2 32-bit hash values + * + * This is identical to hashlittle(), except it returns two 32-bit hash + * values instead of just one. This is good enough for hash table + * lookup with 2^^64 buckets, or if you want a second hash if you're not + * happy with the first, or if you want a probably-unique 64-bit ID for + * the key. *pc is better mixed than *pb, so use *pc first. If you want + * a 64-bit value do something like "*pc + (((uint64_t)*pb)<<32)". + *) +procedure HashLittle2( + AKey: Pointer; //* the key to hash */ + ALength: SizeInt; //* length of the key */ + var APrimaryHashAndInitVal: UInt32; //* IN: primary initval, OUT: primary hash */ + var ASecondaryHashAndInitVal: UInt32); //* IN: secondary initval, OUT: secondary hash */ +var + a,b,c: UInt32; + u: record case byte of + 0: (ptr: Pointer); + 1: (i: PtrUint); + end absolute AKey; + + k32: ^UInt32 absolute AKey; + k16: ^UInt16 absolute AKey; + k8: ^UInt8 absolute AKey; + +label _10, _8, _6, _4, _2; +label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1; + +begin + //* Set up the internal state */ + a := $DEADBEEF + UInt32(ALength) + APrimaryHashAndInitVal; + b := a; + c := b; + c += ASecondaryHashAndInitVal; + +{$IFDEF ENDIAN_LITTLE} + if (u.i and $3) = 0 then + begin + while (ALength > 12) do + begin + a += k32[0]; + b += k32[1]; + c += k32[2]; + mix_abc; + ALength -= 12; + k32 += 3; + end; + + case ALength of + 12: begin c += k32[2]; b += k32[1]; a += k32[0]; end; + 11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end; + 10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end; + 9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end; + 8 : begin b += k32[1]; a += k32[0]; end; + 7 : begin b += k32[1] and $ffffff; a += k32[0]; end; + 6 : begin b += k32[1] and $ffff; a += k32[0]; end; + 5 : begin b += k32[1] and $ff; a += k32[0]; end; + 4 : begin a += k32[0]; end; + 3 : begin a += k32[0] and $ffffff; end; + 2 : begin a += k32[0] and $ffff; end; + 1 : begin a += k32[0] and $ff; end; + 0 : + begin + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; + Exit; // zero length strings require no mixing + end; + end + end + else + if (u.i and $1) = 0 then + begin + while (ALength > 12) do + begin + a += k16[0] + (UInt32(k16[1]) shl 16); + b += k16[2] + (UInt32(k16[3]) shl 16); + c += k16[4] + (UInt32(k16[5]) shl 16); + mix_abc; + ALength -= 12; + k16 += 6; + end; + + case ALength of + 12: + begin + c+=k16[4]+((UInt32(k16[5])) shl 16); + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 11: + begin + c+=(UInt32(k8[10])) shl 16; //* fall through */ + goto _10; + end; + 10: + begin _10: + c+=k16[4]; + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 9 : + begin + c+=k8[8]; //* fall through */ + goto _8; + end; + 8 : + begin _8: + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 7 : + begin + b+=(UInt32(k8[6])) shl 16; //* fall through */ + goto _6; + end; + 6 : + begin _6: + b+=k16[2]; + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 5 : + begin + b+=k8[4]; //* fall through */ + goto _4; + end; + 4 : + begin _4: + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 3 : + begin + a+=(UInt32(k8[2])) shl 16; //* fall through */ + goto _2; + end; + 2 : + begin _2: + a+=k16[0]; + end; + 1 : + begin + a+=k8[0]; + end; + 0 : + begin + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; + Exit; // zero length strings require no mixing + end; + end; + end + else +{$ENDIF} + begin + while ALength > 12 do + begin + a += k8[0]; + a += (UInt32(k8[1])) shl 8; + a += (UInt32(k8[2])) shl 16; + a += (UInt32(k8[3])) shl 24; + b += k8[4]; + b += (UInt32(k8[5])) shl 8; + b += (UInt32(k8[6])) shl 16; + b += (UInt32(k8[7])) shl 24; + c += k8[8]; + c += (UInt32(k8[9])) shl 8; + c += (UInt32(k8[10])) shl 16; + c += (UInt32(k8[11])) shl 24; + mix_abc; + ALength -= 12; + k8 += 12; + end; + + case ALength of + 12: goto Case12; + 11: goto Case11; + 10: goto Case10; + 9 : goto Case9; + 8 : goto Case8; + 7 : goto Case7; + 6 : goto Case6; + 5 : goto Case5; + 4 : goto Case4; + 3 : goto Case3; + 2 : goto Case2; + 1 : goto Case1; + 0 : + begin + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; + Exit; // zero length strings require no mixing + end; + end; + + Case12: c+=(UInt32(k8[11])) shl 24; + Case11: c+=(UInt32(k8[10])) shl 16; + Case10: c+=(UInt32(k8[9])) shl 8; + Case9: c+=k8[8]; + Case8: b+=(UInt32(k8[7])) shl 24; + Case7: b+=(UInt32(k8[6])) shl 16; + Case6: b+=(UInt32(k8[5])) shl 8; + Case5: b+=k8[4]; + Case4: a+=(UInt32(k8[3])) shl 24; + Case3: a+=(UInt32(k8[2])) shl 16; + Case2: a+=(UInt32(k8[1])) shl 8; + Case1: a+=k8[0]; + end; + + final_abc; + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; +end; + +procedure DelphiHashLittle2(AKey: Pointer; ALength: SizeInt; var APrimaryHashAndInitVal, ASecondaryHashAndInitVal: UInt32); +var + a,b,c: UInt32; + u: record case byte of + 0: (ptr: Pointer); + 1: (i: PtrUint); + end absolute AKey; + + k32: ^UInt32 absolute AKey; + k16: ^UInt16 absolute AKey; + k8: ^UInt8 absolute AKey; + +label _10, _8, _6, _4, _2; +label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1; + +begin + //* Set up the internal state */ + a := $DEADBEEF + UInt32(ALength shl 2) + APrimaryHashAndInitVal; // delphi version bug? original version don't have "shl 2" + b := a; + c := b; + c += ASecondaryHashAndInitVal; + +{$IFDEF ENDIAN_LITTLE} + if (u.i and $3) = 0 then + begin + while (ALength > 12) do + begin + a += k32[0]; + b += k32[1]; + c += k32[2]; + mix_abc; + ALength -= 12; + k32 += 3; + end; + + case ALength of + 12: begin c += k32[2]; b += k32[1]; a += k32[0]; end; + 11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end; + 10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end; + 9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end; + 8 : begin b += k32[1]; a += k32[0]; end; + 7 : begin b += k32[1] and $ffffff; a += k32[0]; end; + 6 : begin b += k32[1] and $ffff; a += k32[0]; end; + 5 : begin b += k32[1] and $ff; a += k32[0]; end; + 4 : begin a += k32[0]; end; + 3 : begin a += k32[0] and $ffffff; end; + 2 : begin a += k32[0] and $ffff; end; + 1 : begin a += k32[0] and $ff; end; + 0 : + begin + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; + Exit; // zero length strings require no mixing + end; + end + end + else + if (u.i and $1) = 0 then + begin + while (ALength > 12) do + begin + a += k16[0] + (UInt32(k16[1]) shl 16); + b += k16[2] + (UInt32(k16[3]) shl 16); + c += k16[4] + (UInt32(k16[5]) shl 16); + mix_abc; + ALength -= 12; + k16 += 6; + end; + + case ALength of + 12: + begin + c+=k16[4]+((UInt32(k16[5])) shl 16); + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 11: + begin + c+=(UInt32(k8[10])) shl 16; //* fall through */ + goto _10; + end; + 10: + begin _10: + c+=k16[4]; + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 9 : + begin + c+=k8[8]; //* fall through */ + goto _8; + end; + 8 : + begin _8: + b+=k16[2]+((UInt32(k16[3])) shl 16); + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 7 : + begin + b+=(UInt32(k8[6])) shl 16; //* fall through */ + goto _6; + end; + 6 : + begin _6: + b+=k16[2]; + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 5 : + begin + b+=k8[4]; //* fall through */ + goto _4; + end; + 4 : + begin _4: + a+=k16[0]+((UInt32(k16[1])) shl 16); + end; + 3 : + begin + a+=(UInt32(k8[2])) shl 16; //* fall through */ + goto _2; + end; + 2 : + begin _2: + a+=k16[0]; + end; + 1 : + begin + a+=k8[0]; + end; + 0 : + begin + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; + Exit; // zero length strings require no mixing + end; + end; + end + else +{$ENDIF} + begin + while ALength > 12 do + begin + a += k8[0]; + a += (UInt32(k8[1])) shl 8; + a += (UInt32(k8[2])) shl 16; + a += (UInt32(k8[3])) shl 24; + b += k8[4]; + b += (UInt32(k8[5])) shl 8; + b += (UInt32(k8[6])) shl 16; + b += (UInt32(k8[7])) shl 24; + c += k8[8]; + c += (UInt32(k8[9])) shl 8; + c += (UInt32(k8[10])) shl 16; + c += (UInt32(k8[11])) shl 24; + mix_abc; + ALength -= 12; + k8 += 12; + end; + + case ALength of + 12: goto Case12; + 11: goto Case11; + 10: goto Case10; + 9 : goto Case9; + 8 : goto Case8; + 7 : goto Case7; + 6 : goto Case6; + 5 : goto Case5; + 4 : goto Case4; + 3 : goto Case3; + 2 : goto Case2; + 1 : goto Case1; + 0 : + begin + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; + Exit; // zero length strings require no mixing + end; + end; + + Case12: c+=(UInt32(k8[11])) shl 24; + Case11: c+=(UInt32(k8[10])) shl 16; + Case10: c+=(UInt32(k8[9])) shl 8; + Case9: c+=k8[8]; + Case8: b+=(UInt32(k8[7])) shl 24; + Case7: b+=(UInt32(k8[6])) shl 16; + Case6: b+=(UInt32(k8[5])) shl 8; + Case5: b+=k8[4]; + Case4: a+=(UInt32(k8[3])) shl 24; + Case3: a+=(UInt32(k8[2])) shl 16; + Case2: a+=(UInt32(k8[1])) shl 8; + Case1: a+=k8[0]; + end; + + final_abc; + APrimaryHashAndInitVal := c; + ASecondaryHashAndInitVal := b; +end; + +function DelphiHashLittle(AKey: Pointer; ALength: SizeInt; AInitVal: UInt32): Int32; +var + a, b, c: UInt32; + u: record case byte of + 0: (ptr: Pointer); + 1: (i: PtrUint); + end absolute AKey; + + k32: ^UInt32 absolute AKey; + //k16: ^UInt16 absolute AKey; + k8: ^UInt8 absolute AKey; + +label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1; + +begin + a := $DEADBEEF + UInt32(ALength shl 2) + AInitVal; // delphi version bug? original version don't have "shl 2" + b := a; + c := b; + +{.$IFDEF ENDIAN_LITTLE} // Delphi version don't care + if (u.i and $3) = 0 then + begin + while (ALength > 12) do + begin + a += k32[0]; + b += k32[1]; + c += k32[2]; + mix_abc; + ALength -= 12; + k32 += 3; + end; + + case ALength of + 12: begin c += k32[2]; b += k32[1]; a += k32[0]; end; + 11: begin c += k32[2] and $ffffff; b += k32[1]; a += k32[0]; end; + 10: begin c += k32[2] and $ffff; b += k32[1]; a += k32[0]; end; + 9 : begin c += k32[2] and $ff; b += k32[1]; a += k32[0]; end; + 8 : begin b += k32[1]; a += k32[0]; end; + 7 : begin b += k32[1] and $ffffff; a += k32[0]; end; + 6 : begin b += k32[1] and $ffff; a += k32[0]; end; + 5 : begin b += k32[1] and $ff; a += k32[0]; end; + 4 : begin a += k32[0]; end; + 3 : begin a += k32[0] and $ffffff; end; + 2 : begin a += k32[0] and $ffff; end; + 1 : begin a += k32[0] and $ff; end; + 0 : Exit(c); // zero length strings require no mixing + end + end + else +{.$ENDIF} + begin + while ALength > 12 do + begin + a += k8[0]; + a += (UInt32(k8[1])) shl 8; + a += (UInt32(k8[2])) shl 16; + a += (UInt32(k8[3])) shl 24; + b += k8[4]; + b += (UInt32(k8[5])) shl 8; + b += (UInt32(k8[6])) shl 16; + b += (UInt32(k8[7])) shl 24; + c += k8[8]; + c += (UInt32(k8[9])) shl 8; + c += (UInt32(k8[10])) shl 16; + c += (UInt32(k8[11])) shl 24; + mix_abc; + ALength -= 12; + k8 += 12; + end; + + case ALength of + 12: goto Case12; + 11: goto Case11; + 10: goto Case10; + 9 : goto Case9; + 8 : goto Case8; + 7 : goto Case7; + 6 : goto Case6; + 5 : goto Case5; + 4 : goto Case4; + 3 : goto Case3; + 2 : goto Case2; + 1 : goto Case1; + 0 : Exit(c); + end; + + Case12: c+=(UInt32(k8[11])) shl 24; + Case11: c+=(UInt32(k8[10])) shl 16; + Case10: c+=(UInt32(k8[9])) shl 8; + Case9: c+=k8[8]; + Case8: b+=(UInt32(k8[7])) shl 24; + Case7: b+=(UInt32(k8[6])) shl 16; + Case6: b+=(UInt32(k8[5])) shl 8; + Case5: b+=k8[4]; + Case4: a+=(UInt32(k8[3])) shl 24; + Case3: a+=(UInt32(k8[2])) shl 16; + Case2: a+=(UInt32(k8[1])) shl 8; + Case1: a+=k8[0]; + end; + + final_abc; + Result := Int32(c); +end; + +end. + diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.helpers.pas b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.helpers.pas new file mode 100644 index 000000000..72ddab3f3 --- /dev/null +++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.helpers.pas @@ -0,0 +1,157 @@ +{ + 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.Helpers; + +{$MODE DELPHI}{$H+} +{$MODESWITCH TYPEHELPERS} + +interface + +uses + Classes, SysUtils; + +type + { TValueAnsiStringHelper } + + TValueAnsiStringHelper = record helper for AnsiString + function ToLower: AnsiString; inline; + end; + + { TValuewideStringHelper } + + TValueWideStringHelper = record helper for WideString + function ToLower: WideString; inline; + end; + + { TValueUnicodeStringHelper } + + TValueUnicodeStringHelper = record helper for UnicodeString + function ToLower: UnicodeString; inline; + end; + + { TValueShortStringHelper } + + TValueShortStringHelper = record helper for ShortString + function ToLower: ShortString; inline; + end; + + { TValueUTF8StringHelper } + + TValueUTF8StringHelper = record helper for UTF8String + function ToLower: UTF8String; inline; + end; + + { TValueRawByteStringHelper } + + TValueRawByteStringHelper = record helper for RawByteString + function ToLower: RawByteString; inline; + end; + + { TValueUInt32Helper } + + TValueUInt32Helper = record helper for UInt32 + function High: LongInt; inline; + function Low: LongInt; inline; + + class function GetSignMask: UInt32; static; inline; + class function GetSizedSignMask(ABits: Byte): UInt32; static; inline; + class function GetBitsLength: Byte; static; inline; + + const + SIZED_SIGN_MASK: array[1..32] of UInt32 = ( + $80000000, $C0000000, $E0000000, $F0000000, $F8000000, $FC000000, $FE000000, $FF000000, + $FF800000, $FFC00000, $FFE00000, $FFF00000, $FFF80000, $FFFC0000, $FFFE0000, $FFFF0000, + $FFFF8000, $FFFFC000, $FFFFE000, $FFFFF000, $FFFFF800, $FFFFFC00, $FFFFFE00, $FFFFFF00, + $FFFFFF80, $FFFFFFC0, $FFFFFFE0, $FFFFFFF0, $FFFFFFF8, $FFFFFFFC, $FFFFFFFE, $FFFFFFFF); + BITS_LENGTH = 32; + end; + +implementation + +{ TRawDataStringHelper } + +function TValueAnsiStringHelper.ToLower: AnsiString; +begin + Result := LowerCase(Self); +end; + +{ TValueWideStringHelper } + +function TValueWideStringHelper.ToLower: WideString; +begin + Result := LowerCase(Self); +end; + +{ TValueUnicodeStringHelper } + +function TValueUnicodeStringHelper.ToLower: UnicodeString; +begin + Result := LowerCase(Self); +end; + +{ TValueShortStringHelper } + +function TValueShortStringHelper.ToLower: ShortString; +begin + Result := LowerCase(Self); +end; + +{ TValueUTF8StringHelper } + +function TValueUTF8StringHelper.ToLower: UTF8String; +begin + Result := LowerCase(Self); +end; + +{ TValueRawByteStringHelper } + +function TValueRawByteStringHelper.ToLower: RawByteString; +begin + Result := LowerCase(Self); +end; + +{ TValueUInt32Helper } + +function TValueUInt32Helper.High: LongInt; +begin + Result := System.High(UInt32); +end; + +function TValueUInt32Helper.Low: LongInt; +begin + Result := System.Low(UInt32); +end; + +class function TValueUInt32Helper.GetSignMask: UInt32; +begin + Result := $80000000; +end; + +class function TValueUInt32Helper.GetSizedSignMask(ABits: Byte): UInt32; +begin + Result := SIZED_SIGN_MASK[ABits]; +end; + +class function TValueUInt32Helper.GetBitsLength: Byte; +begin + Result := BITS_LENGTH; +end; + +end. + diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.memoryexpanders.pas b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.memoryexpanders.pas new file mode 100644 index 000000000..11167a998 --- /dev/null +++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.memoryexpanders.pas @@ -0,0 +1,236 @@ +{ + 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.MemoryExpanders; +// Memory expanders + +{$mode delphi} +{$MACRO ON} +{.$WARN 5024 OFF} +{.$WARN 4079 OFF} + +interface + +uses + Classes, SysUtils; + +type + TProbeSequence = class + public + end; + + { TLinearProbing } + + TLinearProbing = class(TProbeSequence) + public + class function Probe(I, {%H-}M, Hash: UInt32): UInt32; static; inline; + + const MAX_LOAD_FACTOR = 1; + const DEFAULT_LOAD_FACTOR = 0.75; + end; + + { TQuadraticProbing } + + TQuadraticProbing = class(TProbeSequence) + private + class constructor Create; + public + class var C1: UInt32; + class var C2: UInt32; + + class function Probe(I, {%H-}M, Hash: UInt32): UInt32; static; inline; + + const MAX_LOAD_FACTOR = 0.5; + const DEFAULT_LOAD_FACTOR = 0.5; + end; + + { TDoubleHashing } + + TDoubleHashing = class(TProbeSequence) + public + class function Probe(I, {%H-}M, Hash1: UInt32; Hash2: UInt32 = 1): UInt32; static; inline; + + const MAX_LOAD_FACTOR = 1; + const DEFAULT_LOAD_FACTOR = 0.85; + end; + +const + // http://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set + // MultiplyDeBruijnBitPosition[uint32(((numberInt32 and -numberInt32) * $077CB531)) shr 27] + MultiplyDeBruijnBitPosition: array[0..31] of Int32 = + ( + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 + ); + + // http://primes.utm.edu/lists/2small/0bit.html + // http://www.math.niu.edu/~rusin/known-math/98/pi_x + // http://oeis.org/A014234/ + PrimaryNumbersJustLessThanPowerOfTwo: array[0..31] of UInt32 = + ( + 0, 1, 3, 7, 13, 31, 61, 127, 251, 509, 1021, 2039, 4093, 8191, 16381, 32749, 65521, 131071, + 262139, 524287, 1048573, 2097143, 4194301, 8388593, 16777213, 33554393, 67108859, + 134217689, 268435399, 536870909, 1073741789, 2147483647 + ); + + // http://oeis.org/A014210 + // http://oeis.org/A203074 + PrimaryNumbersJustBiggerThanPowerOfTwo: array[0..31] of UInt32 = ( + 2,3,5,11,17,37,67,131,257,521,1031,2053,4099, + 8209,16411,32771,65537,131101,262147,524309, + 1048583,2097169,4194319,8388617,16777259,33554467, + 67108879,134217757,268435459,536870923,1073741827, + 2147483659); + + // Fibonacci numbers + FibonacciNumbers: array[0..44] of UInt32 = ( + {0,1,1,2,3,}0,5,8,13,21,34,55,89,144,233,377,610,987, + 1597,2584,4181,6765,10946,17711,28657,46368,75025, + 121393,196418,317811,514229,832040,1346269, + 2178309,3524578,5702887,9227465,14930352,24157817, + 39088169, 63245986, 102334155, 165580141, 267914296, + 433494437, 701408733, 1134903170, 1836311903, 2971215073, + {! not fib number - this is memory limit} 4294967295); + + // Largest prime not exceeding Fibonacci(n) + // http://oeis.org/A138184/list + // http://www.numberempire.com/primenumbers.php + PrimaryNumbersJustLessThanFibonacciNumbers: array[0..44] of UInt32 = ( + {! not correlated to fib number. For empty table} 0, + 5,7,13,19,31,53,89,139,233,373,607,983,1597, + 2579,4177,6763,10939,17707,28657,46351,75017, + 121379,196387,317797,514229,832003,1346249, + 2178283,3524569,5702867,9227443,14930341,24157811, + 39088157,63245971,102334123,165580123,267914279, + 433494437,701408717,1134903127,1836311879,2971215073, + {! not correlated to fib number - this is prime memory limit} 4294967291); + + // Smallest prime >= n-th Fibonacci number. + // http://oeis.org/A138185 + PrimaryNumbersJustBiggerThanFibonacciNumbers: array[0..44] of UInt32 = ( + {! not correlated to fib number. For empty table} 0, + 5,11,13,23,37,59,89,149,233,379,613, + 991,1597,2591,4201,6779,10949,17713,28657,46381, + 75029,121403,196429,317827,514229,832063,1346273, + 2178313,3524603,5702897,9227479,14930387,24157823, + 39088193,63245989,102334157,165580147,267914303, + 433494437,701408753,1134903179,1836311951,2971215073, + {! not correlated to fib number - this is prime memory limit} 4294967291); + +type + + { TCuckooHashingCfg } + + TCuckooHashingCfg = class + public + const D = 2; + const MAX_LOAD_FACTOR = 0.5; + + class function LoadFactor(M: Integer): Integer; virtual; + end; + + TStdCuckooHashingCfg = class(TCuckooHashingCfg) + public + const MAX_LOOP = 1000; + end; + + TDeamortizedCuckooHashingCfg = class(TCuckooHashingCfg) + public + const L = 5; + end; + + TDeamortizedCuckooHashingCfg_D2 = TDeamortizedCuckooHashingCfg; + + { TDeamortizedCuckooHashingCfg_D4 } + + TDeamortizedCuckooHashingCfg_D4 = class(TDeamortizedCuckooHashingCfg) + public + const D = 4; + const L = 20; + const MAX_LOAD_FACTOR = 0.9; + + class function LoadFactor(M: Integer): Integer; override; + end; + + { TDeamortizedCuckooHashingCfg_D6 } + + TDeamortizedCuckooHashingCfg_D6 = class(TDeamortizedCuckooHashingCfg) + public + const D = 6; + const L = 170; + const MAX_LOAD_FACTOR = 0.99; + + class function LoadFactor(M: Integer): Integer; override; + end; + + TL5CuckooHashingCfg = class(TCuckooHashingCfg) + public + end; + +implementation + +{ TDeamortizedCuckooHashingCfg_D6 } + +class function TDeamortizedCuckooHashingCfg_D6.LoadFactor(M: Integer): Integer; +begin + Result:=Pred(Round(MAX_LOAD_FACTOR*M)); +end; + +{ TDeamortizedCuckooHashingCfg_D4 } + +class function TDeamortizedCuckooHashingCfg_D4.LoadFactor(M: Integer): Integer; +begin + Result:=Pred(Round(MAX_LOAD_FACTOR*M)); +end; + +{ TCuckooHashingCfg } + +class function TCuckooHashingCfg.LoadFactor(M: Integer): Integer; +begin + Result := Pred(M shr 1); +end; + +{ TLinearProbing } + +class function TLinearProbing.Probe(I, M, Hash: UInt32): UInt32; +begin + Result := (Hash + I) +end; + +{ TQuadraticProbing } + +class constructor TQuadraticProbing.Create; +begin + C1 := 1; + C2 := 1; +end; + +class function TQuadraticProbing.Probe(I, M, Hash: UInt32): UInt32; +begin + Result := (Hash + C1 * I {%H-}+ C2 * Sqr(I)); +end; + +{ TDoubleHashingNoMod } + +class function TDoubleHashing.Probe(I, M, Hash1: UInt32; Hash2: UInt32): UInt32; +begin + Result := Hash1 + I * Hash2; +end; + +end. + diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.strings.pas b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.strings.pas new file mode 100644 index 000000000..1f9c2690e --- /dev/null +++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/generics.strings.pas @@ -0,0 +1,34 @@ +{ + 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.Strings; + +{$mode objfpc}{$H+} + +interface + +resourcestring + SArgumentOutOfRange = 'Argument out of range'; + SDuplicatesNotAllowed = 'Duplicates not allowed in dictionary'; + SDictionaryKeyDoesNotExist = 'Dictionary key does not exist'; + SItemNotFound = 'Item not found'; + +implementation + +end. + diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/inc/generics.dictionaries.inc b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/inc/generics.dictionaries.inc new file mode 100644 index 000000000..74820d755 --- /dev/null +++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/inc/generics.dictionaries.inc @@ -0,0 +1,1859 @@ +{%MainUnit generics.collections.pas} + +{ + 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. + + **********************************************************************} + +{ TPair<TKey,TValue> } + +class function TPair<TKey, TValue>.Create(AKey: TKey; + AValue: TValue): TPair<TKey, TValue>; +begin + Result.Key := AKey; + Result.Value := AValue; +end; + +{ TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS> } + +procedure TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.PairNotify(constref APair: TPair<TKey, TValue>; + ACollectionNotification: TCollectionNotification); +begin + KeyNotify(APair.Key, ACollectionNotification); + ValueNotify(APair.Value, ACollectionNotification); +end; + +procedure TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.KeyNotify(constref AKey: TKey; + ACollectionNotification: TCollectionNotification); +begin + if Assigned(FOnKeyNotify) then + FOnKeyNotify(Self, AKey, ACollectionNotification); +end; + +procedure TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.SetValue(var AValue: TValue; constref ANewValue: TValue); +var + LOldValue: TValue; +begin + LOldValue := AValue; + AValue := ANewValue; + + ValueNotify(LOldValue, cnRemoved); + ValueNotify(ANewValue, cnAdded); +end; + +procedure TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.ValueNotify(constref AValue: TValue; + ACollectionNotification: TCollectionNotification); +begin + if Assigned(FOnValueNotify) then + FOnValueNotify(Self, AValue, ACollectionNotification); +end; + +constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create; +begin + Create(0); +end; + +constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create(ACapacity: SizeInt); overload; +begin + Create(ACapacity, TEqualityComparer<TKey>.Default(THashFactory)); +end; + +constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create(ACapacity: SizeInt; + const AComparer: IEqualityComparer<TKey>); +begin + FEqualityComparer := AComparer; + SetCapacity(ACapacity); +end; + +constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create(const AComparer: IEqualityComparer<TKey>); +begin + Create(0, AComparer); +end; + +constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>); +begin + Create(ACollection, TEqualityComparer<TKey>.Default(THashFactory)); +end; + +constructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>; + const AComparer: IEqualityComparer<TKey>); overload; +var + LItem: TPair<TKey, TValue>; +begin + Create(AComparer); + for LItem in ACollection do + Add(LItem); +end; + +destructor TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.Destroy; +begin + Clear; + FKeys.Free; + FValues.Free; + inherited; +end; + +function TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.ToArray(ACount: SizeInt): TArray<TDictionaryPair>; +var + i: SizeInt; + LEnumerator: TEnumerator<TDictionaryPair>; +begin + SetLength(Result, ACount); + LEnumerator := DoGetEnumerator; + + i := 0; + while LEnumerator.MoveNext do + begin + Result[i] := LEnumerator.Current; + Inc(i); + end; + LEnumerator.Free; +end; + +function TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>.ToArray: TArray<TDictionaryPair>; +begin + Result := ToArray(Count); +end; + +{ TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS> } + +constructor TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>.Create( + ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>); +begin + inherited Create; + FIndex := -1; + FDictionary := ADictionary; +end; + +function TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>.DoGetCurrent: T; +begin + Result := GetCurrent; +end; + +{ TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS> } + +constructor TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.Create( + ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>); +begin + FDictionary := ADictionary; +end; + +function TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>. + DoGetEnumerator: TDictionaryEnumerator; +begin + Result := TDictionaryEnumerator(TDictionaryEnumerator.NewInstance); + TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>(Result).Create(FDictionary); +end; + +function TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.GetCount: SizeInt; +begin + Result := TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>(FDictionary).Count; +end; + +function TDictionaryEnumerable<TDictionaryEnumerator, T, CUSTOM_DICTIONARY_CONSTRAINTS>.ToArray: TArray; +begin + Result := ToArrayImpl(FDictionary.Count); +end; + +{ TOpenAddressingEnumerator<T, DICTIONARY_CONSTRAINTS> } + +function TOpenAddressingEnumerator<T, OPEN_ADDRESSING_CONSTRAINTS>.DoMoveNext: Boolean; +var + LLength: SizeInt; +begin + Inc(FIndex); + + LLength := Length(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems); + + if FIndex >= LLength then + Exit(False); + + // maybe related to bug #24098 + // compiler error for (TDictionary<DICTIONARY_CONSTRAINTS>(FDictionary).FItems[FIndex].Hash and UInt32.GetSignMask) = 0 + while ((TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems[FIndex].Hash) and UInt32.GetSignMask) = 0 do + begin + Inc(FIndex); + if FIndex = LLength then + Exit(False); + end; + + Result := True; +end; + +{ TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS> } + +constructor TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACapacity: SizeInt; + const AComparer: IEqualityComparer<TKey>); +begin + inherited Create(ACapacity, AComparer); + + FMaxLoadFactor := TProbeSequence.DEFAULT_LOAD_FACTOR; +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.GetKeys: TKeyCollection; +begin + if not Assigned(FKeys) then + FKeys := TKeyCollection.Create(Self); + Result := TKeyCollection(FKeys); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.GetValues: TValueCollection; +begin + if not Assigned(FValues) then + FValues := TValueCollection.Create(Self); + Result := TValueCollection(FValues); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.FindBucketIndex(constref AKey: TKey): SizeInt; +var + LHash: UInt32; +begin + Result := FindBucketIndex(FItems, AKey, LHash); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.PrepareAddingItem: SizeInt; +begin + if RealItemsLength > FItemsThreshold then + Rehash(Length(FItems) shl 1) + else if FItemsThreshold = 0 then + begin + SetLength(FItems, 8); + UpdateItemsThreshold(8); + end + else if FItemsLength = $40000001 then // High(TIndex) ... Error: Type mismatch + OutOfMemoryError; + + Result := FItemsLength; + Inc(FItemsLength); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.UpdateItemsThreshold(ASize: SizeInt); +begin + if ASize = $40000000 then + FItemsThreshold := $40000001 + else + FItemsThreshold := Pred(Round(ASize * FMaxLoadFactor)); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.AddItem(var AItem: TItem; constref AKey: TKey; + constref AValue: TValue; const AHash: UInt32); +begin + AItem.Hash := AHash; + AItem.Pair.Key := AKey; + AItem.Pair.Value := AValue; + + PairNotify(AItem.Pair, cnAdded); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Add(constref AKey: TKey; constref AValue: TValue); +begin + DoAdd(AKey, AValue); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Add(constref APair: TPair<TKey, TValue>); +begin + DoAdd(APair.Key, APair.Value); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; +var + LHash: UInt32; +begin + PrepareAddingItem; + + Result := FindBucketIndex(FItems, AKey, LHash); + if Result >= 0 then + raise EListError.CreateRes(@SDuplicatesNotAllowed); + + Result := not Result; + AddItem(FItems[Result], AKey, AValue, LHash); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.DoRemove(AIndex: SizeInt; + ACollectionNotification: TCollectionNotification): TValue; +var + LItem: PItem; + LPair: TPair<TKey, TValue>; +begin + LItem := @FItems[AIndex]; + LItem.Hash := 0; + Result := LItem.Pair.Value; + LPair := LItem.Pair; + LItem.Pair := Default(TPair<TKey, TValue>); + Dec(FItemsLength); + PairNotify(LPair, ACollectionNotification); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Remove(constref AKey: TKey); +var + LIndex: SizeInt; +begin + LIndex := FindBucketIndex(AKey); + if LIndex < 0 then + Exit; + + DoRemove(LIndex, cnRemoved); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.ExtractPair(constref AKey: TKey): TPair<TKey, TValue>; +var + LIndex: SizeInt; +begin + LIndex := FindBucketIndex(AKey); + if LIndex < 0 then + Exit(Default(TPair<TKey, TValue>)); + + Result.Key := AKey; + Result.Value := DoRemove(LIndex, cnExtracted); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Clear; +var + LItem: PItem; + i: SizeInt; + LOldItems: array of TItem; +begin + FItemsLength := 0; + FItemsThreshold := 0; + // ClearTombstones; + LOldItems := FItems; + FItems := nil; + + for i := 0 to High(LOldItems) do + begin + LItem := @LOldItems[i]; + if (LItem.Hash and UInt32.GetSignMask = 0) then + Continue; + + PairNotify(LItem.Pair, cnRemoved); + end; +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.RealItemsLength: SizeInt; +begin + Result := FItemsLength; +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Rehash(ASizePow2: SizeInt; AForce: Boolean): Boolean; +var + LNewItems: TArray<TItem>; + LHash: UInt32; + LIndex: SizeInt; + i: SizeInt; + LItem, LNewItem: PItem; +begin + if (ASizePow2 = Length(FItems)) and not AForce then + Exit(False); + if ASizePow2 < 0 then + OutOfMemoryError; + + SetLength(LNewItems, ASizePow2); + UpdateItemsThreshold(ASizePow2); + + for i := 0 to High(FItems) do + begin + LItem := @FItems[i]; + + if (LItem.Hash and UInt32.GetSignMask) <> 0 then + begin + LIndex := FindBucketIndex(LNewItems, LItem.Pair.Key, LHash); + LIndex := not LIndex; + + LNewItem := @LNewItems[LIndex]; + LNewItem.Hash := LHash; + LNewItem.Pair := LItem.Pair; + end; + end; + + FItems := LNewItems; + Result := True; +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.DoGetEnumerator: TEnumerator<TDictionaryPair>; +begin + Result := GetEnumerator; +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.SetCapacity(ACapacity: SizeInt); +begin + if ACapacity < FItemsLength then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + Resize(ACapacity); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.SetMaxLoadFactor(AValue: single); +var + LItemsLength: SizeInt; +begin + if (AValue > TProbeSequence.MAX_LOAD_FACTOR) or (AValue <= 0) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + FMaxLoadFactor := AValue; + + repeat + LItemsLength := Length(FItems); + UpdateItemsThreshold(LItemsLength); + if RealItemsLength > FItemsThreshold then + Rehash(LItemsLength shl 1); + until RealItemsLength <= FItemsThreshold; +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.GetLoadFactor: single; +begin + Result := FItemsLength / Length(FItems); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.GetCapacity: SizeInt; +begin + Result := Length(FItems); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.Resize(ANewSize: SizeInt); +var + LNewSize: SizeInt; +begin + if ANewSize < 0 then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + LNewSize := 0; + if ANewSize > 0 then + begin + LNewSize := 8; + while LNewSize < ANewSize do + LNewSize := LNewSize shl 1; + end; + + Rehash(LNewSize); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.GetEnumerator: TPairEnumerator; +begin + Result := TPairEnumerator.Create(Self); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.GetItem(const AKey: TKey): TValue; +var + LIndex: SizeInt; +begin + LIndex := FindBucketIndex(AKey); + if LIndex < 0 then + raise EListError.CreateRes(@SDictionaryKeyDoesNotExist); + Result := FItems[LIndex].Pair.Value; +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TrimExcess; +begin + SetCapacity(Succ(FItemsLength)); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.SetItem(const AKey: TKey; const AValue: TValue); +var + LIndex: SizeInt; +begin + LIndex := FindBucketIndex(AKey); + if LIndex < 0 then + raise EListError.CreateRes(@SItemNotFound); + + SetValue(FItems[LIndex].Pair.Value, AValue); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean; +var + LIndex: SizeInt; +begin + LIndex := FindBucketIndex(AKey); + Result := LIndex >= 0; + + if Result then + AValue := FItems[LIndex].Pair.Value + else + AValue := Default(TValue); +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.AddOrSetValue(constref AKey: TKey; constref AValue: TValue); +var + LIndex: SizeInt; + LHash: UInt32; +begin + LIndex := FindBucketIndex(FItems, AKey, LHash); + + if LIndex < 0 then + DoAdd(AKey, AValue) + else + SetValue(FItems[LIndex].Pair.Value, AValue); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.ContainsKey(constref AKey: TKey): Boolean; +var + LIndex: SizeInt; +begin + LIndex := FindBucketIndex(AKey); + Result := LIndex >= 0; +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.ContainsValue(constref AValue: TValue): Boolean; +begin + Result := ContainsValue(AValue, TEqualityComparer<TValue>.Default(THashFactory)); +end; + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.ContainsValue(constref AValue: TValue; + const AEqualityComparer: IEqualityComparer<TValue>): Boolean; +var + i: SizeInt; + LItem: PItem; +begin + if Length(FItems) = 0 then + Exit(False); + + for i := 0 to High(FItems) do + begin + LItem := @FItems[i]; + if (LItem.Hash and UInt32.GetSignMask) = 0 then + Continue; + + if AEqualityComparer.Equals(AValue, LItem.Pair.Value) then + Exit(True); + end; + Result := False; +end; + +procedure TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.GetMemoryLayout( + const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition); +var + i: SizeInt; +begin + for i := 0 to High(FItems) do + if (FItems[i].Hash and UInt32.GetSignMask) <> 0 then + AOnGetMemoryLayoutKeyPosition(Self, i); +end; + +{ TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TPairEnumerator } + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TPairEnumerator.GetCurrent: TPair<TKey, TValue>; +begin + Result := TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems[FIndex].Pair; +end; + +{ TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TValueEnumerator } + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TValueEnumerator.GetCurrent: TValue; +begin + Result := TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems[FIndex].Pair.Value; +end; + +{ TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TKeyEnumerator } + +function TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.TKeyEnumerator.GetCurrent: TKey; +begin + Result := TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>(FDictionary).FItems[FIndex].Pair.Key; +end; + +{ TOpenAddressingLP<DICTIONARY_CONSTRAINTS> } + +procedure TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.NotifyIndexChange(AFrom, ATo: SizeInt); +begin +end; + +function TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.DoRemove(AIndex: SizeInt; + ACollectionNotification: TCollectionNotification): TValue; +var + LItem: PItem; + LPair: TPair<TKey, TValue>; + LLengthMask: SizeInt; + i, m, LIndex, LGapIndex: SizeInt; + LHash, LBucket: UInt32; +begin + LItem := @FItems[AIndex]; + LPair := LItem.Pair; + + // try fill gap + LHash := LItem.Hash; + LItem.Hash := 0; // prevents an infinite searching loop + m := Length(FItems); + LLengthMask := m - 1; + i := Succ(AIndex - (LHash and LLengthMask)); + LGapIndex := AIndex; + repeat + LIndex := TProbeSequence.Probe(i, m, LHash) and LLengthMask; + LItem := @FItems[LIndex]; + + // Empty position + if (LItem.Hash and UInt32.GetSignMask) = 0 then + Break; // breaking bad! + + LBucket := LItem.Hash and LLengthMask; + if not InCircularRange(LGapIndex, LBucket, LIndex) then + begin + NotifyIndexChange(LIndex, LGapIndex); + FItems[LGapIndex] := LItem^; + LItem.Hash := 0; // new gap + LGapIndex := LIndex; + end; + Inc(i); + until false; + + LItem := @FItems[LGapIndex]; + LItem.Hash := 0; + LItem.Pair := Default(TPair<TKey, TValue>); + Dec(FItemsLength); + + Result := LPair.Value; + PairNotify(LPair, ACollectionNotification); +end; + +function TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.FindBucketIndex(constref AItems: TArray<TItem>; + constref AKey: TKey; out AHash: UInt32): SizeInt; +var + LItem: {TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.}_TItem; // for workaround Lazarus bug #25613 + LLengthMask: SizeInt; + i, m: SizeInt; + LHash: UInt32; +begin + m := Length(AItems); + LLengthMask := m - 1; + + LHash := FEqualityComparer.GetHashCode(AKey); + + i := 0; + AHash := LHash or UInt32.GetSignMask; + + if m = 0 then + Exit(-1); + + Result := AHash and LLengthMask; + + repeat + LItem := _TItem(AItems[Result]); + + // Empty position + if (LItem.Hash and UInt32.GetSignMask) = 0 then + Exit(not Result); // insert! + + // Same position? + if LItem.Hash = AHash then + if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then + Exit; + + Inc(i); + + Result := TProbeSequence.Probe(i, m, AHash) and LLengthMask; + + until false; +end; + +{ TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS> } + +function TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>.Rehash(ASizePow2: SizeInt; AForce: Boolean): Boolean; +begin + if inherited then + FTombstonesCount := 0; +end; + +function TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>.RealItemsLength: SizeInt; +begin + Result := FItemsLength + FTombstonesCount +end; + +procedure TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>.ClearTombstones; +begin + Rehash(Length(FItems), True); +end; + +procedure TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>.Clear; +begin + FTombstonesCount := 0; + inherited; +end; + +function TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>.DoRemove(AIndex: SizeInt; + ACollectionNotification: TCollectionNotification): TValue; +begin + Result := inherited; + + FItems[AIndex].Hash := 1; + Inc(FTombstonesCount); +end; + +function TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>.DoAdd(constref AKey: TKey; + constref AValue: TValue): SizeInt; +var + LHash: UInt32; +begin + PrepareAddingItem; + + Result := FindBucketIndexOrTombstone(FItems, AKey, LHash); + if Result >= 0 then + raise EListError.CreateRes(@SDuplicatesNotAllowed); + + Result := not Result; + // Can't ovverride because we lost info about old hash + if FItems[Result].Hash <> 0 then + Dec(FTombstonesCount); + + AddItem(FItems[Result], AKey, AValue, LHash); +end; + +{ TOpenAddressingSH<OPEN_ADDRESSING_CONSTRAINTS> } + +function TOpenAddressingSH<OPEN_ADDRESSING_CONSTRAINTS>.FindBucketIndex(constref AItems: TArray<TItem>; + constref AKey: TKey; out AHash: UInt32): SizeInt; +var + LItem: {TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.}_TItem; // for workaround Lazarus bug #25613 + LLengthMask: SizeInt; + i, m: SizeInt; + LHash: UInt32; +begin + m := Length(AItems); + LLengthMask := m - 1; + + LHash := FEqualityComparer.GetHashCode(AKey); + + i := 0; + AHash := LHash or UInt32.GetSignMask; + + if m = 0 then + Exit(-1); + + Result := AHash and LLengthMask; + + repeat + LItem := _TItem(AItems[Result]); + // Empty position + if LItem.Hash = 0 then + Exit(not Result); // insert! + + // Same position? + if LItem.Hash = AHash then + if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then + Exit; + + Inc(i); + + Result := TProbeSequence.Probe(i, m, AHash) and LLengthMask; + + until false; +end; + +function TOpenAddressingSH<OPEN_ADDRESSING_CONSTRAINTS>.FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; + constref AKey: TKey; out AHash: UInt32): SizeInt; +var + LItem: {TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.}_TItem; // for workaround Lazarus bug #25613 + LLengthMask: SizeInt; + i, m: SizeInt; + LHash: UInt32; +begin + m := Length(AItems); + LLengthMask := m - 1; + + LHash := FEqualityComparer.GetHashCode(AKey); + + i := 0; + AHash := LHash or UInt32.GetSignMask; + + if m = 0 then + Exit(-1); + + Result := AHash and LLengthMask; + + repeat + LItem := _TItem(AItems[Result]); + + // Empty position or tombstone + if LItem.Hash and UInt32.GetSignMask = 0 then + Exit(not Result); // insert! + + // Same position? + if LItem.Hash = AHash then + if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then + Exit; + + Inc(i); + + Result := TProbeSequence.Probe(i, m, AHash) and LLengthMask; + + until false; +end; + +{ TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS> } + +constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACapacity: SizeInt; + const AComparer: IEqualityComparer<TKey>); +begin +end; + +constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(const AComparer: IEqualityComparer<TKey>); +begin +end; + +constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>; + const AComparer: IEqualityComparer<TKey>); +begin +end; + +constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACapacity: SizeInt); +begin + Create(ACapacity, TExtendedEqualityComparer<TKey>.Default(THashFactory)); +end; + +constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>); +begin + Create(ACollection, TExtendedEqualityComparer<TKey>.Default(THashFactory)); +end; + +constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACapacity: SizeInt; + const AComparer: IExtendedEqualityComparer<TKey>); +begin + FMaxLoadFactor := TProbeSequence.DEFAULT_LOAD_FACTOR; + FEqualityComparer := AComparer; + SetCapacity(ACapacity); +end; + +constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(const AComparer: IExtendedEqualityComparer<TKey>); +begin + Create(0, AComparer); +end; + +constructor TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>; + const AComparer: IExtendedEqualityComparer<TKey>); +var + LItem: TPair<TKey, TValue>; +begin + Create(AComparer); + for LItem in ACollection do + Add(LItem); +end; + +procedure TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.UpdateItemsThreshold(ASize: SizeInt); +begin + inherited; + R := + PrimaryNumbersJustLessThanPowerOfTwo[ + MultiplyDeBruijnBitPosition[UInt32(((ASize and -ASize) * $077CB531)) shr 27]] +end; + +function TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.FindBucketIndex(constref AItems: TArray<TItem>; + constref AKey: TKey; out AHash: UInt32): SizeInt; +var + LItem: {TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.}_TItem; // for workaround Lazarus bug #25613 + LLengthMask: SizeInt; + i, m: SizeInt; + LHash: array[-1..1] of UInt32; + LHash1: UInt32 absolute LHash[0]; + LHash2: UInt32 absolute LHash[1]; +begin + m := Length(AItems); + LLengthMask := m - 1; + LHash[-1] := 2; // number of hashes + + IExtendedEqualityComparer<TKey>(FEqualityComparer).GetHashList(AKey, @LHash[-1]); + + i := 0; + AHash := LHash1 or UInt32.GetSignMask; + + if m = 0 then + Exit(-1); + + Result := LHash1 and LLengthMask; + // second hash function must be special + LHash2 := (R - (LHash2 mod R)) or 1; + + repeat + LItem := _TItem(AItems[Result]); + + // Empty position + if LItem.Hash = 0 then + Exit(not Result); + + // Same position? + if LItem.Hash = AHash then + if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then + Exit; + + Inc(i); + + Result := TProbeSequence.Probe(i, m, AHash, LHash2) and LLengthMask; + until false; +end; + +function TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS>.FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; + constref AKey: TKey; out AHash: UInt32): SizeInt; +var + LItem: {TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>.}_TItem; // for workaround Lazarus bug #25613 + LLengthMask: SizeInt; + i, m: SizeInt; + LHash: array[-1..1] of UInt32; + LHash1: UInt32 absolute LHash[0]; + LHash2: UInt32 absolute LHash[1]; +begin + m := Length(AItems); + LLengthMask := m - 1; + LHash[-1] := 2; // number of hashes + + IExtendedEqualityComparer<TKey>(FEqualityComparer).GetHashList(AKey, @LHash[-1]); + + i := 0; + AHash := LHash1 or UInt32.GetSignMask; + + if m = 0 then + Exit(-1); + + Result := LHash1 and LLengthMask; + // second hash function must be special + LHash2 := (R - (LHash2 mod R)) or 1; + + repeat + LItem := _TItem(AItems[Result]); + + // Empty position or tombstone + if LItem.Hash and UInt32.GetSignMask = 0 then + Exit(not Result); + + // Same position? + if LItem.Hash = AHash then + if FEqualityComparer.Equals(AKey, LItem.Pair.Key) then + Exit; + + Inc(i); + + Result := TProbeSequence.Probe(i, m, AHash, LHash2) and LLengthMask; + until false; +end; + +{ TDeamortizedDArrayCuckooMapEnumerator<T, CUCKOO_CONSTRAINTS> } + +constructor TDeamortizedDArrayCuckooMapEnumerator<T, CUCKOO_CONSTRAINTS>.Create( + ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>); +begin + inherited; + if ADictionary.Count = 0 then + FMainIndex := TCuckooCfg.D + else + FMainIndex := 0; +end; + +function TDeamortizedDArrayCuckooMapEnumerator<T, CUCKOO_CONSTRAINTS>.DoMoveNext: Boolean; +var + LLength: SizeInt; + LArray: TItemsArray; +begin + Inc(FIndex); + + if (FMainIndex = TCuckooCfg.D) then // queue + begin + LLength := Length(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FQueue.FItems); + if FIndex >= LLength then + Exit(False); + + while ((TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FQueue.FItems[FIndex].Hash) + and UInt32.GetSignMask) = 0 do + begin + Inc(FIndex); + if FIndex = LLength then + Exit(False); + end; + end + else // d-array + begin + LArray := TItemsArray(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FItems[FMainIndex]); + LLength := Length(LArray); + if FIndex >= LLength then + begin + Inc(FMainIndex); + FIndex := -1; + Exit(DoMoveNext); + end; + + while ((LArray[FIndex].Hash) and UInt32.GetSignMask) = 0 do + begin + Inc(FIndex); + if FIndex = LLength then + begin + Inc(FMainIndex); + FIndex := -1; + Exit(DoMoveNext); + end; + end; + end; + + Result := True; +end; + +{ TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS> } + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.Rehash(ASizePow2: SizeInt; + AForce: boolean): Boolean; +var + FOldIdx: array of TKey; + i: SizeInt; +begin + SetLength(FOldIdx, FIdx.Count); + for i := 0 to FIdx.Count - 1 do + FOldIdx[i] := FItems[FIdx[i]].Pair.Key; + + Result := inherited Rehash(ASizePow2, AForce); + + for i := 0 to FIdx.Count - 1 do + FIdx[i] := FindBucketIndex(FOldIdx[i]); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.NotifyIndexChange(AFrom, ATo: SizeInt); +var + i: SizeInt; +begin + // notify change position + for i := 0 to FIdx.Count-1 do + if FIdx[i] = AFrom then + begin + FIdx[i] := ATo; + Exit; + end; +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.InsertIntoBack(AItem: Pointer); +//var +// LItem: TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.PItem; absolute AItem; !!! bug #25917 +var + LItem: TQueueDictionary.PValue absolute AItem; + LIndex: SizeInt; +begin + LIndex := DoAdd(LItem.Pair.Key, LItem^); + FIdx.Insert(0, LIndex); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.InsertIntoHead(AItem: Pointer); +//var +// LItem: TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.PItem absolute AItem; !!! bug #25917 +var + LItem: TQueueDictionary.PValue absolute AItem; + LIndex: SizeInt; +begin + LIndex := DoAdd(LItem.Pair.Key, LItem^); + FIdx.Add(LIndex); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.IsEmpty: Boolean; +begin + Result := FIdx.Count = 0; +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.Pop: Pointer; +var + AIndex, LGap: SizeInt; + //LResult: TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TItem; !!!bug #25917 +begin + AIndex := FIdx.DoRemove(FIdx.Count - 1, cnExtracted); + + Result := New(TQueueDictionary.PValue); + TQueueDictionary.PValue(Result)^ := DoRemove(AIndex, cnExtracted); +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.Create(ACapacity: SizeInt; + const AComparer: IEqualityComparer<TKey>); +begin + FIdx := TList<UInt32>.Create; + inherited Create(ACapacity, AComparer); +end; + +destructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TQueueDictionary.Destroy; +begin + FIdx.Free; +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetQueueCount: SizeInt; +begin + Result := FQueue.Count; +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACapacity: SizeInt; + const AComparer: IEqualityComparer<TKey>); +begin +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(const AComparer: IEqualityComparer<TKey>); +begin +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>; + const AComparer: IEqualityComparer<TKey>); +begin +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create; +begin + Create(0); +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACapacity: SizeInt); +begin + Create(ACapacity, TExtendedEqualityComparer<TKey>.Default(THashFactory)); +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>); +begin + Create(ACollection, TExtendedEqualityComparer<TKey>.Default(THashFactory)); +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACapacity: SizeInt; + const AComparer: IExtendedEqualityComparer<TKey>); +begin + FMaxLoadFactor := TCuckooCfg.MAX_LOAD_FACTOR; + FQueue := TQueueDictionary.Create; + FCDM := TCDM.Create; + + // to do - check constraint consts + + if TCuckooCfg.D > THashFactory.MAX_HASHLIST_COUNT then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + // should be moved to class constructor, but bug #24848 + CUCKOO_SIGN := UInt32.GetSizedSignMask(THashFactory.HASH_FUNCTIONS_MASK_SIZE + 1); + CUCKOO_INDEX_SIZE := UInt32.GetBitsLength - (THashFactory.HASH_FUNCTIONS_MASK_SIZE + 1); + CUCKOO_HASH_SIGN := THashFactory.HASH_FUNCTIONS_MASK shl CUCKOO_INDEX_SIZE; + + FEqualityComparer := AComparer; + SetCapacity(ACapacity); +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(const AComparer: IExtendedEqualityComparer<TKey>); +begin + Create(0, AComparer); +end; + +constructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create(ACollection: TEnumerable<TDictionaryPair>; + const AComparer: IExtendedEqualityComparer<TKey>); +var + LItem: TPair<TKey, TValue>; +begin + Create(AComparer); + for LItem in ACollection do + Add(LItem); +end; + +destructor TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Destroy; +begin + inherited; + FQueue.Free; + FCDM.Free; +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetKeys: TKeyCollection; +begin + if not Assigned(FKeys) then + FKeys := TKeyCollection.Create(Self); + Result := TKeyCollection(FKeys); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetValues: TValueCollection; +begin + if not Assigned(FValues) then + FValues := TValueCollection.Create(Self); + Result := TValueCollection(FValues); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Lookup(constref AKey: TKey; + var AHashListOrIndex: PUInt32): SizeInt; +begin + Result := Lookup(FItems, AKey, AHashListOrIndex); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Lookup(constref AItems: TItemsDArray; constref AKey: TKey; + var AHashListOrIndex: PUInt32): SizeInt; +var + LLengthMask: SizeInt; + i, j, k: SizeInt; + AHashList: PUInt32 absolute AHashListOrIndex; + AHashListParams: PUInt16 absolute AHashListOrIndex; + AIndex: PtrInt absolute AHashListOrIndex; + // LBloomFilter: UInt32; // to rethink. now is useless +begin + if Length(AItems[0]) = 0 then + Exit(LR_NIL); + + LLengthMask := Length(AItems[0]) - 1; + AHashListParams[0] := TCuckooCfg.D; // number of hashes + + i := 1; // ineks iteracji iteracji haszy + k := 1; // indeks iteracji haszy + // LBloomFilter := 0; + repeat + AHashListParams[1] := i; // iteration + IExtendedEqualityComparer<TKey>(FEqualityComparer).GetHashList(AKey, AHashList); + for j := 0 to THashFactory.HASHLIST_COUNT_PER_FUNCTION[i] - 1 do + begin + AHashList[k] := AHashList[k] or CUCKOO_SIGN; + // LBloomFilter := LBloomFilter or AHashList[k]; + + with AItems[k-1][AHashList[k] and LLengthMask] do + if (Hash and UInt32.GetSignMask) <> 0 then + if (AHashList[k] = Hash or CUCKOO_SIGN) and FEqualityComparer.Equals(AKey, Pair.Key) then + Exit(k-1); + + Inc(k); + end; + Inc(i); + until k > TCuckooCfg.D; + + i := FQueue.FindBucketIndex(AKey); + if i >= 0 then + begin + AIndex := i; + Exit(LR_QUEUE); + end; + +{ LBloomFilter := not LBloomFilter; + for i := 0 to FDicQueueList.Count - 1 do + // with FQueue[i] do + if LBloomFilter and FQueue[i].Hash = 0 then + for j := 1 to TCuckooCfg.D do + if (FQueue[i].Hash or CUCKOO_SIGN = AHashList[j]) then + if FEqualityComparer.Equals(AKey, FQueue[i].Pair.Key) then + begin + AIndex := i; + Exit(LR_QUEUE); + end; } + + Result := LR_NIL; +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.PrepareAddingItem: SizeInt; +var + i: SizeInt; +begin + if FItemsLength > FItemsThreshold then + Rehash(Length(FItems[0]) shl 1) + else if FItemsThreshold = 0 then + begin + for i := 0 to TCuckooCfg.D - 1 do + SetLength(FItems[i], 4); + UpdateItemsThreshold(4); + end + else if FItemsLength = $40000001 then // High(TIndex) ... Error: Type mismatch + OutOfMemoryError; + + Result := FItemsLength; + Inc(FItemsLength); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.UpdateItemsThreshold(ASize: SizeInt); +var + LLength: SizeInt; +begin + LLength := ASize*TCuckooCfg.D; + if LLength = $40000000 then + FItemsThreshold := $40000001 + else + FItemsThreshold := Pred(Round(LLength * FMaxLoadFactor)); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.AddItem(constref AItems: TItemsDArray; constref AKey: TKey; + constref AValue: TValue; const AHashList: PUInt32); +var + LNewItem: TItem; + LPNewItem: PItem; + y: boolean = false; + b: UInt32; + LIndex: UInt32; + i, j, LLengthMask: SizeInt; + LTempItem: TItem; + LHashList: array[0..1] of UInt32; + LHashListParams: array[0..3] of UInt16 absolute LHashList; +begin + LLengthMask := Length(AItems[0]) - 1; + + LNewItem.Pair.Key := AKey; + LNewItem.Pair.Value := AValue; + // by concept already sign bit is set + LNewItem.Hash := ((not CUCKOO_HASH_SIGN) and AHashList[1]) or UInt32.GetSignMask; // start at array [0] + FQueue.InsertIntoBack(@LNewItem); + + for i := 0 to TCuckooCfg.L - 1 do + begin + if not y then + if FQueue.IsEmpty then + Exit + else + begin + LPNewItem := FQueue.Pop; // bug #25917 workaround + LNewItem := LPNewItem^; + Dispose(LPNewItem); + b := (LNewItem.Hash and CUCKOO_HASH_SIGN) shr CUCKOO_INDEX_SIZE; + y := true; + end; + LIndex := LNewItem.Hash and LLengthMask; + if (AItems[b][LIndex].Hash and UInt32.GetSignMask) = 0 then // insert! + begin + AItems[b][LIndex] := LNewItem; + FCDM.Clear; + y := false; + end + else + begin + if FCDM.ContainsKey(LNewItem.Pair.Key) then // found second cycle + begin + FQueue.InsertIntoBack(@LNewItem); + FCDM.Clear; + y := false; + end + else + begin + LTempItem := AItems[b][LIndex]; + AItems[b][LIndex] := LNewItem; + LNewItem.Hash := LNewItem.Hash or CUCKOO_SIGN; + FCDM.AddOrSetValue(LNewItem.Pair.Key, EmptyRecord); + + LNewItem := LTempItem; + b := b + 1; + if b >= TCuckooCfg.D then + b := 0; + LHashListParams[0] := -Succ(b); + IExtendedEqualityComparer<TKey>(FEqualityComparer).GetHashList(LNewItem.Pair.Key, @LHashList[0]); + LNewItem.Hash := (LHashList[1] and not CUCKOO_SIGN) or (b shl CUCKOO_INDEX_SIZE) or UInt32.GetSignMask; + // y := True; // always true in this place + end; + end; + end; + if y then + FQueue.InsertIntoHead(@LNewItem); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.DoAdd(constref AKey: TKey; constref AValue: TValue; + const AHashList: PUInt32); +begin + AddItem(FItems, AKey, AValue, AHashList); + KeyNotify(AKey, cnAdded); + ValueNotify(AValue, cnAdded); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Add(constref AKey: TKey; constref AValue: TValue); +var + LHashList: array[0..TCuckooCfg.D] of UInt32; + LHashListOrIndex: PUint32; +begin + PrepareAddingItem; + LHashListOrIndex := @LHashList[0]; + if Lookup(AKey, LHashListOrIndex) <> LR_NIL then + raise EListError.CreateRes(@SDuplicatesNotAllowed); + + DoAdd(AKey, AValue, LHashListOrIndex); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Add(constref APair: TPair<TKey, TValue>); +begin + Add(APair.Key, APair.Value); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.DoRemove(const AHashListOrIndex: PUInt32; + ALookupResult: SizeInt; ACollectionNotification: TCollectionNotification): TValue; +var + LItem: PItem; + LIndex: UInt32; + LQueueIndex: SizeInt absolute AHashListOrIndex; + LPair: TPair<TKey, TValue>; +begin + case ALookupResult of + LR_QUEUE: + LPair := FQueue.FItems[LQueueIndex].Pair.Value.Pair; + LR_NIL: + raise ERangeError.Create(SItemNotFound); + else + LIndex := AHashListOrIndex[ALookupResult + 1] and (Length(FItems[0]) - 1); + LItem := @FItems[ALookupResult][LIndex]; + LItem.Hash := 0; + LPair := LItem.Pair; + LItem.Pair := Default(TPair<TKey, TValue>); + end; + + Result := LPair.Value; + Dec(FItemsLength); + if ALookupResult = LR_QUEUE then + begin + FQueue.FIdx.Remove(LQueueIndex); + FQueue.DoRemove(LQueueIndex, cnRemoved); + end; + + FCDM.Remove(LPair.Key); // item can exist in CDM + + PairNotify(LPair, ACollectionNotification); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Remove(constref AKey: TKey); +var + LHashList: array[0..TCuckooCfg.D] of UInt32; + LHashListOrIndex: PUint32; + LLookupResult: SizeInt; +begin + LHashListOrIndex := @LHashList[0]; + LLookupResult := Lookup(AKey, LHashListOrIndex); + if LLookupResult = LR_NIL then + Exit; + + DoRemove(LHashListOrIndex, LLookupResult, cnRemoved); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.ExtractPair(constref AKey: TKey): TPair<TKey, TValue>; +var + LHashList: array[0..TCuckooCfg.D] of UInt32; + LHashListOrIndex: PUint32; + LLookupResult: SizeInt; +begin + LHashListOrIndex := @LHashList[0]; + LLookupResult := Lookup(AKey, LHashListOrIndex); + if LLookupResult = LR_NIL then + Exit(Default(TPair<TKey, TValue>)); + + Result.Key := AKey; + Result.Value := DoRemove(LHashListOrIndex, LLookupResult, cnExtracted); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Clear; +var + LItem: PItem; + i, j: SizeInt; + LOldItems: TItemsDArray; + LOldQueueItems: TQueueDictionary.TItemsArray; + LQueueItem: TQueueDictionary._TItem; +begin + FItemsLength := 0; + FItemsThreshold := 0; + LOldItems := FItems; + for i := 0 to TCuckooCfg.D - 1 do + FItems[i] := nil; + + for i := 0 to TCuckooCfg.D - 1 do + begin + for j := 0 to High(LOldItems[0]) do + begin + LItem := @LOldItems[i][j]; + if (LItem.Hash and UInt32.GetSignMask <> 0) then + PairNotify(LItem.Pair, cnRemoved); + end; + end; + + FCDM.Clear; + + // queue + FQueue.FItemsLength := 0; + FQueue.FItemsThreshold := 0; + LOldQueueItems := FQueue.FItems; + FQueue.FItems := nil; + + for i := 0 to High(LOldQueueItems) do + begin + LQueueItem := TQueueDictionary._TItem(LOldQueueItems[i]); + if (LQueueItem.Hash and UInt32.GetSignMask = 0) then + Continue; + + PairNotify(LQueueItem.Pair.Value.Pair, cnRemoved); + end; +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Rehash(ASizePow2: SizeInt); +var + LNewItems: TItemsDArray; + LHash: UInt32; + LIndex: SizeInt; + i, j: SizeInt; + LItem, LNewItem: PItem; + LOldQueue: TQueueDictionary; +var + LHashList: array[0..1] of UInt32; + LHashListParams: array[0..3] of Int16 absolute LHashList; +begin + if ASizePow2 = Length(FItems[0]) then + Exit; + if ASizePow2 < 0 then + OutOfMemoryError; + + for i := 0 to TCuckooCfg.D - 1 do + SetLength(LNewItems[i], ASizePow2); + + LHashListParams[0] := -1; + + // opportunity to clear the queue + LOldQueue := FQueue; + FCDM.Clear; + FQueue := TQueueDictionary.Create; + for i := 0 to LOldQueue.FIdx.Count - 1 do + begin + LItem := @LOldQueue.FItems[LOldQueue.FIdx[i]].Pair.Value; + LHashList[1] := FEqualityComparer.GetHashCode(LItem.Pair.Key); + AddItem(LNewItems, LItem.Pair.Key, LItem.Pair.Value, @LHashList[0]); + end; + LOldQueue.Free; + + // copy the old elements + for i := 0 to TCuckooCfg.D - 1 do + for j := 0 to High(FItems[0]) do + begin + LItem := @FItems[i][j]; + if (LItem.Hash and UInt32.GetSignMask) = 0 then + Continue; + + // small optimization. most of items exist in table 0 + if LItem.Hash and CUCKOO_HASH_SIGN = 0 then + begin + LHashList[1] := LItem.Hash; + AddItem(LNewItems, LItem.Pair.Key, LItem.Pair.Value, @LHashList[0]); + end + else + begin + LHashList[1] := FEqualityComparer.GetHashCode(LItem.Pair.Key); + AddItem(LNewItems, LItem.Pair.Key, LItem.Pair.Value, @LHashList[0]); + end; + end; + + FItems := LNewItems; + UpdateItemsThreshold(ASizePow2); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.DoGetEnumerator: TEnumerator<TDictionaryPair>; +begin + Result := GetEnumerator; +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.SetCapacity(ACapacity: SizeInt); +begin + if ACapacity < FItemsLength then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + Resize(ACapacity); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.SetMaxLoadFactor(AValue: single); +var + LItemsLength: SizeInt; +begin + if (AValue > TCuckooCfg.MAX_LOAD_FACTOR) or (AValue <= 0) then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + FMaxLoadFactor := AValue; + + repeat + LItemsLength := Length(FItems[0]); + UpdateItemsThreshold(LItemsLength); + if FItemsLength > FItemsThreshold then + Rehash(LItemsLength shl 1); + until FItemsLength <= FItemsThreshold; +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetLoadFactor: single; +begin + Result := FItemsLength / (Length(FItems[0]) * TCuckooCfg.D); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetCapacity: SizeInt; +begin + Result := Length(FItems[0]) * TCuckooCfg.D; +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Resize(ANewSize: SizeInt); +var + LNewSize: SizeInt; +begin + if ANewSize < 0 then + raise EArgumentOutOfRangeException.CreateRes(@SArgumentOutOfRange); + + LNewSize := 0; + if ANewSize > 0 then + begin + LNewSize := 4; + while LNewSize * TCuckooCfg.D < ANewSize do + LNewSize := LNewSize shl 1; + end; + + Rehash(LNewSize); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetEnumerator: TPairEnumerator; +begin + Result := TPairEnumerator.Create(Self); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetItem(const AKey: TKey): TValue; +var + LHashList: array[0..TCuckooCfg.D] of UInt32; + LHashListOrIndex: PUint32; + LLookupResult: SizeInt; + LIndex: UInt32; +begin + LHashListOrIndex := @LHashList[0]; + LLookupResult := Lookup(AKey, LHashListOrIndex); + + case LLookupResult of + LR_QUEUE: + Result := FQueue.FItems[PtrInt(LHashListOrIndex)].Pair.Value.Pair.Value; + LR_NIL: + raise EListError.CreateRes(@SDictionaryKeyDoesNotExist); + else + LIndex := LHashListOrIndex[LLookupResult + 1] and (Length(FItems[0]) - 1); + Result := FItems[LLookupResult][LIndex].Pair.Value; + end; +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TrimExcess; +begin + SetCapacity(Succ(FItemsLength)); +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.SetItem(constref AValue: TValue; + const AHashListOrIndex: PUInt32; ALookupResult: SizeInt); +var + LIndex: UInt32; +begin + case ALookupResult of + LR_QUEUE: + SetValue(FQueue.FItems[PtrInt(AHashListOrIndex)].Pair.Value.Pair.Value, AValue); + LR_NIL: + raise EListError.CreateRes(@SItemNotFound); + else + LIndex := AHashListOrIndex[ALookupResult + 1] and (Length(FItems[0]) - 1); + SetValue(FItems[ALookupResult][LIndex].Pair.Value, AValue); + end; +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.SetItem(const AKey: TKey; const AValue: TValue); +var + LHashList: array[0..TCuckooCfg.D] of UInt32; + LHashListOrIndex: PUint32; + LLookupResult: SizeInt; + LIndex: UInt32; +begin + LHashListOrIndex := @LHashList[0]; + LLookupResult := Lookup(AKey, LHashListOrIndex); + + SetItem(AValue, LHashListOrIndex, LLookupResult); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean; +var + LHashList: array[0..TCuckooCfg.D] of UInt32; + LHashListOrIndex: PUint32; + LLookupResult: SizeInt; + LIndex: UInt32; +begin + LHashListOrIndex := @LHashList[0]; + LLookupResult := Lookup(AKey, LHashListOrIndex); + + Result := LLookupResult <> LR_NIL; + + case LLookupResult of + LR_QUEUE: + AValue := FQueue.FItems[PtrInt(LHashListOrIndex)].Pair.Value.Pair.Value; + LR_NIL: + AValue := Default(TValue); + else + LIndex := LHashListOrIndex[LLookupResult + 1] and (Length(FItems[0]) - 1); + AValue := FItems[LLookupResult][LIndex].Pair.Value; + end; +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.AddOrSetValue(constref AKey: TKey; constref AValue: TValue); +var + LHashList: array[0..TCuckooCfg.D] of UInt32; + LHashListOrIndex: PUint32; + LLookupResult: SizeInt; + LIndex: UInt32; +begin + LHashListOrIndex := @LHashList[0]; + LLookupResult := Lookup(AKey, LHashListOrIndex); + + if LLookupResult = LR_NIL then + begin + PrepareAddingItem; + DoAdd(AKey, AValue, LHashListOrIndex); + end + else + SetItem(AValue, LHashListOrIndex, LLookupResult); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.ContainsKey(constref AKey: TKey): Boolean; +var + LHashList: array[0..TCuckooCfg.D] of UInt32; + LHashListOrIndex: PUint32; +begin + LHashListOrIndex := @LHashList[0]; + Result := Lookup(AKey, LHashListOrIndex) <> LR_NIL; +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.ContainsValue(constref AValue: TValue): Boolean; +begin + Result := ContainsValue(AValue, TEqualityComparer<TValue>.Default(THashFactory)); +end; + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.ContainsValue(constref AValue: TValue; + const AEqualityComparer: IEqualityComparer<TValue>): Boolean; +var + i, j: SizeInt; + LItem: PItem; +begin + if Length(FItems[0]) = 0 then + Exit(False); + + for i := 0 to TCuckooCfg.D - 1 do + for j := 0 to High(FItems[0]) do + begin + LItem := @FItems[i][j]; + if (LItem.Hash and UInt32.GetSignMask) = 0 then + Continue; + + if AEqualityComparer.Equals(AValue, LItem.Pair.Value) then + Exit(True); + end; + Result := False; +end; + +procedure TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.GetMemoryLayout( + const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition); +var + i, j, k: SizeInt; +begin + k := 0; + for i := 0 to TCuckooCfg.D - 1 do + for j := 0 to High(FItems[0]) do + begin + if FItems[i][j].Hash and UInt32.GetSignMask <> 0 then + AOnGetMemoryLayoutKeyPosition(Self, k); + inc(k); + end; +end; + +{ TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TPairEnumerator } + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TPairEnumerator.GetCurrent: TPair<TKey, TValue>; +begin + if FMainIndex = TCuckooCfg.D then + Result := TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair + else + Result := TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FItems[FMainIndex][FIndex].Pair; +end; + +{ TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TValueEnumerator } + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TValueEnumerator.GetCurrent: TValue; +begin + if FMainIndex = TCuckooCfg.D then + Result := TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair.Value + else + Result := TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FItems[FMainIndex][FIndex].Pair.Value; +end; + +{ TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TKeyEnumerator } + +function TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.TKeyEnumerator.GetCurrent: TKey; +begin + if FMainIndex = TCuckooCfg.D then + Result := TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FQueue.FItems[FIndex].Pair.Value.Pair.Key + else + Result := TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>(FDictionary).FItems[FMainIndex][FIndex].Pair.Key; +end; + +{ TObjectDictionary<DICTIONARY_CONSTRAINTS> } + +procedure TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.KeyNotify( + constref AKey: TKey; ACollectionNotification: TCollectionNotification); +begin + inherited; + + if (doOwnsKeys in FOwnerships) and (ACollectionNotification = cnRemoved) then + TObject(AKey).Free; +end; + +procedure TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.ValueNotify(constref AValue: TValue; + ACollectionNotification: TCollectionNotification); +begin + inherited; + + if (doOwnsValues in FOwnerships) and (ACollectionNotification = cnRemoved) then + TObject(AValue).Free; +end; + +constructor TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create( + AOwnerships: TDictionaryOwnerships); +begin + Create(AOwnerships, 0); +end; + +constructor TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create( + AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); +begin + inherited Create(ACapacity); + + FOwnerships := AOwnerships; +end; + +constructor TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create( + AOwnerships: TDictionaryOwnerships; const AComparer: IExtendedEqualityComparer<TKey>); +begin + inherited Create(AComparer); + + FOwnerships := AOwnerships; +end; + +constructor TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>.Create( + AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); +begin + inherited Create(ACapacity, AComparer); + + FOwnerships := AOwnerships; +end; + +procedure TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.KeyNotify( + constref AKey: TKey; ACollectionNotification: TCollectionNotification); +begin + inherited; + + if (doOwnsKeys in FOwnerships) and (ACollectionNotification = cnRemoved) then + TObject(AKey).Free; +end; + +procedure TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.ValueNotify( + constref AValue: TValue; ACollectionNotification: TCollectionNotification); +begin + inherited; + + if (doOwnsValues in FOwnerships) and (ACollectionNotification = cnRemoved) then + TObject(AValue).Free; +end; + +constructor TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.Create(AOwnerships: TDictionaryOwnerships); +begin + Create(AOwnerships, 0); +end; + +constructor TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.Create(AOwnerships: TDictionaryOwnerships; + ACapacity: SizeInt); +begin + inherited Create(ACapacity); + + FOwnerships := AOwnerships; +end; + +constructor TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.Create(AOwnerships: TDictionaryOwnerships; + const AComparer: IEqualityComparer<TKey>); +begin + inherited Create(AComparer); + + FOwnerships := AOwnerships; +end; + +constructor TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>.Create(AOwnerships: TDictionaryOwnerships; + ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); +begin + inherited Create(ACapacity, AComparer); + + FOwnerships := AOwnerships; +end; diff --git a/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/inc/generics.dictionariesh.inc b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/inc/generics.dictionariesh.inc new file mode 100644 index 000000000..adfc91415 --- /dev/null +++ b/References/DelphiAST/Source/FreePascalSupport/Generics.Collection/src/inc/generics.dictionariesh.inc @@ -0,0 +1,533 @@ +{%MainUnit generics.collections.pas} + +{ + 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. + + **********************************************************************} + +{$WARNINGS OFF} +type + TEmptyRecord = record // special record for Dictionary TValue (Dictionary as Set) + end; + + { TPair } + + TPair<TKey, TValue> = record + public + Key: TKey; + Value: TValue; + class function Create(AKey: TKey; AValue: TValue): TPair<TKey, TValue>; static; + end; + + { TCustomDictionary } + + // bug #24283 and #24097 (forward declaration) - should be: + // TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS> = class(TEnumerable<TPair<TKey, TValue> >); + TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract + public type + // workaround... no generics types in generics types + TDictionaryPair = TPair<TKey, TValue>; + PDictionaryPair = ^TDictionaryPair; + PKey = ^TKey; + PValue = ^TValue; + THashFactoryClass = THashFactory; + public + FItemsLength: SizeInt; + FEqualityComparer: IEqualityComparer<TKey>; + FKeys: TEnumerable<TKey>; + FValues: TEnumerable<TValue>; + FMaxLoadFactor: single; + protected + procedure SetCapacity(ACapacity: SizeInt); virtual; abstract; + // bug #24283. workaround for this class because can't inherit from TEnumerable + function DoGetEnumerator: TEnumerator<TDictionaryPair>; virtual; abstract; {override;} + + procedure SetMaxLoadFactor(AValue: single); virtual; abstract; + function GetLoadFactor: single; virtual; abstract; + function GetCapacity: SizeInt; virtual; abstract; + public + property MaxLoadFactor: single read FMaxLoadFactor write SetMaxLoadFactor; + property LoadFactor: single read GetLoadFactor; + property Capacity: SizeInt read GetCapacity write SetCapacity; + + property Count: SizeInt read FItemsLength; + + procedure Clear; virtual; abstract; + procedure Add(constref APair: TPair<TKey, TValue>); virtual; abstract; + strict private // bug #24283. workaround for this class because can't inherit from TEnumerable + function ToArray(ACount: SizeInt): TArray<TDictionaryPair>; overload; + public + function ToArray: TArray<TDictionaryPair>; virtual; final; {override; final; // bug #24283} overload; + + constructor Create; virtual; overload; + constructor Create(ACapacity: SizeInt); virtual; overload; + constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); virtual; overload; + constructor Create(const AComparer: IEqualityComparer<TKey>); overload; + constructor Create(ACollection: TEnumerable<TDictionaryPair>); virtual; overload; + constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); virtual; overload; + + destructor Destroy; override; + private + FOnKeyNotify: TCollectionNotifyEvent<TKey>; + FOnValueNotify: TCollectionNotifyEvent<TValue>; + protected + procedure UpdateItemsThreshold(ASize: SizeInt); virtual; abstract; + + procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); virtual; + procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); virtual; + procedure PairNotify(constref APair: TPair<TKey, TValue>; ACollectionNotification: TCollectionNotification); inline; + procedure SetValue(var AValue: TValue; constref ANewValue: TValue); + public + property OnKeyNotify: TCollectionNotifyEvent<TKey> read FOnKeyNotify write FOnKeyNotify; + property OnValueNotify: TCollectionNotifyEvent<TValue> read FOnValueNotify write FOnValueNotify; + end; + + { TCustomDictionaryEnumerator } + + TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract(TEnumerator< T >) + private + FDictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>; + FIndex: SizeInt; + protected + function DoGetCurrent: T; override; + function GetCurrent: T; virtual; abstract; + public + constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>); + end; + + { TDictionaryEnumerable } + + TDictionaryEnumerable<TDictionaryEnumerator: TObject; // ... inherits from TCustomDictionaryEnumerator. workaround... + T, CUSTOM_DICTIONARY_CONSTRAINTS> = class abstract(TEnumerable<T>) + private + FDictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>; + function GetCount: SizeInt; + public + constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>); + function DoGetEnumerator: TDictionaryEnumerator; override; + function ToArray: TArray<T>; override; final; + property Count: SizeInt read GetCount; + end; + + // more info : http://en.wikipedia.org/wiki/Open_addressing + + { TDictionaryEnumerable } + + TOpenAddressingEnumerator<T, OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>) + protected + function DoMoveNext: Boolean; override; + end; + + TOnGetMemoryLayoutKeyPosition = procedure(Sender: TObject; AKeyPos: UInt32) of object; + + TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>) + private type + PItem = ^TItem; + TItem = record + Hash: UInt32; + Pair: TPair<TKey, TValue>; + end; + + TItemsArray = array of TItem; + private var + FItemsThreshold: SizeInt; + FItems: TItemsArray; + + procedure Resize(ANewSize: SizeInt); + function PrepareAddingItem: SizeInt; + protected + function RealItemsLength: SizeInt; virtual; + function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; virtual; + function FindBucketIndex(constref AKey: TKey): SizeInt; overload; inline; + function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey; out AHash: UInt32): SizeInt; virtual; abstract; overload; + public + type + // Enumerators + TPairEnumerator = class(TOpenAddressingEnumerator<TDictionaryPair, OPEN_ADDRESSING_CONSTRAINTS>) + protected + function GetCurrent: TPair<TKey,TValue>; override; + end; + + TValueEnumerator = class(TOpenAddressingEnumerator<TValue, OPEN_ADDRESSING_CONSTRAINTS>) + protected + function GetCurrent: TValue; override; + end; + + TKeyEnumerator = class(TOpenAddressingEnumerator<TKey, OPEN_ADDRESSING_CONSTRAINTS>) + protected + function GetCurrent: TKey; override; + end; + + // Collections + TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>); + + TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>); + + // bug #24283 - workaround related to lack of DoGetEnumerator + function GetEnumerator: TPairEnumerator; reintroduce; + private + function GetKeys: TKeyCollection; + function GetValues: TValueCollection; + private + function GetItem(const AKey: TKey): TValue; inline; + procedure SetItem(const AKey: TKey; const AValue: TValue); inline; + procedure AddItem(var AItem: TItem; constref AKey: TKey; constref AValue: TValue; const AHash: UInt32); inline; + protected + // useful for using dictionary as array + function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; virtual; + function DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; virtual; + + procedure UpdateItemsThreshold(ASize: SizeInt); override; + + procedure SetCapacity(ACapacity: SizeInt); override; + // bug #24283 - can't descadent from TEnumerable + function DoGetEnumerator: TEnumerator<TDictionaryPair>; override; + procedure SetMaxLoadFactor(AValue: single); override; + function GetLoadFactor: single; override; + function GetCapacity: SizeInt; override; + public + // many constructors because bug #25607 + constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload; + + procedure Add(constref APair: TPair<TKey, TValue>); override; overload; + procedure Add(constref AKey: TKey; constref AValue: TValue); overload; inline; + procedure Remove(constref AKey: TKey); + function ExtractPair(constref AKey: TKey): TPair<TKey, TValue>; + procedure Clear; override; + procedure TrimExcess; + function TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean; + procedure AddOrSetValue(constref AKey: TKey; constref AValue: TValue); + function ContainsKey(constref AKey: TKey): Boolean; inline; + function ContainsValue(constref AValue: TValue): Boolean; overload; + function ContainsValue(constref AValue: TValue; const AEqualityComparer: IEqualityComparer<TValue>): Boolean; virtual; overload; + + property Items[Index: TKey]: TValue read GetItem write SetItem; default; + property Keys: TKeyCollection read GetKeys; + property Values: TValueCollection read GetValues; + + procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition); + end; + + TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>) + private type // for workaround Lazarus bug #25613 + _TItem = record + Hash: UInt32; + Pair: TPair<TKey, TValue>; + end; + protected + procedure NotifyIndexChange(AFrom, ATo: SizeInt); virtual; + function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; override; + function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey; out AHash: UInt32): SizeInt; override; overload; + end; + + // More info and TODO + // https://github.com/OpenHFT/UntitledCollectionsProject/wiki/Tombstones-purge-from-hashtable:-theory-and-practice + + TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS> = class abstract(TOpenAddressing<OPEN_ADDRESSING_CONSTRAINTS>) + private + FTombstonesCount: SizeInt; + protected + function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): boolean; override; + function RealItemsLength: SizeInt; override; + + function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey; + out AHash: UInt32): SizeInt; virtual; abstract; + + function DoRemove(AIndex: SizeInt; ACollectionNotification: TCollectionNotification): TValue; override; + function DoAdd(constref AKey: TKey; constref AValue: TValue): SizeInt; override; + public + property TombstonesCount: SizeInt read FTombstonesCount; + procedure ClearTombstones; virtual; + procedure Clear; override; + end; + + TOpenAddressingSH<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>) + private type // for workaround Lazarus bug #25613 + _TItem = record + Hash: UInt32; + Pair: TPair<TKey, TValue>; + end; + protected + function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey; + out AHash: UInt32): SizeInt; override; overload; + function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey; + out AHash: UInt32): SizeInt; override; + end; + + TOpenAddressingDH<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingTombstones<OPEN_ADDRESSING_CONSTRAINTS>) + private type // for workaround Lazarus bug #25613 + _TItem = record + Hash: UInt32; + Pair: TPair<TKey, TValue>; + end; + private + R: UInt32; + protected + procedure UpdateItemsThreshold(ASize: SizeInt); override; + function FindBucketIndex(constref AItems: TArray<TItem>; constref AKey: TKey; + out AHash: UInt32): SizeInt; override; overload; + function FindBucketIndexOrTombstone(constref AItems: TArray<TItem>; constref AKey: TKey; + out AHash: UInt32): SizeInt; override; + strict protected + constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload; + constructor Create(const AComparer: IEqualityComparer<TKey>); reintroduce; overload; + constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload; + public // bug #26181 (redundancy of constructors) + constructor Create(ACapacity: SizeInt); override; overload; + constructor Create(ACollection: TEnumerable<TDictionaryPair>); override; overload; + constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload; + constructor Create(const AComparer: IExtendedEqualityComparer<TKey>); overload; + constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload; + end; + + TDeamortizedDArrayCuckooMapEnumerator<T, CUCKOO_CONSTRAINTS> = class abstract(TCustomDictionaryEnumerator<T, CUSTOM_DICTIONARY_CONSTRAINTS>) + private type // for workaround Lazarus bug #25613 + TItem = record + Hash: UInt32; + Pair: TPair<TKey, TValue>; + end; + TItemsArray = array of TItem; + private + FMainIndex: SizeInt; + protected + function DoMoveNext: Boolean; override; + public + constructor Create(ADictionary: TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>); + end; + + // more info : + // http://arxiv.org/abs/0903.0391 + + TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS> = class(TCustomDictionary<CUSTOM_DICTIONARY_CONSTRAINTS>) + private const // Lookup Result + LR_NIL = -1; + LR_QUEUE = -2; + private type + PItem = ^TItem; + TItem = record + Hash: UInt32; + Pair: TPair<TKey, TValue>; + end; + TValueForQueue = TItem; + + TQueueDictionary = class(TOpenAddressingLP<TKey, TValueForQueue, TDelphiHashFactory, TLinearProbing>) + private type // for workaround Lazarus bug #25613 + _TItem = record + Hash: UInt32; + Pair: TPair<TKey, TValueForQueue>; + end; + private + FIdx: TList<UInt32>; // list to keep order + protected + procedure NotifyIndexChange(AFrom, ATo: SizeInt); override; + function Rehash(ASizePow2: SizeInt; AForce: Boolean = False): Boolean; override; + public + procedure InsertIntoBack(AItem: Pointer); + procedure InsertIntoHead(AItem: Pointer); + function IsEmpty: Boolean; + function Pop: Pointer; + constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload; + destructor Destroy; override; + end; + + // cycle-detection mechanism class + TCDM = class(TOpenAddressingSH<TKey, TEmptyRecord, TDelphiHashFactory, TLinearProbing>); + TItemsArray = array of TItem; + TItemsDArray = array[0..Pred(TCuckooCfg.D)] of TItemsArray; + private var + FQueue: TQueueDictionary; // probably can be optimized - hash TItem give information from TItem.Hash for cuckoo ... + // currently is kept in "TQueueDictionary = class(TOpenAddressingSH<TKey, TItem, ...>" + + FCDM: TCDM; // cycle-detection mechanism + FItemsThreshold: SizeInt; + FItems: TItemsDArray; + // sadly there is bug #24848 for class var ... + {class} var + CUCKOO_SIGN, CUCKOO_INDEX_SIZE, CUCKOO_HASH_SIGN: UInt32; + // CUCKOO_MAX_ITEMS_LENGTH: <- to do : calc max length for items based on CUCKOO sign + // maybe some CDM bloom filter? + + procedure UpdateItemsThreshold(ASize: SizeInt); override; + procedure Resize(ANewSize: SizeInt); + procedure Rehash(ASizePow2: SizeInt); + function PrepareAddingItem: SizeInt; + protected + function Lookup(constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; inline; overload; + function Lookup(constref AItems: TItemsDArray; constref AKey: TKey; var AHashListOrIndex: PUInt32): SizeInt; virtual; overload; + public + type + // Enumerators + TPairEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TDictionaryPair, CUCKOO_CONSTRAINTS>) + protected + function GetCurrent: TPair<TKey,TValue>; override; + end; + + TValueEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TValue, CUCKOO_CONSTRAINTS>) + protected + function GetCurrent: TValue; override; + end; + + TKeyEnumerator = class(TDeamortizedDArrayCuckooMapEnumerator<TKey, CUCKOO_CONSTRAINTS>) + protected + function GetCurrent: TKey; override; + end; + + // Collections + TValueCollection = class(TDictionaryEnumerable<TValueEnumerator, TValue, CUSTOM_DICTIONARY_CONSTRAINTS>); + + TKeyCollection = class(TDictionaryEnumerable<TKeyEnumerator, TKey, CUSTOM_DICTIONARY_CONSTRAINTS>); + + // bug #24283 - workaround related to lack of DoGetEnumerator + function GetEnumerator: TPairEnumerator; reintroduce; + private + function GetKeys: TKeyCollection; + function GetValues: TValueCollection; + private + function GetItem(const AKey: TKey): TValue; inline; + procedure SetItem(const AKey: TKey; const AValue: TValue); overload; inline; + procedure SetItem(constref AValue: TValue; const AHashListOrIndex: PUInt32; ALookupResult: SizeInt); overload; + + procedure AddItem(constref AItems: TItemsDArray; constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload; + procedure DoAdd(constref AKey: TKey; constref AValue: TValue; const AHashList: PUInt32); overload; inline; + function DoRemove(const AHashListOrIndex: PUInt32; ALookupResult: SizeInt; + ACollectionNotification: TCollectionNotification): TValue; + + function GetQueueCount: SizeInt; + protected + procedure SetCapacity(ACapacity: SizeInt); override; + // bug #24283 - can't descadent from TEnumerable + function DoGetEnumerator: TEnumerator<TDictionaryPair>; override; + procedure SetMaxLoadFactor(AValue: single); override; + function GetLoadFactor: single; override; + function GetCapacity: SizeInt; override; + strict protected // bug #26181 + constructor Create(ACapacity: SizeInt; const AComparer: IEqualityComparer<TKey>); override; overload; + constructor Create(const AComparer: IEqualityComparer<TKey>); reintroduce; overload; + constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IEqualityComparer<TKey>); override; overload; + public + // TODO: function TryFlushQueue(ACount: SizeInt): SizeInt; + + constructor Create; override; overload; + constructor Create(ACapacity: SizeInt); override; overload; + constructor Create(ACollection: TEnumerable<TDictionaryPair>); override; overload; + constructor Create(ACapacity: SizeInt; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload; + constructor Create(const AComparer: IExtendedEqualityComparer<TKey>); overload; + constructor Create(ACollection: TEnumerable<TDictionaryPair>; const AComparer: IExtendedEqualityComparer<TKey>); virtual; overload; + destructor Destroy; override; + + procedure Add(constref APair: TPair<TKey, TValue>); override; overload; + procedure Add(constref AKey: TKey; constref AValue: TValue); overload; + procedure Remove(constref AKey: TKey); + function ExtractPair(constref AKey: TKey): TPair<TKey, TValue>; + procedure Clear; override; + procedure TrimExcess; + function TryGetValue(constref AKey: TKey; out AValue: TValue): Boolean; + procedure AddOrSetValue(constref AKey: TKey; constref AValue: TValue); + function ContainsKey(constref AKey: TKey): Boolean; inline; + function ContainsValue(constref AValue: TValue): Boolean; overload; + function ContainsValue(constref AValue: TValue; const AEqualityComparer: IEqualityComparer<TValue>): Boolean; virtual; overload; + + property Items[Index: TKey]: TValue read GetItem write SetItem; default; + property Keys: TKeyCollection read GetKeys; + property Values: TValueCollection read GetValues; + + property QueueCount: SizeInt read GetQueueCount; + procedure GetMemoryLayout(const AOnGetMemoryLayoutKeyPosition: TOnGetMemoryLayoutKeyPosition); + end; + + TDictionaryOwnerships = set of (doOwnsKeys, doOwnsValues); + + TObjectDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS> = class(TDeamortizedDArrayCuckooMap<CUCKOO_CONSTRAINTS>) + private + FOwnerships: TDictionaryOwnerships; + protected + procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); override; + procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); override; + public + // can't be as "Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt = 0)" + // because bug #25607 + constructor Create(AOwnerships: TDictionaryOwnerships); overload; + constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); overload; + constructor Create(AOwnerships: TDictionaryOwnerships; + const AComparer: IExtendedEqualityComparer<TKey>); overload; + constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt; + const AComparer: IExtendedEqualityComparer<TKey>); overload; + end; + + TObjectOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS> = class(TOpenAddressingLP<OPEN_ADDRESSING_CONSTRAINTS>) + private + FOwnerships: TDictionaryOwnerships; + protected + procedure KeyNotify(constref AKey: TKey; ACollectionNotification: TCollectionNotification); override; + procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); override; + public + // can't be as "Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt = 0)" + // because bug #25607 + constructor Create(AOwnerships: TDictionaryOwnerships); overload; + constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt); overload; + constructor Create(AOwnerships: TDictionaryOwnerships; + const AComparer: IEqualityComparer<TKey>); overload; + constructor Create(AOwnerships: TDictionaryOwnerships; ACapacity: SizeInt; + const AComparer: IEqualityComparer<TKey>); overload; + end; + + // useful generics overloads + TOpenAddressingLP<TKey, TValue, THashFactory> = class(TOpenAddressingLP<TKey, TValue, THashFactory, TLinearProbing>); + TOpenAddressingLP<TKey, TValue> = class(TOpenAddressingLP<TKey, TValue, TDelphiHashFactory, TLinearProbing>); + + TObjectOpenAddressingLP<TKey, TValue, THashFactory> = class(TObjectOpenAddressingLP<TKey, TValue, THashFactory, TLinearProbing>); + TObjectOpenAddressingLP<TKey, TValue> = class(TObjectOpenAddressingLP<TKey, TValue, TDelphiHashFactory, TLinearProbing>); + + // Linear Probing with Tombstones (LPT) + TOpenAddressingLPT<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TLinearProbing>); + TOpenAddressingLPT<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, TLinearProbing>); + + TOpenAddressingQP<TKey, TValue, THashFactory> = class(TOpenAddressingSH<TKey, TValue, THashFactory, TQuadraticProbing>); + TOpenAddressingQP<TKey, TValue> = class(TOpenAddressingSH<TKey, TValue, TDelphiHashFactory, TQuadraticProbing>); + + TOpenAddressingDH<TKey, TValue, THashFactory> = class(TOpenAddressingDH<TKey, TValue, THashFactory, TDoubleHashing>); + TOpenAddressingDH<TKey, TValue> = class(TOpenAddressingDH<TKey, TValue, TDelphiDoubleHashFactory, TDoubleHashing>); + + TCuckooD2<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D2>); + TCuckooD2<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiDoubleHashFactory, TDeamortizedCuckooHashingCfg_D2>); + + TCuckooD4<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D4>); + TCuckooD4<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiQuadrupleHashFactory, TDeamortizedCuckooHashingCfg_D4>); + + TCuckooD6<TKey, TValue, THashFactory> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D6>); + TCuckooD6<TKey, TValue> = class(TDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiSixfoldHashFactory, TDeamortizedCuckooHashingCfg_D6>); + + TObjectCuckooD2<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D2>); + TObjectCuckooD2<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiDoubleHashFactory, TDeamortizedCuckooHashingCfg_D2>); + + TObjectCuckooD4<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D4>); + TObjectCuckooD4<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiQuadrupleHashFactory, TDeamortizedCuckooHashingCfg_D4>); + + TObjectCuckooD6<TKey, TValue, THashFactory> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, THashFactory, TDeamortizedCuckooHashingCfg_D6>); + TObjectCuckooD6<TKey, TValue> = class(TObjectDeamortizedDArrayCuckooMap<TKey, TValue, TDelphiSixfoldHashFactory, TDeamortizedCuckooHashingCfg_D6>); + + // for normal programmers to normal use =) + TDictionary<TKey, TValue> = class(TOpenAddressingLP<TKey, TValue>); + TObjectDictionary<TKey, TValue> = class(TObjectOpenAddressingLP<TKey, TValue>); + + TFastHashMap<TKey, TValue> = class(TCuckooD2<TKey, TValue>); + TFastObjectHashMap<TKey, TValue> = class(TObjectCuckooD2<TKey, TValue>); + + THashMap<TKey, TValue> = class(TCuckooD4<TKey, TValue>); + TObjectHashMap<TKey, TValue> = class(TObjectCuckooD4<TKey, TValue>); + +var + EmptyRecord: TEmptyRecord; diff --git a/References/DelphiAST/Source/FreePascalSupport/IOUtils.pas b/References/DelphiAST/Source/FreePascalSupport/IOUtils.pas new file mode 100644 index 000000000..a5bdb75cd --- /dev/null +++ b/References/DelphiAST/Source/FreePascalSupport/IOUtils.pas @@ -0,0 +1,22 @@ +// Dummy implementation of IOUtils in order to be able to compile Delphi AST with FPC +unit IOUtils; + +interface + +uses + SysUtils; + +type + TPath = class + public + class function Combine(const Path1, Path2: string): string; inline; static; + end; + +implementation + +class function TPath.Combine(const Path1, Path2: string): string; +begin + Result := ConcatPaths([Path1, Path2]); +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Source/SimpleParser/SimpleParser.Lexer.Types.pas b/References/DelphiAST/Source/SimpleParser/SimpleParser.Lexer.Types.pas new file mode 100644 index 000000000..ceaff9514 --- /dev/null +++ b/References/DelphiAST/Source/SimpleParser/SimpleParser.Lexer.Types.pas @@ -0,0 +1,327 @@ +{--------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License Version +1.1 (the "License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at +http://www.mozilla.org/NPL/NPL-1_1Final.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: mwPasLexTypes, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +unit CastaliaPasLexTypes; + +----------------------------------------------------------------------------} + +unit SimpleParser.Lexer.Types; + +{$IFDEF FPC}{$MODE DELPHI}{$ENDIF} + +interface + +uses + SysUtils, + TypInfo; + +{$INCLUDE SimpleParser.inc} + +{$IFNDEF D14_NEWER} +type + TArray<T> = array of T; +{$ENDIF} + +type + TMessageEventType = (meError, meNotSupported); + + TMessageEvent = procedure(Sender: TObject; const Typ: TMessageEventType; + const Msg: string; X, Y: Integer) of object; + + TCommentState = (csAnsi, csBor, csNo); + + TTokenPoint = packed record + X: Integer; + Y: Integer; + LineSeq: Integer; + end; + + TptTokenKind = ( + ptAbort, + ptAbsolute, + ptAbstract, + ptAdd, + ptAddressOp, + ptAlign, + ptAmpersand, + ptAnd, + ptAnsiComment, + ptAnsiString, + ptArray, + ptAs, + ptAsciiChar, + ptAsm, + ptAssembler, + ptAssign, + ptAt, + ptAutomated, + ptBegin, + ptBoolean, + ptBorComment, + ptBraceClose, + ptBraceOpen, + ptBreak, + ptByte, + ptByteBool, + ptCardinal, + ptCase, + ptCdecl, + ptChar, + ptClass, + ptClassForward, + ptClassFunction, + ptClassProcedure, + ptColon, + ptComma, + ptComp, + ptCompDirect, + ptConst, + ptConstructor, + ptContains, + ptContinue, + ptCRLF, + ptCRLFCo, + ptCurrency, + ptDefault, + ptDefineDirect, + ptDeprecated, + ptDestructor, + ptDispid, + ptDispinterface, + ptDiv, + ptDo, + ptDotDot, + ptDouble, + ptDoubleAddressOp, + ptDownto, + ptDWORD, + ptDynamic, + ptElse, + ptElseDirect, + ptEnd, + ptEndIfDirect, + ptEqual, + ptError, + ptExcept, + ptExit, + ptExport, + ptExports, + ptExtended, + ptExternal, + ptFar, + ptFile, + ptFinal, + ptExperimental, + ptDelayed, + ptFinalization, + ptFinally, + ptFloat, + ptFor, + ptForward, + ptFunction, + ptGoto, + ptGreater, + ptGreaterEqual, + ptHalt, + ptHelper, + ptIdentifier, + ptIf, + ptIfDirect, + ptIfEndDirect, + ptElseIfDirect, + ptIfDefDirect, + ptIfNDefDirect, + ptIfOptDirect, + ptImplementation, + ptImplements, + ptIn, + ptIncludeDirect, + ptIndex, + ptInherited, + ptInitialization, + ptInline, + ptInt64, + ptInteger, + ptIntegerConst, + ptInterface, + ptIs, + ptLabel, + ptLibrary, + ptLocal, + ptLongBool, + ptLongint, + ptLongword, + ptLower, + ptLowerEqual, + ptMessage, + ptMinus, + ptMod, + ptName, + ptNear, + ptNil, + ptNodefault, + ptNone, + ptNoreturn, + ptNot, + ptNotEqual, + ptNull, + ptObject, + ptOf, + ptOleVariant, + ptOn, + ptOperator, + ptOr, + ptOut, + ptOverload, + ptOverride, + ptPackage, + ptPacked, + ptPascal, + ptPChar, + ptPlatform, + ptPlus, + ptPoint, + ptPointerSymbol, + ptPrivate, + ptProcedure, + ptProgram, + ptProperty, + ptProtected, + ptPublic, + ptPublished, + ptRaise, + ptRead, + ptReadonly, + ptReal, + ptReal48, + ptRecord, + ptReference, + ptRegister, + ptReintroduce, + ptRemove, + ptRepeat, + ptRequires, + ptResident, + ptResourceDirect, + ptResourcestring, + ptRoundClose, + ptRoundOpen, + ptRunError, + ptSafeCall, + ptScopedEnumsDirect, + ptSealed, + ptSemiColon, + ptSet, + ptShl, + ptShortint, + ptShortString, + ptShr, + ptSingle, + ptSlash, + ptSlashesComment, + ptSmallint, + ptSpace, + ptSquareClose, + ptSquareOpen, + ptStar, + ptStatic, + ptStdcall, + ptStored, + ptStrict, + ptString, + ptStringConst, + ptStringDQConst, + ptStringresource, + ptSymbol, + ptThen, + ptThreadvar, + ptTo, + ptTry, + ptType, + ptUndefDirect, + ptUnit, + ptUnknown, + ptUnsafe, + ptUntil, + ptUses, + ptVar, + ptVarargs, + ptVariant, + ptVirtual, + ptWhile, + ptWideChar, + ptWideString, + ptWith, + ptWord, + ptWordBool, + ptWrite, + ptWriteonly, + ptXor); + + TmwPasLexStatus = record + CommentState: TCommentState; + ExID: TptTokenKind; + LineNumber: Integer; + LinePos: Integer; + Origin: PChar; + RunPos: Integer; + TokenPos: Integer; + TokenID: TptTokenKind; + end; + + EIncludeError = class(Exception); + IIncludeHandler = interface + ['{C5F20740-41D2-43E9-8321-7FE5E3AA83B6}'] + function GetIncludeFileContent(const ParentFileName, IncludeName: string; + out Content: string; out FileName: string): Boolean; + end; + +function TokenName(Value: TptTokenKind): string; +function ptTokenName(Value: TptTokenKind): string; +function IsTokenIDJunk(const aTokenID: TptTokenKind): Boolean; + +implementation + +function TokenName(Value: TptTokenKind): string; +begin + Result := Copy(ptTokenName(Value), 3, MaxInt); +end; + +function ptTokenName(Value: TptTokenKind): string; +begin + result := GetEnumName(TypeInfo(TptTokenKind), Integer(Value)); +end; + +function IsTokenIDJunk(const aTokenID: TptTokenKind): Boolean; +begin + Result := aTokenID in [ + ptAnsiComment, + ptBorComment, + ptCRLF, + ptCRLFCo, + ptSlashesComment, + ptSpace, + ptIfDirect, + ptElseDirect, + ptIfEndDirect, + ptElseIfDirect, + ptIfDefDirect, + ptIfNDefDirect, + ptEndIfDirect, + ptIfOptDirect, + ptDefineDirect, + ptScopedEnumsDirect, + ptUndefDirect]; +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Source/SimpleParser/SimpleParser.Lexer.pas b/References/DelphiAST/Source/SimpleParser/SimpleParser.Lexer.pas new file mode 100644 index 000000000..57bb887cd --- /dev/null +++ b/References/DelphiAST/Source/SimpleParser/SimpleParser.Lexer.pas @@ -0,0 +1,3076 @@ +{----------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License Version +1.1 (the "License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at +http://www.mozilla.org/NPL/NPL-1_1Final.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: mwPasLex.PAS, released August 17, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +(Martin.Waldenburg@T-Online.de). +Portions created by Martin Waldenburg are Copyright (C) 1998, 1999 Martin +Waldenburg. +All Rights Reserved. + +Contributor(s): James Jacobson, LaKraven Studios Ltd, Roman Yankovsky +(This list is ALPHABETICAL) + +Last Modified: mm/dd/yyyy +Current Version: 2.25 + +Notes: This program is a very fast Pascal tokenizer. I'd like to invite the +Delphi community to develop it further and to create a fully featured Object +Pascal parser. + +Modification history: + +LaKraven Studios Ltd, January 2015: + +- Cleaned up version-specifics up to XE8 +- Fixed all warnings & hints + +Daniel Rolf between 20010723 and 20020116 + +Made ready for Delphi 6 + +platform +deprecated +varargs +local + +Known Issues: +-----------------------------------------------------------------------------} + +unit SimpleParser.Lexer; + +{$IFDEF FPC}{$MODE DELPHI}{$ENDIF} + +{$I SimpleParser.inc} + +interface + +uses + SysUtils, Classes, Character, + {$IFDEF FPC} + Generics.Collections, + {$ENDIF} + SimpleParser.Lexer.Types; + +{$IFDEF FPC} +const + CompilerVersion = 0; + RTLVersion = 0; +{$ENDIF} + +var + Identifiers: array[#0..#127] of ByteBool; + mHashTable: array[#0..#127] of Integer; + +type + TmwBasePasLex = class; + TDirectiveEvent = procedure(Sender: TmwBasePasLex) of object; + TCommentEvent = procedure(Sender: TObject; const Text: string) of object; + + PDefineRec = ^TDefineRec; + TDefineRec = record + Defined: Boolean; + StartCount: Integer; + Next: PDefineRec; + end; + + PBufferRec = ^TBufferRec; + TBufferRec = record + Buf: PChar; + Run: Integer; + SharedBuffer: Boolean; + LineNumber: Integer; + LinePos: Integer; + FileName: string; + Next: PBufferRec; + end; + + TmwBasePasLex = class(TObject) + private + FCommentState: TCommentState; + FProcTable: array[#0..#127] of procedure of object; + FBuffer: PBufferRec; + RunAhead: Integer; + TempRun: Integer; + BufferSize: integer; + FIdentFuncTable: array[0..191] of function: TptTokenKind of object; + FTokenPos: Integer; + FTokenLine: Integer; + FTokenLinePos: Integer; + FTokenID: TptTokenKind; + FExID: TptTokenKind; + FOnMessage: TMessageEvent; + FOnCompDirect: TDirectiveEvent; + FOnElseDirect: TDirectiveEvent; + FOnEndIfDirect: TDirectiveEvent; + FOnIfDefDirect: TDirectiveEvent; + FOnIfNDefDirect: TDirectiveEvent; + FOnResourceDirect: TDirectiveEvent; + FOnIncludeDirect: TDirectiveEvent; + FOnDefineDirect: TDirectiveEvent; + FOnIfOptDirect: TDirectiveEvent; + FOnIfDirect: TDirectiveEvent; + FOnIfEndDirect: TDirectiveEvent; + FOnElseIfDirect: TDirectiveEvent; + FOnUnDefDirect: TDirectiveEvent; + FDirectiveParamOrigin: PChar; + FAsmCode: Boolean; + FDefines: TArray<string>; + FDefineStack: Integer; + FTopDefineRec: PDefineRec; + FUseDefines: Boolean; + FScopedEnums: Boolean; + FIncludeHandler: IIncludeHandler; + FOnComment: TCommentEvent; + FLineSeq: Integer; + + function KeyHash: Integer; + function KeyComp(const aKey: string): Boolean; + function Func9: tptTokenKind; + function Func15: TptTokenKind; + function Func19: TptTokenKind; + function Func20: TptTokenKind; + function Func21: TptTokenKind; + function Func23: TptTokenKind; + function Func25: TptTokenKind; + function Func27: TptTokenKind; + function Func28: TptTokenKind; + function Func29: TptTokenKind; + function Func30: TptTokenKind; + function Func32: TptTokenKind; + function Func33: TptTokenKind; + function Func35: TptTokenKind; + function Func36: TptTokenKind; + function Func37: TptTokenKind; + function Func38: TptTokenKind; + function Func39: TptTokenKind; + function Func40: TptTokenKind; + function Func41: TptTokenKind; + function Func42: TptTokenKind; + function Func43: TptTokenKind; + function Func44: TptTokenKind; + function Func45: TptTokenKind; + function Func46: TptTokenKind; + function Func47: TptTokenKind; + function Func49: TptTokenKind; + function Func52: TptTokenKind; + function Func54: TptTokenKind; + function Func55: TptTokenKind; + function Func56: TptTokenKind; + function Func57: TptTokenKind; + function Func58: TptTokenKind; + function Func59: TptTokenKind; + function Func60: TptTokenKind; + function Func61: TptTokenKind; + function Func62: TptTokenKind; + function Func63: TptTokenKind; + function Func64: TptTokenKind; + function Func65: TptTokenKind; + function Func66: TptTokenKind; + function Func69: TptTokenKind; + function Func71: TptTokenKind; + function Func72: TptTokenKind; + function Func73: TptTokenKind; + function Func75: TptTokenKind; + function Func76: TptTokenKind; + function Func78: TptTokenKind; + function Func79: TptTokenKind; + function Func81: TptTokenKind; + function Func84: TptTokenKind; + function Func85: TptTokenKind; + function Func86: TptTokenKind; + function Func87: TptTokenKind; + function Func88: TptTokenKind; + function Func89: TptTokenKind; + function Func91: TptTokenKind; + function Func92: TptTokenKind; + function Func94: TptTokenKind; + function Func95: TptTokenKind; + function Func96: TptTokenKind; + function Func97: TptTokenKind; + function Func98: TptTokenKind; + function Func99: TptTokenKind; + function Func100: TptTokenKind; + function Func101: TptTokenKind; + function Func102: TptTokenKind; + function Func103: TptTokenKind; + function Func104: TptTokenKind; + function Func105: TptTokenKind; + function Func106: TptTokenKind; + function Func107: TptTokenKind; + function Func108: TptTokenKind; + function Func112: TptTokenKind; + function Func117: TptTokenKind; + function Func123: TptTokenKind; + function Func125: TptTokenKind; + function Func126: TptTokenKind; + function Func127: TptTokenKind; + function Func128: TptTokenKind; + function Func129: TptTokenKind; + function Func130: TptTokenKind; + function Func132: TptTokenKind; + function Func133: TptTokenKind; + function Func136: TptTokenKind; + function Func141: TptTokenKind; + function Func142: TptTokenKind; + function Func143: TptTokenKind; + function Func166: TptTokenKind; + function Func167: TptTokenKind; + function Func168: TptTokenKind; + function Func191: TptTokenKind; + function AltFunc: TptTokenKind; + procedure InitIdent; + function GetPosXY: TTokenPoint; + function IdentKind: TptTokenKind; + procedure MakeMethodTables; + procedure AddressOpProc; + procedure AmpersandOpProc; + procedure AsciiCharProc; + procedure AnsiProc; + procedure BinaryIntegerProc; + procedure BorProc; + procedure BraceCloseProc; + procedure BraceOpenProc; + procedure ColonProc; + procedure CommaProc; + procedure CRProc; + procedure EqualProc; + procedure GreaterProc; + procedure IdentProc; + procedure IntegerProc; + procedure LFProc; + procedure LowerProc; + procedure MinusProc; + procedure NullProc; + procedure NumberProc; + procedure PlusProc; + procedure PointerSymbolProc; + procedure PointProc; + procedure RoundCloseProc; + procedure RoundOpenProc; + procedure SemiColonProc; + procedure SlashProc; + procedure SpaceProc; + procedure SquareCloseProc; + procedure SquareOpenProc; + procedure StarProc; + procedure StringProc; + procedure StringDQProc; + procedure SymbolProc; + procedure UnknownProc; + function GetToken: string; inline; + function GetTokenLen: Integer; inline; + function GetCompilerDirective: string; + function GetDirectiveKind: TptTokenKind; + function GetDirectiveParam: string; + function GetStringContent: string; + function GetIsJunk: Boolean; + function GetIsSpace: Boolean; + function GetIsOrdIdent: Boolean; + function GetIsRealType: Boolean; + function GetIsStringType: Boolean; + function GetIsVariantType: Boolean; + function GetIsAddOperator: Boolean; + function GetIsMulOperator: Boolean; + function GetIsRelativeOperator: Boolean; + function GetIsCompilerDirective: Boolean; + function GetIsOrdinalType: Boolean; + function GetGenID: TptTokenKind; + + procedure EnterDefineBlock(ADefined: Boolean); + procedure ExitDefineBlock; + procedure CloneDefinesFrom(ALexer: TmwBasePasLex); + procedure DoProcTable(AChar: Char); + function IsIdentifiers(AChar: Char): Boolean; inline; + function HashValue(AChar: Char): Integer; + function EvaluateComparison(AValue1: Extended; const AOper: String; AValue2: Extended): Boolean; + function EvaluateConditionalExpression(const AParams: String): Boolean; + procedure IncludeFile; + function GetIncludeFileNameFromToken(const IncludeToken: string): string; + function GetOrigin: string; + function GetRunPos: Integer; + procedure SetRunPos(const Value: Integer); + procedure SetSharedBuffer(SharedBuffer: PBufferRec); + procedure DisposeBuffer(Buf: PBufferRec); + function GetFileName: string; + procedure UpdateScopedEnums; + procedure DoOnComment(const CommentText: string); + protected + procedure SetOrigin(const NewValue: string); virtual; + public + constructor Create; + destructor Destroy; override; + function CharAhead: Char; + procedure Next; + procedure NextNoJunk; + procedure NextNoSpace; + procedure Init; + procedure InitFrom(ALexer: TmwBasePasLex); + function FirstInLine: Boolean; + + procedure AddDefine(const ADefine: string); + procedure RemoveDefine(const ADefine: string); + function IsDefined(const ADefine: string): Boolean; + procedure ClearDefines; + procedure InitDefinesDefinedByCompiler; + + property Buffer: PBufferRec read FBuffer; + property CompilerDirective: string read GetCompilerDirective; + property DirectiveParam: string read GetDirectiveParam; + property IsJunk: Boolean read GetIsJunk; + property IsSpace: Boolean read GetIsSpace; + property Origin: string read GetOrigin write SetOrigin; + property PosXY: TTokenPoint read GetPosXY; + property RunPos: Integer read GetRunPos write SetRunPos; + property Token: string read GetToken; + property TokenLen: Integer read GetTokenLen; + property TokenPos: Integer read FTokenPos; + property TokenID: TptTokenKind read FTokenID; + property ExID: TptTokenKind read FExID; + property GenID: TptTokenKind read GetGenID; + property StringContent: string read GetStringContent; + property IsOrdIdent: Boolean read GetIsOrdIdent; + property IsOrdinalType: Boolean read GetIsOrdinalType; + property IsRealType: Boolean read GetIsRealType; + property IsStringType: Boolean read GetIsStringType; + property IsVariantType: Boolean read GetIsVariantType; + property IsRelativeOperator: Boolean read GetIsRelativeOperator; + property IsAddOperator: Boolean read GetIsAddOperator; + property IsMulOperator: Boolean read GetIsMulOperator; + property IsCompilerDirective: Boolean read GetIsCompilerDirective; + property OnComment: TCommentEvent read FOnComment write FOnComment; + property OnMessage: TMessageEvent read FOnMessage write FOnMessage; + property OnCompDirect: TDirectiveEvent read FOnCompDirect write FOnCompDirect; + property OnDefineDirect: TDirectiveEvent read FOnDefineDirect write FOnDefineDirect; + property OnElseDirect: TDirectiveEvent read FOnElseDirect write FOnElseDirect; + property OnEndIfDirect: TDirectiveEvent read FOnEndIfDirect write FOnEndIfDirect; + property OnIfDefDirect: TDirectiveEvent read FOnIfDefDirect write FOnIfDefDirect; + property OnIfNDefDirect: TDirectiveEvent read FOnIfNDefDirect write FOnIfNDefDirect; + property OnIfOptDirect: TDirectiveEvent read FOnIfOptDirect write FOnIfOptDirect; + property OnIncludeDirect: TDirectiveEvent read FOnIncludeDirect write FOnIncludeDirect; + property OnIfDirect: TDirectiveEvent read FOnIfDirect write FOnIfDirect; + property OnIfEndDirect: TDirectiveEvent read FOnIfEndDirect write FOnIfEndDirect; + property OnElseIfDirect: TDirectiveEvent read FOnElseIfDirect write FOnElseIfDirect; + property OnResourceDirect: TDirectiveEvent read FOnResourceDirect write FOnResourceDirect; + property OnUnDefDirect: TDirectiveEvent read FOnUnDefDirect write FOnUnDefDirect; + property AsmCode: Boolean read FAsmCode write FAsmCode; + property DirectiveParamOrigin: PChar read FDirectiveParamOrigin; + property UseDefines: Boolean read FUseDefines write FUseDefines; + property ScopedEnums: Boolean read FScopedEnums; + property IncludeHandler: IIncludeHandler read FIncludeHandler write FIncludeHandler; + property FileName: string read GetFileName; + end; + + TmwPasLex = class(TmwBasePasLex) + private + FAheadLex: TmwBasePasLex; + function GetAheadExID: TptTokenKind; + function GetAheadGenID: TptTokenKind; + function GetAheadToken: string; + function GetAheadTokenID: TptTokenKind; + protected + procedure SetOrigin(const NewValue: string); override; + public + constructor Create; + destructor Destroy; override; + procedure InitAhead; + procedure AheadNext; + property AheadLex: TmwBasePasLex read FAheadLex; + property AheadToken: string read GetAheadToken; + property AheadTokenID: TptTokenKind read GetAheadTokenID; + property AheadExID: TptTokenKind read GetAheadExID; + property AheadGenID: TptTokenKind read GetAheadGenID; + end; + +implementation + +uses + StrUtils; + +type + TmwPasLexExpressionEvaluation = (leeNone, leeAnd, leeOr); + +procedure MakeIdentTable; +var + I, J: Char; +begin + for I := #0 to #127 do + begin + case I of + '_', '0'..'9', 'a'..'z', 'A'..'Z': Identifiers[I] := True; + else + Identifiers[I] := False; + end; + J := UpperCase(I)[1]; + case I of + 'a'..'z', 'A'..'Z', '_': mHashTable[I] := Ord(J) - 64; + else + mHashTable[Char(I)] := 0; + end; + end; +end; + +function TmwBasePasLex.CharAhead: Char; +begin + RunAhead := FBuffer.Run; + while (FBuffer.Buf[RunAhead] > #0) and (FBuffer.Buf[RunAhead] < #33) do + Inc(RunAhead); + Result := FBuffer.Buf[RunAhead]; +end; + +procedure TmwBasePasLex.ClearDefines; +var + Frame: PDefineRec; +begin + while FTopDefineRec <> nil do + begin + Frame := FTopDefineRec; + FTopDefineRec := Frame^.Next; + Dispose(Frame); + end; + FDefines := nil; + FDefineStack := 0; +end; + +procedure TmwBasePasLex.CloneDefinesFrom(ALexer: TmwBasePasLex); +var + Frame, LastFrame, SourceFrame: PDefineRec; +begin + ClearDefines; + FDefines := Copy(ALexer.FDefines); + FDefineStack := ALexer.FDefineStack; + + Frame := nil; + LastFrame := nil; + SourceFrame := ALexer.FTopDefineRec; + while SourceFrame <> nil do + begin + New(Frame); + if FTopDefineRec = nil then + FTopDefineRec := Frame + else + LastFrame^.Next := Frame; + Frame^.Defined := SourceFrame^.Defined; + Frame^.StartCount := SourceFrame^.StartCount; + LastFrame := Frame; + + SourceFrame := SourceFrame^.Next; + end; + if Frame <> nil then + Frame^.Next := nil; +end; + +function TmwBasePasLex.GetPosXY: TTokenPoint; +begin + Result.Y := FTokenLine + 1; + Result.X := FTokenPos - FTokenLinePos + 1; +end; + +function TmwBasePasLex.GetRunPos: Integer; +begin + Result := FBuffer.Run; +end; + +procedure TmwBasePasLex.InitIdent; +var + I: Integer; +begin + for I := 0 to 191 do + case I of + 9: FIdentFuncTable[I] := Func9; + 15: FIdentFuncTable[I] := Func15; + 19: FIdentFuncTable[I] := Func19; + 20: FIdentFuncTable[I] := Func20; + 21: FIdentFuncTable[I] := Func21; + 23: FIdentFuncTable[I] := Func23; + 25: FIdentFuncTable[I] := Func25; + 27: FIdentFuncTable[I] := Func27; + 28: FIdentFuncTable[I] := Func28; + 29: FIdentFuncTable[I] := Func29; + 30: FIdentFuncTable[I] := Func30; + 32: FIdentFuncTable[I] := Func32; + 33: FIdentFuncTable[I] := Func33; + 35: FIdentFuncTable[I] := Func35; + 36: FIdentFuncTable[I] := Func36; + 37: FIdentFuncTable[I] := Func37; + 38: FIdentFuncTable[I] := Func38; + 39: FIdentFuncTable[I] := Func39; + 40: FIdentFuncTable[I] := Func40; + 41: FIdentFuncTable[I] := Func41; + 42: FIdentFuncTable[I] := Func42; + 43: FIdentFuncTable[I] := Func43; + 44: FIdentFuncTable[I] := Func44; + 45: FIdentFuncTable[I] := Func45; + 46: FIdentFuncTable[I] := Func46; + 47: FIdentFuncTable[I] := Func47; + 49: FIdentFuncTable[I] := Func49; + 52: FIdentFuncTable[I] := Func52; + 54: FIdentFuncTable[I] := Func54; + 55: FIdentFuncTable[I] := Func55; + 56: FIdentFuncTable[I] := Func56; + 57: FIdentFuncTable[I] := Func57; + 58: FIdentFuncTable[I] := Func58; + 59: FIdentFuncTable[I] := Func59; + 60: FIdentFuncTable[I] := Func60; + 61: FIdentFuncTable[I] := Func61; + 62: FIdentFuncTable[I] := Func62; + 63: FIdentFuncTable[I] := Func63; + 64: FIdentFuncTable[I] := Func64; + 65: FIdentFuncTable[I] := Func65; + 66: FIdentFuncTable[I] := Func66; + 69: FIdentFuncTable[I] := Func69; + 71: FIdentFuncTable[I] := Func71; + 72: FIdentFuncTable[I] := Func72; + 73: FIdentFuncTable[I] := Func73; + 75: FIdentFuncTable[I] := Func75; + 76: FIdentFuncTable[I] := Func76; + 78: FIdentFuncTable[I] := Func78; + 79: FIdentFuncTable[I] := Func79; + 81: FIdentFuncTable[I] := Func81; + 84: FIdentFuncTable[I] := Func84; + 85: FIdentFuncTable[I] := Func85; + 86: FIdentFuncTable[I] := Func86; + 87: FIdentFuncTable[I] := Func87; + 88: FIdentFuncTable[I] := Func88; + 89: FIdentFuncTable[I] := Func89; + 91: FIdentFuncTable[I] := Func91; + 92: FIdentFuncTable[I] := Func92; + 94: FIdentFuncTable[I] := Func94; + 95: FIdentFuncTable[I] := Func95; + 96: FIdentFuncTable[I] := Func96; + 97: FIdentFuncTable[I] := Func97; + 98: FIdentFuncTable[I] := Func98; + 99: FIdentFuncTable[I] := Func99; + 100: FIdentFuncTable[I] := Func100; + 101: FIdentFuncTable[I] := Func101; + 102: FIdentFuncTable[I] := Func102; + 103: FIdentFuncTable[I] := Func103; + 104: FIdentFuncTable[I] := Func104; + 105: FIdentFuncTable[I] := Func105; + 106: FIdentFuncTable[I] := Func106; + 107: FIdentFuncTable[I] := Func107; + 108: FIdentFuncTable[I] := Func108; + 112: FIdentFuncTable[I] := Func112; + 117: FIdentFuncTable[I] := Func117; + 123: FIdentFuncTable[I] := Func123; + 125: FIdentFuncTable[I] := Func125; + 126: FIdentFuncTable[I] := Func126; + 127: FIdentFuncTable[I] := Func127; + 128: FIdentFuncTable[I] := Func128; + 129: FIdentFuncTable[I] := Func129; + 130: FIdentFuncTable[I] := Func130; + 132: FIdentFuncTable[I] := Func132; + 133: FIdentFuncTable[I] := Func133; + 136: FIdentFuncTable[I] := Func136; + 141: FIdentFuncTable[I] := Func141; + 142: FIdentFuncTable[I] := Func142; + 143: FIdentFuncTable[I] := Func143; + 166: FIdentFuncTable[I] := Func166; + 167: FIdentFuncTable[I] := Func167; + 168: FIdentFuncTable[I] := Func168; + 191: FIdentFuncTable[I] := Func191; + else + FIdentFuncTable[I] := AltFunc; + end; +end; + +function TmwBasePasLex.KeyHash: Integer; +begin + Result := 0; + while IsIdentifiers(FBuffer.Buf[FBuffer.Run]) do + begin + Inc(Result, HashValue(FBuffer.Buf[FBuffer.Run])); + Inc(FBuffer.Run); + end; +end; + +function TmwBasePasLex.KeyComp(const aKey: string): Boolean; +var + I: Integer; + Temp: PChar; +begin + if Length(aKey) = TokenLen then + begin + Temp := FBuffer.Buf + FTokenPos; + Result := True; + for i := 1 to TokenLen do + begin + if mHashTable[Temp^] <> mHashTable[aKey[i]] then + begin + Result := False; + Break; + end; + Inc(Temp); + end; + end + else + Result := False; +end; + +function TmwBasePasLex.Func9: tptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Add') then + FExID := ptAdd; +end; + +function TmwBasePasLex.Func15: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('If') then Result := ptIf; +end; + +function TmwBasePasLex.Func19: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Do') then Result := ptDo else + if KeyComp('And') then Result := ptAnd; +end; + +function TmwBasePasLex.Func20: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('As') then Result := ptAs; +end; + +function TmwBasePasLex.Func21: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Of') then Result := ptOf else + if KeyComp('At') then FExID := ptAt; +end; + +function TmwBasePasLex.Func23: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('End') then Result := ptEnd else + if KeyComp('In') then Result := ptIn; +end; + +function TmwBasePasLex.Func25: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Far') then FExID := ptFar; +end; + +function TmwBasePasLex.Func27: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Cdecl') then FExID := ptCdecl; +end; + +function TmwBasePasLex.Func28: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Read') then FExID := ptRead else + if KeyComp('Case') then Result := ptCase else + if KeyComp('Is') then Result := ptIs; +end; + +function TmwBasePasLex.Func29: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('On') then FExID := ptOn; +end; + +function TmwBasePasLex.Func30: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Char') then FExID := ptChar; +end; + +function TmwBasePasLex.Func32: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('File') then Result := ptFile else + if KeyComp('Label') then Result := ptLabel else + if KeyComp('Mod') then Result := ptMod; +end; + +function TmwBasePasLex.Func33: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Or') then Result := ptOr else + if KeyComp('Name') then FExID := ptName else + if KeyComp('Asm') then Result := ptAsm; +end; + +function TmwBasePasLex.Func35: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Nil') then Result := ptNil else + if KeyComp('To') then Result := ptTo else + if KeyComp('Div') then Result := ptDiv; +end; + +function TmwBasePasLex.Func36: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Real') then FExID := ptReal else + if KeyComp('Real48') then FExID := ptReal48; +end; + +function TmwBasePasLex.Func37: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Begin') then Result := ptBegin else + if KeyComp('Break') then FExID := ptBreak; +end; + +function TmwBasePasLex.Func38: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Near') then FExID := ptNear; +end; + +function TmwBasePasLex.Func39: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('For') then Result := ptFor else + if KeyComp('Shl') then Result := ptShl; +end; + +function TmwBasePasLex.Func40: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Packed') then Result := ptPacked; +end; + +function TmwBasePasLex.Func41: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Var') then Result := ptVar else + if KeyComp('Else') then Result := ptElse else + if KeyComp('Halt') then FExID := ptHalt; +end; + +function TmwBasePasLex.Func42: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Final') then + FExID := ptFinal; //TODO: Is this supposed to be an ExID? +end; + +function TmwBasePasLex.Func43: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Int64') then FExID := ptInt64 + else if KeyComp('local') then FExID := ptLocal + else if KeyComp('align') then FExID := ptAlign; +end; + +function TmwBasePasLex.Func44: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Set') then Result := ptSet else + if KeyComp('Package') then FExID := ptPackage; +end; + +function TmwBasePasLex.Func45: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Shr') then Result := ptShr; +end; + +function TmwBasePasLex.Func46: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('PChar') then FExID := ptPChar else + if KeyComp('Sealed') then Result := ptSealed; +end; + +function TmwBasePasLex.Func47: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Then') then Result := ptThen else + if KeyComp('Comp') then FExID := ptComp; +end; + +function TmwBasePasLex.Func49: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Not') then Result := ptNot; +end; + +function TmwBasePasLex.Func52: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Byte') then FExID := ptByte else + if KeyComp('Raise') then Result := ptRaise else + if KeyComp('Pascal') then FExID := ptPascal; +end; + +function TmwBasePasLex.Func54: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Class') then Result := ptClass; +end; + +function TmwBasePasLex.Func55: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Object') then Result := ptObject; +end; + +function TmwBasePasLex.Func56: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Index') then FExID := ptIndex else + if KeyComp('Out') then FExID := ptOut else // bug in Delphi's documentation: OUT is a directive + if KeyComp('Abort') then FExID := ptAbort else + if KeyComp('Delayed') then FExID := ptDelayed; +end; + +function TmwBasePasLex.Func57: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('While') then Result := ptWhile else + if KeyComp('Xor') then Result := ptXor else + if KeyComp('Goto') then Result := ptGoto; +end; + +function TmwBasePasLex.Func58: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Exit') then FExID := ptExit; +end; + +function TmwBasePasLex.Func59: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Safecall') then FExID := ptSafecall else + if KeyComp('Double') then FExID := ptDouble; +end; + +function TmwBasePasLex.Func60: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('With') then Result := ptWith else + if KeyComp('Word') then FExID := ptWord; +end; + +function TmwBasePasLex.Func61: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Dispid') then FExID := ptDispid; +end; + +function TmwBasePasLex.Func62: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Cardinal') then FExID := ptCardinal; +end; + +function TmwBasePasLex.Func63: TptTokenKind; +begin + Result := ptIdentifier; + case FBuffer.Buf[FTokenPos] of + 'P', 'p': if KeyComp('Public') then FExID := ptPublic; + 'A', 'a': if KeyComp('Array') then Result := ptArray; + 'T', 't': if KeyComp('Try') then Result := ptTry; + 'R', 'r': if KeyComp('Record') then Result := ptRecord; + 'I', 'i': if KeyComp('Inline') then + begin + Result := ptInline; + FExID := ptInline; + end; + end; +end; + +function TmwBasePasLex.Func64: TptTokenKind; +begin + Result := ptIdentifier; + case FBuffer.Buf[FTokenPos] of + 'B', 'b': if KeyComp('Boolean') then FExID := ptBoolean; + 'D', 'd': if KeyComp('DWORD') then FExID := ptDWORD; + 'U', 'u': if KeyComp('Uses') then Result := ptUses else + if KeyComp('Unit') then Result := ptUnit; + 'H', 'h': if KeyComp('Helper') then FExID := ptHelper; + end; +end; + +function TmwBasePasLex.Func65: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Repeat') then Result := ptRepeat; +end; + +function TmwBasePasLex.Func66: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Single') then FExID := ptSingle else + if KeyComp('Type') then Result := ptType else + if KeyComp('Unsafe') then Result := ptUnsafe; +end; + +function TmwBasePasLex.Func69: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Default') then FExID := ptDefault else + if KeyComp('Dynamic') then FExID := ptDynamic else + if KeyComp('Message') then FExID := ptMessage; +end; + +function TmwBasePasLex.Func71: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('WideChar') then FExID := ptWideChar else + if KeyComp('Stdcall') then FExID := ptStdcall else + if KeyComp('Const') then Result := ptConst; +end; + +function TmwBasePasLex.Func72: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Static') then FExID := ptStatic; +end; + +function TmwBasePasLex.Func73: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Except') then Result := ptExcept; +end; + +function TmwBasePasLex.Func75: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Write') then FExID := ptWrite; +end; + +function TmwBasePasLex.Func76: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Until') then Result := ptUntil; +end; + +function TmwBasePasLex.Func78: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Integer') then FExID := ptInteger else + if KeyComp('Remove') then FExID := ptRemove; +end; + +function TmwBasePasLex.Func79: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Finally') then Result := ptFinally else + if KeyComp('Reference') then FExID := ptReference; +end; + +function TmwBasePasLex.Func81: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Extended') then FExID := ptExtended else + if KeyComp('Stored') then FExID := ptStored else + if KeyComp('Interface') then Result := ptInterface else + if KeyComp('Deprecated') then FExID := ptDeprecated; +end; + +function TmwBasePasLex.Func84: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Abstract') then FExID := ptAbstract; +end; + +function TmwBasePasLex.Func85: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Library') then Result := ptLibrary else + if KeyComp('Forward') then FExID := ptForward else + if KeyComp('Variant') then FExID := ptVariant; +end; + +function TmwBasePasLex.Func87: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('String') then Result := ptString; +end; + +function TmwBasePasLex.Func88: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Program') then Result := ptProgram; +end; + +function TmwBasePasLex.Func89: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Strict') then FExID := ptStrict; +end; + +function TmwBasePasLex.Func91: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Downto') then Result := ptDownto else + if KeyComp('Private') then FExID := ptPrivate else + if KeyComp('Longint') then FExID := ptLongint; +end; + +function TmwBasePasLex.Func92: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Inherited') then Result := ptInherited else + if KeyComp('LongBool') then FExID := ptLongBool else + if KeyComp('Overload') then FExID := ptOverload; +end; + +function TmwBasePasLex.Func94: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Resident') then FExID := ptResident else + if KeyComp('Readonly') then FExID := ptReadonly else + if KeyComp('Assembler') then FExID := ptAssembler; +end; + +function TmwBasePasLex.Func95: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Contains') then FExID := ptContains else + if KeyComp('Absolute') then FExID := ptAbsolute; +end; + +function TmwBasePasLex.Func96: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('ByteBool') then FExID := ptByteBool else + if KeyComp('Override') then FExID := ptOverride else + if KeyComp('Published') then FExID := ptPublished; +end; + +function TmwBasePasLex.Func97: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Threadvar') then Result := ptThreadvar; +end; + +function TmwBasePasLex.Func98: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Export') then FExID := ptExport else + if KeyComp('Nodefault') then FExID := ptNodefault; +end; + +function TmwBasePasLex.Func99: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('External') then FExID := ptExternal; +end; + +function TmwBasePasLex.Func100: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Automated') then FExID := ptAutomated else + if KeyComp('Smallint') then FExID := ptSmallint; +end; + +function TmwBasePasLex.Func101: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Register') then FExID := ptRegister else + if KeyComp('Platform') then FExID := ptPlatform else + if KeyComp('Continue') then FExID := ptContinue; +end; + +function TmwBasePasLex.Func102: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Function') then Result := ptFunction; +end; + +function TmwBasePasLex.Func103: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Virtual') then FExID := ptVirtual; +end; + +function TmwBasePasLex.Func104: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('WordBool') then FExID := ptWordBool; +end; + +function TmwBasePasLex.Func105: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Procedure') then Result := ptProcedure; +end; + +function TmwBasePasLex.Func106: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Protected') then FExID := ptProtected; +end; + +function TmwBasePasLex.Func107: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Currency') then FExID := ptCurrency; +end; + +function TmwBasePasLex.Func108: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Longword') then FExID := ptLongword else + if KeyComp('Operator') then FExID := ptOperator; +end; + +function TmwBasePasLex.Func112: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Requires') then FExID := ptRequires; +end; + +function TmwBasePasLex.Func117: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Exports') then Result := ptExports else + if KeyComp('OleVariant') then FExID := ptOleVariant; +end; + +function TmwBasePasLex.Func123: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Shortint') then FExID := ptShortint; +end; + +function TmwBasePasLex.Func125: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('noreturn') then FExID := ptNoreturn; +end; + +function TmwBasePasLex.Func126: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Implements') then FExID := ptImplements; +end; + +function TmwBasePasLex.Func127: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Runerror') then FExID := ptRunError; +end; + +function TmwBasePasLex.Func128: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('WideString') then FExID := ptWideString; +end; + +function TmwBasePasLex.Func129: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Dispinterface') then Result := ptDispinterface +end; + +function TmwBasePasLex.Func130: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('AnsiString') then FExID := ptAnsiString; +end; + +function TmwBasePasLex.Func132: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Reintroduce') then FExID := ptReintroduce; +end; + +function TmwBasePasLex.Func133: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Property') then Result := ptProperty; +end; + +function TmwBasePasLex.Func136: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Finalization') then Result := ptFinalization; +end; + +function TmwBasePasLex.Func141: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Writeonly') then FExID := ptWriteonly; +end; + +function TmwBasePasLex.Func142: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('experimental') then FExID := ptExperimental; +end; + +function TmwBasePasLex.Func143: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Destructor') then Result := ptDestructor; +end; + +function TmwBasePasLex.Func166: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Constructor') then Result := ptConstructor else + if KeyComp('Implementation') then Result := ptImplementation; +end; + +function TmwBasePasLex.Func167: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('ShortString') then FExID := ptShortString; +end; + +function TmwBasePasLex.Func168: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Initialization') then Result := ptInitialization; +end; + +function TmwBasePasLex.Func191: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Resourcestring') then Result := ptResourcestring else + if KeyComp('Stringresource') then FExID := ptStringresource; +end; + +function TmwBasePasLex.AltFunc: TptTokenKind; +begin + Result := ptIdentifier; +end; + +function TmwBasePasLex.IdentKind: TptTokenKind; +var + HashKey: Integer; +begin + HashKey := KeyHash; + if HashKey < 192 then + Result := FIdentFuncTable[HashKey] + else + Result := ptIdentifier; +end; + +procedure TmwBasePasLex.MakeMethodTables; +var + I: Char; +begin + for I := #0 to #127 do + case I of + #0: FProcTable[I] := NullProc; + #10: FProcTable[I] := LFProc; + #13: FProcTable[I] := CRProc; + #1..#9, #11, #12, #14..#32: FProcTable[I] := SpaceProc; + '#': FProcTable[I] := AsciiCharProc; + '$': FProcTable[I] := IntegerProc; + '%': FProcTable[I] := BinaryIntegerProc; + #39: FProcTable[I] := StringProc; + '0'..'9': FProcTable[I] := NumberProc; + 'A'..'Z', 'a'..'z', '_': FProcTable[I] := IdentProc; + '{': FProcTable[I] := BraceOpenProc; + '}': FProcTable[I] := BraceCloseProc; + '!', '"', '&', '('..'/', ':'..'@', '['..'^', '`', '~': + begin + case I of + '(': FProcTable[I] := RoundOpenProc; + ')': FProcTable[I] := RoundCloseProc; + '*': FProcTable[I] := StarProc; + '+': FProcTable[I] := PlusProc; + ',': FProcTable[I] := CommaProc; + '-': FProcTable[I] := MinusProc; + '.': FProcTable[I] := PointProc; + '/': FProcTable[I] := SlashProc; + ':': FProcTable[I] := ColonProc; + ';': FProcTable[I] := SemiColonProc; + '<': FProcTable[I] := LowerProc; + '=': FProcTable[I] := EqualProc; + '>': FProcTable[I] := GreaterProc; + '@': FProcTable[I] := AddressOpProc; + '[': FProcTable[I] := SquareOpenProc; + ']': FProcTable[I] := SquareCloseProc; + '^': FProcTable[I] := PointerSymbolProc; + '"': FProcTable[I] := StringDQProc; + '&': FProcTable[I] := AmpersandOpProc; + else + FProcTable[I] := SymbolProc; + end; + end; + else + FProcTable[I] := UnknownProc; + end; +end; + +constructor TmwBasePasLex.Create; +begin + inherited Create; + InitIdent; + MakeMethodTables; + FExID := ptUnKnown; + + FUseDefines := True; + FScopedEnums := False; + FTopDefineRec := nil; + ClearDefines; + + New(FBuffer); + FillChar(FBuffer^, SizeOf(TBufferRec), 0); +end; + +destructor TmwBasePasLex.Destroy; +begin + if not FBuffer.SharedBuffer then + FreeMem(FBuffer.Buf); + + Dispose(FBuffer); + + ClearDefines; //If we don't do this, we get a memory leak + inherited Destroy; +end; + +procedure TmwBasePasLex.DisposeBuffer(Buf: PBufferRec); +begin + if Assigned(Buf.Buf) and not Buf.SharedBuffer then + FreeMem(Buf.Buf); + Dispose(Buf); +end; + +procedure TmwBasePasLex.DoOnComment(const CommentText: string); +begin + if not FUseDefines or (FDefineStack = 0) then + FOnComment(Self, CommentText); +end; + +procedure TmwBasePasLex.DoProcTable(AChar: Char); +begin + if Ord(AChar) <= 127 then + FProcTable[AChar] + else + begin + IdentProc; + end; +end; + +procedure TmwBasePasLex.SetOrigin(const NewValue: string); +begin + BufferSize := (Length(NewValue) + 1) * SizeOf(Char); + + GetMem(FBuffer.Buf, BufferSize); + StrPCopy(FBuffer.Buf, NewValue); + + Init; + Next; +end; + +procedure TmwBasePasLex.SetRunPos(const Value: Integer); +begin + FBuffer.Run := Value; + Next; +end; + +procedure TmwBasePasLex.SetSharedBuffer(SharedBuffer: PBufferRec); +var + NextBuffer: PBufferRec; +begin + while Assigned(FBuffer.Next) do + begin + NextBuffer := FBuffer; + FBuffer := FBuffer.Next; + DisposeBuffer(NextBuffer); + end; + + if not FBuffer.SharedBuffer and Assigned(FBuffer.Buf) then + FreeMem(FBuffer.Buf); + + FBuffer.Buf := SharedBuffer.Buf; + FBuffer.Run := SharedBuffer.Run; + FBuffer.LineNumber := SharedBuffer.LineNumber; + FBuffer.LinePos := SharedBuffer.LinePos; + FBuffer.SharedBuffer := True; + + Next; +end; + +procedure TmwBasePasLex.AddDefine(const ADefine: string); +var + len: Integer; +begin + len := Length(FDefines); + SetLength(FDefines, len + 1); + FDefines[len] := ADefine; +end; + +procedure TmwBasePasLex.AddressOpProc; +begin + case FBuffer.Buf[FBuffer.Run + 1] of + '@': + begin + FTokenID := ptDoubleAddressOp; + Inc(FBuffer.Run, 2); + end; + else + begin + FTokenID := ptAddressOp; + Inc(FBuffer.Run); + end; + end; +end; + +procedure TmwBasePasLex.AsciiCharProc; +begin + FTokenID := ptAsciiChar; + Inc(FBuffer.Run); + if FBuffer.Buf[FBuffer.Run] = '$' then + begin + Inc(FBuffer.Run); + while CharInSet(FBuffer.Buf[FBuffer.Run], ['0'..'9', 'A'..'F', 'a'..'f']) do Inc(FBuffer.Run); + end else + begin +{$IFDEF SUPPORTS_INTRINSIC_HELPERS} + while Char(FBuffer.Buf[FBuffer.Run]).IsDigit do +{$ELSE} + while IsDigit(FBuffer.Buf[FBuffer.Run]) do +{$ENDIF} + Inc(FBuffer.Run); + end; +end; + +procedure TmwBasePasLex.BraceCloseProc; +begin + Inc(FBuffer.Run); + FTokenID := ptError; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Illegal character', PosXY.X, PosXY.Y); +end; + +procedure TmwBasePasLex.BinaryIntegerProc; +begin + Inc(FBuffer.Run); + FTokenID := ptIntegerConst; + while CharInSet(FBuffer.Buf[FBuffer.Run], ['0', '1', '_']) do + Inc(FBuffer.Run); +end; + +procedure TmwBasePasLex.BorProc; +var + BeginRun: Integer; + CommentText: string; +begin + FTokenID := ptBorComment; + case FBuffer.Buf[FBuffer.Run] of + #0: + begin + NullProc; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unexpected file end', PosXY.X, PosXY.Y); + Exit; + end; + end; + + BeginRun := FBuffer.Run; + + while FBuffer.Buf[FBuffer.Run] <> #0 do + case FBuffer.Buf[FBuffer.Run] of + '}': + begin + FCommentState := csNo; + Inc(FBuffer.Run); + Break; + end; + #10: + begin + Inc(FLineSeq); + Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + #13: + begin + Inc(FLineSeq); + Inc(FBuffer.Run); + if FBuffer.Buf[FBuffer.Run] = #10 then Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + else + Inc(FBuffer.Run); + end; + + if Assigned(FOnComment) then + begin + SetString(CommentText, PChar(@FBuffer.Buf[BeginRun]), FBuffer.Run - BeginRun - 1); + DoOnComment(CommentText); + end; +end; + +procedure TmwBasePasLex.BraceOpenProc; +var + BeginRun: Integer; + CommentText: string; +begin + case FBuffer.Buf[FBuffer.Run + 1] of + '$': FTokenID := GetDirectiveKind; + else + begin + FTokenID := ptBorComment; + FCommentState := csBor; + end; + end; + + Inc(FBuffer.Run); + BeginRun := FBuffer.Run; + while FBuffer.Buf[FBuffer.Run] <> #0 do + case FBuffer.Buf[FBuffer.Run] of + '}': + begin + FCommentState := csNo; + Inc(FBuffer.Run); + Break; + end; + #10: + begin + Inc(FLineSeq); + Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + #13: + begin + Inc(FLineSeq); + Inc(FBuffer.Run); + if FBuffer.Buf[FBuffer.Run] = #10 then Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + else + Inc(FBuffer.Run); + end; + case FTokenID of + PtBorComment: + begin + if Assigned(FOnComment) then + begin + SetString(CommentText, PChar(@FBuffer.Buf[BeginRun]), FBuffer.Run - BeginRun - 1); + DoOnComment(CommentText); + end; + end; + PtCompDirect: + begin + if Assigned(FOnCompDirect) then + FOnCompDirect(Self); + end; + PtDefineDirect: + begin + if FUseDefines and (FDefineStack = 0) then + AddDefine(DirectiveParam); + if Assigned(FOnDefineDirect) then + FOnDefineDirect(Self); + end; + PtElseDirect: + begin + if FUseDefines then + begin + if FTopDefineRec <> nil then + begin + if FTopDefineRec^.Defined then + Inc(FDefineStack) + else + if FDefineStack > 0 then + Dec(FDefineStack); + end; + end; + if Assigned(FOnElseDirect) then + FOnElseDirect(Self); + end; + PtEndIfDirect: + begin + if FUseDefines then + ExitDefineBlock; + if Assigned(FOnEndIfDirect) then + FOnEndIfDirect(Self); + end; + PtIfDefDirect: + begin + if FUseDefines then + EnterDefineBlock(IsDefined(DirectiveParam)); + if Assigned(FOnIfDefDirect) then + FOnIfDefDirect(Self); + end; + PtIfNDefDirect: + begin + if FUseDefines then + EnterDefineBlock(not IsDefined(DirectiveParam)); + if Assigned(FOnIfNDefDirect) then + FOnIfNDefDirect(Self); + end; + PtIfOptDirect: + begin + if FUseDefines then + EnterDefineBlock(False); + if Assigned(FOnIfOptDirect) then + FOnIfOptDirect(Self); + end; + PtIfDirect: + begin + if FUseDefines then + EnterDefineBlock(EvaluateConditionalExpression(DirectiveParam)); + if Assigned(FOnIfDirect) then + FOnIfDirect(Self); + end; + PtIfEndDirect: + begin + if FUseDefines then + ExitDefineBlock; + if Assigned(FOnIfEndDirect) then + FOnIfEndDirect(Self); + end; + PtElseIfDirect: + begin + if FUseDefines then + begin + if FTopDefineRec <> nil then + begin + if FTopDefineRec^.Defined then + FDefineStack := FTopDefineRec.StartCount + 1 + else + begin + FDefineStack := FTopDefineRec.StartCount; + if EvaluateConditionalExpression(DirectiveParam) then + FTopDefineRec^.Defined := True + else + FDefineStack := FTopDefineRec.StartCount + 1 + end; + end; + end; + if Assigned(FOnElseIfDirect) then + FOnElseIfDirect(Self); + end; + PtIncludeDirect: + begin +// if Assigned(FOnIncludeDirect) then +// FOnIncludeDirect(Self); + if Assigned(FIncludeHandler) and (FDefineStack = 0) then + IncludeFile + else + Next; + end; + PtResourceDirect: + begin + if Assigned(FOnResourceDirect) then + FOnResourceDirect(Self); + end; + PtScopedEnumsDirect: + begin + UpdateScopedEnums; + end; + PtUndefDirect: + begin + if FUseDefines and (FDefineStack = 0) then + RemoveDefine(DirectiveParam); + if Assigned(FOnUnDefDirect) then + FOnUnDefDirect(Self); + end; + end; +end; + +function TmwBasePasLex.EvaluateComparison(AValue1: Extended; const AOper: String; AValue2: Extended): Boolean; +begin + if AOper = '=' then + Result := AValue1 = AValue2 + else if AOper = '<>' then + Result := AValue1 <> AValue2 + else if AOper = '<' then + Result := AValue1 < AValue2 + else if AOper = '<=' then + Result := AValue1 <= AValue2 + else if AOper = '>' then + Result := AValue1 > AValue2 + else if AOper = '>=' then + Result := AValue1 >= AValue2 + else + Result := False; +end; + +function TmwBasePasLex.EvaluateConditionalExpression(const AParams: String): Boolean; +var + LParams: String; + LDefine: String; + LEvaluation: TmwPasLexExpressionEvaluation; + LIsComVer: Boolean; + LIsRtlVer: Boolean; + LOper: string; + LValue: Integer; + p: Integer; +begin + { TODO : Expand support for <=> evaluations (complicated to do). Expand support for NESTED expressions } + LEvaluation := leeNone; + LParams := TrimLeft(AParams); + LIsComVer := Pos('COMPILERVERSION', LParams) = 1; + LIsRtlVer := Pos('RTLVERSION', LParams) = 1; + if LIsComVer or LIsRtlVer then //simple parser which covers most frequent use cases + begin + Result := False; + if LIsComVer then + Delete(LParams, 1, Length('COMPILERVERSION')); + if LIsRtlVer then + Delete(LParams, 1, Length('RTLVERSION')); + while (LParams <> '') and (LParams[1] = ' ') do + Delete(LParams, 1, 1); + p := Pos(' ', LParams); + if p > 0 then + begin + LOper := Copy(LParams, 1, p-1); + Delete(LParams, 1, p); + while (LParams <> '') and (LParams[1] = ' ') do + Delete(LParams, 1, 1); + p := Pos(' ', LParams); + if p = 0 then + p := Length(LParams) + 1; + if TryStrToInt(Copy(LParams, 1, p-1), LValue) then + begin + Delete(LParams, 1, p); + while (LParams <> '') and (LParams[1] = ' ') do + Delete(LParams, 1, 1); + if LParams = '' then + if LIsComVer then + Result := EvaluateComparison(CompilerVersion, LOper, LValue) + else if LIsRtlVer then + Result := EvaluateComparison(RTLVersion, LOper, LValue); + end; + end; + end else + if (Pos('DEFINED(', LParams) = 1) or (Pos('NOT DEFINED(', LParams) = 1) then + begin + Result := True; // Optimistic + while (Pos('DEFINED(', LParams) = 1) or (Pos('NOT DEFINED(', LParams) = 1) do + begin + if Pos('DEFINED(', LParams) = 1 then + begin + LDefine := Copy(LParams, 9, Pos(')', LParams) - 9); + LParams := TrimLeft(Copy(LParams, 10 + Length(LDefine), Length(AParams) - (9 + Length(LDefine)))); + case LEvaluation of + leeNone: Result := IsDefined(LDefine); + leeAnd: Result := Result and IsDefined(LDefine); + leeOr: Result := Result or IsDefined(LDefine); + end; + end + else if Pos('NOT DEFINED(', LParams) = 1 then + begin + LDefine := Copy(LParams, 13, Pos(')', LParams) - 13); + LParams := TrimLeft(Copy(LParams, 14 + Length(LDefine), Length(AParams) - (13 + Length(LDefine)))); + case LEvaluation of + leeNone: Result := (not IsDefined(LDefine)); + leeAnd: Result := Result and (not IsDefined(LDefine)); + leeOr: Result := Result or (not IsDefined(LDefine)); + end; + end; + // Determine next Evaluation + if Pos('AND ', LParams) = 1 then + begin + LEvaluation := leeAnd; + LParams := TrimLeft(Copy(LParams, 4, Length(LParams) - 3)); + end + else if Pos('OR ', LParams) = 1 then + begin + LEvaluation := leeOr; + LParams := TrimLeft(Copy(LParams, 3, Length(LParams) - 2)); + end; + end; + end else + Result := False; +end; + +procedure TmwBasePasLex.ColonProc; +begin + case FBuffer.Buf[FBuffer.Run + 1] of + '=': + begin + Inc(FBuffer.Run, 2); + FTokenID := ptAssign; + end; + else + begin + Inc(FBuffer.Run); + FTokenID := ptColon; + end; + end; +end; + +procedure TmwBasePasLex.CommaProc; +begin + Inc(FBuffer.Run); + FTokenID := ptComma; +end; + +procedure TmwBasePasLex.CRProc; +begin + case FCommentState of + csBor: FTokenID := ptCRLFCo; + csAnsi: FTokenID := ptCRLFCo; + else + FTokenID := ptCRLF; + end; + + case FBuffer.Buf[FBuffer.Run + 1] of + #10: Inc(FBuffer.Run, 2); + else + Inc(FBuffer.Run); + end; + Inc(FLineSeq); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; +end; + +procedure TmwBasePasLex.EnterDefineBlock(ADefined: Boolean); +var + StackFrame: PDefineRec; +begin + New(StackFrame); + StackFrame^.Next := FTopDefineRec; + StackFrame^.Defined := ADefined; + StackFrame^.StartCount := FDefineStack; + FTopDefineRec := StackFrame; + if not ADefined then + Inc(FDefineStack); +end; + +procedure TmwBasePasLex.EqualProc; +begin + Inc(FBuffer.Run); + FTokenID := ptEqual; +end; + +procedure TmwBasePasLex.ExitDefineBlock; +var + StackFrame: PDefineRec; +begin + StackFrame := FTopDefineRec; + if StackFrame <> nil then + begin + FDefineStack := StackFrame^.StartCount; + FTopDefineRec := StackFrame^.Next; + Dispose(StackFrame); + end; +end; + +procedure TmwBasePasLex.GreaterProc; +begin + case FBuffer.Buf[FBuffer.Run + 1] of + '=': + begin + Inc(FBuffer.Run, 2); + FTokenID := ptGreaterEqual; + end; + else + begin + Inc(FBuffer.Run); + FTokenID := ptGreater; + end; + end; +end; + +function TmwBasePasLex.HashValue(AChar: Char): Integer; +begin + if AChar <= #127 then + Result := mHashTable[FBuffer.Buf[FBuffer.Run]] + else + Result := Ord(AChar); +end; + +procedure TmwBasePasLex.IdentProc; +begin + FTokenID := IdentKind; +end; + +procedure TmwBasePasLex.IntegerProc; +begin + Inc(FBuffer.Run); + FTokenID := ptIntegerConst; + while CharInSet(FBuffer.Buf[FBuffer.Run], ['0'..'9', 'A'..'F', 'a'..'f', '_']) do + Inc(FBuffer.Run); +end; + +function TmwBasePasLex.IsDefined(const ADefine: string): Boolean; +var + i: Integer; +begin + for i := 0 to High(FDefines) do + if SameText(FDefines[i], ADefine) then + Exit(True); + Result := False; +end; + +function TmwBasePasLex.IsIdentifiers(AChar: Char): Boolean; +begin + {$IF DECLARED(TCharHelper)} + Result := AChar.IsLetterOrDigit or (AChar = '_') + or ((Ord(AChar) > 127) and not AChar.IsHighSurrogate and not AChar.IsLowSurrogate); + {$ELSE} + // assuming Delphi identifier may include letters, digits, underscore symbol + // and any character over 127 except surrogates + Result := TCharacter.IsLetterOrDigit(AChar) or (AChar = '_') + or ((Ord(AChar) > 127) and not TCharacter.IsHighSurrogate(AChar) and not TCharacter.IsLowSurrogate(AChar)); + {$IFEND} +end; + +procedure TmwBasePasLex.LFProc; +begin + case FCommentState of + csBor: FTokenID := ptCRLFCo; + csAnsi: FTokenID := ptCRLFCo; + else + FTokenID := ptCRLF; + end; + Inc(FLineSeq); + Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; +end; + +procedure TmwBasePasLex.LowerProc; +begin + case FBuffer.Buf[FBuffer.Run + 1] of + '=': + begin + Inc(FBuffer.Run, 2); + FTokenID := ptLowerEqual; + end; + '>': + begin + Inc(FBuffer.Run, 2); + FTokenID := ptNotEqual; + end + else + begin + Inc(FBuffer.Run); + FTokenID := ptLower; + end; + end; +end; + +procedure TmwBasePasLex.MinusProc; +begin + Inc(FBuffer.Run); + FTokenID := ptMinus; +end; + +procedure TmwBasePasLex.NullProc; +var + OldBuffer: PBufferRec; +begin + if Assigned(FBuffer.Next) then + begin + OldBuffer := FBuffer; + FBuffer := FBuffer.Next; + DisposeBuffer(OldBuffer); + + Next; + end else + FTokenID := ptNull; +end; + +procedure TmwBasePasLex.NumberProc; +begin + Inc(FBuffer.Run); + FTokenID := ptIntegerConst; + while CharInSet(FBuffer.Buf[FBuffer.Run], ['0'..'9', '.', 'e', 'E', '_']) do + begin + case FBuffer.Buf[FBuffer.Run] of + '.': + if FBuffer.Buf[FBuffer.Run + 1] = '.' then + Break + else + FTokenID := ptFloat + end; + Inc(FBuffer.Run); + end; +end; + +procedure TmwBasePasLex.PlusProc; +begin + Inc(FBuffer.Run); + FTokenID := ptPlus; +end; + +procedure TmwBasePasLex.PointerSymbolProc; +const + PointerChars = ['a'..'z', 'A'..'Z', '\', '!', '"', '#', '$', '%', '&', '''', + '?', '@', '_', '`', '|', '}', '~']; + // TODO: support ']', '), ''*', '+', ',', '-', '.', '/', ':', ';', '<', '=', '>', '{', '^', '(', '[' +begin + Inc(FBuffer.Run); + FTokenID := ptPointerSymbol; + + //This is a wierd Pascal construct that rarely appears, but needs to be + //supported. ^M is a valid char reference (#13, in this case) + if CharInSet(FBuffer.Buf[FBuffer.Run], PointerChars) and not IsIdentifiers(FBuffer.Buf[FBuffer.Run+1]) then + begin + Inc(FBuffer.Run); + FTokenID := ptAsciiChar; + end; +end; + +procedure TmwBasePasLex.PointProc; +begin + case FBuffer.Buf[FBuffer.Run + 1] of + '.': + begin + Inc(FBuffer.Run, 2); + FTokenID := ptDotDot; + end; + ')': + begin + Inc(FBuffer.Run, 2); + FTokenID := ptSquareClose; + end; + else + begin + Inc(FBuffer.Run); + FTokenID := ptPoint; + end; + end; +end; + +procedure Delete(var values: TArray<string>; index: Integer); +var + len: Integer; + tailCount: Integer; +begin + len := Length(values); + if len = 0 then + Exit; + values[index] := ''; + tailCount := len - (index + 1); + if tailCount > 0 then + Move(values[index + 1], values[index], SizeOf(string) * tailCount); + Pointer(values[len - 1]) := nil; // do not trigger string refcounting as we moved it + SetLength(values, len - 1); +end; + +procedure TmwBasePasLex.RemoveDefine(const ADefine: string); +var + i: Integer; +begin + for i := High(FDefines) downto 0 do + if SameText(FDefines[i], ADefine) then + Delete(FDefines, i); +end; + +procedure TmwBasePasLex.RoundCloseProc; +begin + Inc(FBuffer.Run); + FTokenID := ptRoundClose; +end; + +procedure TmwBasePasLex.AnsiProc; +var + BeginRun: Integer; + CommentText: string; +begin + FTokenID := ptAnsiComment; + case FBuffer.Buf[FBuffer.Run] of + #0: + begin + NullProc; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unexpected file end', PosXY.X, PosXY.Y); + Exit; + end; + end; + + BeginRun := FBuffer.Run + 1; + + while FBuffer.Buf[FBuffer.Run] <> #0 do + case FBuffer.Buf[FBuffer.Run] of + '*': + if FBuffer.Buf[FBuffer.Run + 1] = ')' then + begin + FCommentState := csNo; + Inc(FBuffer.Run, 2); + Break; + end + else Inc(FBuffer.Run); + #10: + begin + Inc(FLineSeq); + Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + #13: + begin + Inc(FLineSeq); + Inc(FBuffer.Run); + if FBuffer.Buf[FBuffer.Run] = #10 then Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + else + Inc(FBuffer.Run); + end; + + if Assigned(FOnComment) then + begin + SetString(CommentText, PChar(@FBuffer.Buf[BeginRun]), FBuffer.Run - BeginRun - 2); + DoOnComment(CommentText); + end; +end; + +procedure TmwBasePasLex.RoundOpenProc; +var + BeginRun: Integer; + CommentText: string; +begin + BeginRun := FBuffer.Run + 2; + Inc(FBuffer.Run); + case FBuffer.Buf[FBuffer.Run] of + '*': + begin + FTokenID := ptAnsiComment; + if FBuffer.Buf[FBuffer.Run + 1] = '$' then + FTokenID := GetDirectiveKind + else + FCommentState := csAnsi; + Inc(FBuffer.Run); + while FBuffer.Buf[FBuffer.Run] <> #0 do + case FBuffer.Buf[FBuffer.Run] of + '*': + if FBuffer.Buf[FBuffer.Run + 1] = ')' then + begin + FCommentState := csNo; + Inc(FBuffer.Run, 2); + Break; + end + else + Inc(FBuffer.Run); + #10: + begin + Inc(FLineSeq); + Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + #13: + begin + Inc(FLineSeq); + Inc(FBuffer.Run); + if FBuffer.Buf[FBuffer.Run] = #10 then Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + else + Inc(FBuffer.Run); + end; + end; + '.': + begin + Inc(FBuffer.Run); + FTokenID := ptSquareOpen; + end; + else + FTokenID := ptRoundOpen; + end; + case FTokenID of + PtAnsiComment: + begin + if Assigned(FOnComment) then + begin + SetString(CommentText, PChar(@FBuffer.Buf[BeginRun]), FBuffer.Run - BeginRun - 2); + DoOnComment(CommentText); + end; + end; + PtCompDirect: + begin + if Assigned(FOnCompDirect) then + FOnCompDirect(Self); + end; + PtDefineDirect: + begin + if Assigned(FOnDefineDirect) then + FOnDefineDirect(Self); + end; + PtElseDirect: + begin + if Assigned(FOnElseDirect) then + FOnElseDirect(Self); + end; + PtEndIfDirect: + begin + if Assigned(FOnEndIfDirect) then + FOnEndIfDirect(Self); + end; + PtIfDefDirect: + begin + if Assigned(FOnIfDefDirect) then + FOnIfDefDirect(Self); + end; + PtIfNDefDirect: + begin + if Assigned(FOnIfNDefDirect) then + FOnIfNDefDirect(Self); + end; + PtIfOptDirect: + begin + if Assigned(FOnIfOptDirect) then + FOnIfOptDirect(Self); + end; + PtIncludeDirect: + begin + if Assigned(FIncludeHandler) then + IncludeFile; + end; + PtResourceDirect: + begin + if Assigned(FOnResourceDirect) then + FOnResourceDirect(Self); + end; + PtScopedEnumsDirect: + begin + UpdateScopedEnums; + end; + PtUndefDirect: + begin + if Assigned(FOnUnDefDirect) then + FOnUnDefDirect(Self); + end; + end; +end; + +procedure TmwBasePasLex.SemiColonProc; +begin + Inc(FBuffer.Run); + FTokenID := ptSemiColon; +end; + +procedure TmwBasePasLex.SlashProc; +var + BeginRun: Integer; + CommentText: string; +begin + case FBuffer.Buf[FBuffer.Run + 1] of + '/': + begin + Inc(FBuffer.Run, 2); + + BeginRun := FBuffer.Run; + + FTokenID := ptSlashesComment; + while FBuffer.Buf[FBuffer.Run] <> #0 do + begin + case FBuffer.Buf[FBuffer.Run] of + #10, #13: Break; + end; + Inc(FBuffer.Run); + end; + + if Assigned(FOnComment) then + begin + SetString(CommentText, PChar(@FBuffer.Buf[BeginRun]), FBuffer.Run - BeginRun); + DoOnComment(CommentText); + end; + end; + else + begin + Inc(FBuffer.Run); + FTokenID := ptSlash; + end; + end; +end; + +procedure TmwBasePasLex.SpaceProc; +begin + Inc(FBuffer.Run); + FTokenID := ptSpace; + while CharInSet(FBuffer.Buf[FBuffer.Run], [#1..#9, #11, #12, #14..#32]) do + Inc(FBuffer.Run); +end; + +procedure TmwBasePasLex.SquareCloseProc; +begin + Inc(FBuffer.Run); + FTokenID := ptSquareClose; +end; + +procedure TmwBasePasLex.SquareOpenProc; +begin + Inc(FBuffer.Run); + FTokenID := ptSquareOpen; +end; + +procedure TmwBasePasLex.StarProc; +begin + Inc(FBuffer.Run); + FTokenID := ptStar; +end; + +procedure TmwBasePasLex.StringProc; +var + StartQuoteCount, EndQuoteCount: Integer; + NewLine: Boolean; +begin + FTokenID := ptStringConst; + + StartQuoteCount := 0; + while FBuffer.Buf[FBuffer.Run] = #39 do + begin + StartQuoteCount := StartQuoteCount + 1; + Inc(FBuffer.Run); + end; + + if StartQuoteCount mod 2 = 0 then + Exit; + + if (StartQuoteCount > 1) and ((FBuffer.Buf[FBuffer.Run] = #10) or (FBuffer.Buf[FBuffer.Run] = #13)) then + begin // multiline string + NewLine := False; + repeat + case FBuffer.Buf[FBuffer.Run] of + #10: + begin + NewLine := True; + Inc(FLineSeq); + Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + #13: + begin + NewLine := True; + Inc(FLineSeq); + Inc(FBuffer.Run); + if FBuffer.Buf[FBuffer.Run] = #10 then Inc(FBuffer.Run); + Inc(FBuffer.LineNumber); + FBuffer.LinePos := FBuffer.Run; + end; + #0: + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unterminated string', PosXY.X, PosXY.Y); + Break; + end; + #39: + begin + EndQuoteCount := 0; + while (FBuffer.Buf[FBuffer.Run] = #39) do + begin + Inc(EndQuoteCount); + Inc(FBuffer.Run); + end; + if EndQuoteCount = StartQuoteCount then + begin + if not NewLine and Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Non-whitespace characters before closing quotes', PosXY.X, PosXY.Y); + Break; + end; + NewLine := False; + end; + else + if NewLine and (FBuffer.Buf[FBuffer.Run] <> #9) and (FBuffer.Buf[FBuffer.Run] <> #32) then + NewLine := False; + end; + Inc(FBuffer.Run); + until False; + end + else + begin // singleline string + repeat + Inc(FBuffer.Run); + case FBuffer.Buf[FBuffer.Run] of + #0, #10, #13: + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unterminated string', PosXY.X, PosXY.Y); + Break; + end; + #39: + begin + while (FBuffer.Buf[FBuffer.Run] = #39) and (FBuffer.Buf[FBuffer.Run + 1] = #39) do + begin + Inc(FBuffer.Run, 2); + end; + end; + end; + until FBuffer.Buf[FBuffer.Run] = #39; + if FBuffer.Buf[FBuffer.Run] = #39 then + begin + Inc(FBuffer.Run); + if TokenLen = 3 then + begin + FTokenID := ptAsciiChar; + end; + end; + end; +end; + +procedure TmwBasePasLex.SymbolProc; +begin + Inc(FBuffer.Run); + FTokenID := ptSymbol; +end; + +procedure TmwBasePasLex.UnknownProc; +begin + Inc(FBuffer.Run); + FTokenID := ptUnknown; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unknown Character', PosXY.X, PosXY.Y); +end; + +procedure TmwBasePasLex.Next; +begin + FExID := ptUnKnown; + FTokenPos := FBuffer.Run; + FTokenLine := FBuffer.LineNumber; + FTokenLinePos := FBuffer.LinePos; + case FCommentState of + csNo: DoProcTable(FBuffer.Buf[FBuffer.Run]); + csBor: BorProc; + csAnsi: AnsiProc; + end; +end; + +function TmwBasePasLex.GetIsJunk: Boolean; +begin + Result := IsTokenIDJunk(FTokenID) or (FUseDefines and (FDefineStack > 0) and (TokenID <> ptNull)); +end; + +function TmwBasePasLex.GetIsSpace: Boolean; +begin + Result := FTokenID in [ptCRLF, ptSpace]; +end; + +function TmwBasePasLex.GetToken: string; +begin + SetString(Result, FBuffer.Buf + FTokenPos, TokenLen); +end; + +function TmwBasePasLex.GetTokenLen: Integer; +begin + Result := FBuffer.Run - FTokenPos; +end; + +procedure TmwBasePasLex.NextNoJunk; +begin + repeat + Next; + until not IsJunk; +end; + +procedure TmwBasePasLex.NextNoSpace; +begin + repeat + Next; + until not IsSpace; +end; + +function TmwBasePasLex.FirstInLine: Boolean; +var + RunBack: Integer; +begin + Result := True; + if FTokenPos = 0 then Exit; + RunBack := FTokenPos; + Dec(RunBack); + while CharInSet(FBuffer.Buf[RunBack], [#1..#9, #11, #12, #14..#32]) do + Dec(RunBack); + if RunBack = 0 then Exit; + case FBuffer.Buf[RunBack] of + #10, #13: Exit; + else + begin + Result := False; + Exit; + end; + end; +end; + +function TmwBasePasLex.GetCompilerDirective: string; +var + DirectLen: Integer; +begin + if TokenID <> ptCompDirect then + Result := '' + else + case FBuffer.Buf[FTokenPos] of + '(': + begin + DirectLen := FBuffer.Run - FTokenPos - 4; + SetString(Result, (FBuffer.Buf + FTokenPos + 2), DirectLen); + Result := UpperCase(Result); + end; + '{': + begin + DirectLen := FBuffer.Run - FTokenPos - 2; + SetString(Result, (FBuffer.Buf + FTokenPos + 1), DirectLen); + Result := UpperCase(Result); + end; + end; +end; + +function TmwBasePasLex.GetDirectiveKind: TptTokenKind; +var + TempPos: Integer; +begin + case FBuffer.Buf[FTokenPos] of + '(': FBuffer.Run := FTokenPos + 3; + '{': FBuffer.Run := FTokenPos + 2; + end; + FDirectiveParamOrigin := FBuffer.Buf + FTokenPos; + TempPos := FTokenPos; + FTokenPos := FBuffer.Run; + case KeyHash of + 9: + if KeyComp('I') and (not CharInSet(FBuffer.Buf[FBuffer.Run], ['+', '-'])) then + Result := ptIncludeDirect else + Result := ptCompDirect; + 15: + if KeyComp('IF') then + Result := ptIfDirect else + Result := ptCompDirect; + 18: + if KeyComp('R') then + begin + if not CharInSet(FBuffer.Buf[FBuffer.Run], ['+', '-']) then + Result := ptResourceDirect else Result := ptCompDirect; + end else Result := ptCompDirect; + 30: + if KeyComp('IFDEF') then + Result := ptIfDefDirect else + Result := ptCompDirect; + 38: + if KeyComp('ENDIF') then + Result := ptEndIfDirect else + if KeyComp('IFEND') then + Result := ptIfEndDirect else + Result := ptCompDirect; + 41: + if KeyComp('ELSE') then + Result := ptElseDirect else + Result := ptCompDirect; + 43: + if KeyComp('DEFINE') then + Result := ptDefineDirect else + Result := ptCompDirect; + 44: + if KeyComp('IFNDEF') then + Result := ptIfNDefDirect else + Result := ptCompDirect; + 50: + if KeyComp('UNDEF') then + Result := ptUndefDirect else + Result := ptCompDirect; + 56: + if KeyComp('ELSEIF') then + Result := ptElseIfDirect else + Result := ptCompDirect; + 66: + if KeyComp('IFOPT') then + Result := ptIfOptDirect else + Result := ptCompDirect; + 68: + if KeyComp('INCLUDE') then + Result := ptIncludeDirect else + Result := ptCompDirect; + 104: + if KeyComp('Resource') then + Result := ptResourceDirect else + Result := ptCompDirect; + 134: + if KeyComp('SCOPEDENUMS') then + Result := ptScopedEnumsDirect else + Result := ptCompDirect; + else Result := ptCompDirect; + end; + FTokenPos := TempPos; + Dec(FBuffer.Run); +end; + +function TmwBasePasLex.GetDirectiveParam: string; +var + EndPos: Integer; + ParamLen: Integer; +begin + case FBuffer.Buf[FTokenPos] of + '(': + begin + TempRun := FTokenPos + 3; + EndPos := FBuffer.Run - 2; + end; + '{': + begin + TempRun := FTokenPos + 2; + EndPos := FBuffer.Run - 1; + end; + else + EndPos := 0; + end; + while IsIdentifiers(FBuffer.Buf[TempRun]) do + Inc(TempRun); + while CharInSet(FBuffer.Buf[TempRun], ['+', ',', '-']) do + begin + Inc(TempRun); + while IsIdentifiers(FBuffer.Buf[TempRun]) do + Inc(TempRun); + if CharInSet(FBuffer.Buf[TempRun - 1], ['+', ',', '-']) and (FBuffer.Buf[TempRun] = ' ') + then Inc(TempRun); + end; + + while CharInSet(FBuffer.Buf[TempRun], [' ', #9]) do Inc(TempRun); + while CharInSet(FBuffer.Buf[EndPos - 1], [' ', #9]) do Dec(EndPos); + + ParamLen := EndPos - TempRun; + SetString(Result, (FBuffer.Buf + TempRun), ParamLen); + Result := UpperCase(Result); +end; + +function TmwBasePasLex.GetFileName: string; +begin + Result := FBuffer.FileName; +end; + +function TmwBasePasLex.GetIncludeFileNameFromToken(const IncludeToken: string): string; +var + FileNameStartPos, CurrentPos: integer; + TrimmedToken: string; + QuotedFileName: Boolean; +begin + TrimmedToken := Trim(IncludeToken); + CurrentPos := 1; + while TrimmedToken[CurrentPos] > #32 do + inc(CurrentPos); + while TrimmedToken[CurrentPos] <= #32 do + inc(CurrentPos); + QuotedFileName := TrimmedToken[CurrentPos] = ''''; + if QuotedFileName then + inc(CurrentPos); + FileNameStartPos := CurrentPos; + while (TrimmedToken[CurrentPos] <> '}') + and (TrimmedToken[CurrentPos] <> '''') + and ((TrimmedToken[CurrentPos] > #32) or QuotedFileName) + do + inc(CurrentPos); + + Result := Copy(TrimmedToken, FileNameStartPos, CurrentPos - FileNameStartPos); +end; + +procedure TmwBasePasLex.IncludeFile; +var + IncludeName, IncludeDirective, Content, FileName: string; + NewBuffer: PBufferRec; +begin + IncludeDirective := Token; + IncludeName := GetIncludeFileNameFromToken(IncludeDirective); + + if FIncludeHandler.GetIncludeFileContent(FBuffer.FileName, IncludeName, Content, FileName) then + begin + Content := Content + #13#10; + + New(NewBuffer); + NewBuffer.SharedBuffer := False; + NewBuffer.Next := FBuffer; + NewBuffer.LineNumber := 0; + NewBuffer.LinePos := 0; + NewBuffer.Run := 0; + NewBuffer.FileName := FileName; + GetMem(NewBuffer.Buf, (Length(Content) + 1) * SizeOf(Char)); + StrPCopy(NewBuffer.Buf, Content); + NewBuffer.Buf[Length(Content)] := #0; + + FBuffer := NewBuffer; + end; + + Next; +end; + +procedure TmwBasePasLex.Init; +begin + FCommentState := csNo; + FBuffer.LineNumber := 0; + FBuffer.LinePos := 0; + FBuffer.Run := 0; + FLineSeq := 0; +end; + +procedure TmwBasePasLex.InitFrom(ALexer: TmwBasePasLex); +begin + SetSharedBuffer(ALexer.FBuffer); + FCommentState := ALexer.FCommentState; + FScopedEnums := ALexer.ScopedEnums; + FBuffer.Run := ALexer.RunPos; + FTokenID := ALexer.TokenID; + FExID := ALexer.ExID; + CloneDefinesFrom(ALexer); +end; + +procedure TmwBasePasLex.InitDefinesDefinedByCompiler; +begin + //Set up the defines that are defined by the compiler + {$IFDEF VER90} + AddDefine('VER90'); // 2 + {$ENDIF} + {$IFDEF VER100} + AddDefine('VER100'); // 3 + {$ENDIF} + {$IFDEF VER120} + AddDefine('VER120'); // 4 + {$ENDIF} + {$IFDEF VER130} + AddDefine('VER130'); // 5 + {$ENDIF} + {$IFDEF VER140} // 6 + AddDefine('VER140'); + {$ENDIF} + {$IFDEF VER150} // 7/7.1 + AddDefine('VER150'); + {$ENDIF} + {$IFDEF VER160} // 8 + AddDefine('VER160'); + {$ENDIF} + {$IFDEF VER170} // 2005 + AddDefine('VER170'); + {$ENDIF} + {$IFDEF VER180} // 2007 + AddDefine('VER180'); + {$ENDIF} + {$IFDEF VER185} // 2007 + AddDefine('VER185'); + {$ENDIF} + {$IFDEF VER190} // 2007.NET + AddDefine('VER190'); + {$ENDIF} + {$IFDEF CONDITIONALEXPRESSIONS} + {$IF COMPILERVERSION > 19.0} + AddDefine('VER' + IntToStr(Round(10*CompilerVersion))); + {$IFEND} + {$ENDIF} + {$IFDEF WIN32} + AddDefine('WIN32'); + {$ENDIF} + {$IFDEF WIN64} + AddDefine('WIN64'); + {$ENDIF} + {$IFDEF LINUX} + AddDefine('LINUX'); + {$ENDIF} + {$IFDEF LINUX32} + AddDefine('LINUX32'); + {$ENDIF} + {$IFDEF LINUX64} + AddDefine('LINUX64'); + {$ENDIF} + {$IFDEF POSIX} + AddDefine('POSIX'); + {$ENDIF} + {$IFDEF POSIX32} + AddDefine('POSIX32'); + {$ENDIF} + {$IFDEF POSIX64} + AddDefine('POSIX64'); + {$ENDIF} + {$IFDEF CPUARM} + AddDefine('CPUARM'); + {$ENDIF} + {$IFDEF CPUARM32} + AddDefine('CPUARM32'); + {$ENDIF} + {$IFDEF CPUARM64} + AddDefine('CPUARM64'); + {$ENDIF} + {$IFDEF CPU386} + AddDefine('CPU386'); + {$ENDIF} + {$IFDEF CPUX86} + AddDefine('CPUX86'); + {$ENDIF} + {$IFDEF CPUX64} + AddDefine('CPUX64'); + {$ENDIF} + {$IFDEF CPU32BITS} + AddDefine('CPU32BITS'); + {$ENDIF} + {$IFDEF CPU64BITS} + AddDefine('CPU64BITS'); + {$ENDIF} + {$IFDEF MSWINDOWS} + AddDefine('MSWINDOWS'); + {$ENDIF} + {$IFDEF MACOS} + AddDefine('MACOS'); + {$ENDIF} + {$IFDEF MACOS32} + AddDefine('MACOS32'); + {$ENDIF} + {$IFDEF MACOS64} + AddDefine('MACOS64'); + {$ENDIF} + {$IFDEF IOS} + AddDefine('IOS'); + {$ENDIF} + {$IFDEF IOS32} + AddDefine('IOS32'); + {$ENDIF} + {$IFDEF IOS64} + AddDefine('IOS64'); + {$ENDIF} + {$IFDEF ANDROID} + AddDefine('ANDROID'); + {$ENDIF} + {$IFDEF ANDROID32} + AddDefine('ANDROID32'); + {$ENDIF} + {$IFDEF ANDROID64} + AddDefine('ANDROID64'); + {$ENDIF} + {$IFDEF CONSOLE} + AddDefine('CONSOLE'); + {$ENDIF} + {$IFDEF NATIVECODE} + AddDefine('NATIVECODE'); + {$ENDIF} + {$IFDEF CONDITIONALEXPRESSIONS} + AddDefine('CONDITIONALEXPRESSIONS'); + {$ENDIF} + {$IFDEF UNICODE} + AddDefine('UNICODE'); + {$ENDIF} + {$IFDEF ALIGN_STACK} + AddDefine('ALIGN_STACK'); + {$ENDIF} + {$IFDEF ARM_NO_VFP_USE} + AddDefine('ARM_NO_VFP_USE'); + {$ENDIF} + {$IFDEF ASSEMBLER} + AddDefine('ASSEMBLER'); + {$ENDIF} + {$IFDEF AUTOREFCOUNT} + AddDefine('AUTOREFCOUNT'); + {$ENDIF} + {$IFDEF EXTERNALLINKER} + AddDefine('EXTERNALLINKER'); + {$ENDIF} + {$IFDEF ELF} + AddDefine('ELF'); + {$ENDIF} + {$IFDEF NEXTGEN} + AddDefine('NEXTGEN'); + {$ENDIF} + {$IFDEF PC_MAPPED_EXCEPTIONS} + AddDefine('PC_MAPPED_EXCEPTIONS'); + {$ENDIF} + {$IFDEF PIC} + AddDefine('PIC'); + {$ENDIF} + {$IFDEF UNDERSCOREIMPORTNAME} + AddDefine('UNDERSCOREIMPORTNAME'); + {$ENDIF} + {$IFDEF WEAKREF} + AddDefine('WEAKREF'); + {$ENDIF} + {$IFDEF WEAKINSTREF} + AddDefine('WEAKINSTREF'); + {$ENDIF} + {$IFDEF WEAKINTFREF} + AddDefine('WEAKINTFREF'); + {$ENDIF} +end; + +function TmwBasePasLex.GetStringContent: string; +var + TempString: string; + sEnd: Integer; +begin + if TokenID <> ptStringConst then + Result := '' + else + begin + TempString := Token; + sEnd := Length(TempString); + if TempString[sEnd] <> #39 then Inc(sEnd); + Result := Copy(TempString, 2, sEnd - 2); + TempString := ''; + end; +end; + +function TmwBasePasLex.GetIsOrdIdent: Boolean; +begin + if FTokenID = ptIdentifier then + Result := FExID in [ptBoolean, ptByte, ptChar, ptDWord, ptInt64, ptInteger, + ptLongInt, ptLongWord, ptPChar, ptShortInt, ptSmallInt, ptWideChar, ptWord] + else + Result := False; +end; + +function TmwBasePasLex.GetIsOrdinalType: Boolean; +begin + Result := GetIsOrdIdent or (FTokenID in [ptAsciiChar, ptIntegerConst]); +end; + +function TmwBasePasLex.GetIsRealType: Boolean; +begin + if FTokenID = ptIdentifier then + Result := FExID in [ptComp, ptCurrency, ptDouble, ptExtended, ptReal, ptReal48, ptSingle] + else + Result := False; +end; + +function TmwBasePasLex.GetIsStringType: Boolean; +begin + if FTokenID = ptIdentifier then + Result := FExID in [ptAnsiString, ptWideString] + else + Result := FTokenID in [ptString, ptStringConst]; +end; + +function TmwBasePasLex.GetIsVariantType: Boolean; +begin + if FTokenID = ptIdentifier then + Result := FExID in [ptOleVariant, ptVariant] + else + Result := False; +end; + +function TmwBasePasLex.GetOrigin: string; +begin + Result := FBuffer.Buf; +end; + +function TmwBasePasLex.GetIsAddOperator: Boolean; +begin + Result := FTokenID in [ptMinus, ptOr, ptPlus, ptXor]; +end; + +function TmwBasePasLex.GetIsMulOperator: Boolean; +begin + Result := FTokenID in [ptAnd, ptAs, ptDiv, ptMod, ptShl, ptShr, ptSlash, ptStar]; +end; + +function TmwBasePasLex.GetIsRelativeOperator: Boolean; +begin + Result := FTokenID in [ptAs, ptEqual, ptGreater, ptGreaterEqual, ptLower, ptLowerEqual, + ptIn, ptIs, ptNotEqual]; +end; + +function TmwBasePasLex.GetIsCompilerDirective: Boolean; +begin + Result := FTokenID in [ptCompDirect, ptDefineDirect, ptElseDirect, + ptEndIfDirect, ptIfDefDirect, ptIfNDefDirect, ptIfOptDirect, + ptIncludeDirect, ptResourceDirect, ptScopedEnumsDirect, ptUndefDirect]; +end; + +function TmwBasePasLex.GetGenID: TptTokenKind; +begin + Result := FTokenID; + if FTokenID = ptIdentifier then + if FExID <> ptUnknown then Result := FExID; +end; + +{ TmwPasLex } + +constructor TmwPasLex.Create; +begin + inherited Create; + FAheadLex := TmwBasePasLex.Create; +end; + +destructor TmwPasLex.Destroy; +begin + FAheadLex.Free; + inherited Destroy; +end; + +procedure TmwPasLex.AheadNext; +begin + FAheadLex.NextNoJunk; +end; + +function TmwPasLex.GetAheadExID: TptTokenKind; +begin + Result := FAheadLex.ExID; +end; + +function TmwPasLex.GetAheadGenID: TptTokenKind; +begin + Result := FAheadLex.GenID; +end; + +function TmwPasLex.GetAheadToken: string; +begin + Result := FAheadLex.Token; +end; + +function TmwPasLex.GetAheadTokenID: TptTokenKind; +begin + Result := FAheadLex.TokenID; +end; + +procedure TmwPasLex.InitAhead; +begin + FAheadLex.FCommentState := FCommentState; + FAheadLex.CloneDefinesFrom(Self); + + FAheadLex.SetSharedBuffer(FBuffer); + + while FAheadLex.IsJunk do + FAheadLex.Next; +end; + +procedure TmwPasLex.SetOrigin(const NewValue: string); +begin + inherited SetOrigin(NewValue); + FAheadLex.SetSharedBuffer(FBuffer); +end; + +function TmwBasePasLex.Func86: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Varargs') then FExID := ptVarargs; +end; + +procedure TmwBasePasLex.StringDQProc; +begin + if not FAsmCode then + begin + SymbolProc; + Exit; + end; + FTokenID := ptStringDQConst; + repeat + Inc(FBuffer.Run); + case FBuffer.Buf[FBuffer.Run] of + #0, #10, #13: + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unterminated string', PosXY.X, PosXY.Y); + Break; + end; + '\': + begin + Inc(FBuffer.Run); + if CharInSet(FBuffer.Buf[FBuffer.Run], [#32..#127]) then Inc(FBuffer.Run); + end; + end; + until FBuffer.Buf[FBuffer.Run] = '"'; + if FBuffer.Buf[FBuffer.Run] = '"' then + Inc(FBuffer.Run); +end; + +procedure TmwBasePasLex.AmpersandOpProc; +begin + FTokenID := ptAmpersand; + Inc(FBuffer.Run); + while CharInSet(FBuffer.Buf[FBuffer.Run], ['a'..'z', 'A'..'Z','0'..'9', '_', '&']) do + Inc(FBuffer.Run); + FTokenID := ptIdentifier; +end; + +procedure TmwBasePasLex.UpdateScopedEnums; +begin + FScopedEnums := SameText(DirectiveParam, 'ON'); +end; + +initialization + MakeIdentTable; +end. diff --git a/References/DelphiAST/Source/SimpleParser/SimpleParser.Types.pas b/References/DelphiAST/Source/SimpleParser/SimpleParser.Types.pas new file mode 100644 index 000000000..f365251f2 --- /dev/null +++ b/References/DelphiAST/Source/SimpleParser/SimpleParser.Types.pas @@ -0,0 +1,330 @@ +{--------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License Version +1.1 (the "License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at +http://www.mozilla.org/NPL/NPL-1_1Final.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: mwSimplePasParTypes, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +unit CastaliaPasLexTypes; + +----------------------------------------------------------------------------} + +unit SimpleParser.Types; + +interface + +uses + SysUtils, + TypInfo; + +type + TmwParseError = ( + InvalidAdditiveOperator, + InvalidAccessSpecifier, + InvalidCharString, + InvalidClassMethodHeading, + InvalidConstantDeclaration, + InvalidConstSection, + InvalidDeclarationSection, + InvalidDirective16Bit, + InvalidDirectiveBinding, + InvalidDirectiveCalling, + InvalidExportedHeading, + InvalidForStatement, + InvalidInitializationSection, + InvalidInterfaceDeclaration, + InvalidInterfaceType, + InvalidLabelId, + InvalidLabeledStatement, + InvalidMethodHeading, + InvalidMultiplicativeOperator, + InvalidNumber, + InvalidOrdinalIdentifier, + InvalidParameter, + InvalidParseFile, + InvalidProceduralDirective, + InvalidProceduralType, + InvalidProcedureDeclarationSection, + InvalidProcedureMethodDeclaration, + InvalidRealIdentifier, + InvalidRelativeOperator, + InvalidStorageSpecifier, + InvalidStringIdentifier, + InvalidStructuredType, + InvalidTryStatement, + InvalidTypeKind, + InvalidVariantIdentifier, + InvalidVarSection, + vchInvalidClass, + vchInvalidMethod, + vchInvalidProcedure, + vchInvalidCircuit, + vchInvalidIncludeFile + ); + + TmwPasCodeInfo = ( + ciNone, + ciAccessSpecifier, + ciAdditiveOperator, + ciArrayConstant, + ciArrayType, + ciAsmStatement, + ciBlock, + ciCaseLabel, + ciCaseSelector, + ciCaseStatement, + ciCharString, + ciClassClass, + ciClassField, + ciClassForward, + ciClassFunctionHeading, + ciClassHeritage, + ciClassMemberList, + ciClassMethodDirective, + ciClassMethodHeading, + ciClassMethodOrProperty, + ciClassMethodResolution, + ciClassProcedureHeading, + ciClassProperty, + ciClassReferenceType, + ciClassType, + ciClassTypeEnd, + ciClassVisibility, + ciCompoundStatement, + ciConstantColon, + ciConstantDeclaration, + ciConstantEqual, + ciConstantExpression, + ciConstantName, + ciConstantValue, + ciConstantValueTyped, + ciConstParameter, + ciConstructorHeading, + ciConstructorName, + ciConstSection, + ciContainsClause, + ciContainsExpression, + ciContainsIdentifier, + ciContainsStatement, + ciDeclarationSection, + ciDesignator, + ciDestructorHeading, + ciDestructorName, + ciDirective16Bit, + ciDirectiveBinding, + ciDirectiveCalling, + ciDirectiveDeprecated, + ciDirectiveLibrary, + ciDirectiveLocal, + ciDirectivePlatform, + ciDirectiveVarargs, + ciDispIDSpecifier, + ciDispInterfaceForward, + ciEmptyStatement, + ciEnumeratedType, + ciEnumeratedTypeItem, + ciExceptBlock, + ciExceptionBlockElseBranch, + ciExceptionClassTypeIdentifier, + ciExceptionHandler, + ciExceptionHandlerList, + ciExceptionIdentifier, + ciExceptionVariable, + ciExpliciteType, + ciExportedHeading, + ciExportsClause, + ciExportsElement, + ciExpression, + ciExpressionList, + ciExternalDirective, + ciExternalDirectiveThree, + ciExternalDirectiveTwo, + ciFactor, + ciFieldDeclaration, + ciFieldList, + ciFileType, + ciFormalParameterList, + ciFormalParameterSection, + ciForStatement, + ciForwardDeclaration, + ciFunctionHeading, + ciFunctionMethodDeclaration, + ciFunctionMethodName, + ciFunctionProcedureBlock, + ciFunctionProcedureName, + ciHandlePtCompDirect, + ciHandlePtDefineDirect, + ciHandlePtElseDirect, + ciHandlePtIfDefDirect, + ciHandlePtEndIfDirect, + ciHandlePtIfNDefDirect, + ciHandlePtIfOptDirect, + ciHandlePtIncludeDirect, + ciHandlePtResourceDirect, + ciHandlePtUndefDirect, + ciIdentifier, + ciIdentifierList, + ciIfStatement, + ciImplementationSection, + ciIncludeFile, + ciIndexSpecifier, + ciInheritedStatement, + ciInitializationSection, + ciInlineStatement, + ciInterfaceDeclaration, + ciInterfaceForward, + ciInterfaceGUID, + ciInterfaceHeritage, + ciInterfaceMemberList, + ciInterfaceSection, + ciInterfaceType, + ciLabelDeclarationSection, + ciLabeledStatement, + ciLabelId, + ciLibraryFile, + ciMainUsedUnitExpression, + ciMainUsedUnitName, + ciMainUsedUnitStatement, + ciMainUsesClause, + ciMultiplicativeOperator, + ciNewFormalParameterType, + ciNumber, + ciNextToken, + ciObjectConstructorHeading, + ciObjectDestructorHeading, + ciObjectField, + ciObjectForward, + ciObjectFunctionHeading, + ciObjectHeritage, + ciObjectMemberList, + ciObjectMethodDirective, + ciObjectMethodHeading, + ciObjectNameOfMethod, + ciObjectProcedureHeading, + ciObjectProperty, + ciObjectPropertySpecifiers, + ciObjectType, + ciObjectTypeEnd, + ciObjectVisibility, + ciOldFormalParameterType, + ciOrdinalIdentifier, + ciOrdinalType, + ciOutParameter, + ciPackageFile, + ciParameterFormal, + ciParameterName, + ciParameterNameList, + ciParseFile, + ciPointerType, + ciProceduralDirective, + ciProceduralType, + ciProcedureDeclarationSection, + ciProcedureHeading, + ciProcedureMethodDeclaration, + ciProcedureMethodName, + ciProgramBlock, + ciProgramFile, + ciPropertyDefault, + ciPropertyInterface, + ciPropertyName, + ciPropertyParameterConst, + ciPropertyParameterList, + ciPropertySpecifiers, + ciQualifiedIdentifier, + ciQualifiedIdentifierList, + ciRaiseStatement, + ciReadAccessIdentifier, + ciRealIdentifier, + ciRealType, + ciRecordConstant, + ciRecordFieldConstant, + ciRecordType, + ciRecordVariant, + ciRelativeOperator, + ciRepeatStatement, + ciRequiresClause, + ciRequiresIdentifier, + ciResolutionInterfaceName, + ciResourceDeclaration, + ciReturnType, + ciSEMICOLON, + ciSetConstructor, + ciSetElement, + ciSetType, + ciSimpleExpression, + ciSimpleStatement, + ciSimpleType, + ciSkipAnsiComment, + ciSkipBorComment, + ciSkipSlashesComment, + ciSkipSpace, + ciSkipCRLFco, + ciSkipCRLF, + ciStatement, + ciStatementList, + ciStorageExpression, + ciStorageIdentifier, + ciStorageDefault, + ciStorageNoDefault, + ciStorageSpecifier, + ciStorageStored, + ciStringIdentifier, + ciStringStatement, + ciStringType, + ciStructuredType, + ciSubrangeType, + ciTagField, + ciTagFieldName, + ciTagFieldTypeName, + ciTerm, + ciTryStatement, + ciTypedConstant, + ciTypeDeclaration, + ciTypeId, + ciTypeKind, + ciTypeName, + ciTypeSection, + ciUnitFile, + ciUnitId, + ciUsedUnitName, + ciUsedUnitsList, + ciUsesClause, + ciVarAbsolute, + ciVarEqual, + ciVarDeclaration, + ciVariable, + ciVariableList, + ciVariableReference, + ciVariableTwo, + ciVariantIdentifier, + ciVariantSection, + ciVarParameter, + ciVarSection, + ciVisibilityAutomated, + ciVisibilityPrivate, + ciVisibilityProtected, + ciVisibilityPublic, + ciVisibilityPublished, + ciVisibilityUnknown, + ciWhileStatement, + ciWithStatement, + ciWriteAccessIdentifier + ); + +function ParserErrorName(Value: TmwParseError): string; + +implementation + +function ParserErrorName(Value: TmwParseError): string; +begin + result := GetEnumName(TypeInfo(TmwParseError), Integer(Value)); +end; + +end. + diff --git a/References/DelphiAST/Source/SimpleParser/SimpleParser.inc b/References/DelphiAST/Source/SimpleParser/SimpleParser.inc new file mode 100644 index 000000000..136e6c0a6 --- /dev/null +++ b/References/DelphiAST/Source/SimpleParser/SimpleParser.inc @@ -0,0 +1,332 @@ +{$IFDEF VER370} // Delphi 13 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} + {$DEFINE D23_NEWER} + {$DEFINE D24_NEWER} + {$DEFINE D25_NEWER} + {$DEFINE D26_NEWER} + {$DEFINE D27_NEWER} + {$DEFINE D28_NEWER} + {$DEFINE D29_NEWER} + {$DEFINE D37_NEWER} +{$ENDIF} + +{$IFDEF VER360} // Delphi 12 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} + {$DEFINE D23_NEWER} + {$DEFINE D24_NEWER} + {$DEFINE D25_NEWER} + {$DEFINE D26_NEWER} + {$DEFINE D27_NEWER} + {$DEFINE D28_NEWER} + {$DEFINE D29_NEWER} +{$ENDIF} + +{$IFDEF VER350} // Delphi 11 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} + {$DEFINE D23_NEWER} + {$DEFINE D24_NEWER} + {$DEFINE D25_NEWER} + {$DEFINE D26_NEWER} + {$DEFINE D27_NEWER} + {$DEFINE D28_NEWER} +{$ENDIF} + +{$IFDEF VER340} // Delphi 10.4 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} + {$DEFINE D23_NEWER} + {$DEFINE D24_NEWER} + {$DEFINE D25_NEWER} + {$DEFINE D26_NEWER} + {$DEFINE D27_NEWER} +{$ENDIF} + +{$IFDEF VER330} // Delphi 10.3 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} + {$DEFINE D23_NEWER} + {$DEFINE D24_NEWER} + {$DEFINE D25_NEWER} + {$DEFINE D26_NEWER} +{$ENDIF} + +{$IFDEF VER320} // Delphi 10 Tokyo + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} + {$DEFINE D23_NEWER} + {$DEFINE D24_NEWER} + {$DEFINE D25_NEWER} +{$ENDIF} + +{$IFDEF VER310} // Delphi 10 Berlin + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} + {$DEFINE D23_NEWER} + {$DEFINE D24_NEWER} +{$ENDIF} + +{$IFDEF VER300} // Delphi 10 Seattle + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} + {$DEFINE D23_NEWER} +{$ENDIF} + +{$IFDEF VER290} // Delphi XE8 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} + {$DEFINE D22_NEWER} +{$ENDIF} + +{$IFDEF VER280} // Delphi XE7 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} + {$DEFINE D21_NEWER} +{$ENDIF} + +{$IFDEF VER270} // Delphi XE6 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} + {$DEFINE D20_NEWER} +{$ENDIF} + +{$IFDEF VER260} // Delphi XE5 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} + {$DEFINE D19_NEWER} +{$ENDIF} + +{$IFDEF VER250} // Delphi XE4 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} + {$DEFINE D18_NEWER} +{$ENDIF} + +{$IFDEF VER240} // Delphi XE3 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} + {$DEFINE D17_NEWER} +{$ENDIF} + +{$IFDEF VER230} // Delphi XE2 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} + {$DEFINE D16_NEWER} +{$ENDIF} + +{$IFDEF VER220} // Delphi XE + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} + {$DEFINE D15_NEWER} +{$ENDIF} + +{$IFDEF VER210} // Delphi 2010 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} + {$DEFINE D14_NEWER} +{$ENDIF} + +{$IFDEF VER200} // Delphi 2009 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} +{$ENDIF} + +{$IFDEF VER190} // Delphi 2007 .NET + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} +{$ENDIF} + +{$IFDEF VER185} // Delphi 2007 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} +{$ENDIF} + +{$IFDEF VER180} // Delphi 2006 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} +{$ENDIF} + +{$IFDEF VER170} // Delphi 2005 + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} +{$ENDIF} + +{$IFDEF VER160} // Delphi 8 + {$DEFINE D8_NEWER} +{$ENDIF} + +{$IFDEF D18_NEWER} + {$DEFINE SUPPORTS_INTRINSIC_HELPERS} +{$ENDIF} + +{$IFNDEF D16_NEWER} + {$DEFINE CPUX86} +{$ENDIF} diff --git a/References/DelphiAST/Source/SimpleParser/SimpleParser.pas b/References/DelphiAST/Source/SimpleParser/SimpleParser.pas new file mode 100644 index 000000000..d7efd2cb0 --- /dev/null +++ b/References/DelphiAST/Source/SimpleParser/SimpleParser.pas @@ -0,0 +1,5918 @@ +{--------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License Version +1.1 (the "License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at +http://www.mozilla.org/NPL/NPL-1_1Final.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: mwSimplePasPar.pas, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +(Martin.Waldenburg@T-Online.de). +Portions created by Martin Waldenburg are Copyright (C) 1998, 1999 Martin +Waldenburg. +All Rights Reserved. +Portions CopyRight by Robert Zierer. + +Contributor(s): Vladimir Churbanov, Dean Hill, James Jacobson, LaKraven Studios Ltd, Roman Yankovsky +(This list is ALPHABETICAL) + +Last Modified: 2014/09/14 +Current Version: 1.10 + +Notes: This program is an early beginning of a Pascal parser. +I'd like to invite the Delphi community to develop it further and to create +a fully featured Object Pascal parser. + +Modification history: + +LaKraven Studios Ltd, January 2015: + +- Cleaned up version-specifics up to XE8 +- Fixed all warnings & hints + +Jacob Thurman between 20040301 and 20020401 + +Made ready for Delphi 8: + +Added new directives and keywords: static, sealed, final, operator, unsafe. + +Added parsing for custom attributes (based on ECMA C# specification). + +Added support for nested types in class declarations. + +Jeff Rafter between 20020116 and 20020302 + +Added AncestorId and AncestorIdList back in, but now treat them as Qualified +Identifiers per Daniel Rolf's fix. The separation from QualifiedIdentifierList +is need for descendent classes. + +Added VarName and VarNameList back in for descendent classes, fixed to correctly +use Identifiers as in Daniel's verison + +Removed fInJunk flags (they were never used, only set) + +Pruned uses clause to remove windows dependency. This required changing +"TPoint" to "TTokenPoint". TTokenPoint was declared in mwPasLexTypes + +Daniel Rolf between 20010723 and 20020116 + +Made ready for Delphi 6 + +ciClassClass for "class function" etc. +ciClassTypeEnd marks end of a class declaration (I needed that for the delphi-objectif-connector) +ciEnumeratedTypeItem for items of enumerations +ciDirectiveXXX for the platform, deprecated, varargs, local +ciForwardDeclaration for "forward" (until now it has been read but no event) +ciIndexSpecifier for properties +ciObjectTypeEnd marks end of an object declaration +ciObjectProperty property for objects +ciObjectPropertySpecifiers property for objects +ciPropertyDefault marking default of property +ciDispIDSpecifier for dispid + +patched some functions for implementing the above things and patching the following bugs/improv.: + +ObjectProperty handling overriden properties +ProgramFile, UnitFile getting Identifier instead of dropping it +InterfaceHeritage: Qualified identifiers +bugs in variant records +typedconstant failed with complex set constants. simple patch using ConstantExpression + +German localization for the two string constants. Define GERMAN for german string constants. + +Greg Chapman on 20010522 +Better handling of defaut array property +Separate handling of X and Y in property Pixels[X, Y: Integer through identifier "event" +corrected spelling of "ForwardDeclaration" + +James Jacobson on 20010223 +semi colon before finalization fix + +James Jacobson on 20010223 +RecordConstant Fix + +Martin waldenburg on 2000107 +Even Faster lexer implementation !!!! + +James Jacobson on 20010107 + Improper handling of the construct + property TheName: Integer read FTheRecord.One.Two; (stop at second point) + where one and two are "qualifiable" structures. + +James Jacobson on 20001221 + Stops at the second const. + property Anchor[const Section: string; const Ident:string]: string read + changed TmwSimplePasPar.PropertyParameterList + +On behalf of Martin Waldenburg and James Jacobson + Correction in array property Handling (Matin and James) 07/12/2000 + Use of ExId instead of TokenId in ExportsElements (James) 07/12/2000 + Reverting to old behavior in Statementlist [PtintegerConst put back in] (James) 07/12/2000 + +Xavier Masson InnerCircleProject : XM : 08/11/2000 + Integration of the new version delivered by Martin Waldenburg with the modification I made described just below + +Xavier Masson InnerCircleProject : XM : 07/15/2000 + Added "states/events " for spaces( SkipSpace;) CRLFco (SkipCRLFco) and + CRLF (SkipCRLF) this way the parser can give a complete view on code allowing + "perfect" code reconstruction. + (I fully now that this is not what a standard parser will do but I think it is more usefull this way ;) ) + go to www.innercircleproject.com for more explanations or express your critisism ;) + +previous modifications not logged sorry ;) + +Known Issues: +-----------------------------------------------------------------------------} +{---------------------------------------------------------------------------- + Last Modified: 05/22/2001 + Current Version: 1.1 + official version + Maintained by InnerCircle + + http://www.innercircleproject.org + + 02/07/2001 + added property handling in Object types + changed handling of forward declarations in ExportedHeading method +-----------------------------------------------------------------------------} +unit SimpleParser; + +{$IFDEF FPC}{$MODE DELPHI}{$ENDIF} + +interface + +uses + SysUtils, + Classes, + SimpleParser.Lexer.Types, + SimpleParser.Lexer, + SimpleParser.Types; + +{$INCLUDE SimpleParser.inc} + +resourcestring + rsExpected = '''%s'' expected found ''%s'''; + rsEndOfFile = 'end of file'; + +const + ClassMethodDirectiveEnum = [ + ptAbstract, + ptCdecl, + ptDynamic, + ptMessage, + ptOverride, + ptOverload, + ptPascal, + ptRegister, + ptReintroduce, + ptSafeCall, + ptStdCall, + ptVirtual, + ptDeprecated, + ptLibrary, + ptPlatform, + ptStatic, + ptInline, + ptFinal, + ptExperimental, + ptDispId, + ptNoreturn + ]; + +type + ESyntaxError = class(Exception) + private + FPosXY: TTokenPoint; + public + constructor Create(const Msg: string); + constructor CreateFmt(const Msg: string; const Args: array of const); + constructor CreatePos(const Msg: string; aPosXY: TTokenPoint); + property PosXY: TTokenPoint read FPosXY write FPosXY; + end; + + TmwSimplePasPar = class(TObject) + private + FOnMessage: TMessageEvent; + FLexer: TmwPasLex; + FInterfaceOnly: Boolean; + FLastNoJunkPos: Integer; + FLastNoJunkLen: Integer; + AheadParse: TmwSimplePasPar; + FInRound: Integer; + procedure InitAhead; + procedure VariableTail; + function GetInRound: Boolean; + function GetUseDefines: Boolean; + function GetScopedEnums: Boolean; + procedure SetUseDefines(const Value: Boolean); + procedure SetIncludeHandler(IncludeHandler: IIncludeHandler); + function GetOnComment: TCommentEvent; + procedure SetOnComment(const Value: TCommentEvent); + protected + procedure Expected(Sym: TptTokenKind); virtual; + procedure ExpectedEx(Sym: TptTokenKind); virtual; + procedure ExpectedFatal(Sym: TptTokenKind); virtual; + procedure HandlePtCompDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtDefineDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtElseDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtEndIfDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfDefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfNDefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfOptDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtResourceDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtUndefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfEndDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtElseIfDirect(Sender: TmwBasePasLex); virtual; + procedure NextToken; virtual; + procedure SkipJunk; virtual; + procedure Semicolon; virtual; + function GetExID: TptTokenKind; virtual; + function GetTokenID: TptTokenKind; virtual; + function GetGenID: TptTokenKind; virtual; + procedure AccessSpecifier; virtual; + procedure AdditiveOperator; virtual; + procedure AddressOp; virtual; + procedure AlignmentParameter; virtual; + procedure AsOp; virtual; + procedure AncestorIdList; virtual; + procedure AncestorId; virtual; + procedure AnonymousMethod; virtual; + procedure AnonymousMethodType; virtual; + procedure ArrayConstant; virtual; + procedure ArrayBounds; virtual; + procedure ArrayDimension; virtual; + procedure ArrayType; virtual; + procedure AsmStatement; virtual; + procedure AssignOp; virtual; + procedure AtExpression; virtual; + procedure Block; virtual; + procedure CaseElseStatement; virtual; + procedure CaseLabel; virtual; + procedure CaseLabelList; virtual; + procedure CaseSelector; virtual; + procedure CaseStatement; virtual; + procedure CharString; virtual; + procedure ClassField; virtual; + procedure ClassForward; virtual; + procedure ClassFunctionHeading; virtual; + procedure ClassHelper; virtual; + procedure ClassHeritage; virtual; + procedure ClassMemberList; virtual; + procedure ClassMethodDirective; virtual; + procedure ClassMethodHeading; virtual; + procedure ClassMethodOrProperty; virtual; + procedure ClassMethodResolution; virtual; + procedure ClassOperatorHeading; virtual; + procedure ClassProcedureHeading; virtual; + procedure ClassClass; virtual; + procedure ClassConstraint; virtual; + procedure ClassMethod; virtual; + procedure ClassProperty; virtual; + procedure ClassReferenceType; virtual; + procedure ClassType; virtual; + procedure ClassTypeEnd; virtual; + procedure ClassVisibility; virtual; + procedure CompoundStatement; virtual; + procedure ConstantColon; virtual; + procedure ConstantDeclaration; virtual; + procedure ConstantEqual; virtual; + procedure ConstantExpression; virtual; + procedure ConstantName; virtual; + procedure ConstantType; virtual; + procedure ConstantValue; virtual; + procedure ConstantValueTyped; virtual; + procedure ConstParameter; virtual; + procedure ConstructorConstraint; virtual; + procedure ConstructorHeading; virtual; + procedure ConstructorName; virtual; + procedure ConstSection; virtual; + procedure ContainsClause; virtual; + procedure CustomAttribute; virtual; + procedure DeclarationSection; virtual; + procedure DeclarationSections; virtual; + procedure Designator; virtual; + procedure DestructorHeading; virtual; + procedure DestructorName; virtual; + procedure Directive16Bit; virtual; + procedure DirectiveBinding; virtual; + procedure DirectiveBindingMessage; virtual; + procedure DirectiveCalling; virtual; + procedure DirectiveDeprecated; virtual; + procedure DirectiveInline; virtual; + procedure DirectiveLibrary; virtual; + procedure DirectiveLocal; virtual; + procedure DirectivePlatform; virtual; + procedure DirectiveVarargs; virtual; + procedure DispInterfaceForward; virtual; + procedure DispIDSpecifier; virtual; + procedure DotOp; virtual; + procedure ElseStatement; virtual; + procedure ElseExpression; virtual; + procedure EmptyStatement; virtual; + procedure EnumeratedType; virtual; + procedure EnumeratedTypeItem; virtual; + procedure ExceptBlock; virtual; + procedure ExceptionBlockElseBranch; virtual; + procedure ExceptionClassTypeIdentifier; virtual; + procedure ExceptionHandler; virtual; + procedure ExceptionHandlerList; virtual; + procedure ExceptionIdentifier; virtual; + procedure ExceptionVariable; virtual; + procedure ExplicitType; virtual; + procedure ExportedHeading; virtual; + procedure ExportsClause; virtual; + procedure ExportsElement; virtual; + procedure ExportsName; virtual; + procedure ExportsNameId; virtual; + procedure Expression; virtual; + procedure ExpressionList; virtual; + procedure ExternalDirective; virtual; + procedure ExternalDirectiveThree; virtual; + procedure ExternalDirectiveTwo; virtual; + procedure Factor; virtual; + procedure FieldDeclaration; virtual; + procedure FieldList; virtual; + procedure FieldNameList; virtual; + procedure FieldName; virtual; + procedure FileType; virtual; + procedure FinalizationSection; virtual; + procedure FinallyBlock; virtual; + procedure FormalParameterList; virtual; + procedure FormalParameterSection; virtual; + procedure ForStatement; virtual; + procedure ForStatementDownTo; virtual; + procedure ForStatementFrom; virtual; + procedure ForStatementIn; virtual; + procedure ForStatementTo; virtual; + procedure ForwardDeclaration; virtual; + procedure FunctionHeading; virtual; + procedure FunctionMethodDeclaration; virtual; + procedure FunctionMethodName; virtual; + procedure FunctionProcedureBlock; virtual; + procedure FunctionProcedureName; virtual; + procedure GotoStatement; virtual; + procedure Identifier; virtual; + procedure IdentifierList; virtual; + procedure IfStatement; virtual; + procedure TernaryOp; virtual; + procedure ImplementationSection; virtual; + procedure ImplementsSpecifier; virtual; + procedure IncludeFile; virtual; + procedure IndexSpecifier; virtual; + procedure IndexOp; virtual; + procedure InheritedStatement; virtual; + procedure InheritedVariableReference; virtual; + procedure InitializationSection; virtual; + procedure InlineConstSection; virtual; + procedure InlineStatement; virtual; + procedure InlineVarDeclaration; virtual; + procedure InlineVarSection; virtual; + procedure InParameter; virtual; + procedure InterfaceDeclaration; virtual; + procedure InterfaceForward; virtual; + procedure InterfaceGUID; virtual; + procedure InterfaceHeritage; virtual; + procedure InterfaceMemberList; virtual; + procedure InterfaceSection; virtual; + procedure InterfaceType; virtual; + procedure IsNotOp; virtual; + procedure LabelDeclarationSection; virtual; + procedure LabeledStatement; virtual; + procedure LabelId; virtual; + procedure LibraryFile; virtual; + procedure LibraryBlock; virtual; + procedure MainUsedUnitExpression; virtual; + procedure MainUsedUnitName; virtual; + procedure MainUsedUnitStatement; virtual; + procedure MainUsesClause; virtual; + procedure MethodKind; virtual; + procedure MultiplicativeOperator; virtual; + procedure FormalParameterType; virtual; + procedure NotInOp; virtual; + procedure NotOp; virtual; + procedure NilToken; virtual; + procedure Number; virtual; + procedure ObjectConstructorHeading; virtual; + procedure ObjectDestructorHeading; virtual; + procedure ObjectField; virtual; + procedure ObjectForward; virtual; + procedure ObjectFunctionHeading; virtual; + procedure ObjectHeritage; virtual; + procedure ObjectMemberList; virtual; + procedure ObjectMethodDirective; virtual; + procedure ObjectMethodHeading; virtual; + procedure ObjectNameOfMethod; virtual; + procedure ObjectProperty; virtual; + procedure ObjectPropertySpecifiers; virtual; + procedure ObjectProcedureHeading; virtual; + procedure ObjectType; virtual; + procedure ObjectTypeEnd; virtual; + procedure ObjectVisibility; virtual; + procedure OrdinalIdentifier; virtual; + procedure OrdinalType; virtual; + procedure OutParameter; virtual; + procedure PackageFile; virtual; + procedure ParameterFormal; virtual; + procedure ParameterName; virtual; + procedure ParameterNameList; virtual; + procedure ParseFile; virtual; + procedure PointerSymbol; virtual; + procedure PointerType; virtual; + procedure ProceduralDirective; virtual; + procedure ProceduralDirectiveOf; virtual; + procedure ProceduralType; virtual; + procedure ProcedureDeclarationSection; virtual; + procedure ProcedureHeading; virtual; + procedure ProcedureProcedureName; virtual; + procedure ProcedureMethodName; virtual; + procedure ProgramBlock; virtual; + procedure ProgramFile; virtual; + procedure PropertyDefault; virtual; + procedure PropertyInterface; virtual; + procedure PropertyName; virtual; + procedure PropertyParameterList; virtual; + procedure PropertySpecifiers; virtual; + procedure QualifiedIdentifier; virtual; + procedure RaiseStatement; virtual; + procedure ReadAccessIdentifier; virtual; + procedure RealIdentifier; virtual; + procedure RealType; virtual; + procedure RecordAlign; virtual; + procedure RecordAlignValue; virtual; + procedure RecordConstant; virtual; + procedure RecordConstraint; virtual; + procedure RecordFieldConstant; virtual; + procedure RecordType; virtual; + procedure RecordVariant; virtual; + procedure RelativeOperator; virtual; + procedure RepeatStatement; virtual; + procedure RequiresClause; virtual; + procedure RequiresIdentifier; virtual; + procedure RequiresIdentifierId; virtual; + procedure ResolutionInterfaceName; virtual; + procedure ResourceDeclaration; virtual; + procedure ResourceValue; virtual; + procedure ReturnType; virtual; + procedure RoundClose; virtual; + procedure RoundOpen; virtual; + procedure SetConstructor; virtual; + procedure SetElement; virtual; + procedure SetType; virtual; + procedure SimpleExpression; virtual; + procedure SimpleStatement; virtual; + procedure SimpleType; virtual; + procedure SkipAnsiComment; virtual; + procedure SkipBorComment; virtual; + procedure SkipSlashesComment; virtual; + procedure SkipSpace; virtual; + procedure SkipCRLFco; virtual; + procedure SkipCRLF; virtual; + procedure Statement; virtual; + procedure StatementOrExpression; virtual; + procedure Statements; virtual; + procedure StatementList; virtual; + procedure StorageExpression; virtual; + procedure StorageIdentifier; virtual; + procedure StorageDefault; virtual; + procedure StorageNoDefault; virtual; + procedure StorageSpecifier; virtual; + procedure StorageStored; virtual; + procedure StringConst; virtual; + procedure StringConstSimple; virtual; + procedure StringIdentifier; virtual; + procedure StringStatement; virtual; + procedure StringType; virtual; + procedure StructuredType; virtual; + procedure SubrangeType; virtual; + procedure TagField; virtual; + procedure TagFieldName; virtual; + procedure TagFieldTypeName; virtual; + procedure Term; virtual; + procedure ThenStatement; virtual; + procedure ThenExpression; virtual; + procedure TryStatement; virtual; + procedure TypedConstant; virtual; + procedure TypeDeclaration; virtual; + procedure TypeId; virtual; + procedure TypeKind; virtual; + procedure TypeName; virtual; + procedure TypeReferenceType; virtual; + procedure TypeSimple; virtual; + //generics + procedure TypeArgs; virtual; + procedure TypeDirective; virtual; + procedure TypeParams; virtual; + procedure TypeParamDecl; virtual; + procedure TypeParamDeclList; virtual; + procedure TypeParamList; virtual; + procedure ConstraintList; virtual; + procedure Constraint; virtual; + //end generics + procedure TypeSection; virtual; + procedure UnaryMinus; virtual; + procedure UnitFile; virtual; + procedure UnitId; virtual; + procedure UnitName; virtual; + procedure UsedUnitName; virtual; + procedure UsedUnitsList; virtual; + procedure UsesClause; virtual; + procedure VarAbsolute; virtual; + procedure VarEqual; virtual; + procedure VarDeclaration; virtual; + procedure Variable; virtual; + procedure VariableReference; virtual; + procedure VariantIdentifier; virtual; + procedure VariantSection; virtual; + procedure VarParameter; virtual; + procedure VarName; virtual; + procedure VarNameList; virtual; + procedure VarSection; virtual; + procedure VisibilityAutomated; virtual; + procedure VisibilityPrivate; virtual; + procedure VisibilityProtected; virtual; + procedure VisibilityPublic; virtual; + procedure VisibilityPublished; virtual; + procedure VisibilityStrictPrivate; virtual; + procedure VisibilityStrictProtected; virtual; + procedure VisibilityUnknown; virtual; + procedure WhileStatement; virtual; + procedure WithExpressionList; virtual; + procedure WithStatement; virtual; + procedure WriteAccessIdentifier; virtual; + //JThurman 2004-03-21 + {This is the syntax for custom attributes, based quite strictly on the + ECMA syntax specifications for C#, but with a Delphi expression being + used at the bottom as opposed to a C# expression} + procedure GlobalAttributes; + procedure GlobalAttributeSections; + procedure GlobalAttributeSection; + procedure GlobalAttributeTargetSpecifier; + procedure GlobalAttributeTarget; + procedure Attributes; + procedure AttributeSections; virtual; + procedure AttributeSection; + procedure AttributeTargetSpecifier; + procedure AttributeTarget; + procedure AttributeList; + procedure Attribute; virtual; + procedure AttributeName; virtual; + procedure AttributeArguments; virtual; + procedure PositionalArgumentList; + procedure PositionalArgument; virtual; + procedure NamedArgumentList; + procedure NamedArgument; virtual; + procedure AttributeArgumentName; virtual; + procedure AttributeArgumentExpression; virtual; + + property ExID: TptTokenKind read GetExID; + property GenID: TptTokenKind read GetGenID; + property TokenID: TptTokenKind read GetTokenID; + property InRound: Boolean read GetInRound; + public + constructor Create; virtual; + destructor Destroy; override; + procedure SynError(Error: TmwParseError); virtual; + procedure Run(const UnitName: string; SourceStream: TStream); virtual; + + procedure ClearDefines; + procedure InitDefinesDefinedByCompiler; + procedure AddDefine(const ADefine: string); + procedure RemoveDefine(const ADefine: string); + function IsDefined(const ADefine: string): Boolean; + + property InterfaceOnly: Boolean read FInterfaceOnly write FInterfaceOnly; + property Lexer: TmwPasLex read FLexer; + property OnComment: TCommentEvent read GetOnComment write SetOnComment; + property OnMessage: TMessageEvent read FOnMessage write FOnMessage; + property LastNoJunkPos: Integer read FLastNoJunkPos; + property LastNoJunkLen: Integer read FLastNoJunkLen; + + property UseDefines: Boolean read GetUseDefines write SetUseDefines; + property ScopedEnums: Boolean read GetScopedEnums; + property IncludeHandler: IIncludeHandler write SetIncludeHandler; + end; + +implementation + +{ ESyntaxError } + +constructor ESyntaxError.Create(const Msg: string); +begin + FPosXY.X := -1; + FPosXY.Y := -1; + inherited Create(Msg); +end; + +constructor ESyntaxError.CreateFmt(const Msg: string; const Args: array of const); +begin + FPosXY.X := -1; + FPosXY.Y := -1; + inherited CreateFmt(Msg, Args); +end; + +constructor ESyntaxError.CreatePos(const Msg: string; aPosXY: TTokenPoint); +begin + FPosXY := aPosXY; + inherited Create(Msg); +end; + +{ TmwSimplePasPar } + +procedure TmwSimplePasPar.ForwardDeclaration; +begin + NextToken; + Semicolon; +end; + +procedure TmwSimplePasPar.ObjectProperty; +begin + Expected(ptProperty); + PropertyName; + case TokenID of + ptColon, ptSquareOpen: + begin + PropertyInterface; + end; + end; + ObjectPropertySpecifiers; + case ExID of + ptDefault: + begin + PropertyDefault; + Semicolon; + end; + end; +end; + +procedure TmwSimplePasPar.ObjectPropertySpecifiers; +begin + if ExID = ptIndex then + begin + IndexSpecifier; + end; + while ExID in [ptRead, ptReadOnly, ptWrite, ptWriteOnly] do + begin + AccessSpecifier; + end; + while ExID in [ptDefault, ptNoDefault, ptStored] do + begin + StorageSpecifier; + end; + Semicolon; +end; + +type + TStringStreamHelper = class helper for TStringStream + function GetDataString: string; + {$IFNDEF FPC} + property DataString: string read GetDataString; + {$ENDIF} + end; + +function TStringStreamHelper.GetDataString: string; +{$IFNDEF FPC} +var + Encoding: TEncoding; +begin + // try to read a bom from the buffer to create the correct encoding + // but only if the encoding is still the default encoding + if Self.Encoding = TEncoding.Default then + begin + Encoding := nil; + TEncoding.GetBufferEncoding(Bytes, Encoding); + Result := Encoding.GetString(Bytes, Length(Encoding.GetPreamble), Size); + end + else + Result := Self.Encoding.GetString(Bytes, 0, Size); +{$ELSE} +var + Encoding: TEncoding; + Bytes: TBytes; +begin + Encoding := nil; + SetLength(Bytes, Self.Size); + Bytes := BytesOf(DataString); + TEncoding.GetBufferEncoding(Bytes, Encoding); + Result := Encoding.GetString(Bytes, Length(Encoding.GetPreamble), Size); +{$ENDIF} +end; + +procedure TmwSimplePasPar.Run(const UnitName: string; SourceStream: TStream); +var + StringStream: TStringStream; + OwnStream: Boolean; +{$IFDEF FPC} + Strings: TStringList; +{$ENDIF} +begin + OwnStream := not (SourceStream is TStringStream); + if OwnStream then + begin + {$IFNDEF FPC} + StringStream := TStringStream.Create; + StringStream.LoadFromStream(SourceStream); + {$ELSE} + Strings := TStringList.Create; + try + Strings.LoadFromStream(SourceStream); + StringStream := TStringStream.Create(''); + Strings.SaveToStream(StringStream); + finally + FreeAndNil(Strings); + end; + {$ENDIF} + end + else + StringStream := TStringStream(SourceStream); + FLexer.Origin := StringStream.GetDataString; + ParseFile; + if OwnStream then + StringStream.Free; +end; + +constructor TmwSimplePasPar.Create; +begin + inherited Create; + FLexer := TmwPasLex.Create; + FLexer.OnCompDirect := HandlePtCompDirect; + FLexer.OnDefineDirect := HandlePtDefineDirect; + FLexer.OnElseDirect := HandlePtElseDirect; + FLexer.OnEndIfDirect := HandlePtEndIfDirect; + FLexer.OnIfDefDirect := HandlePtIfDefDirect; + FLexer.OnIfNDefDirect := HandlePtIfNDefDirect; + FLexer.OnIfOptDirect := HandlePtIfOptDirect; + FLexer.OnResourceDirect := HandlePtResourceDirect; + FLexer.OnUnDefDirect := HandlePtUndefDirect; + FLexer.OnIfDirect := HandlePtIfDirect; + FLexer.OnIfEndDirect := HandlePtIfEndDirect; + FLexer.OnElseIfDirect := HandlePtElseIfDirect; +end; + +destructor TmwSimplePasPar.Destroy; +begin + AheadParse.Free; + + FLexer.Free; + inherited Destroy; +end; + +{next two check for ptNull and ExpectedFatal for an EOF Error} + +procedure TmwSimplePasPar.Expected(Sym: TptTokenKind); +begin + if Sym <> Lexer.TokenID then + begin + if TokenID = ptNull then + ExpectedFatal(Sym) + else + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, Format(rsExpected, [TokenName(Sym), FLexer.Token]), + FLexer.PosXY.X, FLexer.PosXY.Y); + end; + end + else + NextToken; +end; + +procedure TmwSimplePasPar.ExpectedEx(Sym: TptTokenKind); +begin + if Sym <> Lexer.ExID then + begin + if Lexer.TokenID = ptNull then + ExpectedFatal(Sym) {jdj 7/22/1999} + else if Assigned(FOnMessage) then + FOnMessage(Self, meError, Format(rsExpected, ['EX:' + TokenName(Sym), FLexer.Token]), + FLexer.PosXY.X, FLexer.PosXY.Y); + end + else + NextToken; +end; + +{Replace Token with cnEndOfFile if TokenId = ptnull} + +procedure TmwSimplePasPar.ExpectedFatal(Sym: TptTokenKind); +var + tS: string; +begin + if Sym <> Lexer.TokenID then + begin + {--jdj 7/22/1999--} + if Lexer.TokenId = ptNull then + tS := rsEndOfFile + else + tS := FLexer.Token; + {--jdj 7/22/1999--} + raise ESyntaxError.CreatePos(Format(rsExpected, [TokenName(Sym), tS]), FLexer.PosXY); + end + else + NextToken; +end; + +procedure TmwSimplePasPar.HandlePtCompDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtDefineDirect(Sender: TmwBasePasLex); +begin + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtElseDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtElseIfDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtEndIfDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfDefDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfEndDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfNDefDirect(Sender: TmwBasePasLex); +begin + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfOptDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtResourceDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + FLexer.Token, FLexer.PosXY.X, FLexer.PosXY.Y); + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtUndefDirect(Sender: TmwBasePasLex); +begin + Sender.Next; +end; + +procedure TmwSimplePasPar.NextToken; +begin + FLexer.NextNoJunk; +end; + +procedure TmwSimplePasPar.NilToken; +begin + Expected(ptNil); +end; + +procedure TmwSimplePasPar.NotInOp; +begin + Expected(ptNot); + Expected(ptIn); +end; + +procedure TmwSimplePasPar.NotOp; +begin + Expected(ptNot); +end; + +procedure TmwSimplePasPar.SkipJunk; +begin + if Lexer.IsJunk then + begin + case TokenID of + ptAnsiComment: + begin + SkipAnsiComment; + end; + ptBorComment: + begin + SkipBorComment; + end; + ptSlashesComment: + begin + SkipSlashesComment; + end; + ptSpace: + begin + SkipSpace; + end; + ptCRLFCo: + begin + SkipCRLFco; + end; + ptCRLF: + begin + SkipCRLF; + end; + ptSquareOpen: + begin + CustomAttribute; + end; + else + begin + Lexer.Next; + end; + end; + end; + FLastNoJunkPos := Lexer.TokenPos; + FLastNoJunkLen := Lexer.TokenLen; +end; + +procedure TmwSimplePasPar.SkipAnsiComment; +begin + Expected(ptAnsiComment); + while TokenID in [ptAnsiComment] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipBorComment; +begin + Expected(ptBorComment); + while TokenID in [ptBorComment] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipSlashesComment; +begin + Expected(ptSlashesComment); +end; + +procedure TmwSimplePasPar.ThenExpression; +begin + Expected(ptThen); + Expression; +end; + +procedure TmwSimplePasPar.ThenStatement; +begin + Expected(ptThen); + Statement; +end; + +procedure TmwSimplePasPar.Semicolon; +begin + case Lexer.TokenID of + ptElse, ptEnd, ptExcept, ptfinally, ptFinalization, ptRoundClose, ptUntil: ; + else + Expected(ptSemiColon); + end; +end; + +function TmwSimplePasPar.GetExID: TptTokenKind; +begin + Result := FLexer.ExID; +end; + +function TmwSimplePasPar.GetTokenID: TptTokenKind; +begin + Result := FLexer.TokenID; +end; + +function TmwSimplePasPar.GetUseDefines: Boolean; +begin + Result := FLexer.UseDefines; +end; + +function TmwSimplePasPar.GetScopedEnums: Boolean; +begin + Result := FLexer.ScopedEnums; +end; + +procedure TmwSimplePasPar.GotoStatement; +begin + Expected(ptGoto); + LabelId; +end; + +function TmwSimplePasPar.GetGenID: TptTokenKind; +begin + Result := FLexer.GenID; +end; + +function TmwSimplePasPar.GetInRound: Boolean; +begin + Result := FInRound > 0; +end; + +function TmwSimplePasPar.GetOnComment: TCommentEvent; +begin + Result := FLexer.OnComment; +end; + +procedure TmwSimplePasPar.SynError(Error: TmwParseError); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, ParserErrorName(Error) + ' found ' + FLexer.Token, FLexer.PosXY.X, + FLexer.PosXY.Y); + +end; + +(****************************************************************************** + This part is oriented at the official grammar of Delphi 4 + and parialy based on Robert Zierers Delphi grammar. + For more information about Delphi grammars take a look at: + http://www.stud.mw.tu-muenchen.de/~rz1/Grammar.html +******************************************************************************) + +procedure TmwSimplePasPar.ParseFile; +begin + SkipJunk; + case GenID of + ptLibrary: + begin + LibraryFile; + end; + ptPackage: + begin + PackageFile; + end; + ptProgram: + begin + ProgramFile; + end; + ptUnit: + begin + UnitFile; + end; + else + begin + IncludeFile; + end; + end; +end; + +procedure TmwSimplePasPar.LibraryFile; +begin + Expected(ptLibrary); + UnitName; + Semicolon; + + LibraryBlock; + Expected(ptPoint); +end; + +procedure TmwSimplePasPar.LibraryBlock; +begin + if TokenID = ptUses then + MainUsesClause; + + DeclarationSections; + + if TokenID = ptBegin then + CompoundStatement + else + Expected(ptEnd); +end; + +procedure TmwSimplePasPar.PackageFile; +begin + ExpectedEx(ptPackage); + UnitName; + Semicolon; + case ExID of + ptRequires: + begin + RequiresClause; + end; + end; + case ExID of + ptContains: + begin + ContainsClause; + end; + end; + + while Lexer.TokenID = ptSquareOpen do + begin + CustomAttribute; + end; + + Expected(ptEnd); + Expected(ptPoint); +end; + +procedure TmwSimplePasPar.ProgramFile; +begin + Expected(ptProgram); + UnitName; + if TokenID = ptRoundOpen then + begin + NextToken; + IdentifierList; + Expected(ptRoundClose); + end; + if not InterfaceOnly then + begin + Semicolon; + ProgramBlock; + Expected(ptPoint); + end; +end; + +procedure TmwSimplePasPar.UnaryMinus; +begin + Expected(ptMinus); +end; + +procedure TmwSimplePasPar.UnitFile; +begin + Expected(ptUnit); + UnitName; + TypeDirective; + + Semicolon; + InterfaceSection; + if not InterfaceOnly then + begin + ImplementationSection; + case TokenID of + ptInitialization: + begin + InitializationSection; + if TokenID = ptFinalization then + FinalizationSection; + Expected(ptEnd); + end; + ptBegin: + begin + CompoundStatement; + end; + ptEnd: + begin + NextToken; + end; + end; + + Expected(ptPoint); + end; +end; + +procedure TmwSimplePasPar.ProgramBlock; +begin + if TokenID = ptUses then + begin + MainUsesClause; + end; + Block; +end; + +procedure TmwSimplePasPar.MainUsesClause; +begin + Expected(ptUses); + MainUsedUnitStatement; + while TokenID = ptComma do + begin + NextToken; + MainUsedUnitStatement; + end; + Semicolon; +end; + +procedure TmwSimplePasPar.MethodKind; +begin + case TokenID of + ptConstructor: + begin + NextToken; + end; + ptDestructor: + begin + NextToken; + end; + ptProcedure: + begin + NextToken; + end; + ptFunction: + begin + NextToken; + end; + else + begin + SynError(InvalidProcedureMethodDeclaration); + end; + end; +end; + +procedure TmwSimplePasPar.MainUsedUnitStatement; +begin + MainUsedUnitName; + if Lexer.TokenID = ptIn then + begin + NextToken; + MainUsedUnitExpression; + end; +end; + +procedure TmwSimplePasPar.MainUsedUnitName; +begin + UsedUnitName; +end; + +procedure TmwSimplePasPar.MainUsedUnitExpression; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.UsesClause; +begin + Expected(ptUses); + UsedUnitsList; + Semicolon; +end; + +procedure TmwSimplePasPar.UsedUnitsList; +begin + UsedUnitName; + while TokenID = ptComma do + begin + NextToken; + UsedUnitName; + end; +end; + +procedure TmwSimplePasPar.UsedUnitName; +begin + UnitId; + while Lexer.TokenID = ptPoint do + begin + NextToken; + UnitId; + end; +end; + +procedure TmwSimplePasPar.Block; +begin + DeclarationSections; + case TokenID of + ptAsm: + begin + AsmStatement; + end; + else + begin + CompoundStatement; + end; + end; +end; + +procedure TmwSimplePasPar.DeclarationSection; +begin + case TokenID of + ptClass: + begin + ProcedureDeclarationSection; + end; + ptConst: + begin + ConstSection; + end; + ptConstructor: + begin + ProcedureDeclarationSection; + end; + ptDestructor: + begin + ProcedureDeclarationSection; + end; + ptExports: + begin + ExportsClause; + end; + ptFunction: + begin + ProcedureDeclarationSection; + end; + ptLabel: + begin + LabelDeclarationSection; + end; + ptProcedure: + begin + ProcedureDeclarationSection; + end; + ptResourceString: + begin + ConstSection; + end; + ptType: + begin + TypeSection; + end; + ptThreadVar: + begin + VarSection; + end; + ptVar: + begin + VarSection; + end; + ptSquareOpen: + begin + CustomAttribute; + end; + else + begin + SynError(InvalidDeclarationSection); + end; + end; +end; + +procedure TmwSimplePasPar.UnitId; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.UnitName; +begin + UnitId; + while Lexer.TokenID = ptPoint do + begin + NextToken; + UnitId; + end; +end; + +procedure TmwSimplePasPar.InterfaceHeritage; +begin + Expected(ptRoundOpen); + AncestorIdList; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.InterfaceGUID; +begin + Expected(ptSquareOpen); + CharString; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.AccessSpecifier; +begin + case ExID of + ptRead: + begin + NextToken; + ReadAccessIdentifier; + end; + ptWrite: + begin + NextToken; + WriteAccessIdentifier; + end; + ptReadOnly: + begin + NextToken; + end; + ptWriteOnly: + begin + NextToken; + end; + ptAdd: + begin + NextToken; + QualifiedIdentifier; //TODO: AddAccessIdentifier + end; + ptRemove: + begin + NextToken; + QualifiedIdentifier; //TODO: RemoveAccessIdentifier + end; + else + begin + SynError(InvalidAccessSpecifier); + end; + end; +end; + +procedure TmwSimplePasPar.ReadAccessIdentifier; +begin + variable; +end; + +procedure TmwSimplePasPar.WriteAccessIdentifier; +begin + variable; +end; + +procedure TmwSimplePasPar.StorageSpecifier; +begin + case ExID of + ptStored: + begin + StorageStored; + end; + ptDefault: + begin + StorageDefault; + end; + ptNoDefault: + begin + StorageNoDefault; + end + else + begin + SynError(InvalidStorageSpecifier); + end; + end; +end; + +procedure TmwSimplePasPar.StorageDefault; +begin + ExpectedEx(ptDefault); + StorageExpression; +end; + +procedure TmwSimplePasPar.StorageNoDefault; +begin + ExpectedEx(ptNoDefault); +end; + +procedure TmwSimplePasPar.StorageStored; +begin + ExpectedEx(ptStored); + case TokenID of + ptIdentifier: + begin + StorageIdentifier; + end; + else + if TokenID <> ptSemiColon then + begin + StorageExpression; + end; + end; +end; + +procedure TmwSimplePasPar.StorageExpression; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.StorageIdentifier; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.PropertyParameterList; +begin + Expected(ptSquareOpen); + FormalParameterSection; + while TokenID = ptSemiColon do + begin + Semicolon; + FormalParameterSection; + end; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.PropertySpecifiers; +begin + if ExID = ptIndex then + begin + IndexSpecifier; + end; + while ExID in [ptRead, ptReadOnly, ptWrite, ptWriteOnly, ptAdd, ptRemove] do + begin + AccessSpecifier; + if TokenID = ptSemicolon then + NextToken; + end; + if ExID = ptDispId then + begin + DispIDSpecifier; + end; + while ExID in [ptDefault, ptNoDefault, ptStored] do + begin + StorageSpecifier; + if TokenID = ptSemicolon then + NextToken; + end; + if ExID = ptImplements then + begin + ImplementsSpecifier; + end; + if TokenID = ptSemicolon then + NextToken; +end; + +procedure TmwSimplePasPar.PropertyInterface; +begin + if TokenID = ptSquareOpen then + begin + PropertyParameterList; + end; + Expected(ptColon); + TypeID; +end; + +procedure TmwSimplePasPar.ClassMethodHeading; +begin + if TokenID = ptClass then + ClassClass; + + InitAhead; + AheadParse.NextToken; + AheadParse.FunctionProcedureName; + + if AheadParse.TokenId = ptEqual then + ClassMethodResolution + else + begin + case TokenID of + ptConstructor: + begin + ConstructorHeading; + end; + ptDestructor: + begin + DestructorHeading; + end; + ptFunction: + begin + ClassFunctionHeading; + end; + ptProcedure: + begin + ClassProcedureHeading; + end; + ptIdentifier: + begin + if Lexer.ExID = ptOperator then + begin + ClassOperatorHeading; + end + else + SynError(InvalidProcedureMethodDeclaration); + end; + else + SynError(InvalidClassMethodHeading); + end; + end; +end; + +procedure TmwSimplePasPar.ClassFunctionHeading; +begin + Expected(ptFunction); + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + Expected(ptColon); + ReturnType; + if TokenId = ptSemicolon then + Semicolon; + if ExID in ClassMethodDirectiveEnum then + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.FunctionMethodName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ClassProcedureHeading; +begin + Expected(ptProcedure); + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenId = ptSemicolon then + Semicolon; + + if ExID = ptDispId then + begin + DispIDSpecifier; + if TokenId = ptSemicolon then + Semicolon; + end; + if exID in ClassMethodDirectiveEnum then + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.ProcedureMethodName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ClassMethodResolution; +begin + case TokenID of + ptFunction: + begin + NextToken; + end; + ptProcedure: + begin + NextToken; + end; + ptIdentifier: + begin + if Lexer.ExID = ptOperator then + NextToken; + end; + end; + FunctionProcedureName; + Expected(ptEqual); + FunctionMethodName; + Semicolon; +end; + +procedure TmwSimplePasPar.ClassOperatorHeading; +begin + ExpectedEx(ptOperator); + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + + if TokenID = ptColon then + begin + Expected(ptColon); + ReturnType; + end; + + if TokenId = ptSemicolon then + Semicolon; + if ExID in ClassMethodDirectiveEnum then + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.ResolutionInterfaceName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.Constraint; +begin + while TokenId in [ptConstructor, ptRecord, ptClass, ptIdentifier] do + begin + case TokenId of + ptConstructor: ConstructorConstraint; + ptRecord: RecordConstraint; + ptClass: ClassConstraint; + ptIdentifier: TypeId; + end; + if TokenId = ptComma then + NextToken; + end; +end; + +procedure TmwSimplePasPar.ConstraintList; +begin + Constraint; + while TokenId = ptComma do + begin + Constraint; + end; +end; + +procedure TmwSimplePasPar.ConstructorConstraint; +begin + Expected(ptConstructor); +end; + +procedure TmwSimplePasPar.ConstructorHeading; +begin + Expected(ptConstructor); + ConstructorName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptSemiColon then Semicolon; + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.ConstructorName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.DestructorHeading; +begin + Expected(ptDestructor); + DestructorName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptSemiColon then Semicolon; + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.DestructorName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ClassMethod; +begin + Expected(ptClass); +end; + +procedure TmwSimplePasPar.ClassMethodDirective; +begin + while ExId in ClassMethodDirectiveEnum do + begin + if ExID = ptDispId then + DispIDSpecifier + else + ProceduralDirective; + if TokenId = ptSemicolon then + Semicolon; + end; +end; + +procedure TmwSimplePasPar.ObjectMethodHeading; +begin + case TokenID of + ptConstructor: + begin + ObjectConstructorHeading; + end; + ptDestructor: + begin + ObjectDestructorHeading; + end; + ptFunction: + begin + ObjectFunctionHeading; + end; + ptProcedure: + begin + ObjectProcedureHeading; + end; + else + begin + SynError(InvalidMethodHeading); + end; + end; +end; + +procedure TmwSimplePasPar.ObjectFunctionHeading; +begin + Expected(ptFunction); + FunctionMethodName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + Expected(ptColon); + ReturnType; + if TokenID = ptSemiColon then Semicolon; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectProcedureHeading; +begin + Expected(ptProcedure); + ProcedureMethodName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptSemiColon then Semicolon; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectConstructorHeading; +begin + Expected(ptConstructor); + ConstructorName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptSemiColon then Semicolon; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectDestructorHeading; +begin + Expected(ptDestructor); + DestructorName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptSemiColon then Semicolon; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectMethodDirective; +begin + while ExID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, + ptMessage, ptNear, ptOverload, ptPascal, ptRegister, ptSafeCall, ptStdCall, + ptVirtual, ptDeprecated, ptLibrary, ptPlatform, ptStatic, ptInline] do + begin + ProceduralDirective; + if TokenID = ptSemiColon then Semicolon; + end; +end; + +procedure TmwSimplePasPar.Directive16Bit; +begin + case ExID of + ptNear: + begin + NextToken; + end; + ptFar: + begin + NextToken; + end; + ptExport: + begin + NextToken; + end; + else + begin + SynError(InvalidDirective16Bit); + end; + end; +end; + +procedure TmwSimplePasPar.DirectiveBinding; +begin + case ExID of + ptAbstract: + begin + NextToken; + end; + ptVirtual: + begin + NextToken; + end; + ptDynamic: + begin + NextToken; + end; + ptMessage: + begin + DirectiveBindingMessage; + end; + ptOverride: + begin + NextToken; + end; + ptOverload: + begin + NextToken; + end; + ptReintroduce: + begin + NextToken; + end; + ptNoreturn: + begin + NextToken; + end; + else + begin + SynError(InvalidDirectiveBinding); + end; + end; +end; + +procedure TmwSimplePasPar.DirectiveBindingMessage; +begin + NextToken; + ConstantExpression; +end; + +procedure TmwSimplePasPar.ReturnType; +begin + while TokenID = ptSquareOpen do + CustomAttribute; + + TypeID; +end; + +procedure TmwSimplePasPar.RoundClose; +begin + Expected(ptRoundClose); + Dec(FInRound); +end; + +procedure TmwSimplePasPar.RoundOpen; +begin + Expected(ptRoundOpen); + Inc(FInRound); +end; + +procedure TmwSimplePasPar.FormalParameterList; +begin + Expected(ptRoundOpen); + FormalParameterSection; + while TokenID = ptSemiColon do + begin + Semicolon; + FormalParameterSection; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.FormalParameterSection; +begin + while TokenID = ptSquareOpen do + CustomAttribute; + case TokenID of + ptConst: + begin + ConstParameter; + end; + ptIdentifier: + case ExID of + ptOut: OutParameter; + else + ParameterFormal; + end; + ptIn: + begin + InParameter; + end; + ptVar: + begin + VarParameter; + end; + end; +end; + +procedure TmwSimplePasPar.ConstParameter; +begin + Expected(ptConst); + ParameterNameList; + case TokenID of + ptColon: + begin + NextToken; + FormalParameterType; + if TokenID = ptEqual then + begin + NextToken; + TypedConstant; + end; + end + end; +end; + +procedure TmwSimplePasPar.VarParameter; +begin + Expected(ptVar); + ParameterNameList; + case TokenID of + ptColon: + begin + NextToken; + FormalParameterType; + end + end; +end; + +procedure TmwSimplePasPar.OutParameter; +begin + ExpectedEx(ptOut); + ParameterNameList; + case TokenID of + ptColon: + begin + NextToken; + FormalParameterType; + end + end; +end; + +procedure TmwSimplePasPar.ParameterFormal; +begin + case TokenID of + ptIdentifier: + begin + ParameterNameList; + Expected(ptColon); + FormalParameterType; + if TokenID = ptEqual then + begin + NextToken; + TypedConstant; + end; + end; + else + begin + SynError(InvalidParameter); + end; + end; +end; + +procedure TmwSimplePasPar.ParameterNameList; +begin + while TokenID = ptSquareOpen do + CustomAttribute; + ParameterName; + + while TokenID = ptComma do + begin + NextToken; + + while TokenID = ptSquareOpen do + CustomAttribute; + ParameterName; + end; +end; + +procedure TmwSimplePasPar.ParameterName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.FormalParameterType; +begin + if TokenID = ptArray then + StructuredType + else + TypeID; +end; + +procedure TmwSimplePasPar.FunctionMethodDeclaration; +begin + if (TokenID = ptIdentifier) and (Lexer.ExID = ptOperator) then + NextToken else + MethodKind; + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + case TokenID of + ptSemiColon: + begin + FunctionProcedureBlock; + end; + else + begin + Expected(ptColon); + ReturnType; + FunctionProcedureBlock; + end; + end; +end; + +procedure TmwSimplePasPar.ProcedureProcedureName; +begin + MethodKind; + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + FunctionProcedureBlock; +end; + +procedure TmwSimplePasPar.FunctionProcedureName; +begin + ObjectNameOfMethod; +end; + +procedure TmwSimplePasPar.ObjectNameOfMethod; +begin + if TokenID = ptIn then + Expected(ptIn) + else + Expected(ptIdentifier); + + if TokenId = ptLower then + TypeParams; + if TokenID = ptPoint then + begin + Expected(ptPoint); + ObjectNameOfMethod; + end; +end; + +procedure TmwSimplePasPar.FunctionProcedureBlock; +var + HasBlock: Boolean; +begin + HasBlock := True; + if TokenID = ptSemiColon then Semicolon; + + while ExID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptDelayed, ptFar, + ptMessage, ptNear, ptOverload, ptOverride, ptPascal, ptRegister, + ptReintroduce, ptSafeCall, ptStdCall, ptVirtual, ptLibrary, + ptPlatform, ptLocal, ptVarargs, ptAssembler, ptStatic, ptInline, ptForward, + ptExperimental, ptDeprecated, ptNoreturn] do + begin + case ExId of + ptExternal: + begin + ProceduralDirective; + HasBlock := False; + end; + ptForward: + begin + ForwardDeclaration; + HasBlock := False; + end + else + begin + ProceduralDirective; + end; + end; + if TokenID = ptSemiColon then Semicolon; + end; + + if HasBlock then + begin + case TokenID of + ptAsm: + begin + AsmStatement; + end; + else + begin + Block; + end; + end; + Semicolon; + end; +end; + +procedure TmwSimplePasPar.ExternalDirective; +begin + ExpectedEx(ptExternal); + case TokenID of + ptSemiColon: + begin + Semicolon; + end; + else + begin + if FLexer.ExID <> ptName then + SimpleExpression; + + if FLexer.ExID = ptDelayed then + NextToken; + + ExternalDirectiveTwo; + end; + end; +end; + +procedure TmwSimplePasPar.ExternalDirectiveTwo; +begin + case FLexer.ExID of + ptIndex: + begin + IndexSpecifier; + end; + ptName: + begin + NextToken; + SimpleExpression; + end; + ptSemiColon: + begin + Semicolon; + ExternalDirectiveThree; + end; + end +end; + +procedure TmwSimplePasPar.ExternalDirectiveThree; +begin + case TokenID of + ptMinus: + begin + NextToken; + end; + end; + case TokenID of + ptIdentifier, ptIntegerConst: + begin + NextToken; + end; + end; +end; + +procedure TmwSimplePasPar.ForStatement; +begin + Expected(ptFor); + if TokenID = ptVar then + begin + NextToken; + InlineVarDeclaration; + end + else + QualifiedIdentifier; + + if Lexer.TokenID = ptAssign then + begin + Expected(ptAssign); + ForStatementFrom; + case TokenID of + ptTo: + begin + ForStatementTo; + end; + ptDownTo: + begin + ForStatementDownTo; + end; + else + begin + SynError(InvalidForStatement); + end; + end; + end else + if Lexer.TokenID = ptIn then + ForStatementIn; + Expected(ptDo); + Statement; +end; + +procedure TmwSimplePasPar.ForStatementDownTo; +begin + Expected(ptDownTo); + Expression; +end; + +procedure TmwSimplePasPar.ForStatementFrom; +begin + Expression; +end; + +procedure TmwSimplePasPar.ForStatementIn; +begin + Expected(ptIn); + Expression; +end; + +procedure TmwSimplePasPar.ForStatementTo; +begin + Expected(ptTo); + Expression; +end; + +procedure TmwSimplePasPar.WhileStatement; +begin + Expected(ptWhile); + Expression; + Expected(ptDo); + Statement; +end; + +procedure TmwSimplePasPar.RepeatStatement; +begin + Expected(ptRepeat); + StatementList; + Expected(ptUntil); + Expression; +end; + +procedure TmwSimplePasPar.CaseStatement; +begin + Expected(ptCase); + Expression; + Expected(ptOf); + CaseSelector; + while TokenID = ptSemiColon do + begin + Semicolon; + case TokenID of + ptElse, ptEnd: ; + else + CaseSelector; + end; + end; + if TokenID = ptElse then + CaseElseStatement; + Expected(ptEnd); +end; + +procedure TmwSimplePasPar.CaseSelector; +begin + CaseLabelList; + Expected(ptColon); + case TokenID of + ptSemiColon: EmptyStatement; + else + Statement; + end; +end; + +procedure TmwSimplePasPar.CaseElseStatement; +begin + Expected(ptElse); + StatementList; + Semicolon; +end; + +procedure TmwSimplePasPar.CaseLabel; +begin + ConstantExpression; + if TokenID = ptDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.IfStatement; +begin + Expected(ptIf); + Expression; + ThenStatement; + if TokenID = ptElse then + ElseStatement; +end; + +procedure TmwSimplePasPar.TernaryOp; +begin + Expected(ptIf); + Expression; + ThenExpression; + ElseExpression; +end; + +procedure TmwSimplePasPar.ExceptBlock; +begin + if ExID = ptOn then + begin + ExceptionHandlerList; + if TokenID = ptElse then + ExceptionBlockElseBranch; + end else + if TokenID = ptElse then + ExceptionBlockElseBranch + else + StatementList; +end; + +procedure TmwSimplePasPar.ExceptionHandlerList; +begin + while FLexer.ExID = ptOn do + begin + ExceptionHandler; + Semicolon; + end; +end; + +procedure TmwSimplePasPar.ExceptionHandler; +begin + ExpectedEx(ptOn); + ExceptionIdentifier; + Expected(ptDo); + Statement; +end; + +procedure TmwSimplePasPar.ExceptionBlockElseBranch; +begin + NextToken; + StatementList; +end; + +procedure TmwSimplePasPar.ExceptionIdentifier; +begin + Lexer.InitAhead; + case Lexer.AheadTokenID of + ptPoint: + begin + ExceptionClassTypeIdentifier; + end; + ptColon: + begin + ExceptionVariable; + end + else + begin + ExceptionClassTypeIdentifier; + end; + end; +end; + +procedure TmwSimplePasPar.ExceptionClassTypeIdentifier; +begin + TypeKind; +end; + +procedure TmwSimplePasPar.ExceptionVariable; +begin + Expected(ptIdentifier); + Expected(ptColon); + ExceptionClassTypeIdentifier; +end; + +procedure TmwSimplePasPar.InlineConstSection; +begin + case TokenID of + ptConst: + begin + NextToken; + ConstantDeclaration; + end; + else + begin + SynError(InvalidConstSection); + end; + end; +end; + +procedure TmwSimplePasPar.InlineStatement; +begin + Expected(ptInline); + Expected(ptRoundOpen); + Expected(ptIntegerConst); + while (TokenID = ptSlash) do + begin + NextToken; + Expected(ptIntegerConst); + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.InlineVarSection; +begin + Expected(ptVar); + while TokenID = ptIdentifier do + InlineVarDeclaration; + + if TokenID = ptAssign then + begin + NextToken; + Expression; + end; +end; + +procedure TmwSimplePasPar.InlineVarDeclaration; +begin + VarNameList; + if TokenID = ptColon then + begin + NextToken; + TypeKind; + end; +end; + +procedure TmwSimplePasPar.InParameter; +begin + Expected(ptIn); + ParameterNameList; + case TokenID of + ptColon: + begin + NextToken; + FormalParameterType; + if TokenID = ptEqual then + begin + NextToken; + TypedConstant; + end; + end + end; +end; + +procedure TmwSimplePasPar.AsmStatement; +begin + Lexer.AsmCode := True; + Expected(ptAsm); + { should be replaced with a Assembler lexer } + while TokenID <> ptEnd do + case FLexer.TokenID of + ptAddressOp: + begin + NextToken; + NextToken; + end; + ptDoubleAddressOp: + begin + NextToken; + NextToken; + end; + ptNull: + begin + Expected(ptEnd); + Exit; + end; + else + NextToken; + end; + Lexer.AsmCode := False; + Expected(ptEnd); +end; + +procedure TmwSimplePasPar.AsOp; +begin + Expected(ptAs); +end; + +procedure TmwSimplePasPar.AssignOp; +begin + Expected(ptAssign); +end; + +procedure TmwSimplePasPar.AtExpression; +begin + ExpectedEx(ptAt); + Expression; +end; + +procedure TmwSimplePasPar.RaiseStatement; +begin + Expected(ptRaise); + case TokenID of + ptAddressOp, ptDoubleAddressOp, ptIdentifier, ptRoundOpen: + begin + Expression; + end; + end; + if ExID = ptAt then + AtExpression; +end; + +procedure TmwSimplePasPar.TryStatement; +begin + Expected(ptTry); + StatementList; + case TokenID of + ptExcept: + begin + NextToken; + ExceptBlock; + Expected(ptEnd); + end; + ptFinally: + begin + NextToken; + FinallyBlock; + Expected(ptEnd); + end; + else + begin + SynError(InvalidTryStatement); + end; + end; +end; + +procedure TmwSimplePasPar.WithStatement; +begin + Expected(ptWith); + WithExpressionList; + Expected(ptDo); + Statement; +end; + +procedure TmwSimplePasPar.WithExpressionList; +begin + Expression; + while FLexer.TokenID = ptComma do + begin + NextToken; + Expression; + end; +end; + +procedure TmwSimplePasPar.StatementList; +begin + Statements; +end; + +procedure TmwSimplePasPar.StatementOrExpression; +begin + if TokenID = ptGoto then + SimpleStatement + else + begin + InitAhead; + AheadParse.Designator; + + if AheadParse.TokenId in [ptAssign, ptSemicolon, ptElse] then + SimpleStatement + else + Expression; + end; +end; + +procedure TmwSimplePasPar.Statements; +begin {removed ptIntegerConst jdj-Put back in for labels} + while TokenID in [ptAddressOp, ptAsm, ptBegin, ptCase, ptConst, ptDoubleAddressOp, + ptFor, ptGoTo, ptIdentifier, ptIf, ptInherited, ptInline, ptIntegerConst, + ptPointerSymbol, ptRaise, ptRoundOpen, ptRepeat, ptSemiColon, ptString, + ptTry, ptVar, ptWhile, ptWith] do + begin + Statement; + Semicolon; + end; +end; + +procedure TmwSimplePasPar.SimpleStatement; +begin + case TokenID of + ptAddressOp, ptDoubleAddressOp, ptIdentifier, ptRoundOpen, ptString: + begin + Designator; + if TokenID = ptAssign then + begin + AssignOp; + Expression; + end; + end; + ptGoTo: + begin + GotoStatement; + end; + end; +end; + +procedure TmwSimplePasPar.Statement; +begin + case TokenID of + ptAsm: + begin + AsmStatement; + end; + ptBegin: + begin + CompoundStatement; + end; + ptCase: + begin + CaseStatement; + end; + ptConst: + begin + InlineConstSection; + end; + ptFor: + begin + ForStatement; + end; + ptIf: + begin + IfStatement; + end; + ptIdentifier: + begin + FLexer.InitAhead; + case Lexer.AheadTokenID of + ptColon: + begin + LabeledStatement; + end; + else + begin + StatementOrExpression; + end; + end; + end; + ptInherited: + begin + InheritedStatement; + end; + ptInLine: + begin + InlineStatement; + end; + ptIntegerConst: + begin + FLexer.InitAhead; + case Lexer.AheadTokenID of + ptColon: + begin + LabeledStatement; + end; + else + begin + SynError(InvalidLabeledStatement); + NextToken; + end; + end; + end; + ptRepeat: + begin + RepeatStatement; + end; + ptRaise: + begin + RaiseStatement; + end; + ptSemiColon: + begin + EmptyStatement; + end; + ptTry: + begin + TryStatement; + end; + ptVar: + begin + InlineVarSection; + end; + ptWhile: + begin + WhileStatement; + end; + ptWith: + begin + WithStatement; + end; + else + begin + StatementOrExpression; + end; + end; +end; + +procedure TmwSimplePasPar.ElseExpression; +begin + Expected(ptElse); + Expression; +end; + +procedure TmwSimplePasPar.ElseStatement; +begin + Expected(ptElse); + Statement; +end; + +procedure TmwSimplePasPar.EmptyStatement; +begin + { Nothing to do here. + The semicolon will be removed in StatementList } +end; + +procedure TmwSimplePasPar.InheritedStatement; +begin + Expected(ptInherited); + if TokenID = ptIdentifier then + Statement; +end; + +procedure TmwSimplePasPar.LabeledStatement; +begin + case TokenID of + ptIdentifier: + begin + NextToken; + Expected(ptColon); + Statement; + end; + ptIntegerConst: + begin + NextToken; + Expected(ptColon); + Statement; + end; + else + begin + SynError(InvalidLabeledStatement); + end; + end; +end; + +procedure TmwSimplePasPar.StringStatement; +begin + Expected(ptString); +end; + +procedure TmwSimplePasPar.SetElement; +begin + Expression; + if TokenID = ptDotDot then + begin + NextToken; + Expression; + end; +end; + +procedure TmwSimplePasPar.SetIncludeHandler(IncludeHandler: IIncludeHandler); +begin + FLexer.IncludeHandler := IncludeHandler; +end; + +procedure TmwSimplePasPar.SetOnComment(const Value: TCommentEvent); +begin + FLexer.OnComment := Value; +end; + +procedure TmwSimplePasPar.QualifiedIdentifier; +begin + Identifier; + + while TokenID = ptPoint do + begin + DotOp; + Identifier; + end; +end; + +procedure TmwSimplePasPar.SetConstructor; +begin + Expected(ptSquareOpen); + if TokenID <> ptSquareClose then + begin + SetElement; + while TokenID = ptComma do + begin + NextToken; + SetElement; + end; + end; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.Number; +begin + case TokenID of + ptFloat: + begin + NextToken; + end; + ptIntegerConst: + begin + NextToken; + end; + ptIdentifier: + begin + NextToken; + end; + else + begin + SynError(InvalidNumber); + end; + end; +end; + +procedure TmwSimplePasPar.ExpressionList; +begin + Expression; + if TokenID = ptAssign then + begin + Expected(ptAssign); + Expression; + end; + while TokenID = ptComma do + begin + NextToken; + Expression; + if TokenID = ptAssign then + begin + Expected(ptAssign); + Expression; + end; + end; +end; + +procedure TmwSimplePasPar.Designator; +begin + VariableReference; +end; + +procedure TmwSimplePasPar.MultiplicativeOperator; +begin + case TokenID of + ptAnd: + begin + NextToken; + end; + ptDiv: + begin + NextToken; + end; + ptMod: + begin + NextToken; + end; + ptShl: + begin + NextToken; + end; + ptShr: + begin + NextToken; + end; + ptSlash: + begin + NextToken; + end; + ptStar: + begin + NextToken; + end; + else + begin SynError(InvalidMultiplicativeOperator); + end; + end; +end; + +procedure TmwSimplePasPar.Factor; +begin + case TokenID of + ptIf: + begin + TernaryOp; + end; + ptAsciiChar, ptStringConst: + begin + CharString; + end; + ptAddressOp, ptDoubleAddressOp, ptIdentifier, ptInherited, ptPointerSymbol: + begin + Designator; + end; + ptRoundOpen: + begin + RoundOpen; + ExpressionList; + RoundClose; + end; + ptIntegerConst, ptFloat: + begin + Number; + end; + ptNil: + begin + NilToken; + end; + ptMinus: + begin + UnaryMinus; + Factor; + end; + ptNot: + begin + NotOp; + Factor; + end; + ptPlus: + begin + NextToken; + Factor; + end; + ptSquareOpen: + begin + SetConstructor; + end; + ptString: + begin + StringStatement; + end; + ptFunction, ptProcedure: + AnonymousMethod; + end; + + while TokenID = ptSquareOpen do + IndexOp; + + while TokenID = ptPointerSymbol do + PointerSymbol; + + if TokenID = ptRoundOpen then + Factor; + + while TokenID = ptPoint do + begin + DotOp; + Factor; + end; +end; + +procedure TmwSimplePasPar.AdditiveOperator; +begin + if TokenID in [ptMinus, ptOr, ptPlus, ptXor] then + begin + NextToken; + end + else + begin + SynError(InvalidAdditiveOperator); + end; +end; + +procedure TmwSimplePasPar.AddressOp; +begin + Expected(ptAddressOp); +end; + +procedure TmwSimplePasPar.AlignmentParameter; +begin + SimpleExpression; +end; + +procedure TmwSimplePasPar.Term; +begin + Factor; + while TokenID in [ptAnd, ptDiv, ptMod, ptShl, ptShr, ptSlash, ptStar] do + begin + MultiplicativeOperator; + Factor; + end; +end; + +procedure TmwSimplePasPar.RelativeOperator; +begin + case TokenID of + ptAs: + begin + NextToken; + end; + ptEqual: + begin + NextToken; + end; + ptGreater: + begin + NextToken; + end; + ptGreaterEqual: + begin + NextToken; + end; + ptIn: + begin + NextToken; + end; + ptIs: + begin + NextToken; + end; + ptLower: + begin + NextToken; + end; + ptLowerEqual: + begin + NextToken; + end; + ptNotEqual: + begin + NextToken; + end; + else + begin + SynError(InvalidRelativeOperator); + end; + end; +end; + +procedure TmwSimplePasPar.SimpleExpression; +begin + Term; + while TokenID in [ptMinus, ptOr, ptPlus, ptXor] do + begin + AdditiveOperator; + Term; + end; + + case TokenID of + ptAs: + begin + AsOp; + TypeId; + end; + end; +end; + +procedure TmwSimplePasPar.Expression; +begin + SimpleExpression; + + //JT 2006-07-17 The Delphi language guide has this as + //Expression -> SimpleExpression [RelOp SimpleExpression]... + //So this needs to be able to repeat itself. + case TokenID of + ptEqual, ptGreater, ptGreaterEqual, ptLower, ptLowerEqual, ptIn, + ptNotEqual, ptNot, ptIs: + begin + while TokenID in [ptEqual, ptGreater, ptGreaterEqual, ptLower, ptLowerEqual, + ptIn, ptNotEqual{, ptColon}, ptNot, ptIs] do + begin + if TokenID = ptNot then + begin + Lexer.InitAhead; + if Lexer.AheadTokenID = ptIn then + begin + NotInOp; + SimpleExpression; + Continue; + end; + end; + + if TokenID = ptIs then + begin + Lexer.InitAhead; + if Lexer.AheadTokenID = ptNot then + begin + IsNotOp; + SimpleExpression; + Continue; + end; + end; + + RelativeOperator; + SimpleExpression; + end; + end; + ptColon: + begin + case InRound of + False: ; + True: + while TokenID = ptColon do + begin + NextToken; + AlignmentParameter; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.VarDeclaration; +begin + VarNameList; + Expected(ptColon); + TypeKind; + TypeDirective; + + case GenID of + ptAbsolute: + begin + VarAbsolute; + end; + ptEqual: + begin + VarEqual; + end; + end; + TypeDirective; +end; + +procedure TmwSimplePasPar.VarAbsolute; +begin + ExpectedEx(ptAbsolute); + ConstantValue; +end; + +procedure TmwSimplePasPar.VarEqual; +begin + Expected(ptEqual); + ConstantValueTyped; +end; + +procedure TmwSimplePasPar.VarNameList; +begin + VarName; + while TokenID = ptComma do + begin + NextToken; + VarName; + end; +end; + +procedure TmwSimplePasPar.VarName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.DirectiveCalling; +begin + case ExID of + ptCdecl: + begin + NextToken; + end; + ptPascal: + begin + NextToken; + end; + ptRegister: + begin + NextToken; + end; + ptSafeCall: + begin + NextToken; + end; + ptStdCall: + begin + NextToken; + end; + else + begin + SynError(InvalidDirectiveCalling); + end; + end; +end; + +procedure TmwSimplePasPar.RecordVariant; +begin + ConstantExpression; + while (TokenID = ptComma) do + begin + NextToken; + ConstantExpression; + end; + Expected(ptColon); + Expected(ptRoundOpen); + if TokenID <> ptRoundClose then + begin + FieldList; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.VariantSection; +begin + Expected(ptCase); + TagField; + Expected(ptOf); + RecordVariant; + while TokenID = ptSemiColon do + begin + Semicolon; + case TokenID of + ptEnd, ptRoundClose: Break; + else + RecordVariant; + end; + end; +end; + +procedure TmwSimplePasPar.TagField; +begin + TagFieldName; + case FLexer.TokenID of + ptColon: + begin + NextToken; + TagFieldTypeName; + end; + end; +end; + +procedure TmwSimplePasPar.TagFieldName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.TagFieldTypeName; +begin + OrdinalType; +end; + +procedure TmwSimplePasPar.FieldDeclaration; +begin + if TokenID = ptSquareOpen then + CustomAttribute; + FieldNameList; + Expected(ptColon); + TypeKind; + TypeDirective; +end; + +procedure TmwSimplePasPar.FieldList; +begin + while TokenID in [ptIdentifier, ptSquareOpen] do + begin + FieldDeclaration; + Semicolon; + end; + if TokenID = ptCase then + begin + VariantSection; + end; +end; + +procedure TmwSimplePasPar.FieldName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.FieldNameList; +begin + FieldName; + while TokenID = ptComma do + begin + NextToken; + FieldName; + end; +end; + +procedure TmwSimplePasPar.RecordType; +begin + Expected(ptRecord); + if TokenID = ptSemicolon then + Exit; + + if ExID = ptHelper then + ClassHelper; + + if TokenID = ptRoundOpen then + begin + ClassHeritage; + if TokenID = ptSemicolon then + Exit; + end; + ClassMemberList; + Expected(ptEnd); + + ClassTypeEnd; + RecordAlign; +end; + +procedure TmwSimplePasPar.FileType; +begin + Expected(ptFile); + if TokenID = ptOf then + begin + NextToken; + TypeId; + end; +end; + +procedure TmwSimplePasPar.FinalizationSection; +begin + Expected(ptFinalization); + StatementList; +end; + +procedure TmwSimplePasPar.FinallyBlock; +begin + StatementList; +end; + +procedure TmwSimplePasPar.SetType; +begin + Expected(ptSet); + Expected(ptOf); + OrdinalType; +end; + +procedure TmwSimplePasPar.SetUseDefines(const Value: Boolean); +begin + FLexer.UseDefines := Value; +end; + +procedure TmwSimplePasPar.ArrayType; +begin + Expected(ptArray); + ArrayBounds; + Expected(ptOf); + TypeKind; +end; + +procedure TmwSimplePasPar.EnumeratedType; +begin + Expected(ptRoundOpen); + EnumeratedTypeItem; + while TokenID = ptComma do + begin + NextToken; + EnumeratedTypeItem; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.SubrangeType; +begin + ConstantExpression; + if TokenID = ptDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.RealIdentifier; +begin + case ExID of + ptReal48: + begin + NextToken; + end; + ptReal: + begin + NextToken; + end; + ptSingle: + begin + NextToken; + end; + ptDouble: + begin + NextToken; + end; + ptExtended: + begin + NextToken; + end; + ptCurrency: + begin + NextToken; + end; + ptComp: + begin + NextToken; + end; + else + begin + SynError(InvalidRealIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.RealType; +begin + case TokenID of + ptMinus: + begin + NextToken; + end; + ptPlus: + begin + NextToken; + end; + end; + case TokenId of + ptFloat: + begin + NextToken; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.OrdinalIdentifier; +begin + case ExID of + ptBoolean: + begin + NextToken; + end; + ptByte: + begin + NextToken; + end; + ptBytebool: + begin + NextToken; + end; + ptCardinal: + begin + NextToken; + end; + ptChar: + begin + NextToken; + end; + ptDWord: + begin + NextToken; + end; + ptInt64: + begin + NextToken; + end; + ptInteger: + begin + NextToken; + end; + ptLongBool: + begin + NextToken; + end; + ptLongInt: + begin + NextToken; + end; + ptLongWord: + begin + NextToken; + end; + ptPChar: + begin + NextToken; + end; + ptShortInt: + begin + NextToken; + end; + ptSmallInt: + begin + NextToken; + end; + ptWideChar: + begin + NextToken; + end; + ptWord: + begin + NextToken; + end; + ptWordbool: + begin + NextToken; + end; + else + begin + SynError(InvalidOrdinalIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.OrdinalType; +begin + case TokenID of + ptIdentifier: + begin + Lexer.InitAhead; + case Lexer.AheadTokenID of + ptPoint: + begin + TypeId; + end; + ptRoundOpen, ptDotDot: + begin + ConstantExpression; + end; + else + begin + TypeID; + end; + end; + end; + ptRoundOpen: + begin + EnumeratedType; + end; + ptSquareOpen: + begin + NextToken; + SubrangeType; + Expected(ptSquareClose); + end; + else + begin + ConstantExpression; + end; + end; + if TokenID = ptDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.VariableReference; +begin + case TokenID of + ptRoundOpen: + begin + RoundOpen; + Expression; + RoundClose; + VariableTail; + end; + ptSquareOpen: + begin + SetConstructor; + end; + ptAddressOp: + begin + AddressOp; + VariableReference; + end; + ptDoubleAddressOp: + begin + NextToken; + VariableReference; + end; + ptInherited: + begin + InheritedVariableReference; + end; + else + variable; + end; +end; + +procedure TmwSimplePasPar.Variable; (* Attention: could also came from proc_call ! ! *) +begin + QualifiedIdentifier; + VariableTail; +end; + +procedure TmwSimplePasPar.VariableTail; +begin + case TokenID of + ptRoundOpen: + begin + RoundOpen; + ExpressionList; + RoundClose; + end; + ptSquareOpen: + begin + IndexOp; + end; + ptPointerSymbol: + begin + PointerSymbol; + end; + ptLower: + begin + InitAhead; + AheadParse.NextToken; + AheadParse.TypeArgs; + + if AheadParse.TokenId = ptGreater then + begin + NextToken; + TypeArgs; + Expected(ptGreater); + case TokenID of + ptAddressOp, ptDoubleAddressOp, ptIdentifier: + begin + VariableReference; + end; + ptPoint, ptPointerSymbol, ptRoundOpen, ptSquareOpen: + begin + VariableTail; + end; + end; + end; + end; + end; + + case TokenID of + ptRoundOpen, ptSquareOpen, ptPointerSymbol: + begin + VariableTail; + end; + ptPoint: + begin + DotOp; + Variable; + end; + ptAs: + begin + AsOp; + SimpleExpression; + end; + end; +end; + +procedure TmwSimplePasPar.InterfaceType; +begin + case TokenID of + ptInterface: + begin + NextToken; + end; + ptDispInterface: + begin + NextToken; + end + else + begin + SynError(InvalidInterfaceType); + end; + end; + case TokenID of + ptEnd: + begin + NextToken; { Direct descendant without new members } + end; + ptRoundOpen: + begin + InterfaceHeritage; + case TokenID of + ptEnd: + begin + NextToken; { No new members } + end; + ptSemiColon: ; { No new members } + else + begin + if TokenID = ptSquareOpen then + begin + InterfaceGUID; + end; + InterfaceMemberList; + Expected(ptEnd); + end; + end; + end; + else + begin + if TokenID = ptSquareOpen then + begin + InterfaceGUID; + end; + InterfaceMemberList; { Direct descendant } + Expected(ptEnd); + end; + end; +end; + +procedure TmwSimplePasPar.InterfaceMemberList; +begin + while TokenID in [ptSquareOpen, ptFunction, ptProcedure, ptProperty] do + begin + while TokenID = ptSquareOpen do + CustomAttribute; + + ClassMethodOrProperty; + end; +end; + +procedure TmwSimplePasPar.ClassType; +begin + Expected(ptClass); + case TokenID of + ptIdentifier: //NASTY hack because Abstract is generally an ExID, except in this case when it should be a keyword. + begin + if Lexer.ExID = ptAbstract then + Expected(ptIdentifier); + + if Lexer.ExID = ptHelper then + ClassHelper; + end; + ptSealed: + Expected(ptSealed); + end; + case TokenID of + ptEnd: + begin + ClassTypeEnd; + NextToken; { Direct descendant of TObject without new members } + end; + ptRoundOpen: + begin + ClassHeritage; + case TokenID of + ptEnd: + begin + Expected(ptEnd); + ClassTypeEnd; + end; + ptSemiColon: ClassTypeEnd; + else + begin + ClassMemberList; { Direct descendant of TObject } + Expected(ptEnd); + ClassTypeEnd; + end; + end; + end; + ptSemicolon: ClassTypeEnd; + else + begin + ClassMemberList; { Direct descendant of TObject } + Expected(ptEnd); + ClassTypeEnd; + end; + end; +end; + +procedure TmwSimplePasPar.ClassHelper; +begin + ExpectedEx(ptHelper); + if TokenID = ptRoundOpen then + ClassHeritage; + Expected(ptFor); + TypeId; +end; + +procedure TmwSimplePasPar.ClassHeritage; +begin + Expected(ptRoundOpen); + AncestorIdList; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.ClassVisibility; +var + IsStrict: boolean; +begin + IsStrict := ExID = ptStrict; + if IsStrict then + ExpectedEx(ptStrict); + + while ExID in [ptAutomated, ptPrivate, ptProtected, ptPublic, ptPublished] do + begin + Lexer.InitAhead; + case Lexer.AheadExID of + ptColon, ptComma: ; + else + case ExID of + ptAutomated: + begin + VisibilityAutomated; + end; + ptPrivate: + begin + if IsStrict then + VisibilityStrictPrivate + else + VisibilityPrivate; + end; + ptProtected: + begin + if IsStrict then + VisibilityStrictProtected + else + VisibilityProtected; + end; + ptPublic: + begin + VisibilityPublic; + end; + ptPublished: + begin + VisibilityPublished; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.VisibilityAutomated; +begin + ExpectedEx(ptAutomated); +end; + +procedure TmwSimplePasPar.VisibilityStrictPrivate; +begin + ExpectedEx(ptPrivate); +end; + +procedure TmwSimplePasPar.VisibilityPrivate; +begin + ExpectedEx(ptPrivate); +end; + +procedure TmwSimplePasPar.VisibilityStrictProtected; +begin + ExpectedEx(ptProtected); +end; + +procedure TmwSimplePasPar.VisibilityProtected; +begin + ExpectedEx(ptProtected); +end; + +procedure TmwSimplePasPar.VisibilityPublic; +begin + ExpectedEx(ptPublic); +end; + +procedure TmwSimplePasPar.VisibilityPublished; +begin + ExpectedEx(ptPublished); +end; + +procedure TmwSimplePasPar.VisibilityUnknown; +begin +end; + +procedure TmwSimplePasPar.ClassMemberList; +begin + while (TokenID in [ptClass, ptConstructor, ptDestructor, ptFunction, + ptIdentifier, ptProcedure, ptProperty, ptType, ptSquareOpen, ptVar, ptConst, ptCase]) or (ExID = ptStrict) do + begin + ClassVisibility; + + if TokenID = ptSquareOpen then + CustomAttribute; + + if (TokenID = ptIdentifier) and + not (ExID in [ptPrivate, ptProtected, ptPublished, ptPublic, ptStrict]) then + begin + InitAhead; + AheadParse.NextToken; + + if AheadParse.TokenId = ptEqual then + ConstantDeclaration + else + begin + ClassField; + if TokenID = ptEqual then + begin + NextToken; + TypedConstant; + end; + end; + + Semicolon; + end + else if TokenID in [ptClass, ptConstructor, ptDestructor, ptFunction, + ptProcedure, ptProperty, ptVar, ptConst] then + begin + ClassMethodOrProperty; + end; + if TokenID = ptType then + TypeSection; + if TokenID = ptCase then + begin + VariantSection; + end; + end; +end; + +procedure TmwSimplePasPar.ClassMethodOrProperty; +var + CurToken: TptTokenKind; +begin + if TokenID = ptClass then + begin + InitAhead; + AheadParse.NextToken; + CurToken := AheadParse.TokenID; + end else + CurToken := TokenID; + + case CurToken of + ptProperty: + begin + ClassProperty; + end; + ptVar, ptThreadVar: + begin + if TokenID = ptClass then + ClassClass; + + NextToken; + while (TokenID = ptIdentifier) and (ExID = ptUnknown) do + begin + ClassField; + Semicolon; + end; + end; + ptConst: + begin + if TokenID = ptClass then + ClassClass; + + NextToken; + while (TokenID = ptIdentifier) and (ExID = ptUnknown) do + begin + ConstantDeclaration; + Semicolon; + end; + end; + else + begin + ClassMethodHeading; + end; + end; +end; + +procedure TmwSimplePasPar.ClassProperty; +begin + if TokenID = ptClass then + ClassClass; + + Expected(ptProperty); + PropertyName; + case TokenID of + ptColon, ptSquareOpen: + begin + PropertyInterface; + end; + end; + PropertySpecifiers; + case ExID of + ptDefault: + begin + PropertyDefault; + Semicolon; + end; + end; +end; + +procedure TmwSimplePasPar.PropertyName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ClassField; +begin + if TokenID = ptSquareOpen then + CustomAttribute; + FieldNameList; + Expected(ptColon); + TypeKind; + TypeDirective; +end; + +procedure TmwSimplePasPar.ObjectType; +begin + Expected(ptObject); + case TokenID of + ptEnd: + begin + ObjectTypeEnd; + NextToken; { Direct descendant without new members } + end; + ptRoundOpen: + begin + ObjectHeritage; + case TokenID of + ptEnd: + begin + Expected(ptEnd); + ObjectTypeEnd; + end; + ptSemiColon: ObjectTypeEnd; + else + begin + ObjectMemberList; { Direct descendant } + Expected(ptEnd); + ObjectTypeEnd; + end; + end; + end; + else + begin + ObjectMemberList; { Direct descendant } + Expected(ptEnd); + ObjectTypeEnd; + end; + end; +end; + +procedure TmwSimplePasPar.ObjectHeritage; +begin + Expected(ptRoundOpen); + AncestorIdList; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.ObjectMemberList; +begin {jdj added ptProperty-call to ObjectProperty 02/07/2001} + ObjectVisibility; + while TokenID in [ptConstructor, ptDestructor, ptFunction, ptIdentifier, + ptProcedure, ptProperty] do + begin + while TokenID = ptIdentifier do + begin + ObjectField; + Semicolon; + ObjectVisibility; + end; + while TokenID in [ptConstructor, ptDestructor, ptFunction, ptProcedure, ptProperty] do + begin + case TokenID of + ptConstructor, ptDestructor, ptFunction, ptProcedure: + ObjectMethodHeading; + ptProperty: + ObjectProperty; + end; + end; + ObjectVisibility; + end; +end; + +procedure TmwSimplePasPar.ObjectVisibility; +begin + while ExID in [ptPrivate, ptProtected, ptPublic] do + begin + Lexer.InitAhead; + case Lexer.AheadExID of + ptColon, ptComma: ; + else + case ExID of + ptPrivate: + begin + VisibilityPrivate; + end; + ptProtected: + begin + VisibilityProtected; + end; + ptPublic: + begin + VisibilityPublic; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.ObjectField; +begin + IdentifierList; + Expected(ptColon); + TypeKind; + TypeDirective; +end; + +procedure TmwSimplePasPar.ClassReferenceType; +begin + Expected(ptClass); + Expected(ptOf); + TypeId; +end; + +procedure TmwSimplePasPar.VariantIdentifier; +begin + case ExID of + ptOleVariant: + begin + NextToken; + end; + ptVariant: + begin + NextToken; + end; + else + begin + SynError(InvalidVariantIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.ProceduralType; +var + TheTokenID: TptTokenKind; +begin + case TokenID of + ptFunction: + begin + NextToken; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + Expected(ptColon); + ReturnType; + end; + ptProcedure: + begin + NextToken; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + end; + else + begin + SynError(InvalidProceduralType); + end; + end; + if TokenID = ptOf then + ProceduralDirectiveOf; + + Lexer.InitAhead; + case TokenID of + ptSemiColon: TheTokenID := Lexer.AheadExID; + else + TheTokenID := ExID; + end; + while TheTokenID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, + ptMessage, ptNear, ptOverload, ptOverride, ptPascal, ptRegister, + ptReintroduce, ptSafeCall, ptStdCall, ptVirtual, ptStatic, ptInline, ptVarargs, ptNoreturn] do + // DR 2001-11-14 no checking for deprecated etc. since it's captured by the typedecl + begin + if TokenID = ptSemiColon then Semicolon; + ProceduralDirective; + Lexer.InitAhead; + case TokenID of + ptSemiColon: TheTokenID := Lexer.AheadExID; + else + TheTokenID := ExID; + end; + end; + + if TokenID = ptOf then + ProceduralDirectiveOf; +end; + +procedure TmwSimplePasPar.StringConst; +begin + StringConstSimple; + while TokenID in [ptStringConst, ptAsciiChar] do + StringConstSimple; +end; + +procedure TmwSimplePasPar.StringConstSimple; +begin + NextToken; +end; + +procedure TmwSimplePasPar.StringIdentifier; +begin + case ExID of + ptAnsiString: + begin + NextToken; + end; + ptShortString: + begin + NextToken; + end; + ptWideString: + begin + NextToken; + end; + else + begin + SynError(InvalidStringIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.StringType; +begin + case TokenID of + ptString: + begin + NextToken; + if TokenID = ptSquareOpen then + begin + NextToken; + ConstantExpression; + Expected(ptSquareClose); + end; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.PointerSymbol; +begin + Expected(ptPointerSymbol); +end; + +procedure TmwSimplePasPar.PointerType; +begin + Expected(ptPointerSymbol); + TypeId; +end; + +procedure TmwSimplePasPar.StructuredType; +begin + case TokenID of + ptArray: + begin + ArrayType; + end; + ptFile: + begin + FileType; + end; + ptRecord: + begin + RecordType; + end; + ptSet: + begin + SetType; + end; + ptObject: + begin + ObjectType; + end + else + begin + SynError(InvalidStructuredType); + end; + end; +end; + +procedure TmwSimplePasPar.SimpleType; +begin + case TokenID of + ptMinus: + begin + NextToken; + end; + ptPlus: + begin + NextToken; + end; + end; + case FLexer.TokenID of + ptAsciiChar, ptIntegerConst: + begin + OrdinalType; + end; + ptFloat: + begin + RealType; + end; + ptIdentifier: + begin + InitAhead; + AheadParse.NextToken; + AheadParse.SimpleExpression; + if AheadParse.TokenID = ptDotDot then + SubrangeType + else + TypeId; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.RecordAlign; +begin + if ExID = ptAlign then + begin + NextToken; + RecordAlignValue; + end; +end; + +procedure TmwSimplePasPar.RecordAlignValue; +begin + Expected(ptIntegerConst); +end; + +procedure TmwSimplePasPar.RecordFieldConstant; +begin + Expected(ptIdentifier); + Expected(ptColon); + TypedConstant; +end; + +procedure TmwSimplePasPar.RecordConstant; +begin + Expected(ptRoundOpen); + RecordFieldConstant; + while (TokenID = ptSemiColon) do + begin + Semicolon; + if TokenId <> ptRoundClose then + RecordFieldConstant; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.RecordConstraint; +begin + Expected(ptRecord); +end; + +procedure TmwSimplePasPar.ArrayConstant; +begin + Expected(ptRoundOpen); + + TypedConstant; + if TokenID = ptDotDot then + begin + NextToken; + TypedConstant; + end; + + while (TokenID = ptComma) do + begin + NextToken; + TypedConstant; + if TokenID = ptDotDot then + begin + NextToken; + TypedConstant; + end; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.ArrayDimension; +begin + OrdinalType; +end; + +procedure TmwSimplePasPar.ClassForward; +begin + Expected(ptClass); +end; + +procedure TmwSimplePasPar.DispInterfaceForward; +begin + Expected(ptDispInterface); +end; + +procedure TmwSimplePasPar.DotOp; +begin + Expected(ptPoint); +end; + +procedure TmwSimplePasPar.InterfaceForward; +begin + Expected(ptInterface); +end; + +procedure TmwSimplePasPar.ObjectForward; +begin + Expected(ptObject); +end; + +procedure TmwSimplePasPar.TypeDeclaration; +begin + TypeName; + Expected(ptEqual); + + Lexer.InitAhead; + + if TokenID = ptType then + begin + if Lexer.AheadTokenID = ptOf then + begin + TypeReferenceType; + TypeDirective; + Exit; + end else + ExplicitType; + end; + + if (TokenID = ptPacked) and (Lexer.AheadTokenID in [ptClass, ptObject]) then + NextToken; + + case TokenID of + ptPointerSymbol: + begin + PointerType; + end; + ptClass: + begin + case Lexer.AheadTokenID of + ptOf: + begin + ClassReferenceType; + end; + ptSemiColon: + begin + ClassForward; + end; + else + begin + ClassType; + end; + end; + end; + ptInterface: + begin + case Lexer.AheadTokenID of + ptSemiColon: + begin + InterfaceForward; + end; + else + begin + InterfaceType; + end; + end; + end; + ptDispInterface: + begin + case Lexer.AheadTokenID of + ptSemiColon: + begin + DispInterfaceForward; + end; + else + begin + InterfaceType; + end; + end; + end; + ptObject: + begin + case Lexer.AheadTokenID of + ptSemiColon: + begin + ObjectForward; + end; + else + begin + ObjectType; + end; + end; + end; + else + begin + if ExID = ptReference then + AnonymousMethodType + else + TypeKind; + end; + end; + TypeDirective; +end; + +procedure TmwSimplePasPar.TypeName; +begin + Expected(ptIdentifier); + if TokenId = ptLower then + TypeParams; +end; + +procedure TmwSimplePasPar.ExplicitType; +begin + Expected(ptType); +end; + +procedure TmwSimplePasPar.TypeKind; +begin + case TokenID of + ptAsciiChar, ptFloat, ptIntegerConst, ptMinus, ptNil, ptPlus, ptStringConst, ptConst: + begin + SimpleType; + end; + ptRoundOpen: + begin + EnumeratedType; + end; + ptSquareOpen: + begin + SubrangeType; + end; + ptArray, ptFile, ptPacked, ptRecord, ptSet: + begin + if TokenID = ptPacked then + NextToken; + StructuredType; + end; + ptFunction, ptProcedure: + begin + ProceduralType; + end; + ptIdentifier: + begin + InitAhead; + AheadParse.NextToken; + AheadParse.SimpleExpression; + if AheadParse.TokenID = ptDotDot then + SubrangeType + else + TypeId; + end; + ptPointerSymbol: + begin + PointerType; + end; + ptString: + begin + TypeId; + end; + else + begin + SynError(InvalidTypeKind); + end; + end; +end; + +procedure TmwSimplePasPar.TypeArgs; +begin + TypeKind; + while TokenId = ptComma do + begin + NextToken; + TypeKind; + end; +end; + +procedure TmwSimplePasPar.TypedConstant; +var + RoundBrackets: Integer; +begin + case TokenID of + ptRoundOpen: + begin + Lexer.InitAhead; + while Lexer.AheadTokenID <> ptSemiColon do + case Lexer.AheadTokenID of + ptAnd, ptBegin, ptCase, ptColon, ptEnd, ptElse, ptIf, ptMinus, ptNull, + ptOr, ptPlus, ptShl, ptShr, ptSlash, ptStar, ptWhile, ptWith, + ptXor: Break; + ptRoundOpen: + begin + RoundBrackets := 0; + repeat + case Lexer.AheadTokenID of + ptBegin, ptCase, ptEnd, ptElse, ptIf, ptNull, ptWhile, ptWith: Break; + else + if Lexer.AheadTokenID = ptRoundOpen then + Inc(RoundBrackets); + if Lexer.AheadTokenID = ptRoundClose then + Dec(RoundBrackets); + + Lexer.AheadNext; + end; + until RoundBrackets = 0; + end; + else + Lexer.AheadNext; + end; + case Lexer.AheadTokenID of + ptColon: + begin + RecordConstant; + end; + ptNull: ; + ptAnd, ptMinus, ptOr, ptPlus, ptShl, ptShr, ptSlash, ptStar, ptXor: + begin + ConstantExpression; + end; + else + begin + ArrayConstant; + end; + end; + end; + ptSquareOpen: + ConstantExpression; + else + begin + ConstantExpression; + end; + end; +end; + +procedure TmwSimplePasPar.TypeId; +begin + TypeSimple; + + while TokenID = ptPoint do + begin + Expected(ptPoint); + TypeSimple; + end; + + if TokenID = ptRoundOpen then + begin + Expected(ptRoundOpen); + SimpleExpression; + Expected(ptRoundClose); + end; +end; + +procedure TmwSimplePasPar.ConstantExpression; +begin + SimpleExpression; +end; + +procedure TmwSimplePasPar.ResourceDeclaration; +begin + ConstantName; + Expected(ptEqual); + + ResourceValue; + + TypeDirective; +end; + +procedure TmwSimplePasPar.ResourceValue; +begin + CharString; + while TokenID = ptPlus do + begin + NextToken; + CharString; + end; +end; + +procedure TmwSimplePasPar.ConstantDeclaration; +begin + ConstantName; + case TokenID of + ptEqual: + begin + ConstantEqual; + end; + ptColon: + begin + ConstantColon; + end; + else + begin + SynError(InvalidConstantDeclaration); + end; + end; + TypeDirective; +end; + +procedure TmwSimplePasPar.ConstantColon; +begin + Expected(ptColon); + ConstantType; + Expected(ptEqual); + ConstantValueTyped; +end; + +procedure TmwSimplePasPar.ConstantEqual; +begin + Expected(ptEqual); + ConstantValue; +end; + +procedure TmwSimplePasPar.ConstantValue; +begin + Expression; +end; + +procedure TmwSimplePasPar.ConstantValueTyped; +begin + TypedConstant; +end; + +procedure TmwSimplePasPar.ConstantName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ConstantType; +begin + TypeKind; +end; + +procedure TmwSimplePasPar.LabelId; +begin + case TokenID of + ptIntegerConst: + begin + NextToken; + end; + ptIdentifier: + begin + NextToken; + end; + else + begin + SynError(InvalidLabelId); + end; + end; +end; + +procedure TmwSimplePasPar.ProcedureDeclarationSection; +begin + if TokenID = ptClass then + begin + ClassMethod; + end; + case TokenID of + ptConstructor: + begin + ProcedureProcedureName; + end; + ptDestructor: + begin + ProcedureProcedureName; + end; + ptProcedure: + begin + ProcedureProcedureName; + end; + ptFunction: + begin + FunctionMethodDeclaration; + end; + ptIdentifier: + begin + if Lexer.ExID = ptOperator then + begin + FunctionMethodDeclaration; + end + else + SynError(InvalidProcedureDeclarationSection); + end; + else + begin + SynError(InvalidProcedureDeclarationSection); + end; + end; +end; + +procedure TmwSimplePasPar.LabelDeclarationSection; +begin + Expected(ptLabel); + LabelId; + while (TokenID = ptComma) do + begin + NextToken; + LabelId; + end; + Semicolon; +end; + +procedure TmwSimplePasPar.ProceduralDirective; +begin + case GenID of + ptAbstract: + begin + DirectiveBinding; + end; + ptCdecl, ptPascal, ptRegister, ptSafeCall, ptStdCall: + begin + DirectiveCalling; + end; + ptExport, ptFar, ptNear: + begin + Directive16Bit; + end; + ptExternal: + begin + ExternalDirective; + end; + ptDynamic, ptMessage, ptOverload, ptOverride, ptReintroduce, ptVirtual, ptNoreturn: + begin + DirectiveBinding; + end; + ptAssembler: + begin + NextToken; + end; + ptStatic: + begin + NextToken; + end; + ptInline: + begin + DirectiveInline; + end; + ptDeprecated: + DirectiveDeprecated; + ptLibrary: + DirectiveLibrary; + ptPlatform: + DirectivePlatform; + ptLocal: + DirectiveLocal; + ptVarargs: + DirectiveVarargs; + ptFinal, ptExperimental, ptDelayed: + NextToken; + else + begin + SynError(InvalidProceduralDirective); + end; + end; +end; + +procedure TmwSimplePasPar.ExportedHeading; +begin + case TokenID of + ptFunction: + begin + FunctionHeading; + end; + ptProcedure: + begin + ProcedureHeading; + end; + else + begin + SynError(InvalidExportedHeading); + end; + end; + if TokenID = ptSemiColon then Semicolon; + + //TODO: Add FINAL + while ExID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, + ptMessage, ptNear, ptOverload, ptOverride, ptPascal, ptRegister, + ptReintroduce, ptSafeCall, ptStdCall, ptVirtual, + ptDeprecated, ptLibrary, ptPlatform, ptLocal, ptVarargs, + ptStatic, ptInline, ptAssembler, ptForward, ptDelayed, ptNoreturn] do + begin + case ExID of + ptAssembler: NextToken; + ptForward: ForwardDeclaration; + else + ProceduralDirective; + end; + if TokenID = ptSemiColon then Semicolon; + end; +end; + +procedure TmwSimplePasPar.FunctionHeading; +begin + Expected(ptFunction); + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptColon then + begin + Expected(ptColon); + ReturnType; + end; +end; + +procedure TmwSimplePasPar.ProcedureHeading; +begin + Expected(ptProcedure); + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; +end; + +procedure TmwSimplePasPar.VarSection; +begin + case TokenID of + ptThreadVar: + begin + NextToken; + end; + ptVar: + begin + NextToken; + end; + else + begin + SynError(InvalidVarSection); + end; + end; + while TokenID in [ptIdentifier, ptSquareOpen] do + begin + if TokenID = ptSquareOpen then + CustomAttribute + else + begin + VarDeclaration; + Semicolon; + end; + end; +end; + +procedure TmwSimplePasPar.TypeSection; +begin + Expected(ptType); + + while (TokenID = ptIdentifier) or (Lexer.TokenID = ptSquareOpen) do + begin + if TokenID = ptSquareOpen then + CustomAttribute + else + begin + InitAhead; + AheadParse.NextToken; + if AheadParse.TokenID = ptLower then + AheadParse.TypeParams; + + if AheadParse.TokenID <> ptEqual then + Break; + + TypeDeclaration; + if TokenID = ptEqual then + TypedConstant; + Semicolon; + end; + end; +end; + +procedure TmwSimplePasPar.TypeSimple; +begin + case GenID of + ptBoolean, ptByte, ptChar, ptDWord, ptInt64, ptInteger, ptLongInt, + ptLongWord, ptPChar, ptShortInt, ptSmallInt, ptWideChar, ptWord: + begin + OrdinalIdentifier; + end; + ptComp, ptCurrency, ptDouble, ptExtended, ptReal, ptReal48, ptSingle: + begin + RealIdentifier; + end; + ptAnsiString, ptShortString, ptWideString: + begin + StringIdentifier; + end; + ptOleVariant, ptVariant: + begin + VariantIdentifier; + end; + ptString: + begin + StringType; + end; + ptFile: + begin + FileType; + end; + ptArray: + begin + NextToken; + Expected(ptOf); + case TokenID of + ptConst: (*new in ObjectPascal80*) + begin + NextToken; + end; + else + begin + TypeID; + end; + end; + end; + else + Expected(ptIdentifier); + end; + + if TokenId = ptLower then + begin + Expected(ptLower); + TypeArgs; + Expected(ptGreater); + end; +end; + +procedure TmwSimplePasPar.TypeParamDecl; +begin + TypeParamList; + if TokenId = ptColon then + begin + NextToken; + ConstraintList; + end; +end; + +procedure TmwSimplePasPar.TypeParamDeclList; +begin + TypeParamDecl; + while TokenId = ptSemicolon do + begin + NextToken; + TypeParamDecl; + end; +end; + +procedure TmwSimplePasPar.TypeParamList; +begin + if TokenId = ptSquareOpen then + AttributeSection; + TypeSimple; + while TokenId = ptComma do + begin + NextToken; + if TokenId = ptSquareOpen then + AttributeSection; + TypeSimple; + end; +end; + +procedure TmwSimplePasPar.TypeParams; +begin + Expected(ptLower); + TypeParamDeclList; + // workaround for TSomeClass< T >= class(TObject) + if TokenID = ptGreaterEqual then + Lexer.RunPos := Lexer.RunPos - 1 + else + Expected(ptGreater); +end; + +procedure TmwSimplePasPar.TypeReferenceType; +begin + Expected(ptType); + Expected(ptOf); + TypeId; +end; + +procedure TmwSimplePasPar.ConstSection; +begin + case TokenID of + ptConst: + begin + NextToken; + while TokenID in [ptIdentifier, ptSquareOpen] do + begin + if TokenID = ptSquareOpen then + CustomAttribute + else + begin + ConstantDeclaration; + Semicolon; + end; + end; + end; + ptResourceString: + begin + NextToken; + while (TokenID = ptIdentifier) do + begin + ResourceDeclaration; + Semicolon; + end; + end + else + begin + SynError(InvalidConstSection); + end; + end; +end; + +procedure TmwSimplePasPar.InterfaceDeclaration; +begin + case TokenID of + ptConst: + begin + ConstSection; + end; + ptFunction: + begin + ExportedHeading; + end; + ptProcedure: + begin + ExportedHeading; + end; + ptResourceString: + begin + ConstSection; + end; + ptType: + begin + TypeSection; + end; + ptThreadVar: + begin + VarSection; + end; + ptVar: + begin + VarSection; + end; + ptExports: + begin + ExportsClause; + end; + ptSquareOpen: + begin + CustomAttribute; + end; + else + begin + SynError(InvalidInterfaceDeclaration); + end; + end; +end; + +procedure TmwSimplePasPar.ExportsElement; +begin + ExportsName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + + if FLexer.ExID = ptIndex then + begin + NextToken; + Expected(ptIntegerConst); + end; + if FLexer.ExID = ptName then + begin + NextToken; + SimpleExpression; + end; + if FLexer.ExID = ptResident then + begin + NextToken; + end; +end; + +procedure TmwSimplePasPar.CompoundStatement; +begin + Expected(ptBegin); + Statements; + Expected(ptEnd); +end; + +procedure TmwSimplePasPar.ExportsClause; +begin + Expected(ptExports); + ExportsElement; + while TokenID = ptComma do + begin + NextToken; + ExportsElement; + end; + Semicolon; +end; + +procedure TmwSimplePasPar.ContainsClause; +begin + ExpectedEx(ptContains); + MainUsedUnitStatement; + while TokenID = ptComma do + begin + NextToken; + MainUsedUnitStatement; + end; + Semicolon; +end; + +procedure TmwSimplePasPar.RequiresClause; +begin + ExpectedEx(ptRequires); + RequiresIdentifier; + while TokenID = ptComma do + begin + NextToken; + RequiresIdentifier; + end; + Semicolon; +end; + +procedure TmwSimplePasPar.RequiresIdentifier; +begin + RequiresIdentifierId; + while Lexer.TokenID = ptPoint do + begin + NextToken; + RequiresIdentifierId; + end; +end; + +procedure TmwSimplePasPar.RequiresIdentifierId; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.InitializationSection; +begin + Expected(ptInitialization); + StatementList; +end; + +procedure TmwSimplePasPar.ImplementationSection; +begin + Expected(ptImplementation); + if TokenID = ptUses then + begin + UsesClause; + end; + while TokenID in [ptClass, ptConst, ptConstructor, ptDestructor, ptFunction, + ptLabel, ptProcedure, ptResourceString, ptThreadVar, ptType, ptVar, + ptExports, ptSquareOpen] do + begin + DeclarationSection; + end; +end; + +procedure TmwSimplePasPar.InterfaceSection; +begin + Expected(ptInterface); + if TokenID = ptUses then + begin + UsesClause; + end; + while TokenID in [ptConst, ptFunction, ptResourceString, ptProcedure, + ptThreadVar, ptType, ptVar, ptExports, ptSquareOpen] do + begin + InterfaceDeclaration; + end; +end; + +procedure TmwSimplePasPar.IdentifierList; +begin + Identifier; + while TokenID = ptComma do + begin + NextToken; + Identifier; + end; +end; + +procedure TmwSimplePasPar.CharString; +begin + case GenID of + ptAsciiChar, ptIdentifier, ptRoundOpen, ptStringConst: + while GenID in + [ptAsciiChar, ptIdentifier, ptRoundOpen, ptStringConst, ptString] do + begin + case TokenID of + ptIdentifier, ptRoundOpen: + begin + if ExID in [ptIndex] then + Break; + VariableReference; + end; + ptString: + begin + StringStatement; + Statement; + end; + else + StringConst; + end; +// if Lexer.TokenID = ptPoint then +// begin +// NextToken; +// VariableReference; +// end; + end; + else + begin + SynError(InvalidCharString); + end; + end; +end; + +procedure TmwSimplePasPar.IncludeFile; +begin + while TokenID <> ptNull do + case TokenID of + ptClass: + begin + ProcedureDeclarationSection; + end; + ptConst: + begin + ConstSection; + end; + ptConstructor: + begin + ProcedureDeclarationSection; + end; + ptDestructor: + begin + ProcedureDeclarationSection; + end; + ptExports: + begin + ExportsClause; + end; + ptFunction: + begin + ProcedureDeclarationSection; + end; + ptIdentifier: + begin + Statements; + end; + ptLabel: + begin + LabelDeclarationSection; + end; + ptProcedure: + begin + ProcedureDeclarationSection; + end; + ptResourceString: + begin + ConstSection; + end; + ptType: + begin + TypeSection; + end; + ptThreadVar: + begin + VarSection; + end; + ptVar: + begin + VarSection; + end; + else + begin + NextToken; + end; + end; +end; + +procedure TmwSimplePasPar.SkipSpace; +begin + Expected(ptSpace); + while TokenID in [ptSpace] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipCRLFco; +begin + Expected(ptCRLFCo); + while TokenID in [ptCRLFCo] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipCRLF; +begin + Expected(ptCRLF); + while TokenID in [ptCRLF] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.ClassClass; +begin + Expected(ptClass); +end; + +procedure TmwSimplePasPar.ClassConstraint; +begin + Expected(ptClass); +end; + +procedure TmwSimplePasPar.PropertyDefault; +begin + ExpectedEx(ptDefault); +end; + +procedure TmwSimplePasPar.DispIDSpecifier; +begin + ExpectedEx(ptDispid); + ConstantExpression; +end; + +procedure TmwSimplePasPar.IndexOp; +begin + Expected(ptSquareOpen); + Expression; + while TokenID = ptComma do + begin + NextToken; + Expression; + end; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.IndexSpecifier; +begin + ExpectedEx(ptIndex); + ConstantExpression; +end; + +procedure TmwSimplePasPar.ClassTypeEnd; +begin + case ExID of + ptExperimental: NextToken; + ptDeprecated: DirectiveDeprecated; + end; +end; + +procedure TmwSimplePasPar.ObjectTypeEnd; +begin +end; + +procedure TmwSimplePasPar.DirectiveDeprecated; +begin + ExpectedEx(ptDeprecated); + if TokenID = ptStringConst then + NextToken; +end; + +procedure TmwSimplePasPar.DirectiveInline; +begin + Expected(ptInline); +end; + +procedure TmwSimplePasPar.DirectiveLibrary; +begin + Expected(ptLibrary); +end; + +procedure TmwSimplePasPar.DirectivePlatform; +begin + ExpectedEx(ptPlatform); +end; + +procedure TmwSimplePasPar.EnumeratedTypeItem; +begin + QualifiedIdentifier; + if TokenID = ptEqual then + begin + Expected(ptEqual); + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.Identifier; +begin + NextToken; +end; + +procedure TmwSimplePasPar.DirectiveLocal; +begin + ExpectedEx(ptLocal); +end; + +procedure TmwSimplePasPar.DirectiveVarargs; +begin + ExpectedEx(ptVarargs); +end; + +procedure TmwSimplePasPar.AncestorId; +begin + TypeId; +end; + +procedure TmwSimplePasPar.AncestorIdList; +begin + AncestorId; + while(TokenID = ptComma) do + begin + NextToken; + AncestorId; + end; +end; + +procedure TmwSimplePasPar.AnonymousMethod; +begin + case TokenID of + ptFunction: + begin + NextToken; + if TokenID = ptRoundOpen then + FormalParameterList; + Expected(ptColon); + ReturnType; + end; + ptProcedure: + begin + NextToken; + if TokenId = ptRoundOpen then + FormalParameterList; + end; + end; + Block; +end; + +procedure TmwSimplePasPar.AnonymousMethodType; +begin + ExpectedEx(ptReference); + Expected(ptTo); + case TokenID of + ptProcedure: + begin + NextToken; + if TokenID = ptRoundOpen then + FormalParameterList; + end; + ptFunction: + begin + NextToken; + if TokenID = ptRoundOpen then + FormalParameterList; + Expected(ptColon); + ReturnType; + end; + end; +end; + +procedure TmwSimplePasPar.AddDefine(const ADefine: string); +begin + FLexer.AddDefine(ADefine); +end; + +procedure TmwSimplePasPar.RemoveDefine(const ADefine: string); +begin + FLexer.RemoveDefine(ADefine); +end; + +function TmwSimplePasPar.IsDefined(const ADefine: string): Boolean; +begin + Result := FLexer.IsDefined(ADefine); +end; + +procedure TmwSimplePasPar.IsNotOp; +begin + Expected(ptIs); + Expected(ptNot); +end; + +procedure TmwSimplePasPar.ExportsNameId; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ExportsName; +begin + ExportsNameId; + while FLexer.TokenID = ptPoint do + begin + NextToken; + ExportsNameId; + end; +end; + +procedure TmwSimplePasPar.ImplementsSpecifier; +begin + ExpectedEx(ptImplements); + + TypeId; + while (TokenID = ptComma) do + begin + NextToken; + TypeId; + end; +end; + +procedure TmwSimplePasPar.AttributeArgumentName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.CaseLabelList; +begin + CaseLabel; + while TokenID = ptComma do + begin + NextToken; + CaseLabel; + end; +end; + +procedure TmwSimplePasPar.ArrayBounds; +begin + if TokenID = ptSquareOpen then + begin + NextToken; + ArrayDimension; + while TokenID = ptComma do + begin + NextToken; + ArrayDimension; + end; + Expected(ptSquareClose); + end; +end; + +procedure TmwSimplePasPar.DeclarationSections; +begin + while TokenID in [ptClass, ptConst, ptConstructor, ptDestructor, ptExports, ptFunction, ptLabel, ptProcedure, ptResourceString, ptThreadVar, ptType, ptVar, ptSquareOpen] do + begin + DeclarationSection; + end; +end; + +procedure TmwSimplePasPar.ProceduralDirectiveOf; +begin + NextToken; + Expected(ptObject); +end; + +procedure TmwSimplePasPar.TypeDirective; +begin + while GenID in [ptDeprecated, ptLibrary, ptPlatform, ptExperimental] do + case GenID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + ptExperimental: NextToken; + end; +end; + +procedure TmwSimplePasPar.InheritedVariableReference; +begin + Expected(ptInherited); + if TokenID = ptIdentifier then + VariableReference; +end; + +procedure TmwSimplePasPar.ClearDefines; +begin + FLexer.ClearDefines; +end; + +procedure TmwSimplePasPar.InitAhead; +begin + if AheadParse = nil then + AheadParse := TmwSimplePasPar.Create; + AheadParse.Lexer.InitFrom(Lexer); +end; + +procedure TmwSimplePasPar.InitDefinesDefinedByCompiler; +begin + FLexer.InitDefinesDefinedByCompiler; +end; + +procedure TmwSimplePasPar.GlobalAttributes; +begin + GlobalAttributeSections; +end; + +procedure TmwSimplePasPar.GlobalAttributeSections; +begin + while TokenID = ptSquareOpen do + GlobalAttributeSection; +end; + +procedure TmwSimplePasPar.GlobalAttributeSection; +begin + Expected(ptSquareOpen); + GlobalAttributeTargetSpecifier; + AttributeList; + while TokenID = ptComma do + begin + Expected(ptComma); + GlobalAttributeTargetSpecifier; + AttributeList; + end; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.GlobalAttributeTargetSpecifier; +begin + GlobalAttributeTarget; + Expected(ptColon); +end; + +procedure TmwSimplePasPar.GlobalAttributeTarget; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.Attributes; +begin + AttributeSections; +end; + +procedure TmwSimplePasPar.AttributeSections; +begin + while TokenID = ptSquareOpen do + AttributeSection; +end; + +procedure TmwSimplePasPar.AttributeSection; +begin + Expected(ptSquareOpen); + Lexer.InitAhead; + if Lexer.AheadTokenID = ptColon then + AttributeTargetSpecifier; + AttributeList; + while TokenID = ptComma do + begin + Lexer.InitAhead; + if Lexer.AheadTokenID = ptColon then + AttributeTargetSpecifier; + AttributeList; + end; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.AttributeTargetSpecifier; +begin + AttributeTarget; + Expected(ptColon); +end; + +procedure TmwSimplePasPar.AttributeTarget; +begin + case TokenID of + ptProperty: + Expected(ptProperty); + ptType: + Expected(ptType); + else + Expected(ptIdentifier); + end; +end; + +procedure TmwSimplePasPar.AttributeList; +begin + Attribute; + while TokenID = ptComma do + begin + Expected(ptComma); + AttributeList; + end; +end; + +procedure TmwSimplePasPar.Attribute; +begin + AttributeName; + if TokenID = ptRoundOpen then + AttributeArguments; +end; + +procedure TmwSimplePasPar.AttributeName; +begin + case TokenID of + ptIn, ptOut, ptConst, ptVar, ptUnsafe: + NextToken; + else + begin + Expected(ptIdentifier); + while TokenID = ptPoint do + begin + NextToken; + Expected(ptIdentifier); + end; + end; + end; +end; + +procedure TmwSimplePasPar.AttributeArguments; +begin + Expected(ptRoundOpen); + if TokenID <> ptRoundClose then + begin + Lexer.InitAhead; + if Lexer.AheadTokenID = ptEqual then + NamedArgumentList + else + PositionalArgumentList; + if Lexer.TokenID = ptEqual then + NamedArgumentList; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.PositionalArgumentList; +begin + PositionalArgument; + while TokenID = ptComma do + begin + Expected(ptComma); + PositionalArgument; + end; +end; + +procedure TmwSimplePasPar.PositionalArgument; +begin + AttributeArgumentExpression; +end; + +procedure TmwSimplePasPar.NamedArgumentList; +begin + NamedArgument; + while TokenID = ptComma do + begin + Expected(ptComma); + NamedArgument; + end; +end; + +procedure TmwSimplePasPar.NamedArgument; +begin + AttributeArgumentName; + Expected(ptEqual); + AttributeArgumentExpression; +end; + +procedure TmwSimplePasPar.AttributeArgumentExpression; +begin + Expression; +end; + +procedure TmwSimplePasPar.CustomAttribute; +begin + //TODO: Global vs. Local attributes + AttributeSections; +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Source/SimpleParser/SimpleParser.rsj b/References/DelphiAST/Source/SimpleParser/SimpleParser.rsj new file mode 100644 index 000000000..a0502c6c7 --- /dev/null +++ b/References/DelphiAST/Source/SimpleParser/SimpleParser.rsj @@ -0,0 +1,4 @@ +{"version":1,"strings":[ +{"hash":24029655,"name":"simpleparser.rsexpected","value":"'%s' expected found '%s'"}, +{"hash":99256917,"name":"simpleparser.rsendoffile","value":"end of file"} +]} diff --git a/References/DelphiAST/Source/StringPool.pas b/References/DelphiAST/Source/StringPool.pas new file mode 100644 index 000000000..6489006fa --- /dev/null +++ b/References/DelphiAST/Source/StringPool.pas @@ -0,0 +1,118 @@ +unit StringPool; + +{$IFDEF FPC}{$MODE Delphi}{$ENDIF} + +interface + +type + TStringBucket = record + Hash: Cardinal; + Value: string; + end; + PStringBucket = ^TStringBucket; + TStringBuckets = array of TStringBucket; + + TStringPool = class + private + FBuckets: TStringBuckets; + FCount: Integer; + FGrowth: Integer; + FCapacity: Integer; + procedure Grow; + public + procedure StringIntern(var s: string); + + procedure Clear; + property Count: Integer read FCount; + end; + +implementation + +{ TStringPool } + +procedure TStringPool.Clear; +begin + SetLength(FBuckets, 0); + FCount := 0; + FGrowth := 0; + FCapacity := 0; +end; + +procedure TStringPool.Grow; +var + i, j, n: Integer; + oldBuckets: TStringBuckets; +begin + if FCapacity = 0 then + FCapacity := 32 + else + FCapacity := FCapacity * 2; + FGrowth := (FCapacity * 3) div 4 - FCount; + + oldBuckets := FBuckets; + FBuckets := nil; + SetLength(FBuckets, FCapacity); + + n := FCapacity - 1; + for i := 0 to High(oldBuckets) do + begin + if oldBuckets[i].Hash = 0 then + Continue; + j := oldBuckets[i].Hash and (FCapacity - 1); + while FBuckets[j].Hash <> 0 do + j := (j + 1) and n; + FBuckets[j].Hash := oldBuckets[i].Hash; + FBuckets[j].Value := oldBuckets[i].Value; + end; +end; + +procedure TStringPool.StringIntern(var s: string); + +{$OVERFLOWCHECKS OFF} + + function HashString(const s: string): Cardinal; inline; + var + i: Integer; + begin + // modified FNV-1a using length as seed + Result := Length(s); + for i := 1 to Result do + Result := (Result xor Ord(s[i])) * 16777619; + end; + +{$OVERFLOWCHECKS ON} + +var + hash: Cardinal; + i: Integer; + bucket: PStringBucket; +begin + if s = '' then + Exit; + + if FGrowth = 0 then + Grow; + + hash := HashString(s) shr 6; + i := hash and (FCapacity - 1); + + repeat + bucket := @FBuckets[i]; + if (bucket.Hash = hash) and (bucket.Value = s) then + begin + s := bucket.Value; + Exit; + end + else if bucket.Hash = 0 then + begin + bucket.Hash := hash; + bucket.Value := s; + Inc(FCount); + Dec(FGrowth); + Exit; + end; + i := (i + 1) and (FCapacity - 1); + until False; +end; + +end. diff --git a/References/DelphiAST/Test/DelphiASTTest.dpr b/References/DelphiAST/Test/DelphiASTTest.dpr new file mode 100644 index 000000000..0012281fb --- /dev/null +++ b/References/DelphiAST/Test/DelphiASTTest.dpr @@ -0,0 +1,16 @@ +program DelphiASTTest; + +uses + Vcl.Forms, + uMainForm in 'uMainForm.pas' {Form2}; + +{$R *.res} + +begin + System.ReportMemoryLeaksOnShutdown := True; + + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/References/DelphiAST/Test/DelphiASTTest.dproj b/References/DelphiAST/Test/DelphiASTTest.dproj new file mode 100644 index 000000000..4c07180ff --- /dev/null +++ b/References/DelphiAST/Test/DelphiASTTest.dproj @@ -0,0 +1,520 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{321657A2-2981-497B-80FB-95AE03110DDF}</ProjectGuid> + <ProjectVersion>17.2</ProjectVersion> + <FrameworkType>VCL</FrameworkType> + <MainSource>DelphiASTTest.dpr</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <Platform Condition="'$(Platform)'==''">Win32</Platform> + <TargetedPlatforms>1</TargetedPlatforms> + <AppType>Application</AppType> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''"> + <Cfg_1_Win32>true</Cfg_1_Win32> + <CfgParent>Cfg_1</CfgParent> + <Cfg_1>true</Cfg_1> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <VerInfo_Locale>1049</VerInfo_Locale> + <DCC_UnitSearchPath>..\Source;..\Source\SimpleParser;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> + <SanitizedProjectName>DelphiASTTest</SanitizedProjectName> + <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> + <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <DCC_E>false</DCC_E> + <DCC_N>false</DCC_N> + <DCC_S>false</DCC_S> + <DCC_F>false</DCC_F> + <DCC_K>false</DCC_K> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_UsePackage>dxPScxSchedulerLnkRS21;JvGlobus;JvMM;cxSchedulerRibbonStyleEventEditorRS21;JvManagedThreads;cxSchedulerRS21;FireDACPgDriver;dxSkinOffice2007BlueRS21;RemObjects_Server_Indy_D21;FixInsight_XE7;JvCrypt;cxTreeListdxBarPopupMenuRS21;dxSkinHighContrastRS21;dxSkinSevenRS21;cxPivotGridRS21;DBXInterBaseDriver;DataSnapServer;DataSnapCommon;DataAbstract_SQLiteDriver_D21;DPIAwareExpert;JvNet;dxGaugeControlRS21;JvDotNetCtrls;cxEditorsRS21;DbxCommonDriver;CromisIPC;vclimg;dxTileControlRS21;dxSkinSilverRS21;dbxcds;cxPivotGridOLAPRS21;DatasnapConnectorsFreePascal;dxPSdxGaugeControlLnkRS21;dxPsPrVwAdvRS21;dxSkinMoneyTwinsRS21;JvXPCtrls;OmniXMLCore;vcldb;cxTreeListRS21;DataAbstract_DBXDriver_Enterprise_D21;GMLibEdit_DXE7;dxdborRS21;cxSpreadSheetRS21;dxBarExtItemsRS21;frxDBX21;dxWizardControlRS21;dxSkinBlueprintRS21;RemObjects_Synapse_D21;DataAbstract_SpiderMonkeyScripting_D21;CustomIPTransport;dsnap;IndyIPServer;dxSkinOffice2010BlackRS21;IndyCore;SynEdit_RXE7;dxSkinsdxBarPainterRS21;cxPageControldxBarPopupMenuRS21;dxSkinValentineRS21;CloudService;dxSkinDevExpressStyleRS21;FmxTeeUI;FireDACIBDriver;dxSkinCaramelRS21;dxPScxPCProdRS21;frxADO21;ShareBikeCommon_XE7;dxSkinOffice2013DarkGrayRS21;JvDB;JvRuntimeDesign;dxDockingRS21;dxLayoutControlRS21;dsnapxml;JclDeveloperTools;FireDACDb2Driver;dxSkinscxSchedulerPainterRS21;dxPSLnksRS21;dxPSdxDBOCLnkRS21;dxSkinVS2010RS21;cxLibraryRS21;bindcompfmx;cxDataRS21;dxComnRS21;FireDACODBCDriver;RESTBackendComponents;dxSkinBlackRS21;dxSkinDarkSideRS21;RemObjects_WebBroker_D21;dbrtl;FireDACCommon;bindcomp;inetdb;JvPluginSystem;dxPScxTLLnkRS21;DBXOdbcDriver;JvCmp;vclFireDAC;JvTimeFramework;xmlrtl;ibxpress;cxExportRS21;FireDACCommonDriver;dxSkinOffice2007PinkRS21;dxFlowChartRS21;bindengine;vclactnband;soaprtl;FMXTee;bindcompvcl;cxPageControlRS21;dxCoreRS21;Jcl;vclie;dxSkinOffice2007BlackRS21;dxPSCoreRS21;dxPSdxDBTVLnkRS21;dxPScxCommonRS21;dxADOServerModeRS21;FireDACMSSQLDriver;DBXInformixDriver;dxSkinLilianRS21;dxSkinWhiteprintRS21;DataSnapServerMidas;dxPSTeeChartRS21;DataAbstract_DBXDriver_Pro_D21;dsnapcon;DBXFirebirdDriver;dxNavBarRS21;inet;dxRibbonRS21;dxSkinsdxNavBarPainterRS21;JvPascalInterpreter;FireDACMySQLDriver;soapmidas;vclx;dxSkinOffice2013WhiteRS21;cxBarEditItemRS21;dxSkinsCoreRS21;DBXSybaseASADriver;dxFireDACServerModeRS21;dxSkinSharpPlusRS21;RESTComponents;dxSkinSevenClassicRS21;dbexpress;EurekaLogCore;IndyIPClient;dxThemeRS21;fsIBX21;FireDACSqliteDriver;dxSkinBlueRS21;FireDACDSDriver;dxDBXServerModeRS21;DBXSqliteDriver;dxSkinsdxDLPainterRS21;dxRichEditControlRS21;DPFiOSPackagesXE7;fmx;dxSkinMetropolisDarkRS21;cxVerticalGridRS21;IndySystem;dxSkinMetropolisRS21;TeeDB;tethering;dxSpreadSheetRS21;JvDlgs;dxSkinGlassOceansRS21;frxe21;vclib;dxSkinSummer2008RS21;DataSnapClient;dxPScxPivotGridLnkRS21;frxIBX21;frx21;DataSnapProviderClient;dxPSPrVwRibbonRS21;DBXSybaseASEDriver;ORM_R;cxGridRS21;RemObjects_Indy_D21;GMLib_DXE7;MetropolisUILiveTile;vcldsnap;dxSpellCheckerRS21;dxSkinLondonLiquidSkyRS21;dxSkinMcSkinRS21;dxSkinOffice2010SilverRS21;dxSkinOffice2007GreenRS21;fsTee21;fmxFireDAC;DBXDb2Driver;dxSkinFoggyRS21;DBXOracleDriver;JvCore;vclribbon;dxtrmdRS21;fmxase;vcl;dxBarExtDBItemsRS21;dxGDIPlusRS21;DBXMSSQLDriver;IndyIPCommon;CodeSiteExpressPkg;dxPSDBTeeChartRS21;dxSkinOffice2007SilverRS21;DataSnapFireDAC;FireDACDBXDriver;dxSkinStardustRS21;dxPSdxSpreadSheetLnkRS21;soapserver;JvAppFrm;dxdbtrRS21;inetdbxpress;FireDACInfxDriver;dxSkinCoffeeRS21;dxPSdxFCLnkRS21;dxPScxGridLnkRS21;FMXContainer_Runtime_XE7;JvDocking;adortl;RemObjects_Server_Synapse_D21;JvWizards;FireDACASADriver;JvHMI;fsADO21;JvBands;dxTabbedMDIRS21;emsclientfiredac;rtl;dxPScxSSLnkRS21;DbxClientDriver;dxSkinDarkRoomRS21;dxorgcRS21;dxPScxExtCommonRS21;dxPSdxOCLnkRS21;frxTee21;Tee;dxPSdxLCLnkRS21;JclContainers;frxDB21;dxMapControlRS21;JvSystem;DataSnapNativeClient;svnui;JvControls;dxSkinSpringTimeRS21;IndyProtocols;DBXMySQLDriver;cxPivotGridChartRS21;dxSkinOffice2013LightGrayRS21;dxSkinPumpkinRS21;bindcompdbx;TeeUI;fsDB21;JvJans;JvPrintPreview;JvPageComps;JvStdCtrls;cxSchedulerTreeBrowserRS21;dxmdsRS21;JvCustom;fs21;dxSkinDevExpressDarkStyleRS21;dxSkinSharpRS21;FireDACADSDriver;vcltouch;dxSkinscxPCPainterRS21;dxServerModeRS21;emsclient;FrameViewerXE7;dxSkinsdxRibbonPainterRS21;VCLRESTComponents;FireDAC;VclSmp;dxBarDBNavRS21;dxSkinTheAsphaltWorldRS21;dxSkinXmas2008BlueRS21;DataSnapConnectors;dxSkinLiquidSkyRS21;cxSchedulerGridRS21;fmxobj;JclVcl;dxPScxVGridLnkRS21;svn;dxBarRS21;FireDACOracleDriver;fmxdae;dxSkinOffice2010BlueRS21;VirtualTreesR;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dxSkiniMaginaryRS21;$(DCC_UsePackage)</DCC_UsePackage> + <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Locale>1033</VerInfo_Locale> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <DCC_UsePackage>dxPScxSchedulerLnkRS21;cxSchedulerRibbonStyleEventEditorRS21;cxSchedulerRS21;FireDACPgDriver;dxSkinOffice2007BlueRS21;RemObjects_Server_Indy_D21;cxTreeListdxBarPopupMenuRS21;dxSkinHighContrastRS21;dxSkinSevenRS21;cxPivotGridRS21;DBXInterBaseDriver;DataSnapServer;DataSnapCommon;DataAbstract_SQLiteDriver_D21;dxGaugeControlRS21;cxEditorsRS21;DbxCommonDriver;vclimg;dxTileControlRS21;dxSkinSilverRS21;dbxcds;cxPivotGridOLAPRS21;DatasnapConnectorsFreePascal;dxPSdxGaugeControlLnkRS21;dxPsPrVwAdvRS21;dxSkinMoneyTwinsRS21;vcldb;cxTreeListRS21;DataAbstract_DBXDriver_Enterprise_D21;dxdborRS21;cxSpreadSheetRS21;dxBarExtItemsRS21;dxWizardControlRS21;dxSkinBlueprintRS21;RemObjects_Synapse_D21;DataAbstract_SpiderMonkeyScripting_D21;CustomIPTransport;dsnap;IndyIPServer;dxSkinOffice2010BlackRS21;IndyCore;SynEdit_RXE7;dxSkinsdxBarPainterRS21;cxPageControldxBarPopupMenuRS21;dxSkinValentineRS21;CloudService;dxSkinDevExpressStyleRS21;FmxTeeUI;FireDACIBDriver;dxSkinCaramelRS21;dxPScxPCProdRS21;ShareBikeCommon_XE7;dxSkinOffice2013DarkGrayRS21;dxDockingRS21;dxLayoutControlRS21;dsnapxml;FireDACDb2Driver;dxSkinscxSchedulerPainterRS21;dxPSLnksRS21;dxPSdxDBOCLnkRS21;dxSkinVS2010RS21;cxLibraryRS21;bindcompfmx;cxDataRS21;dxComnRS21;FireDACODBCDriver;RESTBackendComponents;dxSkinBlackRS21;dxSkinDarkSideRS21;RemObjects_WebBroker_D21;dbrtl;FireDACCommon;bindcomp;inetdb;dxPScxTLLnkRS21;DBXOdbcDriver;vclFireDAC;xmlrtl;ibxpress;cxExportRS21;FireDACCommonDriver;dxSkinOffice2007PinkRS21;dxFlowChartRS21;bindengine;vclactnband;soaprtl;FMXTee;bindcompvcl;cxPageControlRS21;dxCoreRS21;vclie;dxSkinOffice2007BlackRS21;dxPSCoreRS21;dxPSdxDBTVLnkRS21;dxPScxCommonRS21;dxADOServerModeRS21;FireDACMSSQLDriver;DBXInformixDriver;dxSkinLilianRS21;dxSkinWhiteprintRS21;DataSnapServerMidas;dxPSTeeChartRS21;DataAbstract_DBXDriver_Pro_D21;dsnapcon;DBXFirebirdDriver;dxNavBarRS21;inet;dxRibbonRS21;dxSkinsdxNavBarPainterRS21;FireDACMySQLDriver;soapmidas;vclx;dxSkinOffice2013WhiteRS21;cxBarEditItemRS21;dxSkinsCoreRS21;DBXSybaseASADriver;dxFireDACServerModeRS21;dxSkinSharpPlusRS21;RESTComponents;dxSkinSevenClassicRS21;dbexpress;IndyIPClient;dxThemeRS21;FireDACSqliteDriver;dxSkinBlueRS21;FireDACDSDriver;dxDBXServerModeRS21;DBXSqliteDriver;dxSkinsdxDLPainterRS21;dxRichEditControlRS21;fmx;dxSkinMetropolisDarkRS21;cxVerticalGridRS21;IndySystem;dxSkinMetropolisRS21;TeeDB;tethering;dxSpreadSheetRS21;dxSkinGlassOceansRS21;vclib;dxSkinSummer2008RS21;DataSnapClient;dxPScxPivotGridLnkRS21;DataSnapProviderClient;dxPSPrVwRibbonRS21;DBXSybaseASEDriver;cxGridRS21;RemObjects_Indy_D21;GMLib_DXE7;MetropolisUILiveTile;vcldsnap;dxSpellCheckerRS21;dxSkinLondonLiquidSkyRS21;dxSkinMcSkinRS21;dxSkinOffice2010SilverRS21;dxSkinOffice2007GreenRS21;fmxFireDAC;DBXDb2Driver;dxSkinFoggyRS21;DBXOracleDriver;vclribbon;dxtrmdRS21;fmxase;vcl;dxBarExtDBItemsRS21;dxGDIPlusRS21;DBXMSSQLDriver;IndyIPCommon;dxPSDBTeeChartRS21;dxSkinOffice2007SilverRS21;DataSnapFireDAC;FireDACDBXDriver;dxSkinStardustRS21;dxPSdxSpreadSheetLnkRS21;soapserver;dxdbtrRS21;inetdbxpress;FireDACInfxDriver;dxSkinCoffeeRS21;dxPSdxFCLnkRS21;dxPScxGridLnkRS21;adortl;RemObjects_Server_Synapse_D21;FireDACASADriver;dxTabbedMDIRS21;emsclientfiredac;rtl;dxPScxSSLnkRS21;DbxClientDriver;dxSkinDarkRoomRS21;dxorgcRS21;dxPScxExtCommonRS21;dxPSdxOCLnkRS21;Tee;dxPSdxLCLnkRS21;dxMapControlRS21;DataSnapNativeClient;dxSkinSpringTimeRS21;IndyProtocols;DBXMySQLDriver;cxPivotGridChartRS21;dxSkinOffice2013LightGrayRS21;dxSkinPumpkinRS21;bindcompdbx;TeeUI;cxSchedulerTreeBrowserRS21;dxmdsRS21;dxSkinDevExpressDarkStyleRS21;dxSkinSharpRS21;FireDACADSDriver;vcltouch;dxSkinscxPCPainterRS21;dxServerModeRS21;emsclient;dxSkinsdxRibbonPainterRS21;VCLRESTComponents;FireDAC;VclSmp;dxBarDBNavRS21;dxSkinTheAsphaltWorldRS21;dxSkinXmas2008BlueRS21;DataSnapConnectors;dxSkinLiquidSkyRS21;cxSchedulerGridRS21;fmxobj;dxPScxVGridLnkRS21;dxBarRS21;FireDACOracleDriver;fmxdae;dxSkinOffice2010BlueRS21;VirtualTreesR;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dxSkiniMaginaryRS21;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_DebugDCUs>true</DCC_DebugDCUs> + <DCC_Optimize>false</DCC_Optimize> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_DebugInfoInExe>true</DCC_DebugInfoInExe> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_RemoteDebug>false</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_DebugInformation>0</DCC_DebugInformation> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="uMainForm.pas"> + <Form>Form2</Form> + <FormType>dfm</FormType> + </DCCReference> + <BuildConfiguration Include="Release"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Debug"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Application</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">DelphiASTTest.dpr</Source> + </Source> + <Excluded_Packages> + <Excluded_Packages Name="C:\Users\Public\Documents\Embarcadero\Studio\15.0\Bpl\FixInsightIntegration.bpl">(untitled)</Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dcloffice2k210.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dclofficexp210.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> + </Excluded_Packages> + </Delphi.Personality> + <Deployment Version="1"> + <DeployFile LocalName="Win32\Debug\DelphiASTTest.exe" Configuration="Debug" Class="ProjectOutput"> + <Platform Name="Win32"> + <RemoteName>DelphiASTTest.exe</RemoteName> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployClass Required="true" Name="DependencyPackage"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.bpl</Extensions> + </Platform> + <Platform Name="OSX32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="DependencyModule"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.dll;.bpl</Extensions> + </Platform> + <Platform Name="OSX32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch2048"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXInfoPList"> + <Platform Name="OSX32"> + <RemoteDir>Contents</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceDebug"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage470"> + <Platform Name="Android"> + <RemoteDir>res\drawable-normal</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeX86File"> + <Platform Name="Android"> + <RemoteDir>library\lib\x86</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSResource"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXEntitlements"> + <Platform Name="OSX32"> + <RemoteDir>../</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidGDBServer"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage960"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xlarge</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch320"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon144"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeMipsFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDef"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DebugSymbols"> + <Platform Name="OSX32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyFramework"> + <Platform Name="OSX32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage426"> + <Platform Name="Android"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSEntitlements"> + <Platform Name="iOSDevice64"> + <RemoteDir>../</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <RemoteDir>../</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AdditionalDebugSymbols"> + <Platform Name="OSX32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidClassesDexFile"> + <Platform Name="Android"> + <RemoteDir>classes</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSInfoPList"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1024"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_DefaultAppIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXResource"> + <Platform Name="OSX32"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceResourceRules"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch768"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="ProjectOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeArmeabiFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage640"> + <Platform Name="Android"> + <RemoteDir>res\drawable-large</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="File"> + <Platform Name="Android"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>0</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640x1136"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStyles"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1536"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectAndroidManifest"> + <Platform Name="Android"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> + </Deployment> + <Platforms> + <Platform value="Win32">True</Platform> + <Platform value="Win64">False</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> + <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/> +</Project> diff --git a/References/DelphiAST/Test/DelphiASTTest.lpr b/References/DelphiAST/Test/DelphiASTTest.lpr new file mode 100644 index 000000000..30483af94 --- /dev/null +++ b/References/DelphiAST/Test/DelphiASTTest.lpr @@ -0,0 +1,16 @@ +program DelphiASTTest; + +{$MODE Delphi} + +uses + Forms, Interfaces, + uMainForm in 'uMainForm.pas' {Form2}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/References/DelphiAST/Test/Snippets/DeprecatedOnConst.pas b/References/DelphiAST/Test/Snippets/DeprecatedOnConst.pas new file mode 100644 index 000000000..8d27ffc55 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/DeprecatedOnConst.pas @@ -0,0 +1,11 @@ +unit DeprecatedOnConst; + +interface + +const + MyConst = 'test' deprecated 'Do not use'; + MyConst2 = 'test2' platform; + MyConst3 = 'test4' library; + +implementation +end. diff --git a/References/DelphiAST/Test/Snippets/VariantRecordFieldAttributes.pas b/References/DelphiAST/Test/Snippets/VariantRecordFieldAttributes.pas new file mode 100644 index 000000000..bbe6a275b --- /dev/null +++ b/References/DelphiAST/Test/Snippets/VariantRecordFieldAttributes.pas @@ -0,0 +1,17 @@ +unit VariantRecordFieldAttributes; + +interface + +type + TVariantRecord = record + case byte of + 1:( + Value: Double; + [Example] + ValueWithAttribute: Integer; + ); + end; + +implementation + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/alignedrecords.pas b/References/DelphiAST/Test/Snippets/alignedrecords.pas new file mode 100644 index 000000000..659e57ac7 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/alignedrecords.pas @@ -0,0 +1,26 @@ +unit alignedrecords; + +interface + +type + TMyRecord = record + Value: Integer; + Align: string; + class operator Initialize (out Dest: TMyRecord); + class operator Finalize(var Dest: TMyRecord); + end align 8; + +implementation + +class operator TMyRecord.Initialize (out Dest: TMyRecord); +begin + Dest.Value := 10; + Log('created' + IntToHex (Integer(Pointer(@Dest)))); +end; + +class operator TMyRecord.Finalize(var Dest: TMyRecord); +begin + Log('destroyed' + IntToHex (Integer(Pointer(@Dest)))); +end; + +end. diff --git a/References/DelphiAST/Test/Snippets/constset.pas b/References/DelphiAST/Test/Snippets/constset.pas new file mode 100644 index 000000000..3d983387e --- /dev/null +++ b/References/DelphiAST/Test/Snippets/constset.pas @@ -0,0 +1,21 @@ +unit constset; + +interface + +type + TClass = class + public type + TInnerEnum = (eOne, eTwo, wThree); + end; + +const + cConstant: set of TClass.TInnerEnum = [ + TClass.TInnerEnum.eOne, + TClass.TInnerEnum.eTwo, + TClass.TInnerEnum.wThree + ]; + + +implementation + +end. diff --git a/References/DelphiAST/Test/Snippets/deprecatedtype.pas b/References/DelphiAST/Test/Snippets/deprecatedtype.pas new file mode 100644 index 000000000..d9b3f9464 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/deprecatedtype.pas @@ -0,0 +1,20 @@ +unit deprecatedtype deprecated; + +interface + +type + TFoo = record + end deprecated 'Use TBar'; + + TBar = record + end deprecated; + + TFooClass = class + end deprecated 'Use TBarClass'; + + TBarClass = class + end deprecated; + +implementation + +end. diff --git a/References/DelphiAST/Test/Snippets/dottedtypes.pas b/References/DelphiAST/Test/Snippets/dottedtypes.pas new file mode 100644 index 000000000..148b405b4 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/dottedtypes.pas @@ -0,0 +1,37 @@ +unit dottedtypes; + +interface + +uses + MyUnit; + +type + TSample<T: MyUnit.TItem, MyUnit.MyType.IStuff> = class(MyUnit.TBaseClass, MyUnit.IStuff) + public + function DoStuff<T2: MyUnit.TMyObject>(Obj: MyUnit.TMyObject): MyUnit.TMyObject; + + property Obj : TObj read FObj implements MyUnit.IStuff; + end; + +implementation + +function TSample<T>.DoStuff<T2>(Obj: MyUnit.TMyObject): MyUnit.TMyObject; +var + Obj2: MyUnit.TMyObject; + Obj3, Obj4: MyUnit.TMyAdditionalObject; + Sample: TSample<MyUnit.TSpecialItem>; + MyObjectArray: array of MyUnit.TMyObject; +begin + Sample := TSample<MyUnit.TSpecialItem>.Create; + + try + Sample.DoOtherStuff<MyUnit.TSpecialObject, MyUnit.TObject>(Obj2); + except + on E: MyUnit.MyException do + begin + WriteLn(E.Message); + end; + end; +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/endtoken.pas b/References/DelphiAST/Test/Snippets/endtoken.pas new file mode 100644 index 000000000..2a94359b4 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/endtoken.pas @@ -0,0 +1,32 @@ +unit endtoken; + +interface + +function BitsHighest(X: Cardinal): Integer; + +implementation + +// Bit manipulation +function BitsHighest(X: Cardinal): Integer; +asm + {$IFDEF CPU32} + // --> EAX X + // <-- EAX + MOV ECX, EAX + MOV EAX, -1 + BSR EAX, ECX + JNZ @@End + MOV EAX, -1 +@@End: + {$ENDIF CPU32} + {$IFDEF CPU64} + // --> ECX X + // <-- RAX + MOV EAX, -1 + MOV R10D, EAX + BSR EAX, ECX + CMOVZ EAX, R10D + {$ENDIF CPU64} +end; + +end. diff --git a/References/DelphiAST/Test/Snippets/experimentals.pas b/References/DelphiAST/Test/Snippets/experimentals.pas new file mode 100644 index 000000000..65c1ce643 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/experimentals.pas @@ -0,0 +1,18 @@ +unit experimentals experimental; + +interface + +type + TExperimentalClass = class + Field: Integer; + end experimental; + +procedure someExperimentalProc(); + +implementation + +procedure someExperimentalProc(); experimental; +begin +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/externalfunction.pas b/References/DelphiAST/Test/Snippets/externalfunction.pas new file mode 100644 index 000000000..dcca0c8dd --- /dev/null +++ b/References/DelphiAST/Test/Snippets/externalfunction.pas @@ -0,0 +1,9 @@ +unit externalfunction; + +interface + +function CreateJobObjectA; external Kernel32 name 'CreateJobObjectA'; + +implementation + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/finalizationinitializationexports.pas b/References/DelphiAST/Test/Snippets/finalizationinitializationexports.pas new file mode 100644 index 000000000..9c755dc8a --- /dev/null +++ b/References/DelphiAST/Test/Snippets/finalizationinitializationexports.pas @@ -0,0 +1,53 @@ +unit finalizationinitializationexports; + +interface + +type + TFoo = class(TObject) + function A : Integer; + constructor Create; + end; + + TBar = record + procedure B; + end; + + IFooBar = interface + ['{BED74FE6-570B-40F8-ABF0-5E23C8EE8E7E}'] + procedure C; + end; + + procedure Hello; + +const + A = 1; + +implementation + +procedure Hello; +begin + +end; + +{ TFoo } + +function TFoo.A : Integer; +begin + +end; + +constructor TFoo.Create; +begin + +end; + +exports + Hello; + +initialization + Hello; + +finalization + Hello; + +end. diff --git a/References/DelphiAST/Test/Snippets/forwardoverloaded.pas b/References/DelphiAST/Test/Snippets/forwardoverloaded.pas new file mode 100644 index 000000000..8c5381938 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/forwardoverloaded.pas @@ -0,0 +1,19 @@ +unit forwardoverloaded; + +interface + +implementation + +procedure Test; forward; overload; + +procedure Test(AParam: Integer); overload; +begin + +end; + +procedure Test; +begin + +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/forwardwithoutsemicolon.pas b/References/DelphiAST/Test/Snippets/forwardwithoutsemicolon.pas new file mode 100644 index 000000000..712c8f3ff --- /dev/null +++ b/References/DelphiAST/Test/Snippets/forwardwithoutsemicolon.pas @@ -0,0 +1,20 @@ +unit forwardwithoutsemicolon; + +interface + +procedure proc1(); forward // NO TRAILING SEMICOLON +procedure proc2(); + +implementation + +procedure proc1(); +begin + +end; + +procedure proc2(); +begin + +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/genericconstraints.pas b/References/DelphiAST/Test/Snippets/genericconstraints.pas new file mode 100644 index 000000000..37c3ac9ce --- /dev/null +++ b/References/DelphiAST/Test/Snippets/genericconstraints.pas @@ -0,0 +1,26 @@ +unit genericconstraints; + +interface + +type + TFoo<T: TComponent> = class(TObject); // T inherits from TComponent + TFoo<TComma1, TComma2> = class(TObject); // TComma1 and TComma2 have no constraints + TBar<TTwoConstraints: TComponent, IUnknown> = class(TObject); // TTwoConstraints inherits from TComponent and implements IUnknown + TBar<T1: TComponent; T2: IUnknown> = class(TObject); // T1 inherits from TComponent, T2 implements IUnknown + TBaz<TThreeConstraints: TComponent, IUnknown, constructor> = class(TObject); // TThreeConstraints inherits from TComponent, implements IUnknown and has a constructor without parameters + TBaz<TComma1, TComma2: class> = class(TObject); // TComma1 and TComma2 are classes + TBax<T1: class; T2: record> = class(TObject) // T1 is a class, T2 is a record + public + procedure DoStuff; + end; + +implementation + +{ TBax<T1, T2> } + +procedure TBax<T1, T2>.DoStuff; +begin +// +end; + +end. diff --git a/References/DelphiAST/Test/Snippets/genericinterfacemethoddelegation.pas b/References/DelphiAST/Test/Snippets/genericinterfacemethoddelegation.pas new file mode 100644 index 000000000..4fe0efc68 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/genericinterfacemethoddelegation.pas @@ -0,0 +1,28 @@ +unit genericinterfacemethoddelegation; + +interface + +uses + SysUtils; + +type + TGenerator<T1, TResult> = class(TInterfacedObject, + TFunc<T1, IEnumerable<TResult>>) + private + function TFunc<T1, IEnumerable<TResult>>.Invoke = Bind; + public + constructor Create(const proc: TProc<T1>); + function Bind(arg1: T1): IEnumerable<TResult>; + end; + +implementation + +function TGenerator<T1, TResult>.Bind(arg1: T1): IEnumerable<TResult>; +begin +end; + +constructor TGenerator<T1, TResult>.Create(const proc: TProc<T1>); +begin +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/implementsgenerictype.pas b/References/DelphiAST/Test/Snippets/implementsgenerictype.pas new file mode 100644 index 000000000..69dbd0afc --- /dev/null +++ b/References/DelphiAST/Test/Snippets/implementsgenerictype.pas @@ -0,0 +1,18 @@ +unit implementsgenerictype; + +interface + +type + IFoo<T> = interface + end; + + TBar = class(TInterfacedObject, IFoo<IInterface>) + private + FFoo : IFoo<IInterface>; + public + property Foo : IFoo<IInterface> read FFoo implements IFoo<IInterface>; + end; + +implementation + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/include file2.inc b/References/DelphiAST/Test/Snippets/include file2.inc new file mode 100644 index 000000000..da96d6b7f --- /dev/null +++ b/References/DelphiAST/Test/Snippets/include file2.inc @@ -0,0 +1 @@ +{$DEFINE TESTINCLUDE2} \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/includefile.inc b/References/DelphiAST/Test/Snippets/includefile.inc new file mode 100644 index 000000000..e4a0c8ffe --- /dev/null +++ b/References/DelphiAST/Test/Snippets/includefile.inc @@ -0,0 +1 @@ +{$DEFINE TESTINCLUDE} \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/includefile.pas b/References/DelphiAST/Test/Snippets/includefile.pas new file mode 100644 index 000000000..8d5ec0cf7 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/includefile.pas @@ -0,0 +1,17 @@ +{$I includefile.inc} +{$INCLUDE 'include file2.inc'} +unit includefile; + +interface + +{$IFNDEF TESTINCLUDE} + this must be ignored +{$ENDIF} + +{$IFNDEF TESTINCLUDE2} + this must be ignored +{$ENDIF} + +implementation + +end. diff --git a/References/DelphiAST/Test/Snippets/isnotnotin.pas b/References/DelphiAST/Test/Snippets/isnotnotin.pas new file mode 100644 index 000000000..d73ed86ba --- /dev/null +++ b/References/DelphiAST/Test/Snippets/isnotnotin.pas @@ -0,0 +1,18 @@ +unit isnotnotin; + +interface + +procedure Test; + +implementation + +procedure Test; +var + a: array of Integer; + b: TObject; +begin + if 1 not in a and b is not TButton then + Exit; +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/managedrecords.pas b/References/DelphiAST/Test/Snippets/managedrecords.pas new file mode 100644 index 000000000..021db1611 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/managedrecords.pas @@ -0,0 +1,25 @@ +unit managedrecords; + +interface + +type + TMyRecord = record + Value: Integer; + class operator Initialize (out Dest: TMyRecord); + class operator Finalize(var Dest: TMyRecord); + end; + +implementation + +class operator TMyRecord.Initialize (out Dest: TMyRecord); +begin + Dest.Value := 10; + Log('created' + IntToHex (Integer(Pointer(@Dest)))); +end; + +class operator TMyRecord.Finalize(var Dest: TMyRecord); +begin + Log('destroyed' + IntToHex (Integer(Pointer(@Dest)))); +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/messagemethod.pas b/References/DelphiAST/Test/Snippets/messagemethod.pas new file mode 100644 index 000000000..497a869f5 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/messagemethod.pas @@ -0,0 +1,13 @@ +unit externalfunction; + +interface + +type + TMyClass = class + strict protected + procedure ProcessMsg(var Msg: TMessage); message WM_USER; + end; + +implementation + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/multiline.pas b/References/DelphiAST/Test/Snippets/multiline.pas new file mode 100644 index 000000000..d28a1db56 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/multiline.pas @@ -0,0 +1,24 @@ +unit multilie; + +interface + +implementation + +const + Str1 = 'Str''Str'; + Str2 = ''; + Str3 = ''' + TEST + STRING + '''; + Str4 = ''''' + TEST ''' + STRING + '''''; + Str5 = ''''' + TEST + '''' + STRING + text'''' + '''''; +end. diff --git a/References/DelphiAST/Test/Snippets/nonalignedrecords.pas b/References/DelphiAST/Test/Snippets/nonalignedrecords.pas new file mode 100644 index 000000000..021db1611 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/nonalignedrecords.pas @@ -0,0 +1,25 @@ +unit managedrecords; + +interface + +type + TMyRecord = record + Value: Integer; + class operator Initialize (out Dest: TMyRecord); + class operator Finalize(var Dest: TMyRecord); + end; + +implementation + +class operator TMyRecord.Initialize (out Dest: TMyRecord); +begin + Dest.Value := 10; + Log('created' + IntToHex (Integer(Pointer(@Dest)))); +end; + +class operator TMyRecord.Finalize(var Dest: TMyRecord); +begin + Log('destroyed' + IntToHex (Integer(Pointer(@Dest)))); +end; + +end. \ No newline at end of file diff --git a/References/DelphiAST/Test/Snippets/noreturn.pas b/References/DelphiAST/Test/Snippets/noreturn.pas new file mode 100644 index 000000000..a0ff43112 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/noreturn.pas @@ -0,0 +1,18 @@ +unit experimentals experimental; + +interface + +type + TExperimentalClass = class + Field: Integer; + end; + +procedure someExperimentalProc(); noreturn; + +implementation + +procedure someExperimentalProc(); noreturn; +begin +end; + +end. diff --git a/References/DelphiAST/Test/Snippets/numbers.pas b/References/DelphiAST/Test/Snippets/numbers.pas new file mode 100644 index 000000000..4d0d849ff --- /dev/null +++ b/References/DelphiAST/Test/Snippets/numbers.pas @@ -0,0 +1,20 @@ +unit constset; + +interface + +implementation + +procedure Test; +var + A,B,C: Integer; + D: Double; +begin + A := 123123_; + B := $_1241_3_; + C := %_01011; + D := 12_3_.12_3_; + A := 1____________23123_; + B := $_12_________41_3_; +end; + +end. diff --git a/References/DelphiAST/Test/Snippets/pointerchars.pas b/References/DelphiAST/Test/Snippets/pointerchars.pas new file mode 100644 index 000000000..cf729081d --- /dev/null +++ b/References/DelphiAST/Test/Snippets/pointerchars.pas @@ -0,0 +1,28 @@ +unit pointerchars; + +interface + +implementation + +procedure FormKeyPress(Sender: TObject; var Key: Char); +var + P: PInteger; + Arr: array of Integer; +begin + if Arr[P^] > 0 then + begin + // some code + end; + + if Key = ^\ then + begin + //some code + end; + + if Key = ^M then + begin + //some code + end; +end; + +end. diff --git a/References/DelphiAST/Test/Snippets/properties.pas b/References/DelphiAST/Test/Snippets/properties.pas new file mode 100644 index 000000000..3539831b8 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/properties.pas @@ -0,0 +1,24 @@ +unit properties; + +interface + +type + TProps = class + public + property Name: string read FName write FName; + property ReadableName: string read FName; + property WriteableName: string write FName; + property Redeclared; + property Width: TWidth read GetWidth write SetWidth stored IsWidthStored default 50; + property Tag: Integer read FTag write FTag default 0; + property Indexed[Index: integer]: string read GetByIndex write SetByIndexed; + property ReadableIndexed[Index: integer]: string read GetByIndex; + property WriteableIndexed[Index: integer]: string write SetByIndexed; + property DefaultIndexed[Index: integer]: string read GetByIndex write SetByIndexed; default; + property DefaultReadableIndexed[Index: integer]: string read GetByIndex; default; + property DefaultWriteableIndexed[Index: integer]: string write SetByIndexed; default; + end; + +implementation + +end. diff --git a/References/DelphiAST/Test/Snippets/strictvisibility.pas b/References/DelphiAST/Test/Snippets/strictvisibility.pas new file mode 100644 index 000000000..0c84f5de6 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/strictvisibility.pas @@ -0,0 +1,13 @@ +unit strictvisibility; + +interface + +type + TStrictClass = class + strict private + strict protected + end; + +implementation + +end. diff --git a/References/DelphiAST/Test/Snippets/ternaryop.pas b/References/DelphiAST/Test/Snippets/ternaryop.pas new file mode 100644 index 000000000..627b1586f --- /dev/null +++ b/References/DelphiAST/Test/Snippets/ternaryop.pas @@ -0,0 +1,17 @@ +unit ternaryop; + +interface + +procedure Test; + +implementation + +procedure Test; +var + a,b: Integer; +begin + a := if True then 1 else 2; + b := if a > 2 then 5 else 6 * 18; +end; + +end. diff --git a/References/DelphiAST/Test/Snippets/tryexcept.pas b/References/DelphiAST/Test/Snippets/tryexcept.pas new file mode 100644 index 000000000..32a0a3610 --- /dev/null +++ b/References/DelphiAST/Test/Snippets/tryexcept.pas @@ -0,0 +1,54 @@ +unit tryexcept; + +interface + +implementation + +procedure DoStuff; +var + O: MyUnit.TMyObject; +begin + try + DoSomething; + except + Log('DoSomething failed'); + end; + + try + DoSomethingElse + except + on E: Exception do + begin + LogError(E); + end; + end; + + try + DoCrazyStuff; + except + + on EFileNotFound do + begin + LogHint('File not found. Does''nt matter.'); + end; + + on MyUnit.EFileNotFound do + begin + LogHint('MyUnit file not found. Does''nt matter.'); + end; + + on E: MyUnit.ECriticalError do + begin + LogError('MyUnit Critical error: ' + E.Message); + end; + + on E: Exception do + begin + LogError(E); + end + else + LogError('Unknown error'); + end; +end; + +end. diff --git a/References/DelphiAST/Test/Snippets/umlauts.pas b/References/DelphiAST/Test/Snippets/umlauts.pas new file mode 100644 index 0000000000000000000000000000000000000000..7fe399d878e5a48066ddd8a1d6f458368bea32db GIT binary patch literal 308 zcmcJK(G9{d3`E~I5<7GP7T}8k7@{SijYQn4O}Awh;9^t>2Iz+!+jsU|-meuSQD|7n zJZSY67S0?wcqB0jk(s;Do2m_&G#h;qv^5K9c+xr7lm}gmTy@_Fsutb32=APm)mQai ii2dnhCOL_|UA0?9l9KJHTwV9>bo*U(6@Gku`x77h#x|$` literal 0 HcmV?d00001 diff --git a/References/DelphiAST/Test/Snippets/whitespacearoundifdefcondition.pas b/References/DelphiAST/Test/Snippets/whitespacearoundifdefcondition.pas new file mode 100644 index 000000000..13204dc6f --- /dev/null +++ b/References/DelphiAST/Test/Snippets/whitespacearoundifdefcondition.pas @@ -0,0 +1,23 @@ +unit whitespacearoundifdefcondition; + +interface + +implementation + +{$DEFINE CPUX86} + +procedure Foo; +{$IFDEF CPUX86 } +begin +end; +{$ENDIF} + +procedure Foo2; +{$IF defined(CPUX86) } +begin +end; +{$ENDIF} + +initialization + +end. diff --git a/References/DelphiAST/Test/uMainForm.dfm b/References/DelphiAST/Test/uMainForm.dfm new file mode 100644 index 000000000..6198193bf --- /dev/null +++ b/References/DelphiAST/Test/uMainForm.dfm @@ -0,0 +1,44 @@ +object Form2: TForm2 + Left = -3 + Top = 81 + Caption = 'DelphiAST Test Application' + ClientHeight = 231 + ClientWidth = 687 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = True + DesignSize = ( + 687 + 231) + PixelsPerInch = 96 + TextHeight = 13 + object memLog: TMemo + Left = 0 + Top = 0 + Width = 687 + Height = 193 + Anchors = [akLeft, akTop, akRight, akBottom] + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Lucida Console' + Font.Style = [] + ParentFont = False + ScrollBars = ssBoth + TabOrder = 0 + end + object btnRun: TButton + Left = 604 + Top = 198 + Width = 75 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'Run' + TabOrder = 1 + OnClick = btnRunClick + end +end diff --git a/References/DelphiAST/Test/uMainForm.pas b/References/DelphiAST/Test/uMainForm.pas new file mode 100644 index 000000000..0c9b92776 --- /dev/null +++ b/References/DelphiAST/Test/uMainForm.pas @@ -0,0 +1,102 @@ +unit uMainForm; + +{$IFDEF FPC}{$MODE Delphi}{$ENDIF} + +interface + +uses + {$IFNDEF FPC} + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, + {$ELSE} + SysUtils, Variants, Classes, Controls, Forms, StdCtrls, + {$ENDIF} + SimpleParser.Lexer.Types; + +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; + + TForm2 = class(TForm) + memLog: TMemo; + btnRun: TButton; + procedure btnRunClick(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form2: TForm2; + +implementation + +uses + FileCtrl, IOUtils, DelphiAST, DelphiAST.Classes; + +{$R *.dfm} + +procedure TForm2.btnRunClick(Sender: TObject); +var + Path, FileName: string; + SyntaxTree: TSyntaxNode; +begin + memLog.Clear; + + Path := ExtractFilePath(Application.ExeName) + 'Snippets\'; + if not SelectDirectory('Select Folder', '', Path) then + Exit; + + for FileName in TDirectory.GetFiles(Path, '*.pas', TSearchOption.soAllDirectories) do + begin + try + SyntaxTree := TPasSyntaxTreeBuilder.Run(FileName, False, TIncludeHandler.Create(Path)); + try + memLog.Lines.Add('OK: ' + FileName); + finally + SyntaxTree.Free; + end; + except + on E: Exception do + begin + memLog.Lines.Add('FAILED: ' + FileName); + memLog.Lines.Add(' ' + E.ClassName); + memLog.Lines.Add(' ' + E.Message); + memLog.Repaint; + end; + end; + end; +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 + FileName := TPath.Combine(FPath, IncludeName); + FileContent.LoadFromFile(FileName); + Content := FileContent.Text; + Result := True; + finally + FileContent.Free; + end; +end; + +end. From f9d695591db079edfc2643c14603c67d94453972 Mon Sep 17 00:00:00 2001 From: stv <stephane.vanderclock@pvsyst.com> Date: Tue, 22 Sep 2026 11:19:06 +0200 Subject: [PATCH 8/9] update --- Tools/CodeProfiler/_Source/CodeProfiler.dproj | 377 +++++++++--------- 1 file changed, 190 insertions(+), 187 deletions(-) diff --git a/Tools/CodeProfiler/_Source/CodeProfiler.dproj b/Tools/CodeProfiler/_Source/CodeProfiler.dproj index 5e5f378de..78f82eda0 100644 --- a/Tools/CodeProfiler/_Source/CodeProfiler.dproj +++ b/Tools/CodeProfiler/_Source/CodeProfiler.dproj @@ -1,188 +1,191 @@ <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> - <PropertyGroup> - <ProjectGuid>{AF4D00F0-C14D-4232-9454-D8872D1FA1D1}</ProjectGuid> - <MainSource>CodeProfiler.dpr</MainSource> - <Base>True</Base> - <Config Condition="'$(Config)'==''">Debug</Config> - <TargetedPlatforms>3</TargetedPlatforms> - <AppType>Application</AppType> - <FrameworkType>VCL</FrameworkType> - <ProjectVersion>20.3</ProjectVersion> - <Platform Condition="'$(Platform)'==''">Win64</Platform> - <ProjectName Condition="'$(ProjectName)'==''">CodeProfiler</ProjectName> - </PropertyGroup> - <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> - <Base_Win32>true</Base_Win32> - <CfgParent>Base</CfgParent> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> - <Base_Win64>true</Base_Win64> - <CfgParent>Base</CfgParent> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> - <Cfg_1>true</Cfg_1> - <CfgParent>Base</CfgParent> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''"> - <Cfg_1_Win32>true</Cfg_1_Win32> - <CfgParent>Cfg_1</CfgParent> - <Cfg_1>true</Cfg_1> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win64)'!=''"> - <Cfg_1_Win64>true</Cfg_1_Win64> - <CfgParent>Cfg_1</CfgParent> - <Cfg_1>true</Cfg_1> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> - <Cfg_2>true</Cfg_2> - <CfgParent>Base</CfgParent> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> - <Cfg_2_Win32>true</Cfg_2_Win32> - <CfgParent>Cfg_2</CfgParent> - <Cfg_2>true</Cfg_2> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> - <Cfg_2_Win64>true</Cfg_2_Win64> - <CfgParent>Cfg_2</CfgParent> - <Cfg_2>true</Cfg_2> - <Base>true</Base> - </PropertyGroup> - <PropertyGroup Condition="'$(Base)'!=''"> - <SanitizedProjectName>CodeProfiler</SanitizedProjectName> - <DCC_DcuOutput>.\Dcu\$(Platform)\$(Config)</DCC_DcuOutput> - <Manifest_File>None</Manifest_File> - <DCC_CodePage>65001</DCC_CodePage> - <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=13.1.26.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=io.magicfoundation.alcinoe.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=13.1.26.0;Comments=</VerInfo_Keys> - <VerInfo_Locale>1033</VerInfo_Locale> - <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> - <DCC_ImageBase>00400000</DCC_ImageBase> - <DCC_E>false</DCC_E> - <DCC_N>false</DCC_N> - <DCC_S>false</DCC_S> - <DCC_F>false</DCC_F> - <DCC_K>false</DCC_K> - <DCC_UnitSearchPath>..\..\..\Source;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> - <DCC_ExeOutput>..\</DCC_ExeOutput> - <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> - <VerInfo_MajorVer>13</VerInfo_MajorVer> - <VerInfo_Release>26</VerInfo_Release> - </PropertyGroup> - <PropertyGroup Condition="'$(Base_Win32)'!=''"> - <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> - <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> - <AppDPIAwarenessMode>none</AppDPIAwarenessMode> - <UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44> - <UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150> - </PropertyGroup> - <PropertyGroup Condition="'$(Base_Win64)'!=''"> - <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> - <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> - <UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44> - <UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150> - <AppDPIAwarenessMode>none</AppDPIAwarenessMode> - </PropertyGroup> - <PropertyGroup Condition="'$(Cfg_1)'!=''"> - <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> - <DCC_DebugInformation>0</DCC_DebugInformation> - <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> - <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> - </PropertyGroup> - <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''"> - <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> - </PropertyGroup> - <PropertyGroup Condition="'$(Cfg_1_Win64)'!=''"> - <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> - </PropertyGroup> - <PropertyGroup Condition="'$(Cfg_2)'!=''"> - <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> - <DCC_Optimize>false</DCC_Optimize> - <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> - </PropertyGroup> - <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> - <BT_BuildType>Debug</BT_BuildType> - <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> - </PropertyGroup> - <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> - <BT_BuildType>Debug</BT_BuildType> - <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> - <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=13.1.26.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=io.magicfoundation.alcinoe.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=13.1.26.0;Comments=</VerInfo_Keys> - <VerInfo_MajorVer>13</VerInfo_MajorVer> - <VerInfo_Release>26</VerInfo_Release> - </PropertyGroup> - <ItemGroup> - <DelphiCompile Include="$(MainSource)"> - <MainSource>MainSource</MainSource> - </DelphiCompile> - <BuildConfiguration Include="Base"> - <Key>Base</Key> - </BuildConfiguration> - <BuildConfiguration Include="Debug"> - <CfgParent>Base</CfgParent> - <Key>Cfg_2</Key> - </BuildConfiguration> - <BuildConfiguration Include="Release"> - <CfgParent>Base</CfgParent> - <Key>Cfg_1</Key> - </BuildConfiguration> - </ItemGroup> - <ProjectExtensions> - <Borland.Personality>Delphi.Personality.12</Borland.Personality> - <Borland.ProjectType/> - <BorlandProject> - <Delphi.Personality> - <Source> - <Source Name="MainSource">CodeProfiler.dpr</Source> - </Source> - <VersionInfo> - <VersionInfo Name="IncludeVerInfo">False</VersionInfo> - <VersionInfo Name="AutoIncBuild">False</VersionInfo> - <VersionInfo Name="MajorVer">13</VersionInfo> - <VersionInfo Name="MinorVer">1</VersionInfo> - <VersionInfo Name="Release">26</VersionInfo> - <VersionInfo Name="Build">357</VersionInfo> - <VersionInfo Name="Debug">False</VersionInfo> - <VersionInfo Name="PreRelease">False</VersionInfo> - <VersionInfo Name="Special">False</VersionInfo> - <VersionInfo Name="Private">False</VersionInfo> - <VersionInfo Name="DLL">False</VersionInfo> - <VersionInfo Name="Locale">1033</VersionInfo> - <VersionInfo Name="CodePage">1252</VersionInfo> - </VersionInfo> - <VersionInfoKeys> - <VersionInfoKeys Name="CompanyName"/> - <VersionInfoKeys Name="FileDescription"/> - <VersionInfoKeys Name="FileVersion">13.1.26.0</VersionInfoKeys> - <VersionInfoKeys Name="InternalName"/> - <VersionInfoKeys Name="LegalCopyright"/> - <VersionInfoKeys Name="LegalTrademarks"/> - <VersionInfoKeys Name="OriginalFilename"/> - <VersionInfoKeys Name="ProductName"/> - <VersionInfoKeys Name="ProductVersion">13.1.26.0</VersionInfoKeys> - <VersionInfoKeys Name="Comments"/> - </VersionInfoKeys> - <Excluded_Packages> - <Excluded_Packages Name="$(BDSBIN)\dcloffice2k370.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> - <Excluded_Packages Name="$(BDSBIN)\dclofficexp370.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> - </Excluded_Packages> - </Delphi.Personality> - <Platforms> - <Platform value="Win32">True</Platform> - <Platform value="Win64">True</Platform> - </Platforms> - </BorlandProject> - <ProjectFileVersion>12</ProjectFileVersion> - </ProjectExtensions> - <Import Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')" Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/> - <Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/> -</Project> \ No newline at end of file + <PropertyGroup> + <ProjectGuid>{AF4D00F0-C14D-4232-9454-D8872D1FA1D1}</ProjectGuid> + <MainSource>CodeProfiler.dpr</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>3</TargetedPlatforms> + <AppType>Application</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>20.4</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win64</Platform> + <ProjectName Condition="'$(ProjectName)'==''">CodeProfiler</ProjectName> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''"> + <Cfg_1_Win32>true</Cfg_1_Win32> + <CfgParent>Cfg_1</CfgParent> + <Cfg_1>true</Cfg_1> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win64)'!=''"> + <Cfg_1_Win64>true</Cfg_1_Win64> + <CfgParent>Cfg_1</CfgParent> + <Cfg_1>true</Cfg_1> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> + <Cfg_2_Win32>true</Cfg_2_Win32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''"> + <Cfg_2_Win64>true</Cfg_2_Win64> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <SanitizedProjectName>CodeProfiler</SanitizedProjectName> + <DCC_DcuOutput>.\Dcu\$(Platform)\$(Config)</DCC_DcuOutput> + <Manifest_File>None</Manifest_File> + <DCC_CodePage>65001</DCC_CodePage> + <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=13.1.26.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=io.magicfoundation.alcinoe.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=13.1.26.0;Comments=</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_E>false</DCC_E> + <DCC_N>false</DCC_N> + <DCC_S>false</DCC_S> + <DCC_F>false</DCC_F> + <DCC_K>false</DCC_K> + <DCC_UnitSearchPath>..\..\..\Source;c:\Dev\DelphiAST\Source\;c:\Dev\DelphiAST\Source\SimpleParser\;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> + <DCC_ExeOutput>..\</DCC_ExeOutput> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_MajorVer>13</VerInfo_MajorVer> + <VerInfo_Release>26</VerInfo_Release> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> + <AppDPIAwarenessMode>none</AppDPIAwarenessMode> + <UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44> + <UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> + <UWP_DelphiLogo44>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png</UWP_DelphiLogo44> + <UWP_DelphiLogo150>$(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png</UWP_DelphiLogo150> + <AppDPIAwarenessMode>none</AppDPIAwarenessMode> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''"> + <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1_Win64)'!=''"> + <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> + <BT_BuildType>Debug</BT_BuildType> + <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> + <BT_BuildType>Debug</BT_BuildType> + <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> + <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=13.1.26.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=io.magicfoundation.alcinoe.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=13.1.26.0;Comments=</VerInfo_Keys> + <VerInfo_MajorVer>13</VerInfo_MajorVer> + <VerInfo_Release>26</VerInfo_Release> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="Main.pas"> + <Form>MainForm</Form> + </DCCReference> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType/> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">CodeProfiler.dpr</Source> + </Source> + <VersionInfo> + <VersionInfo Name="IncludeVerInfo">False</VersionInfo> + <VersionInfo Name="AutoIncBuild">False</VersionInfo> + <VersionInfo Name="MajorVer">13</VersionInfo> + <VersionInfo Name="MinorVer">1</VersionInfo> + <VersionInfo Name="Release">26</VersionInfo> + <VersionInfo Name="Build">357</VersionInfo> + <VersionInfo Name="Debug">False</VersionInfo> + <VersionInfo Name="PreRelease">False</VersionInfo> + <VersionInfo Name="Special">False</VersionInfo> + <VersionInfo Name="Private">False</VersionInfo> + <VersionInfo Name="DLL">False</VersionInfo> + <VersionInfo Name="Locale">1033</VersionInfo> + <VersionInfo Name="CodePage">1252</VersionInfo> + </VersionInfo> + <VersionInfoKeys> + <VersionInfoKeys Name="CompanyName"/> + <VersionInfoKeys Name="FileDescription"/> + <VersionInfoKeys Name="FileVersion">13.1.26.0</VersionInfoKeys> + <VersionInfoKeys Name="InternalName"/> + <VersionInfoKeys Name="LegalCopyright"/> + <VersionInfoKeys Name="LegalTrademarks"/> + <VersionInfoKeys Name="OriginalFilename"/> + <VersionInfoKeys Name="ProductName"/> + <VersionInfoKeys Name="ProductVersion">13.1.26.0</VersionInfoKeys> + <VersionInfoKeys Name="Comments"/> + </VersionInfoKeys> + <Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dcloffice2k370.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dclofficexp370.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> + </Excluded_Packages> + </Delphi.Personality> + <Platforms> + <Platform value="Win32">True</Platform> + <Platform value="Win64">True</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')" Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/> + <Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/> +</Project> From 51ca1581f49dc66c90b08eab9d7af396b39ec2bf Mon Sep 17 00:00:00 2001 From: stv <stephane.vanderclock@pvsyst.com> Date: Tue, 22 Sep 2026 16:26:55 +0200 Subject: [PATCH 9/9] update --- .../DelphiAST/Source/SimpleParser/SimpleParser.pas | 13 +++++++++++++ Tools/CodeProfiler/_Source/CodeProfiler.dproj | 7 +++---- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/References/DelphiAST/Source/SimpleParser/SimpleParser.pas b/References/DelphiAST/Source/SimpleParser/SimpleParser.pas index d7efd2cb0..b9a4c6ae5 100644 --- a/References/DelphiAST/Source/SimpleParser/SimpleParser.pas +++ b/References/DelphiAST/Source/SimpleParser/SimpleParser.pas @@ -424,6 +424,7 @@ TmwSimplePasPar = class(TObject) procedure PointerSymbol; virtual; procedure PointerType; virtual; procedure ProceduralDirective; virtual; + procedure ProceduralDirectiveList; virtual; procedure ProceduralDirectiveOf; virtual; procedure ProceduralType; virtual; procedure ProcedureDeclarationSection; virtual; @@ -5588,6 +5589,7 @@ procedure TmwSimplePasPar.AnonymousMethod; FormalParameterList; end; end; + ProceduralDirectiveList; Block; end; @@ -5611,6 +5613,7 @@ procedure TmwSimplePasPar.AnonymousMethodType; ReturnType; end; end; + ProceduralDirectiveList; end; procedure TmwSimplePasPar.AddDefine(const ADefine: string); @@ -5699,6 +5702,16 @@ procedure TmwSimplePasPar.DeclarationSections; end; end; +procedure TmwSimplePasPar.ProceduralDirectiveList; +begin + // A calling convention may follow a procedural signature without a leading + // semicolon, e.g. "reference to function(const P: T): HResult stdcall;" as + // used by Vcl.Edge.pas. Consume every such directive. + while GenID in [ptCdecl, ptPascal, ptRegister, ptSafeCall, ptStdCall, + ptVarargs, ptNoreturn] do + ProceduralDirective; +end; + procedure TmwSimplePasPar.ProceduralDirectiveOf; begin NextToken; diff --git a/Tools/CodeProfiler/_Source/CodeProfiler.dproj b/Tools/CodeProfiler/_Source/CodeProfiler.dproj index 78f82eda0..f316e046e 100644 --- a/Tools/CodeProfiler/_Source/CodeProfiler.dproj +++ b/Tools/CodeProfiler/_Source/CodeProfiler.dproj @@ -72,11 +72,12 @@ <DCC_S>false</DCC_S> <DCC_F>false</DCC_F> <DCC_K>false</DCC_K> - <DCC_UnitSearchPath>..\..\..\Source;c:\Dev\DelphiAST\Source\;c:\Dev\DelphiAST\Source\SimpleParser\;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> + <DCC_UnitSearchPath>..\..\..\Source;..\..\..\References\DelphiAST\Source\;..\..\..\References\DelphiAST\Source\SimpleParser\;$(DCC_UnitSearchPath)</DCC_UnitSearchPath> <DCC_ExeOutput>..\</DCC_ExeOutput> <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> <VerInfo_MajorVer>13</VerInfo_MajorVer> <VerInfo_Release>26</VerInfo_Release> + <VerInfo_MinorVer>1</VerInfo_MinorVer> </PropertyGroup> <PropertyGroup Condition="'$(Base_Win32)'!=''"> <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> @@ -116,9 +117,7 @@ <PropertyGroup Condition="'$(Cfg_2_Win64)'!=''"> <BT_BuildType>Debug</BT_BuildType> <Manifest_File>$(BDS)\bin\default_app.manifest</Manifest_File> - <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=13.1.26.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=io.magicfoundation.alcinoe.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=13.1.26.0;Comments=</VerInfo_Keys> - <VerInfo_MajorVer>13</VerInfo_MajorVer> - <VerInfo_Release>26</VerInfo_Release> + <VerInfo_MinorVer>1</VerInfo_MinorVer> </PropertyGroup> <ItemGroup> <DelphiCompile Include="$(MainSource)">