paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-05 23:50:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fix generics >=Class and type ^File and external vars

Browse Source 
git-svn-id: trunk@47494 -
This commit is contained in:
michael 2020-11-20 16:14:49 +00:00
parent 45e2c837b8
commit 6ee3d6064f
4 changed files with 83 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
packages/fcl-passrc/src/pparser.pp
View File

@ -1192,29 +1192,40 @@ procedure TPasParser.ChangeToken(tk: TToken);
var
Cur, Last: PTokenRec;
IsLast: Boolean;
Procedure DoChange(tk1,tk2 : TToken);
begin
// change last token '>>' into two '>'
Cur:=@FTokenRing[FTokenRingCur];
Cur^.Token:=tk2;
Cur^.AsString:=TokenInfos[tk2];
Last:=@FTokenRing[FTokenRingEnd];
Last^.Token:=tk2;
Last^.AsString:=TokenInfos[tk2];
if Last^.Comments<>nil then
Last^.Comments.Clear;
Last^.SourcePos:=Cur^.SourcePos;
dec(Cur^.SourcePos.Column);
Last^.TokenPos:=Cur^.TokenPos;
inc(Last^.TokenPos.Column);
FTokenRingEnd:=(FTokenRingEnd+1) mod FTokenRingSize;
if FTokenRingStart=FTokenRingEnd then
FTokenRingStart:=(FTokenRingStart+1) mod FTokenRingSize;
FCurToken:=tk1;
FCurTokenString:=TokenInfos[tk1];
end;
begin
//writeln('TPasParser.ChangeToken FTokenBufferSize=',FTokenRingStart,' FTokenBufferIndex=',FTokenRingCur);
IsLast:=((FTokenRingCur+1) mod FTokenRingSize)=FTokenRingEnd;
if (CurToken=tkshr) and (tk=tkGreaterThan) and IsLast then
if (CurToken=tkGreaterEqualThan) and (tk=tkGreaterThan) and IsLast then
begin
// change last token '>>' into two '>'
Cur:=@FTokenRing[FTokenRingCur];
Cur^.Token:=tkGreaterThan;
Cur^.AsString:='>';
Last:=@FTokenRing[FTokenRingEnd];
Last^.Token:=tkGreaterThan;
Last^.AsString:='>';
if Last^.Comments<>nil then
Last^.Comments.Clear;
Last^.SourcePos:=Cur^.SourcePos;
dec(Cur^.SourcePos.Column);
Last^.TokenPos:=Cur^.TokenPos;
inc(Last^.TokenPos.Column);
FTokenRingEnd:=(FTokenRingEnd+1) mod FTokenRingSize;
if FTokenRingStart=FTokenRingEnd then
FTokenRingStart:=(FTokenRingStart+1) mod FTokenRingSize;
FCurToken:=tkGreaterThan;
FCurTokenString:='>';
DoChange(tkGreaterThan,tkEqual);
end
else if (CurToken=tkshr) and (tk=tkGreaterThan) and IsLast then
begin
DoChange(tkGreaterThan,tkGreaterThan);
end
else
CheckToken(tk);
@ -1770,7 +1781,7 @@ begin
Try
// only allowed: ^dottedidentifer
// forbidden: ^^identifier, ^array of word, ^A<B>
ExpectIdentifier;
ExpectTokens([tkIdentifier,tkFile]);
Name:=CurTokenString;
repeat
NextToken;
@ -4196,8 +4207,12 @@ begin
until CurToken<>tkComma;
Engine.FinishScope(stTypeDef,T);
until not (CurToken in [tkSemicolon,tkComma]);
if CurToken<>tkGreaterThan then
ParseExcExpectedAorB(TokenInfos[tkComma], TokenInfos[tkGreaterThan]);
if Not (CurToken in [tkGreaterThan,tkGreaterEqualThan]) then
ParseExcExpectedAorB(TokenInfos[tkComma], TokenInfos[tkGreaterThan])
else if CurToken=tkGreaterEqualThan then
begin
ChangeToken(tkGreaterThan);
end;
end;
{$warn 5043 on}
@ -4611,6 +4626,8 @@ begin
Result := Result + ' ' + CurTokenText;
LibName:=DoParseExpression(Parent);
end;
if CurToken=tkSemiColon then
exit;
if not CurTokenIsIdentifier('name') then
ParseExcSyntaxError;
NextToken;

22
packages/fcl-passrc/tests/tcgenerics.pp
View File

@ -21,6 +21,7 @@ Type
Procedure TestProcTypeGenerics;
Procedure TestDeclarationDelphi;
Procedure TestDeclarationFPC;
Procedure TestDeclarationFPCNoSpaces;
Procedure TestMethodImplementation;
// generic constraints
@ -141,6 +142,27 @@ begin
AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
end;
procedure TTestGenerics.TestDeclarationFPCNoSpaces;
Var
T : TPasClassType;
begin
Scanner.CurrentModeSwitches:=[msDelphi]+Scanner.CurrentModeSwitches;
Source.Add('Type');
Source.Add(' TSomeClass<T;T2>=Class(TObject)');
Source.Add(' b : T;');
Source.Add(' b2 : T2;');
Source.Add(' end;');
ParseDeclarations;
AssertNotNull('have generic definition',Declarations.Classes);
AssertEquals('have generic definition',1,Declarations.Classes.Count);
AssertEquals('Pascal class',TPasClassType,TObject(Declarations.Classes[0]).ClassType);
T:=TPasClassType(Declarations.Classes[0]);
AssertNotNull('have generic templates',T.GenericTemplateTypes);
AssertEquals('2 template types',2,T.GenericTemplateTypes.Count);
AssertSame('Parent 0 is class',T,TPasElement(T.GenericTemplateTypes[0]).Parent);
AssertSame('Parent 1 is class',T,TPasElement(T.GenericTemplateTypes[1]).Parent);
end;
procedure TTestGenerics.TestMethodImplementation;
begin
With source do

10
packages/fcl-passrc/tests/tctypeparser.pas
View File

@ -168,6 +168,7 @@ type
Procedure TestTypeHelperWithParent;
procedure TestPointerReference;
Procedure TestPointerKeyWord;
Procedure TestPointerFile;
end;
{ TTestRecordTypeParser }
@ -3674,6 +3675,15 @@ begin
AssertEquals('object definition count',1,Declarations.Classes.Count);
end;
procedure TTestTypeParser.TestPointerFile;
begin
Add('type');
Add(' pfile = ^file;');
ParseDeclarations;
AssertEquals('object definition count',1,Declarations.Types.Count);
end;
initialization
RegisterTests([TTestTypeParser,TTestRecordTypeParser,TTestProcedureTypeParser]);

12
packages/fcl-passrc/tests/tcvarparser.pas
View File

@ -49,6 +49,7 @@ Type
Procedure TestVarExternalLib;
Procedure TestVarExternalLibName;
procedure TestVarExternalNoSemiColon;
procedure TestVarExternalLibNoName;
Procedure TestVarCVar;
Procedure TestVarCVarExternal;
Procedure TestVarPublic;
@ -325,6 +326,17 @@ begin
AssertNotNull('Library symbol',TheVar.ExportName);
end;
procedure TTestVarParser.TestVarExternalLibNoName;
begin
// Found in e.g.apache headers
ParseVar('integer; external ''mylib''','');
AssertEquals('Variable modifiers',[vmexternal],TheVar.VarModifiers);
AssertNotNull('Library name',TheVar.LibraryName);
end;
procedure TTestVarParser.TestVarExternalLibName;
begin
ParseVar('integer; external ''mylib'' name ''de''','');