fcl-passrc: resolver: implemented overriding property with index specifier

git-svn-id: trunk@37382 -

packages/fcl-passrc/src/pasresolveeval.pas

@@ -142,6 +142,7 @@ const
   nDivByZero = 3069;
   nRangeCheckInSetConstructor = 3070;
   nIncompatibleTypesGotParametersExpected = 3071;
+  nAddingIndexSpecifierRequiresNewX = 3072;
 
 // resourcestring patterns of messages
 resourcestring
@@ -216,6 +217,7 @@ resourcestring
   sDivByZero = 'Division by zero';
   sRangeCheckInSetConstructor = 'range check error in set constructor or duplicate set element';
   sIncompatibleTypesGotParametersExpected = 'Incompatible types, got %s parameters, expected %s';
+  sAddingIndexSpecifierRequiresNewX = 'adding index specifier requires new "%s" specifier';
 
 type
   { TResolveData - base class for data stored in TPasElement.CustomData }

packages/fcl-passrc/src/pasresolver.pp

@@ -1352,6 +1352,7 @@ type
     function GetPasPropertyAncestor(El: TPasProperty; WithRedeclarations: boolean = false): TPasProperty;
     function GetPasPropertyGetter(El: TPasProperty): TPasElement;
     function GetPasPropertySetter(El: TPasProperty): TPasElement;
+    function GetPasPropertyIndex(El: TPasProperty): TPasExpr;
     function GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
     function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
     function GetLoop(El: TPasElement): TPasImplElement;
@@ -3933,11 +3934,12 @@ procedure TPasResolver.FinishPropertyOfClass(PropEl: TPasProperty);
 var
   PropType: TPasType;
   ClassScope: TPasClassScope;
+  AncestorProp: TPasProperty;
+  IndexExpr: TPasExpr;
 
   procedure GetPropType;
   var
     AncEl: TPasElement;
-    AncProp: TPasProperty;
   begin
     if PropType<>nil then exit;
     AncEl:=nil;
@@ -3946,14 +3948,14 @@ var
     if AncEl is TPasProperty then
       begin
       // override or redeclaration property
-      AncProp:=TPasProperty(AncEl);
-      TPasPropertyScope(PropEl.CustomData).AncestorProp:=AncProp;
-      AncProp.AddRef;
+      AncestorProp:=TPasProperty(AncEl);
+      TPasPropertyScope(PropEl.CustomData).AncestorProp:=AncestorProp;
+      AncestorProp.AddRef;
       if proFixCaseOfOverrides in Options then
-        PropEl.Name:=AncProp.Name;
+        PropEl.Name:=AncestorProp.Name;
       end
     else
-      AncProp:=nil;
+      AncestorProp:=nil;
 
     if PropEl.VarType<>nil then
       begin
@@ -3963,15 +3965,15 @@ var
     else
       begin
       // property override
-      if AncProp=nil then
+      if AncestorProp=nil then
         RaiseMsg(20170216151741,nNoPropertyFoundToOverride,sNoPropertyFoundToOverride,[],PropEl);
       // check property versus class property
-      if PropEl.ClassType<>AncProp.ClassType then
-        RaiseXExpectedButYFound(20170216151744,AncProp.ElementTypeName,PropEl.ElementTypeName,PropEl);
+      if PropEl.ClassType<>AncestorProp.ClassType then
+        RaiseXExpectedButYFound(20170216151744,AncestorProp.ElementTypeName,PropEl.ElementTypeName,PropEl);
       // get inherited type
-      PropType:=GetPasPropertyType(AncProp);
+      PropType:=GetPasPropertyType(AncestorProp);
       // update DefaultProperty
-      if (ClassScope.DefaultProperty=AncProp) then
+      if (ClassScope.DefaultProperty=AncestorProp) then
         ClassScope.DefaultProperty:=PropEl;
       end;
   end;
@@ -4043,7 +4045,7 @@ var
         [IntToStr(ArgNo),'untyped',GetTypeDescription(IndexResolved)],ErrorEl)
     else
       begin
