* Allow to retrieve info about last invalid type cast

rtl/inc/except.inc

@@ -325,6 +325,10 @@ Procedure SysInitExceptions;
   Initialize exceptionsupport
 }
 begin
+  // These are here, because they need to be initialized for every thread.
+  CastErrorFrom:='';
+  CastErrorTo:='';
+
   ExceptObjectstack:=Nil;
   ExceptAddrStack:=Nil;
 end;

rtl/inc/objpas.inc

@@ -42,12 +42,31 @@
            aobject.inheritsfrom(aclass);
       end;
 
+{$IFDEF FPC_HAS_FEATURE_THREADING}
+threadvar
+  CastErrorFrom : ShortString;
+  CastErrorTo : ShortString;
+{$ELSE}
+var
+  CastErrorFrom : ShortString = '';
+  CastErrorTo : ShortString = '';
+{$ENDIF}
+
+
+    procedure SetCastErrorInfo(const aFrom,aTo : shortstring);
+    begin
+      CastErrorFrom:=aFrom;
+      CastErrorTo:=aTo;
+    end;
 
     { the reverse order of the parameters make code generation easier }
     function fpc_do_as(aclass : tclass;aobject : tobject): tobject;[public,alias: 'FPC_DO_AS']; compilerproc;
       begin
          if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then
+           begin
+           SetCastErrorInfo(aObject.ClassName,aClass.ClassName);
            handleerroraddrframeInd(219,get_pc_addr,get_frame);
+           end;
          result := aobject;
       end;
 
