fcl-passrc: resolver: pointer=class

git-svn-id: trunk@39309 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1732,7 +1732,7 @@ type
     function IsVarInit(Expr: TPasExpr): boolean;
     function IsEmptyArrayExpr(const ResolvedEl: TPasResolverResult): boolean;
     function IsClassMethod(El: TPasElement): boolean;
-    function IsExternalClassName(aClass: TPasClassType; const ExtName: string): boolean;
+    function IsExternalClass_Name(aClass: TPasClassType; const ExtName: string): boolean;
     function IsProcedureType(const ResolvedEl: TPasResolverResult; HasValue: boolean): boolean;
     function IsArrayType(const ResolvedEl: TPasResolverResult): boolean;
     function IsArrayExpr(Expr: TParamsExpr): TPasArrayType;
@@ -16775,7 +16775,13 @@ begin
       RTypeEl:=RHS.LoTypeEl;
       if RTypeEl.ClassType=TPasPointerType then
         // @Something=TypedPointer
-        exit(cExact);
+        exit(cExact)
+      else if RTypeEl.ClassType=TPasClassType then
+        // @Something=ClassOrInterface
+        exit(cCompatible)
+      else if RTypeEl.ClassType=TPasClassOfType then
+        // @Something=ClassOf
+        exit(cCompatible);
       end;
     end
   else if LHS.BaseType in [btSet,btArrayOrSet] then
@@ -16868,7 +16874,9 @@ begin
       end
     else if LTypeEl.ClassType=TPasClassType then
       begin
-      if TPasClassType(LTypeEl).ObjKind=okInterface then
+      if RHS.BaseType=btPointer then
+        exit(cCompatible)
+      else if TPasClassType(LTypeEl).ObjKind=okInterface then
         begin
         if RHS.BaseType in btAllStrings then
           begin
@@ -16886,6 +16894,11 @@ begin
           end;
         end;
       end
+    else if LTypeEl.ClassType=TPasClassOfType then
+      begin
+      if RHS.BaseType=btPointer then
+        exit(cCompatible);
+      end
     else if LTypeEl.ClassType=TPasRecordType then
       begin
       if IsTGUID(TPasRecordType(LTypeEl)) then
@@ -19484,7 +19497,7 @@ begin
        or (C=TPasClassOperator);
 end;
 
