diff options
Diffstat (limited to 'closures/compiler/pdecobj.pas')
| -rw-r--r-- | closures/compiler/pdecobj.pas | 1281 |
1 files changed, 1281 insertions, 0 deletions
diff --git a/closures/compiler/pdecobj.pas b/closures/compiler/pdecobj.pas new file mode 100644 index 0000000000..1c29df2437 --- /dev/null +++ b/closures/compiler/pdecobj.pas @@ -0,0 +1,1281 @@ +{ + Copyright (c) 1998-2002 by Florian Klaempfl + + Does object types for Free Pascal + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit pdecobj; + +{$i fpcdefs.inc} + +interface + + uses + cclasses, + globtype,symconst,symtype,symdef; + + { parses a object declaration } + function object_dec(objecttype:tobjecttyp;const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef;helpertype:thelpertype) : tobjectdef; + + function class_constructor_head:tprocdef; + function class_destructor_head:tprocdef; + function constructor_head:tprocdef; + function destructor_head:tprocdef; + procedure struct_property_dec(is_classproperty:boolean); + +implementation + + uses + sysutils,cutils, + globals,verbose,systems,tokens, + symbase,symsym,symtable, + node,nld,nmem,ncon,ncnv,ncal, + fmodule,scanner, + pbase,pexpr,pdecsub,pdecvar,ptype,pdecl,pgenutil,ppu + ; + + const + { Please leave this here, this module should NOT use + these variables. + Declaring it as string here results in an error when compiling (PFV) } + current_procinfo = 'error'; + + var + current_objectdef : tobjectdef absolute current_structdef; + + function class_constructor_head:tprocdef; + var + pd : tprocdef; + begin + result:=nil; + consume(_CONSTRUCTOR); + { must be at same level as in implementation } + parse_proc_head(current_structdef,potype_class_constructor,pd); + if not assigned(pd) then + begin + consume(_SEMICOLON); + exit; + end; + pd.calcparas; + if (pd.maxparacount>0) then + Message(parser_e_no_paras_for_class_constructor); + consume(_SEMICOLON); + include(current_structdef.objectoptions,oo_has_class_constructor); + current_module.flags:=current_module.flags or uf_classinits; + { no return value } + pd.returndef:=voidtype; + result:=pd; + end; + + function constructor_head:tprocdef; + var + pd : tprocdef; + begin + result:=nil; + consume(_CONSTRUCTOR); + { must be at same level as in implementation } + parse_proc_head(current_structdef,potype_constructor,pd); + if not assigned(pd) then + begin + consume(_SEMICOLON); + exit; + end; + if (cs_constructor_name in current_settings.globalswitches) and + (pd.procsym.name<>'INIT') then + Message(parser_e_constructorname_must_be_init); + consume(_SEMICOLON); + include(current_structdef.objectoptions,oo_has_constructor); + { Set return type, class and record constructors return the + created instance, object constructors return boolean } + if is_class(pd.struct) or is_record(pd.struct) then + pd.returndef:=pd.struct + else +{$ifdef CPU64bitaddr} + pd.returndef:=bool64type; +{$else CPU64bitaddr} + pd.returndef:=bool32type; +{$endif CPU64bitaddr} + result:=pd; + end; + + + procedure struct_property_dec(is_classproperty:boolean); + var + p : tpropertysym; + begin + { check for a class, record or helper } + if not((is_class_or_interface_or_dispinterface(current_structdef) or is_record(current_structdef) or is_objectpascal_helper(current_structdef)) or + (not(m_tp7 in current_settings.modeswitches) and (is_object(current_structdef)))) then + Message(parser_e_syntax_error); + consume(_PROPERTY); + p:=read_property_dec(is_classproperty,current_structdef); + consume(_SEMICOLON); + if try_to_consume(_DEFAULT) then + begin + if oo_has_default_property in current_structdef.objectoptions then + message(parser_e_only_one_default_property); + include(current_structdef.objectoptions,oo_has_default_property); + include(p.propoptions,ppo_defaultproperty); + if not(ppo_hasparameters in p.propoptions) then + message(parser_e_property_need_paras); + if (token=_COLON) then + begin + Message(parser_e_field_not_allowed_here); + consume_all_until(_SEMICOLON); + end; + consume(_SEMICOLON); + end; + { parse possible enumerator modifier } + if try_to_consume(_ENUMERATOR) then + begin + if (token = _ID) then + begin + if pattern='CURRENT' then + begin + if oo_has_enumerator_current in current_structdef.objectoptions then + message(parser_e_only_one_enumerator_current); + if not p.propaccesslist[palt_read].empty then + begin + include(current_structdef.objectoptions,oo_has_enumerator_current); + include(p.propoptions,ppo_enumerator_current); + end + else + Message(parser_e_enumerator_current_is_not_valid) // property has no reader + end + else + Message1(parser_e_invalid_enumerator_identifier, pattern); + consume(token); + end + else + Message(parser_e_enumerator_identifier_required); + consume(_SEMICOLON); + end; + { hint directives, these can be separated by semicolons here, + that needs to be handled here with a loop (PFV) } + while try_consume_hintdirective(p.symoptions,p.deprecatedmsg) do + Consume(_SEMICOLON); + end; + + + function class_destructor_head:tprocdef; + var + pd : tprocdef; + begin + result:=nil; + consume(_DESTRUCTOR); + parse_proc_head(current_structdef,potype_class_destructor,pd); + if not assigned(pd) then + begin + consume(_SEMICOLON); + exit; + end; + pd.calcparas; + if (pd.maxparacount>0) then + Message(parser_e_no_paras_for_class_destructor); + consume(_SEMICOLON); + include(current_structdef.objectoptions,oo_has_class_destructor); + current_module.flags:=current_module.flags or uf_classinits; + { no return value } + pd.returndef:=voidtype; + result:=pd; + end; + + function destructor_head:tprocdef; + var + pd : tprocdef; + begin + result:=nil; + consume(_DESTRUCTOR); + parse_proc_head(current_structdef,potype_destructor,pd); + if not assigned(pd) then + begin + consume(_SEMICOLON); + exit; + end; + if (cs_constructor_name in current_settings.globalswitches) and + (pd.procsym.name<>'DONE') then + Message(parser_e_destructorname_must_be_done); + pd.calcparas; + if not(pd.maxparacount=0) and + (m_fpc in current_settings.modeswitches) then + Message(parser_e_no_paras_for_destructor); + consume(_SEMICOLON); + include(current_structdef.objectoptions,oo_has_destructor); + { no return value } + pd.returndef:=voidtype; + result:=pd; + end; + + + procedure setinterfacemethodoptions; + var + i : longint; + def : tdef; + begin + include(current_structdef.objectoptions,oo_has_virtual); + for i:=0 to current_structdef.symtable.DefList.count-1 do + begin + def:=tdef(current_structdef.symtable.DefList[i]); + if assigned(def) and + (def.typ=procdef) then + begin + include(tprocdef(def).procoptions,po_virtualmethod); + tprocdef(def).forwarddef:=false; + end; + end; + end; + + + procedure setobjcclassmethodoptions; + var + i : longint; + def : tdef; + begin + for i:=0 to current_structdef.symtable.DefList.count-1 do + begin + def:=tdef(current_structdef.symtable.DefList[i]); + if assigned(def) and + (def.typ=procdef) then + begin + include(tprocdef(def).procoptions,po_virtualmethod); + end; + end; + end; + + + procedure handleImplementedInterface(intfdef : tobjectdef); + begin + if not is_interface(intfdef) then + begin + Message1(type_e_interface_type_expected,intfdef.typename); + exit; + end; + if current_objectdef.find_implemented_interface(intfdef)<>nil then + Message1(sym_e_duplicate_id,intfdef.objname^) + else + begin + { allocate and prepare the GUID only if the class + implements some interfaces. } + if current_objectdef.ImplementedInterfaces.count = 0 then + current_objectdef.prepareguid; + current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef)); + end; + end; + + + procedure handleImplementedProtocol(intfdef : tobjectdef); + begin + intfdef:=find_real_objcclass_definition(intfdef,false); + if not is_objcprotocol(intfdef) then + begin + Message1(type_e_protocol_type_expected,intfdef.typename); + exit; + end; + if ([oo_is_forward,oo_is_formal] * intfdef.objectoptions <> []) then + begin + Message1(parser_e_forward_protocol_declaration_must_be_resolved,intfdef.objrealname^); + exit; + end; + if current_objectdef.find_implemented_interface(intfdef)<>nil then + Message1(sym_e_duplicate_id,intfdef.objname^) + else + begin + current_objectdef.ImplementedInterfaces.Add(TImplementedInterface.Create(intfdef)); + end; + end; + + + procedure readImplementedInterfacesAndProtocols(intf: boolean); + var + hdef : tdef; + begin + while try_to_consume(_COMMA) do + begin + { use single_type instead of id_type for specialize support } + single_type(hdef,[stoAllowSpecialization,stoParseClassParent]); + if (hdef.typ<>objectdef) then + begin + if intf then + Message1(type_e_interface_type_expected,hdef.typename) + else + Message1(type_e_protocol_type_expected,hdef.typename); + continue; + end; + if intf then + handleImplementedInterface(tobjectdef(hdef)) + else + handleImplementedProtocol(tobjectdef(hdef)); + end; + end; + + + procedure readinterfaceiid; + var + p : tnode; + valid : boolean; + begin + p:=comp_expr(true,false); + if p.nodetype=stringconstn then + begin + stringdispose(current_objectdef.iidstr); + current_objectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); + valid:=string2guid(current_objectdef.iidstr^,current_objectdef.iidguid^); + if (current_objectdef.objecttype in [odt_interfacecom,odt_dispinterface]) and + not valid then + Message(parser_e_improper_guid_syntax); + include(current_structdef.objectoptions,oo_has_valid_guid); + end + else + Message(parser_e_illegal_expression); + p.free; + end; + + procedure get_cpp_class_external_status(od: tobjectdef); + var + hs: string; + begin + { C++ classes can be external -> all methods inside are external + (defined at the class level instead of per method, so that you cannot + define some methods as external and some not) + } + if try_to_consume(_EXTERNAL) then + begin + if token in [_CSTRING,_CWSTRING,_CCHAR,_CWCHAR] then + begin + { Always add library prefix and suffix to create an uniform name } + hs:=get_stringconst; + if ExtractFileExt(hs)='' then + hs:=ChangeFileExt(hs,target_info.sharedlibext); + if Copy(hs,1,length(target_info.sharedlibprefix))<>target_info.sharedlibprefix then + hs:=target_info.sharedlibprefix+hs; + od.import_lib:=stringdup(hs); + end; + include(od.objectoptions, oo_is_external); + { check if we shall use another name for the class } + if try_to_consume(_NAME) then + od.objextname:=stringdup(get_stringconst) + else + od.objextname:=stringdup(od.objrealname^); + include(od.objectoptions,oo_is_external); + end + else + od.objextname:=stringdup(od.objrealname^); + { ToDo: read the namespace of the class (influences the mangled name)} + end; + + procedure get_objc_class_or_protocol_external_status(od: tobjectdef); + begin + { Objective-C classes can be external -> all messages inside are + external (defined at the class level instead of per method, so + that you cannot define some methods as external and some not) + } + if try_to_consume(_EXTERNAL) then + begin + if try_to_consume(_NAME) then + od.objextname:=stringdup(get_stringconst) + else + { the external name doesn't matter for formally declared + classes, and allowing to specify one would mean that we would + have to check it for consistency with the actual definition + later on } + od.objextname:=stringdup(od.objrealname^); + include(od.objectoptions,oo_is_external); + end + else + od.objextname:=stringdup(od.objrealname^); + end; + + + procedure parse_object_options; + begin + case current_objectdef.objecttype of + odt_object,odt_class: + begin + while true do + begin + if try_to_consume(_ABSTRACT) then + include(current_structdef.objectoptions,oo_is_abstract) + else + if try_to_consume(_SEALED) then + include(current_structdef.objectoptions,oo_is_sealed) + else + break; + end; + if [oo_is_abstract, oo_is_sealed] * current_structdef.objectoptions = [oo_is_abstract, oo_is_sealed] then + Message(parser_e_abstract_and_sealed_conflict); + end; + odt_cppclass: + get_cpp_class_external_status(current_objectdef); + odt_objcclass,odt_objcprotocol,odt_objccategory: + get_objc_class_or_protocol_external_status(current_objectdef); + odt_helper: ; // nothing + end; + end; + + procedure parse_parent_classes; + var + intfchildof, + childof : tobjectdef; + hdef : tdef; + hasparentdefined : boolean; + begin + childof:=nil; + intfchildof:=nil; + hasparentdefined:=false; + + { reads the parent class } + if (token=_LKLAMMER) or + is_objccategory(current_structdef) then + begin + consume(_LKLAMMER); + { use single_type instead of id_type for specialize support } + single_type(hdef,[stoAllowSpecialization, stoParseClassParent]); + if (not assigned(hdef)) or + (hdef.typ<>objectdef) then + begin + if assigned(hdef) then + Message1(type_e_class_type_expected,hdef.typename) + else if is_objccategory(current_structdef) then + { a category must specify the class to extend } + Message(type_e_objcclass_type_expected); + end + else + begin + childof:=tobjectdef(hdef); + { a mix of class, interfaces, objects and cppclasses + isn't allowed } + case current_objectdef.objecttype of + odt_class: + if not(is_class(childof)) then + begin + if is_interface(childof) then + begin + { we insert the interface after the child + is set, see below + } + intfchildof:=childof; + childof:=class_tobject; + end + else + Message(parser_e_mix_of_classes_and_objects); + end + else + if oo_is_sealed in childof.objectoptions then + Message1(parser_e_sealed_descendant,childof.typename); + odt_interfacecorba, + odt_interfacecom: + begin + if not(is_interface(childof)) then + Message(parser_e_mix_of_classes_and_objects); + current_objectdef.objecttype:=childof.objecttype; + end; + odt_cppclass: + if not(is_cppclass(childof)) then + Message(parser_e_mix_of_classes_and_objects); + odt_objcclass: + if not(is_objcclass(childof) or + is_objccategory(childof)) then + begin + if is_objcprotocol(childof) then + begin + if not(oo_is_classhelper in current_structdef.objectoptions) then + begin + intfchildof:=childof; + childof:=nil; + CGMessage(parser_h_no_objc_parent); + end + else + { a category must specify the class to extend } + CGMessage(type_e_objcclass_type_expected); + end + else + Message(parser_e_mix_of_classes_and_objects); + end + else + childof:=find_real_objcclass_definition(childof,true); + odt_objcprotocol: + begin + if not(is_objcprotocol(childof)) then + Message(parser_e_mix_of_classes_and_objects); + intfchildof:=childof; + childof:=nil; + end; + odt_object: + if not(is_object(childof)) then + Message(parser_e_mix_of_classes_and_objects) + else + if oo_is_sealed in childof.objectoptions then + Message1(parser_e_sealed_descendant,childof.typename); + odt_dispinterface: + Message(parser_e_dispinterface_cant_have_parent); + odt_helper: + if not is_objectpascal_helper(childof) then + begin + Message(type_e_helper_type_expected); + childof:=nil; + end; + end; + end; + hasparentdefined:=true; + end; + + { if no parent class, then a class get tobject as parent } + if not assigned(childof) then + begin + case current_objectdef.objecttype of + odt_class: + if current_objectdef<>class_tobject then + childof:=class_tobject; + odt_interfacecom: + if current_objectdef<>interface_iunknown then + childof:=interface_iunknown; + odt_dispinterface: + childof:=interface_idispatch; + odt_objcclass: + CGMessage(parser_h_no_objc_parent); + end; + end; + + if assigned(childof) then + begin + { Forbid not completly defined objects to be used as parents. This will + also prevent circular loops of classes, because we set the forward flag + at the start of the new definition and will reset it below after the + parent has been set } + if (oo_is_forward in childof.objectoptions) then + Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^) + else if not(oo_is_formal in childof.objectoptions) then + current_objectdef.set_parent(childof) + else + Message1(sym_e_objc_formal_class_not_resolved,childof.objrealname^); + end; + + { remove forward flag, is resolved } + exclude(current_structdef.objectoptions,oo_is_forward); + + if hasparentdefined then + begin + if current_objectdef.objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then + begin + if assigned(intfchildof) then + if current_objectdef.objecttype=odt_class then + handleImplementedInterface(intfchildof) + else + handleImplementedProtocol(intfchildof); + readImplementedInterfacesAndProtocols(current_objectdef.objecttype=odt_class); + end; + consume(_RKLAMMER); + end; + end; + + procedure parse_extended_type(helpertype:thelpertype); + var + hdef: tdef; + begin + if not is_objectpascal_helper(current_structdef) then + Internalerror(2011021103); + if helpertype=ht_none then + Internalerror(2011021001); + + consume(_FOR); + single_type(hdef,[stoParseClassParent]); + if (not assigned(hdef)) or + not (hdef.typ in [objectdef,recorddef]) then + begin + if helpertype=ht_class then + Message1(type_e_class_type_expected,hdef.typename) + else + if helpertype=ht_record then + Message1(type_e_record_type_expected,hdef.typename); + end + else + begin + case helpertype of + ht_class: + begin + if not is_class(hdef) then + Message1(type_e_class_type_expected,hdef.typename); + { a class helper must extend the same class or a subclass + of the class extended by the parent class helper } + if assigned(current_objectdef.childof) then + begin + if not is_class(current_objectdef.childof.extendeddef) then + Internalerror(2011021101); + if not hdef.is_related(current_objectdef.childof.extendeddef) then + Message1(type_e_class_helper_must_extend_subclass,current_objectdef.childof.extendeddef.typename); + end; + end; + ht_record: + begin + if not is_record(hdef) then + Message1(type_e_record_type_expected,hdef.typename); + { a record helper must extend the same record as the + parent helper } + if assigned(current_objectdef.childof) then + begin + if not is_record(current_objectdef.childof.extendeddef) then + Internalerror(2011021102); + if hdef<>current_objectdef.childof.extendeddef then + Message1(type_e_record_helper_must_extend_same_record,current_objectdef.childof.extendeddef.typename); + end; + end; + else + hdef:=nil; + end; + end; + + if assigned(hdef) then + current_objectdef.extendeddef:=hdef + else + current_objectdef.extendeddef:=generrordef; + end; + + procedure parse_guid; + begin + { read GUID } + if (current_objectdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and + try_to_consume(_LECKKLAMMER) then + begin + readinterfaceiid; + consume(_RECKKLAMMER); + end + else if (current_objectdef.objecttype=odt_dispinterface) then + message(parser_e_dispinterface_needs_a_guid); + end; + + procedure parse_object_members; + + procedure chkobjc(pd: tprocdef); + begin + if is_objc_class_or_protocol(pd.struct) then + begin + include(pd.procoptions,po_objc); + end; + end; + + + procedure chkcpp(pd:tprocdef); + begin + { nothing currently } + end; + + procedure maybe_parse_hint_directives(pd:tprocdef); + var + dummysymoptions : tsymoptions; + deprecatedmsg : pshortstring; + begin + dummysymoptions:=[]; + deprecatedmsg:=nil; + while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do + Consume(_SEMICOLON); + if assigned(pd) then + begin + pd.symoptions:=pd.symoptions+dummysymoptions; + pd.deprecatedmsg:=deprecatedmsg; + end + else + stringdispose(deprecatedmsg); + end; + + var + pd : tprocdef; + has_destructor, + oldparse_only: boolean; + object_member_blocktype : tblock_type; + fields_allowed, is_classdef, classfields: boolean; + vdoptions: tvar_dec_options; + begin + { empty class declaration ? } + if (current_objectdef.objecttype in [odt_class,odt_objcclass]) and + (token=_SEMICOLON) then + exit; + + { in "publishable" classes the default access type is published } + if (oo_can_have_published in current_structdef.objectoptions) then + current_structdef.symtable.currentvisibility:=vis_published + else + current_structdef.symtable.currentvisibility:=vis_public; + has_destructor:=false; + fields_allowed:=true; + is_classdef:=false; + classfields:=false; + object_member_blocktype:=bt_general; + repeat + case token of + _TYPE : + begin + if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper]) then + Message(parser_e_type_var_const_only_in_records_and_classes); + consume(_TYPE); + object_member_blocktype:=bt_type; + end; + _VAR : + begin + if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper]) then + Message(parser_e_type_var_const_only_in_records_and_classes); + consume(_VAR); + fields_allowed:=true; + object_member_blocktype:=bt_general; + classfields:=is_classdef; + is_classdef:=false; + end; + _CONST: + begin + if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper]) then + Message(parser_e_type_var_const_only_in_records_and_classes); + consume(_CONST); + object_member_blocktype:=bt_const; + end; + _ID : + begin + if is_objcprotocol(current_structdef) and + ((idtoken=_REQUIRED) or + (idtoken=_OPTIONAL)) then + begin + current_structdef.symtable.currentlyoptional:=(idtoken=_OPTIONAL); + consume(idtoken) + end + else case idtoken of + _PRIVATE : + begin + if is_interface(current_structdef) or + is_objc_protocol_or_category(current_structdef) then + Message(parser_e_no_access_specifier_in_interfaces); + consume(_PRIVATE); + current_structdef.symtable.currentvisibility:=vis_private; + include(current_structdef.objectoptions,oo_has_private); + fields_allowed:=true; + is_classdef:=false; + classfields:=false; + object_member_blocktype:=bt_general; + end; + _PROTECTED : + begin + if is_interface(current_structdef) or + is_objc_protocol_or_category(current_structdef) then + Message(parser_e_no_access_specifier_in_interfaces); + consume(_PROTECTED); + current_structdef.symtable.currentvisibility:=vis_protected; + include(current_structdef.objectoptions,oo_has_protected); + fields_allowed:=true; + is_classdef:=false; + classfields:=false; + object_member_blocktype:=bt_general; + end; + _PUBLIC : + begin + if is_interface(current_structdef) or + is_objc_protocol_or_category(current_structdef) then + Message(parser_e_no_access_specifier_in_interfaces); + consume(_PUBLIC); + current_structdef.symtable.currentvisibility:=vis_public; + fields_allowed:=true; + is_classdef:=false; + classfields:=false; + object_member_blocktype:=bt_general; + end; + _PUBLISHED : + begin + { we've to check for a pushlished section in non- } + { publishable classes later, if a real declaration } + { this is the way, delphi does it } + if is_interface(current_structdef) then + Message(parser_e_no_access_specifier_in_interfaces); + { Objective-C classes do not support "published", + as basically everything is published. } + if is_objc_class_or_protocol(current_structdef) then + Message(parser_e_no_objc_published); + consume(_PUBLISHED); + current_structdef.symtable.currentvisibility:=vis_published; + fields_allowed:=true; + is_classdef:=false; + classfields:=false; + object_member_blocktype:=bt_general; + end; + _STRICT : + begin + if is_interface(current_structdef) or + is_objc_protocol_or_category(current_structdef) then + Message(parser_e_no_access_specifier_in_interfaces); + consume(_STRICT); + if token=_ID then + begin + case idtoken of + _PRIVATE: + begin + consume(_PRIVATE); + current_structdef.symtable.currentvisibility:=vis_strictprivate; + include(current_structdef.objectoptions,oo_has_strictprivate); + end; + _PROTECTED: + begin + consume(_PROTECTED); + current_structdef.symtable.currentvisibility:=vis_strictprotected; + include(current_structdef.objectoptions,oo_has_strictprotected); + end; + else + message(parser_e_protected_or_private_expected); + end; + end + else + message(parser_e_protected_or_private_expected); + fields_allowed:=true; + is_classdef:=false; + classfields:=false; + object_member_blocktype:=bt_general; + end + else + begin + if object_member_blocktype=bt_general then + begin + if is_interface(current_structdef) or + is_objc_protocol_or_category(current_structdef) or + is_objectpascal_helper(current_structdef) then + Message(parser_e_no_vars_in_interfaces); + + if (current_structdef.symtable.currentvisibility=vis_published) and + not(oo_can_have_published in current_structdef.objectoptions) then + Message(parser_e_cant_have_published); + if (not fields_allowed) then + Message(parser_e_field_not_allowed_here); + + vdoptions:=[vd_object]; + if classfields then + include(vdoptions,vd_class); + read_record_fields(vdoptions); + end + else if object_member_blocktype=bt_type then + types_dec(true) + else if object_member_blocktype=bt_const then + consts_dec(true) + else + internalerror(201001110); + end; + end; + end; + _PROPERTY : + begin + struct_property_dec(is_classdef); + fields_allowed:=false; + is_classdef:=false; + end; + _CLASS: + begin + is_classdef:=false; + { read class method/field/property } + consume(_CLASS); + { class modifier is only allowed for procedures, functions, } + { constructors, destructors, fields and properties } + if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR]) then + Message(parser_e_procedure_or_function_expected); + + if is_interface(current_structdef) then + Message(parser_e_no_static_method_in_interfaces) + else + { class methods are also allowed for Objective-C protocols } + is_classdef:=true; + end; + _PROCEDURE, + _FUNCTION: + begin + if (current_structdef.symtable.currentvisibility=vis_published) and + not(oo_can_have_published in current_structdef.objectoptions) then + Message(parser_e_cant_have_published); + + oldparse_only:=parse_only; + parse_only:=true; + pd:=parse_proc_dec(is_classdef,current_structdef); + + { this is for error recovery as well as forward } + { interface mappings, i.e. mapping to a method } + { which isn't declared yet } + if assigned(pd) then + begin + parse_object_proc_directives(pd); + + { check if dispid is set } + if is_dispinterface(pd.struct) and not (po_dispid in pd.procoptions) then + begin + pd.dispid:=tobjectdef(pd.struct).get_next_dispid; + include(pd.procoptions, po_dispid); + end; + + { all Macintosh Object Pascal methods are virtual. } + { this can't be a class method, because macpas mode } + { has no m_class } + if (m_mac in current_settings.modeswitches) then + include(pd.procoptions,po_virtualmethod); + + { for record helpers only static class methods are allowed } + if is_objectpascal_helper(current_structdef) and + is_record(current_objectdef.extendeddef) and + is_classdef and not (po_staticmethod in pd.procoptions) then + MessagePos(pd.fileinfo, parser_e_class_methods_only_static_in_records); + + handle_calling_convention(pd); + + { add definition to procsym } + proc_add_definition(pd); + + { add procdef options to objectdef options } + if (po_msgint in pd.procoptions) then + include(current_structdef.objectoptions,oo_has_msgint); + if (po_msgstr in pd.procoptions) then + include(current_structdef.objectoptions,oo_has_msgstr); + if (po_virtualmethod in pd.procoptions) then + include(current_structdef.objectoptions,oo_has_virtual); + + chkcpp(pd); + chkobjc(pd); + end; + + maybe_parse_hint_directives(pd); + + parse_only:=oldparse_only; + fields_allowed:=false; + is_classdef:=false; + end; + _CONSTRUCTOR : + begin + if (current_structdef.symtable.currentvisibility=vis_published) and + not(oo_can_have_published in current_structdef.objectoptions) then + Message(parser_e_cant_have_published); + + if not is_classdef and not(current_structdef.symtable.currentvisibility in [vis_public,vis_published]) then + Message(parser_w_constructor_should_be_public); + + if is_interface(current_structdef) then + Message(parser_e_no_con_des_in_interfaces); + + { Objective-C does not know the concept of a constructor } + if is_objc_class_or_protocol(current_structdef) then + Message(parser_e_objc_no_constructor_destructor); + + if is_objectpascal_helper(current_structdef) then + if is_classdef then + { class constructors are not allowed in class helpers } + Message(parser_e_no_class_constructor_in_helpers) + else + if is_record(current_objectdef.extendeddef) then + { as long as constructors aren't allowed in records they + aren't allowed in helpers either } + Message(parser_e_no_constructor_in_records); + + { only 1 class constructor is allowed } + if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then + Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^); + + oldparse_only:=parse_only; + parse_only:=true; + if is_classdef then + pd:=class_constructor_head + else + pd:=constructor_head; + parse_object_proc_directives(pd); + handle_calling_convention(pd); + + { add definition to procsym } + proc_add_definition(pd); + + { add procdef options to objectdef options } + if (po_virtualmethod in pd.procoptions) then + include(current_structdef.objectoptions,oo_has_virtual); + chkcpp(pd); + maybe_parse_hint_directives(pd); + + parse_only:=oldparse_only; + fields_allowed:=false; + is_classdef:=false; + end; + _DESTRUCTOR : + begin + if (current_structdef.symtable.currentvisibility=vis_published) and + not(oo_can_have_published in current_structdef.objectoptions) then + Message(parser_e_cant_have_published); + + if not is_classdef then + if has_destructor then + Message(parser_n_only_one_destructor) + else + has_destructor:=true; + + if is_interface(current_structdef) then + Message(parser_e_no_con_des_in_interfaces); + + { (class) destructors are not allowed in class helpers } + if is_objectpascal_helper(current_structdef) then + Message(parser_e_no_destructor_in_records); + + if not is_classdef and (current_structdef.symtable.currentvisibility<>vis_public) then + Message(parser_w_destructor_should_be_public); + + { Objective-C does not know the concept of a destructor } + if is_objc_class_or_protocol(current_structdef) then + Message(parser_e_objc_no_constructor_destructor); + + { only 1 class destructor is allowed } + if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then + Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^); + + oldparse_only:=parse_only; + parse_only:=true; + if is_classdef then + pd:=class_destructor_head + else + pd:=destructor_head; + parse_object_proc_directives(pd); + handle_calling_convention(pd); + + { add definition to procsym } + proc_add_definition(pd); + + { add procdef options to objectdef options } + if (po_virtualmethod in pd.procoptions) then + include(current_structdef.objectoptions,oo_has_virtual); + + chkcpp(pd); + maybe_parse_hint_directives(pd); + + parse_only:=oldparse_only; + fields_allowed:=false; + is_classdef:=false; + end; + _END : + begin + consume(_END); + break; + end; + else + consume(_ID); { Give a ident expected message, like tp7 } + end; + until false; + end; + + + function object_dec(objecttype:tobjecttyp;const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef;helpertype:thelpertype) : tobjectdef; + var + old_current_structdef: tabstractrecorddef; + old_current_genericdef, + old_current_specializedef: tstoreddef; + old_parse_generic: boolean; + list: TFPObjectList; + s: String; + st: TSymtable; + begin + old_current_structdef:=current_structdef; + old_current_genericdef:=current_genericdef; + old_current_specializedef:=current_specializedef; + old_parse_generic:=parse_generic; + + current_structdef:=nil; + current_genericdef:=nil; + current_specializedef:=nil; + + { objects and class types can't be declared local } + if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and + not assigned(genericlist) then + Message(parser_e_no_local_objects); + + { reuse forward objectdef? } + if assigned(fd) then + begin + if fd.objecttype<>objecttype then + begin + Message(parser_e_forward_mismatch); + { recover } + current_structdef:=tobjectdef.create(current_objectdef.objecttype,n,nil); + include(current_structdef.objectoptions,oo_is_forward); + end + else + current_structdef:=fd + end + else + begin + { anonym objects aren't allow (o : object a : longint; end;) } + if n='' then + Message(parser_f_no_anonym_objects); + + { create new class } + current_structdef:=tobjectdef.create(objecttype,n,nil); + + { include always the forward flag, it'll be removed after the parent class have been + added. This is to prevent circular childof loops } + include(current_structdef.objectoptions,oo_is_forward); + + if (cs_compilesystem in current_settings.moduleswitches) then + begin + case current_objectdef.objecttype of + odt_interfacecom : + if (current_structdef.objname^='IUNKNOWN') then + interface_iunknown:=current_objectdef + else + if (current_structdef.objname^='IDISPATCH') then + interface_idispatch:=current_objectdef; + odt_class : + if (current_structdef.objname^='TOBJECT') then + class_tobject:=current_objectdef; + end; + end; + if (current_module.modulename^='OBJCBASE') then + begin + case current_objectdef.objecttype of + odt_objcclass: + if (current_objectdef.objname^='Protocol') then + objc_protocoltype:=current_objectdef; + end; + end; + end; + + { usage of specialized type inside its generic template } + if assigned(genericdef) then + current_specializedef:=current_structdef + { reject declaration of generic class inside generic class } + else if assigned(genericlist) then + current_genericdef:=current_structdef; + + { nested types of specializations are specializations as well } + if assigned(old_current_structdef) and + (df_specialization in old_current_structdef.defoptions) then + include(current_structdef.defoptions,df_specialization); + + { set published flag in $M+ mode, it can also be inherited and will + be added when the parent class set with tobjectdef.set_parent (PFV) } + if (cs_generate_rtti in current_settings.localswitches) and + (current_objectdef.objecttype in [odt_interfacecom,odt_class,odt_helper]) then + include(current_structdef.objectoptions,oo_can_have_published); + + { Objective-C objectdefs can be "formal definitions", in which case + the syntax is "type tc = objcclass external;" -> we have to parse + its object options (external) already here, to make sure that such + definitions are recognised as formal defs } + if objecttype in [odt_objcclass,odt_objcprotocol,odt_objccategory] then + parse_object_options; + + { forward def? } + if not assigned(fd) and + (token=_SEMICOLON) then + begin + { add to the list of definitions to check that the forward + is resolved. this is required for delphi mode } + current_module.checkforwarddefs.add(current_structdef); + end + else + begin + { change objccategories into objcclass helpers } + if (objecttype=odt_objccategory) then + begin + current_objectdef.objecttype:=odt_objcclass; + include(current_structdef.objectoptions,oo_is_classhelper); + end; + + { include the class helper flag for Object Pascal helpers } + if (objecttype=odt_helper) then + include(current_objectdef.objectoptions,oo_is_classhelper); + + { parse list of options (abstract / sealed) } + if not(objecttype in [odt_objcclass,odt_objcprotocol,odt_objccategory]) then + parse_object_options; + + symtablestack.push(current_structdef.symtable); + insert_generic_parameter_types(current_structdef,genericdef,genericlist); + { when we are parsing a generic already then this is a generic as + well } + if old_parse_generic then + include(current_structdef.defoptions, df_generic); + parse_generic:=(df_generic in current_structdef.defoptions); + + { parse list of parent classes } + { for record helpers in mode Delphi this is not allowed } + if not (is_objectpascal_helper(current_objectdef) and + (m_delphi in current_settings.modeswitches) and + (helpertype=ht_record)) then + parse_parent_classes + else + { remove forward flag, is resolved (this is normally done inside + parse_parent_classes) } + exclude(current_structdef.objectoptions,oo_is_forward); + + { parse extended type for helpers } + if is_objectpascal_helper(current_structdef) then + parse_extended_type(helpertype); + + { parse optional GUID for interfaces } + parse_guid; + + { parse and insert object members } + parse_object_members; + symtablestack.pop(current_structdef.symtable); + end; + + { generate vmt space if needed } + if not(oo_has_vmt in current_structdef.objectoptions) and + not(oo_is_forward in current_structdef.objectoptions) and + ( + ([oo_has_virtual,oo_has_constructor,oo_has_destructor]*current_structdef.objectoptions<>[]) or + (current_objectdef.objecttype in [odt_class]) + ) then + current_objectdef.insertvmt; + + { for implemented classes with a vmt check if there is a constructor } + if (oo_has_vmt in current_structdef.objectoptions) and + not(oo_is_forward in current_structdef.objectoptions) and + not(oo_has_constructor in current_structdef.objectoptions) and + not is_objc_class_or_protocol(current_structdef) then + Message1(parser_w_virtual_without_constructor,current_structdef.objrealname^); + + if is_interface(current_structdef) or + is_objcprotocol(current_structdef) then + setinterfacemethodoptions + else if is_objcclass(current_structdef) then + setobjcclassmethodoptions; + + { if this helper is defined in the implementation section of the unit + or inside the main project file, the extendeddefs list of the current + module must be updated (it will be removed when poping the symtable) } + if is_objectpascal_helper(current_structdef) and + (current_objectdef.extendeddef.typ in [recorddef,objectdef]) then + begin + { the topmost symtable must be a static symtable } + st:=current_structdef.owner; + while st.symtabletype in [objectsymtable,recordsymtable] do + st:=st.defowner.owner; + if st.symtabletype=staticsymtable then + begin + s:=make_mangledname('',tabstractrecorddef(current_objectdef.extendeddef).symtable,''); + list:=TFPObjectList(current_module.extendeddefs.Find(s)); + if not assigned(list) then + begin + list:=TFPObjectList.Create(false); + current_module.extendeddefs.Add(s, list); + end; + list.add(current_structdef); + end; + end; + tabstractrecordsymtable(current_objectdef.symtable).addalignmentpadding; + + { return defined objectdef } + result:=current_objectdef; + + { restore old state } + current_structdef:=old_current_structdef; + current_genericdef:=old_current_genericdef; + current_specializedef:=old_current_specializedef; + parse_generic:=old_parse_generic; + end; + +end. |