fcl-passrc: resolver: obj:=obj.create

git-svn-id: trunk@40806 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1898,7 +1898,7 @@ type
     function GetPathStart(El: TPasExpr): TPasExpr;
     function GetNewInstanceExpr(El: TPasExpr): TPasExpr;
     function ParentNeedsExprResult(El: TPasExpr): boolean;
-    function GetReference_NewInstance_Type(Ref: TResolvedReference): TPasMembersType;
+    function GetReference_ConstructorType(Ref: TResolvedReference): TPasMembersType;
     function IsDynArray(TypeEl: TPasType; OptionalOpenArray: boolean = true): boolean;
     function IsOpenArray(TypeEl: TPasType): boolean;
     function IsDynOrOpenArray(TypeEl: TPasType): boolean;
@@ -10819,11 +10819,10 @@ begin
           // function call => return result
           ComputeElement(TPasFunctionType(Proc.ProcType).ResultEl,ResolvedEl,
             Flags+[rcNoImplicitProc],StartEl)
-        else if (Proc.ClassType=TPasConstructor)
-            and (rrfNewInstance in Ref.Flags) then
+        else if (Proc.ClassType=TPasConstructor) then
           begin
-          // new instance call -> return value of type class
-          ClassOrRec:=GetReference_NewInstance_Type(Ref);
+          // constructor -> return value of type class
+          ClassOrRec:=GetReference_ConstructorType(Ref);
           SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,Params.Value,[rrfReadable]);
           end
         else
@@ -15102,10 +15101,10 @@ begin
     // constructor: NewInstance or normal call
     //  it is a NewInstance iff the scope is a class/record, e.g. TObject.Create
     if (Proc.ClassType=TPasConstructor)
-        and OnlyTypeMembers
         and (Ref<>nil) then
       begin
-      Ref.Flags:=Ref.Flags+[rrfNewInstance]-[rrfConstInherited];
+      if OnlyTypeMembers then
+        Ref.Flags:=Ref.Flags+[rrfNewInstance]-[rrfConstInherited];
       // store the class in Ref.Context
       if Ref.Context<>nil then
         RaiseInternalError(20170131141936);
@@ -15121,7 +15120,7 @@ begin
         RaiseInternalError(20170131150855,GetObjName(StartScope));
       TypeEl:=ClassRecScope.Element as TPasType;
       TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
-      if ClassRecScope is TPasClassScope then
+      if OnlyTypeMembers and (ClassRecScope is TPasClassScope) then
         begin
         AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
         if (length(AbstractProcs)>0) then
@@ -20112,11 +20111,10 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
             ComputeElement(TPasFunction(ResolvedEl.IdentEl).FuncType.ResultEl,
               ResolvedEl,Flags+[rcType],StartEl);
             end
-          else if (ResolvedEl.IdentEl.ClassType=TPasConstructor)
-              and (rrfNewInstance in Ref.Flags) then
+          else if (ResolvedEl.IdentEl.ClassType=TPasConstructor) then
             begin
-            // new instance constructor -> return value of type class
-            ClassOrRec:=GetReference_NewInstance_Type(Ref);
+            // constructor -> return value of type class
+            ClassOrRec:=GetReference_ConstructorType(Ref);
             SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,
                                  TPrimitiveExpr(Expr),[rrfReadable]);
             end
@@ -20194,7 +20192,7 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
         and (rrfNewInstance in Ref.Flags) then
       begin
       // new instance constructor -> return value of type class
-      ClassOrRec:=GetReference_NewInstance_Type(Ref);
+      ClassOrRec:=GetReference_ConstructorType(Ref);
       SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,Expr,[rrfReadable]);
       end
     else if ParentNeedsExprResult(Expr) then
@@ -20341,6 +20339,7 @@ begin
         end;
       eopMemAddress:
         if (ResolvedEl.BaseType=btContext) and (ResolvedEl.LoTypeEl is TPasProcedureType) then
