|
@@ -30,7 +30,7 @@ interface
|
|
|
globtype,symtype,symdef;
|
|
globtype,symtype,symdef;
|
|
|
|
|
|
|
|
{ parses a object declaration }
|
|
{ parses a object declaration }
|
|
|
- function object_dec(const n : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tdef;
|
|
|
|
|
|
|
+ function object_dec(const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tdef;
|
|
|
|
|
|
|
|
implementation
|
|
implementation
|
|
|
|
|
|
|
@@ -50,454 +50,431 @@ implementation
|
|
|
current_procinfo = 'error';
|
|
current_procinfo = 'error';
|
|
|
|
|
|
|
|
|
|
|
|
|
- function object_dec(const n : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tdef;
|
|
|
|
|
- { this function parses an object or class declaration }
|
|
|
|
|
|
|
+ function constructor_head:tprocdef;
|
|
|
var
|
|
var
|
|
|
- there_is_a_destructor : boolean;
|
|
|
|
|
- classtype : tobjecttyp;
|
|
|
|
|
- pcrd : tclassrefdef;
|
|
|
|
|
- hdef : tdef;
|
|
|
|
|
- old_object_option : tsymoptions;
|
|
|
|
|
- oldparse_only : boolean;
|
|
|
|
|
- storetypecanbeforward : boolean;
|
|
|
|
|
-
|
|
|
|
|
-
|
|
|
|
|
- function constructor_head:tprocdef;
|
|
|
|
|
- var
|
|
|
|
|
- pd : tprocdef;
|
|
|
|
|
- begin
|
|
|
|
|
- consume(_CONSTRUCTOR);
|
|
|
|
|
- { must be at same level as in implementation }
|
|
|
|
|
- parse_proc_head(current_objectdef,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_objectdef.objectoptions,oo_has_constructor);
|
|
|
|
|
- { Set return type, class constructors return the
|
|
|
|
|
- created instance, object constructors return boolean }
|
|
|
|
|
- if is_class(pd._class) then
|
|
|
|
|
- pd.returndef:=pd._class
|
|
|
|
|
- else
|
|
|
|
|
|
|
+ pd : tprocdef;
|
|
|
|
|
+ begin
|
|
|
|
|
+ result:=nil;
|
|
|
|
|
+ consume(_CONSTRUCTOR);
|
|
|
|
|
+ { must be at same level as in implementation }
|
|
|
|
|
+ parse_proc_head(current_objectdef,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_objectdef.objectoptions,oo_has_constructor);
|
|
|
|
|
+ { Set return type, class constructors return the
|
|
|
|
|
+ created instance, object constructors return boolean }
|
|
|
|
|
+ if is_class(pd._class) then
|
|
|
|
|
+ pd.returndef:=pd._class
|
|
|
|
|
+ else
|
|
|
{$ifdef CPU64bitaddr}
|
|
{$ifdef CPU64bitaddr}
|
|
|
- pd.returndef:=bool64type;
|
|
|
|
|
|
|
+ pd.returndef:=bool64type;
|
|
|
{$else CPU64bitaddr}
|
|
{$else CPU64bitaddr}
|
|
|
- pd.returndef:=bool32type;
|
|
|
|
|
|
|
+ pd.returndef:=bool32type;
|
|
|
{$endif CPU64bitaddr}
|
|
{$endif CPU64bitaddr}
|
|
|
- constructor_head:=pd;
|
|
|
|
|
- end;
|
|
|
|
|
-
|
|
|
|
|
|
|
+ result:=pd;
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
- procedure property_dec;
|
|
|
|
|
- var
|
|
|
|
|
- p : tpropertysym;
|
|
|
|
|
- begin
|
|
|
|
|
- { check for a class }
|
|
|
|
|
- if not((is_class_or_interface_or_dispinterface(current_objectdef)) or
|
|
|
|
|
- (not(m_tp7 in current_settings.modeswitches) and (is_object(current_objectdef)))) then
|
|
|
|
|
- Message(parser_e_syntax_error);
|
|
|
|
|
- consume(_PROPERTY);
|
|
|
|
|
- p:=read_property_dec(current_objectdef);
|
|
|
|
|
- consume(_SEMICOLON);
|
|
|
|
|
- if try_to_consume(_DEFAULT) then
|
|
|
|
|
- begin
|
|
|
|
|
- if oo_has_default_property in current_objectdef.objectoptions then
|
|
|
|
|
- message(parser_e_only_one_default_property);
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_default_property);
|
|
|
|
|
- include(p.propoptions,ppo_defaultproperty);
|
|
|
|
|
- if not(ppo_hasparameters in p.propoptions) then
|
|
|
|
|
- message(parser_e_property_need_paras);
|
|
|
|
|
- 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) do
|
|
|
|
|
- Consume(_SEMICOLON);
|
|
|
|
|
- end;
|
|
|
|
|
|
|
|
|
|
|
|
+ procedure property_dec;
|
|
|
|
|
+ var
|
|
|
|
|
+ p : tpropertysym;
|
|
|
|
|
+ begin
|
|
|
|
|
+ { check for a class }
|
|
|
|
|
+ if not((is_class_or_interface_or_dispinterface(current_objectdef)) or
|
|
|
|
|
+ (not(m_tp7 in current_settings.modeswitches) and (is_object(current_objectdef)))) then
|
|
|
|
|
+ Message(parser_e_syntax_error);
|
|
|
|
|
+ consume(_PROPERTY);
|
|
|
|
|
+ p:=read_property_dec(current_objectdef);
|
|
|
|
|
+ consume(_SEMICOLON);
|
|
|
|
|
+ if try_to_consume(_DEFAULT) then
|
|
|
|
|
+ begin
|
|
|
|
|
+ if oo_has_default_property in current_objectdef.objectoptions then
|
|
|
|
|
+ message(parser_e_only_one_default_property);
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_default_property);
|
|
|
|
|
+ include(p.propoptions,ppo_defaultproperty);
|
|
|
|
|
+ if not(ppo_hasparameters in p.propoptions) then
|
|
|
|
|
+ message(parser_e_property_need_paras);
|
|
|
|
|
+ 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) do
|
|
|
|
|
+ Consume(_SEMICOLON);
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
- function destructor_head:tprocdef;
|
|
|
|
|
- var
|
|
|
|
|
- pd : tprocdef;
|
|
|
|
|
- begin
|
|
|
|
|
- consume(_DESTRUCTOR);
|
|
|
|
|
- parse_proc_head(current_objectdef,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);
|
|
|
|
|
- if not(pd.maxparacount=0) and
|
|
|
|
|
- (m_fpc in current_settings.modeswitches) then
|
|
|
|
|
- Message(parser_e_no_paras_for_destructor);
|
|
|
|
|
- consume(_SEMICOLON);
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_destructor);
|
|
|
|
|
- { no return value }
|
|
|
|
|
- pd.returndef:=voidtype;
|
|
|
|
|
- destructor_head:=pd;
|
|
|
|
|
- end;
|
|
|
|
|
|
|
|
|
|
- procedure setclassattributes;
|
|
|
|
|
|
|
+ function destructor_head:tprocdef;
|
|
|
|
|
+ var
|
|
|
|
|
+ pd : tprocdef;
|
|
|
|
|
+ begin
|
|
|
|
|
+ result:=nil;
|
|
|
|
|
+ consume(_DESTRUCTOR);
|
|
|
|
|
+ parse_proc_head(current_objectdef,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);
|
|
|
|
|
+ if not(pd.maxparacount=0) and
|
|
|
|
|
+ (m_fpc in current_settings.modeswitches) then
|
|
|
|
|
+ Message(parser_e_no_paras_for_destructor);
|
|
|
|
|
+ consume(_SEMICOLON);
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_destructor);
|
|
|
|
|
+ { no return value }
|
|
|
|
|
+ pd.returndef:=voidtype;
|
|
|
|
|
+ result:=pd;
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
- begin
|
|
|
|
|
- { publishable }
|
|
|
|
|
- if classtype in [odt_interfacecom,odt_class] then
|
|
|
|
|
- begin
|
|
|
|
|
- current_objectdef.objecttype:=classtype;
|
|
|
|
|
- { set published flag in $M+ mode or it is inherited }
|
|
|
|
|
- if (cs_generate_rtti in current_settings.localswitches) or
|
|
|
|
|
- (assigned(current_objectdef.childof) and
|
|
|
|
|
- (oo_can_have_published in current_objectdef.childof.objectoptions)) then
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_can_have_published);
|
|
|
|
|
- { in "publishable" classes the default access type is published, this is
|
|
|
|
|
- done separate from above if-statement because the option can be
|
|
|
|
|
- inherited from the forward class definition }
|
|
|
|
|
- if (oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
- current_object_option:=[sp_published];
|
|
|
|
|
- end;
|
|
|
|
|
- end;
|
|
|
|
|
|
|
|
|
|
|
|
+ procedure setinterfacemethodoptions;
|
|
|
|
|
+ var
|
|
|
|
|
+ i : longint;
|
|
|
|
|
+ def : tdef;
|
|
|
|
|
+ begin
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_virtual);
|
|
|
|
|
+ for i:=0 to current_objectdef.symtable.DefList.count-1 do
|
|
|
|
|
+ begin
|
|
|
|
|
+ def:=tdef(current_objectdef.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 setinterfacemethodoptions;
|
|
|
|
|
|
|
|
|
|
- var
|
|
|
|
|
- i : longint;
|
|
|
|
|
- def : tdef;
|
|
|
|
|
- begin
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_virtual);
|
|
|
|
|
- for i:=0 to current_objectdef.symtable.DefList.count-1 do
|
|
|
|
|
|
|
+ function readobjecttype : tobjecttyp;
|
|
|
|
|
+ begin
|
|
|
|
|
+ result:=odt_none;
|
|
|
|
|
+ { distinguish classes and objects }
|
|
|
|
|
+ case token of
|
|
|
|
|
+ _OBJECT:
|
|
|
begin
|
|
begin
|
|
|
- def:=tdef(current_objectdef.symtable.DefList[i]);
|
|
|
|
|
- if assigned(def) and
|
|
|
|
|
- (def.typ=procdef) then
|
|
|
|
|
- begin
|
|
|
|
|
- include(tprocdef(def).procoptions,po_virtualmethod);
|
|
|
|
|
- tprocdef(def).forwarddef:=false;
|
|
|
|
|
- end;
|
|
|
|
|
|
|
+ result:=odt_object;
|
|
|
|
|
+ consume(_OBJECT)
|
|
|
end;
|
|
end;
|
|
|
- end;
|
|
|
|
|
-
|
|
|
|
|
- function readobjecttype : boolean;
|
|
|
|
|
-
|
|
|
|
|
- begin
|
|
|
|
|
- readobjecttype:=true;
|
|
|
|
|
- { distinguish classes and objects }
|
|
|
|
|
- case token of
|
|
|
|
|
- _OBJECT:
|
|
|
|
|
- begin
|
|
|
|
|
- classtype:=odt_object;
|
|
|
|
|
- consume(_OBJECT)
|
|
|
|
|
- end;
|
|
|
|
|
- _CPPCLASS:
|
|
|
|
|
- begin
|
|
|
|
|
- classtype:=odt_cppclass;
|
|
|
|
|
- consume(_CPPCLASS);
|
|
|
|
|
- end;
|
|
|
|
|
- _DISPINTERFACE:
|
|
|
|
|
- begin
|
|
|
|
|
- { need extra check here since interface is a keyword
|
|
|
|
|
- in all pascal modes }
|
|
|
|
|
- if not(m_class in current_settings.modeswitches) then
|
|
|
|
|
- Message(parser_f_need_objfpc_or_delphi_mode);
|
|
|
|
|
- classtype:=odt_dispinterface;
|
|
|
|
|
- consume(_DISPINTERFACE);
|
|
|
|
|
- { no forward declaration }
|
|
|
|
|
- if not(assigned(fd)) and (token=_SEMICOLON) then
|
|
|
|
|
- begin
|
|
|
|
|
- { also anonym objects aren't allow (o : object a : longint; end;) }
|
|
|
|
|
- if n='' then
|
|
|
|
|
- Message(parser_f_no_anonym_objects);
|
|
|
|
|
- current_objectdef:=tobjectdef.create(classtype,n,nil);
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
- object_dec:=current_objectdef;
|
|
|
|
|
- typecanbeforward:=storetypecanbeforward;
|
|
|
|
|
- readobjecttype:=false;
|
|
|
|
|
- exit;
|
|
|
|
|
- end;
|
|
|
|
|
- end;
|
|
|
|
|
- _INTERFACE:
|
|
|
|
|
- begin
|
|
|
|
|
- { need extra check here since interface is a keyword
|
|
|
|
|
- in all pascal modes }
|
|
|
|
|
- if not(m_class in current_settings.modeswitches) then
|
|
|
|
|
- Message(parser_f_need_objfpc_or_delphi_mode);
|
|
|
|
|
- if current_settings.interfacetype=it_interfacecom then
|
|
|
|
|
- classtype:=odt_interfacecom
|
|
|
|
|
- else {it_interfacecorba}
|
|
|
|
|
- classtype:=odt_interfacecorba;
|
|
|
|
|
- consume(_INTERFACE);
|
|
|
|
|
- { forward declaration }
|
|
|
|
|
- if not(assigned(fd)) and (token=_SEMICOLON) then
|
|
|
|
|
- begin
|
|
|
|
|
- { also anonym objects aren't allow (o : object a : longint; end;) }
|
|
|
|
|
- if n='' then
|
|
|
|
|
- Message(parser_f_no_anonym_objects);
|
|
|
|
|
- current_objectdef:=tobjectdef.create(classtype,n,nil);
|
|
|
|
|
- if (cs_compilesystem in current_settings.moduleswitches) and
|
|
|
|
|
- (classtype=odt_interfacecom) and (upper(n)='IUNKNOWN') then
|
|
|
|
|
- interface_iunknown:=current_objectdef;
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
- if (cs_generate_rtti in current_settings.localswitches) and
|
|
|
|
|
- (classtype=odt_interfacecom) then
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_can_have_published);
|
|
|
|
|
- object_dec:=current_objectdef;
|
|
|
|
|
- typecanbeforward:=storetypecanbeforward;
|
|
|
|
|
- readobjecttype:=false;
|
|
|
|
|
- exit;
|
|
|
|
|
- end;
|
|
|
|
|
- end;
|
|
|
|
|
- _CLASS:
|
|
|
|
|
- begin
|
|
|
|
|
- classtype:=odt_class;
|
|
|
|
|
- consume(_CLASS);
|
|
|
|
|
- if not(assigned(fd)) and
|
|
|
|
|
- (token=_OF) and
|
|
|
|
|
- { Delphi only allows class of in type blocks.
|
|
|
|
|
- Note that when parsing the type of a variable declaration
|
|
|
|
|
- the blocktype is bt_type so the check for typecanbeforward
|
|
|
|
|
- is also necessary (PFV) }
|
|
|
|
|
- (((block_type=bt_type) and typecanbeforward) or
|
|
|
|
|
- not(m_delphi in current_settings.modeswitches)) then
|
|
|
|
|
- begin
|
|
|
|
|
- { a hack, but it's easy to handle
|
|
|
|
|
- class reference type }
|
|
|
|
|
- consume(_OF);
|
|
|
|
|
- single_type(hdef,typecanbeforward);
|
|
|
|
|
-
|
|
|
|
|
- { accept hp1, if is a forward def or a class }
|
|
|
|
|
- if (hdef.typ=forwarddef) or
|
|
|
|
|
- is_class(hdef) then
|
|
|
|
|
- begin
|
|
|
|
|
- pcrd:=tclassrefdef.create(hdef);
|
|
|
|
|
- object_dec:=pcrd;
|
|
|
|
|
- end
|
|
|
|
|
- else
|
|
|
|
|
- begin
|
|
|
|
|
- object_dec:=generrordef;
|
|
|
|
|
- Message1(type_e_class_type_expected,generrordef.typename);
|
|
|
|
|
- end;
|
|
|
|
|
- typecanbeforward:=storetypecanbeforward;
|
|
|
|
|
- readobjecttype:=false;
|
|
|
|
|
- exit;
|
|
|
|
|
- end
|
|
|
|
|
- { forward class }
|
|
|
|
|
- else if not(assigned(fd)) and (token=_SEMICOLON) then
|
|
|
|
|
- begin
|
|
|
|
|
- { also anonym objects aren't allow (o : object a : longint; end;) }
|
|
|
|
|
- if n='' then
|
|
|
|
|
- Message(parser_f_no_anonym_objects);
|
|
|
|
|
- current_objectdef:=tobjectdef.create(odt_class,n,nil);
|
|
|
|
|
- if (cs_compilesystem in current_settings.moduleswitches) and (upper(n)='TOBJECT') then
|
|
|
|
|
- class_tobject:=current_objectdef;
|
|
|
|
|
- current_objectdef.objecttype:=odt_class;
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
- if (cs_generate_rtti in current_settings.localswitches) then
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_can_have_published);
|
|
|
|
|
- { all classes must have a vmt !! at offset zero }
|
|
|
|
|
- if not(oo_has_vmt in current_objectdef.objectoptions) then
|
|
|
|
|
- current_objectdef.insertvmt;
|
|
|
|
|
- object_dec:=current_objectdef;
|
|
|
|
|
- typecanbeforward:=storetypecanbeforward;
|
|
|
|
|
- readobjecttype:=false;
|
|
|
|
|
- exit;
|
|
|
|
|
- end;
|
|
|
|
|
- end;
|
|
|
|
|
- else
|
|
|
|
|
- begin
|
|
|
|
|
- classtype:=odt_class; { this is error but try to recover }
|
|
|
|
|
- consume(_OBJECT);
|
|
|
|
|
- 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 readImplementedInterfaces;
|
|
|
|
|
- var
|
|
|
|
|
- hdef : tdef;
|
|
|
|
|
- begin
|
|
|
|
|
- while try_to_consume(_COMMA) do
|
|
|
|
|
|
|
+ _CPPCLASS:
|
|
|
begin
|
|
begin
|
|
|
- id_type(hdef,false);
|
|
|
|
|
- if (hdef.typ<>objectdef) then
|
|
|
|
|
- begin
|
|
|
|
|
- Message1(type_e_interface_type_expected,hdef.typename);
|
|
|
|
|
- continue;
|
|
|
|
|
- end;
|
|
|
|
|
- handleImplementedInterface(tobjectdef(hdef));
|
|
|
|
|
|
|
+ result:=odt_cppclass;
|
|
|
|
|
+ consume(_CPPCLASS);
|
|
|
end;
|
|
end;
|
|
|
- end;
|
|
|
|
|
-
|
|
|
|
|
- procedure readinterfaceiid;
|
|
|
|
|
- var
|
|
|
|
|
- p : tnode;
|
|
|
|
|
- valid : boolean;
|
|
|
|
|
- begin
|
|
|
|
|
- p:=comp_expr(true);
|
|
|
|
|
- if p.nodetype=stringconstn then
|
|
|
|
|
|
|
+ _DISPINTERFACE:
|
|
|
begin
|
|
begin
|
|
|
- stringdispose(current_objectdef.iidstr);
|
|
|
|
|
- current_objectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? }
|
|
|
|
|
- p.free;
|
|
|
|
|
- valid:=string2guid(current_objectdef.iidstr^,current_objectdef.iidguid^);
|
|
|
|
|
- if (classtype in [odt_interfacecom,odt_dispinterface]) and not assigned(current_objectdef.iidguid) and not valid then
|
|
|
|
|
- Message(parser_e_improper_guid_syntax);
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_valid_guid);
|
|
|
|
|
- end
|
|
|
|
|
|
|
+ { need extra check here since interface is a keyword
|
|
|
|
|
+ in all pascal modes }
|
|
|
|
|
+ if not(m_class in current_settings.modeswitches) then
|
|
|
|
|
+ Message(parser_f_need_objfpc_or_delphi_mode);
|
|
|
|
|
+ result:=odt_dispinterface;
|
|
|
|
|
+ consume(_DISPINTERFACE);
|
|
|
|
|
+ end;
|
|
|
|
|
+ _INTERFACE:
|
|
|
|
|
+ begin
|
|
|
|
|
+ { need extra check here since interface is a keyword
|
|
|
|
|
+ in all pascal modes }
|
|
|
|
|
+ if not(m_class in current_settings.modeswitches) then
|
|
|
|
|
+ Message(parser_f_need_objfpc_or_delphi_mode);
|
|
|
|
|
+ if current_settings.interfacetype=it_interfacecom then
|
|
|
|
|
+ result:=odt_interfacecom
|
|
|
|
|
+ else {it_interfacecorba}
|
|
|
|
|
+ result:=odt_interfacecorba;
|
|
|
|
|
+ consume(_INTERFACE);
|
|
|
|
|
+ end;
|
|
|
|
|
+ _CLASS:
|
|
|
|
|
+ begin
|
|
|
|
|
+ result:=odt_class;
|
|
|
|
|
+ consume(_CLASS);
|
|
|
|
|
+ end;
|
|
|
else
|
|
else
|
|
|
begin
|
|
begin
|
|
|
- p.free;
|
|
|
|
|
- Message(parser_e_illegal_expression);
|
|
|
|
|
|
|
+ { this is error but try to recover }
|
|
|
|
|
+ result:=odt_class;
|
|
|
|
|
+ consume(_OBJECT);
|
|
|
end;
|
|
end;
|
|
|
end;
|
|
end;
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
|
|
|
|
|
- procedure readparentclasses;
|
|
|
|
|
- var
|
|
|
|
|
- intfchildof,
|
|
|
|
|
- childof : tobjectdef;
|
|
|
|
|
- hdef : tdef;
|
|
|
|
|
- hasparentdefined : boolean;
|
|
|
|
|
- begin
|
|
|
|
|
- childof:=nil;
|
|
|
|
|
- intfchildof:=nil;
|
|
|
|
|
- hasparentdefined:=false;
|
|
|
|
|
|
|
+ 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;
|
|
|
|
|
|
|
|
- { reads the parent class }
|
|
|
|
|
- if try_to_consume(_LKLAMMER) then
|
|
|
|
|
- begin
|
|
|
|
|
- { use single_type instead of id_type for specialize support }
|
|
|
|
|
- single_type(hdef,false);
|
|
|
|
|
- if (not assigned(hdef)) or
|
|
|
|
|
- (hdef.typ<>objectdef) then
|
|
|
|
|
- begin
|
|
|
|
|
- if assigned(hdef) then
|
|
|
|
|
- Message1(type_e_class_type_expected,hdef.typename);
|
|
|
|
|
- end
|
|
|
|
|
- else
|
|
|
|
|
- begin
|
|
|
|
|
- childof:=tobjectdef(hdef);
|
|
|
|
|
- { a mix of class, interfaces, objects and cppclasses
|
|
|
|
|
- isn't allowed }
|
|
|
|
|
- case classtype 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;
|
|
|
|
|
- odt_interfacecorba,
|
|
|
|
|
- odt_interfacecom:
|
|
|
|
|
|
|
+
|
|
|
|
|
+ procedure readImplementedInterfaces;
|
|
|
|
|
+ var
|
|
|
|
|
+ hdef : tdef;
|
|
|
|
|
+ begin
|
|
|
|
|
+ while try_to_consume(_COMMA) do
|
|
|
|
|
+ begin
|
|
|
|
|
+ id_type(hdef,false);
|
|
|
|
|
+ if (hdef.typ<>objectdef) then
|
|
|
|
|
+ begin
|
|
|
|
|
+ Message1(type_e_interface_type_expected,hdef.typename);
|
|
|
|
|
+ continue;
|
|
|
|
|
+ end;
|
|
|
|
|
+ handleImplementedInterface(tobjectdef(hdef));
|
|
|
|
|
+ end;
|
|
|
|
|
+ end;
|
|
|
|
|
+
|
|
|
|
|
+
|
|
|
|
|
+ procedure readinterfaceiid;
|
|
|
|
|
+ var
|
|
|
|
|
+ p : tnode;
|
|
|
|
|
+ valid : boolean;
|
|
|
|
|
+ begin
|
|
|
|
|
+ p:=comp_expr(true);
|
|
|
|
|
+ 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 assigned(current_objectdef.iidguid) and
|
|
|
|
|
+ not valid then
|
|
|
|
|
+ Message(parser_e_improper_guid_syntax);
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_valid_guid);
|
|
|
|
|
+ end
|
|
|
|
|
+ else
|
|
|
|
|
+ Message(parser_e_illegal_expression);
|
|
|
|
|
+ p.free;
|
|
|
|
|
+ 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 try_to_consume(_LKLAMMER) then
|
|
|
|
|
+ begin
|
|
|
|
|
+ { use single_type instead of id_type for specialize support }
|
|
|
|
|
+ single_type(hdef,false);
|
|
|
|
|
+ if (not assigned(hdef)) or
|
|
|
|
|
+ (hdef.typ<>objectdef) then
|
|
|
|
|
+ begin
|
|
|
|
|
+ if assigned(hdef) then
|
|
|
|
|
+ Message1(type_e_class_type_expected,hdef.typename);
|
|
|
|
|
+ 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
|
|
begin
|
|
|
- if not(is_interface(childof)) then
|
|
|
|
|
- Message(parser_e_mix_of_classes_and_objects);
|
|
|
|
|
- classtype:=childof.objecttype;
|
|
|
|
|
- current_objectdef.objecttype:=classtype;
|
|
|
|
|
|
|
+ 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;
|
|
end;
|
|
|
- odt_cppclass:
|
|
|
|
|
- if not(is_cppclass(childof)) then
|
|
|
|
|
- Message(parser_e_mix_of_classes_and_objects);
|
|
|
|
|
- odt_object:
|
|
|
|
|
- if not(is_object(childof)) then
|
|
|
|
|
|
|
+ odt_interfacecorba,
|
|
|
|
|
+ odt_interfacecom:
|
|
|
|
|
+ begin
|
|
|
|
|
+ if not(is_interface(childof)) then
|
|
|
Message(parser_e_mix_of_classes_and_objects);
|
|
Message(parser_e_mix_of_classes_and_objects);
|
|
|
- odt_dispinterface:
|
|
|
|
|
- Message(parser_e_dispinterface_cant_have_parent);
|
|
|
|
|
- end;
|
|
|
|
|
|
|
+ current_objectdef.objecttype:=childof.objecttype;
|
|
|
|
|
+ current_objectdef.objecttype:=current_objectdef.objecttype;
|
|
|
|
|
+ end;
|
|
|
|
|
+ odt_cppclass:
|
|
|
|
|
+ if not(is_cppclass(childof)) then
|
|
|
|
|
+ Message(parser_e_mix_of_classes_and_objects);
|
|
|
|
|
+ odt_object:
|
|
|
|
|
+ if not(is_object(childof)) then
|
|
|
|
|
+ Message(parser_e_mix_of_classes_and_objects);
|
|
|
|
|
+ odt_dispinterface:
|
|
|
|
|
+ Message(parser_e_dispinterface_cant_have_parent);
|
|
|
end;
|
|
end;
|
|
|
- hasparentdefined:=true;
|
|
|
|
|
- end;
|
|
|
|
|
|
|
+ end;
|
|
|
|
|
+ hasparentdefined:=true;
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
- { no generic as parents }
|
|
|
|
|
- if assigned(childof) and
|
|
|
|
|
- (df_generic in childof.defoptions) then
|
|
|
|
|
- begin
|
|
|
|
|
- Message(parser_e_no_generics_as_types);
|
|
|
|
|
- childof:=nil;
|
|
|
|
|
|
|
+ { no generic as parents }
|
|
|
|
|
+ if assigned(childof) and
|
|
|
|
|
+ (df_generic in childof.defoptions) then
|
|
|
|
|
+ begin
|
|
|
|
|
+ Message(parser_e_no_generics_as_types);
|
|
|
|
|
+ childof:=nil;
|
|
|
|
|
+ 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;
|
|
|
end;
|
|
end;
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
- { if no parent class, then a class get tobject as parent }
|
|
|
|
|
- if not assigned(childof) then
|
|
|
|
|
- begin
|
|
|
|
|
- case classtype of
|
|
|
|
|
- odt_class:
|
|
|
|
|
- if current_objectdef<>class_tobject then
|
|
|
|
|
- childof:=class_tobject;
|
|
|
|
|
- odt_interfacecom:
|
|
|
|
|
- if current_objectdef<>interface_iunknown then
|
|
|
|
|
- childof:=interface_iunknown;
|
|
|
|
|
|
|
+ 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 not(oo_is_forward in childof.objectoptions) then
|
|
|
|
|
+ current_objectdef.set_parent(childof)
|
|
|
|
|
+ else
|
|
|
|
|
+ Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^);
|
|
|
|
|
+ end;
|
|
|
|
|
+
|
|
|
|
|
+ { remove forward flag, is resolved }
|
|
|
|
|
+ exclude(current_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
+
|
|
|
|
|
+ if hasparentdefined then
|
|
|
|
|
+ begin
|
|
|
|
|
+ if current_objectdef.objecttype=odt_class then
|
|
|
|
|
+ begin
|
|
|
|
|
+ if assigned(intfchildof) then
|
|
|
|
|
+ handleImplementedInterface(intfchildof);
|
|
|
|
|
+ readImplementedInterfaces;
|
|
|
end;
|
|
end;
|
|
|
- end;
|
|
|
|
|
|
|
+ consume(_RKLAMMER);
|
|
|
|
|
+ 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 not(oo_is_forward in childof.objectoptions) then
|
|
|
|
|
- current_objectdef.set_parent(childof)
|
|
|
|
|
- else
|
|
|
|
|
- Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^);
|
|
|
|
|
- end;
|
|
|
|
|
|
|
|
|
|
- { remove forward flag, is resolved }
|
|
|
|
|
- exclude(current_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
|
|
+ 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;
|
|
|
|
|
|
|
|
- if hasparentdefined then
|
|
|
|
|
- begin
|
|
|
|
|
- if current_objectdef.objecttype=odt_class then
|
|
|
|
|
- begin
|
|
|
|
|
- if assigned(intfchildof) then
|
|
|
|
|
- handleImplementedInterface(intfchildof);
|
|
|
|
|
- readImplementedInterfaces;
|
|
|
|
|
- end;
|
|
|
|
|
- consume(_RKLAMMER);
|
|
|
|
|
|
|
+
|
|
|
|
|
+ function try_parse_class_forward_decl:boolean;
|
|
|
|
|
+ begin
|
|
|
|
|
+ result:=false;
|
|
|
|
|
+ if (token<>_SEMICOLON) then
|
|
|
|
|
+ exit;
|
|
|
|
|
+
|
|
|
|
|
+ if (cs_compilesystem in current_settings.moduleswitches) then
|
|
|
|
|
+ begin
|
|
|
|
|
+ case current_objectdef.objecttype of
|
|
|
|
|
+ odt_interfacecom :
|
|
|
|
|
+ if (current_objectdef.objname^='IUNKNOWN') then
|
|
|
|
|
+ interface_iunknown:=current_objectdef;
|
|
|
|
|
+ odt_class :
|
|
|
|
|
+ if (current_objectdef.objname^='TOBJECT') then
|
|
|
|
|
+ class_tobject:=current_objectdef;
|
|
|
end;
|
|
end;
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
- { read GUID }
|
|
|
|
|
- if (classtype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and
|
|
|
|
|
- try_to_consume(_LECKKLAMMER) then
|
|
|
|
|
- begin
|
|
|
|
|
- readinterfaceiid;
|
|
|
|
|
- consume(_RECKKLAMMER);
|
|
|
|
|
- end
|
|
|
|
|
- else if (classtype=odt_dispinterface) then
|
|
|
|
|
- message(parser_e_dispinterface_needs_a_guid);
|
|
|
|
|
- end;
|
|
|
|
|
|
|
+ { enable published? }
|
|
|
|
|
+ if (cs_generate_rtti in current_settings.localswitches) and
|
|
|
|
|
+ (current_objectdef.objecttype in [odt_interfacecom,odt_class]) then
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_can_have_published);
|
|
|
|
|
+
|
|
|
|
|
+ { all classes must have a vmt at offset zero }
|
|
|
|
|
+ if current_objectdef.objecttype=odt_class then
|
|
|
|
|
+ current_objectdef.insertvmt;
|
|
|
|
|
+
|
|
|
|
|
+ result:=true;
|
|
|
|
|
+ end;
|
|
|
|
|
+
|
|
|
|
|
+
|
|
|
|
|
+ function try_parse_class_reference:tdef;
|
|
|
|
|
+ var
|
|
|
|
|
+ hdef : tdef;
|
|
|
|
|
+ begin
|
|
|
|
|
+ result:=nil;
|
|
|
|
|
+ { Delphi only allows class of in type blocks.
|
|
|
|
|
+ Note that when parsing the type of a variable declaration
|
|
|
|
|
+ the blocktype is bt_type so the check for typecanbeforward
|
|
|
|
|
+ is also necessary (PFV) }
|
|
|
|
|
+ if (token<>_OF) or
|
|
|
|
|
+ (
|
|
|
|
|
+ (m_delphi in current_settings.modeswitches) and
|
|
|
|
|
+ not((block_type=bt_type) and typecanbeforward)
|
|
|
|
|
+ ) then
|
|
|
|
|
+ exit;
|
|
|
|
|
+
|
|
|
|
|
+ consume(_OF);
|
|
|
|
|
+ single_type(hdef,typecanbeforward);
|
|
|
|
|
+
|
|
|
|
|
+ { must be a forward def or a class }
|
|
|
|
|
+ if (hdef.typ=forwarddef) or
|
|
|
|
|
+ is_class(hdef) then
|
|
|
|
|
+ result:=tclassrefdef.create(hdef)
|
|
|
|
|
+ else
|
|
|
|
|
+ begin
|
|
|
|
|
+ Message1(type_e_class_type_expected,generrordef.typename);
|
|
|
|
|
+ result:=generrordef;
|
|
|
|
|
+ end;
|
|
|
|
|
+ end;
|
|
|
|
|
+
|
|
|
|
|
+
|
|
|
|
|
+ procedure insert_generic_parameter_types(genericdef:tstoreddef;genericlist:TFPObjectList);
|
|
|
|
|
+ var
|
|
|
|
|
+ i : longint;
|
|
|
|
|
+ generictype : ttypesym;
|
|
|
|
|
+ begin
|
|
|
|
|
+ current_objectdef.genericdef:=genericdef;
|
|
|
|
|
+ if not assigned(genericlist) then
|
|
|
|
|
+ exit;
|
|
|
|
|
+ for i:=0 to genericlist.count-1 do
|
|
|
|
|
+ begin
|
|
|
|
|
+ generictype:=ttypesym(genericlist[i]);
|
|
|
|
|
+ if generictype.typedef.typ=undefineddef then
|
|
|
|
|
+ include(current_objectdef.defoptions,df_generic)
|
|
|
|
|
+ else
|
|
|
|
|
+ include(current_objectdef.defoptions,df_specialization);
|
|
|
|
|
+ symtablestack.top.insert(generictype);
|
|
|
|
|
+ end;
|
|
|
|
|
+ end;
|
|
|
|
|
+
|
|
|
|
|
+
|
|
|
|
|
+ procedure parse_object_members;
|
|
|
|
|
|
|
|
procedure chkcpp(pd:tprocdef);
|
|
procedure chkcpp(pd:tprocdef);
|
|
|
begin
|
|
begin
|
|
@@ -508,351 +485,371 @@ implementation
|
|
|
end;
|
|
end;
|
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
|
|
+ procedure maybe_parse_hint_directives(pd:tprocdef);
|
|
|
|
|
+ var
|
|
|
|
|
+ dummysymoptions : tsymoptions;
|
|
|
|
|
+ begin
|
|
|
|
|
+ dummysymoptions:=[];
|
|
|
|
|
+ while try_consume_hintdirective(dummysymoptions) do
|
|
|
|
|
+ Consume(_SEMICOLON);
|
|
|
|
|
+ if assigned(pd) then
|
|
|
|
|
+ pd.symoptions:=pd.symoptions+dummysymoptions;
|
|
|
|
|
+ end;
|
|
|
|
|
+
|
|
|
var
|
|
var
|
|
|
pd : tprocdef;
|
|
pd : tprocdef;
|
|
|
- dummysymoptions : tsymoptions;
|
|
|
|
|
- i : longint;
|
|
|
|
|
- generictype : ttypesym;
|
|
|
|
|
- current_blocktype : tblock_type;
|
|
|
|
|
- oldcurrent_objectdef : tobjectdef;
|
|
|
|
|
|
|
+ has_destructor,
|
|
|
|
|
+ oldparse_only,
|
|
|
old_parse_generic : boolean;
|
|
old_parse_generic : boolean;
|
|
|
|
|
+ object_member_blocktype : tblock_type;
|
|
|
begin
|
|
begin
|
|
|
- old_object_option:=current_object_option;
|
|
|
|
|
- oldcurrent_objectdef:=current_objectdef;
|
|
|
|
|
- old_parse_generic:=parse_generic;
|
|
|
|
|
-
|
|
|
|
|
- { objects and class types can't be declared local }
|
|
|
|
|
- if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable]) and
|
|
|
|
|
- not assigned(genericlist) then
|
|
|
|
|
- Message(parser_e_no_local_objects);
|
|
|
|
|
-
|
|
|
|
|
- storetypecanbeforward:=typecanbeforward;
|
|
|
|
|
- { for tp7 don't allow forward types }
|
|
|
|
|
- if (m_tp7 in current_settings.modeswitches) then
|
|
|
|
|
- typecanbeforward:=false;
|
|
|
|
|
-
|
|
|
|
|
- if not(readobjecttype) then
|
|
|
|
|
- exit;
|
|
|
|
|
-
|
|
|
|
|
- if assigned(fd) then
|
|
|
|
|
- begin
|
|
|
|
|
- if fd.objecttype<>classtype then
|
|
|
|
|
- begin
|
|
|
|
|
- Message(parser_e_forward_mismatch);
|
|
|
|
|
- { recover }
|
|
|
|
|
- current_objectdef:=tobjectdef.create(classtype,n,nil);
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
- end
|
|
|
|
|
- else
|
|
|
|
|
- current_objectdef:=fd
|
|
|
|
|
- end
|
|
|
|
|
- else
|
|
|
|
|
- begin
|
|
|
|
|
- { anonym objects aren't allow (o : object a : longint; end;) }
|
|
|
|
|
- if n='' then
|
|
|
|
|
- Message(parser_f_no_anonym_objects);
|
|
|
|
|
- current_objectdef:=tobjectdef.create(classtype,n,nil);
|
|
|
|
|
- { include forward flag, it'll be removed after the parent class have been
|
|
|
|
|
- added. This is to prevent circular childof loops }
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
- end;
|
|
|
|
|
-
|
|
|
|
|
- { read list of parent classes }
|
|
|
|
|
- readparentclasses;
|
|
|
|
|
-
|
|
|
|
|
- { default access is public }
|
|
|
|
|
- there_is_a_destructor:=false;
|
|
|
|
|
- current_object_option:=[sp_public];
|
|
|
|
|
-
|
|
|
|
|
- { set class flags and inherits published }
|
|
|
|
|
- setclassattributes;
|
|
|
|
|
-
|
|
|
|
|
- symtablestack.push(current_objectdef.symtable);
|
|
|
|
|
- testcurobject:=1;
|
|
|
|
|
-
|
|
|
|
|
- { add generic type parameters }
|
|
|
|
|
- current_objectdef.genericdef:=genericdef;
|
|
|
|
|
- if assigned(genericlist) then
|
|
|
|
|
- begin
|
|
|
|
|
- for i:=0 to genericlist.count-1 do
|
|
|
|
|
- begin
|
|
|
|
|
- generictype:=ttypesym(genericlist[i]);
|
|
|
|
|
- if generictype.typedef.typ=undefineddef then
|
|
|
|
|
- begin
|
|
|
|
|
- include(current_objectdef.defoptions,df_generic);
|
|
|
|
|
- parse_generic:=true;
|
|
|
|
|
- end
|
|
|
|
|
- else
|
|
|
|
|
- include(current_objectdef.defoptions,df_specialization);
|
|
|
|
|
- symtablestack.top.insert(generictype);
|
|
|
|
|
- end;
|
|
|
|
|
- end;
|
|
|
|
|
-
|
|
|
|
|
- { short class declaration ? }
|
|
|
|
|
- if (classtype<>odt_class) or (token<>_SEMICOLON) then
|
|
|
|
|
- begin
|
|
|
|
|
- { Parse componenten }
|
|
|
|
|
- current_blocktype:=bt_general;
|
|
|
|
|
- repeat
|
|
|
|
|
- case token of
|
|
|
|
|
- _TYPE :
|
|
|
|
|
- begin
|
|
|
|
|
- if ([df_generic,df_specialization]*current_objectdef.defoptions)=[] then
|
|
|
|
|
- Message(parser_e_type_and_var_only_in_generics);
|
|
|
|
|
- consume(_TYPE);
|
|
|
|
|
- current_blocktype:=bt_type;
|
|
|
|
|
- end;
|
|
|
|
|
- _VAR :
|
|
|
|
|
- begin
|
|
|
|
|
- if ([df_generic,df_specialization]*current_objectdef.defoptions)=[] then
|
|
|
|
|
- Message(parser_e_type_and_var_only_in_generics);
|
|
|
|
|
- consume(_VAR);
|
|
|
|
|
- current_blocktype:=bt_general;
|
|
|
|
|
- end;
|
|
|
|
|
- _ID :
|
|
|
|
|
- begin
|
|
|
|
|
- case idtoken of
|
|
|
|
|
- _PRIVATE :
|
|
|
|
|
- begin
|
|
|
|
|
- if is_interface(current_objectdef) then
|
|
|
|
|
- Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
- consume(_PRIVATE);
|
|
|
|
|
- current_object_option:=[sp_private];
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_private);
|
|
|
|
|
- end;
|
|
|
|
|
- _PROTECTED :
|
|
|
|
|
- begin
|
|
|
|
|
- if is_interface(current_objectdef) then
|
|
|
|
|
- Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
- consume(_PROTECTED);
|
|
|
|
|
- current_object_option:=[sp_protected];
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_protected);
|
|
|
|
|
- end;
|
|
|
|
|
- _PUBLIC :
|
|
|
|
|
- begin
|
|
|
|
|
- if is_interface(current_objectdef) then
|
|
|
|
|
- Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
- consume(_PUBLIC);
|
|
|
|
|
- current_object_option:=[sp_public];
|
|
|
|
|
- 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_objectdef) then
|
|
|
|
|
- Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
- consume(_PUBLISHED);
|
|
|
|
|
- current_object_option:=[sp_published];
|
|
|
|
|
- end;
|
|
|
|
|
- _STRICT :
|
|
|
|
|
- begin
|
|
|
|
|
- if is_interface(current_objectdef) then
|
|
|
|
|
- Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
- consume(_STRICT);
|
|
|
|
|
- if token=_ID then
|
|
|
|
|
- begin
|
|
|
|
|
- case idtoken of
|
|
|
|
|
- _PRIVATE:
|
|
|
|
|
- begin
|
|
|
|
|
- consume(_PRIVATE);
|
|
|
|
|
- current_object_option:=[sp_strictprivate];
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_strictprivate);
|
|
|
|
|
- end;
|
|
|
|
|
- _PROTECTED:
|
|
|
|
|
- begin
|
|
|
|
|
- consume(_PROTECTED);
|
|
|
|
|
- current_object_option:=[sp_strictprotected];
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_strictprotected);
|
|
|
|
|
- end;
|
|
|
|
|
- else
|
|
|
|
|
- message(parser_e_protected_or_private_expected);
|
|
|
|
|
|
|
+ { empty class declaration ? }
|
|
|
|
|
+ if (current_objectdef.objecttype=odt_class) and
|
|
|
|
|
+ (token=_SEMICOLON) then
|
|
|
|
|
+ exit;
|
|
|
|
|
+
|
|
|
|
|
+ old_parse_generic:=parse_generic;
|
|
|
|
|
+
|
|
|
|
|
+ parse_generic:=(df_generic in current_objectdef.defoptions);
|
|
|
|
|
+ { in "publishable" classes the default access type is published }
|
|
|
|
|
+ if (oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
+ current_object_option:=[sp_published]
|
|
|
|
|
+ else
|
|
|
|
|
+ current_object_option:=[sp_public];
|
|
|
|
|
+ testcurobject:=1;
|
|
|
|
|
+ has_destructor:=false;
|
|
|
|
|
+ object_member_blocktype:=bt_general;
|
|
|
|
|
+ repeat
|
|
|
|
|
+ case token of
|
|
|
|
|
+ _TYPE :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if ([df_generic,df_specialization]*current_objectdef.defoptions)=[] then
|
|
|
|
|
+ Message(parser_e_type_and_var_only_in_generics);
|
|
|
|
|
+ consume(_TYPE);
|
|
|
|
|
+ object_member_blocktype:=bt_type;
|
|
|
|
|
+ end;
|
|
|
|
|
+ _VAR :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if ([df_generic,df_specialization]*current_objectdef.defoptions)=[] then
|
|
|
|
|
+ Message(parser_e_type_and_var_only_in_generics);
|
|
|
|
|
+ consume(_VAR);
|
|
|
|
|
+ object_member_blocktype:=bt_general;
|
|
|
|
|
+ end;
|
|
|
|
|
+ _ID :
|
|
|
|
|
+ begin
|
|
|
|
|
+ case idtoken of
|
|
|
|
|
+ _PRIVATE :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if is_interface(current_objectdef) then
|
|
|
|
|
+ Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
+ consume(_PRIVATE);
|
|
|
|
|
+ current_object_option:=[sp_private];
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_private);
|
|
|
|
|
+ end;
|
|
|
|
|
+ _PROTECTED :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if is_interface(current_objectdef) then
|
|
|
|
|
+ Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
+ consume(_PROTECTED);
|
|
|
|
|
+ current_object_option:=[sp_protected];
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_protected);
|
|
|
|
|
+ end;
|
|
|
|
|
+ _PUBLIC :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if is_interface(current_objectdef) then
|
|
|
|
|
+ Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
+ consume(_PUBLIC);
|
|
|
|
|
+ current_object_option:=[sp_public];
|
|
|
|
|
+ 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_objectdef) then
|
|
|
|
|
+ Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
+ consume(_PUBLISHED);
|
|
|
|
|
+ current_object_option:=[sp_published];
|
|
|
|
|
+ end;
|
|
|
|
|
+ _STRICT :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if is_interface(current_objectdef) then
|
|
|
|
|
+ Message(parser_e_no_access_specifier_in_interfaces);
|
|
|
|
|
+ consume(_STRICT);
|
|
|
|
|
+ if token=_ID then
|
|
|
|
|
+ begin
|
|
|
|
|
+ case idtoken of
|
|
|
|
|
+ _PRIVATE:
|
|
|
|
|
+ begin
|
|
|
|
|
+ consume(_PRIVATE);
|
|
|
|
|
+ current_object_option:=[sp_strictprivate];
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_strictprivate);
|
|
|
end;
|
|
end;
|
|
|
- end
|
|
|
|
|
- else
|
|
|
|
|
- message(parser_e_protected_or_private_expected);
|
|
|
|
|
- end;
|
|
|
|
|
|
|
+ _PROTECTED:
|
|
|
|
|
+ begin
|
|
|
|
|
+ consume(_PROTECTED);
|
|
|
|
|
+ current_object_option:=[sp_strictprotected];
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_strictprotected);
|
|
|
|
|
+ end;
|
|
|
|
|
+ else
|
|
|
|
|
+ message(parser_e_protected_or_private_expected);
|
|
|
|
|
+ end;
|
|
|
|
|
+ end
|
|
|
else
|
|
else
|
|
|
|
|
+ message(parser_e_protected_or_private_expected);
|
|
|
|
|
+ end;
|
|
|
|
|
+ else
|
|
|
|
|
+ begin
|
|
|
|
|
+ if object_member_blocktype=bt_general then
|
|
|
begin
|
|
begin
|
|
|
- if current_blocktype=bt_general then
|
|
|
|
|
- begin
|
|
|
|
|
- if is_interface(current_objectdef) then
|
|
|
|
|
- Message(parser_e_no_vars_in_interfaces);
|
|
|
|
|
-
|
|
|
|
|
- if (sp_published in current_object_option) and
|
|
|
|
|
- not(oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
- Message(parser_e_cant_have_published);
|
|
|
|
|
-
|
|
|
|
|
- read_record_fields([vd_object])
|
|
|
|
|
- end
|
|
|
|
|
- else
|
|
|
|
|
- types_dec;
|
|
|
|
|
- end;
|
|
|
|
|
- end;
|
|
|
|
|
- end;
|
|
|
|
|
- _PROPERTY :
|
|
|
|
|
- begin
|
|
|
|
|
- property_dec;
|
|
|
|
|
- end;
|
|
|
|
|
- _PROCEDURE,
|
|
|
|
|
- _FUNCTION,
|
|
|
|
|
- _CLASS :
|
|
|
|
|
- begin
|
|
|
|
|
- if (sp_published in current_object_option) and
|
|
|
|
|
- not(oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
- Message(parser_e_cant_have_published);
|
|
|
|
|
-
|
|
|
|
|
- oldparse_only:=parse_only;
|
|
|
|
|
- parse_only:=true;
|
|
|
|
|
- pd:=parse_proc_dec(current_objectdef);
|
|
|
|
|
-
|
|
|
|
|
- { 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);
|
|
|
|
|
-
|
|
|
|
|
- { 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);
|
|
|
|
|
-
|
|
|
|
|
- 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_objectdef.objectoptions,oo_has_msgint);
|
|
|
|
|
- if (po_msgstr in pd.procoptions) then
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_msgstr);
|
|
|
|
|
- if (po_virtualmethod in pd.procoptions) then
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_virtual);
|
|
|
|
|
|
|
+ if is_interface(current_objectdef) then
|
|
|
|
|
+ Message(parser_e_no_vars_in_interfaces);
|
|
|
|
|
|
|
|
- chkcpp(pd);
|
|
|
|
|
- end;
|
|
|
|
|
-
|
|
|
|
|
- { Support hint directives }
|
|
|
|
|
- dummysymoptions:=[];
|
|
|
|
|
- while try_consume_hintdirective(dummysymoptions) do
|
|
|
|
|
- Consume(_SEMICOLON);
|
|
|
|
|
- if assigned(pd) then
|
|
|
|
|
- pd.symoptions:=pd.symoptions+dummysymoptions;
|
|
|
|
|
|
|
+ if (sp_published in current_object_option) and
|
|
|
|
|
+ not(oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
+ Message(parser_e_cant_have_published);
|
|
|
|
|
|
|
|
- parse_only:=oldparse_only;
|
|
|
|
|
- end;
|
|
|
|
|
- _CONSTRUCTOR :
|
|
|
|
|
|
|
+ read_record_fields([vd_object])
|
|
|
|
|
+ end
|
|
|
|
|
+ else
|
|
|
|
|
+ types_dec;
|
|
|
|
|
+ end;
|
|
|
|
|
+ end;
|
|
|
|
|
+ end;
|
|
|
|
|
+ _PROPERTY :
|
|
|
|
|
+ begin
|
|
|
|
|
+ property_dec;
|
|
|
|
|
+ end;
|
|
|
|
|
+ _PROCEDURE,
|
|
|
|
|
+ _FUNCTION,
|
|
|
|
|
+ _CLASS :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if (sp_published in current_object_option) and
|
|
|
|
|
+ not(oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
+ Message(parser_e_cant_have_published);
|
|
|
|
|
+
|
|
|
|
|
+ oldparse_only:=parse_only;
|
|
|
|
|
+ parse_only:=true;
|
|
|
|
|
+ pd:=parse_proc_dec(current_objectdef);
|
|
|
|
|
+
|
|
|
|
|
+ { 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
|
|
begin
|
|
|
- if (sp_published in current_object_option) and
|
|
|
|
|
- not(oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
- Message(parser_e_cant_have_published);
|
|
|
|
|
-
|
|
|
|
|
- if not(sp_public in current_object_option) and
|
|
|
|
|
- not(sp_published in current_object_option) then
|
|
|
|
|
- Message(parser_w_constructor_should_be_public);
|
|
|
|
|
|
|
+ parse_object_proc_directives(pd);
|
|
|
|
|
|
|
|
- if is_interface(current_objectdef) then
|
|
|
|
|
- Message(parser_e_no_con_des_in_interfaces);
|
|
|
|
|
|
|
+ { 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);
|
|
|
|
|
|
|
|
- oldparse_only:=parse_only;
|
|
|
|
|
- parse_only:=true;
|
|
|
|
|
- pd:=constructor_head;
|
|
|
|
|
- parse_object_proc_directives(pd);
|
|
|
|
|
handle_calling_convention(pd);
|
|
handle_calling_convention(pd);
|
|
|
|
|
|
|
|
{ add definition to procsym }
|
|
{ add definition to procsym }
|
|
|
proc_add_definition(pd);
|
|
proc_add_definition(pd);
|
|
|
|
|
|
|
|
{ add procdef options to objectdef options }
|
|
{ add procdef options to objectdef options }
|
|
|
|
|
+ if (po_msgint in pd.procoptions) then
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_msgint);
|
|
|
|
|
+ if (po_msgstr in pd.procoptions) then
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_msgstr);
|
|
|
if (po_virtualmethod in pd.procoptions) then
|
|
if (po_virtualmethod in pd.procoptions) then
|
|
|
include(current_objectdef.objectoptions,oo_has_virtual);
|
|
include(current_objectdef.objectoptions,oo_has_virtual);
|
|
|
|
|
+
|
|
|
chkcpp(pd);
|
|
chkcpp(pd);
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
- { Support hint directives }
|
|
|
|
|
- dummysymoptions:=[];
|
|
|
|
|
- while try_consume_hintdirective(dummysymoptions) do
|
|
|
|
|
- Consume(_SEMICOLON);
|
|
|
|
|
- if assigned(pd) then
|
|
|
|
|
- pd.symoptions:=pd.symoptions+dummysymoptions;
|
|
|
|
|
|
|
+ maybe_parse_hint_directives(pd);
|
|
|
|
|
|
|
|
- parse_only:=oldparse_only;
|
|
|
|
|
- end;
|
|
|
|
|
- _DESTRUCTOR :
|
|
|
|
|
- begin
|
|
|
|
|
- if (sp_published in current_object_option) and
|
|
|
|
|
- not(oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
- Message(parser_e_cant_have_published);
|
|
|
|
|
|
|
+ parse_only:=oldparse_only;
|
|
|
|
|
+ end;
|
|
|
|
|
+ _CONSTRUCTOR :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if (sp_published in current_object_option) and
|
|
|
|
|
+ not(oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
+ Message(parser_e_cant_have_published);
|
|
|
|
|
|
|
|
- if there_is_a_destructor then
|
|
|
|
|
- Message(parser_n_only_one_destructor);
|
|
|
|
|
|
|
+ if not(sp_public in current_object_option) and
|
|
|
|
|
+ not(sp_published in current_object_option) then
|
|
|
|
|
+ Message(parser_w_constructor_should_be_public);
|
|
|
|
|
|
|
|
- if is_interface(current_objectdef) then
|
|
|
|
|
- Message(parser_e_no_con_des_in_interfaces);
|
|
|
|
|
|
|
+ if is_interface(current_objectdef) then
|
|
|
|
|
+ Message(parser_e_no_con_des_in_interfaces);
|
|
|
|
|
|
|
|
- if not(sp_public in current_object_option) then
|
|
|
|
|
- Message(parser_w_destructor_should_be_public);
|
|
|
|
|
|
|
+ oldparse_only:=parse_only;
|
|
|
|
|
+ parse_only:=true;
|
|
|
|
|
+ pd:=constructor_head;
|
|
|
|
|
+ parse_object_proc_directives(pd);
|
|
|
|
|
+ handle_calling_convention(pd);
|
|
|
|
|
|
|
|
- there_is_a_destructor:=true;
|
|
|
|
|
- oldparse_only:=parse_only;
|
|
|
|
|
- parse_only:=true;
|
|
|
|
|
- pd:=destructor_head;
|
|
|
|
|
- parse_object_proc_directives(pd);
|
|
|
|
|
- handle_calling_convention(pd);
|
|
|
|
|
|
|
+ { add definition to procsym }
|
|
|
|
|
+ proc_add_definition(pd);
|
|
|
|
|
|
|
|
- { add definition to procsym }
|
|
|
|
|
- proc_add_definition(pd);
|
|
|
|
|
|
|
+ { add procdef options to objectdef options }
|
|
|
|
|
+ if (po_virtualmethod in pd.procoptions) then
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_has_virtual);
|
|
|
|
|
+ chkcpp(pd);
|
|
|
|
|
+ maybe_parse_hint_directives(pd);
|
|
|
|
|
|
|
|
- { add procdef options to objectdef options }
|
|
|
|
|
- if (po_virtualmethod in pd.procoptions) then
|
|
|
|
|
- include(current_objectdef.objectoptions,oo_has_virtual);
|
|
|
|
|
|
|
+ parse_only:=oldparse_only;
|
|
|
|
|
+ end;
|
|
|
|
|
+ _DESTRUCTOR :
|
|
|
|
|
+ begin
|
|
|
|
|
+ if (sp_published in current_object_option) and
|
|
|
|
|
+ not(oo_can_have_published in current_objectdef.objectoptions) then
|
|
|
|
|
+ Message(parser_e_cant_have_published);
|
|
|
|
|
|
|
|
- chkcpp(pd);
|
|
|
|
|
|
|
+ if has_destructor then
|
|
|
|
|
+ Message(parser_n_only_one_destructor);
|
|
|
|
|
+ has_destructor:=true;
|
|
|
|
|
|
|
|
- { Support hint directives }
|
|
|
|
|
- dummysymoptions:=[];
|
|
|
|
|
- while try_consume_hintdirective(dummysymoptions) do
|
|
|
|
|
- Consume(_SEMICOLON);
|
|
|
|
|
- if assigned(pd) then
|
|
|
|
|
- pd.symoptions:=pd.symoptions+dummysymoptions;
|
|
|
|
|
|
|
+ if is_interface(current_objectdef) then
|
|
|
|
|
+ Message(parser_e_no_con_des_in_interfaces);
|
|
|
|
|
|
|
|
- parse_only:=oldparse_only;
|
|
|
|
|
- end;
|
|
|
|
|
- _END :
|
|
|
|
|
- begin
|
|
|
|
|
- consume(_END);
|
|
|
|
|
- break;
|
|
|
|
|
- end;
|
|
|
|
|
- else
|
|
|
|
|
- consume(_ID); { Give a ident expected message, like tp7 }
|
|
|
|
|
|
|
+ if not(sp_public in current_object_option) then
|
|
|
|
|
+ Message(parser_w_destructor_should_be_public);
|
|
|
|
|
+
|
|
|
|
|
+ oldparse_only:=parse_only;
|
|
|
|
|
+ parse_only:=true;
|
|
|
|
|
+ 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_objectdef.objectoptions,oo_has_virtual);
|
|
|
|
|
+
|
|
|
|
|
+ chkcpp(pd);
|
|
|
|
|
+ maybe_parse_hint_directives(pd);
|
|
|
|
|
+
|
|
|
|
|
+ parse_only:=oldparse_only;
|
|
|
|
|
+ end;
|
|
|
|
|
+ _END :
|
|
|
|
|
+ begin
|
|
|
|
|
+ consume(_END);
|
|
|
|
|
+ break;
|
|
|
end;
|
|
end;
|
|
|
- until false;
|
|
|
|
|
|
|
+ else
|
|
|
|
|
+ consume(_ID); { Give a ident expected message, like tp7 }
|
|
|
end;
|
|
end;
|
|
|
|
|
+ until false;
|
|
|
|
|
+
|
|
|
|
|
+ { restore }
|
|
|
|
|
+ testcurobject:=0;
|
|
|
|
|
+ parse_generic:=old_parse_generic;
|
|
|
|
|
+ end;
|
|
|
|
|
+
|
|
|
|
|
|
|
|
- { generate vmt space if needed }
|
|
|
|
|
- if not(oo_has_vmt in current_objectdef.objectoptions) and
|
|
|
|
|
- (([oo_has_virtual,oo_has_constructor,oo_has_destructor]*current_objectdef.objectoptions<>[]) or
|
|
|
|
|
- (classtype in [odt_class])
|
|
|
|
|
- ) then
|
|
|
|
|
- current_objectdef.insertvmt;
|
|
|
|
|
|
|
+ function object_dec(const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tdef;
|
|
|
|
|
+ label
|
|
|
|
|
+ myexit;
|
|
|
|
|
+ var
|
|
|
|
|
+ objecttype : tobjecttyp;
|
|
|
|
|
+ old_object_option : tsymoptions;
|
|
|
|
|
+ old_typecanbeforward : boolean;
|
|
|
|
|
+ old_current_objectdef : tobjectdef;
|
|
|
|
|
+ begin
|
|
|
|
|
+ old_object_option:=current_object_option;
|
|
|
|
|
+ old_current_objectdef:=current_objectdef;
|
|
|
|
|
+ old_typecanbeforward:=typecanbeforward;
|
|
|
|
|
+
|
|
|
|
|
+ current_objectdef:=nil;
|
|
|
|
|
|
|
|
- if is_interface(current_objectdef) then
|
|
|
|
|
- setinterfacemethodoptions;
|
|
|
|
|
|
|
+ { objects and class types can't be declared local }
|
|
|
|
|
+ if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable]) and
|
|
|
|
|
+ not assigned(genericlist) then
|
|
|
|
|
+ Message(parser_e_no_local_objects);
|
|
|
|
|
|
|
|
- { remove symtable from stack }
|
|
|
|
|
- symtablestack.pop(current_objectdef.symtable);
|
|
|
|
|
|
|
+ { for tp7 don't allow forward types }
|
|
|
|
|
+ if (m_tp7 in current_settings.modeswitches) then
|
|
|
|
|
+ typecanbeforward:=false;
|
|
|
|
|
|
|
|
- { return defined objectdef }
|
|
|
|
|
- result:=current_objectdef;
|
|
|
|
|
|
|
+ { get type of objectdef }
|
|
|
|
|
+ objecttype:=readobjecttype;
|
|
|
|
|
+
|
|
|
|
|
+ { reuse forward objectdef? }
|
|
|
|
|
+ if assigned(fd) then
|
|
|
|
|
+ begin
|
|
|
|
|
+ if fd.objecttype<>objecttype then
|
|
|
|
|
+ begin
|
|
|
|
|
+ Message(parser_e_forward_mismatch);
|
|
|
|
|
+ { recover }
|
|
|
|
|
+ current_objectdef:=tobjectdef.create(current_objectdef.objecttype,n,nil);
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
+ end
|
|
|
|
|
+ else
|
|
|
|
|
+ current_objectdef:=fd
|
|
|
|
|
+ end
|
|
|
|
|
+ else
|
|
|
|
|
+ begin
|
|
|
|
|
+ { Handle class of ... class references }
|
|
|
|
|
+ if objecttype=odt_class then
|
|
|
|
|
+ begin
|
|
|
|
|
+ result:=try_parse_class_reference;
|
|
|
|
|
+ if assigned(result) then
|
|
|
|
|
+ goto myexit;
|
|
|
|
|
+ end;
|
|
|
|
|
+
|
|
|
|
|
+ { anonym objects aren't allow (o : object a : longint; end;) }
|
|
|
|
|
+ if n='' then
|
|
|
|
|
+ Message(parser_f_no_anonym_objects);
|
|
|
|
|
+
|
|
|
|
|
+ { create new class }
|
|
|
|
|
+ current_objectdef:=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_objectdef.objectoptions,oo_is_forward);
|
|
|
|
|
+
|
|
|
|
|
+ { is this a forward declaration? }
|
|
|
|
|
+ if try_parse_class_forward_decl then
|
|
|
|
|
+ begin
|
|
|
|
|
+ result:=current_objectdef;
|
|
|
|
|
+ goto myexit;
|
|
|
|
|
+ end;
|
|
|
|
|
+ end;
|
|
|
|
|
|
|
|
- { restore old state }
|
|
|
|
|
- current_objectdef:=oldcurrent_objectdef;
|
|
|
|
|
- testcurobject:=0;
|
|
|
|
|
- typecanbeforward:=storetypecanbeforward;
|
|
|
|
|
- parse_generic:=old_parse_generic;
|
|
|
|
|
- current_object_option:=old_object_option;
|
|
|
|
|
|
|
+ { 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) then
|
|
|
|
|
+ include(current_objectdef.objectoptions,oo_can_have_published);
|
|
|
|
|
+
|
|
|
|
|
+ { parse list of parent classes }
|
|
|
|
|
+ parse_parent_classes;
|
|
|
|
|
+
|
|
|
|
|
+ { parse optional GUID for interfaces }
|
|
|
|
|
+ parse_guid;
|
|
|
|
|
+
|
|
|
|
|
+ { parse and insert object members }
|
|
|
|
|
+ symtablestack.push(current_objectdef.symtable);
|
|
|
|
|
+ insert_generic_parameter_types(genericdef,genericlist);
|
|
|
|
|
+ parse_object_members;
|
|
|
|
|
+ symtablestack.pop(current_objectdef.symtable);
|
|
|
|
|
+
|
|
|
|
|
+ { generate vmt space if needed }
|
|
|
|
|
+ if not(oo_has_vmt in current_objectdef.objectoptions) and
|
|
|
|
|
+ (
|
|
|
|
|
+ ([oo_has_virtual,oo_has_constructor,oo_has_destructor]*current_objectdef.objectoptions<>[]) or
|
|
|
|
|
+ (current_objectdef.objecttype in [odt_class])
|
|
|
|
|
+ ) then
|
|
|
|
|
+ current_objectdef.insertvmt;
|
|
|
|
|
+
|
|
|
|
|
+ if is_interface(current_objectdef) then
|
|
|
|
|
+ setinterfacemethodoptions;
|
|
|
|
|
+
|
|
|
|
|
+ { return defined objectdef }
|
|
|
|
|
+ result:=current_objectdef;
|
|
|
|
|
+
|
|
|
|
|
+ myexit:
|
|
|
|
|
+ { restore old state }
|
|
|
|
|
+ current_objectdef:=old_current_objectdef;
|
|
|
|
|
+ typecanbeforward:=old_typecanbeforward;
|
|
|
|
|
+ current_object_option:=old_object_option;
|
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
end.
|
|
end.
|
peter