codetools: started test parsing record operators

git-svn-id: trunk@53668 -

.gitattributes

@@ -1049,6 +1049,7 @@ components/codetools/tests/testctxmlfixfragments.pas svneol=native#text/pascal
 components/codetools/tests/testfinddeclaration.pas svneol=native#text/plain
 components/codetools/tests/testglobals.pas svneol=native#text/plain
 components/codetools/tests/testmethodjumptool.pas svneol=native#text/plain
+components/codetools/tests/testpascalparser.pas svneol=native#text/plain
 components/codetools/tests/testrefactoring.pas svneol=native#text/plain
 components/codetools/tests/teststdcodetools.pas svneol=native#text/plain
 components/codetools/unitdictionary.pas svneol=native#text/plain

components/codetools/codetoolmanager.pas

@@ -130,6 +130,7 @@ type
     FWriteLockCount: integer;// Set/Unset counter
     FWriteLockStep: integer; // current write lock ID
     FHandlers: array[TCodeToolManagerHandler] of TMethodList;
+    FErrorDbgMsg: string;
     procedure DoOnRescanFPCDirectoryCache(Sender: TObject);
     function GetBeautifier: TBeautifyCodeOptions; inline;
     function DoOnScannerGetInitValues(Scanner: TLinkScanner; Code: Pointer;
@@ -277,6 +278,7 @@ type
     property ErrorLine: integer read fErrorLine;
     property ErrorMessage: string read fErrorMsg;
     property ErrorTopLine: integer read fErrorTopLine;
+    property ErrorDbgMsg: string read FErrorDbgMsg;
     property Abortable: boolean read FAbortable write SetAbortable;
     property OnCheckAbort: TOnCodeToolCheckAbort
                                          read FOnCheckAbort write FOnCheckAbort;
@@ -1850,11 +1852,11 @@ end;
 procedure TCodeToolManager.WriteError;
 begin
   if FWriteExceptions then begin
-    DbgOut('### TCodeToolManager.HandleException: "'+ErrorMessage+'"');
-    if ErrorLine>0 then DbgOut(' at Line=',DbgS(ErrorLine));
-    if ErrorColumn>0 then DbgOut(' Col=',DbgS(ErrorColumn));
-    if ErrorCode<>nil then DbgOut(' in "',ErrorCode.Filename,'"');
-    DebugLn('');
+    FErrorDbgMsg:='### TCodeToolManager.HandleException: "'+ErrorMessage+'"';
+    if ErrorLine>0 then FErrorDbgMsg+=' at Line='+DbgS(ErrorLine);
+    if ErrorColumn>0 then FErrorDbgMsg+=' Col='+DbgS(ErrorColumn);
+    if ErrorCode<>nil then FErrorDbgMsg+=' in "'+ErrorCode.Filename+'"';
+    Debugln(FErrorDbgMsg);
     {$IFDEF CTDEBUG}
     WriteDebugReport(true,false,false,false,false,false);
     {$ENDIF}

components/codetools/tests/runtestscodetools.lpi

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <Version Value="9"/>
+    <Version Value="10"/>
     <General>
       <Flags>
         <MainUnitHasCreateFormStatements Value="False"/>
@@ -37,7 +37,7 @@
         <PackageName Value="fpcunitconsolerunner"/>
       </Item2>
     </RequiredPackages>
-    <Units Count="13">
+    <Units Count="14">
       <Unit0>
         <Filename Value="runtestscodetools.lpr"/>
         <IsPartOfProject Value="True"/>
@@ -45,7 +45,7 @@
       <Unit1>
         <Filename Value="testfinddeclaration.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="TestFinddeclaration"/>
+        <UnitName Value="TestFindDeclaration"/>
       </Unit1>
       <Unit2>
         <Filename Value="fdt_typehelper.pas"/>
@@ -93,6 +93,11 @@
         <IsPartOfProject Value="True"/>
         <UnitName Value="TestGlobals"/>
       </Unit12>
+      <Unit13>
+        <Filename Value="testpascalparser.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="TestPascalParser"/>
+      </Unit13>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

components/codetools/tests/runtestscodetools.lpr

@@ -14,6 +14,12 @@
   at <http://www.gnu.org/copyleft/gpl.html>. You can also obtain it by writing
   to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
   MA 02111-1307, USA.
+
+  Abstract:
+    Testsuites for codetools.
+
+  Usage:
+
 }
 program runtestscodetools;
 
