From 17a08efb826c35c49c7259be5ff0af8451afecaf Mon Sep 17 00:00:00 2001
From: florian <florian@freepascal.org>
Date: Sat, 15 Nov 2008 23:05:36 +0000
Subject: [PATCH] * handle methodpointer function results like records of the
 same size, resolves #12318

git-svn-id: trunk@12118 -
---
 .gitattributes              |  1 +
 compiler/x86_64/cpupara.pas | 13 +++++++++-
 tests/webtbs/tw12318.pp     | 47 +++++++++++++++++++++++++++++++++++++
 3 files changed, 60 insertions(+), 1 deletion(-)
 create mode 100644 tests/webtbs/tw12318.pp

diff --git a/.gitattributes b/.gitattributes
index 3dc5676d55..39a7657443 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -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
diff --git a/compiler/x86_64/cpupara.pas b/compiler/x86_64/cpupara.pas
index 0baca9ba2e..6f80edf54a 100644
--- a/compiler/x86_64/cpupara.pas
+++ b/compiler/x86_64/cpupara.pas
@@ -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;
diff --git a/tests/webtbs/tw12318.pp b/tests/webtbs/tw12318.pp
new file mode 100644
index 0000000000..c9b92c778f
--- /dev/null
+++ b/tests/webtbs/tw12318.pp
@@ -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.