Merged revisions 7720-7724,7727,7728,7730,7731,7734 via svnmerge from

http://svn.freepascal.org/svn/fpc/trunk

........
  r7720 | yury | 2007-06-18 17:26:08 +0300 (Пн, 18 июн 2007) | 1 line
  
  * Fixed safecall procedures by generating implicit try/finally and setting correct return value if exception was occurred or not. Now safecall is fully Delphi compatible.
........
  r7721 | yury | 2007-06-18 19:12:49 +0300 (Пн, 18 июн 2007) | 1 line
  
  * Pop the last exception object in safecall procedure. 
........
  r7722 | yury | 2007-06-18 20:26:15 +0300 (Пн, 18 июн 2007) | 1 line
  
  * It is needed to destroy exception object in safecall procedure as well. 
........
  r7723 | yury | 2007-06-18 20:38:07 +0300 (Пн, 18 июн 2007) | 1 line
  
  * use proper runtime error codes for EIntfCastError and ESafecallException exceptions.
........
  r7724 | yury | 2007-06-18 20:42:17 +0300 (Пн, 18 июн 2007) | 1 line
  
  * fixed test.
........
  r7727 | yury | 2007-06-19 00:40:33 +0300 (Вт, 19 июн 2007) | 1 line
  
  * Set return value of safecall procedure if implicit try/finally blocks are disabled.
........
  r7728 | yury | 2007-06-19 02:23:46 +0300 (Вт, 19 июн 2007) | 2 lines
  
  * Properly set location of float return value if it is passed as var parameter (it is always happens for safecall functions). It fixes bugs #8523 and #8977.
  + test.
........
  r7730 | yury | 2007-06-19 13:37:59 +0300 (Вт, 19 июн 2007) | 1 line
  
  * fixed test.
........
  r7731 | yury | 2007-06-19 15:09:11 +0300 (Вт, 19 июн 2007) | 2 lines
  
  * fixed bug #9107: procedure which have pushed parameters in its body fails if only -OoSTACKFRAME switch is used.
  + test.
........
  r7734 | yury | 2007-06-20 00:06:44 +0300 (Ср, 20 июн 2007) | 2 lines
  
  * Fixed bug introduced by r7667. Do not release pushed return value be callee for cdecl on win32. It fixes error3 of bug #9098.
........

git-svn-id: branches/fixes_2_2@7740 -

.gitattributes

@@ -8137,10 +8137,13 @@ tests/webtbs/tw8861.pp svneol=native#text/plain
 tests/webtbs/tw8870.pp svneol=native#text/plain
 tests/webtbs/tw8883.pp svneol=native#text/plain
 tests/webtbs/tw8919.pp svneol=native#text/plain
+tests/webtbs/tw8935.pp svneol=native#text/plain
+tests/webtbs/tw8977.pp svneol=native#text/plain
 tests/webtbs/tw9054.pp svneol=native#text/plain
 tests/webtbs/tw9076.pp svneol=native#text/plain
 tests/webtbs/tw9076a.pp svneol=native#text/plain
 tests/webtbs/tw9085.pp svneol=native#text/plain
+tests/webtbs/tw9107.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain

compiler/arm/cpupara.pas

@@ -435,7 +435,13 @@ unit cpupara;
             location_reset(p.funcretloc[side],LOC_VOID,OS_NO);
             exit;
           end;
-
+        { Return is passed as var parameter }
+        if ret_in_param(p.returndef,p.proccalloption) then
+          begin
+            p.funcretloc[side].loc:=LOC_REFERENCE;
+            p.funcretloc[side].size:=retcgsize;
+            exit;
+          end;
         { Return in FPU register? }
         if p.returndef.typ=floatdef then
           begin
@@ -468,8 +474,8 @@ unit cpupara;
                 p.funcretloc[side].register:=NR_FPU_RESULT_REG;
               end;
           end
-          { Return in register? }
-        else if not ret_in_param(p.returndef,p.proccalloption) then
+          { Return in register }
+        else
           begin
             if retcgsize in [OS_64,OS_S64] then
               begin
@@ -483,11 +489,7 @@ unit cpupara;
                 p.funcretloc[side].loc:=LOC_REGISTER;
                 p.funcretloc[side].register:=NR_FUNCTION_RETURN_REG;
               end;
-          end
-        else
-          begin
-            p.funcretloc[side].loc:=LOC_REFERENCE;
-            p.funcretloc[side].size:=retcgsize;
+
           end;
      end;
 

compiler/i386/cgcpu.pas

@@ -310,7 +310,9 @@ unit cgcpu;
                 (not use_fixed_stack)  then
          begin
            { complex return values are removed from stack in C code PM }