@@ -24,7 +30,7 @@ uses
   CodeToolManager, CodeToolsConfig,
   TestGlobals,
   TestBasicCodetools, TestCTRangeScan, TestMethodJumpTool, TestStdCodetools,
-  TestFinddeclaration, TestCompleteBlock, TestRefactoring,
+  TestFindDeclaration, TestCompleteBlock, TestRefactoring,
   // non Pascal
   TestCfgScript, TestCTH2Pas, TestCTXMLFixFragments,
   // compile test files to make sure they are valid Pascal
@@ -36,7 +42,7 @@ uses
   {$IFDEF Darwin}
   fdt_objccategory, fdt_objcclass,
   {$ENDIF}
-  fdt_classof, fdt_with, rt_explodewith, fdt_generics;
+  fdt_classof, fdt_with, rt_explodewith, fdt_generics, TestPascalParser;
 
 const
   ConfigFilename = 'codetools.config';

components/codetools/tests/testbasiccodetools.pas

@@ -572,7 +572,7 @@ begin
 end;
 
 initialization
-  AddToBasicTestSuite(TTestBasicCodeTools);
+  AddToPascalTestSuite(TTestBasicCodeTools);
 
 end.
 

components/codetools/tests/testcompleteblock.pas

@@ -1,15 +1,15 @@
 {
  Test all with:
-     ./runtests --format=plain --suite=TTestCodetoolsCompleteBlock
+   ./runtests --format=plain --suite=TTestCodetoolsCompleteBlock
 
  Test specific with:
-     ./runtests --format=plain --suite=TestCompleteBlockClassStart
-     ./runtests --format=plain --suite=TestCompleteBlockBegin
-     ./runtests --format=plain --suite=TestCompleteBlockRepeat
-     ./runtests --format=plain --suite=TestCompleteBlockCase
-     ./runtests --format=plain --suite=TestCompleteBlockTry
-     ./runtests --format=plain --suite=TestCompleteBlockAsm
-     ./runtests --format=plain --suite=TestCompleteBlockIf
+   ./runtests --format=plain --suite=TestCompleteBlockClassStart
+   ./runtests --format=plain --suite=TestCompleteBlockBegin
+   ./runtests --format=plain --suite=TestCompleteBlockRepeat
+   ./runtests --format=plain --suite=TestCompleteBlockCase
+   ./runtests --format=plain --suite=TestCompleteBlockTry
+   ./runtests --format=plain --suite=TestCompleteBlockAsm
+   ./runtests --format=plain --suite=TestCompleteBlockIf
 }
 unit TestCompleteBlock;
 
@@ -418,7 +418,7 @@ begin
 end;
 
 initialization
-  AddToRefactoringTestSuite(TTestCodetoolsCompleteBlock);
+  AddToPascalTestSuite(TTestCodetoolsCompleteBlock);
 
 end.
 

components/codetools/tests/testctrangescan.pas

@@ -392,7 +392,7 @@ begin
 end;
 
 initialization
-  AddToFindDeclarationTestSuite(TTestCodetoolsRangeScan);
+  AddToPascalTestSuite(TTestCodetoolsRangeScan);
 
 end.
 

components/codetools/tests/testfinddeclaration.pas

@@ -21,7 +21,7 @@
    ./testcodetools --format=plain --suite=TestFindDeclaration_LazTests --filemask=t*.pp
    ./testcodetools --format=plain --suite=TestFindDeclaration_LazTests --filemask=tdefaultproperty1.pp
 }
-unit TestFinddeclaration;
+unit TestFindDeclaration;
 
 {$mode objfpc}{$H+}
 
@@ -58,10 +58,6 @@ type
     procedure TestFindDeclaration_LazTests;
   end;
 
