* Patch from Mattias Gaertner to correctly resolve:

  - check const expression fits type
  - built-in procedures Inc, Dec, Exit, Ord, Assigned
  - type casts boolean, integer and floats
  - check for loop variable and values
  - check case-of expressions
  - type cast classes
  - class-of
  - class vars/procs/properties
  - properties with parameters
  - default properties
  - static and dynamic arrays

git-svn-id: trunk@34709 -

packages/fcl-passrc/src/pastree.pp

@@ -170,7 +170,7 @@ type
     OpCode    : TExprOpCode;
     format1,format2 : TPasExpr;
     constructor Create(AParent : TPasElement; AKind: TPasExprKind; AOpCode: TExprOpCode); virtual; overload;
-    destructor destroy; override;
+    destructor Destroy; override;
   end;
 
   { TUnaryExpr }
@@ -474,11 +474,13 @@ type
     procedure ForEachCall(const aMethodCall: TOnForEachPasElement;
       const Arg: Pointer); override;
   public
-    IndexRange : string;
+    IndexRange : string; // only valid if Parser po_arrayrangeexpr disabled
+    Ranges: TPasExprArray; // only valid if Parser po_arrayrangeexpr enabled
     PackMode : TPackMode;
     ElType: TPasType;
     Function IsGenericArray : Boolean;
     Function IsPacked : Boolean;
+    procedure AddRange(Range: TPasExpr);
   end;
 
   { TPasFileType }
@@ -750,8 +752,10 @@ type
   { TPasProperty }
 
   TPasProperty = class(TPasVariable)
-  public
+  private
     FResolvedType : TPasType;
+    function GetIsClass: boolean;
+    procedure SetIsClass(AValue: boolean);
   public
     constructor Create(const AName: string; AParent: TPasElement); override;
     destructor Destroy; override;
@@ -769,7 +773,8 @@ type
     Args: TFPList;        // List of TPasArgument objects
     ReadAccessorName, WriteAccessorName, ImplementsName,
       StoredAccessorName: string;
-    IsClass, IsDefault, IsNodefault: Boolean;
+    IsDefault, IsNodefault: Boolean;
+    property IsClass: boolean read GetIsClass write SetIsClass;
     Function ResolvedType : TPasType;
     Function IndexValue : String;
     Function DefaultValue : string;
@@ -936,7 +941,7 @@ Type
 
   { TPasClassFunction }
 
-  TPasClassFunction = class(TPasProcedure)
+  TPasClassFunction = class(TPasFunction)
   public
     function ElementTypeName: string; override;
     function TypeName: string; override;
@@ -2062,7 +2067,11 @@ end;
 
 
 destructor TPasArrayType.Destroy;
+var
+  i: Integer;
 begin
+  for i:=0 to length(Ranges)-1 do
+    Ranges[i].Release;
   if Assigned(ElType) then
     ElType.Release;
   inherited Destroy;
@@ -2425,6 +2434,18 @@ begin
   inherited Destroy;
 end;
 
+function TPasProperty.GetIsClass: boolean;
+begin
+  Result:=vmClass in VarModifiers;
+end;
+
+procedure TPasProperty.SetIsClass(AValue: boolean);
+begin
+   if AValue then
+    Include(VarModifiers,vmClass)
+  else
+    Exclude(VarModifiers,vmClass);
+end;
 
 constructor TPasProperty.Create(const AName: string; AParent: TPasElement);
 begin
@@ -3007,6 +3028,15 @@ begin
   Result:=PackMode=pmPacked;
 end;
 
+procedure TPasArrayType.AddRange(Range: TPasExpr);
+var
+  i: Integer;
+begin
+  i:=Length(Ranges);
+  SetLength(Ranges, i+1);
+  Ranges[i]:=Range;
+end;
+
 function TPasFileType.GetDeclaration (full : boolean) : string;
 begin
   Result:='File';
@@ -3739,7 +3769,7 @@ var
 begin
   for i := 0 to UsesList.Count - 1 do
     TPasType(UsesList[i]).Release;
-  UsesList.Free;
+  FreeAndNil(UsesList);
 
   inherited Destroy;
 end;
@@ -4056,11 +4086,11 @@ begin
   OpCode:=AOpCode;
 end;
 
-destructor TPasExpr.destroy;
+destructor TPasExpr.Destroy;
 begin
-  FreeAndNil(Format1);
-  FreeAndNil(Format2);
-  inherited destroy;
+  ReleaseAndNil(TPasElement(Format1));
+  ReleaseAndNil(TPasElement(Format2));
+  inherited Destroy;
 end;
 
 { TPrimitiveExpr }

packages/fcl-passrc/src/pparser.pp

