paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-28 18:40:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: pasresolver: when accessing a record member, access the record too

Browse Source 
git-svn-id: trunk@35719 -
This commit is contained in:
Mattias Gaertner 2017-04-03 15:20:55 +00:00
parent 457d23a151
commit dac17860c4
4 changed files with 193 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

240
packages/fcl-passrc/src/pasresolver.pp
View File

@ -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

4
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -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,');

38
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

@ -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);

7
packages/pastojs/src/fppas2js.pp
View File

@ -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 <modeswitch>
@ -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;