From dac17860c4246b33013e6d91e24adbf709ac512b Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Mon, 3 Apr 2017 15:20:55 +0000 Subject: [PATCH] fcl-passrc: pasresolver: when accessing a record member, access the record too git-svn-id: trunk@35719 - --- packages/fcl-passrc/src/pasresolver.pp | 240 ++++++++++++-------- packages/fcl-passrc/tests/tcresolver.pas | 4 +- packages/fcl-passrc/tests/tcuseanalyzer.pas | 38 ++++ packages/pastojs/src/fppas2js.pp | 7 +- 4 files changed, 193 insertions(+), 96 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index a6eaa7c5fd..9ef7f008a0 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -730,7 +730,7 @@ type TPasWithExprScope = Class(TPasScope) public - WithScope: TPasWithScope; + WithScope: TPasWithScope; // owner Index: integer; Expr: TPasExpr; Scope: TPasScope; @@ -1073,6 +1073,9 @@ type Access: TResolvedRefAccess): boolean; virtual; procedure ResolveSetParamsExpr(Params: TParamsExpr); virtual; procedure ResolveArrayValues(El: TArrayValues); virtual; + procedure SetResolvedRefAccess(Expr: TPasExpr; Ref: TResolvedReference; + Access: TResolvedRefAccess); virtual; + procedure AccessExpr(Expr: TPasExpr; Access: TResolvedRefAccess); procedure FinishModule(CurModule: TPasModule); virtual; procedure FinishUsesList; virtual; procedure FinishTypeSection(El: TPasDeclarations); virtual; @@ -1096,7 +1099,6 @@ type procedure FinishPropertyOfClass(PropEl: TPasProperty); virtual; procedure FinishArgument(El: TPasArgument); virtual; procedure FinishAncestors(aClass: TPasClassType); virtual; - procedure FinishParamExpressionAccess(Expr: TPasExpr; Access: TResolvedRefAccess); procedure FinishPropertyParamAccess(Params: TParamsExpr; Prop: TPasProperty); procedure ReplaceProcScopeImplArgsWithDeclArgs(ImplProcScope: TPasProcedureScope); @@ -4013,70 +4015,6 @@ begin end; end; -procedure TPasResolver.FinishParamExpressionAccess(Expr: TPasExpr; - Access: TResolvedRefAccess); -// called after a call overload was found for each element -// to set the rraParamToUnknownProc to Access -var - Ref: TResolvedReference; - Bin: TBinaryExpr; - Params: TParamsExpr; -begin - if (Expr.CustomData is TResolvedReference) then - begin - Ref:=TResolvedReference(Expr.CustomData); - if Ref.Access=rraParamToUnknownProc then - begin - Ref.Access:=Access; - exit; - end; - end; - - if Expr.ClassType=TBinaryExpr then - begin - Bin:=TBinaryExpr(Expr); - if Bin.OpCode in [eopSubIdent,eopNone] then - FinishParamExpressionAccess(Bin.right,Access); - exit; - end - else if Expr.ClassType=TParamsExpr then - begin - Params:=TParamsExpr(Expr); - case Params.Kind of - pekFuncParams: - if IsTypeCast(Params) then - FinishParamExpressionAccess(Params.Params[0],Access) - else - FinishParamExpressionAccess(Params.Value,Access); - pekArrayParams: - FinishParamExpressionAccess(Params.Value,Access); - pekSet: - if Access<>rraRead then - RaiseMsg(20170306112306,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr); - end; - end - else if ((Expr.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(Expr).Kind=pekIdent)) - or (Expr.ClassType=TSelfExpr) then - begin - Ref:=Expr.CustomData as TResolvedReference; - if Ref.Access<>Access then - RaiseInternalError(20170306101244); - end - else if (Access=rraRead) - and ((Expr.ClassType=TPrimitiveExpr) - or (Expr.ClassType=TNilExpr) - or (Expr.ClassType=TBoolConstExpr) - or (Expr.ClassType=TUnaryExpr)) then - // ok - else - begin - {$IFDEF VerbosePasResolver} - writeln('TPasResolver.FinishParamExpressionAccess Expr=',GetObjName(Expr),' Access=',Access,' Declaration="',Expr.GetDeclaration(false),'"'); - {$ENDIF} - RaiseNotYetImplemented(20170306102158,Expr); - end; -end; - procedure TPasResolver.FinishPropertyParamAccess(Params: TParamsExpr; Prop: TPasProperty); var @@ -4091,7 +4029,7 @@ begin argVar: ParamAccess:=rraVarParam; argOut: ParamAccess:=rraOutParam; end; - FinishParamExpressionAccess(Params.Params[i],ParamAccess); + AccessExpr(Params.Params[i],ParamAccess); end; end; @@ -4835,8 +4773,11 @@ begin // e.g. TPoint.PointInCircle RecordScope.OnlyTypeMembers:=true else + begin // e.g. aPoint.X + AccessExpr(El.left,Access); RecordScope.OnlyTypeMembers:=false; + end; ResolveExpr(El.right,Access); PopScope; exit; @@ -4920,7 +4861,7 @@ procedure TPasResolver.ResolveFuncParamsExpr(Params: TParamsExpr; argVar: ParamAccess:=rraVarParam; argOut: ParamAccess:=rraOutParam; end; - FinishParamExpressionAccess(Params.Params[i],ParamAccess); + AccessExpr(Params.Params[i],ParamAccess); end; end; @@ -5036,7 +4977,7 @@ begin begin // type cast for i:=0 to length(Params.Params)-1 do - FinishParamExpressionAccess(Params.Params[i],Access); + AccessExpr(Params.Params[i],Access); end else if C=TPasUnresolvedSymbolRef then begin @@ -5048,13 +4989,13 @@ begin BuiltInProc.FinishParamsExpression(BuiltInProc,Params) else for i:=0 to length(Params.Params)-1 do - FinishParamExpressionAccess(Params.Params[i],rraRead); + AccessExpr(Params.Params[i],rraRead); end else if TypeEl.CustomData is TResElDataBaseType then begin // type cast to base type for i:=0 to length(Params.Params)-1 do - FinishParamExpressionAccess(Params.Params[i],Access); + AccessExpr(Params.Params[i],Access); end else begin @@ -5188,7 +5129,7 @@ begin if not (rrfReadable in ResolvedArg.Flags) then RaiseMsg(20170216152211,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected, ['type','value'],ArgExp); - FinishParamExpressionAccess(ArgExp,rraRead); + AccessExpr(ArgExp,rraRead); exit; end else if (ResolvedValue.IdentEl is TPasProperty) @@ -5213,7 +5154,7 @@ begin RaiseMsg(20170216152215,nIllegalQualifier,sIllegalQualifier,['['],Params); CheckCallArrayCompatibility(TPasArrayType(ResolvedValue.TypeEl),Params,true); for i:=0 to length(Params.Params)-1 do - FinishParamExpressionAccess(Params.Params[i],rraRead); + AccessExpr(Params.Params[i],rraRead); exit; end; end; @@ -5225,6 +5166,7 @@ function TPasResolver.ResolveBracketOperatorClass(Params: TParamsExpr; Access: TResolvedRefAccess): boolean; var PropEl: TPasProperty; + Value: TPasExpr; begin PropEl:=ClassScope.DefaultProperty; if PropEl<>nil then @@ -5232,8 +5174,9 @@ begin // class has default property if (ResolvedValue.IdentEl is TPasType) and (not PropEl.IsClass) then RaiseMsg(20170216152213,nIllegalQualifier,sIllegalQualifier,['['],Params); - if Params.Value.CustomData is TResolvedReference then - TResolvedReference(Params.Value.CustomData).Access:=rraRead; + Value:=Params.Value; + if Value.CustomData is TResolvedReference then + SetResolvedRefAccess(Value,TResolvedReference(Value.CustomData),rraRead); CreateReference(PropEl,Params,Access); CheckCallPropertyCompatibility(PropEl,Params,true); FinishPropertyParamAccess(Params,PropEl); @@ -5260,6 +5203,119 @@ begin ResolveExpr(El.Values[i],rraRead); end; +procedure TPasResolver.SetResolvedRefAccess(Expr: TPasExpr; + Ref: TResolvedReference; Access: TResolvedRefAccess); +begin + if (Ref.Access=Access) then exit; + if Access in [rraNone,rraParamToUnknownProc] then + exit; + + case Ref.Access of + rraNone,rraParamToUnknownProc: + Ref.Access:=Access; + rraRead: + if Access in [rraAssign,rraReadAndAssign,rraVarParam,rraOutParam] then + Ref.Access:=rraReadAndAssign + else + exit; + rraAssign,rraOutParam: + if Access in [rraRead,rraReadAndAssign,rraVarParam] then + Ref.Access:=rraReadAndAssign + else + exit; + rraReadAndAssign: exit; + rraVarParam: exit; + else + RaiseInternalError(20170403163727); + end; + + if (Expr.ClassType=TSelfExpr) + or ((Expr.ClassType=TPrimitiveExpr) and (TPrimitiveExpr(Expr).Kind=pekIdent)) then + begin + if Ref.WithExprScope<>nil then + begin + if Ref.WithExprScope.Scope is TPasRecordScope then + begin + // a record member was accessed -> access the record too + AccessExpr(Ref.WithExprScope.Expr,Access); + exit; + end; + end; + if (Ref.Declaration is TPasVariable) + and (Expr.Parent is TBinaryExpr) + and (TBinaryExpr(Expr.Parent).right=Expr) then + begin + if ((Ref.Declaration.Parent is TPasRecordType) + or (Ref.Declaration.Parent is TPasVariant)) then + begin + // a record member was accessed -> access the record too + AccessExpr(TBinaryExpr(Expr.Parent).left,Access); + end; + end; + end; +end; + +procedure TPasResolver.AccessExpr(Expr: TPasExpr; + Access: TResolvedRefAccess); +// called after a call overload was found for each element +// to set the rraParamToUnknownProc to Access +var + Ref: TResolvedReference; + Bin: TBinaryExpr; + Params: TParamsExpr; + ValueResolved: TPasResolverResult; + C: TClass; +begin + if (Expr.CustomData is TResolvedReference) then + begin + Ref:=TResolvedReference(Expr.CustomData); + SetResolvedRefAccess(Expr,Ref,Access); + end; + + C:=Expr.ClassType; + if C=TBinaryExpr then + begin + Bin:=TBinaryExpr(Expr); + if Bin.OpCode in [eopSubIdent,eopNone] then + AccessExpr(Bin.right,Access); + end + else if C=TParamsExpr then + begin + Params:=TParamsExpr(Expr); + case Params.Kind of + pekFuncParams: + if IsTypeCast(Params) then + AccessExpr(Params.Params[0],Access) + else + AccessExpr(Params.Value,Access); + pekArrayParams: + begin + ComputeElement(Params.Value,ValueResolved,[]); + if not IsDynArray(ValueResolved.TypeEl) then + AccessExpr(Params.Value,Access); + end; + pekSet: + if Access<>rraRead then + RaiseMsg(20170306112306,nVariableIdentifierExpected,sVariableIdentifierExpected,[],Expr); + end; + end + else if (C=TSelfExpr) or ((C=TPrimitiveExpr) and (TPrimitiveExpr(Expr).Kind=pekIdent)) then + // ok + else if (Access=rraRead) + and ((C=TPrimitiveExpr) + or (C=TNilExpr) + or (C=TBoolConstExpr) + or (C=TUnaryExpr)) then + // ok + else + begin + {$IFDEF VerbosePasResolver} + writeln('TPasResolver.AccessExpr Expr=',GetObjName(Expr),' Access=',Access,' Declaration="',Expr.GetDeclaration(false),'"'); + {$ENDIF} + RaiseNotYetImplemented(20170306102158,Expr); + end; +end; + procedure TPasResolver.CheckPendingForwards(El: TPasElement); var i: Integer; @@ -6624,8 +6680,8 @@ var begin if Proc=nil then ; P:=Params.Params; - FinishParamExpressionAccess(P[0],rraVarParam); - FinishParamExpressionAccess(P[1],rraRead); + AccessExpr(P[0],rraVarParam); + AccessExpr(P[1],rraRead); end; function TPasResolver.BI_InExclude_OnGetCallCompatibility( @@ -6684,8 +6740,8 @@ var begin if Proc=nil then ; P:=Params.Params; - FinishParamExpressionAccess(P[0],rraVarParam); - FinishParamExpressionAccess(P[1],rraRead); + AccessExpr(P[0],rraVarParam); + AccessExpr(P[1],rraRead); end; function TPasResolver.BI_Break_OnGetCallCompatibility(Proc: TResElDataBuiltInProc; @@ -6842,9 +6898,9 @@ var begin if Proc=nil then ; P:=Params.Params; - FinishParamExpressionAccess(P[0],rraVarParam); + AccessExpr(P[0],rraVarParam); if Length(P)>1 then - FinishParamExpressionAccess(P[1],rraRead); + AccessExpr(P[1],rraRead); end; function TPasResolver.BI_Assigned_OnGetCallCompatibility( @@ -7170,8 +7226,8 @@ var begin if Proc=nil then ; P:=Params.Params; - FinishParamExpressionAccess(P[0],rraRead); - FinishParamExpressionAccess(P[1],rraVarParam); + AccessExpr(P[0],rraRead); + AccessExpr(P[1],rraVarParam); end; function TPasResolver.BI_StrFunc_OnGetCallCompatibility( @@ -7360,9 +7416,9 @@ var begin if Proc=nil then ; P:=Params.Params; - FinishParamExpressionAccess(P[0],rraRead); - FinishParamExpressionAccess(P[1],rraVarParam); - FinishParamExpressionAccess(P[2],rraRead); + AccessExpr(P[0],rraRead); + AccessExpr(P[1],rraVarParam); + AccessExpr(P[2],rraRead); end; function TPasResolver.BI_DeleteArray_OnGetCallCompatibility( @@ -7415,9 +7471,9 @@ var begin if Proc=nil then ; P:=Params.Params; - FinishParamExpressionAccess(P[0],rraVarParam); - FinishParamExpressionAccess(P[1],rraRead); - FinishParamExpressionAccess(P[2],rraRead); + AccessExpr(P[0],rraVarParam); + AccessExpr(P[1],rraRead); + AccessExpr(P[2],rraRead); end; constructor TPasResolver.Create; @@ -7569,7 +7625,8 @@ begin RaiseMsg(20170328003146,nIllegalExpression,sIllegalExpression,[],LastElement); end; {$IFDEF VerbosePasResolver} - writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ...'); + if RightPath<>'' then + writeln('TPasResolver.FindElement searching scope "',CurName,'" RightPath="',RightPath,'" ...'); {$ENDIF} if not IsValidIdent(CurName) then RaiseNotYetImplemented(20170328000033,LastElement); @@ -8143,7 +8200,6 @@ begin writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl)); {$ENDIF} Result:=TResolvedReference.Create; - Result.Access:=Access; if FindData<>nil then begin if FindData^.StartScope.ClassType=ScopeClass_WithExpr then @@ -8151,6 +8207,8 @@ begin end; AddResolveData(RefEl,Result,lkModule); Result.Declaration:=DeclEl; + if RefEl is TPasExpr then + SetResolvedRefAccess(TPasExpr(RefEl),Result,Access); end; function TPasResolver.CreateScope(El: TPasElement; ScopeClass: TPasScopeClass diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 63584fb2a8..a3647b2cdf 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -4046,8 +4046,8 @@ begin Add('begin'); Add(' DoIt({#r1_read}r.{#r_a1_read}a,'); Add(' {#r2_read}r.{#r_a2_read}a,'); - Add(' {#r3_read}r.{#r_a3_var}a,'); - Add(' {#r4_read}r.{#r_a4_out}a);'); + Add(' {#r3_readandassign}r.{#r_a3_var}a,'); + Add(' {#r4_readandassign}r.{#r_a4_out}a);'); Add(' with r do'); Add(' DoIt({#w_a1_read}a,'); Add(' {#w_a2_read}a,'); diff --git a/packages/fcl-passrc/tests/tcuseanalyzer.pas b/packages/fcl-passrc/tests/tcuseanalyzer.pas index d8069a3010..f495218fb1 100644 --- a/packages/fcl-passrc/tests/tcuseanalyzer.pas +++ b/packages/fcl-passrc/tests/tcuseanalyzer.pas @@ -90,6 +90,8 @@ type procedure TestM_Hint_LocalMethodInProgramNotUsed; procedure TestM_Hint_AssemblerParameterIgnored; procedure TestM_Hint_FunctionResultDoesNotSeemToBeSet; + procedure TestM_Hint_FunctionResultRecord; + procedure TestM_Hint_FunctionResultPassRecordElement; // whole program optimization procedure TestWP_LocalVar; @@ -1130,6 +1132,42 @@ begin sPAFunctionResultDoesNotSeemToBeSet); end; +procedure TTestUseAnalyzer.TestM_Hint_FunctionResultRecord; +begin + StartProgram(true); + Add('type'); + Add(' TPoint = record X,Y:longint; end;'); + Add('function Point(Left,Top: longint): TPoint;'); + Add('begin'); + Add(' Result.X:=Left;'); + Add('end;'); + Add('begin'); + Add(' Point(1,2);'); + AnalyzeProgram; + CheckHasHint(mtHint,nPAFunctionResultDoesNotSeemToBeSet, + sPAFunctionResultDoesNotSeemToBeSet,false); +end; + +procedure TTestUseAnalyzer.TestM_Hint_FunctionResultPassRecordElement; +begin + StartProgram(true); + Add('type'); + Add(' TPoint = record X,Y:longint; end;'); + Add('procedure Three(out x: longint);'); + Add('begin'); + Add(' x:=3;'); + Add('end;'); + Add('function Point(Left,Top: longint): TPoint;'); + Add('begin'); + Add(' Three(Result.X)'); + Add('end;'); + Add('begin'); + Add(' Point(1,2);'); + AnalyzeProgram; + CheckHasHint(mtHint,nPAFunctionResultDoesNotSeemToBeSet, + sPAFunctionResultDoesNotSeemToBeSet,false); +end; + procedure TTestUseAnalyzer.TestWP_LocalVar; begin StartProgram(false); diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 0c718e6724..13d57f9be0 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -215,7 +215,6 @@ Works: ToDos: - external class array accessor: pass by ref - remove 'Object' array workaround -- pass by ref: arr[3] -> omit this.a - FuncName:= (instead of Result:=) - ord(s[i]) -> s.charCodeAt(i) - $modeswitch -> define @@ -260,6 +259,8 @@ Not in Version 1.0: -O1 no function Result var when assigned only once - SetLength(scope.a,l) -> read scope only once, same for Include, Exclude, Inc, Dec + -O1 replace constant expression with result + -O1 pass array element by ref: when index is constant, use that directly - objects, interfaces, advanced records - class helpers, type helpers, record helpers, - generics @@ -2024,7 +2025,7 @@ begin if (not (rrfReadable in ParamResolved.Flags)) or not (ParamResolved.BaseType in btAllInteger) then CheckRaiseTypeArgNo(20170402194221,1,Param,ParamResolved,'integer',true); - FinishParamExpressionAccess(Param,rraRead); + AccessExpr(Param,rraRead); exit(true); end else if IsExternalClassName(aClass,'Object') then @@ -2040,7 +2041,7 @@ begin if (not (rrfReadable in ParamResolved.Flags)) or not (ParamResolved.BaseType in btAllStringAndChars) then CheckRaiseTypeArgNo(20170402194511,1,Param,ParamResolved,'string',true); - FinishParamExpressionAccess(Param,rraRead); + AccessExpr(Param,rraRead); exit(true); end; end;