* finished safecall support

git-svn-id: trunk@3417 -

compiler/ncgcal.pas

@@ -1035,6 +1035,17 @@ implementation
                  internalerror(2004110214);
               end;
            end;
+
+{$if defined(x86) or defined(arm)}
+         if procdefinition.proccalloption=pocall_safecall then
+           begin
+
+             cg.allocallcpuregisters(current_asmdata.CurrAsmList);
+             cg.a_call_name(current_asmdata.CurrAsmList,'FPC_SAFECALLCHECK');
+             cg.deallocallcpuregisters(current_asmdata.CurrAsmList);
+           end;
+{$endif}
+
          if cg.uses_registers(R_MMREGISTER) then
            cg.dealloccpuregisters(current_asmdata.CurrAsmList,R_MMREGISTER,regs_to_save_mm);
          if cg.uses_registers(R_FPUREGISTER) then

packages/extra/winunits/activex.pp

@@ -3262,6 +3262,11 @@ type
   type
     TDispID = DISPID;
 
+  function SetErrorInfo(dwReserved:ULONG;errinfo:IErrorInfo):HResult;stdcall; external 'ole32.dll' name 'SetErrorInfo';
+  function GetErrorInfo(dwReserved:ULONG;out errinfo:IErrorInfo):HResult;stdcall; external 'ole32.dll' name 'GetErrorInfo';
+  function CreateErrorInfo(out errinfo:ICreateErrorInfo):HResult;stdcall; external 'ole32.dll' name 'CreateErrorInfo';
+
+
 implementation
 
 end.

packages/extra/winunits/comobj.pp

@@ -143,13 +143,35 @@ unit comobj;
        OleCheck(CLSIDFromProgID(PWideChar(WideString(id)),result));
      end;
 
+
+   procedure SafeCallErrorHandler(err : HResult;addr : pointer);
+     var
+       info : IErrorInfo;
+       descr,src,helpfile : widestring;
+       helpctx : DWORD;
+     begin
+       if GetErrorInfo(0,info)=S_OK then
+         begin
+           info.GetDescription(descr);
+           info.GetSource(src);
+           info.GetHelpFile(helpfile);
+           info.GetHelpContext(helpctx);
+           raise EOleException.Create(descr,err,src,helpfile,helpctx) at addr;
+         end
+       else
+         raise EOleException.Create('',err,'','',0) at addr;
+     end;
+
+
 const
   Initialized : boolean = false;
 
 initialization
   if not(IsLibrary) then
     Initialized:=Succeeded(CoInitialize(nil));
+  SafeCallErrorProc:=@SafeCallErrorHandler;
 finalization
+  SafeCallErrorProc:=nil;
   if Initialized then
     CoUninitialize;
 end.

rtl/inc/system.inc

@@ -519,11 +519,13 @@ begin
   HandleErrorFrame(201,get_frame);
 end;
 
+
 procedure fpc_divbyzero;[public,alias:'FPC_DIVBYZERO']; compilerproc;
 begin
   HandleErrorFrame(200,get_frame);
 end;
 
+
 procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; compilerproc;
 begin
   HandleErrorFrame(215,get_frame);
@@ -549,6 +551,7 @@ Begin
   InOutRes:=0;
 End;
 
+
 Function GetThreadID:TThreadID;{$ifdef SYSTEMINLINE}inline;{$endif}
 begin
 (* ThreadID is stored in a threadvar and made available in interface *)
@@ -556,6 +559,19 @@ begin
   GetThreadID := ThreadID;
 end;
 
+
+function fpc_safecallcheck(res : hresult) : hresult;[public,alias:'FPC_SAFECALLCHECK']; compilerproc;
+begin
+  if res<0 then
+    begin
+      if assigned(SafeCallErrorProc) then
+        SafeCallErrorProc(res,get_frame);
+      HandleErrorFrame(229,get_frame);
+    end;
+  result:=res;
+end;
+
+
 {*****************************************************************************
                          Stack check code
 *****************************************************************************}

rtl/inc/systemh.inc

@@ -650,7 +650,7 @@ Type
   TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer);
   TAbstractErrorProc = Procedure;
   TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno:longint;erroraddr:pointer);
-
+  TSafeCallErrorProc = Procedure(error : HResult;addr : pointer);
 
 
 const
@@ -658,7 +658,7 @@ const
   ErrorProc         : TErrorProc = nil;
   AbstractErrorProc : TAbstractErrorProc = nil;
   AssertErrorProc   : TAssertErrorProc = @SysAssert;
-
+  SafeCallErrorProc : TSafeCallErrorProc = nil;
 
 {*****************************************************************************
                           SetJmp/LongJmp