paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 07:06:08 +02:00
Code Issues Packages Projects Releases Wiki Activity

compiler,rtl - safecall handling:

Browse Source 
- 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 -
This commit is contained in:
paul 2010-02-27 04:41:52 +00:00
parent a0ad752e16
commit fcaac0ebe1
4 changed files with 51 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
compiler/psub.pas
View File

@ -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;

1
rtl/inc/compproc.inc
View File

@ -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}

10
rtl/inc/except.inc
View File

@ -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;
{

10
tests/test/tsafecall1.pp
View File

@ -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.
end.