fcl-passrc: parser: create property stored accessor elements for true and false, resolver: property stored modifier

git-svn-id: trunk@37309 -

packages/fcl-passrc/src/pasresolver.pp

@@ -884,6 +884,8 @@ type
     proClassOfIs, // class-of supports is and as operator
     proExtClassInstanceNoTypeMembers, // class members of external class cannot be accessed by instance
     proOpenAsDynArrays, // open arrays work like dynamic arrays
+    //ToDo: proStaticArrayCopy, // copy works with static arrays, returning a dynamic array
+    //ToDo: proStaticArrayConcat, // concat works with static arrays, returning a dynamic array
     proProcTypeWithoutIsNested, // proc types can use nested procs without 'is nested'
     proMethodAddrAsPointer  // can assign @method to a pointer
     );
@@ -1351,7 +1353,7 @@ type
     function GetPasPropertyAncestor(El: TPasProperty; WithRedeclarations: boolean = false): TPasProperty;
     function GetPasPropertyGetter(El: TPasProperty): TPasElement;
     function GetPasPropertySetter(El: TPasProperty): TPasElement;
-    function GetPasPropertyStored(El: TPasProperty): TPasElement;
+    function GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
     function GetPasClassAncestor(ClassEl: TPasClassType; SkipAlias: boolean): TPasType;
     function GetLoop(El: TPasElement): TPasImplElement;
     function ResolveAliasType(aType: TPasType): TPasType;
@@ -4061,8 +4063,82 @@ var
       end;
   end;
 
+  procedure CheckStoredAccessor(Expr: TPasExpr);
+  var
+    ResolvedEl: TPasResolverResult;
+    Value: TResEvalValue;
+    Proc: TPasProcedure;
+    ResultType, TypeEl: TPasType;
+    aVar: TPasVariable;
+    IdentEl: TPasElement;
+  begin
+    ResolveExpr(Expr,rraRead);
+    ComputeElement(Expr,ResolvedEl,[rcNoImplicitProc]);
+    IdentEl:=ResolvedEl.IdentEl;
+    if IdentEl is TPasProcedure then
+      begin
+      // function
+      Proc:=TPasProcedure(IdentEl);
+      // check if member
+      if not (Expr is TPrimitiveExpr) then
+        RaiseXExpectedButYFound(20170923202002,'member function','foreign '+Proc.ElementTypeName,Expr);
+      if Proc.ClassType<>TPasFunction then
+        RaiseXExpectedButYFound(20170216151925,'function',Proc.ElementTypeName,Expr);
+      // check function result type
+      ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
+      if not IsBaseType(ResultType,btBoolean,true) then
+        RaiseXExpectedButYFound(20170923200836,'function: boolean',
+          'function:'+GetTypeDescription(ResultType),PropEl.StoredAccessor);
+      // check arg count
+      if Proc.ProcType.Args.Count<>0 then
+        RaiseMsg(20170923200840,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
+          [Proc.Name],Expr);
+      exit;
+      end;
+    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);
+      if not IsBaseType(TypeEl,btBoolean,true) then
+        RaiseIncompatibleType(20170409214300,nIncompatibleTypesGotExpected,
+          [],TypeEl,BaseTypes[btBoolean],Expr);
+      // check class var
+      if (vmClass in PropEl.VarModifiers)<>(vmClass in aVar.VarModifiers) then
+        if vmClass in PropEl.VarModifiers then
+          RaiseXExpectedButYFound(20170409214351,'class var','var',Expr)
+        else
+          RaiseXExpectedButYFound(20170409214359,'var','class var',Expr);
+      exit;
+      end;
+    if (ResolvedEl.BaseType=btBoolean) and (ResolvedEl.ExprEl<>nil) then
+      begin
+      // try evaluating const boolean
+      Value:=Eval(Expr,[refConst]);
+      if Value<>nil then
+        try
+          if Value.Kind<>revkBool then
+            RaiseXExpectedButYFound(20170923200256,'boolean',GetResolverResultDescription(ResolvedEl),Expr);
+          exit;
+        finally
+          ReleaseEvalValue(Value);
+        end;
+      end;
+    RaiseXExpectedButYFound(20170923194234,'identifier',GetResolverResultDescription(ResolvedEl),Expr);
+  end;
+
 var
