mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-08 23:52:37 +02:00
341 lines
9.9 KiB
ObjectPascal
341 lines
9.9 KiB
ObjectPascal
{
|
|
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, math, CodeToolManager, CodeCache, CodeAtom,
|
|
LazLogger, fpcunit, testregistry, TestGlobals;
|
|
|
|
type
|
|
|
|
{ TCustomTestPascalParser }
|
|
|
|
TCustomTestPascalParser = class(TTestCase)
|
|
private
|
|
FCode: TCodeBuffer;
|
|
protected
|
|
procedure SetUp; override;
|
|
procedure TearDown; override;
|
|
procedure DoParseModule(aCode: TCodeBuffer; out Tool: TCodeTool);
|
|
public
|
|
procedure Add(const s: string);
|
|
procedure Add(Args: array of const);
|
|
procedure StartUnit;
|
|
procedure StartProgram;
|
|
procedure ParseModule;
|
|
property Code: TCodeBuffer read FCode;
|
|
end;
|
|
|
|
{ TTestPascalParser }
|
|
|
|
TTestPascalParser = class(TCustomTestPascalParser)
|
|
published
|
|
procedure TestAtomRing;
|
|
procedure TestRecord_ClassOperators;
|
|
procedure TestDeprecated;
|
|
end;
|
|
|
|
implementation
|
|
|
|
{ TCustomTestPascalParser }
|
|
|
|
procedure TCustomTestPascalParser.SetUp;
|
|
begin
|
|
inherited SetUp;
|
|
FCode:=CodeToolBoss.CreateFile('test1.pas');
|
|
end;
|
|
|
|
procedure TCustomTestPascalParser.TearDown;
|
|
begin
|
|
inherited TearDown;
|
|
end;
|
|
|
|
procedure TCustomTestPascalParser.DoParseModule(aCode: TCodeBuffer; out
|
|
Tool: TCodeTool);
|
|
var
|
|
i: Integer;
|
|
Line: String;
|
|
begin
|
|
if not CodeToolBoss.Explore(aCode,Tool,true) then begin
|
|
debugln(aCode.Filename+'------------------------------------------');
|
|
for i:=1 to aCode.LineCount do begin
|
|
Line:=aCode.GetLine(i-1,false);
|
|
if i=CodeToolBoss.ErrorLine then
|
|
System.Insert('|',Line,CodeToolBoss.ErrorColumn);
|
|
debugln(Format('%:4d: ',[i]),Line);
|
|
end;
|
|
debugln('Error: '+CodeToolBoss.ErrorDbgMsg);
|
|
Fail('PascalParser failed: '+CodeToolBoss.ErrorMessage);
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomTestPascalParser.Add(const s: string);
|
|
begin
|
|
FCode.Source:=FCode.Source+s+LineEnding;
|
|
end;
|
|
|
|
procedure TCustomTestPascalParser.Add(Args: array of const);
|
|
begin
|
|
FCode.Source:=FCode.Source+LinesToStr(Args);
|
|
end;
|
|
|
|
procedure TCustomTestPascalParser.StartUnit;
|
|
begin
|
|
Add('unit test1;');
|
|
Add('');
|
|
Add('{$mode objfpc}{$H+}');
|
|
Add('');
|
|
Add('interface');
|
|
Add('');
|
|
end;
|
|
|
|
procedure TCustomTestPascalParser.StartProgram;
|
|
begin
|
|
Add('program test1;');
|
|
Add('');
|
|
Add('{$mode objfpc}{$H+}');
|
|
Add('');
|
|
end;
|
|
|
|
procedure TCustomTestPascalParser.ParseModule;
|
|
var
|
|
Tool: TCodeTool;
|
|
begin
|
|
Add('end.');
|
|
DoParseModule(Code,Tool);
|
|
end;
|
|
|
|
{ TTestPascalParser }
|
|
|
|
procedure TTestPascalParser.TestAtomRing;
|
|
|
|
procedure CheckAtom(Msg: String; const Expected, Actual: TAtomPosition);
|
|
begin
|
|
AssertEquals(Msg+' StartPos',Expected.StartPos,Actual.StartPos);
|
|
AssertEquals(Msg+' EndPos',Expected.EndPos,Actual.EndPos);
|
|
if Expected.Flag<>Actual.Flag then
|
|
Fail(Msg+' Flag Expected='+CommonAtomFlagNames[Expected.Flag]+' but found '+CommonAtomFlagNames[Actual.Flag]);
|
|
end;
|
|
|
|
procedure CheckIndexOf(Msg: string; R: TAtomRing);
|
|
var
|
|
i, Actual: Integer;
|
|
P: TAtomPosition;
|
|
begin
|
|
for i:=1-R.PriorCount to R.NextCount do begin
|
|
P:=R.GetAtomAt(i);
|
|
if not R.IndexOf(P.StartPos,Actual) then
|
|
Fail(Msg+' CheckIndexOf i='+IntToStr(i)+' IndexOf failed');
|
|
AssertEquals(Msg+' CheckIndexOf',i,Actual);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
R: TAtomRing;
|
|
P, P1, P2: TAtomPosition;
|
|
i: Integer;
|
|
begin
|
|
R:=TAtomRing.Create;
|
|
try
|
|
R.Size:=4;
|
|
AssertEquals('1-empty count',0,R.PriorCount);
|
|
AssertEquals('1-empty nextcount',0,R.NextCount);
|
|
|
|
P1:=AtomPosition(1,2,cafWord);
|
|
R.Add(P1);
|
|
AssertEquals('2-first atom count',1,R.PriorCount);
|
|
AssertEquals('2-first atom nextcount',0,R.NextCount);
|
|
P:=R.GetAtomAt(0);
|
|
CheckAtom('2-first atom',P1,P);
|
|
|
|
CheckIndexOf('2-first atom',R);
|
|
|
|
R.UndoLastAdd;
|
|
//R.WriteDebugReport;
|
|
AssertEquals('3-empty after undo count',0,R.PriorCount);
|
|
AssertEquals('3-empty after undo nextcount',0,R.NextCount);
|
|
|
|
P1:=AtomPosition(1,2,cafWord);
|
|
R.Add(P1);
|
|
//R.WriteDebugReport;
|
|
AssertEquals('4-first atom count',1,R.PriorCount);
|
|
AssertEquals('4-first atom nextcount',0,R.NextCount);
|
|
P:=R.GetAtomAt(0);
|
|
CheckAtom('4-first atom',P1,P);
|
|
CheckIndexOf('4-first atom',R);
|
|
|
|
P2:=AtomPosition(3,4,cafWord);
|
|
R.Add(P2);
|
|
//R.WriteDebugReport;
|
|
|
|
AssertEquals('5-second atom count',2,R.PriorCount);
|
|
AssertEquals('5-second atom nextcount',0,R.NextCount);
|
|
P:=R.GetAtomAt(0);
|
|
CheckAtom('5-second atom 0',P2,P);
|
|
P:=R.GetAtomAt(-1);
|
|
CheckAtom('5-second atom -1',P1,P);
|
|
CheckIndexOf('5-second atom',R);
|
|
|
|
R.UndoLastAdd;
|
|
//R.WriteDebugReport;
|
|
AssertEquals('6-undo after add two: count',1,R.PriorCount);
|
|
AssertEquals('6-undo after add two: nextcount',1,R.NextCount);
|
|
P:=R.GetAtomAt(0);
|
|
CheckAtom('6-undo after add two: atom 0',P1,P);
|
|
P:=R.GetAtomAt(1);
|
|
CheckAtom('6-undo after add two: atom +1',P2,P);
|
|
CheckIndexOf('6-undo after add two',R);
|
|
|
|
P2:=AtomPosition(5,6,cafWord);
|
|
R.Add(P2);
|
|
//R.WriteDebugReport;
|
|
|
|
AssertEquals('7-second atom count',2,R.PriorCount);
|
|
AssertEquals('7-second atom nextcount',0,R.NextCount);
|
|
P:=R.GetAtomAt(0);
|
|
CheckAtom('7-second atom 0',P2,P);
|
|
P:=R.GetAtomAt(-1);
|
|
CheckAtom('7-second atom -1',P1,P);
|
|
CheckIndexOf('7-second atom',R);
|
|
|
|
R.Clear;
|
|
//R.WriteDebugReport;
|
|
for i:=1 to 5 do begin
|
|
// add first
|
|
P1:=AtomPosition(i*4,i*4+1,cafWord);
|
|
R.Add(P1);
|
|
//R.WriteDebugReport;
|
|
AssertEquals('8-Added first: '+IntToStr(i)+' count',Min(i,R.Size),R.PriorCount);
|
|
AssertEquals('8-Added first: '+IntToStr(i)+' nextcount',0,R.NextCount);
|
|
P:=R.GetAtomAt(0);
|
|
CheckAtom('8-Added first: atom 0',P1,P);
|
|
CheckIndexOf('8-Added first',R);
|
|
|
|
// add two
|
|
P2:=AtomPosition(i*4+2,i*4+3,cafWord);
|
|
R.Add(P2);
|
|
//R.WriteDebugReport;
|
|
AssertEquals('9-Added second: '+IntToStr(i)+' count',Min(i+1,R.Size),R.PriorCount);
|
|
AssertEquals('9-Added second: '+IntToStr(i)+' nextcount',0,R.NextCount);
|
|
P:=R.GetAtomAt(0);
|
|
CheckAtom('9-Added second: '+IntToStr(i)+' atom 0',P2,P);
|
|
P:=R.GetAtomAt(-1);
|
|
CheckAtom('9-Added second: '+IntToStr(i)+' atom -1',P1,P);
|
|
CheckIndexOf('9-Added second',R);
|
|
|
|
// undo one
|
|
R.UndoLastAdd;
|
|
//R.WriteDebugReport;
|
|
AssertEquals('10-Undo: '+IntToStr(i)+' count',Min(i,R.Size-1),R.PriorCount);
|
|
AssertEquals('10-Undo: '+IntToStr(i)+' nextcount',1,R.NextCount);
|
|
P:=R.GetAtomAt(0);
|
|
CheckAtom('10-Undo: '+IntToStr(i)+' atom 0',P1,P);
|
|
P:=R.GetAtomAt(1);
|
|
CheckAtom('10-Undo: '+IntToStr(i)+' atom +1',P2,P);
|
|
CheckIndexOf('10-Undo',R);
|
|
end;
|
|
|
|
FreeAndNil(R);
|
|
finally
|
|
if R<>nil then begin
|
|
R.WriteDebugReport;
|
|
R.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTestPascalParser.TestRecord_ClassOperators;
|
|
begin
|
|
StartProgram;
|
|
Add([
|
|
'type',
|
|
' TFlag = (flag1);',
|
|
'{$Define FPC_HAS_MANAGEMENT_OPERATORS}',
|
|
' TMyRecord = record',
|
|
' class operator Implicit(t: TMyRecord): TMyRecord;',
|
|
' class operator Explicit(t: TMyRecord): TMyRecord;',
|
|
' class operator Negative(t: TMyRecord): TMyRecord;',
|
|
' class operator Positive(t: TMyRecord): TMyRecord;',
|
|
' class operator Inc(t: TMyRecord): TMyRecord;',
|
|
' class operator Dec(t: TMyRecord): TMyRecord;',
|
|
' class operator LogicalNot(t: TMyRecord): TMyRecord;',
|
|
' class operator Trunc(t: TMyRecord): TMyRecord;',
|
|
' class operator Round(t: TMyRecord): TMyRecord;',
|
|
' class operator In(f: TFlag; t: TMyRecord): boolean;',
|
|
' class operator Equal(t1, t2: TMyRecord): boolean;',
|
|
' class operator NotEqual(t1, t2: TMyRecord): boolean;',
|
|
' class operator GreaterThan(t1, t2: TMyRecord): boolean;',
|
|
' class operator GreaterThanOrEqual(t1, t2: TMyRecord): boolean;',
|
|
' class operator LessThan(t1, t2: TMyRecord): boolean;',
|
|
' class operator LessThanOrEqual(t1, t2: TMyRecord): boolean;',
|
|
' class operator Add(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator Subtract(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator Multiply(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator Divide(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator IntDivide(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator Modulus(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator LeftShift(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator RightShift(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator LogicalAnd(b: boolean; t: TMyRecord): TMyRecord;',
|
|
' class operator LogicalOr(b: boolean; t: TMyRecord): TMyRecord;',
|
|
' class operator LogicalXor(b: boolean; t: TMyRecord): TMyRecord;',
|
|
' class operator BitwiseAnd(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator BitwiseOr(t1, t2: TMyRecord): TMyRecord;',
|
|
' class operator BitwiseXor(t1, t2: TMyRecord): TMyRecord;',
|
|
' // only IFDEF FPC_HAS_MANAGEMENT_OPERATORS',
|
|
' class operator Initialize(var t: TMyRecord);',
|
|
' class operator Finalize(var t: TMyRecord);',
|
|
' class operator Copy(var t: TMyRecord);',
|
|
' class operator AddRef(constref t1: TMyRecord ; var t2: TMyRecord);',
|
|
' end;',
|
|
'',
|
|
'class operator TMyRecord.Implicit(t: TMyRecord): TMyRecord;',
|
|
'begin end;',
|
|
'',
|
|
'// only IFDEF FPC_HAS_MANAGEMENT_OPERATORS',
|
|
'class operator TMyRecord.Initialize(var t: TMyRecord);',
|
|
'begin end;',
|
|
'',
|
|
'begin'
|
|
]);
|
|
ParseModule;
|
|
end;
|
|
|
|
procedure TTestPascalParser.TestDeprecated;
|
|
begin
|
|
StartProgram;
|
|
Add([
|
|
'type',
|
|
' t = string deprecated ''t'';',
|
|
' TBird = class',
|
|
' FA: longint deprecated;',
|
|
' Deprecated: longint;',
|
|
' procedure SetA; deprecated;',
|
|
' property A: longint read FA; deprecated;',
|
|
' Platform: longint;',
|
|
' end deprecated ''tbird'';',
|
|
'var',
|
|
' c: char deprecated;',
|
|
' b: boolean deprecated ''b'';',
|
|
' deprecated: boolean;',
|
|
'procedure DoIt; deprecated;',
|
|
'begin end;',
|
|
'begin']);
|
|
ParseModule;
|
|
end;
|
|
|
|
initialization
|
|
RegisterTest(TTestPascalParser);
|
|
|
|
end.
|
|
|