@@ -74,7 +74,7 @@ const
   nParserDefaultParameterRequiredFor = 2047;
   nParserOnlyOneVariableCanBeInitialized = 2048;
   nParserExpectedTypeButGot = 2049;
-
+  nParserPropertyArgumentsCanNotHaveDefaultValues = 2050;
 
 // resourcestring patterns of messages
 resourcestring
@@ -127,20 +127,20 @@ resourcestring
   SParserDefaultParameterRequiredFor = 'Default parameter required for "%s"';
   SParserOnlyOneVariableCanBeInitialized = 'Only one variable can be initialized';
   SParserExpectedTypeButGot = 'Expected type, but got %s';
+  SParserPropertyArgumentsCanNotHaveDefaultValues = 'Property arguments can not have default values';
 
 type
   TPasScopeType = (
     stModule,  // e.g. unit, program, library
     stUsesList,
     stTypeSection,
-    stTypeDef, // e.g. the B in 'type A=B;'
-    stConstDef, // e.g. the B in 'const A=B;'
+    stTypeDef, // e.g. a TPasType
+    stConstDef, // e.g. a TPasConst
     stProcedure, // also method, procedure, constructor, destructor, ...
     stProcedureHeader,
     stExceptOnExpr,
     stExceptOnStatement,
-    stDeclaration, // e.g. a TPasType, TPasProperty
-    //stStatement,
+    stDeclaration, // e.g. a TPasProperty
     stAncestors // the list of ancestors and interfaces of a class
     );
   TPasScopeTypes = set of TPasScopeType;
@@ -339,7 +339,7 @@ type
     function ParseSetType(Parent: TPasElement; Const NamePos: TPasSourcePos; const TypeName: String ): TPasSetType;
     function ParseSpecializeType(Parent: TPasElement; Const TypeName: String): TPasClassType;
     Function ParseClassDecl(Parent: TPasElement; Const NamePos: TPasSourcePos; Const AClassName: String; AObjKind: TPasObjKind; PackMode : TPackMode= pmNone): TPasType;
-    Function ParseProperty(Parent : TPasElement; Const AName : String; AVisibility : TPasMemberVisibility) : TPasProperty;
+    Function ParseProperty(Parent : TPasElement; Const AName : String; AVisibility : TPasMemberVisibility; IsClassField: boolean) : TPasProperty;
     function ParseRangeType(AParent: TPasElement; Const NamePos: TPasSourcePos; Const TypeName: String; Full: Boolean = True): TPasRangeType;
     procedure ParseExportDecl(Parent: TPasElement; List: TFPList);
     // Constant declarations