-  ResultType, TypeEl: TPasType;
+  ResultType: TPasType;
   CurClassType: TPasClassType;
   AccEl: TPasElement;
   Proc: TPasProcedure;
@@ -4204,41 +4280,7 @@ begin
   if PropEl.StoredAccessor<>nil then
     begin
     // check compatibility
-    AccEl:=GetAccessor(PropEl.StoredAccessor);
-    if (AccEl.ClassType=TPasVariable) or (AccEl.ClassType=TPasConst) then
-      begin
-      if PropEl.IndexExpr<>nil then
-        RaiseNotYetImplemented(20170409214006,PropEl.StoredAccessor,'stored with index');
-      TypeEl:=TPasVariable(AccEl).VarType;
-      // ToDo: TypeEl=nil  TPasConst false/true
-      TypeEl:=ResolveAliasType(TypeEl);
-      if not IsBaseType(TypeEl,btBoolean,true) then
-        RaiseIncompatibleType(20170409214300,nIncompatibleTypesGotExpected,
-          [],TypeEl,BaseTypes[btBoolean],PropEl.StoredAccessor);
-      if (vmClass in PropEl.VarModifiers)<>(vmClass in TPasVariable(AccEl).VarModifiers) then
-        if vmClass in PropEl.VarModifiers then
-          RaiseXExpectedButYFound(20170409214351,'class var','var',PropEl.StoredAccessor)
-        else
-          RaiseXExpectedButYFound(20170409214359,'var','class var',PropEl.StoredAccessor);
-      end
-    else if AccEl is TPasProcedure then
-      begin
-      // check function
-      Proc:=TPasProcedure(AccEl);
-      if Proc.ClassType<>TPasFunction then
-        RaiseXExpectedButYFound(20170216151925,'function',Proc.ElementTypeName,PropEl.StoredAccessor);
-      // check function result type
-      ResultType:=TPasFunction(Proc).FuncType.ResultEl.ResultType;
-      if not IsBaseType(ResultType,btBoolean,true) then
-        RaiseXExpectedButYFound(20170216151929,'function: boolean',
-          'function:'+GetTypeDescription(ResultType),PropEl.StoredAccessor);
-      // check arg count
-      if Proc.ProcType.Args.Count<>0 then
-        RaiseMsg(20170216151932,nWrongNumberOfParametersForCallTo,sWrongNumberOfParametersForCallTo,
-          [Proc.Name],PropEl.StoredAccessor);
-      end
-    else
-      RaiseXExpectedButYFound(20170216151935,'function: boolean',AccEl.ElementTypeName,PropEl.StoredAccessor);
+    CheckStoredAccessor(PropEl.StoredAccessor);
     end;
   if PropEl.DefaultExpr<>nil then
     begin
@@ -8860,9 +8902,11 @@ begin
   Param:=Params.Params[0];
   ComputeElement(Param,ParamResolved,[]);
   if (rrfReadable in ParamResolved.Flags)
-      and (ParamResolved.BaseType=btContext)
-      and IsDynArray(ParamResolved.TypeEl) then
-    Result:=cExact;
+      and (ParamResolved.BaseType=btContext) then
+    begin
+    if IsDynArray(ParamResolved.TypeEl) then
+      Result:=cExact;
+    end;
   if Result=cIncompatible then
     exit(CheckRaiseTypeArgNo(20170329153951,1,Param,ParamResolved,'dynamic array',RaiseOnError));
   if length(Params.Params)=1 then
@@ -11755,18 +11799,15 @@ begin
     end;
 end;
 
-function TPasResolver.GetPasPropertyStored(El: TPasProperty): TPasElement;
-// search the member variable or setter procedure of a property
-var
-  DeclEl: TPasElement;
+function TPasResolver.GetPasPropertyStoredExpr(El: TPasProperty): TPasExpr;
+// search the stored expression of a property
 begin
   Result:=nil;
   while El<>nil do
     begin
     if El.StoredAccessor<>nil then
       begin
