From eb547259f5bfe2f004f4779a6be8b7b20a62e32d Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Tue, 29 Dec 2020 00:26:00 +0000 Subject: [PATCH] fcl-passrc: fixed parsing a(b).c() git-svn-id: trunk@47879 - (cherry picked from commit 1f4868caa8dc3fd6271e2b525cadc05e29958a07) --- packages/fcl-passrc/src/pasresolver.pp | 12 +++- packages/fcl-passrc/src/pastree.pp | 72 +++++++++++++++++++ packages/fcl-passrc/src/pparser.pp | 7 +- .../fcl-passrc/tests/tcresolvegenerics.pas | 29 +++++++- 4 files changed, 117 insertions(+), 3 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index fef050ce41..09b3cefd90 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -4734,7 +4734,7 @@ end; procedure TPasResolver.GetParamsOfNameExpr(El: TPasExpr; out ParentParams: TPRParentParams); -// Checks is El is the name expression of a call or array access +// Checks if El is the name expression of a call or array access // For example: a.b.El() a.El[] // Note: TPasParser guarantees that there is at most one TBinaryExpr // and one TInlineSpecializeExpr between El and TParamsExpr @@ -10207,9 +10207,19 @@ begin begin TemplTypes:=GetProcTemplateTypes(Proc); if (TemplTypes<>nil) then + begin // implicit function specialization without bracket + {$IFDEF VerbosePasResolver} + DeclEl:=El; + while DeclEl.Parent is TPasExpr do + DeclEl:=DeclEl.Parent; + {AllowWriteln} + writeln('TPasResolver.ResolveNameExpr ',WritePasElTree(TPasExpr(DeclEl),' ')); + {AllowWriteln-} + {$ENDIF} RaiseMsg(20191007222004,nCouldNotInferTypeArgXForMethodY, sCouldNotInferTypeArgXForMethodY,[TPasGenericTemplateType(TemplTypes[0]).Name,Proc.Name],El); + end; end; if El.Parent.ClassType=TPasProperty then diff --git a/packages/fcl-passrc/src/pastree.pp b/packages/fcl-passrc/src/pastree.pp index 940474c775..5d3f0ae602 100644 --- a/packages/fcl-passrc/src/pastree.pp +++ b/packages/fcl-passrc/src/pastree.pp @@ -1789,6 +1789,7 @@ function GenericTemplateTypesAsString(List: TFPList): string; procedure ReleaseProcNameParts(var NameParts: TProcedureNameParts); function dbgs(const s: TProcTypeModifiers): string; overload; +function WritePasElTree(Expr: TPasExpr; FollowPrefix: string = ''): string; {$IFDEF HasPTDumpStack} procedure PTDumpStack; @@ -1903,6 +1904,77 @@ begin Result:='['+Result+']'; end; +function WritePasElTree(Expr: TPasExpr; FollowPrefix: string): string; +{ TBinary Kind= OpCode= + +Left=TBinary Kind= OpCode= + | +Left=TParamsExpr[] + | | +Value=Prim Kind= Value= + | | +Params[1]=Prim Kind= Value= + +Right=Prim +} +var + C: TClass; + s: string; + ParamsExpr: TParamsExpr; + InlineSpecExpr: TInlineSpecializeExpr; + SubEl: TPasElement; + ArrayValues: TArrayValues; + i: Integer; +begin + if Expr=nil then exit('nil'); + C:=Expr.ClassType; + + Result:=C.ClassName; + str(Expr.Kind,s); + Result:=Result+' '+s; + str(Expr.OpCode,s); + Result:=Result+' '+s; + + if C=TPrimitiveExpr then + Result:=Result+' Value="'+TPrimitiveExpr(Expr).Value+'"' + else if C=TUnaryExpr then + Result:=Result+' Operand='+WritePasElTree(TUnaryExpr(Expr).Operand,FollowPrefix) + else if C=TBoolConstExpr then + Result:=Result+' Value='+BoolToStr(TBoolConstExpr(Expr).Value,'True','False') + else if C=TArrayValues then + begin + ArrayValues:=TArrayValues(Expr); + for i:=0 to length(ArrayValues.Values)-1 do + Result:=Result+sLineBreak+FollowPrefix+'+Values['+IntToStr(i)+']='+WritePasElTree(ArrayValues.Values[i],FollowPrefix+'| '); + end + else if C=TBinaryExpr then + begin + Result:=Result+sLineBreak+FollowPrefix+'+Left='+WritePasElTree(TBinaryExpr(Expr).left,FollowPrefix+'| '); + Result:=Result+sLineBreak+FollowPrefix+'+Right='+WritePasElTree(TBinaryExpr(Expr).right,FollowPrefix+'| '); + end + else if C=TParamsExpr then + begin + ParamsExpr:=TParamsExpr(Expr); + Result:=Result+sLineBreak+FollowPrefix+'+Value='+WritePasElTree(ParamsExpr.Value,FollowPrefix+'| '); + for i:=0 to length(ParamsExpr.Params)-1 do + Result:=Result+sLineBreak+FollowPrefix+'+Params['+IntToStr(i)+']='+WritePasElTree(ParamsExpr.Params[i],FollowPrefix+'| '); + end + else if C=TInlineSpecializeExpr then + begin + InlineSpecExpr:=TInlineSpecializeExpr(Expr); + Result:=Result+sLineBreak+FollowPrefix+'+Name='+WritePasElTree(InlineSpecExpr.NameExpr,FollowPrefix+'| '); + if InlineSpecExpr.Params<>nil then + for i:=0 to InlineSpecExpr.Params.Count-1 do + begin + Result:=Result+sLineBreak+FollowPrefix+'+Params['+IntToStr(i)+']='; + SubEl:=TPasElement(InlineSpecExpr.Params[i]); + if SubEl=nil then + Result:=Result+'nil' + else if SubEl is TPasExpr then + Result:=Result+WritePasElTree(TPasExpr(SubEl),FollowPrefix+'| ') + else + Result:=Result+SubEl.Name+':'+SubEl.ClassName; + end; + end + else + Result:=C.ClassName+' Kind='; +end; + Function IndentStrings(S : TStrings; indent : Integer) : string; Var I,CurrLen,CurrPos : Integer; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 1d2e470ce0..26fa383b9b 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -2527,11 +2527,16 @@ begin NextToken; if CurToken=tkspecialize then begin + // Obj.specialize ... if CanSpecialize=aMust then CheckToken(tkLessThan); CanSpecialize:=aMust; NextToken; - end; + end + else if msDelphi in CurrentModeswitches then + CanSpecialize:=aCan + else + CanSpecialize:=aCannot; if CurToken in [tkIdentifier,tktrue,tkfalse,tkself] then // true and false are sub identifiers as well begin aName:=aName+'.'+CurTokenString; diff --git a/packages/fcl-passrc/tests/tcresolvegenerics.pas b/packages/fcl-passrc/tests/tcresolvegenerics.pas index 8a9b967c82..83f59c6c7c 100644 --- a/packages/fcl-passrc/tests/tcresolvegenerics.pas +++ b/packages/fcl-passrc/tests/tcresolvegenerics.pas @@ -156,7 +156,7 @@ type procedure TestGenProc_TypeParamCntOverload; procedure TestGenProc_TypeParamCntOverloadNoParams; procedure TestGenProc_TypeParamWithDefaultParamDelphiFail; - procedure TestGenProc_ParamSpecWithT; // ToDo: Func(Bird: TBird) + procedure TestGenProc_ParamSpecWithT; // ToDo: NestedResultAssign // generic function infer types @@ -186,6 +186,7 @@ type procedure TestGenMethod_OverloadTypeParamCntDelphi; procedure TestGenMethod_OverloadArgs; procedure TestGenMethod_TypeCastParam; + procedure TestGenMethod_TypeCastIdentDot; end; implementation @@ -3010,6 +3011,32 @@ begin ParseUnit; end; +procedure TTestResolveGenerics.TestGenMethod_TypeCastIdentDot; +begin + StartUnit(false); + Add([ + '{$mode delphi}', + 'interface', + 'type', + ' TObject = class end;', + ' TBird = class end;', + ' TEagle = class(TBird)', + ' procedure Run(p: S);', + ' procedure Fly;', + ' end;', + 'implementation', + 'procedure TEagle.Run(p: S);', + 'begin', + 'end;', + 'procedure TEagle.Fly;', + 'var Bird: TBird;', + 'begin', + ' TEagle(Bird).Run(3);', + 'end;', + '']); + ParseUnit; +end; + initialization RegisterTests([TTestResolveGenerics]);