-function TPasResolver.IsExternalClassName(aClass: TPasClassType;
+function TPasResolver.IsExternalClass_Name(aClass: TPasClassType;
   const ExtName: string): boolean;
 var
   AncestorScope: TPasClassScope;

packages/fcl-passrc/tests/tcresolver.pas

@@ -780,6 +780,7 @@ type
     Procedure TestPointer_TypecastFromMethodTypeFail;
     Procedure TestPointer_TypecastMethod_proMethodAddrAsPointer;
     Procedure TestPointer_OverloadSignature;
+    Procedure TestPointer_Assign;
     Procedure TestPointerTyped;
     Procedure TestPointerTypedForwardMissingFail;
     Procedure TestPointerTyped_CycleFail;
@@ -9663,53 +9664,59 @@ end;
 procedure TTestResolver.TestClassOf;
 begin
   StartProgram(false);
-  Add('type');
+  Add([
-  Add('  {#TClass}{=TObj}TClass = class of TObject;');
+  'type',
-  Add('  {#TOBJ}TObject = class');
+  '  {#TClass}{=TObj}TClass = class of TObject;',
-  Add('    ClassType: TClass; ');
+  '  {#TOBJ}TObject = class',
-  Add('  end;');
+  '    ClassType: TClass; ',
-  Add('type');
+  '  end;',
-  Add('  {#TMobile}TMobile = class');
+  'type',
-  Add('  end;');
+  '  {#TMobile}TMobile = class',
-  Add('  {#TMobiles}{=TMobile}TMobiles = class of TMobile;');
+  '  end;',
-  Add('type');
+  '  {#TMobiles}{=TMobile}TMobiles = class of TMobile;',
-  Add('  {#TCars}{=TCar}TCars = class of TCar;');
+  'type',
-  Add('  {#TShips}{=TShip}TShips = class of TShip;');
+  '  {#TCars}{=TCar}TCars = class of TCar;',
-  Add('  {#TCar}TCar = class(TMobile)');
+  '  {#TShips}{=TShip}TShips = class of TShip;',
-  Add('  end;');
+  '  {#TCar}TCar = class(TMobile)',
-  Add('  {#TShip}TShip = class(TMobile)');
+  '  end;',
-  Add('  end;');
+  '  {#TShip}TShip = class(TMobile)',
-  Add('var');
+  '  end;',
-  Add('  o: TObject;');
+  'var',
-  Add('  c: TClass;');
+  '  o: TObject;',
-  Add('  mobile: TMobile;');
+  '  c: TClass;',
-  Add('  mobiletype: TMobiles;');
+  '  mobile: TMobile;',
-  Add('  car: TCar;');
+  '  mobiletype: TMobiles;',
-  Add('  cartype: TCars;');
+  '  car: TCar;',
-  Add('  ship: TShip;');
+  '  cartype: TCars;',
-  Add('  shiptype: TShips;');
+  '  ship: TShip;',
-  Add('begin');
+  '  shiptype: TShips;',
-  Add('  c:=nil;');
+  '  p: pointer;',
-  Add('  c:=o.ClassType;');
+  'begin',
-  Add('  if c=nil then;');
+  '  c:=nil;',
-  Add('  if nil=c then;');
+  '  c:=o.ClassType;',
-  Add('  if c=o.ClassType then ;');
+  '  if c=nil then;',
-  Add('  if c<>o.ClassType then ;');
+  '  if nil=c then;',
-  Add('  if Assigned(o) then ;');
+  '  if c=o.ClassType then ;',
-  Add('  if Assigned(o.ClassType) then ;');
+  '  if c<>o.ClassType then ;',
-  Add('  if Assigned(c) then ;');
+  '  if Assigned(o) then ;',
-  Add('  mobiletype:=TMobile;');
+  '  if Assigned(o.ClassType) then ;',
-  Add('  mobiletype:=TCar;');
+  '  if Assigned(c) then ;',
-  Add('  mobiletype:=TShip;');
+  '  mobiletype:=TMobile;',
-  Add('  mobiletype:=cartype;');
+  '  mobiletype:=TCar;',
-  Add('  if mobiletype=nil then ;');
+  '  mobiletype:=TShip;',
-  Add('  if nil=mobiletype then ;');
+  '  mobiletype:=cartype;',
-  Add('  if mobiletype=TShip then ;');
+  '  if mobiletype=nil then ;',
-  Add('  if TShip=mobiletype then ;');
+  '  if nil=mobiletype then ;',
-  Add('  if mobiletype<>TShip then ;');
+  '  if mobiletype=TShip then ;',
-  Add('  if mobile is mobiletype then ;');
+  '  if TShip=mobiletype then ;',
-  Add('  if car is mobiletype then ;');
+  '  if mobiletype<>TShip then ;',
-  Add('  if mobile is cartype then ;');
+  '  if mobile is mobiletype then ;',
+  '  if car is mobiletype then ;',
+  '  if mobile is cartype then ;',
+  '  p:=c;',
+  '  if p=c then ;',
+  '  if c=p then ;',
+  '']);
   ParseProgram;
 end;
 
@@ -11367,6 +11374,8 @@ begin
   '  if i is TBird then ;',
   '  if e is TBird then ;',
   '  p:=i;',
+  '  if p=i then ;',
+  '  if i=p then ;',
   '']);
   ParseProgram;
 end;
@@ -13846,6 +13855,29 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestPointer_Assign;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TPtr = pointer;',
+  '  TClass = class of TObject;',
+  '  TObject = class end;',
+  'var',
+  '  p: TPtr;',
+  '  o: TObject;',
+  '  c: TClass;',
+  'begin',
+  '  p:=o;',
+  '  if p=o then ;',
+  '  if o=p then ;',
+  '  p:=c;',
+  '  if p=c then ;',
+  '  if c=p then ;',
+  '']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestPointerTyped;
 begin
   StartProgram(false);