1 { 2 Copyright (c) 1998-2002 by Florian Klaempfl 3 4 Does declaration (but not type) parsing for Free Pascal 5 6 This program is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 2 of the License, or 9 (at your option) any later version. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 You should have received a copy of the GNU General Public License 17 along with this program; if not, write to the Free Software 18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 19 20 **************************************************************************** 21 } 22 unit pdecl; 23 24 {$i fpcdefs.inc} 25 26 interface 27 28 uses 29 { common } 30 cclasses, 31 { global } 32 globtype, 33 { symtable } 34 symsym,symdef, 35 { pass_1 } 36 node; 37 readconstantnull38 function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym; 39 40 procedure const_dec(out had_generic:boolean); 41 procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean); 42 procedure label_dec; 43 procedure type_dec(out had_generic:boolean); 44 procedure types_dec(in_structure: boolean;out had_generic:boolean); 45 procedure var_dec(out had_generic:boolean); 46 procedure threadvar_dec(out had_generic:boolean); 47 procedure property_dec; 48 procedure resourcestring_dec(out had_generic:boolean); 49 50 implementation 51 52 uses 53 { common } 54 cutils, 55 { global } 56 globals,tokens,verbose,widestr,constexp, 57 systems,aasmdata,fmodule,compinnr, 58 { symtable } 59 symconst,symbase,symtype,symcpu,symcreat,defutil,defcmp, 60 { pass 1 } 61 ninl,ncon,nobj,ngenutil, 62 { parser } 63 scanner, 64 pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj,pgenutil,pparautl, 65 {$ifdef jvm} 66 pjvm, 67 {$endif} 68 { cpu-information } 69 cpuinfo 70 ; 71 72 readconstantnull73 function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym; 74 var 75 hp : tconstsym; 76 p : tnode; 77 ps : pconstset; 78 pd : pbestreal; 79 pg : pguid; 80 sp : pchar; 81 pw : pcompilerwidestring; 82 storetokenpos : tfileposinfo; 83 begin 84 readconstant:=nil; 85 if orgname='' then 86 internalerror(9584582); 87 hp:=nil; 88 p:=comp_expr([ef_accept_equal]); 89 nodetype:=p.nodetype; 90 storetokenpos:=current_tokenpos; 91 current_tokenpos:=filepos; 92 case p.nodetype of 93 ordconstn: 94 begin 95 if p.resultdef.typ=pointerdef then 96 hp:=cconstsym.create_ordptr(orgname,constpointer,tordconstnode(p).value.uvalue,p.resultdef) 97 else 98 hp:=cconstsym.create_ord(orgname,constord,tordconstnode(p).value,p.resultdef); 99 end; 100 stringconstn: 101 begin 102 if is_wide_or_unicode_string(p.resultdef) then 103 begin 104 initwidestring(pw); 105 copywidestring(pcompilerwidestring(tstringconstnode(p).value_str),pw); 106 hp:=cconstsym.create_wstring(orgname,constwstring,pw); 107 end 108 else 109 begin 110 getmem(sp,tstringconstnode(p).len+1); 111 move(tstringconstnode(p).value_str^,sp^,tstringconstnode(p).len+1); 112 { if a non-default ansistring code page has been specified, 113 keep it } 114 if is_ansistring(p.resultdef) and 115 (tstringdef(p.resultdef).encoding<>0) then 116 hp:=cconstsym.create_string(orgname,conststring,sp,tstringconstnode(p).len,p.resultdef) 117 else 118 hp:=cconstsym.create_string(orgname,conststring,sp,tstringconstnode(p).len,nil); 119 end; 120 end; 121 realconstn : 122 begin 123 new(pd); 124 pd^:=trealconstnode(p).value_real; 125 hp:=cconstsym.create_ptr(orgname,constreal,pd,p.resultdef); 126 end; 127 setconstn : 128 begin 129 new(ps); 130 ps^:=tsetconstnode(p).value_set^; 131 hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); 132 end; 133 pointerconstn : 134 begin 135 hp:=cconstsym.create_ordptr(orgname,constpointer,tpointerconstnode(p).value,p.resultdef); 136 end; 137 niln : 138 begin 139 hp:=cconstsym.create_ord(orgname,constnil,0,p.resultdef); 140 end; 141 typen : 142 begin 143 if is_interface(p.resultdef) then 144 begin 145 if assigned(tobjectdef(p.resultdef).iidguid) then 146 begin 147 new(pg); 148 pg^:=tobjectdef(p.resultdef).iidguid^; 149 hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); 150 end 151 else 152 Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); 153 end 154 else 155 Message(parser_e_illegal_expression); 156 end; 157 inlinen: 158 begin 159 { this situation only happens if a intrinsic is parsed that has a 160 generic type as its argument. As we don't know certain 161 information about the final type yet, we need to use safe 162 values (mostly 0, except for (Bit)SizeOf()) } 163 if not parse_generic then 164 Message(parser_e_illegal_expression); 165 case tinlinenode(p).inlinenumber of 166 in_sizeof_x: 167 begin 168 hp:=cconstsym.create_ord(orgname,constord,1,p.resultdef); 169 end; 170 in_bitsizeof_x: 171 begin 172 hp:=cconstsym.create_ord(orgname,constord,8,p.resultdef); 173 end; 174 { add other cases here if necessary } 175 else 176 Message(parser_e_illegal_expression); 177 end; 178 end; 179 else 180 Message(parser_e_illegal_expression); 181 end; 182 current_tokenpos:=storetokenpos; 183 p.free; 184 readconstant:=hp; 185 end; 186 187 procedure const_dec(out had_generic:boolean); 188 begin 189 consume(_CONST); 190 consts_dec(false,true,had_generic); 191 end; 192 193 procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean); 194 var 195 orgname : TIDString; 196 hdef : tdef; 197 sym : tsym; 198 dummysymoptions : tsymoptions; 199 deprecatedmsg : pshortstring; 200 storetokenpos,filepos : tfileposinfo; 201 nodetype : tnodetype; 202 old_block_type : tblock_type; 203 first, 204 isgeneric, 205 skipequal : boolean; 206 tclist : tasmlist; 207 varspez : tvarspez; 208 begin 209 old_block_type:=block_type; 210 block_type:=bt_const; 211 had_generic:=false; 212 first:=true; 213 repeat 214 orgname:=orgpattern; 215 filepos:=current_tokenpos; 216 isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC); 217 consume(_ID); 218 case token of 219 220 _EQ: 221 begin 222 consume(_EQ); 223 sym:=readconstant(orgname,filepos,nodetype); 224 { Support hint directives } 225 dummysymoptions:=[]; 226 deprecatedmsg:=nil; 227 try_consume_hintdirective(dummysymoptions,deprecatedmsg); 228 if assigned(sym) then 229 begin 230 sym.symoptions:=sym.symoptions+dummysymoptions; 231 sym.deprecatedmsg:=deprecatedmsg; 232 sym.visibility:=symtablestack.top.currentvisibility; 233 symtablestack.top.insert(sym); 234 {$ifdef jvm} 235 { for the JVM target, some constants need to be 236 initialized at run time (enums, sets) -> create fake 237 typed const to do so (at least if they are visible 238 outside this routine, since we won't directly access 239 these symbols in the generated code) } 240 if (symtablestack.top.symtablelevel<normal_function_level) and 241 assigned(tconstsym(sym).constdef) and 242 (tconstsym(sym).constdef.typ in [enumdef,setdef]) then 243 jvm_add_typed_const_initializer(tconstsym(sym)); 244 {$endif} 245 end 246 else 247 stringdispose(deprecatedmsg); 248 consume(_SEMICOLON); 249 end; 250 251 _COLON: 252 begin 253 if not allow_typed_const then 254 begin 255 Message(parser_e_no_typed_const); 256 consume_all_until(_SEMICOLON); 257 end; 258 { set the blocktype first so a consume also supports a 259 caret, to support const s : ^string = nil } 260 block_type:=bt_const_type; 261 consume(_COLON); 262 read_anon_type(hdef,false); 263 block_type:=bt_const; 264 skipequal:=false; 265 { create symbol } 266 storetokenpos:=current_tokenpos; 267 current_tokenpos:=filepos; 268 if not (cs_typed_const_writable in current_settings.localswitches) then 269 varspez:=vs_const 270 else 271 varspez:=vs_value; 272 { if we are dealing with structure const then we need to handle it as a 273 structure static variable: create a symbol in unit symtable and a reference 274 to it from the structure or linking will fail } 275 if symtablestack.top.symtabletype in [recordsymtable,ObjectSymtable] then 276 begin 277 { note: we keep hdef so that we might at least read the 278 constant data correctly for error recovery } 279 check_allowed_for_var_or_const(hdef,false); 280 sym:=cfieldvarsym.create(orgname,varspez,hdef,[]); 281 symtablestack.top.insert(sym); 282 sym:=make_field_static(symtablestack.top,tfieldvarsym(sym)); 283 end 284 else 285 begin 286 sym:=cstaticvarsym.create(orgname,varspez,hdef,[]); 287 sym.visibility:=symtablestack.top.currentvisibility; 288 symtablestack.top.insert(sym); 289 end; 290 current_tokenpos:=storetokenpos; 291 { procvar can have proc directives, but not type references } 292 if (hdef.typ=procvardef) and 293 (hdef.typesym=nil) then 294 begin 295 { support p : procedure;stdcall=nil; } 296 if try_to_consume(_SEMICOLON) then 297 begin 298 if check_proc_directive(true) then 299 parse_var_proc_directives(sym) 300 else 301 begin 302 Message(parser_e_proc_directive_expected); 303 skipequal:=true; 304 end; 305 end 306 else 307 { support p : procedure stdcall=nil; } 308 begin 309 if check_proc_directive(true) then 310 parse_var_proc_directives(sym); 311 end; 312 { add default calling convention } 313 handle_calling_convention(tabstractprocdef(hdef),hcc_default_actions_intf); 314 end; 315 if not skipequal then 316 begin 317 { get init value } 318 consume(_EQ); 319 if (cs_typed_const_writable in current_settings.localswitches) then 320 tclist:=current_asmdata.asmlists[al_typedconsts] 321 else 322 tclist:=current_asmdata.asmlists[al_rotypedconsts]; 323 read_typed_const(tclist,tstaticvarsym(sym),in_structure); 324 end; 325 end; 326 327 else 328 if not first and isgeneric and (token in [_PROCEDURE,_FUNCTION,_CLASS]) then 329 begin 330 had_generic:=true; 331 break; 332 end 333 else 334 { generate an error } 335 consume(_EQ); 336 end; 337 338 first:=false; 339 until (token<>_ID) or 340 (in_structure and 341 ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or 342 ((m_final_fields in current_settings.modeswitches) and 343 (idtoken=_FINAL)))); 344 block_type:=old_block_type; 345 end; 346 347 348 procedure label_dec; 349 var 350 labelsym : tlabelsym; 351 begin 352 consume(_LABEL); 353 if not(cs_support_goto in current_settings.moduleswitches) then 354 Message(sym_e_goto_and_label_not_supported); 355 repeat 356 if not(token in [_ID,_INTCONST]) then 357 consume(_ID) 358 else 359 begin 360 if token=_ID then 361 labelsym:=clabelsym.create(orgpattern) 362 else 363 begin 364 { strip leading 0's in iso mode } 365 if (([m_iso,m_extpas]*current_settings.modeswitches)<>[]) then 366 while pattern[1]='0' do 367 delete(pattern,1,1); 368 labelsym:=clabelsym.create(pattern); 369 end; 370 371 symtablestack.top.insert(labelsym); 372 if m_non_local_goto in current_settings.modeswitches then 373 begin 374 if symtablestack.top.symtabletype=localsymtable then 375 begin 376 labelsym.jumpbuf:=clocalvarsym.create('LABEL$_'+labelsym.name,vs_value,rec_jmp_buf,[]); 377 symtablestack.top.insert(labelsym.jumpbuf); 378 end 379 else 380 begin 381 labelsym.jumpbuf:=cstaticvarsym.create('LABEL$_'+labelsym.name,vs_value,rec_jmp_buf,[]); 382 symtablestack.top.insert(labelsym.jumpbuf); 383 cnodeutils.insertbssdata(tstaticvarsym(labelsym.jumpbuf)); 384 end; 385 include(labelsym.jumpbuf.symoptions,sp_internal); 386 { the buffer will be setup later, but avoid a hint } 387 tabstractvarsym(labelsym.jumpbuf).varstate:=vs_written; 388 end; 389 consume(token); 390 end; 391 if token<>_SEMICOLON then consume(_COMMA); 392 until not(token in [_ID,_INTCONST]); 393 consume(_SEMICOLON); 394 end; 395 396 { From http://clang.llvm.org/docs/LanguageExtensions.html#objective-c-features : 397 To determine whether a method has an inferred related result type, the first word in the camel-case selector 398 (e.g., “init” in “initWithObjects”) is considered, and the method will have a related result type if its return 399 type is compatible with the type of its class and if: 400 * the first word is "alloc" or "new", and the method is a class method, or 401 * the first word is "autorelease", "init", "retain", or "self", and the method is an instance method. 402 403 If a method with a related result type is overridden by a subclass method, the subclass method must also return 404 a type that is compatible with the subclass type. 405 } 406 procedure pd_set_objc_related_result(def: tobject; para: pointer); 407 var 408 pd: tprocdef; 409 i, firstcamelend: longint; 410 inferresult: boolean; 411 begin 412 if tdef(def).typ<>procdef then 413 exit; 414 pd:=tprocdef(def); 415 if not(po_msgstr in pd.procoptions) then 416 internalerror(2019082401); 417 firstcamelend:=length(pd.messageinf.str^); 418 for i:=1 to length(pd.messageinf.str^) do 419 if pd.messageinf.str^[i] in ['A'..'Z'] then 420 begin 421 firstcamelend:=pred(i); 422 break; 423 end; 424 case copy(pd.messageinf.str^,1,firstcamelend) of 425 'alloc', 426 'new': 427 inferresult:=po_classmethod in pd.procoptions; 428 'autorelease', 429 'init', 430 'retain', 431 'self': 432 inferresult:=not(po_classmethod in pd.procoptions); 433 else 434 inferresult:=false; 435 end; 436 if inferresult and 437 def_is_related(tdef(pd.procsym.owner.defowner),pd.returndef) then 438 include(pd.procoptions,po_objc_related_result_type); 439 end; 440 441 procedure types_dec(in_structure: boolean;out had_generic:boolean); 442 determine_generic_defnull443 function determine_generic_def(name:tidstring):tstoreddef; 444 var 445 hashedid : THashedIDString; 446 pd : tprocdef; 447 sym : tsym; 448 begin 449 result:=nil; 450 { check whether this is a declaration of a type inside a 451 specialization } 452 if assigned(current_structdef) and 453 (df_specialization in current_structdef.defoptions) then 454 begin 455 if not assigned(current_structdef.genericdef) or 456 not (current_structdef.genericdef.typ in [recorddef,objectdef]) then 457 internalerror(2011052301); 458 hashedid.id:=name; 459 { we could be inside a method of the specialization 460 instead of its declaration, so check that first (as 461 local nested types aren't allowed we don't need to 462 walk the symtablestack to find the localsymtable) } 463 if symtablestack.top.symtabletype=localsymtable then 464 begin 465 { we are in a method } 466 if not assigned(symtablestack.top.defowner) or 467 (symtablestack.top.defowner.typ<>procdef) then 468 internalerror(2011120701); 469 pd:=tprocdef(symtablestack.top.defowner); 470 if not assigned(pd.genericdef) or (pd.genericdef.typ<>procdef) then 471 internalerror(2011120702); 472 sym:=tsym(tprocdef(pd.genericdef).localst.findwithhash(hashedid)); 473 end 474 else 475 sym:=nil; 476 if not assigned(sym) or not (sym.typ=typesym) then 477 begin 478 { now search in the declaration of the generic } 479 sym:=tsym(tabstractrecorddef(current_structdef.genericdef).symtable.findwithhash(hashedid)); 480 if not assigned(sym) or not (sym.typ=typesym) then 481 internalerror(2011052302); 482 end; 483 { use the corresponding type in the generic's symtable as 484 genericdef for the specialized type } 485 result:=tstoreddef(ttypesym(sym).typedef); 486 end; 487 end; 488 489 procedure finalize_class_external_status(od: tobjectdef); 490 begin 491 if [oo_is_external,oo_is_forward] <= od.objectoptions then 492 begin 493 { formal definition: x = objcclass external; } 494 exclude(od.objectoptions,oo_is_forward); 495 include(od.objectoptions,oo_is_formal); 496 end; 497 end; 498 499 var 500 typename,orgtypename, 501 gentypename,genorgtypename : TIDString; 502 newtype : ttypesym; 503 sym : tsym; 504 hdef : tdef; 505 defpos,storetokenpos : tfileposinfo; 506 old_block_type : tblock_type; 507 old_checkforwarddefs: TFPObjectList; 508 objecttype : tobjecttyp; 509 first, 510 isgeneric, 511 isunique, 512 istyperenaming : boolean; 513 generictypelist : tfphashobjectlist; 514 localgenerictokenbuf : tdynamicarray; 515 vmtbuilder : TVMTBuilder; 516 p:tnode; 517 gendef : tstoreddef; 518 s : shortstring; 519 i : longint; 520 {$ifdef x86} 521 segment_register: string; 522 {$endif x86} 523 begin 524 old_block_type:=block_type; 525 { save unit container of forward declarations - 526 we can be inside nested class type block } 527 old_checkforwarddefs:=current_module.checkforwarddefs; 528 current_module.checkforwarddefs:=TFPObjectList.Create(false); 529 block_type:=bt_type; 530 hdef:=nil; 531 first:=true; 532 had_generic:=false; 533 repeat 534 defpos:=current_tokenpos; 535 istyperenaming:=false; 536 generictypelist:=nil; 537 localgenerictokenbuf:=nil; 538 539 { fpc generic declaration? } 540 if first then 541 had_generic:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC); 542 isgeneric:=had_generic; 543 544 typename:=pattern; 545 orgtypename:=orgpattern; 546 consume(_ID); 547 548 { delphi generic declaration? } 549 if (m_delphi in current_settings.modeswitches) then 550 isgeneric:=token=_LSHARPBRACKET; 551 552 { Generic type declaration? } 553 if isgeneric then 554 begin 555 if assigned(current_genericdef) then 556 Message(parser_f_no_generic_inside_generic); 557 558 consume(_LSHARPBRACKET); 559 generictypelist:=parse_generic_parameters(true); 560 consume(_RSHARPBRACKET); 561 562 { we are not freeing the type parameters, so register them } 563 for i:=0 to generictypelist.count-1 do 564 begin 565 ttypesym(generictypelist[i]).register_sym; 566 tstoreddef(ttypesym(generictypelist[i]).typedef).register_def; 567 end; 568 569 str(generictypelist.Count,s); 570 gentypename:=typename+'$'+s; 571 genorgtypename:=orgtypename+'$'+s; 572 end 573 else 574 begin 575 gentypename:=typename; 576 genorgtypename:=orgtypename; 577 end; 578 579 580 consume(_EQ); 581 582 { support 'ttype=type word' syntax } 583 isunique:=try_to_consume(_TYPE); 584 585 { MacPas object model is more like Delphi's than like TP's, but } 586 { uses the object keyword instead of class } 587 if (m_mac in current_settings.modeswitches) and 588 (token = _OBJECT) then 589 token := _CLASS; 590 591 { Start recording a generic template } 592 if assigned(generictypelist) then 593 begin 594 localgenerictokenbuf:=tdynamicarray.create(256); 595 current_scanner.startrecordtokens(localgenerictokenbuf); 596 end; 597 598 { is the type already defined? -- must be in the current symtable, 599 not in a nested symtable or one higher up the stack -> don't 600 use searchsym & frinds! } 601 sym:=tsym(symtablestack.top.find(gentypename)); 602 newtype:=nil; 603 { found a symbol with this name? } 604 if assigned(sym) then 605 begin 606 if (sym.typ=typesym) and 607 { this should not be a symbol that was created by a generic 608 that was declared earlier } 609 not ( 610 (ttypesym(sym).typedef.typ=undefineddef) and 611 (sp_generic_dummy in sym.symoptions) 612 ) then 613 begin 614 if ((token=_CLASS) or 615 (token=_INTERFACE) or 616 (token=_DISPINTERFACE) or 617 (token=_OBJCCLASS) or 618 (token=_OBJCPROTOCOL) or 619 (token=_OBJCCATEGORY)) and 620 (assigned(ttypesym(sym).typedef)) and 621 is_implicit_pointer_object_type(ttypesym(sym).typedef) and 622 (oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then 623 begin 624 case token of 625 _CLASS : 626 objecttype:=default_class_type; 627 _INTERFACE : 628 case current_settings.interfacetype of 629 it_interfacecom: 630 objecttype:=odt_interfacecom; 631 it_interfacecorba: 632 objecttype:=odt_interfacecorba; 633 it_interfacejava: 634 objecttype:=odt_interfacejava; 635 else 636 internalerror(2010122611); 637 end; 638 _DISPINTERFACE : 639 objecttype:=odt_dispinterface; 640 _OBJCCLASS, 641 _OBJCCATEGORY : 642 objecttype:=odt_objcclass; 643 _OBJCPROTOCOL : 644 objecttype:=odt_objcprotocol; 645 else 646 internalerror(200811072); 647 end; 648 consume(token); 649 { determine the generic def in case we are in a nested type 650 of a specialization } 651 gendef:=determine_generic_def(gentypename); 652 { we can ignore the result, the definition is modified } 653 object_dec(objecttype,genorgtypename,newtype,gendef,generictypelist,tobjectdef(ttypesym(sym).typedef),ht_none); 654 newtype:=ttypesym(sym); 655 hdef:=newtype.typedef; 656 end 657 else 658 message1(parser_h_type_redef,genorgtypename); 659 end; 660 end; 661 { no old type reused ? Then insert this new type } 662 if not assigned(newtype) then 663 begin 664 { insert the new type first with an errordef, so that 665 referencing the type before it's really set it 666 will give an error (PFV) } 667 hdef:=generrordef; 668 gendef:=nil; 669 storetokenpos:=current_tokenpos; 670 if isgeneric then 671 begin 672 { for generics we need to check whether a non-generic type 673 already exists and if not we need to insert a symbol with 674 the non-generic name (available in (org)typename) that is a 675 undefineddef, so that inline specializations can be used } 676 sym:=tsym(symtablestack.top.Find(typename)); 677 if not assigned(sym) then 678 begin 679 sym:=ctypesym.create(orgtypename,cundefineddef.create(true)); 680 Include(sym.symoptions,sp_generic_dummy); 681 ttypesym(sym).typedef.typesym:=sym; 682 sym.visibility:=symtablestack.top.currentvisibility; 683 symtablestack.top.insert(sym); 684 ttypesym(sym).typedef.owner:=sym.owner; 685 end 686 else 687 { this is not allowed in non-Delphi modes } 688 if not (m_delphi in current_settings.modeswitches) then 689 Message1(sym_e_duplicate_id,genorgtypename) 690 else 691 begin 692 { we need to find this symbol even if it's a variable or 693 something else when doing an inline specialization } 694 Include(sym.symoptions,sp_generic_dummy); 695 add_generic_dummysym(sym); 696 end; 697 end 698 else 699 begin 700 if assigned(sym) and (sym.typ=typesym) and 701 (ttypesym(sym).typedef.typ=undefineddef) and 702 (sp_generic_dummy in sym.symoptions) then 703 begin 704 { this is a symbol that was added by an earlier generic 705 declaration, reuse it } 706 newtype:=ttypesym(sym); 707 newtype.typedef:=hdef; 708 { use the correct casing } 709 newtype.RealName:=genorgtypename; 710 sym:=nil; 711 end; 712 713 { determine the generic def in case we are in a nested type 714 of a specialization } 715 gendef:=determine_generic_def(gentypename); 716 end; 717 { insert a new type if we don't reuse an existing symbol } 718 if not assigned(newtype) then 719 begin 720 newtype:=ctypesym.create(genorgtypename,hdef); 721 newtype.visibility:=symtablestack.top.currentvisibility; 722 symtablestack.top.insert(newtype); 723 end; 724 current_tokenpos:=defpos; 725 current_tokenpos:=storetokenpos; 726 { read the type definition } 727 read_named_type(hdef,newtype,gendef,generictypelist,false,isunique); 728 { update the definition of the type } 729 if assigned(hdef) then 730 begin 731 if df_generic in hdef.defoptions then 732 { flag parent symtables that they now contain a generic } 733 hdef.owner.includeoption(sto_has_generic); 734 if assigned(hdef.typesym) then 735 begin 736 istyperenaming:=true; 737 include(newtype.symoptions,sp_explicitrename); 738 end; 739 if isunique then 740 begin 741 if is_objc_class_or_protocol(hdef) or 742 is_java_class_or_interface(hdef) then 743 Message(parser_e_unique_unsupported); 744 745 if is_object(hdef) or 746 is_class_or_interface_or_dispinterface(hdef) then 747 begin 748 { just create a child class type; this is 749 Delphi-compatible } 750 hdef:=cobjectdef.create(tobjectdef(hdef).objecttype,genorgtypename,tobjectdef(hdef),true); 751 end 752 else 753 begin 754 hdef:=tstoreddef(hdef).getcopy; 755 { check if it is an ansistirng(codepage) declaration } 756 if is_ansistring(hdef) and try_to_consume(_LKLAMMER) then 757 begin 758 p:=comp_expr([ef_accept_equal]); 759 consume(_RKLAMMER); 760 if not is_constintnode(p) then 761 begin 762 Message(parser_e_illegal_expression); 763 { error recovery } 764 end 765 else 766 begin 767 if (tordconstnode(p).value<0) or (tordconstnode(p).value>65535) then 768 begin 769 Message(parser_e_invalid_codepage); 770 tordconstnode(p).value:=0; 771 end; 772 tstringdef(hdef).encoding:=int64(tordconstnode(p).value); 773 end; 774 p.free; 775 end; 776 if (hdef.typ in [pointerdef,classrefdef]) and 777 (tabstractpointerdef(hdef).pointeddef.typ=forwarddef) then 778 current_module.checkforwarddefs.add(hdef); 779 end; 780 include(hdef.defoptions,df_unique); 781 end; 782 if not assigned(hdef.typesym) then 783 begin 784 hdef.typesym:=newtype; 785 if sp_generic_dummy in newtype.symoptions then 786 add_generic_dummysym(newtype); 787 end; 788 end; 789 { in non-Delphi modes we need a reference to the generic def 790 without the generic suffix, so it can be found easily when 791 parsing method implementations } 792 if isgeneric and assigned(sym) and 793 not (m_delphi in current_settings.modeswitches) and 794 (ttypesym(sym).typedef.typ=undefineddef) then 795 { don't free the undefineddef as the defids rely on the count 796 of the defs in the def list of the module} 797 ttypesym(sym).typedef:=hdef; 798 newtype.typedef:=hdef; 799 { ensure that the type is registered when no specialization is 800 currently done } 801 if current_scanner.replay_stack_depth=0 then 802 hdef.register_def; 803 { KAZ: handle TGUID declaration in system unit } 804 if (cs_compilesystem in current_settings.moduleswitches) and 805 assigned(hdef) and 806 (hdef.typ=recorddef) then 807 begin 808 if not assigned(rec_tguid) and 809 (gentypename='TGUID') and 810 (hdef.size=16) then 811 rec_tguid:=trecorddef(hdef) 812 else if not assigned(rec_jmp_buf) and 813 (gentypename='JMP_BUF') then 814 rec_jmp_buf:=trecorddef(hdef) 815 else if not assigned(rec_exceptaddr) and 816 (gentypename='TEXCEPTADDR') then 817 rec_exceptaddr:=trecorddef(hdef); 818 end; 819 end; 820 if assigned(hdef) then 821 begin 822 case hdef.typ of 823 pointerdef : 824 begin 825 try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg); 826 consume(_SEMICOLON); 827 {$ifdef x86} 828 {$ifdef i8086} 829 if try_to_consume(_HUGE) then 830 begin 831 tcpupointerdef(hdef).x86pointertyp:=x86pt_huge; 832 consume(_SEMICOLON); 833 end 834 else 835 {$endif i8086} 836 if try_to_consume(_FAR) then 837 begin 838 {$if defined(i8086)} 839 tcpupointerdef(hdef).x86pointertyp:=x86pt_far; 840 {$elseif defined(i386)} 841 tcpupointerdef(hdef).x86pointertyp:=x86pt_near_fs; 842 {$elseif defined(x86_64)} 843 { for compatibility with previous versions of fpc, 844 far pointer = regular pointer on x86_64 } 845 Message1(parser_w_ptr_type_ignored,'FAR'); 846 {$endif} 847 consume(_SEMICOLON); 848 end 849 else 850 if try_to_consume(_NEAR) then 851 begin 852 if token <> _SEMICOLON then 853 begin 854 segment_register:=get_stringconst; 855 case UpCase(segment_register) of 856 'CS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_cs; 857 'DS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_ds; 858 'SS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_ss; 859 'ES': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_es; 860 'FS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_fs; 861 'GS': tcpupointerdef(hdef).x86pointertyp:=x86pt_near_gs; 862 else 863 Message(asmr_e_invalid_register); 864 end; 865 end 866 else 867 tcpupointerdef(hdef).x86pointertyp:=x86pt_near; 868 consume(_SEMICOLON); 869 end; 870 {$else x86} 871 { Previous versions of FPC support declaring a pointer as 872 far even on non-x86 platforms. } 873 if try_to_consume(_FAR) then 874 begin 875 Message1(parser_w_ptr_type_ignored,'FAR'); 876 consume(_SEMICOLON); 877 end; 878 {$endif x86} 879 end; 880 procvardef : 881 begin 882 { in case of type renaming, don't parse proc directives } 883 if istyperenaming then 884 begin 885 try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg); 886 consume(_SEMICOLON); 887 end 888 else 889 begin 890 if not check_proc_directive(true) then 891 begin 892 try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg); 893 consume(_SEMICOLON); 894 end; 895 parse_var_proc_directives(tsym(newtype)); 896 if po_is_function_ref in tprocvardef(hdef).procoptions then 897 begin 898 { these always support everything, no "of object" or 899 "is_nested" is allowed } 900 if is_nested_pd(tprocvardef(hdef)) or 901 is_methodpointer(hdef) then 902 cgmessage(type_e_function_reference_kind) 903 else 904 begin 905 { this message is only temporary; once Delphi style anonymous functions 906 are supported, this check is no longer required } 907 if not (po_is_block in tprocvardef(hdef).procoptions) then 908 comment(v_error,'Function references are not yet supported, only C blocks (add "cblock;" at the end)'); 909 end; 910 end; 911 handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf); 912 if po_is_function_ref in tprocvardef(hdef).procoptions then 913 begin 914 if (po_is_block in tprocvardef(hdef).procoptions) and 915 not (tprocvardef(hdef).proccalloption in [pocall_cdecl,pocall_mwpascal]) then 916 message(type_e_cblock_callconv); 917 end; 918 if try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg) then 919 consume(_SEMICOLON); 920 end; 921 end; 922 objectdef : 923 begin 924 try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg); 925 consume(_SEMICOLON); 926 927 { change a forward and external class declaration into 928 formal external definition, so the compiler does not 929 expect an real definition later } 930 if is_objc_class_or_protocol(hdef) or 931 is_java_class_or_interface(hdef) then 932 finalize_class_external_status(tobjectdef(hdef)); 933 934 { Build VMT indexes, skip for type renaming and forward classes } 935 if (hdef.typesym=newtype) and 936 not(oo_is_forward in tobjectdef(hdef).objectoptions) then 937 begin 938 vmtbuilder:=TVMTBuilder.Create(tobjectdef(hdef)); 939 vmtbuilder.generate_vmt; 940 vmtbuilder.free; 941 end; 942 943 { In case of an objcclass, verify that all methods have a message 944 name set. We only check this now, because message names can be set 945 during the protocol (interface) mapping. At the same time, set the 946 mangled names (these depend on the "external" name of the class), 947 and mark private fields of external classes as "used" (to avoid 948 bogus notes about them being unused) 949 } 950 { watch out for crashes in case of errors } 951 if is_objc_class_or_protocol(hdef) and 952 (not is_objccategory(hdef) or 953 assigned(tobjectdef(hdef).childof)) then 954 begin 955 tobjectdef(hdef).finish_objc_data; 956 tobjectdef(hdef).symtable.DefList.ForEachCall(@pd_set_objc_related_result,nil); 957 end; 958 959 if is_cppclass(hdef) then 960 tobjectdef(hdef).finish_cpp_data; 961 end; 962 recorddef : 963 begin 964 try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg); 965 consume(_SEMICOLON); 966 end; 967 else 968 begin 969 try_consume_hintdirective(newtype.symoptions,newtype.deprecatedmsg); 970 consume(_SEMICOLON); 971 end; 972 end; 973 end; 974 975 if isgeneric and (not(hdef.typ in [objectdef,recorddef,arraydef,procvardef]) 976 or is_objectpascal_helper(hdef)) then 977 message(parser_e_cant_create_generics_of_this_type); 978 979 { Stop recording a generic template } 980 if assigned(generictypelist) then 981 begin 982 current_scanner.stoprecordtokens; 983 tstoreddef(hdef).generictokenbuf:=localgenerictokenbuf; 984 { Generic is never a type renaming } 985 hdef.typesym:=newtype; 986 generictypelist.free; 987 end; 988 989 if not (m_delphi in current_settings.modeswitches) and 990 (token=_ID) and (idtoken=_GENERIC) then 991 begin 992 had_generic:=true; 993 consume(_ID); 994 if token in [_PROCEDURE,_FUNCTION,_CLASS] then 995 break; 996 end 997 else 998 had_generic:=false; 999 first:=false; 1000 until (token<>_ID) or 1001 (in_structure and 1002 ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or 1003 ((m_final_fields in current_settings.modeswitches) and 1004 (idtoken=_FINAL)))); 1005 { resolve type block forward declarations and restore a unit 1006 container for them } 1007 resolve_forward_types; 1008 current_module.checkforwarddefs.free; 1009 current_module.checkforwarddefs:=old_checkforwarddefs; 1010 block_type:=old_block_type; 1011 end; 1012 1013 1014 { reads a type declaration to the symbol table } 1015 procedure type_dec(out had_generic:boolean); 1016 begin 1017 consume(_TYPE); 1018 types_dec(false,had_generic); 1019 end; 1020 1021 1022 procedure var_dec(out had_generic:boolean); 1023 { parses variable declarations and inserts them in } 1024 { the top symbol table of symtablestack } 1025 begin 1026 consume(_VAR); 1027 read_var_decls([vd_check_generic],had_generic); 1028 end; 1029 1030 1031 procedure property_dec; 1032 { parses a global property (fpc mode feature) } 1033 var 1034 old_block_type: tblock_type; 1035 begin 1036 consume(_PROPERTY); 1037 if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then 1038 message(parser_e_property_only_sgr); 1039 old_block_type:=block_type; 1040 block_type:=bt_const; 1041 repeat 1042 read_property_dec(false, nil); 1043 consume(_SEMICOLON); 1044 until token<>_ID; 1045 block_type:=old_block_type; 1046 end; 1047 1048 1049 procedure threadvar_dec(out had_generic:boolean); 1050 { parses thread variable declarations and inserts them in } 1051 { the top symbol table of symtablestack } 1052 begin 1053 consume(_THREADVAR); 1054 if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then 1055 message(parser_e_threadvars_only_sg); 1056 if f_threading in features then 1057 read_var_decls([vd_threadvar,vd_check_generic],had_generic) 1058 else 1059 begin 1060 Message1(parser_f_unsupported_feature,featurestr[f_threading]); 1061 read_var_decls([vd_check_generic],had_generic); 1062 end; 1063 end; 1064 1065 1066 procedure resourcestring_dec(out had_generic:boolean); 1067 var 1068 orgname : TIDString; 1069 p : tnode; 1070 dummysymoptions : tsymoptions; 1071 deprecatedmsg : pshortstring; 1072 storetokenpos,filepos : tfileposinfo; 1073 old_block_type : tblock_type; 1074 sp : pchar; 1075 sym : tsym; 1076 first, 1077 isgeneric : boolean; 1078 begin 1079 if target_info.system in systems_managed_vm then 1080 message(parser_e_feature_unsupported_for_vm); 1081 consume(_RESOURCESTRING); 1082 if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then 1083 message(parser_e_resourcestring_only_sg); 1084 first:=true; 1085 had_generic:=false; 1086 old_block_type:=block_type; 1087 block_type:=bt_const; 1088 repeat 1089 orgname:=orgpattern; 1090 filepos:=current_tokenpos; 1091 isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC); 1092 consume(_ID); 1093 case token of 1094 _EQ: 1095 begin 1096 consume(_EQ); 1097 p:=comp_expr([ef_accept_equal]); 1098 storetokenpos:=current_tokenpos; 1099 current_tokenpos:=filepos; 1100 sym:=nil; 1101 case p.nodetype of 1102 ordconstn: 1103 begin 1104 if is_constcharnode(p) then 1105 begin 1106 getmem(sp,2); 1107 sp[0]:=chr(tordconstnode(p).value.svalue); 1108 sp[1]:=#0; 1109 sym:=cconstsym.create_string(orgname,constresourcestring,sp,1,nil); 1110 end 1111 else 1112 Message(parser_e_illegal_expression); 1113 end; 1114 stringconstn: 1115 with Tstringconstnode(p) do 1116 begin 1117 { resourcestrings are currently always single byte } 1118 if cst_type in [cst_widestring,cst_unicodestring] then 1119 changestringtype(getansistringdef); 1120 getmem(sp,len+1); 1121 move(value_str^,sp^,len+1); 1122 sym:=cconstsym.create_string(orgname,constresourcestring,sp,len,nil); 1123 end; 1124 else 1125 Message(parser_e_illegal_expression); 1126 end; 1127 current_tokenpos:=storetokenpos; 1128 { Support hint directives } 1129 dummysymoptions:=[]; 1130 deprecatedmsg:=nil; 1131 try_consume_hintdirective(dummysymoptions,deprecatedmsg); 1132 if assigned(sym) then 1133 begin 1134 sym.symoptions:=sym.symoptions+dummysymoptions; 1135 sym.deprecatedmsg:=deprecatedmsg; 1136 symtablestack.top.insert(sym); 1137 end 1138 else 1139 stringdispose(deprecatedmsg); 1140 consume(_SEMICOLON); 1141 p.free; 1142 end; 1143 else 1144 if not first and isgeneric and 1145 (token in [_PROCEDURE, _FUNCTION, _CLASS]) then 1146 begin 1147 had_generic:=true; 1148 break; 1149 end 1150 else 1151 consume(_EQ); 1152 end; 1153 first:=false; 1154 until token<>_ID; 1155 block_type:=old_block_type; 1156 end; 1157 1158 end. 1159