@@ -1346,6 +1346,7 @@ function TPasParser.ParseArrayType(Parent: TPasElement;
 Var
   S : String;
   ok: Boolean;
+  RangeExpr: TPasExpr;
 
 begin
   Result := TPasArrayType(CreateElement(TPasArrayType, TypeName, Parent, NamePos));
@@ -1359,9 +1360,20 @@ begin
         begin
           repeat
             NextToken;
-            if CurToken<>tkSquaredBraceClose then
-              S:=S+CurTokenText;
-          until CurToken = tkSquaredBraceClose;
+            if po_arrayrangeexpr in Options then
+              begin
+              RangeExpr:=DoParseExpression(Result);
+              Result.AddRange(RangeExpr);
+              end
+            else if CurToken<>tkSquaredBraceClose then
+               S:=S+CurTokenText;
+            if CurToken=tkSquaredBraceClose then
+              break
+            else if CurToken=tkComma then
+              continue
+            else if po_arrayrangeexpr in Options then
+              ParseExcTokenError(']');
+          until false;
           Result.IndexRange:=S;
           ExpectToken(tkOf);
           Result.ElType := ParseType(Result,Scanner.CurSourcePos);
@@ -1384,6 +1396,7 @@ begin
     if not ok then
       Result.Release;
   end;
+  Engine.FinishScope(stTypeDef,Result);
 end;
 
 function TPasParser.ParseFileType(Parent: TPasElement;
@@ -2490,9 +2503,9 @@ begin
               end;
             declProperty:
               begin
-              PropEl:=ParseProperty(Declarations,CurtokenString,visDefault);
+              PropEl:=ParseProperty(Declarations,CurtokenString,visDefault,false);
               Declarations.Declarations.Add(PropEl);
-              Declarations.properties.Add(PropEl);
+              Declarations.Properties.Add(PropEl);
               end;
           else
             ParseExcSyntaxError;
@@ -2982,7 +2995,10 @@ begin
     if Full then
       Mods:=GetVariableModifiers(VarMods,aLibName,aExpName)
     else
+      begin
       NextToken;
+      VarMods:=[];
+      end;
     SaveComments(D);
 
     // connect
@@ -3160,6 +3176,9 @@ begin
             ArgType:=nil;
             ParseExc(nParserOnlyOneArgumentCanHaveDefault,SParserOnlyOneArgumentCanHaveDefault);
             end;
+          if Parent is TPasProperty then
+            ParseExc(nParserPropertyArgumentsCanNotHaveDefaultValues,
+              SParserPropertyArgumentsCanNotHaveDefaultValues);
           NextToken;
           Value := DoParseExpression(Parent,Nil);
           // After this, we're on ), which must be unget.
@@ -3523,7 +3542,7 @@ end;
 
 
 function TPasParser.ParseProperty(Parent: TPasElement; const AName: String;
-  AVisibility: TPasMemberVisibility): TPasProperty;
+  AVisibility: TPasMemberVisibility; IsClassField: boolean): TPasProperty;
 
   function GetAccessorName(aParent: TPasElement; out Expr: TPasExpr): String;
   var
@@ -3576,6 +3595,8 @@ var
 
 begin
   Result:=TPasProperty(CreateElement(TPasProperty,AName,Parent,AVisibility));
+  if IsClassField then
+    Result.VarModifiers:=Result.VarModifiers+[vmClass];
   ok:=false;
   try
     NextToken;
@@ -3637,6 +3658,8 @@ begin
     else if CurtokenIsIdentifier('NODEFAULT') then
       begin
       Result.IsNodefault:=true;
+      if Result.DefaultExpr<>nil then
+        ParseExcSyntaxError;
       NextToken;
       end;
     // Here the property ends. There can still be a 'default'
@@ -4434,8 +4457,7 @@ begin
         if Not AllowMethods then
           ParseExc(nErrRecordPropertiesNotAllowed,SErrRecordPropertiesNotAllowed);
         ExpectToken(tkIdentifier);
-        Prop:=ParseProperty(ARec,CurtokenString,v);
-        Prop.isClass:=isClass;
+        Prop:=ParseProperty(ARec,CurtokenString,v,isClass);
         Arec.Members.Add(Prop);
         end;
       tkOperator,
@@ -4706,7 +4728,7 @@ begin
         begin
          SaveComments;
          NextToken;
-         if CurToken in [tkConstructor,tkDestructor,tkprocedure,tkFunction] then
+         if CurToken in [tkConstructor,tkDestructor,tkProcedure,tkFunction] then
            ProcessMethod(AType,True,CurVisibility)
          else if CurToken = tkVar then
            begin
@@ -4716,7 +4738,7 @@ begin
          else if CurToken=tkProperty then
            begin
            ExpectToken(tkIdentifier);
-           AType.Members.Add(ParseProperty(AType,CurtokenString,CurVisibility));
+           AType.Members.Add(ParseProperty(AType,CurtokenString,CurVisibility,true));
            end
          else
            ParseExc(nParserTypeSyntaxError,SParserTypeSyntaxError)
@@ -4725,7 +4747,7 @@ begin
         begin
         SaveComments;
         ExpectIdentifier;
-        AType.Members.Add(ParseProperty(AType,CurtokenString,CurVisibility));
+        AType.Members.Add(ParseProperty(AType,CurtokenString,CurVisibility,false));
         end;
     end;
     NextToken;
@@ -4809,6 +4831,7 @@ begin
     ExpectIdentifier;
     UngetToken;                // Only names are allowed as following type
     TPasClassOfType(Result).DestType := ParseType(Result,Scanner.CurSourcePos);
+    Engine.FinishScope(stTypeDef,Result);
     exit;
     end;
   if (CurTokenIsIdentifier('Helper')) then

packages/fcl-passrc/src/pscanner.pp

@@ -330,7 +330,8 @@ type
     po_resolvestandardtypes, // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations
     po_asmwhole,  // store whole text between asm..end in TPasImplAsmStatement.Tokens
     po_nooverloadedprocs,  // do not create TPasOverloadedProc for procs with same name
-    po_keepclassforward    // default: delete class fowards when there is a class declaration
+    po_keepclassforward,   // disabled: delete class fowards when there is a class declaration
+    po_arrayrangeexpr    // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges
     );
   TPOptions = set of TPOption;
 

packages/fcl-passrc/tests/testpassrc.lpi

@@ -30,7 +30,7 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <CommandLineParams Value="--suite=TTestTypeParser.TestCharRangeType"/>
+        <CommandLineParams Value="--suite=TTestExpressions.TestUnaryDoubleDeref"/>
       </local>
     </RunParams>
     <RequiredPackages Count="1">