-      DeclEl:=(El.StoredAccessor.CustomData as TResolvedReference).Declaration;
-      Result:=DeclEl;
+      Result:=El.StoredAccessor;
       exit;
       end;
     El:=GetPasPropertyAncestor(El);

packages/fcl-passrc/src/pastree.pp

@@ -852,7 +852,7 @@ type
 
   TPasConst = class(TPasVariable)
   public
-    IsConst: boolean; // e.g. $WritableConst off
+    IsConst: boolean; // true iff untyped const or typed with $WritableConst off
     function ElementTypeName: string; override;
   end;
 

packages/fcl-passrc/src/pparser.pp

@@ -3393,7 +3393,10 @@ begin
         Ungettoken; // Range type stops on token after last range token}
       end
     else
+      begin
       UngetToken;
+      Result.IsConst:=true;
+      end;
     ExpectToken(tkEqual);
     NextToken;
     Result.Expr:=DoParseConstValueExpression(Result);
@@ -4621,9 +4624,15 @@ begin
       begin
       NextToken;
       if CurToken = tkTrue then
-        Result.StoredAccessorName := 'True'
+        begin
+        Result.StoredAccessorName := 'True';
+        Result.StoredAccessor := CreateBoolConstExpr(Result,pekBoolConst,true);
+        end
       else if CurToken = tkFalse then
-        Result.StoredAccessorName := 'False'
+        begin
+        Result.StoredAccessorName := 'False';
+        Result.StoredAccessor := CreateBoolConstExpr(Result,pekBoolConst,false);
+        end
       else if CurToken = tkIdentifier then
         begin
         UngetToken;

packages/fcl-passrc/tests/tcresolver.pas

@@ -182,6 +182,7 @@ type
     Procedure TestTypedConstWrongExprFail;
     Procedure TestVarWrongExprFail;
     Procedure TestArgWrongExprFail;
+    Procedure TestTypedConstInConstExprFail;
     Procedure TestVarExternal;
     Procedure TestVarNoSemicolonBeginFail;
     Procedure TestConstIntOperators;
@@ -502,6 +503,7 @@ type
     Procedure TestPropertyStoredAccessorProcNotFunc;
     Procedure TestPropertyStoredAccessorFuncWrongResult;
     Procedure TestPropertyStoredAccessorFuncWrongArgCount;
+    Procedure TestPropertyDefaultValue;
     Procedure TestPropertyAssign;
     Procedure TestPropertyAssignReadOnlyFail;
     Procedure TestProperty_PassAsParam;
@@ -542,13 +544,17 @@ type
     Procedure TestArray_DynArrayConst;
     Procedure TestArray_AssignNilToStaticArrayFail1;
     Procedure TestArray_SetLengthProperty;
+    Procedure TestStaticArray_SetlengthFail;
     Procedure TestArray_PassArrayElementToVarParam;
     Procedure TestArray_OpenArrayOfString;
     Procedure TestArray_OpenArrayOfString_IntFail;
     Procedure TestArray_OpenArrayOverride;
     Procedure TestArray_CopyConcat;
+    Procedure TestStaticArray_CopyConcat;// ToDo
     Procedure TestArray_CopyMismatchFail;
     Procedure TestArray_InsertDelete;
+    Procedure TestStaticArray_InsertFail;
+    Procedure TestStaticArray_DeleteFail;
     Procedure TestArray_InsertItemMismatchFail;
     Procedure TestArray_TypeCast;
     Procedure TestArray_TypeCastWrongElTypeFail;
@@ -2127,6 +2133,16 @@ begin
     nIncompatibleTypesGotExpected);
 end;
 
+procedure TTestResolver.TestTypedConstInConstExprFail;
+begin
+  StartProgram(false);
+  Add('const');
+  Add('  a: longint = 3;');
+  Add('  b: longint = a;');
+  Add('begin');
+  CheckResolverException('Constant expression expected',nConstantExpressionExpected);
+end;
+
 procedure TTestResolver.TestVarExternal;
 begin
   StartProgram(false);
@@ -7967,6 +7983,7 @@ end;
 procedure TTestResolver.TestPropertyStoredAccessor;
 begin
   StartProgram(false);