-var
-  BugsTestSuite: TTestSuite;
-  FindDeclarationTestSuite: TTestSuite;
-
 implementation
 
 { TTestFindDeclaration }
@@ -445,6 +441,6 @@ begin
 end;
 
 initialization
-  AddToFindDeclarationTestSuite(TTestFindDeclaration);
+  AddToPascalTestSuite(TTestFindDeclaration);
 end.
 

components/codetools/tests/testglobals.pas

@@ -9,40 +9,21 @@ uses
   classes, sysutils, process;
 
 var
-  BasicTestSuite: TTestSuite;
-  FindDeclararionTestSuite: TTestSuite;
-  StdToolsTestSuite: TTestSuite;
-  RefactoringTestSuite: TTestSuite;
+  PascalTestSuite: TTestSuite;
   NonPascalTestSuite: TTestSuite;
   BugsTestSuite: TTestSuite;
 
-procedure AddToBasicTestSuite(ATestClass: TClass);
-procedure AddToFindDeclarationTestSuite(ATestClass: TClass);
-procedure AddToStdToolsTestSuite(ATestClass: TClass);
-procedure AddToRefactoringTestSuite(ATestClass: TClass);
+procedure AddToPascalTestSuite(ATestClass: TClass);
 procedure AddToNonPascalTestSuite(ATestClass: TClass);
 procedure AddToBugsTestSuite(ATest: TTest);
 
+function LinesToStr(Args: array of const): string;
+
 implementation
 
-procedure AddToBasicTestSuite(ATestClass: TClass);
+procedure AddToPascalTestSuite(ATestClass: TClass);
 begin
-  BasicTestSuite.AddTestSuiteFromClass(ATestClass);
-end;
-
-procedure AddToFindDeclarationTestSuite(ATestClass: TClass);
-begin
-  FindDeclararionTestSuite.AddTestSuiteFromClass(ATestClass);
-end;
-
-procedure AddToStdToolsTestSuite(ATestClass: TClass);
-begin
-  StdToolsTestSuite.AddTestSuiteFromClass(ATestClass);
-end;
-
-procedure AddToRefactoringTestSuite(ATestClass: TClass);
-begin
-  RefactoringTestSuite.AddTestSuiteFromClass(ATestClass);
+  PascalTestSuite.AddTestSuiteFromClass(ATestClass);
 end;
 
 procedure AddToNonPascalTestSuite(ATestClass: TClass);
@@ -55,16 +36,30 @@ begin
   BugsTestSuite.AddTest(ATest);
 end;
 
+function LinesToStr(Args: array of const): string;
+var
+  s: String;
+  i: Integer;
+begin
+  s:='';
+  for i:=Low(Args) to High(Args) do
+    case Args[i].VType of
+      vtChar:         s += Args[i].VChar+LineEnding;
+      vtString:       s += Args[i].VString^+LineEnding;
+      vtPChar:        s += Args[i].VPChar+LineEnding;
+      vtWideChar:     s += AnsiString(Args[i].VWideChar)+LineEnding;
+      vtPWideChar:    s += AnsiString(Args[i].VPWideChar)+LineEnding;
+      vtAnsiString:   s += AnsiString(Args[i].VAnsiString)+LineEnding;
+      vtWidestring:   s += AnsiString(WideString(Args[i].VWideString))+LineEnding;
+      vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString))+LineEnding;
+    end;
+  Result:=s;
+end;
+
 initialization
   GetTestRegistry.TestName := 'All tests';
-  BasicTestSuite := TTestSuite.Create('Basic tests');
-  GetTestRegistry.AddTest(BasicTestSuite);
-  FindDeclararionTestSuite := TTestSuite.Create('FindDeclaration tests');
-  GetTestRegistry.AddTest(FindDeclararionTestSuite);
-  StdToolsTestSuite := TTestSuite.Create('StdTools tests');
-  GetTestRegistry.AddTest(StdToolsTestSuite);
-  RefactoringTestSuite := TTestSuite.Create('Refactoring tests');
-  GetTestRegistry.AddTest(RefactoringTestSuite);
+  PascalTestSuite := TTestSuite.Create('Pascal tests');
+  GetTestRegistry.AddTest(PascalTestSuite);
   NonPascalTestSuite := TTestSuite.Create('No Pascal tests');
   GetTestRegistry.AddTest(NonPascalTestSuite);
   BugsTestSuite := TTestSuite.Create('Bugs');

