diff --git a/.gitattributes b/.gitattributes index 2cb25d73f3..e2fc0c1e22 100644 --- a/.gitattributes +++ b/.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 diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 8eb2246778..0d2bf3755f 100644 --- a/compiler/ncnv.pas +++ b/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; diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 6d972de694..3938a66037 100644 --- a/compiler/pexpr.pas +++ b/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:=@classname.method" expression } + tloadnode(p2).symtable:=tobjectdef(p1.resultdef).symtable + else + p1.free; + end; end; p1:=p2; diff --git a/tests/webtbs/tw14103.pp b/tests/webtbs/tw14103.pp new file mode 100644 index 0000000000..8b9d07ce60 --- /dev/null +++ b/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. +