/compiler/ptype.pas
Pascal | 1805 lines | 1466 code | 84 blank | 255 comment | 195 complexity | 8429cbce16bababc1f1d8aceedbfeb21 MD5 | raw file
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0
Large files files are truncated, but you can click here to view the full file
1{ 2 Copyright (c) 1998-2002 by Florian Klaempfl 3 4 Does parsing types 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} 22unit ptype; 23 24{$i fpcdefs.inc} 25 26interface 27 28 uses 29 globtype,cclasses, 30 symtype,symdef,symbase; 31 32 type 33 TSingleTypeOption=( 34 stoIsForwardDef, { foward declaration } 35 stoAllowTypeDef, { allow type definitions } 36 stoAllowSpecialization, { allow type specialization } 37 stoParseClassParent { parse of parent class type } 38 ); 39 TSingleTypeOptions=set of TSingleTypeOption; 40 41 procedure resolve_forward_types; 42 43 { reads a string, file type or a type identifier } 44 procedure single_type(var def:tdef;options:TSingleTypeOptions); 45 46 { reads any type declaration, where the resulting type will get name as type identifier } 47 procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean;hadtypetoken:boolean); 48 49 { reads any type declaration } 50 procedure read_anon_type(var def : tdef;parseprocvardir:boolean); 51 52 { generate persistent type information like VMT, RTTI and inittables } 53 procedure write_persistent_type_info(st:tsymtable;is_global:boolean); 54 55 { add a definition for a method to a record/objectdef that will contain 56 all code for initialising typed constants (only for targets in 57 systems.systems_typed_constants_node_init) } 58 procedure add_typedconst_init_routine(def: tabstractrecorddef); 59 60 { parse hint directives (platform, deprecated, ...) for a procdef } 61 procedure maybe_parse_hint_directives(pd:tprocdef); 62 63implementation 64 65 uses 66 { common } 67 cutils, 68 { global } 69 globals,tokens,verbose,constexp, 70 systems, 71 { target } 72 paramgr,procinfo, 73 { symtable } 74 symconst,symsym,symtable,symcreat, 75 defutil,defcmp, 76{$ifdef jvm} 77 jvmdef, 78{$endif} 79 { modules } 80 fmodule, 81 { pass 1 } 82 node,ncgrtti,nobj, 83 nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw, 84 { parser } 85 scanner, 86 pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil 87{$ifdef jvm} 88 ,pjvm 89{$endif} 90 ; 91 92 93 procedure maybe_parse_hint_directives(pd:tprocdef); 94 var 95 dummysymoptions : tsymoptions; 96 deprecatedmsg : pshortstring; 97 begin 98 dummysymoptions:=[]; 99 deprecatedmsg:=nil; 100 while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do 101 Consume(_SEMICOLON); 102 if assigned(pd) then 103 begin 104 pd.symoptions:=pd.symoptions+dummysymoptions; 105 pd.deprecatedmsg:=deprecatedmsg; 106 end 107 else 108 stringdispose(deprecatedmsg); 109 end; 110 111 112 procedure resolve_forward_types; 113 var 114 i: longint; 115 hpd, 116 def : tdef; 117 srsym : tsym; 118 srsymtable : TSymtable; 119 hs : string; 120 begin 121 for i:=0 to current_module.checkforwarddefs.Count-1 do 122 begin 123 def:=tdef(current_module.checkforwarddefs[i]); 124 case def.typ of 125 pointerdef, 126 classrefdef : 127 begin 128 { classrefdef inherits from pointerdef } 129 hpd:=tabstractpointerdef(def).pointeddef; 130 { still a forward def ? } 131 if hpd.typ=forwarddef then 132 begin 133 { try to resolve the forward } 134 if not assigned(tforwarddef(hpd).tosymname) then 135 internalerror(200211201); 136 hs:=tforwarddef(hpd).tosymname^; 137 searchsym(upper(hs),srsym,srsymtable); 138 { we don't need the forwarddef anymore, dispose it } 139 hpd.free; 140 tabstractpointerdef(def).pointeddef:=nil; { if error occurs } 141 { was a type sym found ? } 142 if assigned(srsym) and 143 (srsym.typ=typesym) then 144 begin 145 tabstractpointerdef(def).pointeddef:=ttypesym(srsym).typedef; 146 { avoid wrong unused warnings web bug 801 PM } 147 inc(ttypesym(srsym).refs); 148 { we need a class type for classrefdef } 149 if (def.typ=classrefdef) and 150 not(is_class(ttypesym(srsym).typedef)) and 151 not(is_objcclass(ttypesym(srsym).typedef)) and 152 not(is_javaclass(ttypesym(srsym).typedef)) then 153 MessagePos1(def.typesym.fileinfo,type_e_class_type_expected,ttypesym(srsym).typedef.typename); 154 { this could also be a generic dummy that was not 155 overridden with a specific type } 156 if (sp_generic_dummy in srsym.symoptions) and 157 ( 158 (ttypesym(srsym).typedef.typ=undefineddef) or 159 ( 160 { or an unspecialized generic symbol, which is 161 the case for generics defined in non-Delphi 162 modes } 163 (df_generic in ttypesym(srsym).typedef.defoptions) and 164 not parse_generic 165 ) 166 ) then 167 MessagePos(def.typesym.fileinfo,parser_e_no_generics_as_types); 168 end 169 else 170 begin 171 Message1(sym_e_forward_type_not_resolved,hs); 172 { try to recover } 173 tabstractpointerdef(def).pointeddef:=generrordef; 174 end; 175 end; 176 end; 177 objectdef : 178 begin 179 { give an error as the implementation may follow in an 180 other type block which is allowed by FPC modes } 181 if not(m_fpc in current_settings.modeswitches) and 182 (oo_is_forward in tobjectdef(def).objectoptions) then 183 MessagePos1(def.typesym.fileinfo,type_e_type_is_not_completly_defined,def.typename); 184 end; 185 else 186 internalerror(200811071); 187 end; 188 end; 189 current_module.checkforwarddefs.clear; 190 end; 191 192 193 procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean;out srsym:tsym;out srsymtable:tsymtable); forward; 194 195 196 { def is the outermost type in which other types have to be searched 197 198 isforward indicates whether the current definition can be a forward definition 199 200 if assigned, currentstructstack is a list of tabstractrecorddefs that, from 201 last to first, are child types of def that are not yet visible via the 202 normal symtable searching routines because they are types that are currently 203 being parsed (so using id_type on them after pushing def on the 204 symtablestack would result in errors because they'd come back as errordef) 205 } 206 procedure parse_nested_types(var def: tdef; isforwarddef: boolean; currentstructstack: tfpobjectlist); 207 var 208 t2: tdef; 209 structstackindex: longint; 210 srsym: tsym; 211 srsymtable: tsymtable; 212 oldsymtablestack: TSymtablestack; 213 begin 214 if assigned(currentstructstack) then 215 structstackindex:=currentstructstack.count-1 216 else 217 structstackindex:=-1; 218 { handle types inside classes, e.g. TNode.TLongint } 219 while (token=_POINT) do 220 begin 221 if is_class_or_object(def) or is_record(def) or is_java_class_or_interface(def) then 222 begin 223 if (def.typ=objectdef) then 224 def:=find_real_class_definition(tobjectdef(def),false); 225 consume(_POINT); 226 if (structstackindex>=0) and 227 (tabstractrecorddef(currentstructstack[structstackindex]).objname^=pattern) then 228 begin 229 def:=tdef(currentstructstack[structstackindex]); 230 dec(structstackindex); 231 consume(_ID); 232 end 233 else 234 begin 235 structstackindex:=-1; 236 oldsymtablestack:=symtablestack; 237 symtablestack:=TSymtablestack.create; 238 symtablestack.push(tabstractrecorddef(def).symtable); 239 t2:=generrordef; 240 id_type(t2,isforwarddef,false,false,srsym,srsymtable); 241 symtablestack.pop(tabstractrecorddef(def).symtable); 242 symtablestack.free; 243 symtablestack:=oldsymtablestack; 244 def:=t2; 245 end; 246 end 247 else 248 break; 249 end; 250 end; 251 252 253 function try_parse_structdef_nested_type(out def: tdef; basedef: tabstractrecorddef; isfowarddef: boolean): boolean; 254 var 255 structdef : tdef; 256 structdefstack : tfpobjectlist; 257 begin 258 def:=nil; 259 { use of current parsed object: 260 classes, objects, records can be used also in themself } 261 structdef:=basedef; 262 structdefstack:=nil; 263 while assigned(structdef) and (structdef.typ in [objectdef,recorddef]) do 264 begin 265 if (tabstractrecorddef(structdef).objname^=pattern) then 266 begin 267 consume(_ID); 268 def:=structdef; 269 { we found the top-most match, now check how far down we can 270 follow } 271 structdefstack:=tfpobjectlist.create(false); 272 structdef:=basedef; 273 while (structdef<>def) do 274 begin 275 structdefstack.add(structdef); 276 structdef:=tabstractrecorddef(structdef.owner.defowner); 277 end; 278 parse_nested_types(def,isfowarddef,structdefstack); 279 structdefstack.free; 280 result:=true; 281 exit; 282 end; 283 structdef:=tdef(tabstractrecorddef(structdef).owner.defowner); 284 end; 285 result:=false; 286 end; 287 288 procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean;out srsym:tsym;out srsymtable:tsymtable); 289 { reads a type definition } 290 { to a appropriating tdef, s gets the name of } 291 { the type to allow name mangling } 292 var 293 is_unit_specific : boolean; 294 pos : tfileposinfo; 295 s,sorg : TIDString; 296 t : ttoken; 297 begin 298 srsym:=nil; 299 srsymtable:=nil; 300 s:=pattern; 301 sorg:=orgpattern; 302 pos:=current_tokenpos; 303 { use of current parsed object: 304 classes, objects, records can be used also in themself } 305 if checkcurrentrecdef and 306 try_parse_structdef_nested_type(def,current_structdef,isforwarddef) then 307 exit; 308 { Use the special searchsym_type that search only types } 309 searchsym_type(s,srsym,srsymtable); 310 { handle unit specification like System.Writeln } 311 is_unit_specific:=try_consume_unitsym(srsym,srsymtable,t,true); 312 consume(t); 313 { Types are first defined with an error def before assigning 314 the real type so check if it's an errordef. if so then 315 give an error. Only check for typesyms in the current symbol 316 table as forwarddef are not resolved directly } 317 if assigned(srsym) and 318 (srsym.typ=typesym) and 319 ((ttypesym(srsym).typedef.typ=errordef) or 320 (not allowgenericsyms and 321 (ttypesym(srsym).typedef.typ=undefineddef) and 322 not (sp_generic_para in srsym.symoptions))) then 323 begin 324 Message1(type_e_type_is_not_completly_defined,ttypesym(srsym).realname); 325 def:=generrordef; 326 exit; 327 end; 328 { are we parsing a possible forward def ? } 329 if isforwarddef and 330 not(is_unit_specific) then 331 begin 332 def:=tforwarddef.create(sorg,pos); 333 exit; 334 end; 335 { unknown sym ? } 336 if not assigned(srsym) then 337 begin 338 Message1(sym_e_id_not_found,sorg); 339 def:=generrordef; 340 exit; 341 end; 342 { type sym ? } 343 if (srsym.typ<>typesym) then 344 begin 345 Message(type_e_type_id_expected); 346 def:=generrordef; 347 exit; 348 end; 349 { Give an error when referring to an errordef } 350 if (ttypesym(srsym).typedef.typ=errordef) then 351 begin 352 Message(sym_e_error_in_type_def); 353 def:=generrordef; 354 exit; 355 end; 356 { In non-Delphi modes the class/record name of a generic might be used 357 in the declaration of sub types without type parameters; in that case 358 we need to check by name as the link from the dummy symbol to the 359 current type is not yet established } 360 if (sp_generic_dummy in srsym.symoptions) and 361 assigned(current_structdef) and 362 (df_generic in current_structdef.defoptions) and 363 (ttypesym(srsym).typedef.typ=undefineddef) and 364 not (m_delphi in current_settings.modeswitches) then 365 begin 366 def:=get_generic_in_hierarchy_by_name(srsym,current_structdef); 367 if assigned(def) then 368 exit; 369 end; 370 def:=ttypesym(srsym).typedef; 371 end; 372 373 374 procedure single_type(var def:tdef;options:TSingleTypeOptions); 375 var 376 t2 : tdef; 377 dospecialize, 378 again : boolean; 379 srsym : tsym; 380 srsymtable : tsymtable; 381 begin 382 dospecialize:=false; 383 repeat 384 again:=false; 385 case token of 386 _STRING: 387 string_dec(def,stoAllowTypeDef in options); 388 389 _FILE: 390 begin 391 consume(_FILE); 392 if (token=_OF) then 393 begin 394 if not(stoAllowTypeDef in options) then 395 Message(parser_e_no_local_para_def); 396 consume(_OF); 397 single_type(t2,[stoAllowTypeDef]); 398 if is_managed_type(t2) then 399 Message(parser_e_no_refcounted_typed_file); 400 def:=tfiledef.createtyped(t2); 401 end 402 else 403 def:=cfiletype; 404 end; 405 406 _ID: 407 begin 408 if try_to_consume(_SPECIALIZE) then 409 begin 410 if ([stoAllowSpecialization,stoAllowTypeDef] * options = []) then 411 begin 412 Message(parser_e_no_local_para_def); 413 414 { try to recover } 415 while token<>_SEMICOLON do 416 consume(token); 417 def:=generrordef; 418 end 419 else 420 begin 421 dospecialize:=true; 422 again:=true; 423 end; 424 end 425 else 426 begin 427 id_type(def,stoIsForwardDef in options,true,true,srsym,srsymtable); 428 parse_nested_types(def,stoIsForwardDef in options,nil); 429 end; 430 end; 431 432 else 433 begin 434 message(type_e_type_id_expected); 435 def:=generrordef; 436 end; 437 end; 438 until not again; 439 if ([stoAllowSpecialization,stoAllowTypeDef] * options <> []) and 440 (m_delphi in current_settings.modeswitches) then 441 dospecialize:=token in [_LSHARPBRACKET,_LT]; 442 if dospecialize and 443 (def.typ=forwarddef) then 444 begin 445 if not assigned(srsym) or not (srsym.typ=typesym) then 446 begin 447 Message1(type_e_type_is_not_completly_defined,def.typename); 448 def:=generrordef; 449 dospecialize:=false; 450 end; 451 end; 452 if dospecialize then 453 begin 454 if def.typ=forwarddef then 455 def:=ttypesym(srsym).typedef; 456 generate_specialization(def,stoParseClassParent in options,''); 457 end 458 else 459 begin 460 if assigned(current_specializedef) and (def=current_specializedef.genericdef) then 461 begin 462 def:=current_specializedef 463 end 464 else if (def=current_genericdef) then 465 begin 466 def:=current_genericdef 467 end 468 { when parsing a nested specialization in non-Delphi mode it might 469 use the name of the topmost generic without type paramaters, thus 470 def will contain the generic definition, but we need a reference 471 to the specialization of that generic } 472 { TODO : only in non-Delphi modes? } 473 else if assigned(current_structdef) and 474 (df_specialization in current_structdef.defoptions) and 475 return_specialization_of_generic(current_structdef,def,t2) then 476 begin 477 def:=t2 478 end 479 else if (df_generic in def.defoptions) and 480 not 481 ( 482 parse_generic and 483 (current_genericdef.typ in [recorddef,objectdef]) and 484 ( 485 { if both defs belong to the same generic (e.g. both are 486 subtypes) then we must allow the usage } 487 defs_belong_to_same_generic(def,current_genericdef) or 488 { this is needed to correctly resolve "type Foo=SomeGeneric<T>" 489 declarations inside a generic } 490 sym_is_owned_by(srsym,tabstractrecorddef(current_genericdef).symtable) 491 ) 492 ) 493 then 494 begin 495 Message(parser_e_no_generics_as_types); 496 def:=generrordef; 497 end 498 else if (def.typ=undefineddef) and 499 (sp_generic_dummy in srsym.symoptions) and 500 parse_generic and 501 (current_genericdef.typ in [recorddef,objectdef]) and 502 (Pos(upper(srsym.realname),tabstractrecorddef(current_genericdef).objname^)=1) then 503 begin 504 if m_delphi in current_settings.modeswitches then 505 begin 506 Message(parser_e_no_generics_as_types); 507 def:=generrordef; 508 end 509 else 510 def:=current_genericdef; 511 end 512 else if is_classhelper(def) and 513 not (stoParseClassParent in options) then 514 begin 515 Message(parser_e_no_category_as_types); 516 def:=generrordef 517 end 518 end; 519 end; 520 521 522 procedure parse_record_members; 523 524 function IsAnonOrLocal: Boolean; 525 begin 526 result:=(current_structdef.objname^='') or 527 not(symtablestack.stack^.next^.symtable.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]); 528 end; 529 530 var 531 pd : tprocdef; 532 oldparse_only: boolean; 533 member_blocktype : tblock_type; 534 fields_allowed, is_classdef, classfields: boolean; 535 vdoptions: tvar_dec_options; 536 begin 537 { empty record declaration ? } 538 if (token=_SEMICOLON) then 539 Exit; 540 541 current_structdef.symtable.currentvisibility:=vis_public; 542 fields_allowed:=true; 543 is_classdef:=false; 544 classfields:=false; 545 member_blocktype:=bt_general; 546 repeat 547 case token of 548 _TYPE : 549 begin 550 consume(_TYPE); 551 member_blocktype:=bt_type; 552 553 { local and anonymous records can not have inner types. skip top record symtable } 554 if IsAnonOrLocal then 555 Message(parser_e_no_types_in_local_anonymous_records); 556 end; 557 _VAR : 558 begin 559 consume(_VAR); 560 fields_allowed:=true; 561 member_blocktype:=bt_general; 562 classfields:=is_classdef; 563 is_classdef:=false; 564 end; 565 _CONST: 566 begin 567 consume(_CONST); 568 member_blocktype:=bt_const; 569 570 { local and anonymous records can not have constants. skip top record symtable } 571 if IsAnonOrLocal then 572 Message(parser_e_no_consts_in_local_anonymous_records); 573 end; 574 _ID, _CASE, _OPERATOR : 575 begin 576 case idtoken of 577 _PRIVATE : 578 begin 579 consume(_PRIVATE); 580 current_structdef.symtable.currentvisibility:=vis_private; 581 include(current_structdef.objectoptions,oo_has_private); 582 fields_allowed:=true; 583 is_classdef:=false; 584 classfields:=false; 585 member_blocktype:=bt_general; 586 end; 587 _PROTECTED : 588 begin 589 consume(_PROTECTED); 590 current_structdef.symtable.currentvisibility:=vis_protected; 591 include(current_structdef.objectoptions,oo_has_protected); 592 fields_allowed:=true; 593 is_classdef:=false; 594 classfields:=false; 595 member_blocktype:=bt_general; 596 end; 597 _PUBLIC : 598 begin 599 consume(_PUBLIC); 600 current_structdef.symtable.currentvisibility:=vis_public; 601 fields_allowed:=true; 602 is_classdef:=false; 603 classfields:=false; 604 member_blocktype:=bt_general; 605 end; 606 _PUBLISHED : 607 begin 608 Message(parser_e_no_record_published); 609 consume(_PUBLISHED); 610 current_structdef.symtable.currentvisibility:=vis_published; 611 fields_allowed:=true; 612 is_classdef:=false; 613 classfields:=false; 614 member_blocktype:=bt_general; 615 end; 616 _STRICT : 617 begin 618 consume(_STRICT); 619 if token=_ID then 620 begin 621 case idtoken of 622 _PRIVATE: 623 begin 624 consume(_PRIVATE); 625 current_structdef.symtable.currentvisibility:=vis_strictprivate; 626 include(current_structdef.objectoptions,oo_has_strictprivate); 627 end; 628 _PROTECTED: 629 begin 630 consume(_PROTECTED); 631 current_structdef.symtable.currentvisibility:=vis_strictprotected; 632 include(current_structdef.objectoptions,oo_has_strictprotected); 633 end; 634 else 635 message(parser_e_protected_or_private_expected); 636 end; 637 end 638 else 639 message(parser_e_protected_or_private_expected); 640 fields_allowed:=true; 641 is_classdef:=false; 642 classfields:=false; 643 member_blocktype:=bt_general; 644 end 645 else 646 if is_classdef and (idtoken=_OPERATOR) then 647 begin 648 pd:=parse_record_method_dec(current_structdef,is_classdef); 649 fields_allowed:=false; 650 is_classdef:=false; 651 end 652 else 653 begin 654 if member_blocktype=bt_general then 655 begin 656 if (not fields_allowed)and(idtoken<>_CASE) then 657 Message(parser_e_field_not_allowed_here); 658 vdoptions:=[vd_record]; 659 if classfields then 660 include(vdoptions,vd_class); 661 read_record_fields(vdoptions,nil); 662 end 663 else if member_blocktype=bt_type then 664 types_dec(true) 665 else if member_blocktype=bt_const then 666 consts_dec(true,true) 667 else 668 internalerror(201001110); 669 end; 670 end; 671 end; 672 _PROPERTY : 673 begin 674 if IsAnonOrLocal then 675 Message(parser_e_no_properties_in_local_anonymous_records); 676 struct_property_dec(is_classdef); 677 fields_allowed:=false; 678 is_classdef:=false; 679 end; 680 _CLASS: 681 begin 682 is_classdef:=false; 683 { read class method/field/property } 684 consume(_CLASS); 685 { class modifier is only allowed for procedures, functions, } 686 { constructors, destructors, fields and properties } 687 if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and 688 not((token=_ID) and (idtoken=_OPERATOR)) then 689 Message(parser_e_procedure_or_function_expected); 690 691 if IsAnonOrLocal then 692 Message(parser_e_no_class_in_local_anonymous_records); 693 694 is_classdef:=true; 695 end; 696 _PROCEDURE, 697 _FUNCTION: 698 begin 699 if IsAnonOrLocal then 700 Message(parser_e_no_methods_in_local_anonymous_records); 701 pd:=parse_record_method_dec(current_structdef,is_classdef); 702 fields_allowed:=false; 703 is_classdef:=false; 704 end; 705 _CONSTRUCTOR : 706 begin 707 if IsAnonOrLocal then 708 Message(parser_e_no_methods_in_local_anonymous_records); 709 if not is_classdef and (current_structdef.symtable.currentvisibility <> vis_public) then 710 Message(parser_w_constructor_should_be_public); 711 712 { only 1 class constructor is allowed } 713 if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then 714 Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^); 715 716 oldparse_only:=parse_only; 717 parse_only:=true; 718 if is_classdef then 719 pd:=class_constructor_head(current_structdef) 720 else 721 begin 722 pd:=constructor_head; 723 if pd.minparacount = 0 then 724 MessagePos(pd.procsym.fileinfo,parser_e_no_parameterless_constructor_in_records); 725 end; 726 727 parse_only:=oldparse_only; 728 fields_allowed:=false; 729 is_classdef:=false; 730 end; 731 _DESTRUCTOR : 732 begin 733 if IsAnonOrLocal then 734 Message(parser_e_no_methods_in_local_anonymous_records); 735 if not is_classdef then 736 Message(parser_e_no_destructor_in_records); 737 738 { only 1 class destructor is allowed } 739 if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then 740 Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^); 741 742 oldparse_only:=parse_only; 743 parse_only:=true; 744 if is_classdef then 745 pd:=class_destructor_head(current_structdef) 746 else 747 pd:=destructor_head; 748 749 parse_only:=oldparse_only; 750 fields_allowed:=false; 751 is_classdef:=false; 752 end; 753 _END : 754 begin 755{$ifdef jvm} 756 add_java_default_record_methods_intf(trecorddef(current_structdef)); 757{$endif} 758 if target_info.system in systems_typed_constants_node_init then 759 add_typedconst_init_routine(current_structdef); 760 consume(_END); 761 break; 762 end; 763 else 764 consume(_ID); { Give a ident expected message, like tp7 } 765 end; 766 until false; 767 end; 768 769 { reads a record declaration } 770 function record_dec(const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList):tdef; 771 var 772 old_current_structdef: tabstractrecorddef; 773 old_current_genericdef, 774 old_current_specializedef: tstoreddef; 775 old_parse_generic: boolean; 776 recst: trecordsymtable; 777 begin 778 old_current_structdef:=current_structdef; 779 old_current_genericdef:=current_genericdef; 780 old_current_specializedef:=current_specializedef; 781 old_parse_generic:=parse_generic; 782 783 current_genericdef:=nil; 784 current_specializedef:=nil; 785 { create recdef } 786 if (n<>'') or 787 not(target_info.system in systems_jvm) then 788 begin 789 recst:=trecordsymtable.create(n,current_settings.packrecords); 790 { can't use recst.realname^ instead of n, because recst.realname is 791 nil in case of an empty name } 792 current_structdef:=trecorddef.create(n,recst); 793 end 794 else 795 begin 796 { for the JVM target records always need a name, because they are 797 represented by a class } 798 recst:=trecordsymtable.create(current_module.realmodulename^+'__fpc_intern_recname_'+tostr(current_module.deflist.count),current_settings.packrecords); 799 current_structdef:=trecorddef.create(recst.name^,recst); 800 end; 801 result:=current_structdef; 802 { insert in symtablestack } 803 symtablestack.push(recst); 804 805 { usage of specialized type inside its generic template } 806 if assigned(genericdef) then 807 current_specializedef:=current_structdef 808 { reject declaration of generic class inside generic class } 809 else if assigned(genericlist) then 810 current_genericdef:=current_structdef; 811 812 { nested types of specializations are specializations as well } 813 if assigned(old_current_structdef) and 814 (df_specialization in old_current_structdef.defoptions) then 815 include(current_structdef.defoptions,df_specialization); 816 if assigned(old_current_structdef) and 817 (df_generic in old_current_structdef.defoptions) then 818 begin 819 include(current_structdef.defoptions,df_generic); 820 current_genericdef:=current_structdef; 821 end; 822 823 insert_generic_parameter_types(current_structdef,genericdef,genericlist); 824 { when we are parsing a generic already then this is a generic as 825 well } 826 if old_parse_generic then 827 include(current_structdef.defoptions, df_generic); 828 parse_generic:=(df_generic in current_structdef.defoptions); 829 { in non-Delphi modes we need a strict private symbol without type 830 count and type parameters in the name to simply resolving } 831 maybe_insert_generic_rename_symbol(n,genericlist); 832 833 if m_advanced_records in current_settings.modeswitches then 834 begin 835 parse_record_members; 836 end 837 else 838 begin 839 read_record_fields([vd_record],nil); 840{$ifdef jvm} 841 { we need a constructor to create temps, a deep copy helper, ... } 842 add_java_default_record_methods_intf(trecorddef(current_structdef)); 843{$endif} 844 if target_info.system in systems_typed_constants_node_init then 845 add_typedconst_init_routine(current_structdef); 846 consume(_END); 847 end; 848 { make the record size aligned (has to be done before inserting the 849 parameters, because that may depend on the record's size) } 850 recst.addalignmentpadding; 851 { don't keep track of procdefs in a separate list, because the 852 compiler may add additional procdefs (e.g. property wrappers for 853 the jvm backend) } 854 insert_record_hidden_paras(trecorddef(current_structdef)); 855 { restore symtable stack } 856 symtablestack.pop(recst); 857 if trecorddef(current_structdef).is_packed and is_managed_type(current_structdef) then 858 Message(type_e_no_packed_inittable); 859 { restore old state } 860 parse_generic:=old_parse_generic; 861 current_structdef:=old_current_structdef; 862 current_genericdef:=old_current_genericdef; 863 current_specializedef:=old_current_specializedef; 864 end; 865 866 867 { reads a type definition and returns a pointer to it } 868 procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean;hadtypetoken:boolean); 869 var 870 pt : tnode; 871 tt2 : tdef; 872 aktenumdef : tenumdef; 873 s : TIDString; 874 l,v : TConstExprInt; 875 oldpackrecords : longint; 876 defpos,storepos : tfileposinfo; 877 name: TIDString; 878 879 procedure expr_type; 880 var 881 pt1,pt2 : tnode; 882 lv,hv : TConstExprInt; 883 old_block_type : tblock_type; 884 dospecialize : boolean; 885 newdef : tdef; 886 begin 887 old_block_type:=block_type; 888 dospecialize:=false; 889 { use of current parsed object: 890 classes, objects, records can be used also in themself } 891 if (token=_ID) then 892 if try_parse_structdef_nested_type(def,current_structdef,false) then 893 exit; 894 { Generate a specialization in FPC mode? } 895 dospecialize:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_SPECIALIZE); 896 { we can't accept a equal in type } 897 pt1:=comp_expr(false,true); 898 if not dospecialize and 899 try_to_consume(_POINTPOINT) then 900 begin 901 { get high value of range } 902 pt2:=comp_expr(false,false); 903 { make both the same type or give an error. This is not 904 done when both are integer values, because typecasting 905 between -3200..3200 will result in a signed-unsigned 906 conflict and give a range check error (PFV) } 907 if not(is_integer(pt1.resultdef) and is_integer(pt2.resultdef)) then 908 inserttypeconv(pt1,pt2.resultdef); 909 { both must be evaluated to constants now } 910 if (pt1.nodetype=ordconstn) and 911 (pt2.nodetype=ordconstn) then 912 begin 913 lv:=tordconstnode(pt1).value; 914 hv:=tordconstnode(pt2).value; 915 { Check bounds } 916 if hv<lv then 917 message(parser_e_upper_lower_than_lower) 918 else if (lv.signed and (lv.svalue<0)) and (not hv.signed and (hv.uvalue>qword(high(int64)))) then 919 message(type_e_cant_eval_constant_expr) 920 else 921 begin 922 { All checks passed, create the new def } 923 case pt1.resultdef.typ of 924 enumdef : 925 def:=tenumdef.create_subrange(tenumdef(pt1.resultdef),lv.svalue,hv.svalue); 926 orddef : 927 begin 928 if is_char(pt1.resultdef) then 929 def:=torddef.create(uchar,lv,hv) 930 else 931 if is_boolean(pt1.resultdef) then 932 def:=torddef.create(pasbool8,lv,hv) 933 else if is_signed(pt1.resultdef) then 934 def:=torddef.create(range_to_basetype(lv,hv),lv,hv) 935 else 936 def:=torddef.create(range_to_basetype(lv,hv),lv,hv); 937 end; 938 end; 939 end; 940 end 941 else 942 Message(sym_e_error_in_type_def); 943 pt2.free; 944 end 945 else 946 begin 947 { a simple type renaming or generic specialization } 948 if (pt1.nodetype=typen) then 949 begin 950 def:=ttypenode(pt1).resultdef; 951 { Delphi mode specialization? } 952 if (m_delphi in current_settings.modeswitches) then 953 dospecialize:=token=_LSHARPBRACKET 954 else 955 { in non-Delphi modes we might get a inline specialization 956 without "specialize" or "<T>" of the same type we're 957 currently parsing, so we need to handle that special } 958 newdef:=nil; 959 if not dospecialize and 960 assigned(ttypenode(pt1).typesym) and 961 (ttypenode(pt1).typesym.typ=typesym) and 962 (sp_generic_dummy in ttypenode(pt1).typesym.symoptions) and 963 assigned(current_structdef) and 964 ( 965 ( 966 not (m_delphi in current_settings.modeswitches) and 967 (ttypesym(ttypenode(pt1).typesym).typedef.typ=undefineddef) and 968 (df_generic in current_structdef.defoptions) and 969 (ttypesym(ttypenode(pt1).typesym).typedef.owner=current_structdef.owner) and 970 (upper(ttypenode(pt1).typesym.realname)=copy(current_structdef.objname^,1,pos('$',current_structdef.objname^)-1)) 971 ) or ( 972 { this could be a nested specialization which uses 973 the type name of a surrounding generic to 974 reference the specialization of said surrounding 975 class } 976 (df_specialization in current_structdef.defoptions) and 977 return_specialization_of_generic(current_structdef,ttypesym(ttypenode(pt1).typesym).typedef,newdef) 978 ) 979 ) 980 then 981 begin 982 if assigned(newdef) then 983 def:=newdef 984 else 985 def:=current_structdef; 986 if assigned(def) then 987 { handle nested types } 988 post_comp_expr_gendef(def) 989 else 990 def:=generrordef; 991 end; 992 if dospecialize then 993 begin 994 generate_specialization(def,false,name); 995 { handle nested types } 996 if assigned(def) then 997 post_comp_expr_gendef(def); 998 end 999 else 1000 begin 1001 if assigned(current_specializedef) and (def=current_specializedef.genericdef) then 1002 begin 1003 def:=current_specializedef 1004 end 1005 else if (def=current_genericdef) then 1006 begin 1007 def:=current_genericdef 1008 end 1009 else if (df_generic in def.defoptions) and 1010 { TODO : check once nested generics are allowed } 1011 not 1012 ( 1013 parse_generic and 1014 (current_genericdef.typ in [recorddef,objectdef]) and 1015 (def.typ in [recorddef,objectdef]) and 1016 ( 1017 { if both defs belong to the same generic (e.g. both are 1018 subtypes) then we must allow the usage } 1019 defs_belong_to_same_generic(def,current_genericdef) or 1020 { this is needed to correctly resolve "type Foo=SomeGeneric<T>" 1021 declarations inside a generic } 1022 ( 1023 (ttypenode(pt1).typesym<>nil) and 1024 sym_is_owned_by(ttypenode(pt1).typesym,tabstractrecorddef(current_genericdef).symtable) 1025 ) 1026 ) 1027 ) 1028 then 1029 begin 1030 Message(parser_e_no_generics_as_types); 1031 def:=generrordef; 1032 end 1033 else if is_classhelper(def) then 1034 begin 1035 Message(parser_e_no_category_as_types); 1036 def:=generrordef 1037 end 1038 end; 1039 end 1040 else 1041 Message(sym_e_error_in_type_def); 1042 end; 1043 pt1.free; 1044 block_type:=old_block_type; 1045 end; 1046 1047 1048 procedure set_dec; 1049 begin 1050 consume(_SET); 1051 consume(_OF); 1052 read_anon_type(tt2,true); 1053 if assigned(tt2) then 1054 begin 1055 case tt2.typ of 1056 { don't forget that min can be negativ PM } 1057 enumdef : 1058 if (tenumdef(tt2).min>=0) and 1059 (tenumdef(tt2).max<=255) then 1060 // !! def:=tsetdef.create(tt2,tenumdef(tt2.def).min,tenumdef(tt2.def).max)) 1061 def:=tsetdef.create(tt2,tenumdef(tt2).min,tenumdef(tt2).max) 1062 else 1063 Message(sym_e_ill_type_decl_set); 1064 orddef : 1065 begin 1066 if (torddef(tt2).ordtype<>uvoid) and 1067 (torddef(tt2).ordtype<>uwidechar) and 1068 (torddef(tt2).low>=0) then 1069 // !! def:=tsetdef.create(tt2,torddef(tt2.def).low,torddef(tt2.def).high)) 1070 if Torddef(tt2).high>int64(high(byte)) then 1071 message(sym_e_ill_type_decl_set) 1072 else 1073 def:=tsetdef.create(tt2,torddef(tt2).low.svalue,torddef(tt2).high.svalue) 1074 else 1075 Message(sym_e_ill_type_decl_set); 1076 end; 1077 else 1078 Message(sym_e_ill_type_decl_set); 1079 end; 1080 end 1081 else 1082 def:=generrordef; 1083 end; 1084 1085 1086 procedure array_dec(is_packed:boolean;genericdef:tstoreddef;genericlist:TFPObjectList); 1087 var 1088 lowval, 1089 highval : TConstExprInt; 1090 indexdef : tdef; 1091 hdef : tdef; 1092 arrdef : tarraydef; 1093 1094 procedure setdefdecl(def:tdef); 1095 begin 1096 case def.typ of 1097 enumdef : 1098 begin 1099 lowval:=tenumdef(def).min; 1100 highval:=tenumdef(def).max; 1101 if (m_fpc in current_settings.modeswitches) and 1102 (tenumdef(def).has_jumps) then 1103 Message(type_e_array_index_enums_with_assign_not_possible); 1104 indexdef:=def; 1105 end; 1106 orddef : 1107 begin 1108 if torddef(def).ordtype in [uchar, 1109 u8bit,u16bit, 1110 s8bit,s16bit,s32bit, 1111{$ifdef cpu64bitaddr} 1112 u32bit,s64bit, 1113{$endif cpu64bitaddr} 1114 pasbool8,pasbool16,pasbool32,pasbool64, 1115 bool8bit,bool16bit,bool32bit,bool64bit, 1116 uwidechar] then 1117 begin 1118 lowval:=torddef(def).low; 1119 highval:=torddef(def).high; 1120 indexdef:=def; 1121 end 1122 else 1123 Message1(parser_e_type_cant_be_used_in_array_index,def.typename); 1124 end; 1125 else 1126 Message(sym_e_error_in_type_def); 1127 end; 1128 end; 1129 1130 var 1131 old_current_genericdef, 1132 old_current_specializedef: tstoreddef; 1133 first, 1134 old_parse_generic: boolean; 1135 begin 1136 old_current_genericdef:=current_genericdef; 1137 old_current_specializedef:=current_specializedef; 1138 old_parse_generic:=parse_generic; 1139 1140 current_genericdef:=nil; 1141 current_specializedef:=nil; 1142 first:=true; 1143 arrdef:=tarraydef.create(0,0,s32inttype); 1144 consume(_ARRAY); 1145 1146 { usage of specialized type inside its generic template } 1147 if assigned(genericdef) then 1148 current_specializedef:=arrdef 1149 { reject declaration of generic class inside generic class } 1150 else if assigned(genericlist) then 1151 current_genericdef:=arrdef; 1152 symtablestack.push(arrdef.symtable); 1153 insert_generic_parameter_types(arrdef,genericdef,genericlist); 1154 { there are two possibilties for the following to be true: 1155 * the array declaration itself is generic 1156 * the array is declared inside a generic 1157 in both cases we need "parse_generic" and "current_genericdef" 1158 so that e.g. specializations of another generic inside the 1159 current generic can be used (either inline ones or "type" ones) } 1160 parse_generic:=(df_generic in arrdef.defoptions) or old_parse_generic; 1161 if parse_generic and not assigned(current_genericdef) then 1162 current_genericdef:=old_current_genericdef; 1163 1164 { open array? } 1165 if try_to_consume(_LECKKLAMMER) then 1166 begin 1167 { defaults } 1168 indexdef:=generrordef; 1169 { use defaults which don't overflow the compiler } 1170 lowval:=0; 1171 highval:=0; 1172 repeat 1173 { read the expression and check it, check apart if the 1174 declaration is an enum declaration because that needs to 1175 be parsed by readtype (PFV) } 1176 if token=_LKLAMMER then 1177 begin 1178 read_anon_type(hdef,true); 1179 setdefdecl(hdef); 1180 end 1181 else 1182 begin 1183 pt:=expr(true); 1184 if pt.nodetype=typen then 1185 setdefdecl(pt.resultdef) 1186 else 1187 begin 1188 if pt.nodetype=rangen then 1189 begin 1190 { pure ordconstn expressions can be checked for 1191 generics as well, but don't give an error in case 1192 of parsing a generic if that isn't yet the case } 1193 if (trangenode(pt).left.nodetype=ordconstn) and 1194 (trangenode(pt).right.nodetype=ordconstn) then 1195 begin 1196 { make both the same type or give an error. This is not 1197 done when both are integer values, because typecasting 1198 …
Large files files are truncated, but you can click here to view the full file