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

* handle methodpointer function results like records of the same size, resolves #12318

Browse Source 
git-svn-id: trunk@12118 -
This commit is contained in:
florian 2008-11-15 23:05:36 +00:00
parent ea29eb439f
commit 17a08efb82
3 changed files with 60 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -8615,6 +8615,7 @@ tests/webtbs/tw12242.pp svneol=native#text/plain
tests/webtbs/tw12249.pp svneol=native#text/plain
tests/webtbs/tw1228.pp svneol=native#text/plain
tests/webtbs/tw1229.pp svneol=native#text/plain
tests/webtbs/tw12318.pp svneol=native#text/plain
tests/webtbs/tw12385.pp svneol=native#text/plain
tests/webtbs/tw12404.pp svneol=native#text/plain
tests/webtbs/tw1250.pp svneol=native#text/plain

13
compiler/x86_64/cpupara.pas
View File

@ -202,8 +202,13 @@ unit cpupara;
result:=(calloption=pocall_safecall) or
(def.size>8) or not(def.size in [1,2,4,8])
else
{ return method pointers in LOC_REGISTER like records of the same size;
this is SysV only }
if (def.typ=procvardef) and
(po_methodpointer in tprocvardef(def).procoptions) then
result:=false
{ handle objectdefs by the default code because they have no equivalence in C }
if (def.typ in [recorddef {,arraydef }]) and (def.size<=16) then
else if (def.typ in [recorddef {,arraydef }]) and (def.size<=16) then
begin
case def.typ of
recorddef:
@ -457,6 +462,12 @@ unit cpupara;
end;
end;
end
else if retcgsize in [OS_128,OS_S128] then
begin
p.funcretloc[side].size:=retcgsize;
p.funcretloc[side].register:=newreg(R_INTREGISTER,RS_FUNCTION_RESULT_REG,R_SUBWHOLE);
p.funcretloc[side].registerhi:=newreg(R_INTREGISTER,RS_RDX,R_SUBWHOLE);
end
else
begin
p.funcretloc[side].size:=retcgsize;

47
tests/webtbs/tw12318.pp Normal file
View File

@ -0,0 +1,47 @@
program WebmoduleCrash;
{$mode objfpc}
uses
Classes, SysUtils;
type
TGetActionEvent = Procedure (Sender : TObject) of object;
TGetMethodProc=function(): TMethod of object;
type
{ TTestObject }
TTestObject = class(TObject)
function GetOnGetAction: TGetActionEvent;
procedure DataModuleGetAction(Sender: TObject);
end;
function TTestObject.GetOnGetAction: TGetActionEvent;
begin
Result := @DataModuleGetAction;
end;
procedure TTestObject.DataModuleGetAction(Sender: TObject);
begin
writeln('is');
end;
var AMethod : TMethod;
ATestObject : TTestObject;
begin
ATestObject := TTestObject.create;
// uncomment the next line and the exception wil occur on the line after the 'this' writeln,
// else the crash will occur in TTestObject.GetOnGetAction
ATestObject.GetOnGetAction;
AMethod := TGetMethodProc(@ATestObject.GetOnGetAction)();
WriteLn('this');
TGetActionEvent(AMethod)(nil);
WriteLn('a test');
ATestObject.Free;
end.