components/codetools/tests/testmethodjumptool.pas

@@ -120,7 +120,7 @@ begin
 end;
 
 initialization
-  AddToStdToolsTestSuite(TTestCTMethodJumpTool);
+  AddToPascalTestSuite(TTestCTMethodJumpTool);
 
 end.
 

components/codetools/tests/testpascalparser.pas

@@ -0,0 +1,122 @@
+{
+ Test all with:
+   ./runtests --format=plain --suite=TTestPascalParser
+
+ Test specific with:
+   ./runtests --format=plain --suite=TestRecord_ClassOperators
+}
+unit TestPascalParser;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, CodeToolManager, CodeCache,
+  LazLogger, fpcunit, testregistry, TestGlobals;
+
+type
+
+  { TTestPascalParser }
+
+  TTestPascalParser = class(TTestCase)
+  private
+    FCode: TCodeBuffer;
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  public
+    procedure Add(const s: string);
+    procedure Add(Args: array of const);
+    procedure StartUnit;
+    procedure StartProgram;
+    procedure ParseModule;
+    property Code: TCodeBuffer read FCode;
+  published
+    procedure TestRecord_ClassOperators;
+  end;
+
+implementation
+
+{ TTestPascalParser }
+
+procedure TTestPascalParser.SetUp;
+begin
+  inherited SetUp;
+  FCode:=CodeToolBoss.CreateFile('test1.pas');
+end;
+
+procedure TTestPascalParser.TearDown;
+begin
+  inherited TearDown;
+end;
+
+procedure TTestPascalParser.Add(const s: string);
+begin
+  FCode.Source:=FCode.Source+s+LineEnding;
+end;
+
+procedure TTestPascalParser.Add(Args: array of const);
+begin
+  FCode.Source:=FCode.Source+LinesToStr(Args);
+end;
+
+procedure TTestPascalParser.StartUnit;
+begin
+  Add('unit test1;');
+  Add('');
+  Add('{$mode objfpc}{$H+}');
+  Add('');
+  Add('interface');
+  Add('');
+end;
+
+procedure TTestPascalParser.StartProgram;
+begin
+  Add('program test1;');
+  Add('');
+  Add('{$mode objfpc}{$H+}');
+  Add('');
+end;
+
+procedure TTestPascalParser.ParseModule;
+var
+  Tool: TCodeTool;
+  Cnt, i: Integer;
+begin
+  Add('end.');
+  if not CodeToolBoss.Explore(Code,Tool,true) then begin
+    debugln(Code.Filename+'------------------------------------------');
+    if CodeToolBoss.ErrorLine>0 then
+      Cnt:=CodeToolBoss.ErrorLine
+    else
+      Cnt:=Code.LineCount;
+    for i:=1 to Cnt do
+      debugln(Format('%:4d: ',[i]),Code.GetLine(i-1,false));
+    debugln('Error: '+CodeToolBoss.ErrorDbgMsg);
+    Fail('PascalParser failed: '+CodeToolBoss.ErrorMessage);
+  end;
+end;
+
+procedure TTestPascalParser.TestRecord_ClassOperators;
+begin
+  StartProgram;
+  Add([
+    'type',
+    '  TMyRecord = record',
+    '    class operator Implicit(t: TMyRecord): TMyRecord;',
+    '  end;',
+    '',
+    'class operator TMyRecord.Implicit(t: TMyRecord): TMyRecord;',
+    'begin end;',
+    '',
+    'begin'
+    ]);
+  ParseModule;
+end;
+
+initialization
+  AddToPascalTestSuite(TTestPascalParser);
+
+end.
+

components/codetools/tests/teststdcodetools.pas

@@ -197,7 +197,7 @@ begin
 end;
 
 initialization
-  AddToStdToolsTestSuite(TTestCTStdCodetools);
+  AddToPascalTestSuite(TTestCTStdCodetools);
 
 end.