@@ -205,12 +224,19 @@
     function fpc_intf_as(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_INTF_AS']; compilerproc;
       var
         tmpi: pointer; // _AddRef before _Release
+        errObj : TObject;
       begin
         if assigned(S) then
           begin
              tmpi:=nil;
              if IUnknown(S).QueryInterface(iid,tmpi)<>S_OK then
+               begin
+               if (IUnknown(S).QueryInterface(IObjectInstance,errObj)=S_OK) then
+                 SetCastErrorInfo(errObj.ClassName,iid.AsString)
+               else
+                 SetCastErrorInfo('External interface',iid.AsString);
                handleerror(219);
+               end;
              // decrease reference count
              fpc_intf_as:=nil;
              pointer(fpc_intf_as):=tmpi;
@@ -223,11 +249,18 @@
     function fpc_intf_as_class(const S: pointer; const aclass: tclass): pointer;[public,alias: 'FPC_INTF_AS_CLASS']; compilerproc;
       var
         tmpo: tobject;
+        errObj : TObject;
       begin
         if assigned(S) then
           begin
             if not ((IUnknown(S).QueryInterface(IObjectInstance,tmpo)=S_OK) and tmpo.inheritsfrom(aclass)) then
+              begin
+              if (IUnknown(S).QueryInterface(IObjectInstance,errObj)=S_OK) then
+                SetCastErrorInfo(errObj.ClassName,aClass.ClassName)
+              else
+                SetCastErrorInfo('External interface',aClass.ClassName);
               handleerror(219);
+              end;
             fpc_intf_as_class:=tmpo;
           end
         else
@@ -239,13 +272,17 @@
       var
         tmpi: pointer; // _AddRef before _Release
         tmpi2: pointer; // weak!
+        errObj : TObject;
       begin
         if assigned(S) then
           begin
              tmpi:=nil;
              tmpi2:=nil;
              if not ((TObject(S).GetInterfaceWeak(IUnknown,tmpi2) and (IUnknown(tmpi2).QueryInterface(IID,tmpi)=S_OK)) or TObject(S).GetInterface(IID,tmpi)) then
+               begin
+               SetCastErrorInfo(TObject(S).ClassName,iid.AsString);
                handleerror(219);
+               end;
              // decrease reference count
              fpc_class_as_intf:=nil;
              pointer(fpc_class_as_intf):=tmpi;
@@ -263,7 +300,10 @@
           begin
              tmpi:=nil;
              if not TObject(S).GetInterface(iid,tmpi) then
+               begin
+               SetCastErrorInfo(TObject(S).ClassName,iid);
                handleerror(219);
+               end;
              fpc_class_as_corbaintf:=tmpi;
           end
         else
@@ -353,8 +393,18 @@ begin
   Result:=(P[0]=0) and (P[1]=0) and (P[2]=0) and (P[3]=0)
 end;
 
+function TGUID.AsString : ShortString;
 
 
+begin
+  WriteStr(Result,'{',hexstr(Longint(D1),8),
+                      '-',HexStr(D2,4),
+                      '-',HexStr(D3,4),
+                      '-',HexStr(D4[0],2), HexStr(D4[1],2),
+                      '-',HexStr(D4[2],2), HexStr(D4[3],2), HexStr(D4[4],2), HexStr(D4[5],2), HexStr(D4[6],2), HexStr(D4[7],2),
+                   '}');
+end;
+
 {****************************************************************************
                            TINTERFACEENTRY
 ****************************************************************************}
@@ -1055,6 +1105,15 @@ end;
           getinterfacetable:=PVmt(Self)^.vIntfTable;
         end;
 
+      class procedure TObject.GetLastCastErrorInfo(out aFrom,aTo : shortstring);
+
+      begin
+        aFrom:=CastErrorFrom;
+        aTo:=CastErrorTo;
+        CastErrorFrom:='';
+        CastErrorTo:='';
+      end;
+
       class function TObject.UnitName : RTLString;
 {$ifdef FPC_HAS_FEATURE_RTTI}
 

rtl/inc/objpash.inc

@@ -45,6 +45,7 @@
         class function Create(const aData: array of Byte; aStartIndex: Cardinal; aBigEndian: Boolean = False): TGUID; overload; static;
         class function Create(const aData : PByte; aBigEndian: Boolean = False): TGUID; overload; static;
         function IsEmpty: Boolean;
+        function AsString : ShortString;
       Public
          case integer of
             1 : (
@@ -278,6 +279,8 @@
 
           class function MethodAddress(const name : shortstring) : codepointer;
           class function MethodName(address : codepointer) : shortstring;
+          class procedure GetLastCastErrorInfo(out aFrom,aTo : shortstring); static;
+
           function FieldAddress(const name : shortstring) : pointer;
 
           { new since Delphi 4 }

rtl/objpas/sysconst.pp

@@ -89,6 +89,7 @@ const
   SInvalidUnaryVarOp     = 'Invalid variant operation %s %s';
   SInvalidVarOpWithHResultWithPrefix = 'Invalid variant operation (%s%.8x)'+LineEnding+'%s';
   SNoError               = 'No error.';
+  SInstanceIsNotA        = ': %s is not a %s';
   SNoThreadSupport       = 'Threads not supported. Recompile program with thread driver.';
   SNoDynLibsSupport      = 'Dynamic libraries not supported. Recompile program with dynamic library driver.';
   SMissingWStringManager = 'Widestring manager not available. Recompile program with appropriate manager.';

tests/test/units/system/tcastc2c.pp

@@ -0,0 +1,39 @@
+program testtypecastinfo;
+
+// Test that typecast info is available when error 219 is encountered.
+
+{$mode objfpc}
+
+procedure geterrinfo;
+var
+  aFrom,aTo : shortstring;
+
+begin
+  if ExitCode=219 then
+    TObject.GetLastCastErrorInfo(aFrom,aTo);
+  Writeln('Got typecast ',aFrom,' to ',aTo,' error');
+  if (aFrom<>'') or (aTo<>'') then 
+    ExitCode:=0;
+end;
+
+Type
+  TA = Class(TObject);
+  TB = Class(TObject);
+
+var
+  A : TObject;
+  B : TB;
+  F,T : ShortString;
+
+begin
+  TObject.GetLastCastErrorInfo(F,T);
+  if (F<>'') or (T<>'') then
+    begin
+    Writeln('Error, cast info must be empty at start');
+    Halt(1);
+    end;
+  AddExitProc(@geterrinfo);
+  A:=TA.Create;
+  B:=A as TB;
+end.
+

tests/test/units/system/tcastc2i.pp

@@ -0,0 +1,38 @@
+program testtypecastintfinfoexc;
+
+// Test that typecast class -> interface generates the needed info for EInvalidCast.
+{$mode objfpc}
+
+procedure geterrinfo;
+var
+  aFrom,aTo : shortstring;
+
+begin
+  if ExitCode=219 then
+    TObject.GetLastCastErrorInfo(aFrom,aTo);
+  Writeln('Got typecast ',aFrom,' to ',aTo,' error');
+  if (aFrom<>'') or (aTo<>'') then 
+    ExitCode:=0;
+end;
+
+Type
+  TA = Class(TObject);
+
+
+var
+  A : TObject;
+  B : IInterface;
+  F,T : ShortString;
+
+begin
+  AddExitProc(@geterrinfo);
+  TObject.GetLastCastErrorInfo(F,T);
+  if (F<>'') or (T<>'') then
+    begin
+    Writeln('Error, cast info must be empty at start');
+    Halt(1);
+    end;
+  A:=TA.Create;
+  B:=A as IInterface;
+end.
+

tests/test/units/system/tcasti2c.pp

@@ -0,0 +1,38 @@
+program testtypecastintfclinfoexc;
+
+// Test that typecast interface -> class generates the needed info for EInvalidCast.
+{$mode objfpc}
+
+procedure geterrinfo;
+var
+  aFrom,aTo : shortstring;
+
+begin
+  if ExitCode=219 then
+    TObject.GetLastCastErrorInfo(aFrom,aTo);
+  Writeln('Got typecast ',aFrom,' to ',aTo,' error');
+  if (aFrom<>'') or (aTo<>'') then 
+    ExitCode:=0;
+end;
+
+Type
+  TA = Class(TInterfacedObject);
+  TB = Class(TObject);
+
+var
+  A : IInterface;
+  B : TB;
+  F,T : ShortString;
+
+begin
+  AddExitProc(@geterrinfo);
+  TObject.GetLastCastErrorInfo(F,T);
+  if (F<>'') or (T<>'') then
+    begin
+    Writeln('Error, cast info must be empty at start');
+    Halt(1);
+    end;
+  A:=TA.Create;
+  B:=A as TB;
+end.
+

tests/test/units/system/tcasti2i.pp

@@ -0,0 +1,40 @@
+program testtypecastintfintfinfoexc;
+
+// Test that typecast interface -> interface generates the needed info for EInvalidCast.
+{$mode objfpc}
+
+procedure geterrinfo;
+var
+  aFrom,aTo : shortstring;
+
+begin
+  if ExitCode=219 then
+    TObject.GetLastCastErrorInfo(aFrom,aTo);
+  Writeln('Got typecast ',aFrom,' to ',aTo,' error');
+  if (aFrom<>'') or (aTo<>'') then 
+    ExitCode:=0;
+end;
+
+Type
+  TA = Class(TInterfacedObject);
+  TB = Class(TObject);
+  IB = interface ['{3A4B75D4-76E6-4856-A3F1-0B10454763F6}']
+  end;
+
+var
+  A : IInterface;
+  B : IB;
+  F,T : ShortString;
+
+begin
+  AddExitProc(@geterrinfo);
+  TObject.GetLastCastErrorInfo(F,T);
+  if (F<>'') or (T<>'') then
+    begin
+    Writeln('Error, cast info must be empty at start');
+    Halt(1);
+    end;
+  A:=TA.Create;
+  B:=A as IB;
+end.
+

tests/test/units/sysutils/tcstec2c.pp

@@ -0,0 +1,39 @@
+program testtypecastinfoexc;
+
+{$mode objfpc}
+// Test that EInvalidCast picks up the typecast error info.
+ 
+uses SysUtils;
+
+Type
+  TA = Class(TObject);
+  TB = Class(TObject);
+
+var
+  A : TObject;
+  B : TB;
+  F,T : ShortString;
+
+begin
+  TObject.GetLastCastErrorInfo(F,T);
+  if (F<>'') or (T<>'') then
+    begin
+    Writeln('Error, cast info must be empty at start');
+    Halt(1);
+    end;
+  A:=TA.Create;
+  try
+  B:=A as TB;
+  except
+    On E : EInvalidCast do
+      begin
+        if not (Pos('TB',E.Message) > Pos('TA',E.Message)) then
+          Halt(1)
+        else
+          Writeln('TA and TB in error: ',E.Message);
+      end
+  else
+    Halt()
+  end;
+end.
+