mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 10:07:54 +02:00
* implement assignment of procedure and method variables and routines (global, instance and nested) to function references
This commit is contained in:
Sven/Sarah Barth
parent
9f3dcdb211
commit
7974f39522
@ -109,7 +109,8 @@ interface
|
||||
tc_elem_2_openarray,
|
||||
tc_arrayconstructor_2_dynarray,
|
||||
tc_arrayconstructor_2_array,
|
||||
tc_anonproc_2_funcref
|
||||
tc_anonproc_2_funcref,
|
||||
tc_procvar_2_funcref
|
||||
);
|
||||
|
||||
function compare_defs_ext(def_from,def_to : tdef;
|
||||
@ -1956,6 +1957,19 @@ implementation
|
||||
eq:=te_convert_l1;
|
||||
doconv:=tc_equal;
|
||||
end
|
||||
else if is_funcref(def_to) and
|
||||
(def_from.typ in [procdef,procvardef]) then
|
||||
begin
|
||||
subeq:=proc_to_funcref_conv(tabstractprocdef(def_from),tobjectdef(def_to));
|
||||
if subeq>te_incompatible then
|
||||
begin
|
||||
doconv:=tc_procvar_2_funcref;
|
||||
if subeq>te_convert_l5 then
|
||||
eq:=pred(subeq)
|
||||
else
|
||||
eq:=subeq;
|
||||
end;
|
||||
end
|
||||
else if (def_from.typ=variantdef) and is_interfacecom_or_dispinterface(def_to) then
|
||||
begin
|
||||
{ corbainterfaces not accepted, until we have
|
||||
@ -2534,37 +2548,45 @@ implementation
|
||||
a) anything but procvars can be assigned to blocks
|
||||
b) depending on their captured symbols anonymous functions can be
|
||||
assigned to global, method or nested procvars
|
||||
c) if one is a procedure of object, the other also has to be one
|
||||
c) anything can be assigned to function references
|
||||
d) if one is a procedure of object, the other also has to be one
|
||||
("object static procedure" is equal to procedure as well)
|
||||
(except for block)
|
||||
d) if one is a pure address, the other also has to be one
|
||||
e) 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)
|
||||
e) if def1 is a nested procedure, then def2 has to be a nested
|
||||
f) 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
|
||||
or does not use parentfp
|
||||
f) if def1 is a procvar, def1 and def2 both have to be nested or
|
||||
g) 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 is_block(def2) or { a) }
|
||||
(po_anonymous in def1.procoptions) then { b) }
|
||||
(po_anonymous in def1.procoptions) or { b) }
|
||||
(
|
||||
(po_is_function_ref in def2.procoptions) and
|
||||
(
|
||||
(def1.typ<>procdef) or
|
||||
not (po_delphi_nested_cc in def1.procoptions)
|
||||
) { c) }
|
||||
) then
|
||||
{ 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 and not (po_staticmethod in def1.procoptions))<> { c) }
|
||||
((def1.is_methodpointer and not (po_staticmethod in def1.procoptions))<> { d) }
|
||||
(def2.is_methodpointer and not (po_staticmethod in def2.procoptions))) or
|
||||
((def1.is_addressonly<>def2.is_addressonly) and { d) }
|
||||
((def1.is_addressonly<>def2.is_addressonly) and { e) }
|
||||
(is_nested_pd(def1) or
|
||||
not is_nested_pd(def2))) or
|
||||
((def1.typ=procdef) and { e) }
|
||||
((def1.typ=procdef) and { f) }
|
||||
is_nested_pd(def1) and
|
||||
(not(po_delphi_nested_cc in def1.procoptions) or
|
||||
not is_nested_pd(def2))) or
|
||||
((def1.typ=procvardef) and { f) }
|
||||
((def1.typ=procvardef) and { g) }
|
||||
(is_nested_pd(def1)<>is_nested_pd(def2))) then
|
||||
exit;
|
||||
pa_comp:=[cpo_ignoreframepointer];
|
||||
|
||||
@ -2134,6 +2134,18 @@ implementation
|
||||
if tmpeq<>te_incompatible then
|
||||
eq:=tmpeq;
|
||||
end;
|
||||
objectdef :
|
||||
begin
|
||||
tmpeq:=te_incompatible;
|
||||
{ in tp/macpas mode proc -> funcref is allowed }
|
||||
if ((m_tp_procvar in current_settings.modeswitches) or
|
||||
(m_mac_procvar in current_settings.modeswitches)) and
|
||||
(p.left.nodetype=calln) and
|
||||
is_invokable(def_to) then
|
||||
tmpeq:=proc_to_funcref_equal(tprocdef(tcallnode(p.left).procdefinition),tobjectdef(def_to));
|
||||
if tmpeq<>te_incompatible then
|
||||
eq:=tmpeq;
|
||||
end;
|
||||
arraydef :
|
||||
begin
|
||||
{ an arrayconstructor of proccalls may have to be converted to
|
||||
|
||||
@ -121,6 +121,7 @@ interface
|
||||
function typecheck_arrayconstructor_to_dynarray : tnode; virtual;
|
||||
function typecheck_arrayconstructor_to_array : tnode; virtual;
|
||||
function typecheck_anonproc_2_funcref : tnode; virtual;
|
||||
function typecheck_procvar_2_funcref : tnode; virtual;
|
||||
private
|
||||
function _typecheck_int_to_int : tnode;
|
||||
function _typecheck_cord_to_pointer : tnode;
|
||||
@ -155,6 +156,7 @@ interface
|
||||
function _typecheck_arrayconstructor_to_dynarray : tnode;
|
||||
function _typecheck_arrayconstructor_to_array : tnode;
|
||||
function _typecheck_anonproc_to_funcref : tnode;
|
||||
function _typecheck_procvar_to_funcref : tnode;
|
||||
protected
|
||||
function first_int_to_int : tnode;virtual;
|
||||
function first_cstring_to_pchar : tnode;virtual;
|
||||
@ -2346,6 +2348,12 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
function ttypeconvnode._typecheck_procvar_to_funcref : tnode;
|
||||
begin
|
||||
result:=typecheck_procvar_2_funcref;
|
||||
end;
|
||||
|
||||
|
||||
function ttypeconvnode._typecheck_anonproc_to_funcref : tnode;
|
||||
begin
|
||||
result:=typecheck_anonproc_2_funcref;
|
||||
@ -2647,6 +2655,62 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
function ttypeconvnode.typecheck_procvar_2_funcref : tnode;
|
||||
var
|
||||
capturer : tsym;
|
||||
intfdef : tdef;
|
||||
ld,blck,hp : tnode;
|
||||
stmt : tstatementnode;
|
||||
begin
|
||||
result:=nil;
|
||||
|
||||
if not(m_tp_procvar in current_settings.modeswitches) and
|
||||
is_invokable(resultdef) and
|
||||
(left.nodetype=typeconvn) and
|
||||
(ttypeconvnode(left).convtype=tc_proc_2_procvar) and
|
||||
is_methodpointer(left.resultdef) and
|
||||
(po_classmethod in tprocvardef(left.resultdef).procoptions) and
|
||||
not(po_staticmethod in tprocvardef(left.resultdef).procoptions) and
|
||||
(proc_to_funcref_equal(tprocdef(ttypeconvnode(left).left.resultdef),tobjectdef(resultdef))>=te_convert_l1) then
|
||||
begin
|
||||
hp:=left;
|
||||
left:=ttypeconvnode(left).left;
|
||||
if (left.nodetype=loadn) and
|
||||
not assigned(tloadnode(left).left) then
|
||||
tloadnode(left).set_mp(cloadvmtaddrnode.create(ctypenode.create(tdef(tloadnode(left).symtable.defowner))));
|
||||
left:=ctypeconvnode.create_proc_to_procvar(left);
|
||||
ttypeconvnode(left).totypedef:=resultdef;
|
||||
typecheckpass(left);
|
||||
ttypeconvnode(hp).left:=nil;
|
||||
hp.free;
|
||||
end;
|
||||
|
||||
intfdef:=capturer_add_procvar_or_proc(current_procinfo,left,capturer,hp);
|
||||
if assigned(intfdef) then
|
||||
begin
|
||||
if assigned(capturer) then
|
||||
ld:=cloadnode.create(capturer,capturer.owner)
|
||||
else
|
||||
ld:=cnilnode.create;
|
||||
result:=ctypeconvnode.create_internal(
|
||||
ctypeconvnode.create_internal(
|
||||
ld,
|
||||
intfdef),
|
||||
totypedef);
|
||||
if assigned(hp) then
|
||||
begin
|
||||
blck:=internalstatements(stmt);
|
||||
addstatement(stmt,cassignmentnode.create(hp,left));
|
||||
left:=nil;
|
||||
addstatement(stmt,result);
|
||||
result:=blck;
|
||||
end;
|
||||
end;
|
||||
if not assigned(result) then
|
||||
result:=cerrornode.create;
|
||||
end;
|
||||
|
||||
|
||||
function ttypeconvnode.typecheck_anonproc_2_funcref : tnode;
|
||||
var
|
||||
capturer : tsym;
|
||||
@ -2717,7 +2781,8 @@ implementation
|
||||
{ elem_2_openarray } @ttypeconvnode._typecheck_elem_2_openarray,
|
||||
{ arrayconstructor_2_dynarray } @ttypeconvnode._typecheck_arrayconstructor_to_dynarray,
|
||||
{ arrayconstructor_2_array } @ttypeconvnode._typecheck_arrayconstructor_to_array,
|
||||
{ anonproc_2_funcref } @ttypeconvnode._typecheck_anonproc_to_funcref
|
||||
{ anonproc_2_funcref } @ttypeconvnode._typecheck_anonproc_to_funcref,
|
||||
{ procvar_2_funcref } @ttypeconvnode._typecheck_procvar_to_funcref
|
||||
);
|
||||
type
|
||||
tprocedureofobject = function : tnode of object;
|
||||
@ -2893,7 +2958,10 @@ implementation
|
||||
use an extra check for them.}
|
||||
if (left.nodetype=calln) and
|
||||
(tcallnode(left).required_para_count=0) and
|
||||
(resultdef.typ=procvardef) and
|
||||
(
|
||||
(resultdef.typ=procvardef) or
|
||||
is_invokable(resultdef)
|
||||
) and
|
||||
(
|
||||
(m_tp_procvar in current_settings.modeswitches) or
|
||||
(m_mac_procvar in current_settings.modeswitches)
|
||||
@ -2909,8 +2977,16 @@ implementation
|
||||
end
|
||||
else
|
||||
begin
|
||||
convtype:=tc_proc_2_procvar;
|
||||
currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).Find_procdef_byprocvardef(Tprocvardef(resultdef));
|
||||
if resultdef.typ=procvardef then
|
||||
begin
|
||||
convtype:=tc_proc_2_procvar;
|
||||
currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).Find_procdef_byprocvardef(Tprocvardef(resultdef));
|
||||
end
|
||||
else
|
||||
begin
|
||||
convtype:=tc_procvar_2_funcref;
|
||||
currprocdef:=tprocsym(tcallnode(left).symtableprocentry).find_procdef_byfuncrefdef(tobjectdef(resultdef));
|
||||
end;
|
||||
hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
|
||||
tprocdef(currprocdef),tcallnode(left).symtableproc);
|
||||
if (tcallnode(left).symtableprocentry.owner.symtabletype=ObjectSymtable) then
|
||||
@ -2933,7 +3009,15 @@ implementation
|
||||
{ Now check if the procedure we are going to assign to
|
||||
the procvar, is compatible with the procvar's type }
|
||||
if not(nf_explicit in flags) and
|
||||
(proc_to_procvar_equal(currprocdef,tprocvardef(resultdef),false)=te_incompatible) then
|
||||
(
|
||||
(
|
||||
(resultdef.typ=procvardef) and
|
||||
(proc_to_procvar_equal(currprocdef,tprocvardef(resultdef),false)=te_incompatible)
|
||||
) or (
|
||||
is_invokable(resultdef) and
|
||||
(proc_to_funcref_equal(currprocdef,tobjectdef(resultdef))=te_incompatible)
|
||||
)
|
||||
) then
|
||||
IncompatibleTypes(left.resultdef,resultdef)
|
||||
else
|
||||
result:=typecheck_call_helper(convtype);
|
||||
@ -4426,6 +4510,7 @@ implementation
|
||||
@ttypeconvnode._first_nothing,
|
||||
@ttypeconvnode._first_nothing,
|
||||
@ttypeconvnode._first_nothing,
|
||||
nil,
|
||||
nil
|
||||
);
|
||||
type
|
||||
@ -4708,7 +4793,8 @@ implementation
|
||||
@ttypeconvnode._second_elem_to_openarray, { elem_2_openarray }
|
||||
@ttypeconvnode._second_nothing, { arrayconstructor_2_dynarray }
|
||||
@ttypeconvnode._second_nothing, { arrayconstructor_2_array }
|
||||
@ttypeconvnode._second_nothing { anonproc_2_funcref }
|
||||
@ttypeconvnode._second_nothing, { anonproc_2_funcref }
|
||||
@ttypeconvnode._second_nothing { procvar_2_funcref }
|
||||
);
|
||||
type
|
||||
tprocedureofobject = procedure of object;
|
||||
|
||||
@ -341,6 +341,7 @@ implementation
|
||||
named_args_allowed:=false;
|
||||
got_addrn:=false;
|
||||
getprocvardef:=nil;
|
||||
getfuncrefdef:=nil;
|
||||
|
||||
{ show info }
|
||||
Message1(parser_i_compiling,filename);
|
||||
|
||||
@ -51,6 +51,9 @@ interface
|
||||
{ special for handling procedure vars }
|
||||
getprocvardef : tprocvardef = nil;
|
||||
|
||||
{ special for function reference vars }
|
||||
getfuncrefdef : tobjectdef = nil;
|
||||
|
||||
var
|
||||
{ for operators }
|
||||
optoken : ttoken;
|
||||
|
||||
@ -1019,12 +1019,15 @@ implementation
|
||||
|
||||
{ When we are expecting a procvar we also need
|
||||
to get the address in some cases }
|
||||
if assigned(getprocvardef) then
|
||||
if assigned(getprocvardef) or assigned(getfuncrefdef) then
|
||||
begin
|
||||
if (block_type=bt_const) or
|
||||
getaddr then
|
||||
begin
|
||||
aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
|
||||
if assigned(getfuncrefdef) then
|
||||
aprocdef:=Tprocsym(sym).Find_procdef_byfuncrefdef(getfuncrefdef)
|
||||
else
|
||||
aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
|
||||
getaddr:=true;
|
||||
end
|
||||
else
|
||||
@ -1032,7 +1035,10 @@ implementation
|
||||
(m_mac_procvar in current_settings.modeswitches)) and
|
||||
not(token in [_CARET,_POINT,_LKLAMMER]) then
|
||||
begin
|
||||
aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
|
||||
if assigned(getfuncrefdef) then
|
||||
aprocdef:=Tprocsym(sym).Find_procdef_byfuncrefdef(getfuncrefdef)
|
||||
else
|
||||
aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
|
||||
if assigned(aprocdef) then
|
||||
getaddr:=true;
|
||||
end;
|
||||
@ -1059,6 +1065,9 @@ implementation
|
||||
if not assigned(aprocdef) and
|
||||
assigned(getprocvardef) then
|
||||
aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
|
||||
if not assigned(aprocdef) and
|
||||
assigned(getfuncrefdef) then
|
||||
aprocdef:=Tprocsym(sym).Find_procdef_byfuncrefdef(getfuncrefdef);
|
||||
|
||||
{ generate a methodcallnode or proccallnode }
|
||||
{ we shouldn't convert things like @tcollection.load }
|
||||
@ -1079,7 +1088,11 @@ implementation
|
||||
else
|
||||
begin
|
||||
typecheckpass(p1);
|
||||
if (p1.resultdef.typ=classrefdef) and assigned(getprocvardef) then
|
||||
if (p1.resultdef.typ=classrefdef) and
|
||||
(
|
||||
assigned(getprocvardef) or
|
||||
assigned(getfuncrefdef)
|
||||
) then
|
||||
begin
|
||||
p1:=cloadvmtaddrnode.create(p1);
|
||||
tloadnode(p2).set_mp(p1);
|
||||
@ -1186,6 +1199,45 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
procedure handle_funcref(fr:tobjectdef;var p2:tnode);
|
||||
var
|
||||
hp,hp2 : tnode;
|
||||
hpp : ^tnode;
|
||||
currprocdef : tprocdef;
|
||||
begin
|
||||
if not assigned(fr) then
|
||||
internalerror(2022032401);
|
||||
if not is_invokable(fr) then
|
||||
internalerror(2022032402);
|
||||
if (m_tp_procvar in current_settings.modeswitches) or
|
||||
(m_mac_procvar in current_settings.modeswitches) then
|
||||
begin
|
||||
hp:=p2;
|
||||
hpp:=@p2;
|
||||
while assigned(hp) and
|
||||
(hp.nodetype=typeconvn) do
|
||||
begin
|
||||
hp:=ttypeconvnode(hp).left;
|
||||
{ save orignal address of the old tree so we can replace the node }
|
||||
hpp:=@hp;
|
||||
end;
|
||||
if (hp.nodetype=calln) and
|
||||
{ a procvar can't have parameters! }
|
||||
not assigned(tcallnode(hp).left) then
|
||||
begin
|
||||
currprocdef:=tcallnode(hp).symtableprocentry.Find_procdef_byfuncrefdef(fr);
|
||||
if assigned(currprocdef) then
|
||||
begin
|
||||
hp2:=cloadnode.create_procvar(tprocsym(tcallnode(hp).symtableprocentry),currprocdef,tcallnode(hp).symtableproc);
|
||||
hp.free;
|
||||
{ replace the old callnode with the new loadnode }
|
||||
hpp^:=hp2;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{ the following procedure handles the access to a property symbol }
|
||||
procedure handle_propertysym(propsym : tpropertysym;st : TSymtable;var p1 : tnode);
|
||||
var
|
||||
@ -1234,14 +1286,19 @@ implementation
|
||||
consume(_ASSIGNMENT);
|
||||
{ read the expression }
|
||||
if propsym.propdef.typ=procvardef then
|
||||
getprocvardef:=tprocvardef(propsym.propdef);
|
||||
getprocvardef:=tprocvardef(propsym.propdef)
|
||||
else if is_invokable(propsym.propdef) then
|
||||
getfuncrefdef:=tobjectdef(propsym.propdef);
|
||||
p2:=comp_expr([ef_accept_equal]);
|
||||
if assigned(getprocvardef) then
|
||||
handle_procvar(getprocvardef,p2);
|
||||
handle_procvar(getprocvardef,p2)
|
||||
else if assigned(getfuncrefdef) then
|
||||
handle_funcref(getfuncrefdef,p2);
|
||||
tcallnode(p1).left:=ccallparanode.create(p2,tcallnode(p1).left);
|
||||
{ mark as property, both the tcallnode and the real call block }
|
||||
include(p1.flags,nf_isproperty);
|
||||
getprocvardef:=nil;
|
||||
getfuncrefdef:=nil;
|
||||
end;
|
||||
fieldvarsym :
|
||||
begin
|
||||
@ -2804,6 +2861,10 @@ implementation
|
||||
(
|
||||
assigned(getprocvardef) and
|
||||
equal_defs(p1.resultdef,getprocvardef)
|
||||
) or
|
||||
(
|
||||
assigned(getfuncrefdef) and
|
||||
equal_defs(p1.resultdef,getfuncrefdef)
|
||||
) then
|
||||
begin
|
||||
if try_to_consume(_LKLAMMER) then
|
||||
@ -3583,7 +3644,8 @@ implementation
|
||||
again,
|
||||
updatefpos,
|
||||
nodechanged : boolean;
|
||||
oldprocvardef: tprocvardef;
|
||||
oldprocvardef : tprocvardef;
|
||||
oldfuncrefdef : tobjectdef;
|
||||
begin
|
||||
{ can't keep a copy of p1 and compare pointers afterwards, because
|
||||
p1 may be freed and reallocated in the same place! }
|
||||
@ -4195,9 +4257,12 @@ implementation
|
||||
(m_anonymous_functions in current_settings.modeswitches) then
|
||||
begin
|
||||
oldprocvardef:=getprocvardef;
|
||||
oldfuncrefdef:=getfuncrefdef;
|
||||
getprocvardef:=nil;
|
||||
getfuncrefdef:=nil;
|
||||
pd:=read_proc([rpf_anonymous],nil);
|
||||
getprocvardef:=oldprocvardef;
|
||||
getfuncrefdef:=oldfuncrefdef;
|
||||
{ assume that we try to get the address except if certain
|
||||
tokens follow that indicate a call }
|
||||
do_proc_call(pd.procsym,pd.owner,nil,not (token in [_POINT,_CARET,_LECKKLAMMER]),
|
||||
@ -4793,12 +4858,18 @@ implementation
|
||||
_ASSIGNMENT :
|
||||
begin
|
||||
consume(_ASSIGNMENT);
|
||||
if assigned(p1.resultdef) and (p1.resultdef.typ=procvardef) then
|
||||
getprocvardef:=tprocvardef(p1.resultdef);
|
||||
if assigned(p1.resultdef) then
|
||||
if (p1.resultdef.typ=procvardef) then
|
||||
getprocvardef:=tprocvardef(p1.resultdef)
|
||||
else if is_invokable(p1.resultdef) then
|
||||
getfuncrefdef:=tobjectdef(p1.resultdef);
|
||||
p2:=sub_expr(opcompare,[ef_accept_equal],nil);
|
||||
if assigned(getprocvardef) then
|
||||
handle_procvar(getprocvardef,p2);
|
||||
handle_procvar(getprocvardef,p2)
|
||||
else if assigned(getfuncrefdef) then
|
||||
handle_funcref(getfuncrefdef,p2);
|
||||
getprocvardef:=nil;
|
||||
getfuncrefdef:=nil;
|
||||
p1:=cassignmentnode.create(p1,p2);
|
||||
end;
|
||||
_PLUSASN :
|
||||
|
||||
@ -42,6 +42,7 @@ function adjust_funcref(var def:tdef;sym,dummysym:tsym):boolean;
|
||||
|
||||
function get_or_create_capturer(pd:tprocdef):tsym;
|
||||
function capturer_add_anonymous_proc(owner:tprocinfo;pd:tprocdef;out capturer:tsym):tobjectdef;
|
||||
function capturer_add_procvar_or_proc(owner:tprocinfo;n:tnode;out capturer:tsym;out capturen:tnode):tobjectdef;
|
||||
procedure initialize_capturer(ctx:tprocinfo;var stmt:tstatementnode);
|
||||
procedure postprocess_capturer(ctx:tprocinfo);
|
||||
procedure convert_captured_syms(pd:tprocdef;tree:tnode);
|
||||
@ -656,6 +657,417 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
function retrieve_sym_for_filepos(var n:tnode;arg:pointer):foreachnoderesult;
|
||||
var
|
||||
sym : ^tsym absolute arg;
|
||||
begin
|
||||
if assigned(sym^) then
|
||||
exit(fen_norecurse_true);
|
||||
result:=fen_false;
|
||||
if not (n.resultdef.typ in [procdef,procvardef]) then
|
||||
exit;
|
||||
if n.nodetype=loadn then
|
||||
begin
|
||||
sym^:=tloadnode(n).symtableentry;
|
||||
result:=fen_norecurse_true;
|
||||
end
|
||||
else if n.nodetype=subscriptn then
|
||||
begin
|
||||
sym^:=tsubscriptnode(n).vs;
|
||||
result:=fen_norecurse_true;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function collect_syms_to_capture(var n:tnode;arg:pointer):foreachnoderesult;
|
||||
var
|
||||
pd : tprocdef absolute arg;
|
||||
sym : tsym;
|
||||
begin
|
||||
result:=fen_false;
|
||||
if n.nodetype<>loadn then
|
||||
exit;
|
||||
sym:=tsym(tloadnode(n).symtableentry);
|
||||
if not (sym.owner.symtabletype in [parasymtable,localsymtable]) then
|
||||
exit;
|
||||
if sym.owner.symtablelevel>normal_function_level then begin
|
||||
pd.add_captured_sym(sym,n.fileinfo);
|
||||
result:=fen_true;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
type
|
||||
tselfinfo=record
|
||||
selfsym:tsym;
|
||||
ignore:tsym;
|
||||
end;
|
||||
pselfinfo=^tselfinfo;
|
||||
|
||||
|
||||
function find_self_sym(var n:tnode;arg:pointer):foreachnoderesult;
|
||||
var
|
||||
info : pselfinfo absolute arg;
|
||||
begin
|
||||
result:=fen_false;
|
||||
if assigned(info^.selfsym) then
|
||||
exit(fen_norecurse_true);
|
||||
if n.nodetype<>loadn then
|
||||
exit;
|
||||
if tloadnode(n).symtableentry.typ<>paravarsym then
|
||||
exit;
|
||||
if tloadnode(n).symtableentry=info^.ignore then
|
||||
exit;
|
||||
if vo_is_self in tparavarsym(tloadnode(n).symtableentry).varoptions then
|
||||
begin
|
||||
info^.selfsym:=tparavarsym(tloadnode(n).symtableentry);
|
||||
result:=fen_norecurse_true;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function find_outermost_loaded_sym(var n:tnode;arg:pointer):foreachnoderesult;
|
||||
var
|
||||
sym : ^tsym absolute arg;
|
||||
begin
|
||||
if assigned(sym^) then
|
||||
exit(fen_norecurse_true);
|
||||
result:=fen_false;
|
||||
if n.nodetype<>loadn then
|
||||
exit;
|
||||
sym^:=tloadnode(n).symtableentry;
|
||||
result:=fen_norecurse_true;
|
||||
end;
|
||||
|
||||
|
||||
function find_procdef(var n:tnode;arg:pointer):foreachnoderesult;
|
||||
var
|
||||
pd : ^tprocdef absolute arg;
|
||||
begin
|
||||
if assigned(pd^) then
|
||||
exit(fen_norecurse_true);
|
||||
result:=fen_false;
|
||||
if n.resultdef.typ<>procdef then
|
||||
exit;
|
||||
pd^:=tprocdef(n.resultdef);
|
||||
result:=fen_norecurse_true;
|
||||
end;
|
||||
|
||||
|
||||
function capturer_add_procvar_or_proc(owner:tprocinfo;n:tnode;out capturer:tsym;out capturen:tnode):tobjectdef;
|
||||
|
||||
function create_paras(pd:tprocdef):tcallparanode;
|
||||
var
|
||||
para : tparavarsym;
|
||||
i : longint;
|
||||
begin
|
||||
result:=nil;
|
||||
for i:=0 to pd.paras.count-1 do
|
||||
begin
|
||||
para:=tparavarsym(pd.paras[i]);
|
||||
if vo_is_hidden_para in para.varoptions then
|
||||
continue;
|
||||
result:=ccallparanode.create(cloadnode.create(para,pd.parast),result);
|
||||
end;
|
||||
end;
|
||||
|
||||
function find_nested_procinfo(pd:tprocdef):tcgprocinfo;
|
||||
var
|
||||
tmp,
|
||||
res : tprocinfo;
|
||||
begin
|
||||
tmp:=owner;
|
||||
while assigned(tmp) and (tmp.procdef.parast.symtablelevel>=normal_function_level) do
|
||||
begin
|
||||
res:=tmp.find_nestedproc_by_pd(pd);
|
||||
if assigned(res) then
|
||||
exit(tcgprocinfo(res));
|
||||
tmp:=tmp.parent;
|
||||
end;
|
||||
result:=nil;
|
||||
end;
|
||||
|
||||
procedure swap_symtable(var st1,st2:tsymtable);
|
||||
var
|
||||
st : tsymtable;
|
||||
owner : tdefentry;
|
||||
level : byte;
|
||||
begin
|
||||
{ first swap the symtables themselves }
|
||||
st:=st1;
|
||||
st1:=st2;
|
||||
st2:=st;
|
||||
{ then swap the symtables' owners }
|
||||
owner:=st1.defowner;
|
||||
st1.defowner:=st2.defowner;
|
||||
st2.defowner:=owner;
|
||||
{ and finally the symtable level }
|
||||
level:=st1.symtablelevel;
|
||||
st1.symtablelevel:=st2.symtablelevel;
|
||||
st2.symtablelevel:=level;
|
||||
end;
|
||||
|
||||
procedure print_procinfo(pi:tcgprocinfo);
|
||||
begin
|
||||
{ Print the node to tree.log }
|
||||
if paraprintnodetree <> 0 then
|
||||
pi.printproc('after parsing');
|
||||
|
||||
{$ifdef DEBUG_NODE_XML}
|
||||
{ Methods of generic classes don't get any code generated, so output
|
||||
the node tree here }
|
||||
if (df_generic in procdef.defoptions) then
|
||||
pi.XMLPrintProc(True);
|
||||
{$endif DEBUG_NODE_XML}
|
||||
end;
|
||||
|
||||
var
|
||||
ps : tprocsym;
|
||||
pd : tprocdef;
|
||||
pinested,
|
||||
pi : tcgprocinfo;
|
||||
sym,
|
||||
fpsym,
|
||||
selfsym : tsym;
|
||||
invokename : tsymstr;
|
||||
capturedef : tobjectdef;
|
||||
capturesyms : tfplist;
|
||||
captured : pcapturedsyminfo;
|
||||
implintf : TImplementedInterface;
|
||||
i : longint;
|
||||
stmt : tstatementnode;
|
||||
n1 : tnode;
|
||||
fieldsym : tfieldvarsym;
|
||||
selfinfo : tselfinfo;
|
||||
begin
|
||||
if not (n.resultdef.typ in [procdef,procvardef]) then
|
||||
internalerror(2022022101);
|
||||
|
||||
capturer:=nil;
|
||||
capturen:=nil;
|
||||
|
||||
{ determine a unique name for the variable, field for function of the
|
||||
node we're trying to load }
|
||||
|
||||
sym:=nil;
|
||||
if not foreachnodestatic(pm_preprocess,n,@find_outermost_loaded_sym,@sym) then
|
||||
internalerror(2022022102);
|
||||
|
||||
result:=funcref_intf_for_proc(tabstractprocdef(n.resultdef),fileinfo_to_suffix(sym.fileinfo));
|
||||
|
||||
if df_generic in owner.procdef.defoptions then
|
||||
begin
|
||||
{ only check whether we can capture the symbol }
|
||||
if not can_be_captured(sym) then
|
||||
MessagePos1(n.fileinfo,sym_e_symbol_no_capture,sym.realname);
|
||||
exit;
|
||||
end;
|
||||
|
||||
if (sym.typ=procsym) and (sym.owner.symtabletype=localsymtable) then
|
||||
begin
|
||||
{ this is assigning a nested function, so retrieve the correct procdef
|
||||
so that we can then retrieve the procinfo for it }
|
||||
if n.resultdef.typ=procdef then
|
||||
pd:=tprocdef(n.resultdef)
|
||||
else
|
||||
begin
|
||||
pd:=nil;
|
||||
if not foreachnodestatic(pm_preprocess,n,@find_procdef,@pd) then
|
||||
internalerror(2022041801);
|
||||
if not assigned(pd) then
|
||||
internalerror(2022041802);
|
||||
end;
|
||||
pinested:=find_nested_procinfo(pd);
|
||||
if not assigned(pinested) then
|
||||
internalerror(2022041803);
|
||||
if pinested.parent<>owner then
|
||||
begin
|
||||
{ we need to capture this into the owner of the nested function
|
||||
instead }
|
||||
owner:=pinested;
|
||||
capturer:=get_or_create_capturer(pinested.procdef);
|
||||
if not assigned(capturer) then
|
||||
internalerror(2022041804);
|
||||
end;
|
||||
end
|
||||
else
|
||||
pinested:=nil;
|
||||
|
||||
if not assigned(capturer) then
|
||||
capturer:=get_or_create_capturer(owner.procdef);
|
||||
|
||||
if not (capturer.typ in [localvarsym,staticvarsym]) then
|
||||
internalerror(2022022103);
|
||||
capturedef:=tobjectdef(tabstractvarsym(capturer).vardef);
|
||||
if not is_class(capturedef) then
|
||||
internalerror(2022022104);
|
||||
implintf:=find_implemented_interface(capturedef,result);
|
||||
if assigned(implintf) then
|
||||
begin
|
||||
{ this is already captured into a method of the capturer, so nothing
|
||||
further to do }
|
||||
exit;
|
||||
end;
|
||||
implintf:=capturedef.register_implemented_interface(result,true);
|
||||
|
||||
invokename:=method_name_funcref_invoke_decl+'$'+fileinfo_to_suffix(sym.fileinfo);
|
||||
|
||||
ps:=cprocsym.create(invokename);
|
||||
pd:=tprocdef(tabstractprocdef(n.resultdef).getcopyas(procdef,pc_normal,'',false));
|
||||
pd.aliasnames.clear;
|
||||
|
||||
pd.procsym:=ps;
|
||||
pd.struct:=capturedef;
|
||||
pd.changeowner(capturedef.symtable);
|
||||
pd.parast.symtablelevel:=normal_function_level;
|
||||
pd.localst.symtablelevel:=normal_function_level;
|
||||
{ reset procoptions }
|
||||
pd.procoptions:=[];
|
||||
{ to simplify some checks }
|
||||
pd.was_anonymous:=true;
|
||||
ps.ProcdefList.Add(pd);
|
||||
pd.forwarddef:=false;
|
||||
{ set procinfo and current_procinfo.procdef }
|
||||
pi:=tcgprocinfo(cprocinfo.create(nil));
|
||||
pi.procdef:=pd;
|
||||
if not assigned(pinested) then
|
||||
begin
|
||||
insert_funcret_local(pd);
|
||||
{ we always do a call, namely to the provided function }
|
||||
include(pi.flags,pi_do_call);
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ the original nested function now calls the method }
|
||||
include(pinested.flags,pi_do_call);
|
||||
{ swap the para and local symtables of the nested and new routine }
|
||||
swap_symtable(pinested.procdef.parast,pd.parast);
|
||||
swap_symtable(pinested.procdef.localst,pd.localst);
|
||||
{ fix function return symbol }
|
||||
pd.funcretsym:=pinested.procdef.funcretsym;
|
||||
pinested.procdef.funcretsym:=nil;
|
||||
insert_funcret_local(pinested.procdef);
|
||||
end;
|
||||
capturedef.symtable.insertsym(ps);
|
||||
owner.addnestedproc(pi);
|
||||
|
||||
{ remove self and parentfp parameter if any as that will be replaced by
|
||||
the capturer }
|
||||
selfsym:=nil;
|
||||
fpsym:=nil;
|
||||
for i:=0 to pd.parast.symlist.count-1 do
|
||||
begin
|
||||
sym:=tsym(pd.parast.symlist[i]);
|
||||
if sym.typ<>paravarsym then
|
||||
continue;
|
||||
if vo_is_self in tparavarsym(sym).varoptions then
|
||||
selfsym:=sym
|
||||
else if vo_is_parentfp in tparavarsym(sym).varoptions then
|
||||
fpsym:=sym;
|
||||
if assigned(selfsym) and assigned(fpsym) then
|
||||
break;
|
||||
end;
|
||||
if assigned(selfsym) then
|
||||
pd.parast.deletesym(selfsym);
|
||||
if assigned(fpsym) then
|
||||
pd.parast.deletesym(fpsym);
|
||||
pd.calcparas;
|
||||
if assigned(pinested) then
|
||||
pinested.procdef.calcparas;
|
||||
|
||||
insert_self_and_vmt_para(pd);
|
||||
|
||||
if assigned(pinested) then
|
||||
begin
|
||||
{ when we're assigning a nested function to a function reference we
|
||||
move the code of the nested function to the newly created capturer
|
||||
method (including the captured symbols) and have the original nested
|
||||
function simply call that function-turned-method }
|
||||
pi.code:=pinested.code;
|
||||
pinested.code:=internalstatements(stmt);
|
||||
end
|
||||
else
|
||||
pi.code:=internalstatements(stmt);
|
||||
|
||||
selfinfo.selfsym:=nil;
|
||||
selfinfo.ignore:=nil;
|
||||
|
||||
fieldsym:=nil;
|
||||
if assigned(pinested) then
|
||||
begin
|
||||
n1:=ccallnode.create(create_paras(pd),ps,capturedef.symtable,cloadnode.create(capturer,capturer.owner),[],nil);
|
||||
end
|
||||
else if n.resultdef.typ=procvardef then
|
||||
begin
|
||||
{ store the procvar in a field so that it won't be changed if the
|
||||
procvar itself is changed }
|
||||
fieldsym:=cfieldvarsym.create('$'+fileinfo_to_suffix(n.fileinfo),vs_value,n.resultdef,[]);
|
||||
fieldsym.fileinfo:=n.fileinfo;
|
||||
capturedef.symtable.insertsym(fieldsym);
|
||||
tabstractrecordsymtable(capturedef.symtable).addfield(fieldsym,vis_public);
|
||||
|
||||
capturen:=csubscriptnode.create(fieldsym,cloadnode.create(capturer,capturer.owner));
|
||||
|
||||
selfsym:=tsym(pd.parast.find('self'));
|
||||
if not assigned(selfsym) then
|
||||
internalerror(2022052301);
|
||||
selfinfo.ignore:=selfsym;
|
||||
n1:=ccallnode.create_procvar(create_paras(pd),csubscriptnode.create(fieldsym,cloadnode.create(selfsym,selfsym.owner)));
|
||||
end
|
||||
else
|
||||
begin
|
||||
if n.nodetype<>loadn then
|
||||
internalerror(2022032401);
|
||||
if tloadnode(n).symtableentry.typ<>procsym then
|
||||
internalerror(2022032402);
|
||||
n1:=ccallnode.create(create_paras(pd),tprocsym(tloadnode(n).symtableentry),tloadnode(n).symtable,tloadnode(n).left,[],nil);
|
||||
tloadnode(n).left:=nil;
|
||||
end;
|
||||
if assigned(pd.returndef) and not is_void(pd.returndef) then
|
||||
n1:=cassignmentnode.create(
|
||||
cloadnode.create(pd.funcretsym,pd.localst),
|
||||
n1
|
||||
);
|
||||
addstatement(stmt,n1);
|
||||
pd.aliasnames.insert(pd.mangledname);
|
||||
|
||||
if assigned(pinested) then
|
||||
begin
|
||||
{ transfer all captured syms }
|
||||
capturesyms:=pinested.procdef.capturedsyms;
|
||||
if assigned(capturesyms) then
|
||||
begin
|
||||
for i:=0 to capturesyms.count-1 do
|
||||
begin
|
||||
captured:=pcapturedsyminfo(capturesyms[i]);
|
||||
pi.add_captured_sym(captured^.sym,captured^.fileinfo);
|
||||
end;
|
||||
capturesyms.clear;
|
||||
end;
|
||||
{ the original nested function now needs to capture only the capturer }
|
||||
pinested.procdef.add_captured_sym(capturer,n.fileinfo);
|
||||
end
|
||||
{ does this need to capture Self? }
|
||||
else if not foreachnodestatic(pm_postprocess,n,@find_self_sym,@selfinfo) then
|
||||
begin
|
||||
{ does this need some other local variable or parameter? }
|
||||
foreachnodestatic(pm_postprocess,n,@collect_syms_to_capture,@pd)
|
||||
end
|
||||
else if not assigned(fieldsym) then
|
||||
{ this isn't a procdef that was captured into a field, so capture the
|
||||
self }
|
||||
pd.add_captured_sym(selfinfo.selfsym,n.fileinfo);
|
||||
|
||||
print_procinfo(pi);
|
||||
if assigned(pinested) then
|
||||
print_procinfo(pinested);
|
||||
|
||||
implintf.AddMapping(upcase(result.objrealname^+'.')+method_name_funcref_invoke_find,upcase(invokename));
|
||||
|
||||
capture_captured_syms(pd,owner,capturedef);
|
||||
end;
|
||||
|
||||
|
||||
function capturer_add_anonymous_proc(owner:tprocinfo;pd:tprocdef;out capturer:tsym):tobjectdef;
|
||||
var
|
||||
capturedef : tobjectdef;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user