From 2ed2c213136a4e7eede7ec2f4761f4d23bb27562 Mon Sep 17 00:00:00 2001 From: Sven/Sarah Barth Date: Sun, 6 Feb 2022 19:39:53 +0100 Subject: [PATCH] + add support for parsing function references --- compiler/pdecl.pas | 42 ++++++---- compiler/pdecvar.pas | 56 +++++++++++-- compiler/pexpr.pas | 9 ++- compiler/procdefutil.pas | 169 ++++++++++++++++++++++++++++++++++++++- compiler/ptype.pas | 12 ++- 5 files changed, 260 insertions(+), 28 deletions(-) diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index b0b4a6b046..c0598c2614 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -65,6 +65,7 @@ implementation { parser } scanner, pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj,pgenutil,pparautl, + procdefutil, {$ifdef jvm} pjvm, {$endif} @@ -687,12 +688,14 @@ implementation typename,orgtypename, gentypename,genorgtypename : TIDString; newtype : ttypesym; + dummysym, sym : tsym; hdef, hdef2 : tdef; defpos,storetokenpos : tfileposinfo; old_block_type : tblock_type; old_checkforwarddefs: TFPObjectList; + setdummysym, first, isgeneric, isunique, @@ -719,6 +722,7 @@ implementation repeat defpos:=current_tokenpos; istyperenaming:=false; + setdummysym:=false; generictypelist:=nil; localgenerictokenbuf:=nil; @@ -946,13 +950,20 @@ implementation if isgeneric and assigned(sym) and not (m_delphi in current_settings.modeswitches) and (ttypesym(sym).typedef.typ=undefineddef) then - { don't free the undefineddef as the defids rely on the count - of the defs in the def list of the module} - ttypesym(sym).typedef:=hdef; + begin + { don't free the undefineddef as the defids rely on the count + of the defs in the def list of the module} + ttypesym(sym).typedef:=hdef; + setdummysym:=true; + end; newtype.typedef:=hdef; { ensure that the type is registered when no specialization is currently done } - if current_scanner.replay_stack_depth=0 then + if (current_scanner.replay_stack_depth=0) and + ( + (hdef.typ<>procvardef) or + not (po_is_function_ref in tprocdef(hdef).procoptions) + ) then hdef.register_def; { KAZ: handle TGUID declaration in system unit } if (cs_compilesystem in current_settings.moduleswitches) and @@ -1049,21 +1060,22 @@ implementation parse_proctype_directives(tprocvardef(hdef)); if po_is_function_ref in tprocvardef(hdef).procoptions then begin - { these always support everything, no "of object" or - "is_nested" is allowed } - if is_nested_pd(tprocvardef(hdef)) or - is_methodpointer(hdef) then - cgmessage(type_e_function_reference_kind) + if not (m_function_references in current_settings.modeswitches) and + not (po_is_block in tprocvardef(hdef).procoptions) then + messagepos(storetokenpos,sym_e_error_in_type_def) else begin - { this message is only temporary; once Delphi style anonymous functions - are supported, this check is no longer required } - if not (po_is_block in tprocvardef(hdef).procoptions) then - comment(v_error,'Function references are not yet supported, only C blocks (add "cblock;" at the end)'); + if setdummysym then + dummysym:=sym + else + dummysym:=nil; + adjust_funcref(hdef,newtype,dummysym); end; + if current_scanner.replay_stack_depth=0 then + hdef.register_def; end; - handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf); - if po_is_function_ref in tprocvardef(hdef).procoptions then + handle_calling_convention(hdef,hcc_default_actions_intf); + if (hdef.typ=procvardef) and (po_is_function_ref in tprocvardef(hdef).procoptions) then begin if (po_is_block in tprocvardef(hdef).procoptions) and not (tprocvardef(hdef).proccalloption in [pocall_cdecl,pocall_mwpascal]) then diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index cf7563995e..9557d992e3 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -60,7 +60,7 @@ implementation {$if defined(i386) or defined(i8086)} symcpu, {$endif} - fmodule,htypechk, + fmodule,htypechk,procdefutil, { pass 1 } node,pass_1,aasmbase,aasmdata, ncon,nset,ncnv,nld,nutils, @@ -1351,6 +1351,7 @@ implementation deprecatedmsg : pshortstring; old_block_type : tblock_type; sectionname : ansistring; + typepos, tmp_filepos, old_current_filepos : tfileposinfo; begin @@ -1432,6 +1433,7 @@ implementation { read variable type def } block_type:=bt_var_type; consume(_COLON); + typepos:=current_tokenpos; {$ifdef gpc_mode} if (m_gpc in current_settings.modeswitches) and @@ -1488,9 +1490,32 @@ implementation (symtablestack.top.symtabletype<>parasymtable) then begin { Add calling convention for procvar } - if (hdef.typ=procvardef) and + if ( + (hdef.typ=procvardef) or + is_funcref(hdef) + ) and (hdef.typesym=nil) then - handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf); + begin + if po_is_function_ref in tprocvardef(hdef).procoptions then + begin + if not (m_function_references in current_settings.modeswitches) and + not (po_is_block in tprocvardef(hdef).procoptions) then + messagepos(typepos,sym_e_error_in_type_def) + else + begin + if adjust_funcref(hdef,nil,nil) then + { the def was changed, so update it } + for i:=0 to sc.count-1 do + begin + vs:=tabstractvarsym(sc[i]); + vs.vardef:=hdef; + end; + if current_scanner.replay_stack_depth=0 then + hdef.register_def; + end; + end; + handle_calling_convention(hdef,hcc_default_actions_intf); + end; read_default_value(sc); hasdefaultvalue:=true; end @@ -1502,13 +1527,34 @@ implementation { Support calling convention for procvars after semicolon } if not(hasdefaultvalue) and - (hdef.typ=procvardef) and + ( + (hdef.typ=procvardef) or + is_funcref(hdef) + ) and (hdef.typesym=nil) then begin { Parse procvar directives after ; } maybe_parse_proc_directives(hdef); + if po_is_function_ref in tprocvardef(hdef).procoptions then + begin + if not (m_function_references in current_settings.modeswitches) and + not (po_is_block in tprocvardef(hdef).procoptions) then + messagepos(typepos,sym_e_error_in_type_def) + else + begin + if adjust_funcref(hdef,nil,nil) then + { the def was changed, so update it } + for i:=0 to sc.count-1 do + begin + vs:=tabstractvarsym(sc[i]); + vs.vardef:=hdef; + end; + if current_scanner.replay_stack_depth=0 then + hdef.register_def; + end; + end; { Add calling convention for procvar } - handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf); + handle_calling_convention(hdef,hcc_default_actions_intf); { Handling of Delphi typed const = initialized vars } if (token=_EQ) and not(m_tp7 in current_settings.modeswitches) and diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index d44a27081d..86fad077ca 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -2785,7 +2785,14 @@ implementation else begin { is this a procedure variable ? } - if assigned(p1.resultdef) and + if is_invokable(p1.resultdef) and + (token=_LKLAMMER) then + begin + if not searchsym_in_class(tobjectdef(p1.resultdef),tobjectdef(p1.resultdef),method_name_funcref_invoke_find,srsym,srsymtable,[]) then + internalerror(2021040202); + do_proc_call(srsym,srsymtable,tabstractrecorddef(p1.resultdef),false,again,p1,[],nil); + end + else if assigned(p1.resultdef) and (p1.resultdef.typ=procvardef) then begin { Typenode for typecasting or expecting a procvar } diff --git a/compiler/procdefutil.pas b/compiler/procdefutil.pas index 93534047f9..ca59730b5b 100644 --- a/compiler/procdefutil.pas +++ b/compiler/procdefutil.pas @@ -25,18 +25,22 @@ unit procdefutil; interface uses - symconst,symtype,symdef; + symconst,symtype,symdef,globtype; { create a nested procdef that will be used to outline code from a procedure; astruct should usually be nil, except in special cases like the Windows SEH exception handling funclets } function create_outline_procdef(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef): tprocdef; +procedure convert_to_funcref_intf(const n:tidstring;var def:tdef); +function adjust_funcref(var def:tdef;sym,dummysym:tsym):boolean; + implementation uses - cutils, - symbase,symsym,symtable,pparautl,globtype; + cutils,cclasses,verbose,globals, + nobj, + symbase,symsym,symtable,defutil,pparautl; function create_outline_procdef(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef): tprocdef; @@ -91,5 +95,164 @@ implementation end; + function fileinfo_to_suffix(const fileinfo:tfileposinfo):tsymstr;inline; + begin + result:=tostr(fileinfo.moduleindex)+'_'+ + tostr(fileinfo.fileindex)+'_'+ + tostr(fileinfo.line)+'_'+ + tostr(fileinfo.column); + end; + + + const + anon_funcref_prefix='$FuncRef_'; + + + procedure convert_to_funcref_intf(const n:tidstring;var def:tdef); + var + oldsymtablestack : tsymtablestack; + pvdef : tprocvardef absolute def; + intfdef : tobjectdef; + invokedef : tprocdef; + psym : tprocsym; + sym : tsym; + st : tsymtable; + i : longint; + name : tidstring; + begin + if def.typ<>procvardef then + internalerror(2021040201); + if not (po_is_function_ref in tprocvardef(pvdef).procoptions) then + internalerror(2021022101); + if n='' then + name:=anon_funcref_prefix+fileinfo_to_suffix(current_filepos) + else + name:=n; + intfdef:=cobjectdef.create(odt_interfacecom,name,interface_iunknown,true); + include(intfdef.objectoptions,oo_is_funcref); + include(intfdef.objectoptions,oo_is_invokable); + include(intfdef.objectoptions,oo_has_virtual); + intfdef.typesym:=pvdef.typesym; + pvdef.typesym:=nil; + + if cs_generate_rtti in current_settings.localswitches then + include(intfdef.objectoptions,oo_can_have_published); + + oldsymtablestack:=symtablestack; + symtablestack:=nil; + + invokedef:=tprocdef(pvdef.getcopyas(procdef,pc_normal_no_paras,'',false)); + invokedef.struct:=intfdef; + invokedef.forwarddef:=false; + + include(invokedef.procoptions,po_overload); + include(invokedef.procoptions,po_virtualmethod); + + invokedef.procsym:=cprocsym.create(method_name_funcref_invoke_decl); + if cs_generate_rtti in current_settings.localswitches then + invokedef.visibility:=vis_published + else + invokedef.visibility:=vis_public; + + intfdef.symtable.insertsym(invokedef.procsym); + intfdef.symtable.insertdef(invokedef); + + if pvdef.is_generic or pvdef.is_specialization then + begin + if assigned(pvdef.genericdef) and (pvdef.genericdef.typ<>objectdef) then + internalerror(2021040501); + intfdef.genericdef:=pvdef.genericdef; + intfdef.defoptions:=intfdef.defoptions+(pvdef.defoptions*[df_generic,df_specialization]); + { in case of a generic we move all involved syms/defs to the interface } + intfdef.genericparas:=pvdef.genericparas; + pvdef.genericparas:=nil; + for i:=0 to intfdef.genericparas.count-1 do + begin + sym:=tsym(intfdef.genericparas[i]); + if sym.owner<>pvdef.parast then + continue; + sym.changeowner(intfdef.symtable); + if (sym.typ=typesym) and (ttypesym(sym).typedef.owner=pvdef.parast) then + ttypesym(sym).typedef.changeowner(intfdef.symtable); + end; + end; + + { now move the symtable over } + invokedef.parast.free; + invokedef.parast:=pvdef.parast; + invokedef.parast.defowner:=invokedef; + pvdef.parast:=nil; + + for i:=0 to invokedef.parast.symlist.count-1 do + begin + sym:=tsym(invokedef.parast.symlist[i]); + if sym.typ<>paravarsym then + continue; + if tparavarsym(sym).vardef=pvdef then + tparavarsym(sym).vardef:=intfdef; + end; + + symtablestack:=oldsymtablestack; + + if invokedef.returndef=pvdef then + invokedef.returndef:=intfdef; + + handle_calling_convention(invokedef,hcc_default_actions_intf_struct); + proc_add_definition(invokedef); + invokedef.calcparas; + { def is not owned, so it can be simply freed } + def.free; + def:=intfdef; + end; + + + function adjust_funcref(var def:tdef;sym,dummysym:tsym):boolean; + var + sympos : tfileposinfo; + name : string; + begin + result:=false; + if (def.typ<>procvardef) and not is_funcref(def) then + internalerror(2022020401); + if assigned(sym) and not (sym.typ=typesym) then + internalerror(2022020402); + { these always support everything, no "of object" or + "is_nested" is allowed } + if is_nested_pd(tprocvardef(def)) or + is_methodpointer(def) then + cgmessage(type_e_function_reference_kind); + if not (po_is_block in tprocvardef(def).procoptions) then + begin + if assigned(dummysym) then + ttypesym(dummysym).typedef:=nil; + if assigned(sym) then + begin + ttypesym(sym).typedef:=nil; + name:=sym.name; + end + else + name:=''; + convert_to_funcref_intf(name,def); + if assigned(sym) then + ttypesym(sym).typedef:=def; + if assigned(dummysym) then + ttypesym(dummysym).typedef:=def; + build_vmt(tobjectdef(def)); + result:=true; + end + else + begin + if assigned(sym) and (sym.refs>0) then + begin + { find where the symbol was used and trigger + a "symbol not completely defined" error } + if not fileinfo_of_typesym_in_def(def,sym,sympos) then + sympos:=sym.fileinfo; + messagepos1(sympos,type_e_type_is_not_completly_defined,sym.realname); + end; + end; + end; + + end. diff --git a/compiler/ptype.pas b/compiler/ptype.pas index a4ec982dff..74a6f792fd 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -84,7 +84,7 @@ implementation nset,ncnv,ncon,nld, { parser } scanner, - pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil,pparautl + pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil,pparautl,procdefutil {$ifdef jvm} ,pjvm {$endif} @@ -1976,15 +1976,19 @@ implementation end; _REFERENCE: begin - if m_blocks in current_settings.modeswitches then + if current_settings.modeswitches*[m_blocks,m_function_references]<>[] then begin consume(_REFERENCE); consume(_TO); - def:=procvar_dec(genericdef,genericlist,true); + { don't register the def as a non-cblock function + reference will be converted to an interface } + def:=procvar_dec(genericdef,genericlist,false); { could be errordef in case of a syntax error } if assigned(def) and (def.typ=procvardef) then - include(tprocvardef(def).procoptions,po_is_function_ref); + begin + include(tprocvardef(def).procoptions,po_is_function_ref); + end; end else expr_type;