paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 20:29:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Advanced records structure changed, fixed fpdoc

Browse Source 
git-svn-id: trunk@47510 -
(cherry picked from commit 5354cf2a61)
This commit is contained in:
michael 2020-11-21 12:11:38 +00:00 committed by Florian Klämpfl
parent af1bb99fe8
commit 373721ee36
6 changed files with 125 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
packages/fcl-passrc/src/pastree.pp
View File

@ -1169,7 +1169,8 @@ type
otBitwiseAnd, otbitwiseXor,
otLogicalAnd, otLogicalNot, otLogicalXor,
otRightShift,
otEnumerator, otIn
otEnumerator, otIn,
otInitialize // Management operator
);
TOperatorTypes = set of TOperatorType;
@ -1751,13 +1752,13 @@ const
'>',':=','<>','<=','>=','**',
'><','Inc','Dec','mod','-','+','Or','div',
'shl','or','and','xor','and','not','xor',
'shr','enumerator','in');
'shr','enumerator','in','');
OperatorNames : Array[TOperatorType] of string
= ('','implicit','explicit','multiply','add','subtract','divide','lessthan','equal',
'greaterthan','assign','notequal','lessthanorequal','greaterthanorequal','power',
'symmetricaldifference','inc','dec','modulus','negative','positive','bitwiseor','intdivide',
'leftshift','logicalor','bitwiseand','bitwisexor','logicaland','logicalnot','logicalxor',
'rightshift','enumerator','in');
'rightshift','enumerator','in','initialize');
AssignKindNames : Array[TAssignKind] of string = (':=','+=','-=','*=','/=' );
@ -2836,7 +2837,9 @@ begin
Result := Result + ', ';
Result := Result + TPasArgument(ProcType.Args[i]).ArgType.Name;
end;
Result := Result + '): ' + TPasFunctionType(ProcType).ResultEl.ResultType.Name;
Result := Result + ')';
if (OperatorType<>otInitialize) and Assigned(TPasFunctionType(ProcType).ResultEl.ResultType) then
Result:=Result+': ' + TPasFunctionType(ProcType).ResultEl.ResultType.Name;
If WithPath then
begin
S:=Self.ParentPath;

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

@ -5356,13 +5356,17 @@ begin
begin
ResultEl.Name := CurTokenName;
ExpectToken(tkColon);
end
else
if (CurToken=tkColon) then
ResultEl.Name := 'Result'
else
ParseExc(nParserExpectedColonID,SParserExpectedColonID);
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
end
else if not ((Parent is TPasOperator) and (TPasOperator(Parent).OperatorType=otInitialize)) then
// Initialize operator has no result
begin
if (CurToken=tkColon) then
ResultEl.Name := 'Result'
else
ParseExc(nParserExpectedColonID,SParserExpectedColonID);
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
end;
end;
else
ResultEl:=Nil;
@ -6883,7 +6887,10 @@ Var
CurEl: TPasElement;
LastToken: TToken;
AllowVisibility: Boolean;
IsGeneric : Boolean;
begin
IsGeneric:=False;
AllowVisibility:=msAdvancedRecords in CurrentModeswitches;
if AllowVisibility then
v:=visPublic
@ -6969,7 +6976,7 @@ begin
if Not AllowMethods then
ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed);
ProcType:=GetProcTypeFromToken(CurToken,LastToken=tkclass);
Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,false,v);
Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,IsGeneric,v);
if Proc.Parent is TPasOverloadedProc then
TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc)
else
@ -6978,9 +6985,21 @@ begin
end;
tkDestructor:
ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
tkabsolute,tkGeneric,tkSelf, // Counts as field name
tkGeneric, // Can count as field name
tkabsolute,
tkSelf, // Count as field name
tkIdentifier :
begin
if (Curtoken=tkGeneric) and AllowVisibility then
begin
NextToken;
if CurToken in [tkClass,tkOperator,tkFunction,tkProcedure] then
begin
IsGeneric:=True;
Continue;
end;
UnGetToken;
end;
If AllowVisibility and CheckVisibility(CurTokenString,v) then
begin
if not (v in [visPrivate,visPublic,visStrictPrivate]) then
@ -7034,6 +7053,8 @@ begin
break;
LastToken:=CurToken;
NextToken;
if not IsClass then
IsGeneric:=False;
end;
end;

8
packages/fcl-passrc/tests/tcprocfunc.pas
View File

@ -178,6 +178,7 @@ type
Procedure TestProcedureCdeclExternalName;
Procedure TestFunctionCdeclExternalName;
Procedure TestFunctionAlias;
Procedure TestOperatorNamedResult;
Procedure TestOperatorTokens;
procedure TestOperatorNames;
Procedure TestAssignOperatorAfterObject;
@ -1312,6 +1313,13 @@ begin
AssertEquals('Alias name','''myalias''',Func.AliasName);
end;
procedure TTestProcedureFunction.TestOperatorNamedResult;
begin
AddDeclaration('operator = (a,b : T) z : Integer;');
ParseOperator;
AssertEquals('Correct operator type',otEqual,FOperator.OperatorType);
end;
procedure TTestProcedureFunction.TestProcedureAlias;
begin
AddDeclaration('Procedure A; Alias : ''myalias''');

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

