* support asssigning @class.classmethod to a procvar of object in FPC modes

    (mantis #14103)

git-svn-id: trunk@37925 -

.gitattributes

@@ -14837,6 +14837,7 @@ tests/webtbs/tw1407.pp svneol=native#text/plain
 tests/webtbs/tw1408.pp svneol=native#text/plain
 tests/webtbs/tw1409.pp svneol=native#text/plain
 tests/webtbs/tw14092.pp svneol=native#text/pascal
+tests/webtbs/tw14103.pp svneol=native#text/plain
 tests/webtbs/tw1412.pp svneol=native#text/plain
 tests/webtbs/tw14124.pp svneol=native#text/plain
 tests/webtbs/tw14134.pp svneol=native#text/plain

compiler/ncnv.pas

@@ -865,6 +865,39 @@ implementation
           end;
       end;
 
+
+    { similar as above, but for assigning @classtype.method to a
+      procvar of object. pexpr.do_proc_call() stores the symtable of classtype
+      in the loadnode so we can retrieve it here (rather than the symtable in
+      which method was found, which may be a parent class) }
+    function maybe_classmethod_to_methodprocvar(var fromnode: tnode; todef: tdef): boolean;
+      var
+        hp: tnode;
+      begin
+        result:=false;
+        if not(m_tp_procvar in current_settings.modeswitches) and
+           (todef.typ=procvardef) and
+           is_methodpointer(tprocvardef(todef)) and
+           (fromnode.nodetype=typeconvn) and
+           (ttypeconvnode(fromnode).convtype=tc_proc_2_procvar) and
+           is_methodpointer(fromnode.resultdef) and
+           (po_classmethod in tprocvardef(fromnode.resultdef).procoptions) and
+           not(po_staticmethod in tprocvardef(fromnode.resultdef).procoptions) and
+           (proc_to_procvar_equal(tprocdef(ttypeconvnode(fromnode).left.resultdef),tprocvardef(todef),false)>=te_convert_l1) then
+          begin
+            hp:=fromnode;
+            fromnode:=ttypeconvnode(fromnode).left;
+            if (fromnode.nodetype=loadn) and
+               not assigned(tloadnode(fromnode).left) then
+              tloadnode(fromnode).set_mp(cloadvmtaddrnode.create(ctypenode.create(tdef(tloadnode(fromnode).symtable.defowner))));
+            fromnode:=ctypeconvnode.create_proc_to_procvar(fromnode);
+            typecheckpass(fromnode);
+            ttypeconvnode(hp).left:=nil;
+            hp.free;
+            result:=true;
+          end;
+      end;
+
 {*****************************************************************************
                            TTYPECONVNODE
 *****************************************************************************}
@@ -2481,7 +2514,8 @@ implementation
                        result:=typecheck_call_helper(convtype);
                      exit;
                    end
-                  else if maybe_global_proc_to_nested(left,resultdef) then
+                  else if maybe_global_proc_to_nested(left,resultdef) or
+                          maybe_classmethod_to_methodprocvar(left,resultdef) then
                     begin
                       result:=left;
                       left:=nil;

compiler/pexpr.pas

@@ -1042,7 +1042,15 @@ implementation
                 if (p1.nodetype<>typen) then
                   tloadnode(p2).set_mp(p1)
                 else
-                  p1.free;
+                  begin
+                    typecheckpass(p1);
+                    if (p1.resultdef.typ=objectdef) then
+                      { so we can create the correct  method pointer again in case
+                        this is a "objectprocvar:[email protected]" expression }
+                      tloadnode(p2).symtable:=tobjectdef(p1.resultdef).symtable
+                    else
+                      p1.free;
+                  end;
               end;
              p1:=p2;
 

tests/webtbs/tw14103.pp

@@ -0,0 +1,54 @@
+program test;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes, SysUtils;
+
+type
+  TCallback = procedure of object;
+
+  { TTestObject }
+
+  TTestObject = class (TObject)
+  public
+    class procedure Test;
+  end;
+  TTestClass = class of TTestObject;
+
+  TTestObject2 = class(TTestObject)
+  end;
+
+{ TTestObject }
+
+var
+  global: boolean;
+  compareclass: TTestClass;
+
+class procedure TTestObject.Test;
+begin
+  global:=true;
+  if self <> compareclass then
+    halt(2);
+end;
+
+var
+  Cls: TTestClass;
+  Callback: TCallback;
+begin
+  // Doesn't work
+  global:=false;
+  Callback := @TTestObject.Test;
+  compareclass:=TTestObject;
+  Callback();
+  if not global then
+    halt(1);
+
+  global:=false;
+  Callback := @TTestObject2.Test;
+  compareclass:=TTestObject2;
+  Callback();
+  if not global then
+    halt(1);
+end.
+