[fpc-devel] Initialising method pointers with class methods

[Blaise at blaise.ru]

DCC allows the subj (provided that the class type is known at compile time), FPC does not.

The attached init_methptr_with_classmeth.patch implements this feature.

-------8<-------
type C = class
	class procedure Foo;
end;
class procedure C.Foo; begin end;
type CC = class of C;
type H = class helper for C end;
type T = procedure of object;

//var aC: C = nil;
//var aCC: CC = nil;
// Still rejected:
//var ViaInstance: T = aC.Foo;
//var ViaClassRef: T = aCC.Foo;

const ViaClass: T = C.Foo;
// NB: This needs metaclass_meth_to_procvar-2.patch
//	from https://lists.freepascal.org/pipermail/fpc-devel/2021-December/044249.html
//	Otherwise: AV in FPC
var ViaMetaclass: T = CC.Foo;
// TODO: Currently, ICE 2021122302 -- needs to be fixed elsewhere.
//	See https://lists.freepascal.org/pipermail/fpc-devel/2021-December/044251.html
//var ViaHelper: T = H.Foo;

procedure Report(const s: string; const X: T);
var Status: Boolean;
begin
	Status := (TMethod(X).Code = @C.Foo) and (TMethod(X).Data = Pointer(C));
	writeln(s, ': ', Status)
end;

begin
	Report('via class', ViaClass);
	Report('via metaclass', ViaMetaclass)
end.
-------8<-------

Proposed new error message for parser_e_no_procvarobj_const:
Cannot initialize a method pointer: Self pointer is not known at compile time
	In order to initialize a method pointer with a method, the value of the Self pointer for calling that method at run time must be known at compile time. Thus, a method pointer can be initialized either with NIL, or with a class method that is accessed via a class type or a class reference type.

-- 
βþ
-------------- next part --------------
# HG changeset patch
# User Blaise.ru
# Date 1640264248 -10800
#      Thu Dec 23 15:57:28 2021 +0300
+ allow initialisation of method pointers with class methods (when class types are known at compile time)

diff -r d8747975e106 -r e77bf4543d51 ngtcon.pas
--- a/ngtcon.pas	Wed Dec 22 08:12:51 2021 +0300
+++ b/ngtcon.pas	Thu Dec 23 15:57:28 2021 +0300
@@ -1455,6 +1455,8 @@
         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 }
@@ -1469,12 +1471,6 @@
              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]);
@@ -1540,10 +1536,35 @@
               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;
+                { TODO: Happens for helpers. Needs to be fixed elsewhere.
+                  See https://lists.freepascal.org/pipermail/fpc-devel/2021-December/044251.html }
+                if selfnode = nil then
+                  internalerror(2021122302);
+                { class type must be known at compile time }
+                if (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