1 { 2 Copyright (c) 2011 by Jonas Maebe 3 4 This unit provides helpers for creating new syms/defs based on string 5 representations. 6 7 This program is free software; you can redistribute it and/or modify 8 it under the terms of the GNU General Public License as published by 9 the Free Software Foundation; either version 2 of the License, or 10 (at your option) any later version. 11 12 This program is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with this program; if not, write to the Free Software 19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 20 21 **************************************************************************** 22 } 23 {$i fpcdefs.inc} 24 25 unit symcreat; 26 27 interface 28 29 uses 30 finput,tokens,scanner,globtype, 31 aasmdata, 32 symconst,symbase,symtype,symdef,symsym, 33 node; 34 35 36 type 37 tscannerstate = record 38 old_scanner: tscannerfile; 39 old_filepos: tfileposinfo; 40 old_token: ttoken; 41 old_c: char; 42 old_orgpattern: string; 43 old_modeswitches: tmodeswitches; 44 old_idtoken: ttoken; 45 valid: boolean; 46 end; 47 48 { save/restore the scanner state before/after injecting } 49 procedure replace_scanner(const tempname: string; out sstate: tscannerstate); 50 procedure restore_scanner(const sstate: tscannerstate); 51 52 { parses a (class or regular) method/constructor/destructor declaration from 53 str, as if it were declared in astruct's declaration body 54 55 WARNING: save the scanner state before calling this routine, and restore 56 when done. } str_parse_method_decnull57 function str_parse_method_dec(str: ansistring; potype: tproctypeoption; is_classdef: boolean; astruct: tabstractrecorddef; out pd: tprocdef): boolean; 58 59 { parses a (class or regular) method/constructor/destructor implementation 60 from str, as if it appeared in the current unit's implementation section 61 62 WARNINGS: 63 * save the scanner state before calling this routine, and restore when done. 64 * the code *must* be written in objfpc style 65 } str_parse_method_implnull66 function str_parse_method_impl(const str: ansistring; usefwpd: tprocdef; is_classdef: boolean):boolean; 67 68 { parses a typed constant assignment to ssym 69 70 WARNINGS: 71 * save the scanner state before calling this routine, and restore when done. 72 * the code *must* be written in objfpc style 73 } 74 procedure str_parse_typedconst(list: TAsmList; str: ansistring; ssym: tstaticvarsym); 75 76 77 78 { in the JVM, constructors are not automatically inherited (so you can hide 79 them). To emulate the Pascal behaviour, we have to automatically add 80 all parent constructors to the current class as well. We also have to do 81 the same for the (emulated) virtual class methods } 82 procedure add_missing_parent_constructors_intf(obj: tobjectdef; addvirtclassmeth: boolean; forcevis: tvisibility); 83 84 { goes through all defs in st to add implementations for synthetic methods 85 added earlier } 86 procedure add_synthetic_method_implementations(st: tsymtable); 87 88 { create an alias for a procdef with Pascal name "newrealname", 89 mangledname "newmangledname", in symtable newparentst, part of the 90 record/class/.. "newstruct" (nil if none), and with synthetickind "sk" and 91 synthetic kind para "skpara" to create the implementation (tsk_none and nil 92 in case not necessary). Returns the new procdef; finish_copied_procdef() is 93 not required/must not be called for the result. } create_procdef_aliasnull94 function create_procdef_alias(pd: tprocdef; const newrealname: string; const newmangledname: TSymStr; newparentst: tsymtable; newstruct: tabstractrecorddef; sk: tsynthetickind; skpara: pointer): tprocdef; 95 96 { finalize a procdef that has been copied with 97 tprocdef.getcopyas(procdef,pc_bareproc) } 98 procedure finish_copied_procdef(var pd: tprocdef; const realname: string; newparentst: tsymtable; newstruct: tabstractrecorddef); 99 100 { checks whether sym (a local or para of pd) already has a counterpart in 101 pd's parentfpstruct, and if not adds a new field to the struct with type 102 "vardef" (can be different from sym's type in case it's a call-by-reference 103 parameter, which is indicated by addrparam). If it already has a field in 104 the parentfpstruct, this field is returned. } maybe_add_sym_to_parentfpstructnull105 function maybe_add_sym_to_parentfpstruct(pd: tprocdef; sym: tsym; vardef: tdef; addrparam: boolean): tsym; 106 { given a localvarsym or paravarsym of pd, returns the field of the 107 parentfpstruct corresponding to this sym } find_sym_in_parentfpstructnull108 function find_sym_in_parentfpstruct(pd: tprocdef; sym: tsym): tsym; 109 { replaces all local and paravarsyms that have been mirrored in the 110 parentfpstruct with aliasvarsyms that redirect to these fields (used to 111 make sure that references to these syms in the owning procdef itself also 112 use the ones in the parentfpstructs) } 113 procedure redirect_parentfpstruct_local_syms(pd: tprocdef); 114 { finalises the parentfpstruct (alignment padding, ...) } 115 procedure finish_parentfpstruct(pd: tprocdef); 116 117 { turns a fieldvarsym into a class/static field definition, and returns the 118 created staticvarsym that is responsible for allocating the global storage } make_field_staticnull119 function make_field_static(recst: tsymtable; fieldvs: tfieldvarsym): tstaticvarsym; 120 121 { create a new procdef with the signature of orgpd and (mangled) name 122 newname, and change the implementation of orgpd so that it calls through 123 to this new procedure } 124 procedure call_through_new_name(orgpd: tprocdef; const newname: TSymStr); 125 generate_pkg_stubnull126 function generate_pkg_stub(pd:tprocdef):tnode; 127 128 129 130 implementation 131 132 uses 133 cutils,cclasses,globals,verbose,systems,comphook,fmodule,constexp, 134 symtable,defutil,symutil, 135 pbase,pdecobj,pdecsub,psub,ptconst,pparautl, 136 {$ifdef jvm} 137 pjvm,jvmdef, 138 {$endif jvm} 139 nbas,nld,nmem,ncon, 140 defcmp, 141 paramgr; 142 143 procedure replace_scanner(const tempname: string; out sstate: tscannerstate); 144 var 145 old_block_type: tblock_type; 146 begin 147 { would require saving of cstringpattern, patternw } 148 if (token=_CSTRING) or 149 (token=_CWCHAR) or 150 (token=_CWSTRING) then 151 internalerror(2011032201); 152 sstate.old_scanner:=current_scanner; 153 sstate.old_filepos:=current_filepos; 154 sstate.old_token:=token; 155 sstate.old_c:=c; 156 sstate.old_orgpattern:=orgpattern; 157 sstate.old_modeswitches:=current_settings.modeswitches; 158 sstate.old_idtoken:=idtoken; 159 sstate.valid:=true; 160 { creating a new scanner resets the block type, while we want to continue 161 in the current one } 162 old_block_type:=block_type; 163 current_scanner:=tscannerfile.Create('_Macro_.'+tempname,true); 164 block_type:=old_block_type; 165 { required for e.g. FpcDeepCopy record method (uses "out" parameter; field 166 names are escaped via &, so should not cause conflicts } 167 current_settings.modeswitches:=objfpcmodeswitches; 168 end; 169 170 171 procedure restore_scanner(const sstate: tscannerstate); 172 begin 173 if sstate.valid then 174 begin 175 current_scanner.free; 176 current_scanner:=sstate.old_scanner; 177 current_filepos:=sstate.old_filepos; 178 token:=sstate.old_token; 179 current_settings.modeswitches:=sstate.old_modeswitches; 180 c:=sstate.old_c; 181 orgpattern:=sstate.old_orgpattern; 182 pattern:=upper(sstate.old_orgpattern); 183 idtoken:=sstate.old_idtoken; 184 end; 185 end; 186 187 str_parse_method_decnull188 function str_parse_method_dec(str: ansistring; potype: tproctypeoption; is_classdef: boolean; astruct: tabstractrecorddef; out pd: tprocdef): boolean; 189 var 190 oldparse_only: boolean; 191 begin 192 Message1(parser_d_internal_parser_string,str); 193 oldparse_only:=parse_only; 194 parse_only:=true; 195 result:=false; 196 { in case multiple strings are injected, make sure to always close the 197 previous macro inputfile to prevent memory leaks } 198 if assigned(current_scanner.inputfile) and 199 not(current_scanner.inputfile.closed) then 200 current_scanner.closeinputfile; 201 { inject the string in the scanner } 202 str:=str+'end;'; 203 current_scanner.substitutemacro('meth_head_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index); 204 current_scanner.readtoken(false); 205 { and parse it... } 206 case potype of 207 potype_class_constructor: 208 pd:=class_constructor_head(astruct); 209 potype_class_destructor: 210 pd:=class_destructor_head(astruct); 211 potype_constructor: 212 pd:=constructor_head; 213 potype_destructor: 214 pd:=destructor_head; 215 else if assigned(astruct) and 216 (astruct.typ=recorddef) then 217 pd:=parse_record_method_dec(astruct,is_classdef,false) 218 else 219 pd:=method_dec(astruct,is_classdef,false); 220 end; 221 if assigned(pd) then 222 result:=true; 223 parse_only:=oldparse_only; 224 { remove the temporary macro input file again } 225 current_scanner.closeinputfile; 226 current_scanner.nextfile; 227 current_scanner.tempopeninputfile; 228 end; 229 230 str_parse_method_impl_with_fileinfonull231 function str_parse_method_impl_with_fileinfo(str: ansistring; usefwpd: tprocdef; fileno, lineno: longint; is_classdef: boolean):boolean; 232 var 233 oldparse_only: boolean; 234 tmpstr: ansistring; 235 begin 236 if ((status.verbosity and v_debug)<>0) then 237 begin 238 if assigned(usefwpd) then 239 Message1(parser_d_internal_parser_string,usefwpd.customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker,pno_noleadingdollar])+str) 240 else 241 begin 242 if is_classdef then 243 tmpstr:='class ' 244 else 245 tmpstr:=''; 246 Message1(parser_d_internal_parser_string,tmpstr+str); 247 end; 248 end; 249 oldparse_only:=parse_only; 250 parse_only:=false; 251 result:=false; 252 { "const" starts a new kind of block and hence makes the scanner return } 253 str:=str+'const;'; 254 { inject the string in the scanner } 255 current_scanner.substitutemacro('meth_impl_macro',@str[1],length(str),lineno,fileno); 256 current_scanner.readtoken(false); 257 { and parse it... } 258 read_proc(is_classdef,usefwpd,false); 259 parse_only:=oldparse_only; 260 { remove the temporary macro input file again } 261 current_scanner.closeinputfile; 262 current_scanner.nextfile; 263 current_scanner.tempopeninputfile; 264 result:=true; 265 end; 266 267 str_parse_method_implnull268 function str_parse_method_impl(const str: ansistring; usefwpd: tprocdef; is_classdef: boolean):boolean; 269 begin 270 result:=str_parse_method_impl_with_fileinfo(str, usefwpd, current_scanner.inputfile.ref_index, current_scanner.line_no, is_classdef); 271 end; 272 273 274 procedure str_parse_typedconst(list: TAsmList; str: ansistring; ssym: tstaticvarsym); 275 var 276 old_block_type: tblock_type; 277 old_parse_only: boolean; 278 begin 279 Message1(parser_d_internal_parser_string,str); 280 { a string that will be interpreted as the start of a new section -> 281 typed constant parsing will stop } 282 str:=str+'type '; 283 old_parse_only:=parse_only; 284 old_block_type:=block_type; 285 parse_only:=true; 286 block_type:=bt_const; 287 current_scanner.substitutemacro('typed_const_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index); 288 current_scanner.readtoken(false); 289 read_typed_const(list,ssym,ssym.owner.symtabletype in [recordsymtable,objectsymtable]); 290 parse_only:=old_parse_only; 291 block_type:=old_block_type; 292 { remove the temporary macro input file again } 293 current_scanner.closeinputfile; 294 current_scanner.nextfile; 295 current_scanner.tempopeninputfile; 296 end; 297 298 def_unit_name_prefix_if_toplevelnull299 function def_unit_name_prefix_if_toplevel(def: tdef): TSymStr; 300 begin 301 result:=''; 302 { if the routine is a global routine in a unit, explicitly use this unit 303 name to avoid accidentally calling other same-named routines that may be 304 in scope } 305 if not assigned(def.owner.defowner) and 306 assigned(def.owner.realname) and 307 (def.owner.moduleid<>0) then 308 result:=def.owner.realname^+'.'; 309 end; 310 311 312 procedure add_missing_parent_constructors_intf(obj: tobjectdef; addvirtclassmeth: boolean; forcevis: tvisibility); 313 var 314 parent: tobjectdef; 315 def: tdef; 316 parentpd, 317 childpd: tprocdef; 318 i: longint; 319 srsym: tsym; 320 srsymtable: tsymtable; 321 begin 322 if (oo_is_external in obj.objectoptions) or 323 not assigned(obj.childof) then 324 exit; 325 parent:=obj.childof; 326 { find all constructor in the parent } 327 for i:=0 to tobjectsymtable(parent.symtable).deflist.count-1 do 328 begin 329 def:=tdef(tobjectsymtable(parent.symtable).deflist[i]); 330 if (def.typ<>procdef) or 331 ((tprocdef(def).proctypeoption<>potype_constructor) and 332 (not addvirtclassmeth or 333 not([po_classmethod,po_virtualmethod]<=tprocdef(def).procoptions))) or 334 not is_visible_for_object(tprocdef(def),obj) then 335 continue; 336 parentpd:=tprocdef(def); 337 { do we have this constructor too? (don't use 338 search_struct_member/searchsym_in_class, since those will 339 search parents too) } 340 if searchsym_in_record(obj,parentpd.procsym.name,srsym,srsymtable) then 341 begin 342 { there's a symbol with the same name, is it a routine of the 343 same type with the same parameters? } 344 if srsym.typ=procsym then 345 begin 346 childpd:=tprocsym(srsym).find_procdef_bytype_and_para( 347 tprocdef(def).proctypeoption,parentpd.paras,nil, 348 [cpo_ignorehidden,cpo_ignoreuniv,cpo_openequalisexact]); 349 if assigned(childpd) then 350 continue; 351 end; 352 end; 353 { if we get here, we did not find it in the current objectdef -> 354 add } 355 childpd:=tprocdef(parentpd.getcopy); 356 { get rid of the import name for inherited virtual class methods, 357 it has to be regenerated rather than amended } 358 if [po_classmethod,po_virtualmethod]<=childpd.procoptions then 359 begin 360 stringdispose(childpd.import_name); 361 exclude(childpd.procoptions,po_has_importname); 362 end; 363 if forcevis<>vis_none then 364 childpd.visibility:=forcevis; 365 if po_virtualmethod in childpd.procoptions then 366 include(childpd.procoptions,po_overridingmethod); 367 { ignore this artificially added procdef when looking for overloads } 368 include(childpd.procoptions,po_ignore_for_overload_resolution); 369 finish_copied_procdef(childpd,parentpd.procsym.realname,obj.symtable,obj); 370 exclude(childpd.procoptions,po_external); 371 childpd.synthetickind:=tsk_anon_inherited; 372 include(obj.objectoptions,oo_has_constructor); 373 end; 374 end; 375 376 377 procedure implement_anon_inherited(pd: tprocdef); 378 var 379 str: ansistring; 380 isclassmethod: boolean; 381 begin 382 isclassmethod:= 383 (po_classmethod in pd.procoptions) and 384 not(pd.proctypeoption in [potype_constructor,potype_destructor]); 385 str:='begin '; 386 if (pd.proctypeoption<>potype_constructor) and 387 not is_void(pd.returndef) then 388 str:=str+'result:='; 389 str:=str+'inherited end;'; 390 str_parse_method_impl(str,pd,isclassmethod); 391 end; 392 393 394 procedure implement_jvm_clone(pd: tprocdef); 395 var 396 struct: tabstractrecorddef; 397 str: ansistring; 398 i: longint; 399 sym: tsym; 400 fsym: tfieldvarsym; 401 begin 402 if not(pd.struct.typ in [recorddef,objectdef]) then 403 internalerror(2011032802); 404 struct:=pd.struct; 405 { anonymous record types must get an artificial name, so we can generate 406 a typecast at the scanner level } 407 if (struct.typ=recorddef) and 408 not assigned(struct.typesym) then 409 internalerror(2011032812); 410 { We cannot easily use the inherited clone in case we have to create a 411 deep copy of certain fields. The reason is that e.g. sets are pointers 412 at the JVM level, but not in Pascal. So the JVM clone routine will copy 413 the pointer to the set from the old record (= class instance) to the new 414 one, but we have no way to change this pointer itself from inside Pascal 415 code. 416 417 We solve this by relying on the fact that the JVM is garbage collected: 418 we simply declare a temporary instance on the stack, which will be 419 allocated/initialized by the temp generator. We return its address as 420 the result of the clone routine, so it remains live. } 421 str:='var __fpc_newcopy:'+ struct.typesym.realname+'; begin clone:=JLObject(@__fpc_newcopy);'; 422 { copy all field contents } 423 for i:=0 to struct.symtable.symlist.count-1 do 424 begin 425 sym:=tsym(struct.symtable.symlist[i]); 426 if (sym.typ=fieldvarsym) then 427 begin 428 fsym:=tfieldvarsym(sym); 429 str:=str+'__fpc_newcopy.&'+fsym.realname+':=&'+fsym.realname+';'; 430 end; 431 end; 432 str:=str+'end;'; 433 str_parse_method_impl(str,pd,false); 434 end; 435 436 437 procedure implement_record_deepcopy(pd: tprocdef); 438 var 439 struct: tabstractrecorddef; 440 str: ansistring; 441 i: longint; 442 sym: tsym; 443 fsym: tfieldvarsym; 444 begin 445 if not(pd.struct.typ in [recorddef,objectdef]) then 446 internalerror(2011032810); 447 struct:=pd.struct; 448 { anonymous record types must get an artificial name, so we can generate 449 a typecast at the scanner level } 450 if (struct.typ=recorddef) and 451 not assigned(struct.typesym) then 452 internalerror(2011032811); 453 { copy all fields } 454 str:='type _fpc_ptrt = ^'+struct.typesym.realname+'; var res: _fpc_ptrt; begin res:=_fpc_ptrt(result);'; 455 for i:=0 to struct.symtable.symlist.count-1 do 456 begin 457 sym:=tsym(struct.symtable.symlist[i]); 458 if (sym.typ=fieldvarsym) then 459 begin 460 fsym:=tfieldvarsym(sym); 461 str:=str+'res^.&'+fsym.realname+':=&'+fsym.realname+';'; 462 end; 463 end; 464 str:=str+'end;'; 465 str_parse_method_impl(str,pd,false); 466 end; 467 468 469 procedure implement_record_initialize(pd: tprocdef); 470 var 471 struct: tabstractrecorddef; 472 str: ansistring; 473 i: longint; 474 sym: tsym; 475 fsym: tfieldvarsym; 476 begin 477 if not(pd.struct.typ in [recorddef,objectdef]) then 478 internalerror(2011071710); 479 struct:=pd.struct; 480 { anonymous record types must get an artificial name, so we can generate 481 a typecast at the scanner level } 482 if (struct.typ=recorddef) and 483 not assigned(struct.typesym) then 484 internalerror(2011032811); 485 { walk over all fields that need initialization } 486 str:='begin '; 487 for i:=0 to struct.symtable.symlist.count-1 do 488 begin 489 sym:=tsym(struct.symtable.symlist[i]); 490 if (sym.typ=fieldvarsym) then 491 begin 492 fsym:=tfieldvarsym(sym); 493 if fsym.vardef.needs_inittable then 494 str:=str+'system.initialize(&'+fsym.realname+');'; 495 end; 496 end; 497 str:=str+'end;'; 498 str_parse_method_impl(str,pd,false); 499 end; 500 501 procedure implement_empty(pd: tprocdef); 502 var 503 str: ansistring; 504 isclassmethod: boolean; 505 begin 506 isclassmethod:= 507 (po_classmethod in pd.procoptions) and 508 not(pd.proctypeoption in [potype_constructor,potype_destructor]); 509 str:='begin end;'; 510 str_parse_method_impl(str,pd,isclassmethod); 511 end; 512 513 514 procedure addvisibleparameters(var str: ansistring; pd: tprocdef); 515 var 516 currpara: tparavarsym; 517 i: longint; 518 firstpara: boolean; 519 begin 520 firstpara:=true; 521 for i:=0 to pd.paras.count-1 do 522 begin 523 currpara:=tparavarsym(pd.paras[i]); 524 if not(vo_is_hidden_para in currpara.varoptions) then 525 begin 526 if not firstpara then 527 str:=str+','; 528 firstpara:=false; 529 str:=str+'&'+currpara.realname; 530 end; 531 end; 532 end; 533 534 535 536 procedure implement_callthrough(pd: tprocdef); 537 var 538 str: ansistring; 539 callpd: tprocdef; 540 isclassmethod: boolean; 541 begin 542 isclassmethod:= 543 (po_classmethod in pd.procoptions) and 544 not(pd.proctypeoption in [potype_constructor,potype_destructor]); 545 callpd:=tprocdef(pd.skpara); 546 str:='begin '; 547 if pd.returndef<>voidtype then 548 str:=str+'result:='; 549 { if the routine is a global routine in a unit/program, explicitly 550 mnetion this program/unit name to avoid accidentally calling other 551 same-named routines that may be in scope } 552 str:=str+def_unit_name_prefix_if_toplevel(callpd)+callpd.procsym.realname+'('; 553 addvisibleparameters(str,pd); 554 str:=str+') end;'; 555 str_parse_method_impl(str,pd,isclassmethod); 556 end; 557 558 559 {$ifdef jvm} 560 procedure implement_jvm_enum_values(pd: tprocdef); 561 begin 562 str_parse_method_impl('begin result:=__fpc_FVALUES end;',pd,true); 563 end; 564 565 566 procedure implement_jvm_enum_valuof(pd: tprocdef); 567 begin 568 str_parse_method_impl('begin result:=__FPC_TEnumClassAlias(inherited valueOf(JLClass(__FPC_TEnumClassAlias),__fpc_str)) end;',pd,true); 569 end; 570 571 572 procedure implement_jvm_enum_jumps_constr(pd: tprocdef); 573 begin 574 str_parse_method_impl('begin inherited create(__fpc_name,__fpc_ord); __fpc_fenumval:=__fpc_initenumval end;',pd,false); 575 end; 576 577 578 procedure implement_jvm_enum_fpcordinal(pd: tprocdef); 579 var 580 enumclass: tobjectdef; 581 enumdef: tenumdef; 582 begin 583 enumclass:=tobjectdef(pd.owner.defowner); 584 enumdef:=tenumdef(ttypesym(search_struct_member(enumclass,'__FPC_TENUMALIAS')).typedef); 585 if not enumdef.has_jumps then 586 str_parse_method_impl('begin result:=ordinal end;',pd,false) 587 else 588 str_parse_method_impl('begin result:=__fpc_fenumval end;',pd,false); 589 end; 590 591 592 procedure implement_jvm_enum_fpcvalueof(pd: tprocdef); 593 var 594 enumclass: tobjectdef; 595 enumdef: tenumdef; 596 isclassmethod: boolean; 597 begin 598 isclassmethod:= 599 (po_classmethod in pd.procoptions) and 600 not(pd.proctypeoption in [potype_constructor,potype_destructor]); 601 enumclass:=tobjectdef(pd.owner.defowner); 602 enumdef:=tenumdef(ttypesym(search_struct_member(enumclass,'__FPC_TENUMALIAS')).typedef); 603 { convert integer to corresponding enum instance: in case of no jumps 604 get it from the $VALUES array, otherwise from the __fpc_ord2enum 605 hashmap } 606 if not enumdef.has_jumps then 607 str_parse_method_impl('begin result:=__fpc_FVALUES[__fpc_int] end;',pd,isclassmethod) 608 else 609 str_parse_method_impl('begin result:=__FPC_TEnumClassAlias(__fpc_ord2enum.get(JLInteger.valueOf(__fpc_int))) end;',pd,isclassmethod); 610 end; 611 612 CompareEnumSymsnull613 function CompareEnumSyms(Item1, Item2: Pointer): Integer; 614 var 615 I1 : tenumsym absolute Item1; 616 I2 : tenumsym absolute Item2; 617 begin 618 Result:=I1.value-I2.value; 619 end; 620 621 622 procedure implement_jvm_enum_classconstr(pd: tprocdef); 623 var 624 enumclass: tobjectdef; 625 enumdef: tenumdef; 626 enumname, 627 str: ansistring; 628 i: longint; 629 enumsym: tenumsym; 630 orderedenums: tfpobjectlist; 631 begin 632 enumclass:=tobjectdef(pd.owner.defowner); 633 enumdef:=tenumdef(ttypesym(search_struct_member(enumclass,'__FPC_TENUMALIAS')).typedef); 634 if not assigned(enumdef) then 635 internalerror(2011062305); 636 str:='begin '; 637 if enumdef.has_jumps then 638 { init hashmap for ordinal -> enum instance mapping; don't let it grow, 639 and set the capacity to the next prime following the total number of 640 enum elements to minimise the number of collisions } 641 str:=str+'__fpc_ord2enum:=JUHashMap.Create('+tostr(next_prime(enumdef.symtable.symlist.count))+',1.0);'; 642 { iterate over all enum elements and initialise the class fields, and 643 store them in the values array. Since the java.lang.Enum doCompare 644 method is final and hardcoded to compare based on declaration order 645 (= java.lang.Enum.ordinal() value), we have to create them in order of 646 ascending FPC ordinal values (which may not be the same as the FPC 647 declaration order in case of jumps } 648 orderedenums:=tfpobjectlist.create(false); 649 for i:=0 to enumdef.symtable.symlist.count-1 do 650 orderedenums.add(enumdef.symtable.symlist[i]); 651 if enumdef.has_jumps then 652 orderedenums.sort(@CompareEnumSyms); 653 for i:=0 to orderedenums.count-1 do 654 begin 655 enumsym:=tenumsym(orderedenums[i]); 656 enumname:=enumsym.realname; 657 str:=str+enumsym.name+':=__FPC_TEnumClassAlias.Create('''+enumname+''','+tostr(i); 658 if enumdef.has_jumps then 659 str:=str+','+tostr(enumsym.value); 660 str:=str+');'; 661 { alias for $VALUES array used internally by the JDK, and also by FPC 662 in case of no jumps } 663 str:=str+'__fpc_FVALUES['+tostr(i)+']:='+enumname+';'; 664 if enumdef.has_jumps then 665 str:=str+'__fpc_ord2enum.put(JLInteger.valueOf('+tostr(enumsym.value)+'),'+enumname+');'; 666 end; 667 orderedenums.free; 668 str:=str+' end;'; 669 str_parse_method_impl(str,pd,true); 670 end; 671 672 673 procedure implement_jvm_enum_long2set(pd: tprocdef); 674 begin 675 str_parse_method_impl( 676 'var '+ 677 'i, setval: jint;'+ 678 'begin '+ 679 'result:=JUEnumSet.noneOf(JLClass(__FPC_TEnumClassAlias));'+ 680 'if __val<>0 then '+ 681 'begin '+ 682 '__setsize:=__setsize*8;'+ 683 'for i:=0 to __setsize-1 do '+ 684 // setsize-i because JVM = big endian 685 'if (__val and (jlong(1) shl (__setsize-i)))<>0 then '+ 686 'result.add(fpcValueOf(i+__setbase));'+ 687 'end '+ 688 'end;', 689 pd,true); 690 end; 691 692 693 procedure implement_jvm_enum_bitset2set(pd: tprocdef); 694 begin 695 str_parse_method_impl( 696 'var '+ 697 'i, setval: jint;'+ 698 'begin '+ 699 'result:=JUEnumSet.noneOf(JLClass(__FPC_TEnumClassAlias));'+ 700 'i:=__val.nextSetBit(0);'+ 701 'while i>=0 do '+ 702 'begin '+ 703 'setval:=-__fromsetbase;'+ 704 'result.add(fpcValueOf(setval+__tosetbase));'+ 705 'i:=__val.nextSetBit(i+1);'+ 706 'end '+ 707 'end;', 708 pd,true); 709 end; 710 711 712 procedure implement_jvm_enum_set2set(pd: tprocdef); 713 begin 714 str_parse_method_impl( 715 'var '+ 716 'it: JUIterator;'+ 717 'ele: FpcEnumValueObtainable;'+ 718 'i: longint;'+ 719 'begin '+ 720 'result:=JUEnumSet.noneOf(JLClass(__FPC_TEnumClassAlias));'+ 721 'it:=__val.iterator;'+ 722 'while it.hasNext do '+ 723 'begin '+ 724 'ele:=FpcEnumValueObtainable(it.next);'+ 725 'i:=ele.fpcOrdinal-__fromsetbase;'+ 726 'result.add(fpcValueOf(i+__tosetbase));'+ 727 'end '+ 728 'end;', 729 pd,true); 730 end; 731 732 733 procedure implement_jvm_procvar_invoke(pd: tprocdef); 734 var 735 pvclass: tobjectdef; 736 procvar: tprocvardef; 737 paraname,str,endstr: ansistring; 738 pvs: tparavarsym; 739 paradef,boxdef,boxargdef: tdef; 740 i: longint; 741 firstpara: boolean; 742 begin 743 pvclass:=tobjectdef(pd.owner.defowner); 744 procvar:=tprocvardef(ttypesym(search_struct_member(pvclass,'__FPC_PROCVARALIAS')).typedef); 745 { the procvar wrapper class has a tmethod member called "method", whose 746 "code" field is a JLRMethod, and whose "data" field is the self pointer 747 if any (if none is required, it's ignored by the JVM, so there's no 748 problem with always passing it) } 749 750 { force extended syntax to allow calling invokeObjectFunc() without using 751 its result } 752 str:=''; 753 endstr:=''; 754 { create local pointer to result type for typecasting in case of an 755 implicit pointer type } 756 if jvmimplicitpointertype(procvar.returndef) then 757 str:=str+'type __FPC_returnptrtype = ^'+procvar.returndef.typename+';'; 758 str:=str+'begin '; 759 { result handling (skip for generic definitions, we'll generate a new 760 version for the specialized definition) ) } 761 if not is_void(procvar.returndef) and 762 (procvar.returndef.typ<>undefineddef) then 763 begin 764 str:=str+'invoke:='; 765 if procvar.returndef.typ in [orddef,floatdef] then 766 begin 767 { primitivetype(boxtype(..).unboxmethod) } 768 jvmgetboxtype(procvar.returndef,boxdef,boxargdef,false); 769 str:=str+procvar.returndef.typename+'('+boxdef.typename+'('; 770 endstr:=').'+jvmgetunboxmethod(procvar.returndef)+')'; 771 end 772 else if jvmimplicitpointertype(procvar.returndef) then 773 begin 774 str:=str+'__FPC_returnptrtype('; 775 { dereference } 776 endstr:=')^'; 777 end 778 else 779 begin 780 str:=str+procvar.returndef.typename+'('; 781 endstr:=')'; 782 end; 783 end; 784 str:=str+'invokeObjectFunc(['; 785 { parameters are a constant array of jlobject } 786 firstpara:=true; 787 for i:=0 to procvar.paras.count-1 do 788 begin 789 { skip self/vmt/parentfp, passed separately } 790 pvs:=tparavarsym(procvar.paras[i]); 791 if ([vo_is_self,vo_is_vmt,vo_is_parentfp]*pvs.varoptions)<>[] then 792 continue; 793 if not firstpara then 794 str:=str+','; 795 firstpara:=false; 796 paraname:=pvs.realname; 797 paradef:=pvs.vardef; 798 { Pascalize hidden high parameter } 799 if vo_is_high_para in pvs.varoptions then 800 paraname:='high('+tparavarsym(procvar.paras[i-1]).realname+')' 801 else if vo_is_hidden_para in pvs.varoptions then 802 begin 803 if ([vo_is_range_check,vo_is_overflow_check]*pvs.varoptions)<>[] then 804 { ok, simple boolean parameters } 805 else 806 internalerror(2011072403); 807 end; 808 { var/out/constref parameters -> pass address through (same for 809 implicit pointer types) } 810 if paramanager.push_copyout_param(pvs.varspez,paradef,procvar.proccalloption) or 811 jvmimplicitpointertype(paradef) then 812 begin 813 paraname:='@'+paraname; 814 paradef:=java_jlobject; 815 end; 816 if paradef.typ in [orddef,floatdef] then 817 begin 818 { box primitive types; use valueOf() rather than create because it 819 can give better performance } 820 jvmgetboxtype(paradef,boxdef,boxargdef,false); 821 str:=str+boxdef.typename+'.valueOf('+boxargdef.typename+'('+paraname+'))' 822 end 823 else 824 str:=str+'JLObject('+paraname+')'; 825 end; 826 str:=str+'])'+endstr+' end;'; 827 str_parse_method_impl(str,pd,false) 828 end; 829 830 831 procedure implement_jvm_procvar_intconstr(pd: tprocdef); 832 var 833 pvdef: tprocvardef; 834 begin 835 { ideal, and most performant, would be to keep the interface instance 836 passed to the constructor around and always call its method directly 837 rather than working via reflection. Unfortunately, the procvar semantics 838 that allow directly modifying the procvar via typecasting it to a 839 tmethod make this very hard. 840 841 So for now we simply take the address of the interface instance's 842 method and assign it to the tmethod of this procvar } 843 844 pvdef:=tprocvardef(pd.skpara); 845 str_parse_method_impl('begin method:=System.TMethod(@__intf.'+pvdef.typesym.RealName+'Callback) end;',pd,false); 846 end; 847 848 849 procedure implement_jvm_virtual_clmethod(pd: tprocdef); 850 var 851 str: ansistring; 852 callpd: tprocdef; 853 begin 854 callpd:=tprocdef(pd.skpara); 855 str:='var pv: __fpc_virtualclassmethod_pv_t'+pd.unique_id_str+'; begin ' 856 + 'pv:=@'+callpd.procsym.RealName+';'; 857 if (pd.proctypeoption<>potype_constructor) and 858 not is_void(pd.returndef) then 859 str:=str+'result:='; 860 str:=str+'pv('; 861 addvisibleparameters(str,pd); 862 str:=str+') end;'; 863 str_parse_method_impl(str,pd,true) 864 end; 865 {$endif jvm} 866 867 procedure implement_field_getter(pd: tprocdef); 868 var 869 i: longint; 870 pvs: tparavarsym; 871 str: ansistring; 872 callthroughprop: tpropertysym; 873 propaccesslist: tpropaccesslist; 874 lastparanr: longint; 875 firstpara: boolean; 876 begin 877 callthroughprop:=tpropertysym(pd.skpara); 878 str:='begin result:='+callthroughprop.realname; 879 if ppo_hasparameters in callthroughprop.propoptions then 880 begin 881 if not callthroughprop.getpropaccesslist(palt_read,propaccesslist) then 882 internalerror(2012100701); 883 str:=str+'['; 884 firstpara:=true; 885 lastparanr:=tprocdef(propaccesslist.procdef).paras.count-1; 886 if ppo_indexed in callthroughprop.propoptions then 887 dec(lastparanr); 888 for i:=0 to lastparanr do 889 begin 890 { skip self/vmt/parentfp, passed implicitly } 891 pvs:=tparavarsym(tprocdef(propaccesslist.procdef).paras[i]); 892 if ([vo_is_self,vo_is_vmt,vo_is_parentfp]*pvs.varoptions)<>[] then 893 continue; 894 if not firstpara then 895 str:=str+','; 896 firstpara:=false; 897 str:=str+pvs.realname; 898 end; 899 str:=str+']'; 900 end; 901 str:=str+'; end;'; 902 str_parse_method_impl(str,pd,po_classmethod in pd.procoptions) 903 end; 904 905 906 procedure implement_field_setter(pd: tprocdef); 907 var 908 i, lastparaindex: longint; 909 pvs: tparavarsym; 910 paraname, str: ansistring; 911 callthroughprop: tpropertysym; 912 propaccesslist: tpropaccesslist; 913 firstpara: boolean; 914 begin 915 callthroughprop:=tpropertysym(pd.skpara); 916 str:='begin '+callthroughprop.realname; 917 if not callthroughprop.getpropaccesslist(palt_write,propaccesslist) then 918 internalerror(2012100702); 919 if ppo_hasparameters in callthroughprop.propoptions then 920 begin 921 str:=str+'['; 922 firstpara:=true; 923 { last parameter is the value to be set, skip (only add index 924 parameters here) } 925 lastparaindex:=tprocdef(propaccesslist.procdef).paras.count-2; 926 if ppo_indexed in callthroughprop.propoptions then 927 dec(lastparaindex); 928 for i:=0 to lastparaindex do 929 begin 930 { skip self/vmt/parentfp/index, passed implicitly } 931 pvs:=tparavarsym(tprocdef(propaccesslist.procdef).paras[i]); 932 if ([vo_is_self,vo_is_vmt,vo_is_parentfp]*pvs.varoptions)<>[] then 933 continue; 934 if not firstpara then 935 str:=str+','; 936 firstpara:=false; 937 str:=str+pvs.realname; 938 end; 939 str:=str+']'; 940 end; 941 { the value-to-be-set } 942 if assigned(propaccesslist.procdef) then 943 begin 944 pvs:=tparavarsym(tprocdef(propaccesslist.procdef).paras[tprocdef(propaccesslist.procdef).paras.count-1]); 945 paraname:=pvs.realname; 946 end 947 else 948 paraname:='__fpc_newval__'; 949 str:=str+':='+paraname+'; end;'; 950 str_parse_method_impl(str,pd,po_classmethod in pd.procoptions) 951 end; 952 953 954 procedure implement_block_invoke_procvar(pd: tprocdef); 955 var 956 str: ansistring; 957 begin 958 str:=''; 959 str:='begin '; 960 if pd.returndef<>voidtype then 961 str:=str+'result:='; 962 str:=str+'__FPC_BLOCK_INVOKE_PV_TYPE(PFPC_Block_literal_complex_procvar(FPC_Block_Self)^.pv)('; 963 addvisibleparameters(str,pd); 964 str:=str+') end;'; 965 str_parse_method_impl(str,pd,false); 966 end; 967 968 969 procedure implement_interface_wrapper(pd: tprocdef); 970 var 971 wrapperinfo: pskpara_interface_wrapper; 972 callthroughpd: tprocdef; 973 str: ansistring; 974 fileinfo: tfileposinfo; 975 begin 976 wrapperinfo:=pskpara_interface_wrapper(pd.skpara); 977 if not assigned(wrapperinfo) then 978 internalerror(2015090801); 979 callthroughpd:=tprocdef(wrapperinfo^.pd); 980 str:='begin '; 981 { self right now points to the VMT of interface inside the instance -> 982 adjust so it points to the start of the instance } 983 str:=str+'pointer(self):=pointer(self) - '+tostr(wrapperinfo^.offset)+';'; 984 { now call through to the actual method } 985 if pd.returndef<>voidtype then 986 str:=str+'result:='; 987 str:=str+'&'+callthroughpd.procsym.realname+'('; 988 addvisibleparameters(str,pd); 989 str:=str+') end;'; 990 { add dummy file info so we can step in/through it } 991 if pd.owner.iscurrentunit then 992 fileinfo:=pd.fileinfo 993 else 994 begin 995 fileinfo.moduleindex:=current_module.moduleid; 996 fileinfo.fileindex:=1; 997 fileinfo.line:=1; 998 fileinfo.column:=1; 999 end; 1000 str_parse_method_impl_with_fileinfo(str,pd,fileinfo.fileindex,fileinfo.line,false); 1001 dispose(wrapperinfo); 1002 pd.skpara:=nil; 1003 end; 1004 1005 1006 procedure implement_call_no_parameters(pd: tprocdef); 1007 var 1008 callpd: tprocdef; 1009 str: ansistring; 1010 warningson, 1011 isclassmethod: boolean; 1012 begin 1013 { avoid warnings about unset function results in these abstract wrappers } 1014 warningson:=(status.verbosity and V_Warning)<>0; 1015 setverbosity('W-'); 1016 str:='begin '; 1017 callpd:=tprocdef(pd.skpara); 1018 str:=str+def_unit_name_prefix_if_toplevel(callpd)+callpd.procsym.realname+'; end;'; 1019 isclassmethod:= 1020 (po_classmethod in pd.procoptions) and 1021 not(pd.proctypeoption in [potype_constructor,potype_destructor]); 1022 str_parse_method_impl(str,pd,isclassmethod); 1023 if warningson then 1024 setverbosity('W+'); 1025 end; 1026 1027 1028 procedure add_synthetic_method_implementations_for_st(st: tsymtable); 1029 var 1030 i : longint; 1031 def : tdef; 1032 pd : tprocdef; 1033 begin 1034 for i:=0 to st.deflist.count-1 do 1035 begin 1036 def:=tdef(st.deflist[i]); 1037 if (def.typ<>procdef) then 1038 continue; 1039 { skip methods when processing unit symtable } 1040 if def.owner<>st then 1041 continue; 1042 pd:=tprocdef(def); 1043 case pd.synthetickind of 1044 tsk_none: 1045 ; 1046 tsk_anon_inherited: 1047 implement_anon_inherited(pd); 1048 tsk_jvm_clone: 1049 implement_jvm_clone(pd); 1050 tsk_record_deepcopy: 1051 implement_record_deepcopy(pd); 1052 tsk_record_initialize: 1053 implement_record_initialize(pd); 1054 tsk_empty, 1055 { special handling for this one is done in tnodeutils.wrap_proc_body } 1056 tsk_tcinit: 1057 implement_empty(pd); 1058 tsk_callthrough: 1059 implement_callthrough(pd); 1060 tsk_callthrough_nonabstract: 1061 begin 1062 if (pd.owner.defowner.typ<>objectdef) or 1063 (tobjectdef(pd.owner.defowner).abstractcnt=0) then 1064 implement_callthrough(pd) 1065 else 1066 implement_empty(pd); 1067 end; 1068 {$ifdef jvm} 1069 tsk_jvm_enum_values: 1070 implement_jvm_enum_values(pd); 1071 tsk_jvm_enum_valueof: 1072 implement_jvm_enum_valuof(pd); 1073 tsk_jvm_enum_classconstr: 1074 implement_jvm_enum_classconstr(pd); 1075 tsk_jvm_enum_jumps_constr: 1076 implement_jvm_enum_jumps_constr(pd); 1077 tsk_jvm_enum_fpcordinal: 1078 implement_jvm_enum_fpcordinal(pd); 1079 tsk_jvm_enum_fpcvalueof: 1080 implement_jvm_enum_fpcvalueof(pd); 1081 tsk_jvm_enum_long2set: 1082 implement_jvm_enum_long2set(pd); 1083 tsk_jvm_enum_bitset2set: 1084 implement_jvm_enum_bitset2set(pd); 1085 tsk_jvm_enum_set2set: 1086 implement_jvm_enum_set2set(pd); 1087 tsk_jvm_procvar_invoke: 1088 implement_jvm_procvar_invoke(pd); 1089 tsk_jvm_procvar_intconstr: 1090 implement_jvm_procvar_intconstr(pd); 1091 tsk_jvm_virtual_clmethod: 1092 implement_jvm_virtual_clmethod(pd); 1093 {$endif jvm} 1094 tsk_field_getter: 1095 implement_field_getter(pd); 1096 tsk_field_setter: 1097 implement_field_setter(pd); 1098 tsk_block_invoke_procvar: 1099 implement_block_invoke_procvar(pd); 1100 tsk_interface_wrapper: 1101 implement_interface_wrapper(pd); 1102 tsk_call_no_parameters: 1103 implement_call_no_parameters(pd); 1104 else 1105 internalerror(2011032801); 1106 end; 1107 end; 1108 end; 1109 1110 1111 procedure add_synthetic_method_implementations(st: tsymtable); 1112 var 1113 i: longint; 1114 def: tdef; 1115 sstate: tscannerstate; 1116 begin 1117 { skip if any errors have occurred, since then this can only cause more 1118 errors } 1119 if ErrorCount<>0 then 1120 exit; 1121 replace_scanner('synthetic_impl',sstate); 1122 add_synthetic_method_implementations_for_st(st); 1123 for i:=0 to st.deflist.count-1 do 1124 begin 1125 def:=tdef(st.deflist[i]); 1126 if (def.typ=procdef) and 1127 assigned(tprocdef(def).localst) and 1128 { not true for the "main" procedure, whose localsymtable is the staticsymtable } 1129 (tprocdef(def).localst.symtabletype=localsymtable) then 1130 add_synthetic_method_implementations(tprocdef(def).localst) 1131 else if ((def.typ=objectdef) and 1132 not(oo_is_external in tobjectdef(def).objectoptions)) or 1133 (def.typ=recorddef) then 1134 begin 1135 { also complete nested types } 1136 add_synthetic_method_implementations(tabstractrecorddef(def).symtable); 1137 end; 1138 end; 1139 restore_scanner(sstate); 1140 end; 1141 1142 create_procdef_aliasnull1143 function create_procdef_alias(pd: tprocdef; const newrealname: string; const newmangledname: TSymStr; newparentst: tsymtable; newstruct: tabstractrecorddef; 1144 sk: tsynthetickind; skpara: pointer): tprocdef; 1145 begin 1146 { bare copy so we don't copy the aliasnames (specify prefix for 1147 parameter names so we don't get issues in the body in case 1148 we e.g. reference system.initialize and one of the parameters 1149 is called "system") } 1150 result:=tprocdef(pd.getcopyas(procdef,pc_bareproc,'__FPCW_')); 1151 { set the mangled name to the wrapper name } 1152 result.setmangledname(newmangledname); 1153 { finish creating the copy } 1154 finish_copied_procdef(result,newrealname,newparentst,newstruct); 1155 { now insert self/vmt } 1156 insert_self_and_vmt_para(result); 1157 { and the function result } 1158 insert_funcret_para(result); 1159 { recalculate the parameters now that we've added the missing ones } 1160 result.calcparas; 1161 { set the info required to generate the implementation } 1162 result.synthetickind:=sk; 1163 result.skpara:=skpara; 1164 end; 1165 1166 1167 procedure finish_copied_procdef(var pd: tprocdef; const realname: string; newparentst: tsymtable; newstruct: tabstractrecorddef); 1168 var 1169 sym: tsym; 1170 parasym: tparavarsym; 1171 ps: tprocsym; 1172 stname: string; 1173 i: longint; 1174 begin 1175 { add generic flag if required } 1176 if assigned(newstruct) and 1177 (df_generic in newstruct.defoptions) then 1178 include(pd.defoptions,df_generic); 1179 { associate the procdef with a procsym in the owner } 1180 if not(pd.proctypeoption in [potype_class_constructor,potype_class_destructor]) then 1181 stname:=upper(realname) 1182 else 1183 stname:=lower(realname); 1184 sym:=tsym(newparentst.find(stname)); 1185 if assigned(sym) then 1186 begin 1187 if sym.typ<>procsym then 1188 internalerror(2011040601); 1189 ps:=tprocsym(sym); 1190 end 1191 else 1192 begin 1193 ps:=cprocsym.create(realname); 1194 newparentst.insert(ps); 1195 end; 1196 pd.procsym:=ps; 1197 pd.struct:=newstruct; 1198 { in case of methods, replace the special parameter types with new ones } 1199 if assigned(newstruct) then 1200 begin 1201 symtablestack.push(pd.parast); 1202 { may not be assigned in case we converted a procvar into a procdef } 1203 if assigned(pd.paras) then 1204 begin 1205 for i:=0 to pd.paras.count-1 do 1206 begin 1207 parasym:=tparavarsym(pd.paras[i]); 1208 if vo_is_self in parasym.varoptions then 1209 begin 1210 if parasym.vardef.typ=classrefdef then 1211 parasym.vardef:=cclassrefdef.create(newstruct) 1212 else 1213 parasym.vardef:=newstruct; 1214 end 1215 end; 1216 end; 1217 { also fix returndef in case of a constructor } 1218 if pd.proctypeoption=potype_constructor then 1219 pd.returndef:=newstruct; 1220 symtablestack.pop(pd.parast); 1221 end; 1222 pd.calcparas; 1223 proc_add_definition(pd); 1224 end; 1225 1226 maybe_add_sym_to_parentfpstructnull1227 function maybe_add_sym_to_parentfpstruct(pd: tprocdef; sym: tsym; vardef: tdef; addrparam: boolean): tsym; 1228 var 1229 fieldvardef, 1230 nestedvarsdef: tdef; 1231 nestedvarsst: tsymtable; 1232 initcode: tnode; 1233 old_filepos: tfileposinfo; 1234 symname, 1235 symrealname: TSymStr; 1236 begin 1237 nestedvarsdef:=tlocalvarsym(pd.parentfpstruct).vardef; 1238 { redirect all aliases for the function result also to the function 1239 result } 1240 if vo_is_funcret in tabstractvarsym(sym).varoptions then 1241 begin 1242 symname:='result'; 1243 symrealname:='$result' 1244 end 1245 else 1246 begin 1247 symname:=sym.name; 1248 symrealname:=sym.realname; 1249 end; 1250 result:=search_struct_member(trecorddef(nestedvarsdef),symname); 1251 if not assigned(result) then 1252 begin 1253 { mark that this symbol is mirrored in the parentfpstruct } 1254 tabstractnormalvarsym(sym).inparentfpstruct:=true; 1255 { add field to the struct holding all locals accessed 1256 by nested routines } 1257 nestedvarsst:=trecorddef(nestedvarsdef).symtable; 1258 { indicate whether or not this is a var/out/constref/... parameter } 1259 if addrparam then 1260 fieldvardef:=cpointerdef.getreusable(vardef) 1261 else 1262 fieldvardef:=vardef; 1263 result:=cfieldvarsym.create(symrealname,vs_value,fieldvardef,[]); 1264 if nestedvarsst.symlist.count=0 then 1265 include(tfieldvarsym(result).varoptions,vo_is_first_field); 1266 nestedvarsst.insert(result); 1267 trecordsymtable(nestedvarsst).addfield(tfieldvarsym(result),vis_public); 1268 1269 { add initialization with original value if it's a parameter } 1270 if (sym.typ=paravarsym) then 1271 begin 1272 old_filepos:=current_filepos; 1273 fillchar(current_filepos,sizeof(current_filepos),0); 1274 initcode:=cloadnode.create(sym,sym.owner); 1275 { indicate that this load should not be transformed into a load 1276 from the parentfpstruct, but instead should load the original 1277 value } 1278 include(initcode.flags,nf_internal); 1279 { in case it's a var/out/constref parameter, store the address of the 1280 parameter in the struct } 1281 if addrparam then 1282 begin 1283 initcode:=caddrnode.create_internal(initcode); 1284 include(taddrnode(initcode).addrnodeflags,anf_typedaddr); 1285 end; 1286 initcode:=cassignmentnode.create( 1287 csubscriptnode.create(result,cloadnode.create(pd.parentfpstruct,pd.parentfpstruct.owner)), 1288 initcode); 1289 tblocknode(pd.parentfpinitblock).left:=cstatementnode.create 1290 (initcode,tblocknode(pd.parentfpinitblock).left); 1291 current_filepos:=old_filepos; 1292 end; 1293 end; 1294 end; 1295 1296 1297 procedure redirect_parentfpstruct_local_syms(pd: tprocdef); 1298 var 1299 nestedvarsdef: trecorddef; 1300 sl: tpropaccesslist; 1301 fsym, 1302 lsym, 1303 aliassym: tsym; 1304 i: longint; 1305 begin 1306 nestedvarsdef:=trecorddef(tlocalvarsym(pd.parentfpstruct).vardef); 1307 for i:=0 to nestedvarsdef.symtable.symlist.count-1 do 1308 begin 1309 fsym:=tsym(nestedvarsdef.symtable.symlist[i]); 1310 if fsym.typ<>fieldvarsym then 1311 continue; 1312 lsym:=tsym(pd.localst.find(fsym.name)); 1313 if not assigned(lsym) then 1314 lsym:=tsym(pd.parast.find(fsym.name)); 1315 if not assigned(lsym) then 1316 internalerror(2011060408); 1317 { add an absolute variable that redirects to the field } 1318 sl:=tpropaccesslist.create; 1319 sl.addsym(sl_load,pd.parentfpstruct); 1320 sl.addsym(sl_subscript,tfieldvarsym(fsym)); 1321 aliassym:=cabsolutevarsym.create_ref(lsym.name,tfieldvarsym(fsym).vardef,sl); 1322 { hide the original variable (can't delete, because there 1323 may be other loadnodes that reference it) 1324 -- only for locals; hiding parameters changes the 1325 function signature } 1326 if lsym.typ<>paravarsym then 1327 hidesym(lsym); 1328 { insert the absolute variable in the localst of the 1329 routine; ignore duplicates, because this will also check the 1330 parasymtable and we want to override parameters with our local 1331 versions } 1332 pd.localst.insert(aliassym,false); 1333 end; 1334 end; 1335 1336 find_sym_in_parentfpstructnull1337 function find_sym_in_parentfpstruct(pd: tprocdef; sym: tsym): tsym; 1338 var 1339 nestedvarsdef: tdef; 1340 begin 1341 nestedvarsdef:=tlocalvarsym(pd.parentfpstruct).vardef; 1342 result:=search_struct_member(trecorddef(nestedvarsdef),sym.name); 1343 end; 1344 1345 1346 procedure finish_parentfpstruct(pd: tprocdef); 1347 begin 1348 trecordsymtable(trecorddef(tlocalvarsym(pd.parentfpstruct).vardef).symtable).addalignmentpadding; 1349 end; 1350 1351 make_field_staticnull1352 function make_field_static(recst: tsymtable; fieldvs: tfieldvarsym): tstaticvarsym; 1353 var 1354 static_name: string; 1355 hstaticvs: tstaticvarsym; 1356 tmp: tabsolutevarsym; 1357 sl: tpropaccesslist; 1358 begin 1359 include(fieldvs.symoptions,sp_static); 1360 { generate the symbol which reserves the space } 1361 static_name:=lower(generate_nested_name(recst,'_'))+'_'+fieldvs.name; 1362 hstaticvs:=cstaticvarsym.create_from_fieldvar(static_name,fieldvs); 1363 {$ifdef jvm} 1364 { for the JVM, static field accesses are name-based and 1365 hence we have to keep the original name of the field. 1366 Create a staticvarsym instead of a fieldvarsym so we can 1367 nevertheless use a loadn instead of a subscriptn though, 1368 since a subscriptn requires something to subscript and 1369 there is nothing in this case (class+field name will be 1370 encoded in the mangled symbol name) } 1371 recst.insert(hstaticvs); 1372 { only set the staticvarsym's basename (= field name, without any 1373 mangling), because generating the fully mangled name right now can 1374 result in a wrong string in case the field's type is a forward 1375 declared class whose external name will change when the actual 1376 definition is parsed } 1377 if (vo_has_mangledname in fieldvs.varoptions) then 1378 hstaticvs.set_mangledbasename(fieldvs.externalname^) 1379 else 1380 hstaticvs.set_mangledbasename(fieldvs.realname); 1381 { for definition in class file } 1382 hstaticvs.visibility:=fieldvs.visibility; 1383 {$else jvm} 1384 include(hstaticvs.symoptions,sp_internal); 1385 tabstractrecordsymtable(recst).get_unit_symtable.insert(hstaticvs); 1386 {$endif jvm} 1387 { generate the symbol for the access } 1388 sl:=tpropaccesslist.create; 1389 sl.addsym(sl_load,hstaticvs); 1390 { do *not* change the visibility of this absolutevarsym from vis_public 1391 to anything else, because its visibility is used by visibility checks 1392 after turning a class property referring to a class variable into a 1393 load node (handle_staticfield_access -> searchsym_in_class -> 1394 is_visible_for_object), which means that the load will fail if this 1395 symbol is e.g. "strict private" while the property is public } 1396 tmp:=cabsolutevarsym.create_ref('$'+static_name,fieldvs.vardef,sl); 1397 recst.insert(tmp); 1398 result:=hstaticvs; 1399 end; 1400 1401 1402 procedure call_through_new_name(orgpd: tprocdef; const newname: TSymStr); 1403 var 1404 newpd: tprocdef; 1405 begin 1406 { we have a forward declaration like 1407 procedure test; (in the unit interface or "forward") 1408 and then an implementation like 1409 procedure test; external name 'something'; 1410 1411 To solve this, we create a new external procdef for the 1412 implementation, and then generate a procedure body for the original 1413 one that calls through to the external procdef. This is necessary 1414 because there may already be references to the mangled name for the 1415 non-external "test". 1416 } 1417 1418 { prefixing the parameters here is useless, because the new procdef will 1419 just be an external declaration without a body } 1420 newpd:=tprocdef(orgpd.getcopyas(procdef,pc_bareproc,'')); 1421 insert_funcret_para(newpd); 1422 newpd.procoptions:=newpd.procoptions+orgpd.procoptions*[po_external,po_has_importname,po_has_importdll]; 1423 newpd.import_name:=orgpd.import_name; 1424 orgpd.import_name:=nil; 1425 newpd.import_dll:=orgpd.import_dll; 1426 orgpd.import_dll:=nil; 1427 newpd.import_nr:=orgpd.import_nr; 1428 orgpd.import_nr:=0; 1429 newpd.setmangledname(newname); 1430 finish_copied_procdef(newpd,'__FPC_IMPL_EXTERNAL_REDIRECT_'+newname,current_module.localsymtable,nil); 1431 newpd.forwarddef:=false; 1432 { ideally we would prefix the parameters of the original routine here, but since it 1433 can be an interface definition, we cannot do that without risking to change the 1434 interface crc } 1435 orgpd.skpara:=newpd; 1436 orgpd.synthetickind:=tsk_callthrough; 1437 orgpd.procoptions:=orgpd.procoptions-[po_external,po_has_importname,po_has_importdll]; 1438 orgpd.forwarddef:=true; 1439 end; 1440 1441 generate_pkg_stubnull1442 function generate_pkg_stub(pd:tprocdef):tnode; 1443 begin 1444 if target_info.system in systems_all_windows+systems_nativent then 1445 begin 1446 insert_funcret_local(pd); 1447 result:=cassignmentnode.create( 1448 cloadnode.create(pd.funcretsym,pd.localst), 1449 cordconstnode.create(1,bool32type,false) 1450 ); 1451 end 1452 else 1453 result:=cnothingnode.create; 1454 end; 1455 1456 end. 1457 1458