-           if paramanager.ret_in_param(current_procinfo.procdef.returndef,
+           { but not on win32 }
+           if (target_info.system <> system_i386_win32) and
+              paramanager.ret_in_param(current_procinfo.procdef.returndef,
                                        current_procinfo.procdef.proccalloption) then
              list.concat(Taicpu.Op_const(A_RET,S_W,sizeof(aint)))
            else

compiler/i386/cpupara.pas

@@ -328,6 +328,13 @@ unit cpupara;
             location_reset(p.funcretloc[side],LOC_VOID,OS_NO);
             exit;
           end;
+        { Return is passed as var parameter }
+        if ret_in_param(p.returndef,p.proccalloption) then
+          begin
+            p.funcretloc[side].loc:=LOC_REFERENCE;
+            p.funcretloc[side].size:=retcgsize;
+            exit;
+          end;
         { Return in FPU register? }
         if p.returndef.typ=floatdef then
           begin
@@ -336,8 +343,7 @@ unit cpupara;
             p.funcretloc[side].size:=retcgsize;
           end
         else
-         { Return in register? }
-         if not ret_in_param(p.returndef,p.proccalloption) then
+         { Return in register }
           begin
             if retcgsize in [OS_64,OS_S64] then
              begin
@@ -363,11 +369,6 @@ unit cpupara;
                else
                  p.funcretloc[side].register:=newreg(R_INTREGISTER,RS_FUNCTION_RETURN_REG,cgsize2subreg(retcgsize));
              end;
-          end
-        else
-          begin
-            p.funcretloc[side].loc:=LOC_REFERENCE;
-            p.funcretloc[side].size:=retcgsize;
           end;
       end;
 

compiler/m68k/cpupara.pas

@@ -210,6 +210,13 @@ unit cpupara;
             location_reset(p.funcretloc[side],LOC_VOID,OS_NO);
             exit;
           end;
+        { Return is passed as var parameter }
+        if ret_in_param(p.returndef,p.proccalloption) then
+          begin
+            p.funcretloc[side].loc:=LOC_REFERENCE;
+            p.funcretloc[side].size:=retcgsize;
+            exit;
+          end;
         { Return in FPU register? }
         if not(cs_fp_emulation in current_settings.moduleswitches) and (p.returndef.typ=floatdef) then
           begin
@@ -218,8 +225,7 @@ unit cpupara;
             p.funcretloc[side].size:=retcgsize;
           end
         else
-         { Return in register? }
-         if not ret_in_param(p.returndef,p.proccalloption) then
+         { Return in register }
           begin
             if retcgsize in [OS_64,OS_S64] then
              begin
@@ -245,11 +251,6 @@ unit cpupara;
                else
                  p.funcretloc[side].register:=newreg(R_INTREGISTER,RS_FUNCTION_RETURN_REG,cgsize2subreg(retcgsize));
              end;
-          end
-        else
-          begin
-            p.funcretloc[side].loc:=LOC_REFERENCE;
-            p.funcretloc[side].size:=retcgsize;
           end;
       end;
 

compiler/ncal.pas

@@ -2739,7 +2739,7 @@ implementation
            begin
              tcallparanode(left).det_registers;
 
-             if cs_opt_level1 in current_settings.optimizerswitches then
+             if (current_settings.optimizerswitches*[cs_opt_stackframe,cs_opt_level1]<>[]) then
                begin
                  { check for stacked parameters }
                  check_stack_parameters;

compiler/ncgflw.pas

@@ -1475,7 +1475,19 @@ implementation
                CGMessage(cg_e_control_flow_outside_finally);
              if codegenerror then
                exit;
-             cg.a_call_name(current_asmdata.CurrAsmList,'FPC_RERAISE');
+{$if defined(x86) or defined(arm)}
+             if current_procinfo.procdef.proccalloption=pocall_safecall then
+               begin
+                 { Remove and destroy the last exception object }
+                 cg.a_call_name(current_asmdata.CurrAsmList,'FPC_POPOBJECTSTACK');
+                 cg.a_call_name(current_asmdata.CurrAsmList,'FPC_DESTROYEXCEPTION');
+                 { Set return value of safecall procedure to indicate exception.       }
+                 { Exception will be raised after procedure exit based on return value }
+                 cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_ADDR,aint($8000FFFF),NR_FUNCTION_RETURN_REG);
+               end
+             else
+{$endif}
+               cg.a_call_name(current_asmdata.CurrAsmList,'FPC_RERAISE');
            end
          else
            begin

compiler/powerpc/cpupara.pas

@@ -246,7 +246,13 @@ unit cpupara;
             p.funcretloc[side].loc:=LOC_VOID;
             exit;
           end;
