fcl-passrc: resolver: function result is writable

git-svn-id: trunk@40674 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1890,6 +1890,8 @@ type
     function IsNameExpr(El: TPasExpr): boolean; inline; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
     function GetNameExprValue(El: TPasExpr): string; // TSelfExpr or TPrimitiveExpr with Kind=pekIdent
     function GetNextDottedExpr(El: TPasExpr): TPasExpr;
+    function GetLeftMostExpr(El: TPasExpr): TPasExpr;
+    function GetRightMostExpr(El: TPasExpr): TPasExpr;
     function GetUsesUnitInFilename(InFileExpr: TPasExpr): string;
     function GetPathStart(El: TPasExpr): TPasExpr;
     function GetNewInstanceExpr(El: TPasExpr): TPasExpr;
@@ -3865,6 +3867,52 @@ begin
   until false;
 end;
 
+function TPasResolver.GetLeftMostExpr(El: TPasExpr): TPasExpr;
+var
+  C: TClass;
+begin
+  Result:=El;
+  while Result<>nil do
+    begin
+    El:=Result;
+    C:=Result.ClassType;
+    if C=TBinaryExpr then
+      begin
+      if TBinaryExpr(Result).OpCode<>eopSubIdent then
+        exit;
+      Result:=TBinaryExpr(Result).left;
+      end
+    else if C=TParamsExpr then
+      begin
+      if not (TParamsExpr(Result).Kind in [pekFuncParams,pekArrayParams]) then
+        exit;
+      Result:=TParamsExpr(Result).Value;
+      end
+    else
+      exit;
+    end;
+end;
+
+function TPasResolver.GetRightMostExpr(El: TPasExpr): TPasExpr;
+var
+  C: TClass;
+begin
+  Result:=El;
+  while Result<>nil do
+    begin
+    El:=Result;
+    C:=Result.ClassType;
+    if C=TBinaryExpr then
+      begin
+      if TBinaryExpr(Result).OpCode<>eopSubIdent then
+        exit;
+      Result:=TBinaryExpr(Result).right;
+      end
+    else
+      exit;
+    end;
+end;
+
 function TPasResolver.GetUsesUnitInFilename(InFileExpr: TPasExpr): string;
 var
   Value: TResEvalValue;
@@ -7719,7 +7767,7 @@ begin
   {$ENDIF}
   // check LHS can be assigned
   ComputeElement(El.left,LeftResolved,[rcNoImplicitProc,rcSetReferenceFlags]);
-  CheckCanBeLHS(LeftResolved,true,El.left);
+  CheckCanBeLHS(LeftResolved,true,GetRightMostExpr(El.left));
 
   // compute RHS
   ResolveExpr(El.right,rraRead);
@@ -19923,8 +19971,8 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
       writeln('TPasResolver.ComputeElement.ComputeIdentifier "',GetObjName(Expr),'" ',GetResolverResultDbg(ResolvedEl),' Flags=',dbgs(Flags));
     {AllowWriteln-}
     {$ENDIF}
-    if (Expr is TPrimitiveExpr) and (Expr.Parent is TParamsExpr) and (TPrimitiveExpr(Expr).Value='FA') then
-      //RaiseNotYetImplemented(20180621235200,Expr);
+    //if (Expr is TPrimitiveExpr) and (Expr.Parent is TParamsExpr) and (TPrimitiveExpr(Expr).Value='FA') then
+    //  RaiseNotYetImplemented(20180621235200,Expr);
 
     if not (rcSetReferenceFlags in Flags)
         and (rrfNoImplicitCallWithoutParams in Ref.Flags) then
@@ -19950,7 +19998,6 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
             // function => return result
             ComputeElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,
               ResolvedEl,Flags+[rcType],StartEl);
-            Exclude(ResolvedEl.Flags,rrfWritable);
             end
           else if (ResolvedEl.IdentEl.ClassType=TPasConstructor)
               and (rrfNewInstance in Ref.Flags) then

packages/fcl-passrc/tests/tcresolver.pas

@@ -498,10 +498,11 @@ type
     // ToDo: Procedure TestAdvRecord_ClassConstructorParamsFail;
     // ToDo: Procedure TestAdvRecord_ClassDestructorParamsFail;
     Procedure TestAdvRecord_NestedRecordType;
+    Procedure TestAdvRecord_NestedArgConstFail;
     Procedure TestAdvRecord_Property;
     Procedure TestAdvRecord_ClassProperty;
     Procedure TestAdvRecord_RecordAsFuncResult;
-    // ToDo: inheritedexpr fail
+    Procedure TestAdvRecord_InheritedFail;
     // todo: for in record
 
     // class
@@ -8029,19 +8030,21 @@ begin
   '  type',
   '    TSub = record',
   '      x: word;',
+  '      class var y: word;',
   '      procedure DoSub;',
   '    end;',
   '  var',
   '    Sub: TSub;',
-  '    procedure DoIt;',
+  '    procedure DoIt(const r: TRec);',
   '  end;',
   'procedure TRec.TSub.DoSub;',
   'begin',
   '  x:=3;',
   'end;',
-  'procedure TRec.DoIt;',
+  'procedure TRec.DoIt(const r: TRec);',
   'begin',
   '  Sub.x:=4;',
+  '  r.Sub.y:=Sub.x;', // class var y is writable, even though r.Sub is not
   'end;',
   'var r: TRec;',
   'begin',
@@ -8050,6 +8053,30 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestAdvRecord_NestedArgConstFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '  type',
+  '    TSub = record',
+  '      x: word;',
+  '    end;',
+  '  var',
+  '    Sub: TSub;',
+  '    procedure DoIt(const r: TRec);',
+  '  end;',
+  'procedure TRec.DoIt(const r: TRec);',
+  'begin',
+  '  r.Sub.x:=4;',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected);
+end;
+
 procedure TTestResolver.TestAdvRecord_Property;
 begin
   StartProgram(false);
@@ -8149,12 +8176,31 @@ begin
   '  {@v}v:={@A}TRec.{@A_CreateA}Create;',
   '  {@v}v:={@A}TRec.{@A_CreateA}Create();',
   '  {@v}v:={@A}TRec.{@A_CreateB}Create(3);',
-  '  {@A}TRec.{@A_CreateA}Create.{@A_i}i:=4;',
+  '  {@A}TRec.{@A_CreateA}Create . {@A_i}i:=4;',
   '  {@A}TRec.{@A_CreateA}Create().{@A_i}i:=5;',
   '  {@A}TRec.{@A_CreateB}Create(3).{@A_i}i:=6;']);
   ParseProgram;
 end;
 
+procedure TTestResolver.TestAdvRecord_InheritedFail;
+begin
+  StartProgram(false);
+  Add([
+  '{$modeswitch advancedrecords}',
+  'type',
+  '  TRec = record',
+  '    procedure DoIt;',
+  '  end;',
+  'procedure TRec.DoIt;',
+  'begin',
+  '  inherited;',
+  'end;',
+  'begin',
+  '']);
+  CheckResolverException('The use of "inherited" is not allowed in a record',
+    nTheUseOfXisNotAllowedInARecord);
+end;
+
 procedure TTestResolver.TestClass;
 begin
   StartProgram(false);