@ -368,6 +368,8 @@ type
Procedure TestAdvRecordInFunction;
Procedure TestAdvRecordInAnonFunction;
Procedure TestAdvRecordClassOperator;
Procedure TestAdvRecordInitOperator;
Procedure TestAdvRecordGenericFunction;
end;
{ TTestProcedureTypeParser }
@ -2715,6 +2717,51 @@ begin
ParseModule; // We're just interested in that it parses.
end;
procedure TTestRecordTypeParser.TestAdvRecordInitOperator;
// Source from bug id 36180
Const
SRC =
'{$mode objfpc}'+sLineBreak+
'{$modeswitch advancedrecords}'+sLineBreak+
'program afile;'+sLineBreak+
'type'+sLineBreak+
' TMyRecord = record'+sLineBreak+
' class operator initialize (var self: TMyRecord);'+sLineBreak+
' end;'+sLineBreak+
'class operator TMyRecord.initialize (a, b: TMyRecord);'+sLineBreak+
'begin'+sLineBreak+
' result := (@a = @b);'+sLineBreak+
'end;'+sLineBreak+
'begin'+sLineBreak+
'end.';
begin
Source.Text:=Src;
ParseModule; // We're just interested in that it parses.
end;
procedure TTestRecordTypeParser.TestAdvRecordGenericFunction;
Const
SRC =
'{$mode objfpc}'+sLineBreak+
'{$modeswitch advancedrecords}'+sLineBreak+
'program afile;'+sLineBreak+
'type'+sLineBreak+
' TMyRecord = record'+sLineBreak+
' generic class procedure doit<T> (a: T);'+sLineBreak+
' end;'+sLineBreak+
'generic class procedure TMyRecord.DoIt<T>(a: T);'+sLineBreak+
'begin'+sLineBreak+
'end;'+sLineBreak+
'begin'+sLineBreak+
'end.';
begin
Source.Text:=Src;
ParseModule; // We're just interested in that it parses.
end;
{ TBaseTestTypeParser }
Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;

3
packages/pastojs/src/pas2jsfiler.pp
View File

@ -485,7 +485,8 @@ const
'LogicalXor',
'RightShift',
'Enumerator',
'In'
'In',
'Initialize'
);
PCUProcedureModifierNames: array[TProcedureModifier] of string = (

56
utils/fpdoc/dglobals.pp
View File

@ -1056,7 +1056,8 @@ var
i, j, k: Integer;
Module: TPasModule;
Alias : TPasAliasType;
ClassDecl: TPasClassType;
MemberDecl: TPasMembersType;
ClassLikeDecl : TPasClassType;
Member: TPasElement;
s: String;
Buf : TBufType;
@ -1089,41 +1090,48 @@ begin
if not assigned(Module.InterfaceSection) then
continue;
for j := 0 to Module.InterfaceSection.Classes.Count - 1 do
begin
ClassDecl := TPasClassType(Module.InterfaceSection.Classes[j]);
Write(ContentFile, CheckImplicitInterfaceLink(ClassDecl.PathName), ' ');
if Assigned(ClassDecl.AncestorType) then
begin
MemberDecl := TPasClassType(Module.InterfaceSection.Classes[j]);
if MemberDecl is TPasClassType then
ClassLikeDecl:=MemberDecl as TPasClassType
else
ClassLikeDecl:=nil;
Write(ContentFile, CheckImplicitInterfaceLink(MemberDecl.PathName), ' ');
if Assigned(ClassLikeDecl) then
begin
// simple aliases to class types are coded as "alias(classtype)"
Write(ContentFile, CheckImplicitInterfaceLink(ClassDecl.AncestorType.PathName));
if ClassDecl.AncestorType is TPasAliasType then
if Assigned(ClassLikeDecl.AncestorType) then
begin
// simple aliases to class types are coded as "alias(classtype)"
Write(ContentFile, CheckImplicitInterfaceLink(ClassLikeDecl.AncestorType.PathName));
if ClassLikeDecl.AncestorType is TPasAliasType then
begin
alias:= TPasAliasType(ClassDecl.AncestorType);
if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
write(ContentFile,'(',alias.desttype.PathName,')');
alias:= TPasAliasType(ClassLikeDecl.AncestorType);
if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
write(ContentFile,'(',alias.desttype.PathName,')');
end;
end
else if ClassDecl.ObjKind = okClass then
Write(ContentFile, '#rtl.System.TObject')
else if ClassDecl.ObjKind = okInterface then
Write(ContentFile, '#rtl.System.IUnknown');
if ClassDecl.Interfaces.Count>0 then
begin
for k:=0 to ClassDecl.Interfaces.count-1 do
end
else if ClassLikeDecl.ObjKind = okClass then
Write(ContentFile, '#rtl.System.TObject')
else if ClassLikeDecl.ObjKind = okInterface then
Write(ContentFile, '#rtl.System.IUnknown');
if ClassLikeDecl.Interfaces.Count>0 then
begin
for k:=0 to ClassLikeDecl.Interfaces.count-1 do
begin
write(contentfile,',',CheckImplicitInterfaceLink(TPasClassType(ClassDecl.Interfaces[k]).PathName));
if TPasElement(ClassDecl.Interfaces[k]) is TPasAliasType then
write(contentfile,',',CheckImplicitInterfaceLink(TPasClassType(ClassLikeDecl.Interfaces[k]).PathName));
if TPasElement(ClassLikeDecl.Interfaces[k]) is TPasAliasType then
begin
alias:= TPasAliasType(ClassDecl.Interfaces[k]);
alias:= TPasAliasType(ClassLikeDecl.Interfaces[k]);
if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
write(ContentFile,'(',CheckImplicitInterfaceLink(alias.desttype.PathName),')');
end;
end;
end;
end;
writeln(contentfile);
for k := 0 to ClassDecl.Members.Count - 1 do
for k := 0 to MemberDecl.Members.Count - 1 do
begin
Member := TPasElement(ClassDecl.Members[k]);
Member := TPasElement(MemberDecl.Members[k]);
Write(ContentFile, Chr(Ord(Member.Visibility) + Ord('0')));
S:='';
if Member.ClassType = TPasVariable then