mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-07 19:18:27 +02:00
* refactor, no functional changes
git-svn-id: trunk@12030 -
This commit is contained in:
peter
parent
ca48c2f34c
commit
da13c20f59
@ -30,7 +30,7 @@ interface
|
||||
globtype,symtype,symdef;
|
||||
|
||||
{ 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
|
||||
|
||||
@ -50,22 +50,11 @@ implementation
|
||||
current_procinfo = 'error';
|
||||
|
||||
|
||||
function object_dec(const n : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tdef;
|
||||
{ this function parses an object or class declaration }
|
||||
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
|
||||
result:=nil;
|
||||
consume(_CONSTRUCTOR);
|
||||
{ must be at same level as in implementation }
|
||||
parse_proc_head(current_objectdef,potype_constructor,pd);
|
||||
@ -89,7 +78,7 @@ implementation
|
||||
{$else CPU64bitaddr}
|
||||
pd.returndef:=bool32type;
|
||||
{$endif CPU64bitaddr}
|
||||
constructor_head:=pd;
|
||||
result:=pd;
|
||||
end;
|
||||
|
||||
|
||||
@ -125,6 +114,7 @@ implementation
|
||||
var
|
||||
pd : tprocdef;
|
||||
begin
|
||||
result:=nil;
|
||||
consume(_DESTRUCTOR);
|
||||
parse_proc_head(current_objectdef,potype_destructor,pd);
|
||||
if not assigned(pd) then
|
||||
@ -142,32 +132,11 @@ implementation
|
||||
include(current_objectdef.objectoptions,oo_has_destructor);
|
||||
{ no return value }
|
||||
pd.returndef:=voidtype;
|
||||
destructor_head:=pd;
|
||||
end;
|
||||
|
||||
procedure setclassattributes;
|
||||
|
||||
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;
|
||||
result:=pd;
|
||||
end;
|
||||
|
||||
|
||||
procedure setinterfacemethodoptions;
|
||||
|
||||
var
|
||||
i : longint;
|
||||
def : tdef;
|
||||
@ -185,20 +154,20 @@ implementation
|
||||
end;
|
||||
end;
|
||||
|
||||
function readobjecttype : boolean;
|
||||
|
||||
function readobjecttype : tobjecttyp;
|
||||
begin
|
||||
readobjecttype:=true;
|
||||
result:=odt_none;
|
||||
{ distinguish classes and objects }
|
||||
case token of
|
||||
_OBJECT:
|
||||
begin
|
||||
classtype:=odt_object;
|
||||
result:=odt_object;
|
||||
consume(_OBJECT)
|
||||
end;
|
||||
_CPPCLASS:
|
||||
begin
|
||||
classtype:=odt_cppclass;
|
||||
result:=odt_cppclass;
|
||||
consume(_CPPCLASS);
|
||||
end;
|
||||
_DISPINTERFACE:
|
||||
@ -207,21 +176,8 @@ implementation
|
||||
in all pascal modes }
|
||||
if not(m_class in current_settings.modeswitches) then
|
||||
Message(parser_f_need_objfpc_or_delphi_mode);
|
||||
classtype:=odt_dispinterface;
|
||||
result:=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
|
||||
@ -230,96 +186,27 @@ implementation
|
||||
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
|
||||
result:=odt_interfacecom
|
||||
else {it_interfacecorba}
|
||||
classtype:=odt_interfacecorba;
|
||||
result:=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;
|
||||
result:=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 }
|
||||
{ this is error but try to recover }
|
||||
result:=odt_class;
|
||||
consume(_OBJECT);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure handleImplementedInterface(intfdef : tobjectdef);
|
||||
|
||||
procedure handleImplementedInterface(intfdef : tobjectdef);
|
||||
begin
|
||||
if not is_interface(intfdef) then
|
||||
begin
|
||||
@ -338,6 +225,7 @@ implementation
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure readImplementedInterfaces;
|
||||
var
|
||||
hdef : tdef;
|
||||
@ -354,6 +242,7 @@ implementation
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure readinterfaceiid;
|
||||
var
|
||||
p : tnode;
|
||||
@ -363,22 +252,21 @@ implementation
|
||||
if p.nodetype=stringconstn then
|
||||
begin
|
||||
stringdispose(current_objectdef.iidstr);
|
||||
current_objectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? }
|
||||
p.free;
|
||||
current_objectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str));
|
||||
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
|
||||
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
|
||||
begin
|
||||
p.free;
|
||||
Message(parser_e_illegal_expression);
|
||||
end;
|
||||
p.free;
|
||||
end;
|
||||
|
||||
|
||||
procedure readparentclasses;
|
||||
procedure parse_parent_classes;
|
||||
var
|
||||
intfchildof,
|
||||
childof : tobjectdef;
|
||||
@ -405,7 +293,7 @@ implementation
|
||||
childof:=tobjectdef(hdef);
|
||||
{ a mix of class, interfaces, objects and cppclasses
|
||||
isn't allowed }
|
||||
case classtype of
|
||||
case current_objectdef.objecttype of
|
||||
odt_class:
|
||||
if not(is_class(childof)) then
|
||||
begin
|
||||
@ -425,8 +313,8 @@ implementation
|
||||
begin
|
||||
if not(is_interface(childof)) then
|
||||
Message(parser_e_mix_of_classes_and_objects);
|
||||
classtype:=childof.objecttype;
|
||||
current_objectdef.objecttype:=classtype;
|
||||
current_objectdef.objecttype:=childof.objecttype;
|
||||
current_objectdef.objecttype:=current_objectdef.objecttype;
|
||||
end;
|
||||
odt_cppclass:
|
||||
if not(is_cppclass(childof)) then
|
||||
@ -452,7 +340,7 @@ implementation
|
||||
{ if no parent class, then a class get tobject as parent }
|
||||
if not assigned(childof) then
|
||||
begin
|
||||
case classtype of
|
||||
case current_objectdef.objecttype of
|
||||
odt_class:
|
||||
if current_objectdef<>class_tobject then
|
||||
childof:=class_tobject;
|
||||
@ -487,18 +375,107 @@ implementation
|
||||
end;
|
||||
consume(_RKLAMMER);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure parse_guid;
|
||||
begin
|
||||
{ read GUID }
|
||||
if (classtype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and
|
||||
if (current_objectdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and
|
||||
try_to_consume(_LECKKLAMMER) then
|
||||
begin
|
||||
readinterfaceiid;
|
||||
consume(_RECKKLAMMER);
|
||||
end
|
||||
else if (classtype=odt_dispinterface) then
|
||||
else if (current_objectdef.objecttype=odt_dispinterface) then
|
||||
message(parser_e_dispinterface_needs_a_guid);
|
||||
end;
|
||||
|
||||
|
||||
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;
|
||||
|
||||
{ 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);
|
||||
begin
|
||||
if is_cppclass(pd._class) then
|
||||
@ -508,91 +485,40 @@ implementation
|
||||
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
|
||||
pd : tprocdef;
|
||||
dummysymoptions : tsymoptions;
|
||||
i : longint;
|
||||
generictype : ttypesym;
|
||||
current_blocktype : tblock_type;
|
||||
oldcurrent_objectdef : tobjectdef;
|
||||
has_destructor,
|
||||
oldparse_only,
|
||||
old_parse_generic : boolean;
|
||||
object_member_blocktype : tblock_type;
|
||||
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
|
||||
{ empty class declaration ? }
|
||||
if (current_objectdef.objecttype=odt_class) and
|
||||
(token=_SEMICOLON) 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;
|
||||
old_parse_generic:=parse_generic;
|
||||
|
||||
{ read list of parent classes }
|
||||
readparentclasses;
|
||||
|
||||
{ default access is public }
|
||||
there_is_a_destructor:=false;
|
||||
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];
|
||||
|
||||
{ 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;
|
||||
has_destructor:=false;
|
||||
object_member_blocktype:=bt_general;
|
||||
repeat
|
||||
case token of
|
||||
_TYPE :
|
||||
@ -600,14 +526,14 @@ implementation
|
||||
if ([df_generic,df_specialization]*current_objectdef.defoptions)=[] then
|
||||
Message(parser_e_type_and_var_only_in_generics);
|
||||
consume(_TYPE);
|
||||
current_blocktype:=bt_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);
|
||||
current_blocktype:=bt_general;
|
||||
object_member_blocktype:=bt_general;
|
||||
end;
|
||||
_ID :
|
||||
begin
|
||||
@ -674,7 +600,7 @@ implementation
|
||||
end;
|
||||
else
|
||||
begin
|
||||
if current_blocktype=bt_general then
|
||||
if object_member_blocktype=bt_general then
|
||||
begin
|
||||
if is_interface(current_objectdef) then
|
||||
Message(parser_e_no_vars_in_interfaces);
|
||||
@ -735,12 +661,7 @@ implementation
|
||||
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;
|
||||
@ -770,13 +691,7 @@ implementation
|
||||
if (po_virtualmethod in pd.procoptions) then
|
||||
include(current_objectdef.objectoptions,oo_has_virtual);
|
||||
chkcpp(pd);
|
||||
|
||||
{ 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;
|
||||
@ -786,8 +701,9 @@ implementation
|
||||
not(oo_can_have_published in current_objectdef.objectoptions) then
|
||||
Message(parser_e_cant_have_published);
|
||||
|
||||
if there_is_a_destructor then
|
||||
if has_destructor then
|
||||
Message(parser_n_only_one_destructor);
|
||||
has_destructor:=true;
|
||||
|
||||
if is_interface(current_objectdef) then
|
||||
Message(parser_e_no_con_des_in_interfaces);
|
||||
@ -795,7 +711,6 @@ implementation
|
||||
if not(sp_public in current_object_option) then
|
||||
Message(parser_w_destructor_should_be_public);
|
||||
|
||||
there_is_a_destructor:=true;
|
||||
oldparse_only:=parse_only;
|
||||
parse_only:=true;
|
||||
pd:=destructor_head;
|
||||
@ -810,13 +725,7 @@ implementation
|
||||
include(current_objectdef.objectoptions,oo_has_virtual);
|
||||
|
||||
chkcpp(pd);
|
||||
|
||||
{ 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;
|
||||
@ -829,29 +738,117 @@ implementation
|
||||
consume(_ID); { Give a ident expected message, like tp7 }
|
||||
end;
|
||||
until false;
|
||||
|
||||
{ restore }
|
||||
testcurobject:=0;
|
||||
parse_generic:=old_parse_generic;
|
||||
end;
|
||||
|
||||
|
||||
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;
|
||||
|
||||
{ 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);
|
||||
|
||||
{ for tp7 don't allow forward types }
|
||||
if (m_tp7 in current_settings.modeswitches) then
|
||||
typecanbeforward:=false;
|
||||
|
||||
{ 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;
|
||||
|
||||
{ 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
|
||||
(classtype in [odt_class])
|
||||
(
|
||||
([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;
|
||||
|
||||
{ remove symtable from stack }
|
||||
symtablestack.pop(current_objectdef.symtable);
|
||||
|
||||
{ return defined objectdef }
|
||||
result:=current_objectdef;
|
||||
|
||||
myexit:
|
||||
{ restore old state }
|
||||
current_objectdef:=oldcurrent_objectdef;
|
||||
testcurobject:=0;
|
||||
typecanbeforward:=storetypecanbeforward;
|
||||
parse_generic:=old_parse_generic;
|
||||
current_objectdef:=old_current_objectdef;
|
||||
typecanbeforward:=old_typecanbeforward;
|
||||
current_object_option:=old_object_option;
|
||||
end;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user