From 2bc8afaa632d9d84ebef9e60ed02d8d25a47f4a7 Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Fri, 18 Jul 2014 09:15:35 +0000 Subject: [PATCH] + support for calling a method via a block: we capture the method as a procvar in the local state of the block, and then call it insde the generated invoke routine. We can't call it directly there, because due to visibility reasons it may not be accessible from a regular procedure (e.g. if it is a strict private method) git-svn-id: branches/blocks@28234 - --- .gitattributes | 2 ++ compiler/blockutl.pas | 60 +++++++++++++++++++++++++++++++++++++----- compiler/defcmp.pas | 24 +++++++++++------ compiler/ncnv.pas | 3 +-- compiler/symcreat.pas | 16 +++++++++++ tests/test/tblock2.pp | 51 +++++++++++++++++++++++++++++++++++ tests/test/tblock2a.pp | 51 +++++++++++++++++++++++++++++++++++ 7 files changed, 190 insertions(+), 17 deletions(-) create mode 100644 tests/test/tblock2.pp create mode 100644 tests/test/tblock2a.pp diff --git a/.gitattributes b/.gitattributes index 6724e38968..88bf200fdf 100644 --- a/.gitattributes +++ b/.gitattributes @@ -11118,6 +11118,8 @@ tests/test/tassignmentoperator1.pp svneol=native#text/pascal tests/test/tblock1.pp svneol=native#text/plain tests/test/tblock1a.pp svneol=native#text/plain tests/test/tblock1c.pp svneol=native#text/plain +tests/test/tblock2.pp svneol=native#text/plain +tests/test/tblock2a.pp svneol=native#text/plain tests/test/tbopr.pp svneol=native#text/plain tests/test/tbrtlevt.pp svneol=native#text/plain tests/test/tbsx1.pp svneol=native#text/plain diff --git a/compiler/blockutl.pas b/compiler/blockutl.pas index 1375b39084..40b11beba2 100644 --- a/compiler/blockutl.pas +++ b/compiler/blockutl.pas @@ -28,7 +28,7 @@ unit blockutl; interface uses - node,nld, + node,nld,ncnv, symtype,symdef; { accepts a loadnode for a procdef @@ -48,10 +48,10 @@ interface implementation uses - verbose,globtype,cutils, + verbose,globtype,globals,cutils,constexp, pass_1,pparautl,fmodule, aasmdata, - ncnv,nmem, + nbas,ncon,nmem,nutils, symbase,symconst,symtable,symsym,symcreat,objcutil,objcdef,defutil, paramgr; @@ -225,7 +225,10 @@ implementation end else begin - internalerror(2014071609); + { alias for the type to invoke the procvar, used in the symcreat + handling of tsk_block_invoke_procvar } + result.localst.insert(ctypesym.create('__FPC_BLOCK_INVOKE_PV_TYPE',orgpv)); + result.synthetickind:=tsk_block_invoke_procvar; end; end; @@ -265,6 +268,51 @@ implementation end; + { compose an on-stack block literal for a "procedure of object" } + function get_pascal_method_literal(blockliteraldef: tdef; blockisasym: tstaticvarsym; blockflags: longint; procvarnode: tnode; invokepd: tprocdef; orgpv: tprocvardef; descriptor: tstaticvarsym): tnode; + var + statement: tstatementnode; + literaltemp: ttempcreatenode; + begin + result:=internalstatements(statement); + { create new block literal structure } + literaltemp:=ctempcreatenode.create(blockliteraldef,blockliteraldef.size,tt_persistent,false); + addstatement(statement,literaltemp); + { temp.base.isa:=@blockisasym } + addstatement(statement,cassignmentnode.create( + genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'ISA'), + caddrnode.create(cloadnode.create(blockisasym,blockisasym.owner)))); + { temp.base.flags:=blockflags } + addstatement(statement,cassignmentnode.create( + genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'FLAGS'), + genintconstnode(blockflags))); + { temp.base.reserved:=0 } + addstatement(statement,cassignmentnode.create( + genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'RESERVED'), + genintconstnode(0))); + { temp.base.invoke:=tmethod(@invokepd) } + addstatement(statement,cassignmentnode.create( + genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'INVOKE'), + ctypeconvnode.create_proc_to_procvar( + cloadnode.create_procvar(invokepd.procsym,invokepd,invokepd.owner)))); + { temp.base.descriptor:=@descriptor } + addstatement(statement,cassignmentnode.create( + genloadfield(genloadfield(ctemprefnode.create(literaltemp),'BASE'),'DESCRIPTOR'), + caddrnode.create(cloadnode.create(descriptor,descriptor.owner)))); + { temp.pv:=tmethod(@orgpd) } + addstatement(statement,cassignmentnode.create( + ctypeconvnode.create_explicit(genloadfield(ctemprefnode.create(literaltemp),'PV'),orgpv), + procvarnode.getcopy)); + { and return the address of the temp } + addstatement(statement,caddrnode.create(ctemprefnode.create(literaltemp))); + { typecheck this now, because the current source may be written in TP/ + Delphi/MacPas mode and the above node tree has been constructed for + ObjFPC mode, which has been set by replace_scanner (in Delphi, the + assignment to invoke would be without the proc_to_procvar conversion) } + typecheckpass(result); + end; + + function generate_block_for_procaddr(procloadnode: tloadnode): tnode; var procvarnode: tnode; @@ -321,9 +369,7 @@ implementation end else begin - { local variable that gets initialised: create temp, initialise it, - return address of temp } - internalerror(2014071502); + result:=get_pascal_method_literal(blockliteraldef,blockisasym,blockflags,procvarnode,invokepd,orgpv,descriptor) end; procvarnode.free; diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 774ab72011..db77103798 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -2180,30 +2180,38 @@ implementation if not(assigned(def1)) or not(assigned(def2)) then exit; { check for method pointer and local procedure pointer: - a) if one is a procedure of object, the other also has to be one - b) if one is a pure address, the other also has to be one + a) anything but procvars can be assigned to blocks + b) if one is a procedure of object, the other also has to be one + (except for block) + c) if one is a pure address, the other also has to be one except if def1 is a global proc and def2 is a nested procdef (global procedures can be converted into nested procvars) - c) if def1 is a nested procedure, then def2 has to be a nested + d) if def1 is a nested procedure, then def2 has to be a nested procvar and def1 has to have the po_delphi_nested_cc option - d) if def1 is a procvar, def1 and def2 both have to be nested or + e) if def1 is a procvar, def1 and def2 both have to be nested or non-nested (we don't allow assignments from non-nested to nested procvars to make sure that we can still implement nested procvars using trampolines -- e.g., this would be necessary for LLVM or CIL as long as they do not have support for Delphi-style frame pointer parameter passing) } - if (def1.is_methodpointer<>def2.is_methodpointer) or { a) } - ((def1.is_addressonly<>def2.is_addressonly) and { b) } + if is_block(def2) then { a) } + { can't explicitly check against procvars here, because + def1 may already be a procvar due to a proc_to_procvar; + this is checked in the type conversion node itself -> ok } + else if (def1.is_methodpointer<>def2.is_methodpointer) or { b) } + ((def1.is_addressonly<>def2.is_addressonly) and { c) } (is_nested_pd(def1) or not is_nested_pd(def2))) or - ((def1.typ=procdef) and { c) } + ((def1.typ=procdef) and { d) } is_nested_pd(def1) and (not(po_delphi_nested_cc in def1.procoptions) or not is_nested_pd(def2))) or - ((def1.typ=procvardef) and { d) } + ((def1.typ=procvardef) and { e) } (is_nested_pd(def1)<>is_nested_pd(def2))) then exit; pa_comp:=[cpo_ignoreframepointer]; + if is_block(def2) then + include(pa_comp,cpo_ignorehidden); if checkincompatibleuniv then include(pa_comp,cpo_warn_incompatible_univ); { check return value and options, methodpointer is already checked } diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index a06a165b84..50c9d7786a 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -2015,8 +2015,7 @@ implementation while (source^.nodetype=typeconvn) and (ttypeconvnode(source^).convtype=tc_proc_2_procvar) and (is_void(source^.resultdef) or - ((source^.resultdef.typ=procvardef) and - tprocvardef(source^.resultdef).is_addressonly)) do + (source^.resultdef.typ=procvardef)) do begin { won't skip proc2procvar } source:=actualtargetnode(@ttypeconvnode(source^).left); diff --git a/compiler/symcreat.pas b/compiler/symcreat.pas index b4128e89a9..c4cbf70031 100644 --- a/compiler/symcreat.pas +++ b/compiler/symcreat.pas @@ -916,6 +916,20 @@ implementation end; + procedure implement_block_invoke_procvar(pd: tprocdef); + var + str: ansistring; + begin + str:=''; + str:='begin '; + if pd.returndef<>voidtype then + str:=str+'result:='; + str:=str+'__FPC_BLOCK_INVOKE_PV_TYPE(PFPC_Block_literal_complex_procvar(FPC_Block_Self)^.pv)('; + addvisibibleparameters(str,pd); + str:=str+') end;'; + str_parse_method_impl(str,pd,false); + end; + procedure add_synthetic_method_implementations_for_st(st: tsymtable); var i : longint; @@ -986,6 +1000,8 @@ implementation implement_field_getter(pd); tsk_field_setter: implement_field_setter(pd); + tsk_block_invoke_procvar: + implement_block_invoke_procvar(pd); else internalerror(2011032801); end; diff --git a/tests/test/tblock2.pp b/tests/test/tblock2.pp new file mode 100644 index 0000000000..5686c076e3 --- /dev/null +++ b/tests/test/tblock2.pp @@ -0,0 +1,51 @@ +{ %target=darwin,iphonesim} + +{$mode objfpc} +{$modeswitch blocks} + +type + tblock = reference to procedure(j: longint); cdecl; + + tc = class + i: longint; + procedure callme(j: longint); + end; + +var + b: tblock; + c: tc; + +procedure tc.callme(j: longint); +const + invocationcount: longint = 0; +begin + writeln('self: ',hexstr(pointer(self)),', i: ',i,', j: ',j); + if self<>c then + halt(1); + if i<>12345 then + halt(2); + if invocationcount=0 then + begin + if j<>1 then + halt(3) + end + else if j<>2 then + halt(4); + inc(invocationcount); +end; + + +procedure test(b: tblock); + begin + b(2); + end; + +begin + c:=tc.create; + c.i:=12345; + b:=@c.callme; + b(1); + test(@c.callme); + test(b); +end. + diff --git a/tests/test/tblock2a.pp b/tests/test/tblock2a.pp new file mode 100644 index 0000000000..3c3c5293ec --- /dev/null +++ b/tests/test/tblock2a.pp @@ -0,0 +1,51 @@ +{ %target=darwin,iphonesim} + +{$mode delphi} +{$modeswitch blocks} + +type + tblock = reference to procedure(j: longint); cdecl; + + tc = class + i: longint; + procedure callme(j: longint); + end; + +var + b: tblock; + p: procedure(j: longint) of object; + c: tc; + +procedure tc.callme(j: longint); +const + invocationcount: longint = 0; +begin + writeln('self: ',hexstr(pointer(self)),', i: ',i,', j: ',j); + if self<>c then + halt(1); + if i<>12345 then + halt(2); + if invocationcount=0 then + begin + if j<>1 then + halt(3) + end + else if j<>2 then + halt(4); + inc(invocationcount); +end; + +procedure test(b: tblock); + begin + b(2); + end; + +begin + c:=tc.create; + c.i:=12345; + b:=c.callme; + b(1); + test(c.callme); + test(b); +end. +