compiler: safecall exception handling:

  - move safecall exception handling from codegenerator to generate_except_block method (which generates nodes)
  - call SafeCallException for safecall methods which raises an exception

git-svn-id: trunk@14940 -

compiler/ncgflw.pas

@@ -1499,6 +1499,7 @@ implementation
          oldflowcontrol,tryflowcontrol : tflowcontrol;
          decconst : longint;
          excepttemps : texceptiontemps;
+         retsym: tlocalvarsym;
       begin
          location_reset(location,LOC_VOID,OS_NO);
 
@@ -1589,13 +1590,12 @@ implementation
              if (target_info.system in systems_all_windows) and
                 (current_procinfo.procdef.proccalloption=pocall_safecall) then
                begin
-                 { Remove and destroy the last exception object }
-                 cg.a_call_name(current_asmdata.CurrAsmList,'FPC_POPOBJECTSTACK',false);
-                 cg.a_call_name(current_asmdata.CurrAsmList,'FPC_DESTROYEXCEPTION',false);
+                 { find safe_result variable we created in the generate_except_block }
+                 retsym:=tlocalvarsym(current_procinfo.procdef.localst.Find('safe_result'));
                  { Set return value of safecall procedure to indicate exception.       }
                  { Exception will be raised after procedure exit based on return value }
                  cg.a_reg_alloc(current_asmdata.CurrAsmList,NR_FUNCTION_RESULT_REG);
-                 cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_ADDR,aint($8000FFFF),NR_FUNCTION_RETURN_REG);
+                 cg.a_load_ref_reg(current_asmdata.CurrAsmList,retsym.localloc.size,retsym.localloc.size,retsym.localloc.reference,NR_FUNCTION_RESULT_REG);
                  cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_FUNCTION_RESULT_REG);
                end
              else

compiler/psub.pas

@@ -475,6 +475,9 @@ implementation
         pd : tprocdef;
         newstatement : tstatementnode;
         oldlocalswitches: tlocalswitches;
+        { safecall handling }
+        exceptnode: ttempcreatenode;
+        sym,exceptsym: tsym;
       begin
         generate_except_block:=internalstatements(newstatement);
 
@@ -510,6 +513,50 @@ implementation
                (not paramanager.ret_in_param(current_procinfo.procdef.returndef, current_procinfo.procdef.proccalloption)) and
                (not is_class(current_procinfo.procdef.returndef)) then
               addstatement(newstatement,finalize_data_node(load_result_node));
+{$if defined(x86) or defined(arm)}
+            { safecall handling }
+            if (target_info.system in systems_all_windows) and
+               (current_procinfo.procdef.proccalloption=pocall_safecall) then
+              begin
+                { create a local hidden variable "safe_result"    }
+                { it will be used in ncgflw unit                  }
+                { to set "real" result value for safecall routine }
+                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
+                    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)),
+                          tprocsym(exceptsym), tprocsym(exceptsym).owner,load_self_node,[])));
+                  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));
+              end;
+{$endif}
           end;
       end;
 

rtl/inc/compproc.inc

@@ -608,6 +608,7 @@ function fpc_PopObjectStack : TObject; compilerproc;
 function fpc_PopSecondObjectStack : TObject; compilerproc;
 Procedure fpc_ReRaise; compilerproc;
 Function fpc_Catches(Objtype : TClass) : TObject; compilerproc;
+Procedure fpc_DestroyException(o : TObject); compilerproc;
 {$endif FPC_HAS_FEATURE_EXCEPTIONS}
 
 
@@ -619,7 +620,6 @@ procedure fpc_help_fail(_self:pointer;var _vmt:pointer;vmt_pos:cardinal);compile
 
 
 {$ifdef dummy}
-Procedure fpc_DestroyException(o : TObject); compilerproc;
 procedure fpc_check_object(obj:pointer); compilerproc;
 procedure fpc_check_object_ext(vmt,expvmt:pointer);compilerproc;
 {$endif dummy}

rtl/inc/objpas.inc

@@ -381,7 +381,7 @@
         exceptaddr : pointer) : HResult;
 
         begin
-           safecallexception:=E_UNEXPECTED;
+          safecallexception:=E_UNEXPECTED;
         end;
 
       class function TObject.ClassInfo : pointer;