+  Add('const StoreB = true;');
   Add('type');
   Add('  TObject = class');
   Add('    FBird: longint;');
@@ -7974,6 +7991,8 @@ begin
   Add('    function IsBirdStored: boolean; virtual; abstract;');
   Add('    property Bird: longint read FBird stored VStored;');
   Add('    property B: longint read FBird stored IsBirdStored;');
+  Add('    property Eagle: longint read FBird stored StoreB;');
+  Add('    property Hawk: longint read FBird stored false;');
   Add('  end;');
   Add('begin');
   ParseProgram;
@@ -8034,6 +8053,31 @@ begin
     nWrongNumberOfParametersForCallTo);
 end;
 
+procedure TTestResolver.TestPropertyDefaultValue;
+begin
+  StartProgram(false);
+  Add([
+  'const',
+  '  CB = true or false;',
+  '  CI = 1+2;',
+  'type',
+  '  TEnum = (red, blue);',
+  '  TObject = class',
+  '    FB: boolean;',
+  '    property B1: boolean read FB default true;',
+  '    property B2: boolean read FB default CB;',
+  '    property B3: boolean read FB default afile.cb;',
+  '    FI: longint;',
+  '    property I1: longint read FI default 2;',
+  '    property I2: longint read FI default CI;',
+  '    FE: TEnum;',
+  '    property E1: TEnum read FE default red;',
+  '    property E2: TEnum read FE default TEnum.blue;',
+  '  end;',
+  'begin']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestPropertyArgs1;
 begin
   StartProgram(false);
@@ -8755,6 +8799,17 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestStaticArray_SetlengthFail;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  TArrInt = array[1..3] of longint;');
+  Add('var a: TArrInt;');
+  Add('begin');
+  Add('  SetLength(a,2);');
+  CheckResolverException(sIncompatibleTypeArgNo,nIncompatibleTypeArgNo);
+end;
+
 procedure TTestResolver.TestArray_PassArrayElementToVarParam;
 begin
   StartProgram(false);
@@ -8838,6 +8893,29 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestStaticArray_CopyConcat;
+begin
+  exit;
+  //ResolverEngine.Options:=ResolverEngine.Options+[proStaticArrayCopy,proStaticArrayConcat];
+  StartProgram(false);
+  Add('type');
+  Add('  integer = longint;');
+  Add('  TArrayInt = array of integer;');
+  Add('  TThreeInts = array[1..3] of integer;');
+  Add('function Get(A: TThreeInts): TThreeInts; begin end;');
+  Add('var');
+  Add('  i: integer;');
+  Add('  A: TArrayInt;');
+  Add('  S: TThreeInts;');
+  Add('begin');
+  Add('  A:=Copy(S);');
+  Add('  A:=Copy(S,1);');
+  Add('  A:=Copy(S,2,3);');
+  Add('  A:=Copy(Get(S),2,3);');
+  Add('  A:=Concat(S,Get(S));');
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestArray_CopyMismatchFail;
 begin
   StartProgram(false);
@@ -8871,6 +8949,34 @@ begin
   CheckAccessMarkers;
 end;
 
+procedure TTestResolver.TestStaticArray_InsertFail;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  integer = longint;');
+  Add('  TArrayInt = array[1..3] of integer;');
+  Add('var');
+  Add('  i: integer;');
+  Add('  A: TArrayInt;');
+  Add('begin');
+  Add('  Insert(1,A,i);');
+  CheckResolverException(sIncompatibleTypeArgNo,nIncompatibleTypeArgNo);
+end;
+
+procedure TTestResolver.TestStaticArray_DeleteFail;
+begin
+  StartProgram(false);
+  Add('type');
+  Add('  integer = longint;');
+  Add('  TArrayInt = array[1..3] of integer;');
+  Add('var');
+  Add('  i: integer;');
+  Add('  A: TArrayInt;');
+  Add('begin');
+  Add('  Delete(A,i,1);');
+  CheckResolverException(sIncompatibleTypeArgNo,nIncompatibleTypeArgNo);
+end;
+
 procedure TTestResolver.TestArray_InsertItemMismatchFail;
 begin
   StartProgram(false);