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

git-svn-id: trunk@12118 -

.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

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;

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.