* fix #41074: adjust conversion level of class/interface to pointer and class to interface conversions so that sub class to class conversions take precedence

+ added tests

compiler/defcmp.pas

@@ -1714,7 +1714,7 @@ implementation
                         (torddef(tpointerdef(def_to).pointeddef).ordtype=uvoid) then
                        begin
                          doconv:=tc_equal;
-                         eq:=te_convert_l2;
+                         eq:=te_convert_l5;
                        end
                      else if (is_objc_class_or_protocol(def_from) and
                               (def_to=objc_idtype)) or
@@ -1947,8 +1947,9 @@ implementation
                                   else
                                     { for Objective-C, we don't have to do anything special }
                                     doconv:=tc_equal;
-                                  { don't prefer this over objectdef->objectdef }
-                                  eq:=te_convert_l2;
+                                  { don't prefer this over objectdef->objectdef or
+                                    inherited objectdef->objectdef }
+                                  eq:=te_convert_l4;
                                   break;
                                end;
                              hobjdef:=hobjdef.childof;

tests/test/toperator96.pp

@@ -0,0 +1,170 @@
+program toperator96;
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+type
+  ITestIntf = interface
+  ['{4E8F3222-928F-427C-91D9-C499F8A73693}']
+    procedure Test;
+  end;
+
+  TTestObject = class(TInterfacedObject, ITestIntf)
+    procedure Test;
+  end;
+
+  TTestObject2 = class
+  end;
+
+  TOvldType = (otNone, otTObject, otIUnknown, otPointer);
+
+  TTest1 = record
+    t: TOvldType;
+    class operator := (aArg: TObject): TTest1;
+    class operator := (aArg: IUnknown): TTest1;
+    class operator := (aArg: Pointer): TTest1;
+  end;
+
+  TTest2 = record
+    t: TOvldType;
+    class operator := (aArg: IUnknown): TTest2;
+    class operator := (aArg: Pointer): TTest2;
+  end;
+
+  TTest3 = record
+    t: TOvldType;
+    class operator := (aArg: TObject): TTest3;
+    class operator := (aArg: Pointer): TTest3;
+  end;
+
+  TTest4 = record
+    t: TOvldType;
+    class operator := (aArg: TObject): TTest4;
+    class operator := (aArg: IUnknown): TTest4;
+  end;
+
+procedure TTestObject.Test;
+begin
+end;
+
+class operator TTest1. := (aArg: TObject): TTest1;
+begin
+  Result.t := otTObject;
+end;
+
+class operator TTest1. := (aArg: IUnknown): TTest1;
+begin
+  Result.t := otIUnknown;
+end;
+
+class operator TTest1. := (aArg: Pointer): TTest1;
+begin
+  Result.t := otPointer;
+end;
+
+class operator TTest2. := (aArg: IUnknown): TTest2;
+begin
+  Result.t := otIUnknown;
+end;
+
+class operator TTest2. := (aArg: Pointer): TTest2;
+begin
+  Result.t := otPointer;
+end;
+
+class operator TTest3. := (aArg: TObject): TTest3;
+begin
+  Result.t := otTObject;
+end;
+
+class operator TTest3. := (aArg: Pointer): TTest3;
+begin
+  Result.t := otPointer;
+end;
+
+class operator TTest4. := (aArg: TObject): TTest4;
+begin
+  Result.t := otTObject;
+end;
+
+class operator TTest4. := (aArg: IUnknown): TTest4;
+begin
+  Result.t := otIUnknown;
+end;
+
+var
+  o: TTestObject;
+  o2: TTestObject2;
+  t1: TTest1;
+  t2: TTest2;
+  t3: TTest3;
+  t4: TTest4;
+  i: IUnknown;
+begin
+  o := TTestObject.Create;
+  o2 := TTestObject2.Create;
+  i := o;
+
+  t1 := o;
+  Writeln('Test1 o: ', t1.t);
+  if t1.t <> otTObject then
+    Halt(1);
+
+  t2 := o;
+  Writeln('Test2 o: ', t2.t);
+  if t2.t <> otIUnknown then
+    Halt(2);
+
+  t3 := o;
+  Writeln('Test3 o: ', t3.t);
+  if t3.t <> otTObject then
+    Halt(3);
+
+  t4 := o;
+  Writeln('Test4 o: ', t4.t);
+  if t4.t <> otTObject then
+    Halt(4);
+
+  t1 := i;
+  Writeln('Test1 i: ', t1.t);
+  if t1.t <> otIUnknown then
+    Halt(5);
+
+  t2 := i;
+  Writeln('Test2 i: ', t2.t);
+  if t2.t <> otIUnknown then
+    Halt(6);
+
+  t3 := i;
+  Writeln('Test3 i: ', t3.t);
+  if t3.t <> otPointer then
+    Halt(7);
+
+  t4 := i;
+  Writeln('Test4 i: ', t4.t);
+  if t4.t <> otIUnknown then
+    Halt(8);
+
+  t1 := o2;
+  Writeln('Test1 o2: ', t1.t);
+  if t1.t <> otTObject then
+    Halt(9);
+
+  t2 := o2;
+  Writeln('Test2 o2: ', t2.t);
+  if t2.t <> otPointer then
+    Halt(10);
+
+  t3 := o2;
+  Writeln('Test3 o2: ', t3.t);
+  if t3.t <> otTObject then
+    Halt(11);
+
+  t4 := o2;
+  Writeln('Test4 o2: ', t4.t);
+  if t4.t <> otTObject then
+    Halt(12);
+
+  i := Nil;
+  o2.Free;
+end.

tests/webtbs/tw41074.pp

@@ -0,0 +1,79 @@
+program tw41074;
+
+{$IFDEF FPC}
+{$mode objfpc}{$H+}
+{$ELSE}
+{$APPTYPE CONSOLE}
+{$ENDIF}
+
+uses
+  {$IFDEF FPC}
+  {$ENDIF}
+  {$IFnDEF FPC}System.{$ENDIF}SysUtils,
+  {$IFnDEF FPC}System.{$ENDIF}Rtti;
+
+type
+  ITestInterface = interface
+    ['{12345678-1234-1234-1234-123456789012}']
+    procedure DoSomething;
+  end;
+
+  TTestClass = class(TInterfacedObject, ITestInterface)
+  public
+    procedure DoSomething;
+  end;
+
+procedure TTestClass.DoSomething;
+begin
+  //Writeln('TTestClass.DoSomething called');
+end;
+
+{procedure TestType(arg: IUnknown); overload;
+begin
+  Writeln('Argument of type IUnknown received in overload 1');
+end;
+
+procedure TestType(arg: Pointer); overload;
+begin
+  Writeln('Argument of type Pointer received in overload 2');
+end;
+
+procedure TestType(arg: TObject); overload;
+begin
+  Writeln('Argument of type TObject received in overload 3');
+end;}
+
+var
+  obj: TTestClass;
+  i: IUnknown;
+  tval: TValue;
+begin
+  try
+    obj := TTestClass.Create;
+    //try
+      //TestType(obj); // TObject anywhere
+    {finally
+      obj.Free;
+    end;}
+    { keep instance alive in case of conversion to IUnknown }
+    i := obj;
+
+    tval := obj;
+    Writeln(tval.ToString);
+    if tval.Kind <> tkClass then
+      Halt(1);
+    {
+      Delphi: (TTestClass @ 0342BDB8)
+      FPC: (pointer @ 0000000001614170)
+        OR
+           (interface @ 00000000015F4118)
+           (if there is no overloading of the := operator for Pointer at TValue)
+    }
+
+    //Readln;
+  except
+    on E: Exception do
+      Writeln(E.ClassName, ': ', E.Message);
+  end;
+end.
+