From fcaac0ebe12d82af5fd704e2977a4d49f2c65bbe Mon Sep 17 00:00:00 2001
From: paul <paul@idefix.freepascal.org>
Date: Sat, 27 Feb 2010 04:41:52 +0000
Subject: [PATCH] compiler,rtl - safecall handling:   - pass address to
 SafeCallException  method(rtl needed a modification)   - improve code
 generation for regular safecall routines (not methods)   - improve test -
 check that passed exception and address are valid

git-svn-id: trunk@14946 -
---
 compiler/psub.pas        | 51 +++++++++++++++++++++++++---------------
 rtl/inc/compproc.inc     |  1 +
 rtl/inc/except.inc       | 10 ++++++++
 tests/test/tsafecall1.pp | 10 ++++++--
 4 files changed, 51 insertions(+), 21 deletions(-)

diff --git a/compiler/psub.pas b/compiler/psub.pas
index 0bd3aa2376..b49a8f3d6a 100644
--- a/compiler/psub.pas
+++ b/compiler/psub.pas
@@ -476,7 +476,7 @@ implementation
         newstatement : tstatementnode;
         oldlocalswitches: tlocalswitches;
         { safecall handling }
-        exceptnode: ttempcreatenode;
+        exceptobjnode,exceptaddrnode: ttempcreatenode;
         sym,exceptsym: tsym;
       begin
         generate_except_block:=internalstatements(newstatement);
@@ -524,37 +524,50 @@ implementation
                 sym:=tlocalvarsym.create('$safe_result',vs_value,hresultdef,[]);
                 include(sym.symoptions,sp_internal);
                 current_procinfo.procdef.localst.insert(sym);
-                { temp variable to store popped up exception }
-                exceptnode:=ctempcreatenode.create(class_tobject,class_tobject.size,
-                  tt_persistent,true);
-                addstatement(newstatement,exceptnode);
-                addstatement(newstatement,
-                  cassignmentnode.create(
-                    ctemprefnode.create(exceptnode),
-                    ccallnode.createintern('fpc_popobjectstack', nil)));
                 { if safecall is used for a class method we need to call }
                 { SafecallException virtual method                       }
                 { In other case we return E_UNEXPECTED error value       }
                 if is_class(current_procinfo.procdef._class) then
                   begin
+                    { temp variable to store exception address }
+                    exceptaddrnode:=ctempcreatenode.create(voidpointertype,voidpointertype.size,
+                      tt_persistent,true);
+                    addstatement(newstatement,exceptaddrnode);
+                    addstatement(newstatement,
+                      cassignmentnode.create(
+                        ctemprefnode.create(exceptaddrnode),
+                        ccallnode.createintern('fpc_getexceptionaddr',nil)));
+                    { temp variable to store popped up exception }
+                    exceptobjnode:=ctempcreatenode.create(class_tobject,class_tobject.size,
+                      tt_persistent,true);
+                    addstatement(newstatement,exceptobjnode);
+                    addstatement(newstatement,
+                      cassignmentnode.create(
+                        ctemprefnode.create(exceptobjnode),
+                        ccallnode.createintern('fpc_popobjectstack', nil)));
                     exceptsym:=search_class_member(current_procinfo.procdef._class,'SAFECALLEXCEPTION');
                     addstatement(newstatement,
                       cassignmentnode.create(
                         cloadnode.create(sym,sym.Owner),
                         ccallnode.create(
-                          ccallparanode.create(cpointerconstnode.create(0,voidpointertype),
-                          ccallparanode.create(ctemprefnode.create(exceptnode),nil)),
+                          ccallparanode.create(ctemprefnode.create(exceptaddrnode),
+                          ccallparanode.create(ctemprefnode.create(exceptobjnode),nil)),
                           tprocsym(exceptsym), tprocsym(exceptsym).owner,load_self_node,[])));
+                    addstatement(newstatement,ccallnode.createintern('fpc_destroyexception',
+                      ccallparanode.create(ctemprefnode.create(exceptobjnode),nil)));
+                    addstatement(newstatement,ctempdeletenode.create(exceptobjnode));
+                    addstatement(newstatement,ctempdeletenode.create(exceptaddrnode));
                   end
                 else
-                  addstatement(newstatement,
-                    cassignmentnode.create(
-                      cloadnode.create(sym,sym.Owner),
-                      genintconstnode(HResult($8000FFFF))));
-                { destroy popped up exception }
-                addstatement(newstatement,ccallnode.createintern('fpc_destroyexception',
-                  ccallparanode.create(ctemprefnode.create(exceptnode),nil)));
-                addstatement(newstatement,ctempdeletenode.create(exceptnode));
+                  begin
+                    { pop up and destroy an exception }
+                    addstatement(newstatement,ccallnode.createintern('fpc_destroyexception',
+                      ccallparanode.create(ccallnode.createintern('fpc_popobjectstack', nil),nil)));
+                    addstatement(newstatement,
+                      cassignmentnode.create(
+                        cloadnode.create(sym,sym.Owner),
+                        genintconstnode(HResult($8000FFFF))));
+                  end;
               end;
 {$endif}
           end;
diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc
index f600f92eca..f63fb051f6 100644
--- a/rtl/inc/compproc.inc
+++ b/rtl/inc/compproc.inc
@@ -609,6 +609,7 @@ function fpc_PopSecondObjectStack : TObject; compilerproc;
 Procedure fpc_ReRaise; compilerproc;
 Function fpc_Catches(Objtype : TClass) : TObject; compilerproc;
 Procedure fpc_DestroyException(o : TObject); compilerproc;
+function fpc_GetExceptionAddr : Pointer; compilerproc;
 {$endif FPC_HAS_FEATURE_EXCEPTIONS}
 
 
diff --git a/rtl/inc/except.inc b/rtl/inc/except.inc
index 4b6e856951..b2d420ecfc 100644
--- a/rtl/inc/except.inc
+++ b/rtl/inc/except.inc
@@ -343,6 +343,16 @@ begin
   o.Free;
 end;
 
+function fpc_GetExceptionAddr : Pointer;[Public, Alias : 'FPC_GETEXCEPTIONADDR']; compilerproc;
+var
+  _ExceptObjectStack : PExceptObject;
+begin
+  _ExceptObjectStack:=ExceptObjectStack;
+  if _ExceptObjectStack=nil then
+    fpc_GetExceptionAddr:=nil
+  else
+    fpc_GetExceptionAddr:=_ExceptObjectStack^.Addr;
+end;
 
 Procedure SysInitExceptions;
 {
diff --git a/tests/test/tsafecall1.pp b/tests/test/tsafecall1.pp
index 2eaae56fca..d89910d04b 100644
--- a/tests/test/tsafecall1.pp
+++ b/tests/test/tsafecall1.pp
@@ -12,15 +12,21 @@ type
   end;
 
 var
+  ExceptObj: TObject;
   Handled: Boolean;
 
 procedure TTest.SomeError; safecall;
 begin
-  raise Exception.Create('SomeException');
+  ExceptObj := Exception.Create('SomeException');
+  raise ExceptObj;
 end;
 
 function TTest.SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult;
 begin
+  if ExceptAddr = nil then
+    halt(2);
+  if ExceptObject <> ExceptObj then
+    halt(3);
   Handled := True;
   Result := 0;
 end;
@@ -30,4 +36,4 @@ begin
   TTest.Create.SomeError;
   if not Handled then
     halt(1);
-end.
\ No newline at end of file
+end.