-
+        { Return is passed as var parameter }
+        if ret_in_param(p.returndef,p.proccalloption) then
+          begin
+            p.funcretloc[side].loc:=LOC_REFERENCE;
+            p.funcretloc[side].size:=retcgsize;
+            exit;
+          end;
         { Return in FPU register? }
         if p.returndef.typ=floatdef then
           begin
@@ -255,8 +261,7 @@ unit cpupara;
             p.funcretloc[side].size:=retcgsize;
           end
         else
-         { Return in register? }
-         if not ret_in_param(p.returndef,p.proccalloption) then
+         { Return in register }
           begin
 {$ifndef cpu64bit}
             if retcgsize in [OS_64,OS_S64] then
@@ -283,11 +288,6 @@ unit cpupara;
                else
                  p.funcretloc[side].register:=newreg(R_INTREGISTER,RS_FUNCTION_RETURN_REG,cgsize2subreg(retcgsize));
              end;
-          end
-        else
-          begin
-            p.funcretloc[side].loc:=LOC_REFERENCE;
-            p.funcretloc[side].size:=retcgsize;
           end;
       end;
 

compiler/powerpc64/cpupara.pas

@@ -223,15 +223,21 @@ begin
     p.funcretloc[side].loc := LOC_VOID;
     exit;
   end;
-
+  { Return is passed as var parameter }
+  if ret_in_param(p.returndef, p.proccalloption) then
+    begin
+      p.funcretloc[side].loc := LOC_REFERENCE;
+      p.funcretloc[side].size := retcgsize;
+      exit;
+    end;
   { Return in FPU register? }
   if p.returndef.typ = floatdef then begin
     p.funcretloc[side].loc := LOC_FPUREGISTER;
     p.funcretloc[side].register := NR_FPU_RESULT_REG;
     p.funcretloc[side].size := retcgsize;
   end else
-    { Return in register? } 
-    if not ret_in_param(p.returndef, p.proccalloption) then begin
+    { Return in register }
+    begin
       p.funcretloc[side].loc := LOC_REGISTER;
       p.funcretloc[side].size := retcgsize;
       if side = callerside then
@@ -240,9 +246,6 @@ begin
       else
         p.funcretloc[side].register := newreg(R_INTREGISTER,
           RS_FUNCTION_RETURN_REG, cgsize2subreg(retcgsize));
-    end else begin
-      p.funcretloc[side].loc := LOC_REFERENCE;
-      p.funcretloc[side].size := retcgsize;
     end;
 end;
 

compiler/psub.pas

@@ -741,6 +741,11 @@ implementation
         procdef.parast.SymList.ForEachCall(@check_finalize_paras,nil);
         procdef.localst.SymList.ForEachCall(@check_finalize_locals,nil);
 
+{$if defined(x86) or defined(arm)}
+        { set implicit_finally flag for if procedure is safecall }
+        if procdef.proccalloption=pocall_safecall then
+          include(flags, pi_needs_implicit_finally);
+{$endif}
         { firstpass everything }
         flowcontrol:=[];
         do_firstpass(code);
@@ -984,6 +989,12 @@ implementation
             current_filepos:=entrypos;
             gen_proc_entry_code(templist);
             aktproccode.insertlistafter(headertai,templist);
+{$if defined(x86) or defined(arm)}
+            { Set return value of safecall procedure if implicit try/finally blocks are disabled }
+            if not (cs_implicit_exceptions in current_settings.moduleswitches) and
+               (procdef.proccalloption=pocall_safecall) then
+              cg.a_load_const_reg(aktproccode,OS_ADDR,0,NR_FUNCTION_RETURN_REG);
+{$endif}
             { Add exit code at the end }
             current_filepos:=exitpos;
             gen_proc_exit_code(templist);

compiler/sparc/cpupara.pas

@@ -156,7 +156,13 @@ implementation
             p.funcretloc[side].loc:=LOC_VOID;
             exit;
           end;
-
+        { Return is passed as var parameter }
+        if ret_in_param(p.returndef,p.proccalloption) then
+          begin
+            p.funcretloc[side].loc:=LOC_REFERENCE;
+            p.funcretloc[side].size:=retcgsize;
+            exit;
+          end;
         { Return in FPU register? }
         if p.returndef.typ=floatdef then
           begin
@@ -167,8 +173,7 @@ implementation
             p.funcretloc[side].size:=retcgsize;
           end
         else
-         { Return in register? }
-         if not ret_in_param(p.returndef,p.proccalloption) then
+         { Return in register }
           begin
 {$ifndef cpu64bit}
             if retcgsize in [OS_64,OS_S64] then
@@ -195,11 +200,6 @@ implementation
                else
                  p.funcretloc[side].register:=newreg(R_INTREGISTER,RS_FUNCTION_RETURN_REG,cgsize2subreg(retcgsize));
              end;