+          // @@ProcVar
           exit
         else
           RaiseMsg(20180208121549,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
@@ -20526,9 +20525,9 @@ begin
     begin
     TypeEl:=TPasProcedure(El).ProcType;
     SetResolverIdentifier(ResolvedEl,btProc,El,TypeEl,TypeEl,[rrfCanBeStatement]);
-    if TPasProcedure(El).ProcType is TPasFunctionType then
+    if (TPasProcedure(El).ProcType is TPasFunctionType)
+        or (ElClass=TPasConstructor) then
       Include(ResolvedEl.Flags,rrfReadable);
-    // Note: the readability of TPasConstructor depends on the context
     // Note: implicit calls are handled in TPrimitiveExpr
     end
   else if El.InheritsFrom(TPasProcedureType) then
@@ -20864,7 +20863,7 @@ begin
     Result:=(TPasImplRaise(P).ExceptAddr=El);
 end;
 
-function TPasResolver.GetReference_NewInstance_Type(Ref: TResolvedReference
+function TPasResolver.GetReference_ConstructorType(Ref: TResolvedReference
   ): TPasMembersType;
 begin
   Result:=(Ref.Context as TResolvedRefCtxConstructor).Typ as TPasMembersType;

packages/fcl-passrc/src/pastree.pp

@@ -203,7 +203,7 @@ type
                  eopEqual, eopNotEqual,  // Logical
                  eopLessThan,eopGreaterThan, eopLessthanEqual,eopGreaterThanEqual, // ordering
                  eopIn,eopIs,eopAs, eopSymmetricaldifference, // Specials
-                 eopAddress, eopDeref, eopMemAddress, // Pointers
+                 eopAddress, eopDeref, eopMemAddress, // Pointers  eopMemAddress=**
                  eopSubIdent); // SomeRec.A, A is subIdent of SomeRec
 
   { TPasExpr }

packages/fcl-passrc/tests/tcresolver.pas

@@ -585,7 +585,6 @@ type
     Procedure TestClass_StrictPrivateInMainBeginFail;
     Procedure TestClass_StrictProtectedInMainBeginFail;
     Procedure TestClass_Constructor_NewInstance;
-    Procedure TestClass_Constructor_InstanceCallResultFail;
     Procedure TestClass_Destructor_FreeInstance;
     Procedure TestClass_ConDestructor_CallInherited;
     Procedure TestClass_Constructor_Inherited;
@@ -8019,6 +8018,7 @@ begin
   '  TRec.{#p}Create(4); // new object',
   '  r:=TRec.{#q}Create(5); // new object',
   '  r.{#r}Create(6); // normal call',
+  '  r:=r.{#s}Create(7); // normal call',
   '']);
   ParseProgram;
   aMarker:=FirstSrcMarker;
@@ -8043,7 +8043,7 @@ begin
         break;
         end;
       case aMarker^.Identifier of
-      'a','r':// should be normal call
+      'a','r','s':// should be normal call
         if ActualNewInstance then
           RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
       else // should be newinstance
@@ -10040,7 +10040,9 @@ begin
   'begin',
   '  TObject.{#p}Create; // new object',
   '  o:=TObject.{#q}Create; // new object',
-  '  o.{#r}Create; // normal call']);
+  '  o.{#r}Create; // normal call',
+  '  o:=o.{#s}Create; // normal call',
+  '']);
   ParseProgram;
   aMarker:=FirstSrcMarker;
   while aMarker<>nil do
@@ -10066,7 +10068,7 @@ begin
       if not ActualImplicitCallWithoutParams then
         RaiseErrorAtSrcMarker('expected implicit call at "#'+aMarker^.Identifier+', but got function ref"',aMarker);
       case aMarker^.Identifier of
-      'a','r':// should be normal call
+      'a','r','s':// should be normal call
         if ActualNewInstance then
           RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
       else // should be newinstance
@@ -10080,24 +10082,6 @@ begin
     end;
 end;
 
-procedure TTestResolver.TestClass_Constructor_InstanceCallResultFail;
-begin
-  StartProgram(false);
-  Add('type');
-  Add('  TObject = class');
-  Add('    constructor Create;');
-  Add('  end;');
-  Add('constructor TObject.Create;');
-  Add('begin');
-  Add('end;');
-  Add('var');
-  Add('  o: TObject;');
-  Add('begin');
-  Add('  o:=o.Create; // normal call has no result -> fail');
-  CheckResolverException('Incompatible types: got "Procedure/Function" expected "TObject"',
-    nIncompatibleTypesGotExpected);
-end;
-
 procedure TTestResolver.TestClass_Destructor_FreeInstance;
 var
   aMarker: PSrcMarker;