+ apply patch by Blaise.ru: allow initialisation of method pointers with class methods (when class types are

known at compile time)
* adjust error message when a method pointer isn't suitable
+ add tests

compiler/msg/errore.msg

@@ -1027,11 +1027,11 @@ parser_e_illegal_field_or_method=03181_E_Unknown class field or method identifie
 parser_w_proc_overriding_calling=03182_W_Overriding calling convention "$1" with "$2"
 % There are two directives in the procedure declaration that specify a calling
 % convention. Only the last directive will be used.
-parser_e_no_procvarobj_const=03183_E_Typed constants of the type "procedure of object" can only be initialized with NIL
-% You cannot assign the address of a method to a typed constant which has a
-% 'procedure of object' type, because such a constant requires two addresses:
-% that of the method (which is known at compile time) and that of the object or
-% class instance it operates on (which cannot be known at compile time).
+parser_e_no_procvarobj_const=03183_E_Typed constants of the type "procedure of object" need a Self pointer that's known at compile time
+% In order to initialize a method pointer with a method, the value of the \var{Self}
+% pointer for calling that method at run time must be known at compile time.
+% Thus, a method pointer can be initialized either with \var{Nil}, or with a class
+% method that is accessed via a class type or a class reference type.
 parser_e_default_value_only_one_para=03184_E_Default value can only be assigned to one parameter
 % It is not possible to specify a default value for several parameters at once.
 % The following is invalid:

compiler/ngtcon.pas

@@ -1464,6 +1464,8 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
         procaddrdef: tprocvardef;
         havepd,
         haveblock: boolean;
+        selfnode: tnode;
+        selfdef: tdef;
       begin
         { Procvars and pointers are no longer compatible.  }
         { under tp:  =nil or =var under fpc: =nil or =@var }
@@ -1478,12 +1480,6 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
              ftcb.maybe_end_aggregate(def);
              exit;
           end;
-        { you can't assign a value other than NIL to a typed constant  }
-        { which is a "procedure of object", because this also requires }
-        { address of an object/class instance, which is not known at   }
-        { compile time (JM)                                            }
-        if (po_methodpointer in def.procoptions) then
-          Message(parser_e_no_procvarobj_const);
         { parse the rest too, so we can continue with error checking }
         getprocvardef:=def;
         n:=comp_expr([ef_accept_equal]);
@@ -1549,10 +1545,31 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
               begin
                 ftcb.queue_emit_staticvar(tstaticvarsym(tloadnode(n).symtableentry));
               end;
+            { the Data field of a method pointer can be initialised
+              either with NIL (handled above) or with a class type }
+            if po_methodpointer in def.procoptions then
+              begin
+                selfnode:=tloadnode(n).left;
+                { class type must be known at compile time }
+                if assigned(selfnode) and
+                    (selfnode.nodetype=loadvmtaddrn) and
+                    (tloadvmtaddrnode(selfnode).left.nodetype=typen) then
+                  begin
+                    selfdef:=selfnode.resultdef;
+                    if selfdef.typ<>classrefdef then
+                      internalerror(2021122301);
+                    selfdef:=tclassrefdef(selfdef).pointeddef;
+                    ftcb.emit_tai(Tai_const.Create_sym(
+                      current_asmdata.RefAsmSymbol(tobjectdef(selfdef).vmt_mangledname,AT_DATA)),
+                      def);
+                  end
+                else
+                  Message(parser_e_no_procvarobj_const);
+              end
             { nested procvar typed consts can only be initialised with nil
               (checked above) or with a global procedure (checked here),
               because in other cases we need a valid frame pointer }
-            if is_nested_pd(def) then
+            else if is_nested_pd(def) then
               begin
                 if haveblock or
                    is_nested_pd(pd) then

tests/test/tprocvar17.pp

@@ -0,0 +1,33 @@
+program tprocvar17;
+
+{$mode delphi}
+
+type C = class
+    class procedure Foo;
+end;
+class procedure C.Foo; begin end;
+type CC = class of C;
+type H = class helper for C
+    class procedure Bar;
+end;
+class procedure H.Bar; begin end;
+type T = procedure of object;
+type P = procedure;
+
+const ViaClass: T = C.Foo;
+var ViaMetaclass: T = CC.Foo;
+var ViaHelperClass: T = C.Bar;
+var ViaHelperMetaClass: T = CC.Bar;
+
+procedure Check(aCode: TExitCode; const X: T; aAddr: CodePointer);
+begin
+    if (TMethod(X).Code <> aAddr) or (TMethod(X).Data <> Pointer(C)) then
+      Halt(aCode);
+end;
+
+begin
+    Check(1, ViaClass, @C.Foo);
+    Check(2, ViaMetaclass, @C.Foo);
+    Check(3, ViaHelperClass, @C.Bar);
+    Check(4, ViaHelperMetaclass, @C.Bar);
+end.

tests/test/tprocvar18.pp

@@ -0,0 +1,18 @@
+{ %FAIL }
+
+program tprocvar18;
+
+{$mode delphi}
+
+type C = class
+    procedure Foo;
+end;
+procedure C.Foo; begin end;
+type T = procedure of object;
+
+var aC: C = nil;
+// Still rejected:
+var ViaInstance: T = aC.Foo;
+
+begin
+end.

tests/test/tprocvar19.pp

@@ -0,0 +1,19 @@
+{ %FAIL }
+
+program tprocvar19;
+
+{$mode delphi}
+
+type C = class
+    class procedure Foo;
+end;
+class procedure C.Foo; begin end;
+type CC = class of C;
+type T = procedure of object;
+
+var aCC: CC = nil;
+// Still rejected:
+var ViaClassRef: T = aCC.Foo;
+
+begin
+end.

tests/test/tprocvar20.pp

@@ -0,0 +1,19 @@
+{ %FAIL }
+
+program tprocvar20;
+
+{$mode delphi}
+
+type C = class
+end;
+type CC = class of C;
+type H = class helper for C
+  class procedure Foo;
+end;
+class procedure H.Foo; begin end;
+type T = procedure of object;
+
+var ViaHelper: T = H.Foo;
+
+begin
+end.