-          end
-        else
-          begin
-            p.funcretloc[side].loc:=LOC_REFERENCE;
-            p.funcretloc[side].size:=retcgsize;
           end;
       end;
 

compiler/x86_64/cpupara.pas

@@ -335,6 +335,13 @@ unit cpupara;
             location_reset(p.funcretloc[side],LOC_VOID,OS_NO);
             exit;
           end;
+        { Return is passed as var parameter }
+        if ret_in_param(p.returndef,p.proccalloption) then
+          begin
+            p.funcretloc[side].loc:=LOC_REFERENCE;
+            p.funcretloc[side].size:=retcgsize;
+            exit;
+          end;
         { Return in FPU register? }
         if p.returndef.typ=floatdef then
           begin
@@ -358,8 +365,7 @@ unit cpupara;
             end;
           end
         else
-         { Return in register? }
-         if not ret_in_param(p.returndef,p.proccalloption) then
+         { Return in register }
           begin
             p.funcretloc[side].loc:=LOC_REGISTER;
             p.funcretloc[side].size:=retcgsize;
@@ -367,11 +373,6 @@ unit cpupara;
               p.funcretloc[side].register:=newreg(R_INTREGISTER,RS_FUNCTION_RESULT_REG,cgsize2subreg(retcgsize))
             else
               p.funcretloc[side].register:=newreg(R_INTREGISTER,RS_FUNCTION_RETURN_REG,cgsize2subreg(retcgsize));
-          end
-        else
-          begin
-            p.funcretloc[side].loc:=LOC_REFERENCE;
-            p.funcretloc[side].size:=retcgsize;
           end;
       end;
 

rtl/inc/systemh.inc

@@ -762,7 +762,7 @@ Const
      219, 216, 218, 217,
      202, 220, 221, 222,
      223, 224, 225, 227,
-     0  , 228, 229, 233,
+     212, 228, 229, 233,
      234);
 
 Procedure Error(RunTimeError : TRunTimeError);

rtl/objpas/sysutils/sysutils.inc

@@ -289,6 +289,7 @@ begin
   206 : E:=EOverflow.Create(SUnderflow);
   207 : E:=EInvalidOp.Create(SInvalidOp);
   211 : E:=EAbstractError.Create(SAbstractError);
+  212 : E:=EExternalException.Create(SExternalException);
   214 : E:=EBusError.Create(SBusError);
   215 : E:=EIntOverflow.Create(SIntOverflow);
   216 : E:=EAccessViolation.Create(SAccessViolation);
@@ -302,9 +303,8 @@ begin
   224 : E:=EVariantError.Create(SVarNotArray);
   225 : E:=EVariantError.Create(SVarArrayBounds);
   227 : E:=EAssertionFailed.Create(SAssertionFailed);
-  228 : E:=EExternalException.Create(SExternalException);
-  229 : E:=EIntfCastError.Create(SIntfCastError);
-  230 : E:=ESafecallException.Create(SSafecallException);
+  228 : E:=EIntfCastError.Create(SIntfCastError);
+  229 : E:=ESafecallException.Create(SSafecallException);
   231 : E:=EConvertError.Create(SiconvError);
   232 : E:=ENoThreadSupport.Create(SNoThreadSupport);
   else

tests/webtbs/tw8935.pp

@@ -0,0 +1,34 @@
+{%cpu=x86_64,i386,arm}
+{%result=229}
+
+{$mode objfpc}
+
+procedure DoTest1; safecall;
+var
+  i: integer;
+begin
+  i:=-1;
+  i:=i - 1;
+end;
+
+function DoTest2: longint; safecall;
+begin
+  DoTest2:=$12345678;
+end;
+
+procedure DoTest3; safecall;
+begin
+  PChar(nil)^:='A';
+end;
+
+begin
+  try
+    DoTest1;
+  except
+    ErrorAddr:=nil;
+    Halt(1);
+  end;
+  if DoTest2 <> $12345678 then
+    Halt(2);
+  DoTest3;
+end.

tests/webtbs/tw8977.pp

@@ -0,0 +1,8 @@
+function DoTest: double; safecall;
+begin
+  DoTest:=1.0;
+end;
+
+begin
+  writeln(DoTest);
+end.

tests/webtbs/tw9107.pp

@@ -0,0 +1,18 @@
+{%opt=-OoSTACKFRAME}
+
+procedure Proc;
+var
+  s:shortstring;
+begin
+  s:='test';
+  if Copy(s,1,4)<>'test' then begin
+    writeln('Test failed!');
+    Halt(1);
+  end
+  else
+    writeln('Test OK.');
+end;
+
+begin
+  Proc;
+end.