diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index f486a8457c..41c44873dd 100644 --- a/compiler/defcmp.pas +++ b/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; diff --git a/tests/test/toperator96.pp b/tests/test/toperator96.pp new file mode 100644 index 0000000000..b6a1b79a3d --- /dev/null +++ b/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. diff --git a/tests/webtbs/tw41074.pp b/tests/webtbs/tw41074.pp new file mode 100644 index 0000000000..a71a06bada --- /dev/null +++ b/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. +