1 { 2 Copyright (c) 1998-2002 by Florian Klaempfl 3 4 Does object 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 } 22 unit pdecobj; 23 24 {$i fpcdefs.inc} 25 26 interface 27 28 uses 29 cclasses, 30 globtype,symconst,symtype,symdef; 31 32 { parses a object declaration } object_decnull33 function object_dec(objecttype:tobjecttyp;const n:tidstring;objsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;fd : tobjectdef;helpertype:thelpertype) : tobjectdef; 34 35 { parses a (class) method declaration } method_decnull36 function method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef; 37 class_constructor_headnull38 function class_constructor_head(astruct: tabstractrecorddef):tprocdef; class_destructor_headnull39 function class_destructor_head(astruct: tabstractrecorddef):tprocdef; constructor_headnull40 function constructor_head:tprocdef; destructor_headnull41 function destructor_head:tprocdef; 42 procedure struct_property_dec(is_classproperty:boolean); 43 44 implementation 45 46 uses 47 sysutils,cutils, 48 globals,verbose,systems,tokens, 49 symbase,symsym,symtable,symcreat,defcmp, 50 node,ncon, 51 fmodule,scanner, 52 pbase,pexpr,pdecsub,pdecvar,ptype,pdecl,pgenutil,pparautl,ppu 53 {$ifdef jvm} 54 ,jvmdef,pjvm; 55 {$else} 56 ; 57 {$endif} 58 59 const 60 { Please leave this here, this module should NOT use 61 these variables. 62 Declaring it as string here results in an error when compiling (PFV) } 63 current_procinfo = 'error'; 64 65 var 66 current_objectdef : tobjectdef absolute current_structdef; 67 68 69 procedure constr_destr_finish_head(pd: tprocdef; const astruct: tabstractrecorddef); 70 begin 71 case astruct.typ of 72 recorddef: 73 begin 74 parse_record_proc_directives(pd); 75 // we can't add hidden params here because record is not yet defined 76 // and therefore record size which has influence on paramter passing rules may change too 77 // look at record_dec to see where calling conventions are applied (issue #0021044) 78 handle_calling_convention(pd,[hcc_declaration,hcc_check]); 79 end; 80 objectdef: 81 begin 82 parse_object_proc_directives(pd); 83 handle_calling_convention(pd,hcc_default_actions_intf); 84 end 85 else 86 internalerror(2011040502); 87 end; 88 89 { add definition to procsym } 90 proc_add_definition(pd); 91 92 { add procdef options to objectdef options } 93 if (po_virtualmethod in pd.procoptions) then 94 include(astruct.objectoptions,oo_has_virtual); 95 96 maybe_parse_hint_directives(pd); 97 end; 98 99 100 function class_constructor_head(astruct: tabstractrecorddef):tprocdef; 101 var 102 pd : tprocdef; 103 begin 104 result:=nil; 105 consume(_CONSTRUCTOR); 106 { must be at same level as in implementation } 107 parse_proc_head(current_structdef,potype_class_constructor,false,nil,nil,pd); 108 if not assigned(pd) then 109 begin 110 consume(_SEMICOLON); 111 exit; 112 end; 113 pd.calcparas; 114 if (pd.maxparacount>0) then 115 Message(parser_e_no_paras_for_class_constructor); 116 consume(_SEMICOLON); 117 include(astruct.objectoptions,oo_has_class_constructor); 118 current_module.flags:=current_module.flags or uf_classinits; 119 { no return value } 120 pd.returndef:=voidtype; 121 constr_destr_finish_head(pd,astruct); 122 result:=pd; 123 end; 124 125 function constructor_head:tprocdef; 126 var 127 pd : tprocdef; 128 begin 129 result:=nil; 130 consume(_CONSTRUCTOR); 131 { must be at same level as in implementation } 132 parse_proc_head(current_structdef,potype_constructor,false,nil,nil,pd); 133 if not assigned(pd) then 134 begin 135 consume(_SEMICOLON); 136 exit; 137 end; 138 if (cs_constructor_name in current_settings.globalswitches) and 139 (pd.procsym.name<>'INIT') then 140 Message(parser_e_constructorname_must_be_init); 141 consume(_SEMICOLON); 142 include(current_structdef.objectoptions,oo_has_constructor); 143 { Set return type, class and record constructors return the 144 created instance, helper types return the extended type, 145 object constructors return boolean } 146 if is_class(pd.struct) or 147 is_record(pd.struct) or 148 is_javaclass(pd.struct) then 149 pd.returndef:=pd.struct 150 else 151 if is_objectpascal_helper(pd.struct) then 152 pd.returndef:=tobjectdef(pd.struct).extendeddef 153 else 154 {$ifdef CPU64bitaddr} 155 pd.returndef:=bool64type; 156 {$else CPU64bitaddr} 157 pd.returndef:=bool32type; 158 {$endif CPU64bitaddr} 159 constr_destr_finish_head(pd,pd.struct); 160 result:=pd; 161 end; 162 163 164 procedure struct_property_dec(is_classproperty:boolean); 165 var 166 p : tpropertysym; 167 begin 168 { check for a class, record or helper } 169 if not((is_class_or_interface_or_dispinterface(current_structdef) or is_record(current_structdef) or 170 is_objectpascal_helper(current_structdef) or is_java_class_or_interface(current_structdef)) or 171 (not(m_tp7 in current_settings.modeswitches) and (is_object(current_structdef)))) then 172 Message(parser_e_syntax_error); 173 consume(_PROPERTY); 174 p:=read_property_dec(is_classproperty,current_structdef); 175 consume(_SEMICOLON); 176 if try_to_consume(_DEFAULT) then 177 begin 178 if oo_has_default_property in current_structdef.objectoptions then 179 message(parser_e_only_one_default_property); 180 include(current_structdef.objectoptions,oo_has_default_property); 181 include(p.propoptions,ppo_defaultproperty); 182 if not(ppo_hasparameters in p.propoptions) then 183 message(parser_e_property_need_paras); 184 if (token=_COLON) then 185 begin 186 Message(parser_e_field_not_allowed_here); 187 consume_all_until(_SEMICOLON); 188 end; 189 consume(_SEMICOLON); 190 end; 191 { parse possible enumerator modifier } 192 if try_to_consume(_ENUMERATOR) then 193 begin 194 if (token = _ID) then 195 begin 196 if pattern='CURRENT' then 197 begin 198 if oo_has_enumerator_current in current_structdef.objectoptions then 199 message(parser_e_only_one_enumerator_current); 200 if not p.propaccesslist[palt_read].empty then 201 begin 202 include(current_structdef.objectoptions,oo_has_enumerator_current); 203 include(p.propoptions,ppo_enumerator_current); 204 end 205 else 206 Message(parser_e_enumerator_current_is_not_valid) // property has no reader 207 end 208 else 209 Message1(parser_e_invalid_enumerator_identifier, pattern); 210 consume(token); 211 end 212 else 213 Message(parser_e_enumerator_identifier_required); 214 consume(_SEMICOLON); 215 end; 216 { hint directives, these can be separated by semicolons here, 217 that needs to be handled here with a loop (PFV) } 218 while try_consume_hintdirective(p.symoptions,p.deprecatedmsg) do 219 Consume(_SEMICOLON); 220 end; 221 222 223 function class_destructor_head(astruct: tabstractrecorddef):tprocdef; 224 var 225 pd : tprocdef; 226 begin 227 result:=nil; 228 consume(_DESTRUCTOR); 229 parse_proc_head(current_structdef,potype_class_destructor,false,nil,nil,pd); 230 if not assigned(pd) then 231 begin 232 consume(_SEMICOLON); 233 exit; 234 end; 235 pd.calcparas; 236 if (pd.maxparacount>0) then 237 Message(parser_e_no_paras_for_class_destructor); 238 consume(_SEMICOLON); 239 include(astruct.objectoptions,oo_has_class_destructor); 240 current_module.flags:=current_module.flags or uf_classinits; 241 { no return value } 242 pd.returndef:=voidtype; 243 constr_destr_finish_head(pd,astruct); 244 result:=pd; 245 end; 246 247 function destructor_head:tprocdef; 248 var 249 pd : tprocdef; 250 begin 251 result:=nil; 252 consume(_DESTRUCTOR); 253 parse_proc_head(current_structdef,potype_destructor,false,nil,nil,pd); 254 if not assigned(pd) then 255 begin 256 consume(_SEMICOLON); 257 exit; 258 end; 259 if (cs_constructor_name in current_settings.globalswitches) and 260 (pd.procsym.name<>'DONE') then 261 Message(parser_e_destructorname_must_be_done); 262 pd.calcparas; 263 if not(pd.maxparacount=0) and 264 (m_fpc in current_settings.modeswitches) then 265 Message(parser_e_no_paras_for_destructor); 266 consume(_SEMICOLON); 267 include(current_structdef.objectoptions,oo_has_destructor); 268 include(current_structdef.objectoptions,oo_has_new_destructor); 269 { no return value } 270 pd.returndef:=voidtype; 271 constr_destr_finish_head(pd,pd.struct); 272 result:=pd; 273 end; 274 275 276 procedure setinterfacemethodoptions; 277 var 278 i : longint; 279 def : tdef; 280 begin 281 include(current_structdef.objectoptions,oo_has_virtual); 282 for i:=0 to current_structdef.symtable.DefList.count-1 do 283 begin 284 def:=tdef(current_structdef.symtable.DefList[i]); 285 if assigned(def) and 286 (def.typ=procdef) then 287 begin 288 include(tprocdef(def).procoptions,po_virtualmethod); 289 tprocdef(def).forwarddef:=false; 290 end; 291 end; 292 end; 293 294 295 procedure setobjcclassmethodoptions; 296 var 297 i : longint; 298 def : tdef; 299 begin 300 for i:=0 to current_structdef.symtable.DefList.count-1 do 301 begin 302 def:=tdef(current_structdef.symtable.DefList[i]); 303 if assigned(def) and 304 (def.typ=procdef) then 305 begin 306 include(tprocdef(def).procoptions,po_virtualmethod); 307 end; 308 end; 309 end; 310 311 312 procedure handleImplementedInterface(intfdef : tobjectdef); 313 begin 314 if not is_interface(intfdef) then 315 begin 316 Message1(type_e_interface_type_expected,intfdef.typename); 317 exit; 318 end; 319 if ([oo_is_forward,oo_is_formal] * intfdef.objectoptions <> []) then 320 begin 321 Message1(parser_e_forward_intf_declaration_must_be_resolved,intfdef.objrealname^); 322 exit; 323 end; 324 if find_implemented_interface(current_objectdef,intfdef)<>nil then 325 Message1(sym_e_duplicate_id,intfdef.objname^) 326 else 327 begin 328 { allocate and prepare the GUID only if the class 329 implements some interfaces. } 330 if current_objectdef.ImplementedInterfaces.count = 0 then 331 current_objectdef.prepareguid; 332 current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef)); 333 end; 334 end; 335 336 337 procedure handleImplementedProtocolOrJavaIntf(intfdef : tobjectdef); 338 begin 339 intfdef:=find_real_class_definition(intfdef,false); 340 case current_objectdef.objecttype of 341 odt_objcclass, 342 odt_objccategory, 343 odt_objcprotocol: 344 if not is_objcprotocol(intfdef) then 345 begin 346 Message1(type_e_protocol_type_expected,intfdef.typename); 347 exit; 348 end; 349 odt_javaclass, 350 odt_interfacejava: 351 if not is_javainterface(intfdef) then 352 begin 353 Message1(type_e_interface_type_expected,intfdef.typename); 354 exit 355 end; 356 else 357 internalerror(2011010807); 358 end; 359 if ([oo_is_forward,oo_is_formal] * intfdef.objectoptions <> []) then 360 begin 361 Message1(parser_e_forward_intf_declaration_must_be_resolved,intfdef.objrealname^); 362 exit; 363 end; 364 if find_implemented_interface(current_objectdef,intfdef)<>nil then 365 Message1(sym_e_duplicate_id,intfdef.objname^) 366 else 367 begin 368 current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef)); 369 end; 370 end; 371 372 373 procedure readImplementedInterfacesAndProtocols(intf: boolean); 374 var 375 hdef : tdef; 376 begin 377 while try_to_consume(_COMMA) do 378 begin 379 { use single_type instead of id_type for specialize support } 380 single_type(hdef,[stoAllowSpecialization,stoParseClassParent]); 381 if (hdef.typ<>objectdef) then 382 begin 383 if intf then 384 Message1(type_e_interface_type_expected,hdef.typename) 385 else 386 Message1(type_e_protocol_type_expected,hdef.typename); 387 continue; 388 end; 389 if intf then 390 handleImplementedInterface(tobjectdef(hdef)) 391 else 392 handleImplementedProtocolOrJavaIntf(tobjectdef(hdef)); 393 end; 394 end; 395 396 397 procedure readinterfaceiid; 398 var 399 p : tnode; 400 valid : boolean; 401 begin 402 p:=comp_expr([ef_accept_equal]); 403 if p.nodetype=stringconstn then 404 begin 405 stringdispose(current_objectdef.iidstr); 406 current_objectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); 407 valid:=string2guid(current_objectdef.iidstr^,current_objectdef.iidguid^); 408 if (current_objectdef.objecttype in [odt_interfacecom,odt_dispinterface]) and 409 not valid then 410 Message(parser_e_improper_guid_syntax); 411 include(current_structdef.objectoptions,oo_has_valid_guid); 412 end 413 else 414 Message(parser_e_illegal_expression); 415 p.free; 416 end; 417 418 procedure get_cpp_or_java_class_external_status(od: tobjectdef); 419 var 420 hs: string; 421 begin 422 { C++ classes can be external -> all methods inside are external 423 (defined at the class level instead of per method, so that you cannot 424 define some methods as external and some not) 425 } 426 if try_to_consume(_EXTERNAL) then 427 begin 428 hs:=''; 429 if token in [_CSTRING,_CWSTRING,_CCHAR,_CWCHAR] then 430 begin 431 { Always add library prefix and suffix to create an uniform name } 432 hs:=get_stringconst; 433 if ExtractFileExt(hs)='' then 434 hs:=ChangeFileExt(hs,target_info.sharedlibext); 435 if Copy(hs,1,length(target_info.sharedlibprefix))<>target_info.sharedlibprefix then 436 hs:=target_info.sharedlibprefix+hs; 437 end; 438 if hs<>'' then 439 begin 440 { the JVM expects java/lang/Object rather than java.lang.Object } 441 if target_info.system in systems_jvm then 442 Replace(hs,'.','/'); 443 stringdispose(od.import_lib); 444 od.import_lib:=stringdup(hs); 445 end; 446 { check if we shall use another name for the class } 447 if try_to_consume(_NAME) then 448 od.objextname:=stringdup(get_stringconst) 449 else 450 od.objextname:=stringdup(od.objrealname^); 451 include(od.objectoptions,oo_is_external); 452 end 453 else 454 begin 455 od.objextname:=stringdup(od.objrealname^); 456 end; 457 end; 458 459 460 procedure get_objc_class_or_protocol_external_status(od: tobjectdef); 461 begin 462 { Objective-C classes can be external -> all messages inside are 463 external (defined at the class level instead of per method, so 464 that you cannot define some methods as external and some not) 465 } 466 if try_to_consume(_EXTERNAL) then 467 begin 468 if try_to_consume(_NAME) then 469 od.objextname:=stringdup(get_stringconst) 470 else 471 { the external name doesn't matter for formally declared 472 classes, and allowing to specify one would mean that we would 473 have to check it for consistency with the actual definition 474 later on } 475 od.objextname:=stringdup(od.objrealname^); 476 include(od.objectoptions,oo_is_external); 477 end 478 else 479 od.objextname:=stringdup(od.objrealname^); 480 end; 481 482 483 procedure parse_object_options; 484 var 485 gotexternal: boolean; 486 begin 487 case current_objectdef.objecttype of 488 odt_object,odt_class, 489 odt_javaclass: 490 begin 491 gotexternal:=false; 492 while true do 493 begin 494 if try_to_consume(_ABSTRACT) then 495 include(current_structdef.objectoptions,oo_is_abstract) 496 else 497 if try_to_consume(_SEALED) then 498 include(current_structdef.objectoptions,oo_is_sealed) 499 else if (current_objectdef.objecttype=odt_javaclass) and 500 (token=_ID) and 501 (idtoken=_EXTERNAL) then 502 begin 503 get_cpp_or_java_class_external_status(current_objectdef); 504 gotexternal:=true; 505 end 506 else 507 break; 508 end; 509 { don't use <=, because there's a bug in the 2.6.0 SPARC code 510 generator regarding handling this expression } 511 if ([oo_is_abstract, oo_is_sealed] * current_structdef.objectoptions) = [oo_is_abstract, oo_is_sealed] then 512 Message(parser_e_abstract_and_sealed_conflict); 513 { set default external name in case of no external directive } 514 if (current_objectdef.objecttype=odt_javaclass) and 515 not gotexternal then 516 get_cpp_or_java_class_external_status(current_objectdef) 517 end; 518 odt_cppclass, 519 odt_interfacejava: 520 get_cpp_or_java_class_external_status(current_objectdef); 521 odt_objcclass,odt_objcprotocol,odt_objccategory: 522 get_objc_class_or_protocol_external_status(current_objectdef); 523 odt_helper: ; // nothing 524 end; 525 end; 526 527 procedure parse_parent_classes; 528 var 529 intfchildof, 530 childof : tobjectdef; 531 hdef : tdef; 532 hasparentdefined : boolean; 533 begin 534 childof:=nil; 535 intfchildof:=nil; 536 hasparentdefined:=false; 537 538 { reads the parent class } 539 if (token=_LKLAMMER) or 540 is_objccategory(current_structdef) then 541 begin 542 consume(_LKLAMMER); 543 { use single_type instead of id_type for specialize support } 544 single_type(hdef,[stoAllowSpecialization, stoParseClassParent]); 545 if (not assigned(hdef)) or 546 (hdef.typ<>objectdef) then 547 begin 548 if assigned(hdef) then 549 Message1(type_e_class_type_expected,hdef.typename) 550 else if is_objccategory(current_structdef) then 551 { a category must specify the class to extend } 552 Message(type_e_objcclass_type_expected); 553 end 554 else 555 begin 556 childof:=tobjectdef(hdef); 557 { a mix of class, interfaces, objects and cppclasses 558 isn't allowed } 559 case current_objectdef.objecttype of 560 odt_class, 561 odt_javaclass: 562 if (childof.objecttype<>current_objectdef.objecttype) then 563 begin 564 if (is_interface(childof) and 565 is_class(current_objectdef)) or 566 (is_javainterface(childof) and 567 is_javaclass(current_objectdef)) then 568 begin 569 { we insert the interface after the child 570 is set, see below 571 } 572 intfchildof:=childof; 573 childof:=class_tobject; 574 end 575 else 576 Message(parser_e_mix_of_classes_and_objects); 577 end 578 else 579 if oo_is_sealed in childof.objectoptions then 580 Message1(parser_e_sealed_descendant,childof.typename) 581 else 582 childof:=find_real_class_definition(childof,true); 583 odt_interfacecorba, 584 odt_interfacecom: 585 begin 586 if not(is_interface(childof)) then 587 Message(parser_e_mix_of_classes_and_objects); 588 current_objectdef.objecttype:=childof.objecttype; 589 end; 590 odt_cppclass: 591 if not(is_cppclass(childof)) then 592 Message(parser_e_mix_of_classes_and_objects); 593 odt_objcclass: 594 if not(is_objcclass(childof) or 595 is_objccategory(childof)) then 596 begin 597 if is_objcprotocol(childof) then 598 begin 599 if not(oo_is_classhelper in current_structdef.objectoptions) then 600 begin 601 intfchildof:=childof; 602 childof:=nil; 603 CGMessage(parser_h_no_objc_parent); 604 end 605 else 606 { a category must specify the class to extend } 607 CGMessage(type_e_objcclass_type_expected); 608 end 609 else 610 Message(parser_e_mix_of_classes_and_objects); 611 end 612 else 613 childof:=find_real_class_definition(childof,true); 614 odt_objcprotocol: 615 begin 616 if not(is_objcprotocol(childof)) then 617 Message(parser_e_mix_of_classes_and_objects); 618 intfchildof:=childof; 619 childof:=nil; 620 end; 621 odt_interfacejava: 622 begin 623 if not(is_javainterface(childof)) then 624 Message(parser_e_mix_of_classes_and_objects); 625 intfchildof:=find_real_class_definition(childof,true); 626 childof:=nil; 627 end; 628 odt_object: 629 if not(is_object(childof)) then 630 Message(parser_e_mix_of_classes_and_objects) 631 else 632 if oo_is_sealed in childof.objectoptions then 633 Message1(parser_e_sealed_descendant,childof.typename); 634 odt_dispinterface: 635 Message(parser_e_dispinterface_cant_have_parent); 636 odt_helper: 637 if not is_objectpascal_helper(childof) then 638 begin 639 Message(type_e_helper_type_expected); 640 childof:=nil; 641 end; 642 end; 643 end; 644 hasparentdefined:=true; 645 end; 646 647 { if no parent class, then a class get tobject as parent } 648 if not assigned(childof) then 649 begin 650 case current_objectdef.objecttype of 651 odt_class: 652 if current_objectdef<>class_tobject then 653 childof:=class_tobject; 654 odt_interfacecom: 655 if current_objectdef<>interface_iunknown then 656 childof:=interface_iunknown; 657 odt_dispinterface: 658 childof:=interface_idispatch; 659 odt_objcclass: 660 CGMessage(parser_h_no_objc_parent); 661 odt_javaclass: 662 { inherit from TObject by default for compatibility } 663 if current_objectdef<>java_jlobject then 664 childof:=class_tobject; 665 end; 666 end; 667 668 if assigned(childof) then 669 begin 670 { Forbid not completly defined objects to be used as parents. This will 671 also prevent circular loops of classes, because we set the forward flag 672 at the start of the new definition and will reset it below after the 673 parent has been set } 674 if (oo_is_forward in childof.objectoptions) then 675 Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^) 676 else if not(oo_is_formal in childof.objectoptions) then 677 current_objectdef.set_parent(childof) 678 else 679 Message1(sym_e_formal_class_not_resolved,childof.objrealname^); 680 end; 681 682 if hasparentdefined then 683 begin 684 if current_objectdef.objecttype in [odt_class,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then 685 begin 686 if assigned(intfchildof) then 687 if current_objectdef.objecttype=odt_class then 688 handleImplementedInterface(intfchildof) 689 else 690 handleImplementedProtocolOrJavaIntf(intfchildof); 691 readImplementedInterfacesAndProtocols(current_objectdef.objecttype=odt_class); 692 end; 693 consume(_RKLAMMER); 694 end; 695 696 { remove forward flag, is resolved } 697 exclude(current_structdef.objectoptions,oo_is_forward); 698 end; 699 700 procedure parse_extended_type(helpertype:thelpertype); 701 702 procedure validate_extendeddef_typehelper(var def:tdef); 703 begin 704 if (def.typ in [undefineddef,procvardef,procdef, 705 filedef,classrefdef,abstractdef,forwarddef,formaldef]) or 706 ( 707 (def.typ=objectdef) and 708 not (tobjectdef(def).objecttype in objecttypes_with_helpers) 709 ) then 710 begin 711 Message1(type_e_type_not_allowed_for_type_helper,def.typename); 712 def:=generrordef; 713 end; 714 end; 715 716 procedure check_inheritance_record_type_helper(var def:tdef); 717 begin 718 if (def.typ<>errordef) and assigned(current_objectdef.childof) then 719 begin 720 if def<>current_objectdef.childof.extendeddef then 721 begin 722 Message1(type_e_record_helper_must_extend_same_record,current_objectdef.childof.extendeddef.typename); 723 def:=generrordef; 724 end; 725 end; 726 end; 727 728 procedure check_inheritance_class_helper(var def:tdef); 729 begin 730 if (def.typ<>errordef) and assigned(current_objectdef.childof) then 731 begin 732 if (current_objectdef.childof.extendeddef.typ<>objectdef) or 733 not (tobjectdef(current_objectdef.childof.extendeddef).objecttype in objecttypes_with_helpers) then 734 Internalerror(2011021101); 735 if not def_is_related(def,current_objectdef.childof.extendeddef) then 736 begin 737 Message1(type_e_class_helper_must_extend_subclass,current_objectdef.childof.extendeddef.typename); 738 def:=generrordef; 739 end; 740 end; 741 end; 742 743 var 744 hdef: tdef; 745 begin 746 if not is_objectpascal_helper(current_structdef) then 747 Internalerror(2011021103); 748 if helpertype=ht_none then 749 Internalerror(2011021001); 750 751 consume(_FOR); 752 single_type(hdef,[stoParseClassParent]); 753 if not assigned(hdef) or (hdef.typ=errordef) then 754 begin 755 case helpertype of 756 ht_class: 757 Message1(type_e_class_type_expected,hdef.typename); 758 ht_record: 759 Message(type_e_record_type_expected); 760 ht_type: 761 Message1(type_e_type_id_expected,hdef.typename); 762 end; 763 end 764 else 765 begin 766 case helpertype of 767 ht_class: 768 if (hdef.typ<>objectdef) or 769 not is_class(hdef) then 770 Message1(type_e_class_type_expected,hdef.typename) 771 else 772 begin 773 { a class helper must extend the same class or a subclass 774 of the class extended by the parent class helper } 775 check_inheritance_class_helper(hdef); 776 end; 777 ht_record: 778 if (hdef.typ=objectdef) or 779 ( 780 { primitive types are allowed for record helpers in mode 781 delphi } 782 (hdef.typ<>recorddef) and 783 not (m_delphi in current_settings.modeswitches) 784 ) then 785 Message1(type_e_record_type_expected,hdef.typename) 786 else 787 begin 788 if hdef.typ<>recorddef then 789 { this is a primitive type in mode delphi, so validate 790 the def } 791 validate_extendeddef_typehelper(hdef); 792 { a record helper must extend the same record as the 793 parent helper } 794 check_inheritance_record_type_helper(hdef); 795 end; 796 ht_type: 797 begin 798 validate_extendeddef_typehelper(hdef); 799 if (hdef.typ=objectdef) and 800 (tobjectdef(hdef).objecttype in objecttypes_with_helpers) then 801 check_inheritance_class_helper(hdef) 802 else 803 { a type helper must extend the same type as the 804 parent helper } 805 check_inheritance_record_type_helper(hdef); 806 end; 807 end; 808 end; 809 810 if assigned(hdef) then 811 current_objectdef.extendeddef:=hdef 812 else 813 current_objectdef.extendeddef:=generrordef; 814 end; 815 816 procedure parse_guid; 817 begin 818 { read GUID } 819 if (current_objectdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and 820 try_to_consume(_LECKKLAMMER) then 821 begin 822 readinterfaceiid; 823 consume(_RECKKLAMMER); 824 end 825 else if (current_objectdef.objecttype=odt_dispinterface) then 826 message(parser_e_dispinterface_needs_a_guid); 827 end; 828 829 method_decnull830 function method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef; 831 832 procedure chkobjc(pd: tprocdef); 833 begin 834 if is_objc_class_or_protocol(pd.struct) then 835 begin 836 include(pd.procoptions,po_objc); 837 end; 838 end; 839 840 841 procedure chkjava(pd: tprocdef); 842 begin 843 {$ifdef jvm} 844 if is_java_class_or_interface(pd.struct) then 845 begin 846 { mark all non-virtual instance methods as "virtual; final;", 847 because 848 a) that's the only way to guarantee "non-virtual" behaviour 849 (other than making them class methods with an explicit self 850 pointer, but that causes problems with interface mappings 851 and procvars) 852 b) if we don't mark them virtual, they don't get added to the 853 vmt and we can't check whether child classes try to override 854 them 855 } 856 if is_javaclass(pd.struct) then 857 begin 858 if not(po_virtualmethod in pd.procoptions) and 859 not(po_classmethod in pd.procoptions) then 860 begin 861 include(pd.procoptions,po_virtualmethod); 862 include(pd.procoptions,po_finalmethod); 863 include(pd.procoptions,po_java_nonvirtual); 864 end 865 else if [po_virtualmethod,po_classmethod]<=pd.procoptions then 866 begin 867 if po_staticmethod in pd.procoptions then 868 Message(type_e_java_class_method_not_static_virtual); 869 end; 870 end; 871 end; 872 {$endif} 873 end; 874 875 876 procedure chkcpp(pd:tprocdef); 877 begin 878 { nothing currently } 879 end; 880 881 var 882 oldparse_only: boolean; 883 begin 884 case token of 885 _PROCEDURE, 886 _FUNCTION: 887 begin 888 if (astruct.symtable.currentvisibility=vis_published) and 889 not(oo_can_have_published in astruct.objectoptions) then 890 Message(parser_e_cant_have_published); 891 892 oldparse_only:=parse_only; 893 parse_only:=true; 894 result:=parse_proc_dec(is_classdef,astruct,hadgeneric); 895 896 { this is for error recovery as well as forward } 897 { interface mappings, i.e. mapping to a method } 898 { which isn't declared yet } 899 if assigned(result) then 900 begin 901 parse_object_proc_directives(result); 902 903 { check if dispid is set } 904 if is_dispinterface(result.struct) and not (po_dispid in result.procoptions) then 905 begin 906 result.dispid:=tobjectdef(result.struct).get_next_dispid; 907 include(result.procoptions, po_dispid); 908 end; 909 910 { all Macintosh Object Pascal methods are virtual. } 911 { this can't be a class method, because macpas mode } 912 { has no m_class } 913 if (m_mac in current_settings.modeswitches) then 914 include(result.procoptions,po_virtualmethod); 915 916 { for record and type helpers only static class methods are 917 allowed } 918 if is_objectpascal_helper(astruct) and 919 ( 920 (tobjectdef(astruct).extendeddef.typ<>objectdef) or 921 (tobjectdef(tobjectdef(astruct).extendeddef).objecttype<>odt_class) 922 ) and 923 is_classdef and not (po_staticmethod in result.procoptions) then 924 MessagePos(result.fileinfo,parser_e_class_methods_only_static_in_records); 925 926 handle_calling_convention(result,hcc_default_actions_intf); 927 928 { add definition to procsym } 929 proc_add_definition(result); 930 931 { add procdef options to objectdef options } 932 if (po_msgint in result.procoptions) then 933 include(astruct.objectoptions,oo_has_msgint); 934 if (po_msgstr in result.procoptions) then 935 include(astruct.objectoptions,oo_has_msgstr); 936 if (po_virtualmethod in result.procoptions) then 937 include(astruct.objectoptions,oo_has_virtual); 938 939 if result.is_generic then 940 astruct.symtable.includeoption(sto_has_generic); 941 942 chkcpp(result); 943 chkobjc(result); 944 chkjava(result); 945 end; 946 947 maybe_parse_hint_directives(result); 948 949 parse_only:=oldparse_only; 950 end; 951 _CONSTRUCTOR : 952 begin 953 if (astruct.symtable.currentvisibility=vis_published) and 954 not(oo_can_have_published in astruct.objectoptions) then 955 Message(parser_e_cant_have_published); 956 957 if not is_classdef and not(astruct.symtable.currentvisibility in [vis_public,vis_published]) then 958 Message(parser_w_constructor_should_be_public); 959 960 if is_interface(astruct) then 961 Message(parser_e_no_con_des_in_interfaces); 962 963 { Objective-C does not know the concept of a constructor } 964 if is_objc_class_or_protocol(astruct) then 965 Message(parser_e_objc_no_constructor_destructor); 966 967 if is_objectpascal_helper(astruct) then 968 if is_classdef then 969 { class constructors are not allowed in class helpers } 970 Message(parser_e_no_class_constructor_in_helpers); 971 972 { only 1 class constructor is allowed } 973 if is_classdef and (oo_has_class_constructor in astruct.objectoptions) then 974 Message1(parser_e_only_one_class_constructor_allowed, astruct.objrealname^); 975 976 oldparse_only:=parse_only; 977 parse_only:=true; 978 if is_classdef then 979 result:=class_constructor_head(current_structdef) 980 else 981 begin 982 result:=constructor_head; 983 if is_objectpascal_helper(astruct) and 984 (tobjectdef(astruct).extendeddef.typ<>objectdef) and 985 (result.minparacount=0) then 986 { as long as parameterless constructors aren't allowed in records they 987 aren't allowed in record/type helpers either } 988 MessagePos(result.procsym.fileinfo,parser_e_no_parameterless_constructor_in_records); 989 end; 990 991 chkcpp(result); 992 993 parse_only:=oldparse_only; 994 end; 995 _DESTRUCTOR : 996 begin 997 if (astruct.symtable.currentvisibility=vis_published) and 998 not(oo_can_have_published in astruct.objectoptions) then 999 Message(parser_e_cant_have_published); 1000 1001 if not is_classdef then 1002 if (oo_has_new_destructor in astruct.objectoptions) then 1003 Message(parser_n_only_one_destructor); 1004 1005 if is_interface(astruct) then 1006 Message(parser_e_no_con_des_in_interfaces); 1007 1008 { (class) destructors are not allowed in class helpers } 1009 if is_objectpascal_helper(astruct) then 1010 Message(parser_e_no_destructor_in_records); 1011 1012 if not is_classdef and (astruct.symtable.currentvisibility<>vis_public) then 1013 Message(parser_w_destructor_should_be_public); 1014 1015 { Objective-C does not know the concept of a destructor } 1016 if is_objc_class_or_protocol(astruct) then 1017 Message(parser_e_objc_no_constructor_destructor); 1018 1019 { only 1 class destructor is allowed } 1020 if is_classdef and (oo_has_class_destructor in astruct.objectoptions) then 1021 Message1(parser_e_only_one_class_destructor_allowed, astruct.objrealname^); 1022 1023 oldparse_only:=parse_only; 1024 parse_only:=true; 1025 if is_classdef then 1026 result:=class_destructor_head(current_structdef) 1027 else 1028 result:=destructor_head; 1029 1030 chkcpp(result); 1031 1032 parse_only:=oldparse_only; 1033 end; 1034 else 1035 internalerror(2011032102); 1036 end; 1037 end; 1038 1039 1040 procedure parse_object_members; 1041 1042 var 1043 typedconstswritable: boolean; 1044 object_member_blocktype : tblock_type; 1045 hadgeneric, 1046 fields_allowed, is_classdef, class_fields, is_final, final_fields, 1047 threadvar_fields : boolean; 1048 vdoptions: tvar_dec_options; 1049 fieldlist: tfpobjectlist; 1050 1051 1052 procedure parse_const; 1053 begin 1054 if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper,odt_javaclass,odt_interfacejava]) then 1055 Message(parser_e_type_var_const_only_in_records_and_classes); 1056 consume(_CONST); 1057 object_member_blocktype:=bt_const; 1058 final_fields:=is_final; 1059 is_final:=false; 1060 end; 1061 1062 1063 procedure parse_var(isthreadvar:boolean); 1064 begin 1065 if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper,odt_javaclass]) and 1066 { Java interfaces can contain static final class vars } 1067 not((current_objectdef.objecttype=odt_interfacejava) and 1068 is_final and is_classdef) then 1069 Message(parser_e_type_var_const_only_in_records_and_classes); 1070 if isthreadvar then 1071 consume(_THREADVAR) 1072 else 1073 consume(_VAR); 1074 fields_allowed:=true; 1075 object_member_blocktype:=bt_general; 1076 class_fields:=is_classdef; 1077 final_fields:=is_final; 1078 threadvar_fields:=isthreadvar; 1079 is_classdef:=false; 1080 is_final:=false; 1081 end; 1082 1083 1084 procedure parse_class; 1085 begin 1086 is_classdef:=false; 1087 { read class method/field/property } 1088 consume(_CLASS); 1089 { class modifier is only allowed for procedures, functions, } 1090 { constructors, destructors, fields and properties } _PROCEDUREnull1091 if not((token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_DESTRUCTOR,_THREADVAR]) or (token=_CONSTRUCTOR)) then 1092 Message(parser_e_procedure_or_function_expected); 1093 1094 { Java interfaces can contain final class vars } 1095 if is_interface(current_structdef) or 1096 (is_javainterface(current_structdef) and 1097 (not(is_final) or 1098 (token<>_VAR))) then 1099 Message(parser_e_no_static_method_in_interfaces) 1100 else 1101 { class methods are also allowed for Objective-C protocols } 1102 is_classdef:=true; 1103 end; 1104 1105 1106 procedure parse_visibility(vis: tvisibility; oo: tobjectoption); 1107 begin 1108 { Objective-C and Java classes do not support "published", 1109 as basically everything is published. } 1110 if (vis=vis_published) and 1111 (is_objc_class_or_protocol(current_structdef) or 1112 is_java_class_or_interface(current_structdef)) then 1113 Message(parser_e_no_objc_published) 1114 else if is_interface(current_structdef) or 1115 is_objc_protocol_or_category(current_structdef) or 1116 is_javainterface(current_structdef) then 1117 Message(parser_e_no_access_specifier_in_interfaces); 1118 current_structdef.symtable.currentvisibility:=vis; 1119 consume(token); 1120 if (oo<>oo_none) then 1121 include(current_structdef.objectoptions,oo); 1122 fields_allowed:=true; 1123 is_classdef:=false; 1124 class_fields:=false; 1125 threadvar_fields:=false; 1126 is_final:=false; 1127 object_member_blocktype:=bt_general; 1128 end; 1129 1130 1131 begin 1132 { empty class declaration ? } 1133 if (current_objectdef.objecttype in [odt_class,odt_objcclass,odt_javaclass]) and 1134 (token=_SEMICOLON) then 1135 exit; 1136 1137 { in "publishable" classes the default access type is published } 1138 if (oo_can_have_published in current_structdef.objectoptions) then 1139 current_structdef.symtable.currentvisibility:=vis_published 1140 else 1141 current_structdef.symtable.currentvisibility:=vis_public; 1142 fields_allowed:=true; 1143 is_classdef:=false; 1144 class_fields:=false; 1145 is_final:=false; 1146 final_fields:=false; 1147 hadgeneric:=false; 1148 threadvar_fields:=false; 1149 object_member_blocktype:=bt_general; 1150 fieldlist:=tfpobjectlist.create(false); 1151 repeat 1152 case token of 1153 _TYPE : 1154 begin 1155 if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper,odt_javaclass,odt_interfacejava]) then 1156 Message(parser_e_type_var_const_only_in_records_and_classes); 1157 consume(_TYPE); 1158 object_member_blocktype:=bt_type; 1159 end; 1160 _VAR : 1161 begin 1162 parse_var(false); 1163 end; 1164 _CONST: 1165 begin 1166 parse_const 1167 end; 1168 _THREADVAR : 1169 begin 1170 if not is_classdef then 1171 begin 1172 Message(parser_e_threadvar_must_be_class); 1173 { for error recovery we enforce class fields } 1174 is_classdef:=true; 1175 end; 1176 parse_var(true); 1177 end; 1178 _ID : 1179 begin 1180 if is_objcprotocol(current_structdef) and 1181 ((idtoken=_REQUIRED) or 1182 (idtoken=_OPTIONAL)) then 1183 begin 1184 current_structdef.symtable.currentlyoptional:=(idtoken=_OPTIONAL); 1185 consume(idtoken) 1186 end 1187 else case idtoken of 1188 _PRIVATE : 1189 begin 1190 parse_visibility(vis_private,oo_has_private); 1191 end; 1192 _PROTECTED : 1193 begin 1194 parse_visibility(vis_protected,oo_has_protected); 1195 end; 1196 _PUBLIC : 1197 begin 1198 parse_visibility(vis_public,oo_none); 1199 end; 1200 _PUBLISHED : 1201 begin 1202 parse_visibility(vis_published,oo_none); 1203 end; 1204 _STRICT : 1205 begin 1206 if is_interface(current_structdef) or 1207 is_objc_protocol_or_category(current_structdef) or 1208 is_javainterface(current_structdef) then 1209 Message(parser_e_no_access_specifier_in_interfaces); 1210 consume(_STRICT); 1211 if token=_ID then 1212 begin 1213 case idtoken of 1214 _PRIVATE: 1215 begin 1216 consume(_PRIVATE); 1217 current_structdef.symtable.currentvisibility:=vis_strictprivate; 1218 include(current_structdef.objectoptions,oo_has_strictprivate); 1219 end; 1220 _PROTECTED: 1221 begin 1222 consume(_PROTECTED); 1223 current_structdef.symtable.currentvisibility:=vis_strictprotected; 1224 include(current_structdef.objectoptions,oo_has_strictprotected); 1225 end; 1226 else 1227 message(parser_e_protected_or_private_expected); 1228 end; 1229 end 1230 else 1231 message(parser_e_protected_or_private_expected); 1232 fields_allowed:=true; 1233 is_classdef:=false; 1234 class_fields:=false; 1235 threadvar_fields:=false; 1236 is_final:=false; 1237 final_fields:=false; 1238 object_member_blocktype:=bt_general; 1239 end 1240 else if (m_final_fields in current_settings.modeswitches) and 1241 (token=_ID) and 1242 (idtoken=_FINAL) then 1243 begin 1244 { currently only supported for external classes, because 1245 requires fully working DFA otherwise } 1246 if (current_structdef.typ<>objectdef) or 1247 not(oo_is_external in tobjectdef(current_structdef).objectoptions) then 1248 Message(parser_e_final_only_external); 1249 consume(_final); 1250 is_final:=true; 1251 if token=_CLASS then 1252 parse_class; 1253 if not(token in [_CONST,_VAR]) then 1254 message(parser_e_final_only_const_var); 1255 end 1256 else 1257 begin 1258 if object_member_blocktype=bt_general then 1259 begin 1260 if (idtoken=_GENERIC) and 1261 not (m_delphi in current_settings.modeswitches) and 1262 ( 1263 not fields_allowed or 1264 is_objectpascal_helper(current_structdef) 1265 ) then 1266 begin 1267 if hadgeneric then 1268 Message(parser_e_procedure_or_function_expected); 1269 consume(_ID); 1270 hadgeneric:=true; 1271 if not (token in [_PROCEDURE,_FUNCTION,_CLASS]) then 1272 Message(parser_e_procedure_or_function_expected); 1273 end 1274 else 1275 begin 1276 if is_interface(current_structdef) or 1277 is_objc_protocol_or_category(current_structdef) or 1278 ( 1279 is_objectpascal_helper(current_structdef) and 1280 not class_fields 1281 ) or 1282 (is_javainterface(current_structdef) and 1283 not(class_fields and final_fields)) then 1284 Message(parser_e_no_vars_in_interfaces); 1285 1286 if (current_structdef.symtable.currentvisibility=vis_published) and 1287 not(oo_can_have_published in current_structdef.objectoptions) then 1288 Message(parser_e_cant_have_published); 1289 if (not fields_allowed) then 1290 Message(parser_e_field_not_allowed_here); 1291 1292 vdoptions:=[vd_object]; 1293 if not (m_delphi in current_settings.modeswitches) then 1294 include(vdoptions,vd_check_generic); 1295 if class_fields then 1296 include(vdoptions,vd_class); 1297 if is_class(current_structdef) then 1298 include(vdoptions,vd_canreorder); 1299 if final_fields then 1300 include(vdoptions,vd_final); 1301 if threadvar_fields then 1302 include(vdoptions,vd_threadvar); 1303 read_record_fields(vdoptions,fieldlist,nil,hadgeneric); 1304 end; 1305 end 1306 else if object_member_blocktype=bt_type then 1307 types_dec(true,hadgeneric) 1308 else if object_member_blocktype=bt_const then 1309 begin 1310 typedconstswritable:=false; 1311 if final_fields then 1312 begin 1313 { the value of final fields cannot be changed 1314 once they've been assigned a value } 1315 typedconstswritable:=cs_typed_const_writable in current_settings.localswitches; 1316 exclude(current_settings.localswitches,cs_typed_const_writable); 1317 end; 1318 consts_dec(true,not is_javainterface(current_structdef),hadgeneric); 1319 if final_fields and 1320 typedconstswritable then 1321 include(current_settings.localswitches,cs_typed_const_writable); 1322 end 1323 else 1324 internalerror(201001110); 1325 end; 1326 end; 1327 end; 1328 _PROPERTY : 1329 begin 1330 struct_property_dec(is_classdef); 1331 fields_allowed:=false; 1332 is_classdef:=false; 1333 end; 1334 _CLASS: 1335 begin 1336 parse_class; 1337 end; 1338 _PROCEDURE, 1339 _FUNCTION, 1340 _CONSTRUCTOR, 1341 _DESTRUCTOR : 1342 begin 1343 method_dec(current_structdef,is_classdef,hadgeneric); 1344 fields_allowed:=false; 1345 is_classdef:=false; 1346 hadgeneric:=false; 1347 end; 1348 _END : 1349 begin 1350 consume(_END); 1351 break; 1352 end; 1353 else 1354 consume(_ID); { Give a ident expected message, like tp7 } 1355 end; 1356 until false; 1357 1358 if is_class(current_structdef) then 1359 tabstractrecordsymtable(current_structdef.symtable).addfieldlist(fieldlist,true); 1360 fieldlist.free; 1361 end; 1362 1363 object_decnull1364 function object_dec(objecttype:tobjecttyp;const n:tidstring;objsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;fd : tobjectdef;helpertype:thelpertype) : tobjectdef; 1365 var 1366 old_current_structdef: tabstractrecorddef; 1367 old_current_genericdef, 1368 old_current_specializedef: tstoreddef; 1369 old_parse_generic: boolean; 1370 list: TFPObjectList; 1371 s: String; 1372 st: TSymtable; 1373 olddef: tdef; 1374 begin 1375 old_current_structdef:=current_structdef; 1376 old_current_genericdef:=current_genericdef; 1377 old_current_specializedef:=current_specializedef; 1378 old_parse_generic:=parse_generic; 1379 1380 current_structdef:=nil; 1381 current_genericdef:=nil; 1382 current_specializedef:=nil; 1383 1384 { objects and class types can't be declared local } 1385 if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and 1386 not assigned(genericlist) then 1387 Message(parser_e_no_local_objects); 1388 1389 { reuse forward objectdef? } 1390 if assigned(fd) then 1391 begin 1392 if fd.objecttype<>objecttype then 1393 begin 1394 Message(parser_e_forward_mismatch); 1395 { recover } 1396 current_structdef:=cobjectdef.create(objecttype,n,nil,true); 1397 include(current_structdef.objectoptions,oo_is_forward); 1398 end 1399 else 1400 current_structdef:=fd 1401 end 1402 else 1403 begin 1404 { anonym objects aren't allow (o : object a : longint; end;) } 1405 if n='' then 1406 Message(parser_f_no_anonym_objects); 1407 1408 { create new class } 1409 current_structdef:=cobjectdef.create(objecttype,n,nil,true); 1410 tobjectdef(current_structdef).helpertype:=helpertype; 1411 1412 { include always the forward flag, it'll be removed after the parent class have been 1413 added. This is to prevent circular childof loops } 1414 include(current_structdef.objectoptions,oo_is_forward); 1415 1416 if (cs_compilesystem in current_settings.moduleswitches) then 1417 begin 1418 case current_objectdef.objecttype of 1419 odt_interfacecom : 1420 if (current_structdef.objname^='IUNKNOWN') then 1421 interface_iunknown:=current_objectdef 1422 else 1423 if (current_structdef.objname^='IDISPATCH') then 1424 interface_idispatch:=current_objectdef; 1425 odt_class : 1426 if (current_structdef.objname^='TOBJECT') then 1427 class_tobject:=current_objectdef; 1428 odt_javaclass: 1429 begin 1430 if (current_structdef.objname^='TOBJECT') then 1431 class_tobject:=current_objectdef 1432 else if (current_objectdef.objname^='JLOBJECT') then 1433 java_jlobject:=current_objectdef 1434 else if (current_objectdef.objname^='JLTHROWABLE') then 1435 java_jlthrowable:=current_objectdef 1436 else if (current_objectdef.objname^='FPCBASERECORDTYPE') then 1437 java_fpcbaserecordtype:=current_objectdef 1438 else if (current_objectdef.objname^='JLSTRING') then 1439 java_jlstring:=current_objectdef 1440 else if (current_objectdef.objname^='ANSISTRINGCLASS') then 1441 java_ansistring:=current_objectdef 1442 else if (current_objectdef.objname^='SHORTSTRINGCLASS') then 1443 java_shortstring:=current_objectdef 1444 else if (current_objectdef.objname^='JLENUM') then 1445 java_jlenum:=current_objectdef 1446 else if (current_objectdef.objname^='JUENUMSET') then 1447 java_juenumset:=current_objectdef 1448 else if (current_objectdef.objname^='FPCBITSET') then 1449 java_jubitset:=current_objectdef 1450 else if (current_objectdef.objname^='FPCBASEPROCVARTYPE') then 1451 java_procvarbase:=current_objectdef; 1452 end; 1453 end; 1454 end; 1455 if (current_module.modulename^='OBJCBASE') then 1456 begin 1457 case current_objectdef.objecttype of 1458 odt_objcclass: 1459 if (current_objectdef.objname^='Protocol') then 1460 objc_protocoltype:=current_objectdef; 1461 end; 1462 end; 1463 end; 1464 1465 { usage of specialized type inside its generic template } 1466 if assigned(genericdef) then 1467 current_specializedef:=current_structdef; 1468 { reject declaration of generic class inside generic class } 1469 if assigned(genericlist) then 1470 current_genericdef:=current_structdef; 1471 1472 { nested types of specializations are specializations as well } 1473 if assigned(old_current_structdef) and 1474 (df_specialization in old_current_structdef.defoptions) then 1475 include(current_structdef.defoptions,df_specialization); 1476 if assigned(old_current_structdef) and 1477 (df_generic in old_current_structdef.defoptions) then 1478 begin 1479 include(current_structdef.defoptions,df_generic); 1480 current_genericdef:=current_structdef; 1481 end; 1482 1483 { set published flag in $M+ mode, it can also be inherited and will 1484 be added when the parent class set with tobjectdef.set_parent (PFV) } 1485 if (cs_generate_rtti in current_settings.localswitches) and 1486 (current_objectdef.objecttype in [odt_interfacecom,odt_class,odt_helper]) then 1487 include(current_structdef.objectoptions,oo_can_have_published); 1488 1489 { Objective-C/Java objectdefs can be "formal definitions", in which case 1490 the syntax is "type tc = objcclass external;" -> we have to parse 1491 its object options (external) already here, to make sure that such 1492 definitions are recognised as formal defs } 1493 if objecttype in [odt_objcclass,odt_objcprotocol,odt_objccategory,odt_javaclass,odt_interfacejava] then 1494 parse_object_options; 1495 1496 { forward def? } 1497 if not assigned(fd) and 1498 (token=_SEMICOLON) then 1499 begin 1500 if is_objectpascal_helper(current_structdef) then 1501 consume(_FOR); 1502 { add to the list of definitions to check that the forward 1503 is resolved. this is required for delphi mode } 1504 current_module.checkforwarddefs.add(current_structdef); 1505 end 1506 else 1507 begin 1508 { change objccategories into objcclass helpers } 1509 if (objecttype=odt_objccategory) then 1510 begin 1511 current_objectdef.objecttype:=odt_objcclass; 1512 include(current_structdef.objectoptions,oo_is_classhelper); 1513 end; 1514 1515 { include the class helper flag for Object Pascal helpers } 1516 if (objecttype=odt_helper) then 1517 include(current_objectdef.objectoptions,oo_is_classhelper); 1518 1519 { parse list of options (abstract / sealed) } 1520 if not(objecttype in [odt_objcclass,odt_objcprotocol,odt_objccategory,odt_javaclass,odt_interfacejava]) then 1521 parse_object_options; 1522 1523 symtablestack.push(current_structdef.symtable); 1524 insert_generic_parameter_types(current_structdef,genericdef,genericlist); 1525 { when we are parsing a generic already then this is a generic as 1526 well } 1527 if old_parse_generic then 1528 include(current_structdef.defoptions, df_generic); 1529 parse_generic:=(df_generic in current_structdef.defoptions); 1530 1531 { in non-Delphi modes we need a strict private symbol without type 1532 count and type parameters in the name to simply resolving } 1533 maybe_insert_generic_rename_symbol(n,genericlist); 1534 1535 { parse list of parent classes } 1536 { for record helpers in mode Delphi this is not allowed } 1537 if not (is_objectpascal_helper(current_objectdef) and 1538 (m_delphi in current_settings.modeswitches) and 1539 (helpertype=ht_record)) then 1540 parse_parent_classes 1541 else 1542 { remove forward flag, is resolved (this is normally done inside 1543 parse_parent_classes) } 1544 exclude(current_structdef.objectoptions,oo_is_forward); 1545 1546 { parse extended type for helpers } 1547 if is_objectpascal_helper(current_structdef) then 1548 parse_extended_type(helpertype); 1549 1550 { parse optional GUID for interfaces } 1551 parse_guid; 1552 1553 { classes can handle links to themself not only inside type blocks 1554 but in const blocks too. Additionally this is needed to parse parameters that are 1555 specializations of the currently parsed type in basically everything except C++ and 1556 ObjC classes. To make this possible we need to set their symbols to real defs instead 1557 of errordef } 1558 1559 if assigned(objsym) and not (objecttype in [odt_cppclass,odt_objccategory,odt_objcclass,odt_objcprotocol]) then 1560 begin 1561 olddef:=ttypesym(objsym).typedef; 1562 ttypesym(objsym).typedef:=current_structdef; 1563 current_structdef.typesym:=objsym; 1564 end 1565 else 1566 olddef:=nil; 1567 1568 { parse and insert object members } 1569 parse_object_members; 1570 1571 if assigned(olddef) then 1572 begin 1573 ttypesym(objsym).typedef:=olddef; 1574 current_structdef.typesym:=nil; 1575 end; 1576 1577 if not(oo_is_external in current_structdef.objectoptions) then 1578 begin 1579 { In Java, constructors are not automatically inherited (so you can 1580 hide them). Emulate the Pascal behaviour for classes implemented 1581 in Pascal (we cannot do it for classes implemented in Java, since 1582 we obviously cannot add constructors to those) } 1583 if is_javaclass(current_structdef) then 1584 begin 1585 add_missing_parent_constructors_intf(tobjectdef(current_structdef),true,vis_none); 1586 {$ifdef jvm} 1587 maybe_add_public_default_java_constructor(tobjectdef(current_structdef)); 1588 jvm_wrap_virtual_class_methods(tobjectdef(current_structdef)); 1589 {$endif} 1590 end; 1591 { need method to hold the initialization code for typed constants? } 1592 if (target_info.system in systems_typed_constants_node_init) and 1593 not is_any_interface_kind(current_structdef) then 1594 add_typedconst_init_routine(current_structdef); 1595 end; 1596 1597 symtablestack.pop(current_structdef.symtable); 1598 end; 1599 1600 { generate vmt space if needed } 1601 if not(oo_has_vmt in current_structdef.objectoptions) and 1602 not(oo_is_forward in current_structdef.objectoptions) and 1603 not(parse_generic) and 1604 { no vmt for helpers ever } 1605 not is_objectpascal_helper(current_structdef) and 1606 ( 1607 ([oo_has_virtual,oo_has_constructor,oo_has_destructor]*current_structdef.objectoptions<>[]) or 1608 (current_objectdef.objecttype in [odt_class]) 1609 ) then 1610 current_objectdef.insertvmt; 1611 1612 { for implemented classes with a vmt check if there is a constructor } 1613 if (oo_has_vmt in current_structdef.objectoptions) and 1614 not(oo_is_forward in current_structdef.objectoptions) and 1615 not(oo_has_constructor in current_structdef.objectoptions) and 1616 not is_objc_class_or_protocol(current_structdef) and 1617 not is_java_class_or_interface(current_structdef) then 1618 Message1(parser_w_virtual_without_constructor,current_structdef.objrealname^); 1619 1620 if is_interface(current_structdef) or 1621 is_objcprotocol(current_structdef) or 1622 is_javainterface(current_structdef) then 1623 setinterfacemethodoptions 1624 else if is_objcclass(current_structdef) then 1625 setobjcclassmethodoptions; 1626 1627 { we need to add this helper to the extendeddefs of the current module, 1628 as the global and static symtable are not pushed onto the symtable 1629 stack again (it will be removed when poping the symtable) } 1630 if is_objectpascal_helper(current_structdef) and 1631 (current_objectdef.extendeddef.typ<>errordef) then 1632 begin 1633 { the topmost symtable must be a static symtable } 1634 st:=current_structdef.owner; 1635 while st.symtabletype in [objectsymtable,recordsymtable] do 1636 st:=st.defowner.owner; 1637 if st.symtabletype in [staticsymtable,globalsymtable] then 1638 begin 1639 if current_objectdef.extendeddef.typ in [recorddef,objectdef] then 1640 s:=make_mangledname('',tabstractrecorddef(current_objectdef.extendeddef).symtable,'') 1641 else 1642 s:=make_mangledname('',current_objectdef.extendeddef.owner,current_objectdef.extendeddef.typesym.name); 1643 Message1(sym_d_adding_helper_for,s); 1644 list:=TFPObjectList(current_module.extendeddefs.Find(s)); 1645 if not assigned(list) then 1646 begin 1647 list:=TFPObjectList.Create(false); 1648 current_module.extendeddefs.Add(s, list); 1649 end; 1650 list.add(current_structdef); 1651 end; 1652 end; 1653 tabstractrecordsymtable(current_objectdef.symtable).addalignmentpadding; 1654 1655 { return defined objectdef } 1656 result:=current_objectdef; 1657 1658 { restore old state } 1659 current_structdef:=old_current_structdef; 1660 current_genericdef:=old_current_genericdef; 1661 current_specializedef:=old_current_specializedef; 1662 parse_generic:=old_parse_generic; 1663 end; 1664 1665 end. 1666