paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-03 15:50:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* 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.

Browse Source 
git-svn-id: trunk@7720 -
This commit is contained in:
yury 2007-06-18 14:26:08 +00:00
parent 569d7e1138
commit a7d1508959
4 changed files with 41 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -8294,6 +8294,7 @@ 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/tw8950.pp svneol=native#text/plain
tests/webtbs/tw8975.pp svneol=native#text/plain
tests/webtbs/tw8975a.pp svneol=native#text/plain

9
compiler/ncgflw.pas
View File

@ -1477,7 +1477,14 @@ 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
{ 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)
else
{$endif}
cg.a_call_name(current_asmdata.CurrAsmList,'FPC_RERAISE');
end
else
begin

5
compiler/psub.pas
View File

@ -747,6 +747,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);

27
tests/webtbs/tw8935.pp Normal file
View File

@ -0,0 +1,27 @@
{%cpu=x86_64,i386,arm}
{%result=229}
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
DoTest1;
if DoTest2 <> $12345678 then
Halt(1);
DoTest3;
end.