fcl-passrc: resolver: fixed class-of-aliastype

git-svn-id: trunk@37394 -

packages/fcl-passrc/src/pasresolver.pp

@@ -3230,73 +3230,79 @@ begin
 end;
 
 procedure TPasResolver.FinishTypeSection(El: TPasDeclarations);
+
+  function ReplaceDestType(AliasType: TPasAliasType; const DestName: string;
+    MustExist: boolean; ErrorEl: TPasElement): boolean;
+  // returns true if replaces
+  var
+    Abort: boolean;
+    Data: TPRFindData;
+    OldDestType: TPasType;
+  begin
+    Abort:=false;
+    Data:=Default(TPRFindData);
+    Data.ErrorPosEl:=ErrorEl;
+    (TopScope as TPasIdentifierScope).IterateElements(DestName,
+      TopScope,@OnFindFirstElement,@Data,Abort);
+    if (Data.Found=nil) then
+      if MustExist then
+        RaiseIdentifierNotFound(20170216151543,DestName,ErrorEl)
+      else
+        exit(false);
+    if Data.Found.ClassType<>TPasClassType then
+      RaiseXExpectedButYFound(20170216151548,'class',Data.Found.ElementTypeName,ErrorEl);
+    // replace unresolved
+    OldDestType:=AliasType.DestType;
+    AliasType.DestType:=TPasType(Data.Found);
+    AliasType.DestType.AddRef;
+    OldDestType.Release;
+    Result:=true;
+  end;
+
 var
   i: Integer;
   Decl: TPasElement;
   ClassOfEl: TPasClassOfType;
-  Data: TPRFindData;
   UnresolvedEl: TUnresolvedPendingRef;
-  Abort: boolean;
   OldClassType: TPasClassType;
-  ClassOfName: String;
+  TypeEl: TPasType;
+  C: TClass;
 begin
   // resolve pending forwards
   for i:=0 to El.Declarations.Count-1 do
     begin
     Decl:=TPasElement(El.Declarations[i]);
-    if Decl is TPasClassType then
+    C:=Decl.ClassType;
+    if C.InheritsFrom(TPasClassType) then
       begin
       if TPasClassType(Decl).IsForward and (TPasClassType(Decl).CustomData=nil) then
         RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[Decl.Name],Decl);
       end
-    else if (Decl.ClassType=TPasClassOfType) then
+    else if (C=TPasClassOfType) then
       begin
       ClassOfEl:=TPasClassOfType(Decl);
-      Data:=Default(TPRFindData);
-      if (ClassOfEl.DestType.ClassType=TUnresolvedPendingRef) then
+      TypeEl:=ClassOfEl.DestType;
+      if (TypeEl.ClassType=TUnresolvedPendingRef) then
         begin
         // forward class-of -> resolve now
-        UnresolvedEl:=TUnresolvedPendingRef(ClassOfEl.DestType);
-        ClassOfName:=UnresolvedEl.Name;
+        UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
         {$IFDEF VerbosePasResolver}
-        writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',ClassOfName,'"');
+        writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',TypeEl.Name,'"');
         {$ENDIF}
-        Data.ErrorPosEl:=UnresolvedEl;
-        Abort:=false;
-        (TopScope as TPasIdentifierScope).IterateElements(ClassOfName,
-          TopScope,@OnFindFirstElement,@Data,Abort);
-        if (Data.Found=nil) then
-          RaiseIdentifierNotFound(20170216151543,UnresolvedEl.Name,UnresolvedEl);
-        if Data.Found.ClassType<>TPasClassType then
-          RaiseXExpectedButYFound(20170216151548,'class',Data.Found.ElementTypeName,UnresolvedEl);
-        // replace unresolved
-        ClassOfEl.DestType:=TPasClassType(Data.Found);
-        ClassOfEl.DestType.AddRef;
-        UnresolvedEl.Release;
+        ReplaceDestType(ClassOfEl,TypeEl.Name,true,UnresolvedEl);
         end
-      else
+      else if TypeEl.ClassType=TPasClassType then
         begin
         // class-of has found a type
         // another later in the same type section has priority -> check
-        OldClassType:=ClassOfEl.DestType as TPasClassType;
-        if ClassOfEl.DestType.Parent=ClassOfEl.Parent then
+        OldClassType:=TypeEl as TPasClassType;
+        if OldClassType.Parent=ClassOfEl.Parent then
           continue; // class in same type section -> ok
         // class not in same type section -> check
-        ClassOfName:=OldClassType.Name;
         {$IFDEF VerbosePasResolver}
-        writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of resolved "',ClassOfName,'"');
+        writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"');
         {$ENDIF}
