1 { 2 Copyright (c) 2011 3 4 Contains different functions that are used in the context of 5 parsing generics. 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 unit pgenutil; 24 25 {$i fpcdefs.inc} 26 27 interface 28 29 uses 30 { common } 31 cclasses, 32 { global } 33 globtype, 34 { parser } 35 pgentype, 36 { symtable } 37 symtype,symdef,symbase; 38 39 procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string;parsedpos:tfileposinfo);inline; 40 procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string);inline; generate_specialization_phase1null41 function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef):tdef;inline; generate_specialization_phase1null42 function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string):tdef;inline; generate_specialization_phase1null43 function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef; generate_specialization_phase2null44 function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;_prettyname:ansistring):tdef; check_generic_constraintsnull45 function check_generic_constraints(genericdef:tstoreddef;paradeflist:tfpobjectlist;poslist:tfplist):boolean; parse_generic_parametersnull46 function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist; parse_generic_specialization_typesnull47 function parse_generic_specialization_types(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean; 48 procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist); 49 procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist); generate_generic_namenull50 function generate_generic_name(const name:tidstring;specializename:ansistring;owner_hierarchy:string):tidstring; 51 procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint); 52 procedure add_generic_dummysym(sym:tsym); resolve_generic_dummysymnull53 function resolve_generic_dummysym(const name:tidstring):tsym; could_be_genericnull54 function could_be_generic(const name:tidstring):boolean;inline; 55 56 procedure generate_specialization_procs; 57 procedure maybe_add_pending_specialization(def:tdef); 58 59 procedure specialization_init(genericdef:tdef;var state:tspecializationstate); 60 procedure specialization_done(var state:tspecializationstate); 61 62 implementation 63 64 uses 65 { common } 66 cutils,fpccrc, 67 { global } 68 globals,tokens,verbose,finput, 69 { symtable } 70 symconst,symsym,symtable,defcmp,procinfo, 71 { modules } 72 fmodule, 73 node,nobj, 74 { parser } 75 scanner, 76 pbase,pexpr,pdecsub,ptype,psub,pparautl; 77 78 79 procedure maybe_add_waiting_unit(tt:tdef); 80 var 81 hmodule : tmodule; 82 begin 83 if not assigned(tt) or 84 not (df_generic in tt.defoptions) then 85 exit; 86 87 hmodule:=find_module_from_symtable(tt.owner); 88 if not assigned(hmodule) then 89 internalerror(2012092401); 90 91 if hmodule=current_module then 92 exit; 93 94 if hmodule.state<>ms_compiled then 95 begin 96 {$ifdef DEBUG_UNITWAITING} 97 Writeln('Unit ', current_module.modulename^, 98 ' waiting for ', hmodule.modulename^); 99 {$endif DEBUG_UNITWAITING} 100 if current_module.waitingforunit.indexof(hmodule)<0 then 101 current_module.waitingforunit.add(hmodule); 102 if hmodule.waitingunits.indexof(current_module)<0 then 103 hmodule.waitingunits.add(current_module); 104 end; 105 end; 106 check_generic_constraintsnull107 function check_generic_constraints(genericdef:tstoreddef;paradeflist:tfpobjectlist;poslist:tfplist):boolean; 108 var 109 i,j, 110 intfcount : longint; 111 formaldef, 112 paradef : tstoreddef; 113 objdef, 114 paraobjdef, 115 formalobjdef : tobjectdef; 116 intffound : boolean; 117 filepos : tfileposinfo; 118 begin 119 { check whether the given specialization parameters fit to the eventual 120 constraints of the generic } 121 if not assigned(genericdef.genericparas) or (genericdef.genericparas.count=0) then 122 internalerror(2012101001); 123 if genericdef.genericparas.count<>paradeflist.count then 124 internalerror(2012101002); 125 if paradeflist.count<>poslist.count then 126 internalerror(2012120801); 127 result:=true; 128 for i:=0 to genericdef.genericparas.count-1 do 129 begin 130 filepos:=pfileposinfo(poslist[i])^; 131 formaldef:=tstoreddef(ttypesym(genericdef.genericparas[i]).typedef); 132 if formaldef.typ=undefineddef then 133 { the parameter is of unspecified type, so no need to check } 134 continue; 135 if not (df_genconstraint in formaldef.defoptions) or 136 not assigned(formaldef.genconstraintdata) then 137 internalerror(2013021602); 138 paradef:=tstoreddef(paradeflist[i]); 139 { undefineddef is compatible with anything } 140 if formaldef.typ=undefineddef then 141 continue; 142 if paradef.typ<>formaldef.typ then 143 begin 144 case formaldef.typ of 145 recorddef: 146 { delphi has own fantasy about record constraint 147 (almost non-nullable/non-nilable value type) } 148 if m_delphi in current_settings.modeswitches then 149 case paradef.typ of 150 floatdef,enumdef,orddef: 151 continue; 152 objectdef: 153 if tobjectdef(paradef).objecttype=odt_object then 154 continue 155 else 156 MessagePos(filepos,type_e_record_type_expected); 157 else 158 MessagePos(filepos,type_e_record_type_expected); 159 end 160 else 161 MessagePos(filepos,type_e_record_type_expected); 162 objectdef: 163 case tobjectdef(formaldef).objecttype of 164 odt_class, 165 odt_javaclass: 166 MessagePos1(filepos,type_e_class_type_expected,paradef.typename); 167 odt_interfacecom, 168 odt_interfacecorba, 169 odt_dispinterface, 170 odt_interfacejava: 171 MessagePos1(filepos,type_e_interface_type_expected,paradef.typename); 172 else 173 internalerror(2012101003); 174 end; 175 errordef: 176 { ignore } 177 ; 178 else 179 internalerror(2012101004); 180 end; 181 result:=false; 182 end 183 else 184 begin 185 { the paradef types are the same, so do special checks for the 186 cases in which they are needed } 187 if formaldef.typ=objectdef then 188 begin 189 paraobjdef:=tobjectdef(paradef); 190 formalobjdef:=tobjectdef(formaldef); 191 if not (formalobjdef.objecttype in [odt_class,odt_javaclass,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface]) then 192 internalerror(2012101102); 193 if formalobjdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface] then 194 begin 195 { this is either a concerete interface or class type (the 196 latter without specific implemented interfaces) } 197 case paraobjdef.objecttype of 198 odt_interfacecom, 199 odt_interfacecorba, 200 odt_interfacejava, 201 odt_dispinterface: 202 begin 203 if (oo_is_forward in paraobjdef.objectoptions) and 204 (paraobjdef.objecttype=formalobjdef.objecttype) and 205 (df_genconstraint in formalobjdef.defoptions) and 206 ( 207 (formalobjdef.objecttype=odt_interfacecom) and 208 (formalobjdef.childof=interface_iunknown) 209 ) 210 or 211 ( 212 (formalobjdef.objecttype=odt_interfacecorba) and 213 (formalobjdef.childof=nil) 214 ) then 215 continue; 216 if not def_is_related(paraobjdef,formalobjdef.childof) then 217 begin 218 MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename); 219 result:=false; 220 end; 221 end; 222 odt_class, 223 odt_javaclass: 224 begin 225 objdef:=paraobjdef; 226 intffound:=false; 227 while assigned(objdef) do 228 begin 229 for j:=0 to objdef.implementedinterfaces.count-1 do 230 if timplementedinterface(objdef.implementedinterfaces[j]).intfdef=formalobjdef.childof then 231 begin 232 intffound:=true; 233 break; 234 end; 235 if intffound then 236 break; 237 objdef:=objdef.childof; 238 end; 239 result:=intffound; 240 if not result then 241 MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,formalobjdef.childof.typename); 242 end; 243 else 244 begin 245 MessagePos1(filepos,type_e_class_or_interface_type_expected,paraobjdef.typename); 246 result:=false; 247 end; 248 end; 249 end 250 else 251 begin 252 { this is either a "class" or a concrete instance with 253 or without implemented interfaces } 254 if not (paraobjdef.objecttype in [odt_class,odt_javaclass]) then 255 begin 256 MessagePos1(filepos,type_e_class_type_expected,paraobjdef.typename); 257 result:=false; 258 continue; 259 end; 260 { for forward declared classes we allow pure TObject/class declarations } 261 if (oo_is_forward in paraobjdef.objectoptions) and 262 (df_genconstraint in formaldef.defoptions) then 263 begin 264 if (formalobjdef.childof=class_tobject) and 265 not formalobjdef.implements_any_interfaces then 266 continue; 267 end; 268 if assigned(formalobjdef.childof) and 269 not def_is_related(paradef,formalobjdef.childof) then 270 begin 271 MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename); 272 result:=false; 273 end; 274 intfcount:=0; 275 for j:=0 to formalobjdef.implementedinterfaces.count-1 do 276 begin 277 objdef:=paraobjdef; 278 while assigned(objdef) do 279 begin 280 intffound:=assigned( 281 find_implemented_interface(objdef, 282 timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef 283 ) 284 ); 285 if intffound then 286 break; 287 objdef:=objdef.childof; 288 end; 289 if intffound then 290 inc(intfcount) 291 else 292 MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef.typename); 293 end; 294 if intfcount<>formalobjdef.implementedinterfaces.count then 295 result:=false; 296 end; 297 end; 298 end; 299 end; 300 end; 301 302 parse_generic_specialization_types_internalnull303 function parse_generic_specialization_types_internal(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean; 304 var 305 old_block_type : tblock_type; 306 first : boolean; 307 typeparam : tnode; 308 parampos : pfileposinfo; 309 tmpparampos : tfileposinfo; 310 namepart : string; 311 prettynamepart : ansistring; 312 module : tmodule; 313 begin 314 result:=true; 315 if genericdeflist=nil then 316 internalerror(2012061401); 317 { set the block type to type, so that the parsed type are returned as 318 ttypenode (e.g. classes are in non type-compatible blocks returned as 319 tloadvmtaddrnode) } 320 old_block_type:=block_type; 321 { if parsedtype is set, then the first type identifer was already parsed 322 (happens in inline specializations) and thus we only need to parse 323 the remaining types and do as if the first one was already given } 324 first:=not assigned(parsedtype); 325 if assigned(parsedtype) then 326 begin 327 genericdeflist.Add(parsedtype); 328 module:=find_module_from_symtable(parsedtype.owner); 329 if not assigned(module) then 330 internalerror(2016112801); 331 namepart:='_$'+hexstr(module.moduleid,8)+'$$'+parsedtype.unique_id_str; 332 specializename:='$'+namepart; 333 prettyname:=parsedtype.fullownerhierarchyname(true)+parsedtype.typesym.prettyname; 334 if assigned(poslist) then 335 begin 336 New(parampos); 337 parampos^:=parsedpos; 338 poslist.add(parampos); 339 end; 340 end 341 else 342 begin 343 specializename:='$'; 344 prettyname:=''; 345 end; 346 while not (token in [_GT,_RSHARPBRACKET]) do 347 begin 348 { "first" is set to false at the end of the loop! } 349 if not first then 350 consume(_COMMA); 351 block_type:=bt_type; 352 tmpparampos:=current_filepos; 353 typeparam:=factor(false,[ef_type_only]); 354 if typeparam.nodetype=typen then 355 begin 356 if tstoreddef(typeparam.resultdef).is_generic and 357 ( 358 not parse_generic or 359 not defs_belong_to_same_generic(typeparam.resultdef,current_genericdef) 360 ) then 361 Message(parser_e_no_generics_as_params); 362 if assigned(poslist) then 363 begin 364 New(parampos); 365 parampos^:=tmpparampos; 366 poslist.add(parampos); 367 end; 368 if typeparam.resultdef.typ<>errordef then 369 begin 370 if not assigned(typeparam.resultdef.typesym) then 371 message(type_e_generics_cannot_reference_itself) 372 else if (typeparam.resultdef.typ<>errordef) then 373 begin 374 genericdeflist.Add(typeparam.resultdef); 375 module:=find_module_from_symtable(typeparam.resultdef.owner); 376 if not assigned(module) then 377 internalerror(2016112802); 378 namepart:='_$'+hexstr(module.moduleid,8)+'$$'+typeparam.resultdef.unique_id_str; 379 { we use the full name of the type to uniquely identify it } 380 if (symtablestack.top.symtabletype=parasymtable) and 381 (symtablestack.top.defowner.typ=procdef) and 382 (typeparam.resultdef.owner=symtablestack.top) then 383 begin 384 { special handling for specializations inside generic function declarations } 385 prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; 386 end 387 else 388 begin 389 prettynamepart:=typeparam.resultdef.fullownerhierarchyname(true); 390 end; 391 specializename:=specializename+namepart; 392 if not first then 393 prettyname:=prettyname+','; 394 prettyname:=prettyname+prettynamepart+typeparam.resultdef.typesym.prettyname; 395 end; 396 end 397 else 398 begin 399 result:=false; 400 end; 401 end 402 else 403 begin 404 Message(type_e_type_id_expected); 405 result:=false; 406 end; 407 typeparam.free; 408 first:=false; 409 end; 410 block_type:=old_block_type; 411 end; 412 413 parse_generic_specialization_typesnull414 function parse_generic_specialization_types(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean; 415 var 416 dummypos : tfileposinfo; 417 begin 418 FillChar(dummypos, SizeOf(tfileposinfo), 0); 419 result:=parse_generic_specialization_types_internal(genericdeflist,poslist,prettyname,specializename,nil,dummypos); 420 end; 421 422 423 procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string); 424 var 425 dummypos : tfileposinfo; 426 begin 427 FillChar(dummypos, SizeOf(tfileposinfo), 0); 428 generate_specialization(tt,parse_class_parent,_prettyname,nil,'',dummypos); 429 end; 430 431 generate_specialization_phase1null432 function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef):tdef; 433 var 434 dummypos : tfileposinfo; 435 {$push} 436 {$warn 5036 off} 437 begin 438 result:=generate_specialization_phase1(context,genericdef,nil,'',dummypos); 439 end; 440 {$pop} 441 442 generate_specialization_phase1null443 function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string):tdef; 444 var 445 dummypos : tfileposinfo; 446 {$push} 447 {$warn 5036 off} 448 begin 449 result:=generate_specialization_phase1(context,genericdef,nil,symname,dummypos); 450 end; 451 {$pop} 452 453 generate_specialization_phase1null454 function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef; 455 var 456 pt2 : tnode; 457 errorrecovery, 458 found, 459 first, 460 err : boolean; 461 i, 462 gencount : longint; 463 def : tstoreddef; 464 countstr,genname,ugenname : string; 465 srsym : tsym; 466 st : tsymtable; 467 tmpstack : tfpobjectlist; 468 begin 469 context:=nil; 470 result:=nil; 471 472 { either symname must be given or genericdef needs to be valid } 473 errorrecovery:=false; 474 if (symname='') and 475 (not assigned(genericdef) or 476 ( 477 (genericdef.typ<>procdef) and 478 ( 479 not assigned(genericdef.typesym) or 480 (genericdef.typesym.typ<>typesym) 481 ) 482 ) or 483 ( 484 (genericdef.typ=procdef) and 485 ( 486 not assigned(tprocdef(genericdef).procsym) or 487 (tprocdef(genericdef).procsym.typ<>procsym) 488 ) 489 ) 490 ) then 491 begin 492 errorrecovery:=true; 493 result:=generrordef; 494 end; 495 496 { Only parse the parameters for recovery or 497 for recording in genericbuf } 498 if errorrecovery then 499 begin 500 first:=assigned(parsedtype); 501 if not first and not try_to_consume(_LT) then 502 consume(_LSHARPBRACKET); 503 gencount:=0; 504 { handle "<>" } 505 if not first and ((token=_RSHARPBRACKET) or (token=_GT)) then 506 Message(type_e_type_id_expected) 507 else 508 repeat 509 if not first then 510 begin 511 pt2:=factor(false,[ef_type_only]); 512 pt2.free; 513 end; 514 first:=false; 515 inc(gencount); 516 until not try_to_consume(_COMMA); 517 if not try_to_consume(_GT) then 518 consume(_RSHARPBRACKET); 519 { we need to return a def that can later pass some checks like 520 whether it's an interface or not } 521 if not errorrecovery and 522 (not assigned(result) or (result.typ=undefineddef)) then 523 begin 524 if (symname='') and tstoreddef(genericdef).is_generic then 525 { this happens in non-Delphi modes } 526 result:=genericdef 527 else 528 begin 529 { find the corresponding generic symbol so that any checks 530 done on the returned def will be handled correctly } 531 str(gencount,countstr); 532 if symname='' then 533 genname:=ttypesym(genericdef.typesym).realname 534 else 535 genname:=symname; 536 genname:=genname+'$'+countstr; 537 ugenname:=upper(genname); 538 { first check whether the found name is the same as that of 539 the current def or one of its (generic) surrounding defs; 540 this is necessary as the symbol of the generic can not yet 541 be used for lookup as it still contains a reference to an 542 errordef) } 543 def:=current_genericdef; 544 repeat 545 if def.typ in [objectdef,recorddef] then 546 if tabstractrecorddef(def).objname^=ugenname then 547 begin 548 result:=def; 549 break; 550 end; 551 def:=tstoreddef(def.owner.defowner); 552 until not assigned(def) or not (df_generic in def.defoptions); 553 { it's not part of the current object hierarchy, so search 554 for the symbol } 555 if not assigned(result) then 556 begin 557 srsym:=nil; 558 if not searchsym(ugenname,srsym,st) or 559 (srsym.typ<>typesym) then 560 begin 561 identifier_not_found(genname); 562 result:=generrordef; 563 exit; 564 end; 565 result:=ttypesym(srsym).typedef; 566 { this happens in non-Delphi modes if we encounter a 567 specialization of the generic class or record we're 568 currently parsing } 569 if (result.typ=errordef) and assigned(current_structdef) and 570 (current_structdef.objname^=ugenname) then 571 result:=current_structdef; 572 end; 573 end; 574 end; 575 exit; 576 end; 577 578 if not assigned(parsedtype) and not try_to_consume(_LT) then 579 begin 580 consume(_LSHARPBRACKET); 581 { handle "<>" } 582 if (token=_GT) or (token=_RSHARPBRACKET) then 583 begin 584 Message(type_e_type_id_expected); 585 if not try_to_consume(_GT) then 586 try_to_consume(_RSHARPBRACKET); 587 result:=generrordef; 588 exit; 589 end; 590 end; 591 592 context:=tspecializationcontext.create; 593 594 { Parse type parameters } 595 err:=not parse_generic_specialization_types_internal(context.genericdeflist,context.poslist,context.prettyname,context.specializename,parsedtype,parsedpos); 596 if err then 597 begin 598 if not try_to_consume(_GT) then 599 try_to_consume(_RSHARPBRACKET); 600 context.free; 601 context:=nil; 602 result:=generrordef; 603 exit; 604 end; 605 606 { use the name of the symbol as procvars return a user friendly version 607 of the name } 608 if symname='' then 609 begin 610 if genericdef.typ=procdef then 611 genname:=tprocdef(genericdef).procsym.realname 612 else 613 genname:=ttypesym(genericdef.typesym).realname; 614 end 615 else 616 genname:=symname; 617 618 { in case of non-Delphi mode the type name could already be a generic 619 def (but maybe the wrong one) } 620 if assigned(genericdef) and 621 ([df_generic,df_specialization]*genericdef.defoptions<>[]) then 622 begin 623 { remove the type count suffix from the generic's name } 624 for i:=Length(genname) downto 1 do 625 if genname[i]='$' then 626 begin 627 genname:=copy(genname,1,i-1); 628 break; 629 end; 630 { in case of a specialization we've only reached the specialization 631 checksum yet } 632 if df_specialization in genericdef.defoptions then 633 for i:=length(genname) downto 1 do 634 if genname[i]='$' then 635 begin 636 genname:=copy(genname,1,i-1); 637 break; 638 end; 639 end 640 else 641 begin 642 split_generic_name(genname,ugenname,gencount); 643 if genname<>ugenname then 644 genname:=ugenname; 645 end; 646 647 { search a generic with the given count of params } 648 countstr:=''; 649 str(context.genericdeflist.Count,countstr); 650 651 genname:=genname+'$'+countstr; 652 ugenname:=upper(genname); 653 654 context.genname:=genname; 655 656 if assigned(genericdef) and (genericdef.owner.symtabletype in [objectsymtable,recordsymtable]) then 657 begin 658 if genericdef.owner.symtabletype = objectsymtable then 659 found:=searchsym_in_class(tobjectdef(genericdef.owner.defowner),tobjectdef(genericdef.owner.defowner),ugenname,context.sym,context.symtable,[]) 660 else 661 found:=searchsym_in_record(tabstractrecorddef(genericdef.owner.defowner),ugenname,context.sym,context.symtable); 662 if not found then 663 found:=searchsym(ugenname,context.sym,context.symtable); 664 end 665 else 666 found:=searchsym(ugenname,context.sym,context.symtable); 667 668 if found and (context.sym.typ=absolutevarsym) and 669 (vo_is_funcret in tabstractvarsym(context.sym).varoptions) then 670 begin 671 { we found the function result alias of a generic function; go up the 672 symbol stack *before* this alias was inserted, so that we can 673 (hopefully) find the correct generic symbol } 674 tmpstack:=tfpobjectlist.create(false); 675 while assigned(symtablestack.top) do 676 begin 677 tmpstack.Add(symtablestack.top); 678 symtablestack.pop(symtablestack.top); 679 if tmpstack.Last=context.symtable then 680 break; 681 end; 682 if not assigned(symtablestack.top) then 683 internalerror(2019123001); 684 found:=searchsym(ugenname,context.sym,context.symtable); 685 for i:=tmpstack.count-1 downto 0 do 686 symtablestack.push(tsymtable(tmpstack[i])); 687 tmpstack.free; 688 end; 689 690 if not found or not (context.sym.typ in [typesym,procsym]) then 691 begin 692 identifier_not_found(genname); 693 if not try_to_consume(_GT) then 694 try_to_consume(_RSHARPBRACKET); 695 context.free; 696 context:=nil; 697 result:=generrordef; 698 exit; 699 end; 700 701 { we've found the correct def } 702 if context.sym.typ=typesym then 703 result:=tstoreddef(ttypesym(context.sym).typedef) 704 else 705 begin 706 if tprocsym(context.sym).procdeflist.count=0 then 707 internalerror(2015061203); 708 result:=tstoreddef(tprocsym(context.sym).procdefList[0]); 709 end; 710 711 if not try_to_consume(_GT) then 712 consume(_RSHARPBRACKET); 713 end; 714 generate_specialization_phase2null715 function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;_prettyname:ansistring):tdef; 716 717 procedure unset_forwarddef(def: tdef); 718 var 719 st : TSymtable; 720 i : longint; 721 begin 722 case def.typ of 723 procdef: 724 tprocdef(def).forwarddef:=false; 725 objectdef, 726 recorddef: 727 begin 728 st:=def.getsymtable(gs_record); 729 for i:=0 to st.deflist.count-1 do 730 unset_forwarddef(tdef(st.deflist[i])); 731 end; 732 end; 733 end; 734 735 procedure retrieve_genericdef_or_procsym(sym:tsym;out gendef:tdef;out psym:tsym); 736 var 737 i : longint; 738 begin 739 gendef:=nil; 740 psym:=nil; 741 case sym.typ of 742 typesym: 743 begin 744 gendef:=ttypesym(sym).typedef 745 end; 746 procsym: 747 begin 748 for i:=0 to tprocsym(sym).procdeflist.count-1 do 749 if tstoreddef(tprocsym(sym).procdeflist[i]).genericdef=genericdef then 750 begin 751 gendef:=tdef(tprocsym(sym).procdeflist[i]); 752 break; 753 end; 754 psym:=sym; 755 end 756 else 757 internalerror(200710171); 758 end; 759 end; 760 761 var 762 finalspecializename, 763 ufinalspecializename : tidstring; 764 prettyname : ansistring; 765 generictypelist : tfphashobjectlist; 766 srsymtable, 767 specializest : tsymtable; 768 hashedid : thashedidstring; 769 tempst : tglobalsymtable; 770 psym, 771 srsym : tsym; 772 def : tdef; 773 old_block_type : tblock_type; 774 state : tspecializationstate; 775 old_current_structdef : tabstractrecorddef; 776 old_current_specializedef, 777 old_current_genericdef : tstoreddef; 778 old_current_procinfo : tprocinfo; 779 old_module_procinfo : tobject; 780 hmodule : tmodule; 781 oldcurrent_filepos : tfileposinfo; 782 recordbuf : tdynamicarray; 783 hadtypetoken : boolean; 784 vmtbuilder : tvmtbuilder; 785 i, 786 replaydepth : longint; 787 item : tobject; 788 allequal, 789 hintsprocessed : boolean; 790 pd : tprocdef; 791 pdflags : tpdflags; 792 begin 793 if not assigned(context) then 794 internalerror(2015052203); 795 796 result:=nil; 797 798 pd:=nil; 799 800 if not check_generic_constraints(genericdef,context.genericdeflist,context.poslist) then 801 begin 802 { the parameters didn't fit the constraints, so don't continue with the 803 specialization } 804 result:=generrordef; 805 exit; 806 end; 807 808 { build the new type's name } 809 finalspecializename:=generate_generic_name(context.genname,context.specializename,genericdef.ownerhierarchyname); 810 ufinalspecializename:=upper(finalspecializename); 811 if genericdef.typ=procdef then 812 prettyname:=tprocdef(genericdef).procsym.prettyname 813 else 814 prettyname:=genericdef.typesym.prettyname; 815 prettyname:=prettyname+'<'+context.prettyname+'>'; 816 817 generictypelist:=tfphashobjectlist.create(false); 818 819 { build the list containing the types for the generic params } 820 if not assigned(genericdef.genericparas) then 821 internalerror(2013092601); 822 if context.genericdeflist.count<>genericdef.genericparas.count then 823 internalerror(2013092603); 824 for i:=0 to genericdef.genericparas.Count-1 do 825 begin 826 srsym:=tsym(genericdef.genericparas[i]); 827 if not (sp_generic_para in srsym.symoptions) then 828 internalerror(2013092602); 829 generictypelist.add(srsym.realname,tdef(context.genericdeflist[i]).typesym); 830 end; 831 832 { Special case if we are referencing the current defined object } 833 if assigned(current_structdef) and 834 (current_structdef.objname^=ufinalspecializename) then 835 result:=current_structdef; 836 837 { Can we reuse an already specialized type? } 838 839 { for this first check whether we are currently specializing a nested 840 type of the current (main) specialization (this is necessary, because 841 during that time the symbol of the main specialization will still 842 contain a reference to an errordef) } 843 if not assigned(result) and assigned(current_specializedef) then 844 begin 845 def:=current_specializedef; 846 repeat 847 if def.typ in [objectdef,recorddef] then 848 if tabstractrecorddef(def).objname^=ufinalspecializename then begin 849 result:=def; 850 break; 851 end; 852 if assigned(def.owner) then 853 def:=tstoreddef(def.owner.defowner) 854 else 855 { this can happen when specializing a generic function } 856 def:=nil; 857 until not assigned(def) or not (df_specialization in def.defoptions); 858 end; 859 860 { if the genericdef is the def we are currently parsing (or one of its parents) then we can 861 not use it for specializing as the tokenbuffer is not yet set (and we aren't done with 862 parsing anyway), so for now we treat those still as generic defs without doing a partial 863 specialization } 864 if not assigned(result) then 865 begin 866 def:=current_genericdef; 867 while assigned(def) and (def.typ in [recorddef,objectdef]) do 868 begin 869 if (df_generic in def.defoptions) and (def=genericdef) then 870 begin 871 result:=def; 872 break; 873 end; 874 { the following happens when a routine with its parent struct 875 as parameter is specialized as a parameter or result of a 876 generic function } 877 if (df_specialization in def.defoptions) and (tstoreddef(def).genericdef=genericdef) then 878 begin 879 if tstoreddef(def).genericparas.count=generictypelist.count then 880 begin 881 allequal:=true; 882 for i:=0 to generictypelist.count-1 do 883 begin 884 if not equal_defs(ttypesym(generictypelist[i]).typedef,ttypesym(tstoreddef(def).genericparas[i]).typedef) then 885 begin 886 allequal:=false; 887 break; 888 end; 889 end; 890 if allequal then 891 begin 892 result:=def; 893 break; 894 end; 895 end; 896 end; 897 def:=tstoreddef(def.owner.defowner); 898 end; 899 end; 900 901 { decide in which symtable to put the specialization } 902 if parse_generic and not assigned(result) then 903 begin 904 srsymtable:=symtablestack.top; 905 if (srsymtable.symtabletype in [localsymtable,parasymtable]) and tstoreddef(srsymtable.defowner).is_specialization then 906 { if we are currently specializing a routine we need to specialize into 907 the routine's local- or parasymtable so that they are correctly 908 registered should the specialization be finalized } 909 specializest:=srsymtable 910 else if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then 911 { if we are parsing the definition of a method we specialize into 912 the local symtable of it } 913 specializest:=current_procinfo.procdef.getsymtable(gs_local) 914 else 915 begin 916 if not assigned(current_genericdef) then 917 internalerror(2014050901); 918 { we specialize the partial specialization into the symtable of the currently parsed 919 generic } 920 case current_genericdef.typ of 921 procvardef: 922 specializest:=current_genericdef.getsymtable(gs_para); 923 procdef: 924 specializest:=current_genericdef.getsymtable(gs_local); 925 objectdef, 926 recorddef: 927 specializest:=current_genericdef.getsymtable(gs_record); 928 arraydef: 929 specializest:=tarraydef(current_genericdef).symtable; 930 else 931 internalerror(2014050902); 932 end; 933 end; 934 end 935 else 936 if current_module.is_unit and current_module.in_interface then 937 specializest:=current_module.globalsymtable 938 else 939 specializest:=current_module.localsymtable; 940 if not assigned(specializest) then 941 internalerror(2014050910); 942 943 { now check whether there is a specialization somewhere else } 944 psym:=nil; 945 if not assigned(result) then 946 begin 947 hashedid.id:=ufinalspecializename; 948 949 if specializest.symtabletype=objectsymtable then 950 begin 951 { search also in parent classes } 952 if not assigned(current_genericdef) or (current_genericdef.typ<>objectdef) then 953 internalerror(2016112901); 954 if not searchsym_in_class(tobjectdef(current_genericdef),tobjectdef(current_genericdef),ufinalspecializename,srsym,srsymtable,[]) then 955 srsym:=nil; 956 end 957 else 958 srsym:=tsym(specializest.findwithhash(hashedid)); 959 960 if assigned(srsym) then 961 begin 962 retrieve_genericdef_or_procsym(srsym,result,psym); 963 end 964 else 965 { the generic could have been specialized in the globalsymtable 966 already, so search there as well } 967 if (specializest<>current_module.globalsymtable) and assigned(current_module.globalsymtable) then 968 begin 969 srsym:=tsym(current_module.globalsymtable.findwithhash(hashedid)); 970 if assigned(srsym) then 971 begin 972 retrieve_genericdef_or_procsym(srsym,result,psym); 973 end; 974 end; 975 end; 976 977 if not assigned(result) then 978 begin 979 specialization_init(genericdef,state); 980 981 { push a temporary global symtable so that the specialization is 982 added to the correct symtable; this symtable does not contain 983 any other symbols, so that the type resolution can not be 984 influenced by symbols in the current unit } 985 tempst:=tspecializesymtable.create(current_module.modulename^,current_module.moduleid); 986 symtablestack.push(tempst); 987 988 { Reparse the original type definition } 989 begin 990 old_current_specializedef:=nil; 991 old_current_genericdef:=nil; 992 old_current_structdef:=nil; 993 old_current_procinfo:=current_procinfo; 994 old_module_procinfo:=current_module.procinfo; 995 996 current_procinfo:=nil; 997 current_module.procinfo:=nil; 998 999 if parse_class_parent then 1000 begin 1001 old_current_structdef:=current_structdef; 1002 old_current_genericdef:=current_genericdef; 1003 old_current_specializedef:=current_specializedef; 1004 1005 if genericdef.owner.symtabletype in [recordsymtable,objectsymtable] then 1006 current_structdef:=tabstractrecorddef(genericdef.owner.defowner) 1007 else 1008 current_structdef:=nil; 1009 current_genericdef:=nil; 1010 current_specializedef:=nil; 1011 end; 1012 1013 maybe_add_waiting_unit(genericdef); 1014 1015 { First a new sym so we can reuse this specialization and 1016 references to this specialization can be handled } 1017 if genericdef.typ=procdef then 1018 if assigned(psym) then 1019 srsym:=psym 1020 else 1021 srsym:=cprocsym.create(finalspecializename) 1022 else 1023 srsym:=ctypesym.create(finalspecializename,generrordef); 1024 { insert the symbol only if we don't know already that we have 1025 a procsym to add it to } 1026 if not assigned(psym) then 1027 specializest.insert(srsym); 1028 1029 { specializations are declarations as such it is the wisest to 1030 declare set the blocktype to "type"; otherwise we'll 1031 experience unexpected side effects like the addition of 1032 classrefdefs if we have a generic that's derived from another 1033 generic } 1034 old_block_type:=block_type; 1035 block_type:=bt_type; 1036 1037 if ( 1038 (genericdef.typ=procdef) and 1039 not assigned(tprocdef(genericdef).genericdecltokenbuf) 1040 ) or ( 1041 (genericdef.typ<>procdef) and 1042 not assigned(genericdef.generictokenbuf) 1043 ) then 1044 internalerror(200511171); 1045 hmodule:=find_module_from_symtable(genericdef.owner); 1046 if hmodule=nil then 1047 internalerror(2012051202); 1048 oldcurrent_filepos:=current_filepos; 1049 { use the index the module got from the current compilation process } 1050 current_filepos.moduleindex:=hmodule.unit_index; 1051 current_tokenpos:=current_filepos; 1052 if parse_generic then 1053 begin 1054 recordbuf:=current_scanner.recordtokenbuf; 1055 current_scanner.recordtokenbuf:=nil; 1056 end 1057 else 1058 recordbuf:=nil; 1059 replaydepth:=current_scanner.replay_stack_depth; 1060 if genericdef.typ=procdef then 1061 begin 1062 current_scanner.startreplaytokens(tprocdef(genericdef).genericdecltokenbuf,hmodule.change_endian); 1063 parse_proc_head(tprocdef(genericdef).struct,tprocdef(genericdef).proctypeoption,false,genericdef,generictypelist,pd); 1064 if assigned(pd) then 1065 begin 1066 if assigned(psym) then 1067 pd.procsym:=psym 1068 else 1069 pd.procsym:=srsym; 1070 parse_proc_dec_finish(pd,po_classmethod in tprocdef(genericdef).procoptions,tprocdef(genericdef).struct); 1071 end; 1072 result:=pd; 1073 end 1074 else 1075 begin 1076 current_scanner.startreplaytokens(genericdef.generictokenbuf,hmodule.change_endian); 1077 hadtypetoken:=false; 1078 read_named_type(result,srsym,genericdef,generictypelist,false,hadtypetoken); 1079 ttypesym(srsym).typedef:=result; 1080 result.typesym:=srsym; 1081 1082 if _prettyname<>'' then 1083 ttypesym(result.typesym).fprettyname:=_prettyname 1084 else 1085 ttypesym(result.typesym).fprettyname:=prettyname; 1086 end; 1087 current_filepos:=oldcurrent_filepos; 1088 1089 { Note regarding hint directives: 1090 There is no need to remove the flags for them from the 1091 specialized generic symbol, because hint directives that 1092 follow the specialization are handled by the code in 1093 pdecl.types_dec and added to the type symbol. 1094 E.g.: TFoo = TBar<Blubb> deprecated; 1095 Here the symbol TBar$1$Blubb will contain the 1096 "sp_hint_deprecated" flag while the TFoo symbol won't.} 1097 1098 case result.typ of 1099 { Build VMT indexes for classes and read hint directives } 1100 objectdef: 1101 begin 1102 if replaydepth>current_scanner.replay_stack_depth then 1103 begin 1104 try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg); 1105 if replaydepth>current_scanner.replay_stack_depth then 1106 consume(_SEMICOLON); 1107 end; 1108 1109 vmtbuilder:=TVMTBuilder.Create(tobjectdef(result)); 1110 vmtbuilder.generate_vmt; 1111 vmtbuilder.free; 1112 end; 1113 { handle params, calling convention, etc } 1114 procvardef: 1115 begin 1116 hintsprocessed:=false; 1117 if replaydepth>current_scanner.replay_stack_depth then 1118 begin 1119 if not check_proc_directive(true) then 1120 begin 1121 hintsprocessed:=try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg); 1122 if replaydepth>current_scanner.replay_stack_depth then 1123 consume(_SEMICOLON); 1124 end 1125 else 1126 hintsprocessed:=true; 1127 end; 1128 if replaydepth>current_scanner.replay_stack_depth then 1129 parse_var_proc_directives(ttypesym(srsym)); 1130 handle_calling_convention(tprocvardef(result),hcc_default_actions_intf); 1131 if not hintsprocessed and (replaydepth>current_scanner.replay_stack_depth) then 1132 begin 1133 try_consume_hintdirective(ttypesym(srsym).symoptions,ttypesym(srsym).deprecatedmsg); 1134 if replaydepth>current_scanner.replay_stack_depth then 1135 consume(_SEMICOLON); 1136 end; 1137 end; 1138 procdef: 1139 begin 1140 pdflags:=[pd_body,pd_implemen]; 1141 if genericdef.owner.symtabletype=objectsymtable then 1142 include(pdflags,pd_object) 1143 else if genericdef.owner.symtabletype=recordsymtable then 1144 include(pdflags,pd_record); 1145 parse_proc_directives(pd,pdflags); 1146 while try_consume_hintdirective(pd.symoptions,pd.deprecatedmsg) do 1147 consume(_SEMICOLON); 1148 if parse_generic then 1149 handle_calling_convention(tprocdef(result),hcc_default_actions_intf) 1150 else 1151 handle_calling_convention(tprocdef(result),hcc_default_actions_impl); 1152 proc_add_definition(tprocdef(result)); 1153 { for partial specializations we implicitely declare the routine as 1154 having its implementation although we'll not specialize it in reality } 1155 if parse_generic then 1156 unset_forwarddef(result); 1157 end; 1158 else 1159 { parse hint directives for records and arrays } 1160 if replaydepth>current_scanner.replay_stack_depth then begin 1161 try_consume_hintdirective(srsym.symoptions,srsym.deprecatedmsg); 1162 if replaydepth>current_scanner.replay_stack_depth then 1163 consume(_SEMICOLON); 1164 end; 1165 end; 1166 { Consume the remainder of the buffer } 1167 while current_scanner.replay_stack_depth>replaydepth do 1168 consume(token); 1169 1170 if assigned(recordbuf) then 1171 begin 1172 if assigned(current_scanner.recordtokenbuf) then 1173 internalerror(2014050909); 1174 current_scanner.recordtokenbuf:=recordbuf; 1175 end; 1176 1177 block_type:=old_block_type; 1178 current_procinfo:=old_current_procinfo; 1179 current_module.procinfo:=old_module_procinfo; 1180 if parse_class_parent then 1181 begin 1182 current_structdef:=old_current_structdef; 1183 current_genericdef:=old_current_genericdef; 1184 current_specializedef:=old_current_specializedef; 1185 end; 1186 end; 1187 1188 { extract all created symbols and defs from the temporary symtable 1189 and add them to the specializest } 1190 for i:=tempst.SymList.Count-1 downto 0 do 1191 begin 1192 item:=tempst.SymList.Items[i]; 1193 { using changeowner the symbol is automatically added to the 1194 new symtable } 1195 tsym(item).ChangeOwner(specializest); 1196 end; 1197 1198 for i:=tempst.DefList.Count-1 downto 0 do 1199 begin 1200 item:=tempst.DefList.Items[i]; 1201 { using changeowner the def is automatically added to the new 1202 symtable } 1203 tdef(item).ChangeOwner(specializest); 1204 { for partial specializations we implicitely declare any methods as having their 1205 implementations although we'll not specialize them in reality } 1206 if parse_generic then 1207 unset_forwarddef(tdef(item)); 1208 end; 1209 1210 { if a generic was declared during the specialization we need to 1211 flag the specialize symtable accordingly } 1212 if sto_has_generic in tempst.tableoptions then 1213 specializest.includeoption(sto_has_generic); 1214 1215 tempst.free; 1216 1217 specialization_done(state); 1218 1219 { procdefs are only added once we know which overload we use } 1220 if not parse_generic and (result.typ<>procdef) then 1221 current_module.pendingspecializations.add(result.typename,result); 1222 end; 1223 1224 generictypelist.free; 1225 if assigned(genericdef) then 1226 begin 1227 { check the hints of the found generic symbol } 1228 if genericdef.typ=procdef then 1229 srsym:=tprocdef(genericdef).procsym 1230 else 1231 srsym:=genericdef.typesym; 1232 check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg); 1233 end; 1234 end; 1235 1236 1237 procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string;parsedpos:tfileposinfo); 1238 var 1239 context : tspecializationcontext; 1240 genericdef : tstoreddef; 1241 begin 1242 genericdef:=tstoreddef(generate_specialization_phase1(context,tt,parsedtype,symname,parsedpos)); 1243 if genericdef<>generrordef then 1244 genericdef:=tstoreddef(generate_specialization_phase2(context,genericdef,parse_class_parent,_prettyname)); 1245 tt:=genericdef; 1246 if assigned(context) then 1247 context.free; 1248 end; 1249 1250 parse_generic_parametersnull1251 function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist; 1252 var 1253 generictype : ttypesym; 1254 i,firstidx : longint; 1255 srsymtable : tsymtable; 1256 basedef,def : tdef; 1257 defname : tidstring; 1258 allowconstructor, 1259 doconsume : boolean; 1260 constraintdata : tgenericconstraintdata; 1261 old_block_type : tblock_type; 1262 fileinfo : tfileposinfo; 1263 begin 1264 result:=tfphashobjectlist.create(false); 1265 firstidx:=0; 1266 old_block_type:=block_type; 1267 block_type:=bt_type; 1268 repeat 1269 if token=_ID then 1270 begin 1271 generictype:=ctypesym.create(orgpattern,cundefinedtype); 1272 { type parameters need to be added as strict private } 1273 generictype.visibility:=vis_strictprivate; 1274 include(generictype.symoptions,sp_generic_para); 1275 result.add(orgpattern,generictype); 1276 end; 1277 consume(_ID); 1278 fileinfo:=current_tokenpos; 1279 if try_to_consume(_COLON) then 1280 begin 1281 if not allowconstraints then 1282 { TODO } 1283 Message(parser_e_illegal_expression{ parser_e_generic_constraints_not_allowed_here}); 1284 { construct a name which can be used for a type specification } 1285 constraintdata:=tgenericconstraintdata.create; 1286 constraintdata.fileinfo:=fileinfo; 1287 defname:=''; 1288 str(current_module.deflist.count,defname); 1289 defname:='$gendef'+defname; 1290 1291 allowconstructor:=m_delphi in current_settings.modeswitches; 1292 1293 basedef:=generrordef; 1294 repeat 1295 doconsume:=true; 1296 1297 case token of 1298 _CONSTRUCTOR: 1299 begin 1300 if not allowconstructor or (gcf_constructor in constraintdata.flags) then 1301 Message(parser_e_illegal_expression); 1302 include(constraintdata.flags,gcf_constructor); 1303 allowconstructor:=false; 1304 end; 1305 _CLASS: 1306 begin 1307 if gcf_class in constraintdata.flags then 1308 Message(parser_e_illegal_expression); 1309 if basedef=generrordef then 1310 include(constraintdata.flags,gcf_class) 1311 else 1312 Message(parser_e_illegal_expression); 1313 end; 1314 _RECORD: 1315 begin 1316 if ([gcf_constructor,gcf_class]*constraintdata.flags<>[]) 1317 or (constraintdata.interfaces.count>0) then 1318 Message(parser_e_illegal_expression) 1319 else 1320 begin 1321 srsymtable:=trecordsymtable.create(defname,0,1,1); 1322 basedef:=crecorddef.create(defname,srsymtable); 1323 include(constraintdata.flags,gcf_record); 1324 allowconstructor:=false; 1325 end; 1326 end; 1327 else 1328 begin 1329 { after single_type "token" is the trailing ",", ";" or 1330 ">"! } 1331 doconsume:=false; 1332 { def is already set to a class or record } 1333 if gcf_record in constraintdata.flags then 1334 Message(parser_e_illegal_expression); 1335 single_type(def, [stoAllowSpecialization]); 1336 { only types that are inheritable are allowed } 1337 if (def.typ<>objectdef) or 1338 not (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_javaclass]) then 1339 Message1(type_e_class_or_interface_type_expected,def.typename) 1340 else 1341 case tobjectdef(def).objecttype of 1342 odt_class, 1343 odt_javaclass: 1344 begin 1345 if gcf_class in constraintdata.flags then 1346 { "class" + concrete class is not allowed } 1347 Message(parser_e_illegal_expression) 1348 else 1349 { do we already have a concrete class? } 1350 if basedef<>generrordef then 1351 Message(parser_e_illegal_expression) 1352 else 1353 basedef:=def; 1354 end; 1355 odt_interfacecom, 1356 odt_interfacecorba, 1357 odt_interfacejava, 1358 odt_dispinterface: 1359 constraintdata.interfaces.add(def); 1360 end; 1361 end; 1362 end; 1363 if doconsume then 1364 consume(token); 1365 until not try_to_consume(_COMMA); 1366 1367 if ([gcf_class,gcf_constructor]*constraintdata.flags<>[]) or 1368 (constraintdata.interfaces.count>1) or 1369 ( 1370 (basedef.typ=objectdef) and 1371 (tobjectdef(basedef).objecttype in [odt_javaclass,odt_class]) 1372 ) then 1373 begin 1374 if basedef.typ=errordef then 1375 { don't pass an errordef as a parent to a tobjectdef } 1376 basedef:=class_tobject 1377 else 1378 if (basedef.typ<>objectdef) or 1379 not (tobjectdef(basedef).objecttype in [odt_javaclass,odt_class]) then 1380 internalerror(2012101101); 1381 basedef:=cobjectdef.create(tobjectdef(basedef).objecttype,defname,tobjectdef(basedef),false); 1382 for i:=0 to constraintdata.interfaces.count-1 do 1383 tobjectdef(basedef).implementedinterfaces.add( 1384 timplementedinterface.create(tobjectdef(constraintdata.interfaces[i]))); 1385 end 1386 else 1387 if constraintdata.interfaces.count=1 then 1388 begin 1389 if basedef.typ<>errordef then 1390 internalerror(2013021601); 1391 def:=tdef(constraintdata.interfaces[0]); 1392 basedef:=cobjectdef.create(tobjectdef(def).objecttype,defname,tobjectdef(def),false); 1393 constraintdata.interfaces.delete(0); 1394 end; 1395 if basedef.typ<>errordef then 1396 with tstoreddef(basedef) do 1397 begin 1398 genconstraintdata:=tgenericconstraintdata.create; 1399 genconstraintdata.flags:=constraintdata.flags; 1400 genconstraintdata.interfaces.assign(constraintdata.interfaces); 1401 genconstraintdata.fileinfo:=constraintdata.fileinfo; 1402 include(defoptions,df_genconstraint); 1403 end; 1404 1405 for i:=firstidx to result.count-1 do 1406 ttypesym(result[i]).typedef:=basedef; 1407 { we need a typesym in case we do a Delphi-mode inline 1408 specialization with this parameter; so just use the first sym } 1409 if not assigned(basedef.typesym) then 1410 basedef.typesym:=ttypesym(result[firstidx]); 1411 firstidx:=result.count; 1412 1413 constraintdata.free; 1414 end 1415 else 1416 begin 1417 if token=_SEMICOLON then 1418 begin 1419 { two different typeless parameters are considered as incompatible } 1420 for i:=firstidx to result.count-1 do 1421 begin 1422 ttypesym(result[i]).typedef:=cundefineddef.create(false); 1423 ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]); 1424 end; 1425 { a semicolon terminates a type parameter group } 1426 firstidx:=result.count; 1427 end; 1428 end; 1429 until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); 1430 { two different typeless parameters are considered as incompatible } 1431 for i:=firstidx to result.count-1 do 1432 begin 1433 ttypesym(result[i]).typedef:=cundefineddef.create(false); 1434 ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]); 1435 end; 1436 block_type:=old_block_type; 1437 end; 1438 1439 1440 procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist); 1441 var 1442 i : longint; 1443 generictype,sym : ttypesym; 1444 st : tsymtable; 1445 begin 1446 def.genericdef:=genericdef; 1447 if not assigned(genericlist) then 1448 exit; 1449 1450 if assigned(genericdef) then 1451 include(def.defoptions,df_specialization) 1452 else 1453 if genericlist.count>0 then 1454 include(def.defoptions,df_generic); 1455 1456 case def.typ of 1457 recorddef,objectdef: st:=tabstractrecorddef(def).symtable; 1458 arraydef: st:=tarraydef(def).symtable; 1459 procvardef,procdef: st:=tabstractprocdef(def).parast; 1460 else 1461 internalerror(201101020); 1462 end; 1463 1464 if (genericlist.count>0) and not assigned(def.genericparas) then 1465 def.genericparas:=tfphashobjectlist.create(false); 1466 for i:=0 to genericlist.count-1 do 1467 begin 1468 generictype:=ttypesym(genericlist[i]); 1469 if assigned(generictype.owner) then 1470 begin 1471 sym:=ctypesym.create(genericlist.nameofindex(i),generictype.typedef); 1472 { type parameters need to be added as strict private } 1473 sym.visibility:=vis_strictprivate; 1474 st.insert(sym); 1475 include(sym.symoptions,sp_generic_para); 1476 end 1477 else 1478 begin 1479 if (generictype.typedef.typ=undefineddef) and (generictype.typedef<>cundefinedtype) then 1480 begin 1481 { the generic parameters were parsed before the genericdef existed thus the 1482 undefineddefs were added as part of the parent symtable } 1483 if assigned(generictype.typedef.owner) then 1484 generictype.typedef.owner.DefList.Extract(generictype.typedef); 1485 generictype.typedef.changeowner(st); 1486 end; 1487 st.insert(generictype); 1488 include(generictype.symoptions,sp_generic_para); 1489 end; 1490 def.genericparas.add(genericlist.nameofindex(i),generictype); 1491 end; 1492 end; 1493 1494 procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist); 1495 var 1496 gensym : ttypesym; 1497 begin 1498 { for generics in non-Delphi modes we insert a private type symbol 1499 that has the same base name as the currently parsed generic and 1500 that references this defs } 1501 if not (m_delphi in current_settings.modeswitches) and 1502 ( 1503 ( 1504 parse_generic and 1505 assigned(genericlist) and 1506 (genericlist.count>0) 1507 ) or 1508 ( 1509 assigned(current_specializedef) and 1510 assigned(current_structdef.genericdef) and 1511 (current_structdef.genericdef.typ in [objectdef,recorddef]) and 1512 (pos('$',name)>0) 1513 ) 1514 ) then 1515 begin 1516 { we need to pass nil as def here, because the constructor wants 1517 to set the typesym of the def which is not what we want } 1518 gensym:=ctypesym.create(copy(name,1,pos('$',name)-1),nil); 1519 gensym.typedef:=current_structdef; 1520 include(gensym.symoptions,sp_internal); 1521 { the symbol should be only visible to the generic class 1522 itself } 1523 gensym.visibility:=vis_strictprivate; 1524 symtablestack.top.insert(gensym); 1525 end; 1526 end; 1527 generate_generic_namenull1528 function generate_generic_name(const name:tidstring;specializename:ansistring;owner_hierarchy:string):tidstring; 1529 var 1530 crc : cardinal; 1531 begin 1532 if specializename='' then 1533 internalerror(2012061901); 1534 { build the new type's name } 1535 crc:=UpdateCrc32(0,specializename[1],length(specializename)); 1536 result:=name+'$crc'+hexstr(crc,8); 1537 if owner_hierarchy<>'' then 1538 begin 1539 crc:=UpdateCrc32(0,owner_hierarchy[1],length(owner_hierarchy)); 1540 result:=result+'$crc'+hexstr(crc,8); 1541 end; 1542 end; 1543 1544 procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint); 1545 var 1546 i,code : longint; 1547 countstr : string; 1548 begin 1549 for i:=length(name) downto 1 do 1550 if name[i]='$' then 1551 begin 1552 nongeneric:=copy(name,1,i-1); 1553 countstr:=copy(name,i+1,length(name)-i); 1554 val(countstr,count,code); 1555 if code<>0 then 1556 break; 1557 exit; 1558 end; 1559 nongeneric:=name; 1560 count:=0; 1561 end; 1562 1563 1564 procedure add_generic_dummysym(sym:tsym); 1565 var 1566 list: TFPObjectList; 1567 srsym : tsym; 1568 srsymtable : tsymtable; 1569 entry : tgenericdummyentry; 1570 begin 1571 if sp_generic_dummy in sym.symoptions then 1572 begin 1573 { did we already search for a generic with that name? } 1574 list:=tfpobjectlist(current_module.genericdummysyms.find(sym.name)); 1575 if not assigned(list) then 1576 begin 1577 list:=tfpobjectlist.create(true); 1578 current_module.genericdummysyms.add(sym.name,list); 1579 end; 1580 { is the dummy sym still "dummy"? } 1581 if (sym.typ=typesym) and 1582 ( 1583 { dummy sym defined in mode Delphi } 1584 (ttypesym(sym).typedef.typ=undefineddef) or 1585 { dummy sym defined in non-Delphi mode } 1586 (tstoreddef(ttypesym(sym).typedef).is_generic) 1587 ) then 1588 begin 1589 { do we have a non-generic type of the same name 1590 available? } 1591 if not searchsym_with_flags(sym.name,srsym,srsymtable,[ssf_no_addsymref]) then 1592 srsym:=nil; 1593 end 1594 else if (sym.typ=procsym) and 1595 (tprocsym(sym).procdeflist.count>0) then 1596 srsym:=sym 1597 else 1598 { dummy symbol is already not so dummy anymore } 1599 srsym:=nil; 1600 if assigned(srsym) then 1601 begin 1602 entry:=tgenericdummyentry.create; 1603 entry.resolvedsym:=srsym; 1604 entry.dummysym:=sym; 1605 list.add(entry); 1606 end; 1607 end; 1608 end; 1609 1610 resolve_generic_dummysymnull1611 function resolve_generic_dummysym(const name:tidstring):tsym; 1612 var 1613 list : tfpobjectlist; 1614 begin 1615 list:=tfpobjectlist(current_module.genericdummysyms.find(name)); 1616 if assigned(list) and (list.count>0) then 1617 result:=tgenericdummyentry(list.last).resolvedsym 1618 else 1619 result:=nil; 1620 end; 1621 1622 could_be_genericnull1623 function could_be_generic(const name:tidstring):boolean; 1624 begin 1625 result:=(name<>'') and 1626 (current_module.genericdummysyms.findindexof(name)>=0); 1627 end; 1628 1629 procedure specialization_init(genericdef:tdef;var state: tspecializationstate); 1630 var 1631 pu : tused_unit; 1632 hmodule : tmodule; 1633 unitsyms : TFPHashObjectList; 1634 sym : tsym; 1635 i : Integer; 1636 begin 1637 if not assigned(genericdef) then 1638 internalerror(200705151); 1639 { Setup symtablestack at definition time 1640 to get types right, however this is not perfect, we should probably record 1641 the resolved symbols } 1642 state.oldsymtablestack:=symtablestack; 1643 state.oldextendeddefs:=current_module.extendeddefs; 1644 state.oldgenericdummysyms:=current_module.genericdummysyms; 1645 current_module.extendeddefs:=TFPHashObjectList.create(true); 1646 current_module.genericdummysyms:=tfphashobjectlist.create(true); 1647 symtablestack:=tdefawaresymtablestack.create; 1648 hmodule:=find_module_from_symtable(genericdef.owner); 1649 if hmodule=nil then 1650 internalerror(200705152); 1651 { collect all unit syms in the generic's unit as we need to establish 1652 their unitsym.module link again so that unit identifiers can be used } 1653 unitsyms:=tfphashobjectlist.create(false); 1654 if (hmodule<>current_module) and assigned(hmodule.globalsymtable) then 1655 for i:=0 to hmodule.globalsymtable.symlist.count-1 do 1656 begin 1657 sym:=tsym(hmodule.globalsymtable.symlist[i]); 1658 if sym.typ=unitsym then 1659 unitsyms.add(upper(sym.realname),sym); 1660 end; 1661 { add all units if we are specializing inside the current unit (as the 1662 generic could have been declared in the implementation part), but load 1663 only interface units, if we are in a different unit as then the generic 1664 needs to be in the interface section } 1665 pu:=tused_unit(hmodule.used_units.first); 1666 while assigned(pu) do 1667 begin 1668 if not assigned(pu.u.globalsymtable) then 1669 { in certain circular, but valid unit constellations it can happen 1670 that we specialize a generic in a different unit that was used 1671 in the implementation section of the generic's unit and were the 1672 interface is still being parsed and thus the localsymtable is in 1673 reality the global symtable } 1674 if pu.u.in_interface then 1675 symtablestack.push(pu.u.localsymtable) 1676 else 1677 internalerror(200705153) 1678 else 1679 symtablestack.push(pu.u.globalsymtable); 1680 sym:=tsym(unitsyms.find(pu.u.modulename^)); 1681 if assigned(sym) and not assigned(tunitsym(sym).module) then 1682 tunitsym(sym).module:=pu.u; 1683 pu:=tused_unit(pu.next); 1684 end; 1685 unitsyms.free; 1686 if assigned(hmodule.globalsymtable) then 1687 symtablestack.push(hmodule.globalsymtable); 1688 { push the localsymtable if needed } 1689 if ((hmodule<>current_module) or not current_module.in_interface) 1690 and assigned(hmodule.localsymtable) then 1691 symtablestack.push(hmodule.localsymtable); 1692 end; 1693 1694 procedure specialization_done(var state: tspecializationstate); 1695 begin 1696 { Restore symtablestack } 1697 current_module.extendeddefs.free; 1698 current_module.extendeddefs:=state.oldextendeddefs; 1699 current_module.genericdummysyms.free; 1700 current_module.genericdummysyms:=state.oldgenericdummysyms; 1701 symtablestack.free; 1702 symtablestack:=state.oldsymtablestack; 1703 { clear the state record to be on the safe side } 1704 fillchar(state, sizeof(state), 0); 1705 end; 1706 1707 1708 {**************************************************************************** 1709 SPECIALIZATION BODY GENERATION 1710 ****************************************************************************} 1711 1712 1713 procedure process_procdef(def:tprocdef;hmodule:tmodule); 1714 var 1715 oldcurrent_filepos : tfileposinfo; 1716 begin 1717 if assigned(def.genericdef) and 1718 (def.genericdef.typ=procdef) and 1719 assigned(tprocdef(def.genericdef).generictokenbuf) then 1720 begin 1721 if not assigned(tprocdef(def.genericdef).generictokenbuf) then 1722 internalerror(2015061902); 1723 oldcurrent_filepos:=current_filepos; 1724 current_filepos:=tprocdef(def.genericdef).fileinfo; 1725 { use the index the module got from the current compilation process } 1726 current_filepos.moduleindex:=hmodule.unit_index; 1727 current_tokenpos:=current_filepos; 1728 current_scanner.startreplaytokens(tprocdef(def.genericdef).generictokenbuf,hmodule.change_endian); 1729 read_proc_body(def); 1730 current_filepos:=oldcurrent_filepos; 1731 end 1732 { synthetic routines will be implemented afterwards } 1733 else if def.synthetickind=tsk_none then 1734 MessagePos1(def.fileinfo,sym_e_forward_not_resolved,def.fullprocname(false)); 1735 end; 1736 1737 process_abstractrecorddefnull1738 function process_abstractrecorddef(def:tabstractrecorddef):boolean; 1739 var 1740 i : longint; 1741 hp : tdef; 1742 hmodule : tmodule; 1743 begin 1744 result:=true; 1745 hmodule:=find_module_from_symtable(def.genericdef.owner); 1746 if hmodule=nil then 1747 internalerror(201202041); 1748 for i:=0 to def.symtable.DefList.Count-1 do 1749 begin 1750 hp:=tdef(def.symtable.DefList[i]); 1751 if hp.typ=procdef then 1752 begin 1753 { only generate the code if we need a body } 1754 if assigned(tprocdef(hp).struct) and not tprocdef(hp).forwarddef then 1755 continue; 1756 { and the body is available already (which is implicitely the 1757 case if the generic routine is part of another unit) } 1758 if ((hmodule=current_module) or (hmodule.state=ms_compile)) and 1759 { may not be assigned in case it's a synthetic procdef that 1760 still needs to be generated } 1761 assigned(tprocdef(hp).genericdef) and 1762 tprocdef(tprocdef(hp).genericdef).forwarddef then 1763 begin 1764 result:=false; 1765 continue; 1766 end; 1767 process_procdef(tprocdef(hp),hmodule); 1768 end 1769 else 1770 if hp.typ in [objectdef,recorddef] then 1771 { generate code for subtypes as well } 1772 result:=process_abstractrecorddef(tabstractrecorddef(hp)) and result; 1773 end; 1774 end; 1775 1776 1777 procedure generate_specialization_procs; 1778 var 1779 i : longint; 1780 list, 1781 readdlist : tfpobjectlist; 1782 def : tstoreddef; 1783 state : tspecializationstate; 1784 hmodule : tmodule; 1785 begin 1786 { first copy all entries and then work with that list to ensure that 1787 we don't get an infinite recursion } 1788 list:=tfpobjectlist.create(false); 1789 readdlist:=tfpobjectlist.create(false); 1790 1791 for i:=0 to current_module.pendingspecializations.Count-1 do 1792 list.add(current_module.pendingspecializations.Items[i]); 1793 1794 current_module.pendingspecializations.clear; 1795 1796 for i:=0 to list.count-1 do 1797 begin 1798 def:=tstoreddef(list[i]); 1799 if not tstoreddef(def).is_specialization then 1800 continue; 1801 case def.typ of 1802 procdef: 1803 begin 1804 { the use of forwarddef should not backfire as the 1805 specialization always belongs to the current module } 1806 if not tprocdef(def).forwarddef then 1807 continue; 1808 if not assigned(def.genericdef) then 1809 internalerror(2015061903); 1810 hmodule:=find_module_from_symtable(def.genericdef.owner); 1811 if hmodule=nil then 1812 internalerror(2015061904); 1813 { we need to check for a forward declaration only if the 1814 generic was declared in the same unit (otherwise there 1815 should be one) } 1816 if ((hmodule=current_module) or (hmodule.state=ms_compile)) and tprocdef(def.genericdef).forwarddef then 1817 begin 1818 readdlist.add(def); 1819 continue; 1820 end; 1821 1822 specialization_init(tstoreddef(def).genericdef,state); 1823 1824 process_procdef(tprocdef(def),hmodule); 1825 1826 specialization_done(state); 1827 end; 1828 recorddef, 1829 objectdef: 1830 begin 1831 specialization_init(tstoreddef(def).genericdef,state); 1832 1833 if not process_abstractrecorddef(tabstractrecorddef(def)) then 1834 readdlist.add(def); 1835 1836 specialization_done(state); 1837 end; 1838 end; 1839 end; 1840 1841 { add those defs back to the pending list for which we don't yet have 1842 all method bodies } 1843 for i:=0 to readdlist.count-1 do 1844 current_module.pendingspecializations.add(tstoreddef(readdlist[i]).typename,readdlist[i]); 1845 1846 readdlist.free; 1847 list.free; 1848 end; 1849 1850 1851 procedure maybe_add_pending_specialization(def:tdef); 1852 var 1853 hmodule : tmodule; 1854 st : tsymtable; 1855 begin 1856 if parse_generic then 1857 exit; 1858 st:=def.owner; 1859 while st.symtabletype in [localsymtable] do 1860 st:=st.defowner.owner; 1861 hmodule:=find_module_from_symtable(st); 1862 if tstoreddef(def).is_specialization and (hmodule=current_module) then 1863 current_module.pendingspecializations.add(def.typename,def); 1864 end; 1865 1866 end. 1867