-      if CheckParamCompatibility(PropEl.IndexExpr,ProcArg,ArgNo,true)=cIncompatible then
+      if CheckParamCompatibility(IndexExpr,ProcArg,ArgNo,true)=cIncompatible then
         begin
         ComputeElement(ProcArg.ArgType,ProcArgResolved,[rcType]);
         RaiseIncompatibleTypeRes(20170924203829,nIncompatibleTypeArgNo,
@@ -4157,19 +4159,15 @@ var
         end;
       exit;
       end;
-    if (IndexVal=nil)
-        and (IdentEl<>nil)
-        and ((IdentEl.ClassType=TPasVariable)
-          or ((IdentEl.ClassType=TPasConst) and not TPasConst(IdentEl).IsConst))
-        then
+    if (IdentEl<>nil)
+      and ((IdentEl.ClassType=TPasVariable)
+        or ((IdentEl.ClassType=TPasConst) and not TPasConst(IdentEl).IsConst)) then
       begin
       // field
       aVar:=TPasVariable(IdentEl);
       // check if member
       if not (Expr is TPrimitiveExpr) then
         RaiseXExpectedButYFound(20170923202003,'member variable','foreign '+aVar.ElementTypeName,Expr);
-      if PropEl.IndexExpr<>nil then
-        RaiseNotYetImplemented(20170409214006,PropEl.StoredAccessor,'stored with index');
       // check type boolean
       TypeEl:=aVar.VarType;
       TypeEl:=ResolveAliasType(TypeEl);
@@ -4207,9 +4205,11 @@ var
   Proc: TPasProcedure;
   Arg: TPasArgument;
   PropArgCount, NeedArgCnt: Integer;
-  PropTypeResolved, DefaultResolved, IndexResolved: TPasResolverResult;
+  PropTypeResolved, DefaultResolved, IndexResolved,
+    AncIndexResolved: TPasResolverResult;
   m: TVariableModifier;
   IndexVal: TResEvalValue;
+  AncIndexExpr: TPasExpr;
 begin
   CheckTopScope(TPasPropertyScope);
   PopScope;
@@ -4223,15 +4223,23 @@ begin
   PropType:=nil;
   CurClassType:=PropEl.Parent as TPasClassType;
   ClassScope:=NoNil(CurClassType.CustomData) as TPasClassScope;
+  AncestorProp:=nil;
   GetPropType;
   IndexVal:=nil;
   try
     if PropEl.IndexExpr<>nil then
       begin
-      // index specifier -> check if simple value
-      ResolveExpr(PropEl.IndexExpr,rraRead);
-      ComputeElement(PropEl.IndexExpr,IndexResolved,[rcConstant]);
-      IndexVal:=Eval(PropEl.IndexExpr,[refConst]);
+      // index specifier
+      // -> check if simple value
+      IndexExpr:=PropEl.IndexExpr;
+      ResolveExpr(IndexExpr,rraRead);
+      end
+    else
+      IndexExpr:=GetPasPropertyIndex(PropEl);
+    if IndexExpr<>nil then
+      begin
+      ComputeElement(IndexExpr,IndexResolved,[rcConstant]);
+      IndexVal:=Eval(IndexExpr,[refConst]);
       case IndexVal.Kind of
       revkBool,
       revkInt, revkUInt,
@@ -4241,6 +4249,43 @@ begin
       else
         RaiseXExpectedButYFound(20170924202837,'ordinal',GetTypeDescription(IndexResolved),PropEl.IndexExpr);
       end;
+      if (PropEl.IndexExpr<>nil) and (PropEl.VarType=nil) then
+        begin
+        // check if index is compatible to ancestor index specifier
+        AncIndexExpr:=GetPasPropertyIndex(AncestorProp);
+        if AncIndexExpr=nil then
+          begin
+          // ancestor had no index specifier
+          if PropEl.ReadAccessor=nil then
+            begin
+            AccEl:=GetPasPropertyGetter(AncestorProp);
+            if AccEl is TPasProcedure then
+              RaiseMsg(20171002144103,nAddingIndexSpecifierRequiresNewX,
+                sAddingIndexSpecifierRequiresNewX,['read'],IndexExpr);
+            end;
+          if PropEl.WriteAccessor=nil then
+            begin
+            AccEl:=GetPasPropertySetter(AncestorProp);
+            if AccEl is TPasProcedure then
+              RaiseMsg(20171002144419,nAddingIndexSpecifierRequiresNewX,
+                sAddingIndexSpecifierRequiresNewX,['write'],IndexExpr);
+            end;
+          if PropEl.StoredAccessor=nil then
+            begin
+            AccEl:=GetPasPropertyStoredExpr(AncestorProp);
+            if AccEl<>nil then
+              begin
+              ComputeElement(AccEl,AncIndexResolved,[rcNoImplicitProc]);
+              if AncIndexResolved.IdentEl is TPasProcedure then
+                RaiseMsg(20171002144644,nAddingIndexSpecifierRequiresNewX,
+                  sAddingIndexSpecifierRequiresNewX,['stored'],IndexExpr);
+              end;
+            end;
+          end
+        else
+          // ancestor had already an index specifier -> check same type
+          CheckEqualElCompatibility(PropEl.IndexExpr,AncIndexExpr,PropEl.IndexExpr,true);
+        end;
       end;
 
     if PropEl.ReadAccessor<>nil then
@@ -4249,7 +4294,7 @@ begin
       AccEl:=GetAccessor(PropEl.ReadAccessor);
       if (AccEl.ClassType=TPasVariable) or (AccEl.ClassType=TPasConst) then
         begin
-        if (PropEl.Args.Count>0) or (IndexVal<>nil) then
+        if (PropEl.Args.Count>0) then
           RaiseXExpectedButYFound(20170216151823,'function',AccEl.ElementTypeName,PropEl.ReadAccessor);
         if not IsSameType(TPasVariable(AccEl).VarType,PropType,true) then
           RaiseIncompatibleType(20170216151826,nIncompatibleTypesGotExpected,
@@ -4293,8 +4338,6 @@ begin
           RaiseMsg(20170216151847,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
             [Proc.Name],PropEl.ReadAccessor);
         end
-      else if IndexVal<>nil then
-        RaiseXExpectedButYFound(20170216151849,'function',AccEl.ElementTypeName,PropEl.ReadAccessor)
       else
         RaiseXExpectedButYFound(20170216151850,'variable',AccEl.ElementTypeName,PropEl.ReadAccessor);
       end;
@@ -4306,7 +4349,7 @@ begin
       if (AccEl.ClassType=TPasVariable)
           or ((AccEl.ClassType=TPasConst) and (not TPasConst(AccEl).IsConst)) then
         begin
-        if (PropEl.Args.Count>0) or (IndexVal<>nil) then
+        if (PropEl.Args.Count>0) then
           RaiseXExpectedButYFound(20170216151852,'procedure',AccEl.ElementTypeName,PropEl.WriteAccessor);
         if not IsSameType(TPasVariable(AccEl).VarType,PropType,true) then
           RaiseIncompatibleType(20170216151855,nIncompatibleTypesGotExpected,
@@ -11948,6 +11991,21 @@ begin
     end;
 end;
 
+function TPasResolver.GetPasPropertyIndex(El: TPasProperty): TPasExpr;
+// search the index expression of a property
+begin
+  Result:=nil;
+  while El<>nil do
+    begin
+    if El.IndexExpr<>nil then
+      begin
+      Result:=El.IndexExpr;
+      exit;
+      end;
+    El:=GetPasPropertyAncestor(El);
+    end;
+end;
+
 function TPasResolver.GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
 // search the stored expression of a property
 begin

packages/fcl-passrc/tests/tcresolver.pas

@@ -504,7 +504,6 @@ type
     Procedure TestPropertyStoredAccessorFuncWrongResult;
     Procedure TestPropertyStoredAccessorFuncWrongArgCount;
     Procedure TestPropertyIndexSpec;
-    Procedure TestPropertyIndexSpec_ReadAccessorVarFail;
     Procedure TestPropertyIndexSpec_ReadAccessorWrongArgCount;
     Procedure TestPropertyIndexSpec_ReadAccessorWrongIndexArgType;
     Procedure TestPropertyDefaultValue;
@@ -8130,6 +8129,7 @@ begin
   'type',
   '  TEnum = (red, blue);',
   '  TObject = class',
+  '    FB: boolean;',
   '    function GetIntBool(Index: longint): boolean; virtual; abstract;',
   '    procedure SetIntBool(Index: longint; b: boolean); virtual; abstract;',
   '    function GetBoolBool(Index: boolean): boolean; virtual; abstract;',
@@ -8144,23 +8144,16 @@ begin
   '    property B4: boolean index CB read GetBoolBool write SetBoolBool stored GetBoolBool;',
   '    property B5: boolean index red read GetEnumBool write SetEnumBool stored GetEnumBool;',
   '    property B6: boolean index TEnum.blue read GetEnumBool write SetEnumBool stored GetEnumBool;',
+  '    property B7: boolean index 1 read GetIntBool write FB stored FB;',
   '    property I1[A: String]: boolean index 2 read GetStrIntBool write SetStrIntBool;',
   '  end;',
-  'begin']);
-  ParseProgram;
-end;
-
-procedure TTestResolver.TestPropertyIndexSpec_ReadAccessorVarFail;
-begin
-  StartProgram(false);
-  Add([
-  'type',
-  '  TObject = class',
-  '    FB: boolean;',
-  '    property B: boolean index 1 read FB;',
+  '  TBird = class',
+  '    function GetIntBoolOvr(Index: longint): boolean; virtual; abstract;',
+  '    property B1 index 3;',
+  '    property B2 read GetIntBoolOvr;',
   '  end;',
   'begin']);
-  CheckResolverException('function expected, but variable found',nXExpectedButYFound);
+  ParseProgram;
 end;
 
 procedure TTestResolver.TestPropertyIndexSpec_ReadAccessorWrongArgCount;