-        Data.ErrorPosEl:=ClassOfEl;
-        Abort:=false;
-        (TopScope as TPasIdentifierScope).IterateElements(ClassOfName,
-          TopScope,@OnFindFirstElement,@Data,Abort);
-        if (Data.Found=nil) then
-          continue;
-        if Data.Found.ClassType<>TPasClassType then
-          RaiseXExpectedButYFound(20170221171040,'class',Data.Found.ElementTypeName,ClassOfEl);
-        ClassOfEl.DestType:=TPasClassType(Data.Found);
-        ClassOfEl.DestType.AddRef;
-        OldClassType.Release;
+        ReplaceDestType(ClassOfEl,TypeEl.Name,false,ClassOfEl);
         end;
       end;
     end;
@@ -3442,9 +3448,12 @@ begin
 end;
 
 procedure TPasResolver.FinishClassOfType(El: TPasClassOfType);
+var
+  TypeEl: TPasType;
 begin
-  if El.DestType is TUnresolvedPendingRef then exit;
-  if El.DestType is TPasClassType then exit;
+  TypeEl:=ResolveAliasType(El.DestType);
+  if TypeEl is TUnresolvedPendingRef then exit;
+  if TypeEl is TPasClassType then exit;
   RaiseMsg(20170216151602,nIncompatibleTypesGotExpected,sIncompatibleTypesGotExpected,
     [El.DestType.Name,'class'],El);
 end;
@@ -6766,7 +6775,7 @@ begin
         if (LeftResolved.IdentEl=nil) or (LeftResolved.IdentEl is TPasType) then
           RaiseMsg(20170322101128,nIllegalQualifier,sIllegalQualifier,['is'],Bin);
         // left side is class-of variable
-        LeftTypeEl:=TPasClassOfType(LeftResolved.TypeEl).DestType;
+        LeftTypeEl:=ResolveAliasType(TPasClassOfType(LeftResolved.TypeEl).DestType);
         if RightResolved.IdentEl is TPasClassType then
           begin
           // e.g. if ImageClass is TFPMemoryImage then ;
@@ -6781,7 +6790,7 @@ begin
           begin
           // e.g. if ImageClassA is ImageClassB then ;
           // or   if ImageClassA is TFPImageClass then ;
-          RightTypeEl:=TPasClassOfType(RightResolved.TypeEl).DestType;
+          RightTypeEl:=ResolveAliasType(TPasClassOfType(RightResolved.TypeEl).DestType);
           if (CheckClassesAreRelated(LeftTypeEl,RightTypeEl,Bin)<>cIncompatible) then
             begin
             SetBaseType(btBoolean);
@@ -7002,7 +7011,7 @@ begin
       end
     else if TypeEl.ClassType=TPasClassOfType then
       begin
-      ClassScope:=TPasClassOfType(TypeEl).DestType.CustomData as TPasClassScope;
+      ClassScope:=ResolveAliasType(TPasClassOfType(TypeEl).DestType).CustomData as TPasClassScope;
       if ClassScope.DefaultProperty<>nil then
         ComputeIndexProperty(ClassScope.DefaultProperty)
       else
@@ -12650,7 +12659,8 @@ begin
     else if TypeB.IdentEl is TPasClassType then
       begin
       // for example: if ImageClass=TFPMemoryImage then
-      Result:=CheckClassIsClass(TPasClassType(TypeB.IdentEl),TPasClassOfType(ElA).DestType,ErrorEl);
+      Result:=CheckClassIsClass(TPasClassType(TypeB.IdentEl),
+                                TPasClassOfType(ElA).DestType,ErrorEl);
       if (Result=cIncompatible) and RaiseOnIncompatible then
         RaiseMsg(20170216152520,nTypesAreNotRelated,sTypesAreNotRelated,[],ErrorEl);
       exit;

packages/fcl-passrc/src/pparser.pp

@@ -3004,9 +3004,9 @@ begin
           SetBlock(declResourcestring)
         else
           begin
-          { $IFDEF VerbosePasParser}
+          {$IFDEF VerbosePasParser}
           writeln('TPasParser.ParseDeclarations ',Declarations.Parent.ClassName);
-          { $ENDIF}
+          {$ENDIF}
           ParseExc(nParserResourcestringsMustBeGlobal,SParserResourcestringsMustBeGlobal);
           end;
       tkType:

packages/fcl-passrc/tests/tcresolver.pas

@@ -462,6 +462,7 @@ type
 
     // class of
     Procedure TestClassOf;
+    Procedure TestClassOfAlias;
     Procedure TestClassOfNonClassFail;
     Procedure TestClassOfIsOperatorFail;
     Procedure TestClassOfAsOperatorFail;
@@ -7385,6 +7386,31 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestClassOfAlias;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TBird = TObject;',
+  '  TBirds = class of TBird;',
+  //'  TEagles = TBirds;',
+  //'var',
+  //'  o: TBird;',
+  //'  c: TEagles;',
+  'begin',
+  //'  c:=TObject;',
+  //'  c:=TBird;',
+  //'  if c=TObject then ;',
+  //'  if c=TBird then ;',
+  //'  if o is TBirds then ;',
+  //'  if o is TEagles then ;',
+  //'  if o is c then ;',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestClassOfNonClassFail;
 begin
   StartProgram(false);