paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-20 11:09:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* refactor reading and setting of parent classes

Browse Source 
git-svn-id: trunk@1992 -
This commit is contained in:
peter 2005-12-19 12:24:45 +00:00
parent 06c0066c65
commit 767291ca5f
6 changed files with 278 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -5910,6 +5910,8 @@ tests/webtbf/tw4256.pp svneol=native#text/plain
tests/webtbf/tw4359.pp svneol=native#text/plain tests/webtbf/tw4359.pp svneol=native#text/plain
tests/webtbf/tw4445.pp svneol=native#text/plain tests/webtbf/tw4445.pp svneol=native#text/plain
tests/webtbf/tw4529.pp svneol=native#text/plain tests/webtbf/tw4529.pp svneol=native#text/plain
tests/webtbf/tw4569a.pp svneol=native#text/plain
tests/webtbf/tw4569b.pp svneol=native#text/plain
tests/webtbf/uw0744.pp svneol=native#text/plain tests/webtbf/uw0744.pp svneol=native#text/plain
tests/webtbf/uw0840a.pp svneol=native#text/plain tests/webtbf/uw0840a.pp svneol=native#text/plain
tests/webtbf/uw0840b.pp svneol=native#text/plain tests/webtbf/uw0840b.pp svneol=native#text/plain

292
compiler/pdecobj.pas
View File

@ -54,8 +54,7 @@ implementation
var var
there_is_a_destructor : boolean; there_is_a_destructor : boolean;
classtype : tobjectdeftype; classtype : tobjectdeftype;
childof : tobjectdef; // childof : tobjectdef;
aktclass : tobjectdef;
function constructor_head:tprocdef; function constructor_head:tprocdef;
var var
@ -63,7 +62,7 @@ implementation
begin begin
consume(_CONSTRUCTOR); consume(_CONSTRUCTOR);
{ must be at same level as in implementation } { must be at same level as in implementation }
parse_proc_head(aktclass,potype_constructor,pd); parse_proc_head(aktobjectdef,potype_constructor,pd);
if not assigned(pd) then if not assigned(pd) then
begin begin
consume(_SEMICOLON); consume(_SEMICOLON);
@ -73,7 +72,7 @@ implementation
(pd.procsym.name<>'INIT') then (pd.procsym.name<>'INIT') then
Message(parser_e_constructorname_must_be_init); Message(parser_e_constructorname_must_be_init);
consume(_SEMICOLON); consume(_SEMICOLON);
include(aktclass.objectoptions,oo_has_constructor); include(aktobjectdef.objectoptions,oo_has_constructor);
{ Set return type, class constructors return the { Set return type, class constructors return the
created instance, object constructors return boolean } created instance, object constructors return boolean }
if is_class(pd._class) then if is_class(pd._class) then
@ -89,17 +88,17 @@ implementation
p : tpropertysym; p : tpropertysym;
begin begin
{ check for a class } { check for a class }
if not((is_class_or_interface(aktclass)) or if not((is_class_or_interface(aktobjectdef)) or
(not(m_tp7 in aktmodeswitches) and (is_object(aktclass)))) then (not(m_tp7 in aktmodeswitches) and (is_object(aktobjectdef)))) then
Message(parser_e_syntax_error); Message(parser_e_syntax_error);
consume(_PROPERTY); consume(_PROPERTY);
p:=read_property_dec(aktclass); p:=read_property_dec(aktobjectdef);
consume(_SEMICOLON); consume(_SEMICOLON);
if try_to_consume(_DEFAULT) then if try_to_consume(_DEFAULT) then
begin begin
if oo_has_default_property in aktclass.objectoptions then if oo_has_default_property in aktobjectdef.objectoptions then
message(parser_e_only_one_default_property); message(parser_e_only_one_default_property);
include(aktclass.objectoptions,oo_has_default_property); include(aktobjectdef.objectoptions,oo_has_default_property);
include(p.propoptions,ppo_defaultproperty); include(p.propoptions,ppo_defaultproperty);
if not(ppo_hasparameters in p.propoptions) then if not(ppo_hasparameters in p.propoptions) then
message(parser_e_property_need_paras); message(parser_e_property_need_paras);
@ -117,7 +116,7 @@ implementation
pd : tprocdef; pd : tprocdef;
begin begin
consume(_DESTRUCTOR); consume(_DESTRUCTOR);
parse_proc_head(aktclass,potype_destructor,pd); parse_proc_head(aktobjectdef,potype_destructor,pd);
if not assigned(pd) then if not assigned(pd) then
begin begin
consume(_SEMICOLON); consume(_SEMICOLON);
@ -130,7 +129,7 @@ implementation
(m_fpc in aktmodeswitches) then (m_fpc in aktmodeswitches) then
Message(parser_e_no_paras_for_destructor); Message(parser_e_no_paras_for_destructor);
consume(_SEMICOLON); consume(_SEMICOLON);
include(aktclass.objectoptions,oo_has_destructor); include(aktobjectdef.objectoptions,oo_has_destructor);
{ no return value } { no return value }
pd.rettype:=voidtype; pd.rettype:=voidtype;
destructor_head:=pd; destructor_head:=pd;
@ -149,44 +148,18 @@ implementation
{ publishable } { publishable }
if classtype in [odt_interfacecom,odt_class] then if classtype in [odt_interfacecom,odt_class] then
begin begin
aktclass.objecttype:=classtype; aktobjectdef.objecttype:=classtype;
if (cs_generate_rtti in aktlocalswitches) or if (cs_generate_rtti in aktlocalswitches) or
(assigned(aktclass.childof) and (assigned(aktobjectdef.childof) and
(oo_can_have_published in aktclass.childof.objectoptions)) then (oo_can_have_published in aktobjectdef.childof.objectoptions)) then
begin begin
include(aktclass.objectoptions,oo_can_have_published); include(aktobjectdef.objectoptions,oo_can_have_published);
{ in "publishable" classes the default access type is published } { in "publishable" classes the default access type is published }
current_object_option:=[sp_published]; current_object_option:=[sp_published];
end; end;
end; end;
end; end;
procedure setclassparent;
begin
if assigned(fd) then
aktclass:=fd
else
aktclass:=tobjectdef.create(classtype,n,nil);
{ is the current class tobject? }
{ so you could define your own tobject }
if (cs_compilesystem in aktmoduleswitches) and (classtype=odt_class) and (upper(n)='TOBJECT') then
class_tobject:=aktclass
else if (cs_compilesystem in aktmoduleswitches) and (classtype=odt_interfacecom) and (upper(n)='IUNKNOWN') then
interface_iunknown:=aktclass
else
begin
case classtype of
odt_class:
childof:=class_tobject;
odt_interfacecom:
childof:=interface_iunknown;
end;
if (oo_is_forward in childof.objectoptions) then
Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^);
aktclass.set_parent(childof);
end;
end;
procedure setinterfacemethodoptions; procedure setinterfacemethodoptions;
@ -195,15 +168,15 @@ implementation
defs: TIndexArray; defs: TIndexArray;
pd: tdef; pd: tdef;
begin begin
include(aktclass.objectoptions,oo_has_virtual); include(aktobjectdef.objectoptions,oo_has_virtual);
defs:=aktclass.symtable.defindex; defs:=aktobjectdef.symtable.defindex;
for i:=1 to defs.count do for i:=1 to defs.count do
begin begin
pd:=tdef(defs.search(i)); pd:=tdef(defs.search(i));
if pd.deftype=procdef then if pd.deftype=procdef then
begin begin
tprocdef(pd).extnumber:=aktclass.lastvtableindex; tprocdef(pd).extnumber:=aktobjectdef.lastvtableindex;
inc(aktclass.lastvtableindex); inc(aktobjectdef.lastvtableindex);
include(tprocdef(pd).procoptions,po_virtualmethod); include(tprocdef(pd).procoptions,po_virtualmethod);
tprocdef(pd).forwarddef:=false; tprocdef(pd).forwarddef:=false;
end; end;
@ -240,9 +213,9 @@ implementation
{ also anonym objects aren't allow (o : object a : longint; end;) } { also anonym objects aren't allow (o : object a : longint; end;) }
if n='' then if n='' then
Message(parser_f_no_anonym_objects); Message(parser_f_no_anonym_objects);
aktclass:=tobjectdef.create(classtype,n,nil); aktobjectdef:=tobjectdef.create(classtype,n,nil);
include(aktclass.objectoptions,oo_is_forward); include(aktobjectdef.objectoptions,oo_is_forward);
object_dec:=aktclass; object_dec:=aktobjectdef;
typecanbeforward:=storetypecanbeforward; typecanbeforward:=storetypecanbeforward;
readobjecttype:=false; readobjecttype:=false;
exit; exit;
@ -265,12 +238,12 @@ implementation
{ also anonym objects aren't allow (o : object a : longint; end;) } { also anonym objects aren't allow (o : object a : longint; end;) }
if n='' then if n='' then
Message(parser_f_no_anonym_objects); Message(parser_f_no_anonym_objects);
aktclass:=tobjectdef.create(classtype,n,nil); aktobjectdef:=tobjectdef.create(classtype,n,nil);
if (cs_compilesystem in aktmoduleswitches) and if (cs_compilesystem in aktmoduleswitches) and
(classtype=odt_interfacecom) and (upper(n)='IUNKNOWN') then (classtype=odt_interfacecom) and (upper(n)='IUNKNOWN') then
interface_iunknown:=aktclass; interface_iunknown:=aktobjectdef;
include(aktclass.objectoptions,oo_is_forward); include(aktobjectdef.objectoptions,oo_is_forward);
object_dec:=aktclass; object_dec:=aktobjectdef;
typecanbeforward:=storetypecanbeforward; typecanbeforward:=storetypecanbeforward;
readobjecttype:=false; readobjecttype:=false;
exit; exit;
@ -316,16 +289,16 @@ implementation
{ also anonym objects aren't allow (o : object a : longint; end;) } { also anonym objects aren't allow (o : object a : longint; end;) }
if n='' then if n='' then
Message(parser_f_no_anonym_objects); Message(parser_f_no_anonym_objects);
aktclass:=tobjectdef.create(odt_class,n,nil); aktobjectdef:=tobjectdef.create(odt_class,n,nil);
if (cs_compilesystem in aktmoduleswitches) and (upper(n)='TOBJECT') then if (cs_compilesystem in aktmoduleswitches) and (upper(n)='TOBJECT') then
class_tobject:=aktclass; class_tobject:=aktobjectdef;
aktclass.objecttype:=odt_class; aktobjectdef.objecttype:=odt_class;
include(aktclass.objectoptions,oo_is_forward); include(aktobjectdef.objectoptions,oo_is_forward);
{ all classes must have a vmt !! at offset zero } { all classes must have a vmt !! at offset zero }
if not(oo_has_vmt in aktclass.objectoptions) then if not(oo_has_vmt in aktobjectdef.objectoptions) then
aktclass.insertvmt; aktobjectdef.insertvmt;
object_dec:=aktclass; object_dec:=aktobjectdef;
typecanbeforward:=storetypecanbeforward; typecanbeforward:=storetypecanbeforward;
readobjecttype:=false; readobjecttype:=false;
exit; exit;
@ -347,16 +320,16 @@ implementation
Message1(type_e_interface_type_expected,implintf.typename); Message1(type_e_interface_type_expected,implintf.typename);
exit; exit;
end; end;
if aktclass.implementedinterfaces.searchintf(implintf)<>-1 then if aktobjectdef.implementedinterfaces.searchintf(implintf)<>-1 then
Message1(sym_e_duplicate_id,implintf.name) Message1(sym_e_duplicate_id,implintf.name)
else else
begin begin
{ allocate and prepare the GUID only if the class { allocate and prepare the GUID only if the class
implements some interfaces. implements some interfaces.
} }
if aktclass.implementedinterfaces.count = 0 then if aktobjectdef.implementedinterfaces.count = 0 then
aktclass.prepareguid; aktobjectdef.prepareguid;
aktclass.implementedinterfaces.addintf(implintf); aktobjectdef.implementedinterfaces.addintf(implintf);
end; end;
end; end;
@ -384,11 +357,11 @@ implementation
p:=comp_expr(true); p:=comp_expr(true);
if p.nodetype=stringconstn then if p.nodetype=stringconstn then
begin begin
stringdispose(aktclass.iidstr); stringdispose(aktobjectdef.iidstr);
aktclass.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? } aktobjectdef.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? }
p.free; p.free;
valid:=string2guid(aktclass.iidstr^,aktclass.iidguid^); valid:=string2guid(aktobjectdef.iidstr^,aktobjectdef.iidguid^);
if (classtype=odt_interfacecom) and not assigned(aktclass.iidguid) and not valid then if (classtype=odt_interfacecom) and not assigned(aktobjectdef.iidguid) and not valid then
Message(parser_e_improper_guid_syntax); Message(parser_e_improper_guid_syntax);
end end
else else
@ -401,24 +374,28 @@ implementation
procedure readparentclasses; procedure readparentclasses;
var var
hp : tobjectdef; intfchildof,
childof : tobjectdef;
tt : ttype;
hasparentdefined : boolean;
begin begin
hp:=nil; childof:=nil;
intfchildof:=nil;
hasparentdefined:=false;
{ reads the parent class } { reads the parent class }
if try_to_consume(_LKLAMMER) then if try_to_consume(_LKLAMMER) then
begin begin
id_type(tt,false); id_type(tt,false);
childof:=tobjectdef(tt.def); if (not assigned(tt.def)) or
if (not assigned(childof)) or (tt.def.deftype<>objectdef) then
(childof.deftype<>objectdef) then
begin begin
if assigned(childof) then if assigned(tt.def) then
Message1(type_e_class_type_expected,childof.typename); Message1(type_e_class_type_expected,childof.typename);
childof:=nil;
aktclass:=tobjectdef.create(classtype,n,nil);
end end
else else
begin begin
childof:=tobjectdef(tt.def);
{ a mix of class, interfaces, objects and cppclasses { a mix of class, interfaces, objects and cppclasses
isn't allowed } isn't allowed }
case classtype of case classtype of
@ -430,7 +407,7 @@ implementation
{ we insert the interface after the child { we insert the interface after the child
is set, see below is set, see below
} }
hp:=childof; intfchildof:=childof;
childof:=class_tobject; childof:=class_tobject;
end end
else else
@ -449,35 +426,49 @@ implementation
odt_dispinterface: odt_dispinterface:
Message(parser_e_dispinterface_cant_have_parent); Message(parser_e_dispinterface_cant_have_parent);
end; end;
{ the forward of the child must be resolved to get end;
correct field addresses } hasparentdefined:=true;
if assigned(fd) then end;
{ if no parent class, then a class get tobject as parent }
if not assigned(childof) then
begin begin
if (oo_is_forward in childof.objectoptions) then case classtype of
Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^); odt_class:
aktclass:=fd; if aktobjectdef<>class_tobject then
{ we must inherit several options !! childof:=class_tobject;
this was missing !! odt_interfacecom:
all is now done in set_parent if aktobjectdef<>interface_iunknown then
including symtable datasize setting PM } childof:=interface_iunknown;
fd.set_parent(childof); end;
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
aktobjectdef.set_parent(childof)
else else
aktclass:=tobjectdef.create(classtype,n,childof); Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^);
if aktclass.objecttype=odt_class then end;
{ remove forward flag, is resolved }
exclude(aktobjectdef.objectoptions,oo_is_forward);
if hasparentdefined then
begin begin
if assigned(hp) then if aktobjectdef.objecttype=odt_class then
handleimplementedinterface(hp); begin
if assigned(intfchildof) then
handleimplementedinterface(intfchildof);
readimplementedinterfaces; readimplementedinterfaces;
end; end;
end;
consume(_RKLAMMER); consume(_RKLAMMER);
end end;
{ if no parent class, then a class get tobject as parent }
else if classtype in [odt_class,odt_interfacecom] then
setclassparent
else
aktclass:=tobjectdef.create(classtype,n,nil);
{ read GUID } { read GUID }
if (classtype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and if (classtype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and
try_to_consume(_LECKKLAMMER) then try_to_consume(_LECKKLAMMER) then
@ -504,10 +495,6 @@ implementation
begin begin
old_object_option:=current_object_option; old_object_option:=current_object_option;
{ forward is resolved }
if assigned(fd) then
exclude(fd.objectoptions,oo_is_forward);
{ objects and class types can't be declared local } { objects and class types can't be declared local }
if not(symtablestack.symtabletype in [globalsymtable,staticsymtable]) then if not(symtablestack.symtabletype in [globalsymtable,staticsymtable]) then
Message(parser_e_no_local_objects); Message(parser_e_no_local_objects);
@ -520,13 +507,35 @@ implementation
if not(readobjecttype) then if not(readobjecttype) then
exit; exit;
{ also anonym objects aren't allow (o : object a : longint; end;) } if assigned(fd) then
aktobjectdef:=fd
else
begin
{ anonym objects aren't allow (o : object a : longint; end;) }
if n='' then if n='' then
Message(parser_f_no_anonym_objects); Message(parser_f_no_anonym_objects);
aktobjectdef:=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(aktobjectdef.objectoptions,oo_is_forward);
end;
{ read list of parent classes } { read list of parent classes }
readparentclasses; readparentclasses;
(*
{ keep reference to implicit parent classes }
if (cs_compilesystem in aktmoduleswitches) then
begin
if (classtype=odt_class) and
(upper(n)='TOBJECT') then
class_tobject:=aktobjectdef
else if (classtype=odt_interfacecom) and
(upper(n)='IUNKNOWN') then
interface_iunknown:=aktobjectdef;
end;
*)
{ default access is public } { default access is public }
there_is_a_destructor:=false; there_is_a_destructor:=false;
current_object_option:=[sp_public]; current_object_option:=[sp_public];
@ -534,11 +543,9 @@ implementation
{ set class flags and inherits published } { set class flags and inherits published }
setclassattributes; setclassattributes;
aktobjectdef:=aktclass; aktobjectdef.symtable.next:=symtablestack;
aktclass.symtable.next:=symtablestack; symtablestack:=aktobjectdef.symtable;
symtablestack:=aktclass.symtable;
testcurobject:=1; testcurobject:=1;
curobjectname:=Upper(n);
{ short class declaration ? } { short class declaration ? }
if (classtype<>odt_class) or (token<>_SEMICOLON) then if (classtype<>odt_class) or (token<>_SEMICOLON) then
@ -551,23 +558,23 @@ implementation
case idtoken of case idtoken of
_PRIVATE : _PRIVATE :
begin begin
if is_interface(aktclass) then if is_interface(aktobjectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
consume(_PRIVATE); consume(_PRIVATE);
current_object_option:=[sp_private]; current_object_option:=[sp_private];
include(aktclass.objectoptions,oo_has_private); include(aktobjectdef.objectoptions,oo_has_private);
end; end;
_PROTECTED : _PROTECTED :
begin begin
if is_interface(aktclass) then if is_interface(aktobjectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
consume(_PROTECTED); consume(_PROTECTED);
current_object_option:=[sp_protected]; current_object_option:=[sp_protected];
include(aktclass.objectoptions,oo_has_protected); include(aktobjectdef.objectoptions,oo_has_protected);
end; end;
_PUBLIC : _PUBLIC :
begin begin
if is_interface(aktclass) then if is_interface(aktobjectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
consume(_PUBLIC); consume(_PUBLIC);
current_object_option:=[sp_public]; current_object_option:=[sp_public];
@ -577,14 +584,14 @@ implementation
{ we've to check for a pushlished section in non- } { we've to check for a pushlished section in non- }
{ publishable classes later, if a real declaration } { publishable classes later, if a real declaration }
{ this is the way, delphi does it } { this is the way, delphi does it }
if is_interface(aktclass) then if is_interface(aktobjectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
consume(_PUBLISHED); consume(_PUBLISHED);
current_object_option:=[sp_published]; current_object_option:=[sp_published];
end; end;
_STRICT : _STRICT :
begin begin
if is_interface(aktclass) then if is_interface(aktobjectdef) then
Message(parser_e_no_access_specifier_in_interfaces); Message(parser_e_no_access_specifier_in_interfaces);
consume(_STRICT); consume(_STRICT);
if token=_ID then if token=_ID then
@ -594,13 +601,13 @@ implementation
begin begin
consume(_PRIVATE); consume(_PRIVATE);
current_object_option:=[sp_strictprivate]; current_object_option:=[sp_strictprivate];
include(aktclass.objectoptions,oo_has_strictprivate); include(aktobjectdef.objectoptions,oo_has_strictprivate);
end; end;
_PROTECTED: _PROTECTED:
begin begin
consume(_PROTECTED); consume(_PROTECTED);
current_object_option:=[sp_strictprotected]; current_object_option:=[sp_strictprotected];
include(aktclass.objectoptions,oo_has_strictprotected); include(aktobjectdef.objectoptions,oo_has_strictprotected);
end; end;
else else
message(parser_e_protected_or_private_expected); message(parser_e_protected_or_private_expected);
@ -611,11 +618,11 @@ implementation
end; end;
else else
begin begin
if is_interface(aktclass) then if is_interface(aktobjectdef) then
Message(parser_e_no_vars_in_interfaces); Message(parser_e_no_vars_in_interfaces);
if (sp_published in current_object_option) and if (sp_published in current_object_option) and
not(oo_can_have_published in aktclass.objectoptions) then not(oo_can_have_published in aktobjectdef.objectoptions) then
Message(parser_e_cant_have_published); Message(parser_e_cant_have_published);
read_var_decs([vd_object]); read_var_decs([vd_object]);
@ -631,12 +638,12 @@ implementation
_CLASS : _CLASS :
begin begin
if (sp_published in current_object_option) and if (sp_published in current_object_option) and
not(oo_can_have_published in aktclass.objectoptions) then not(oo_can_have_published in aktobjectdef.objectoptions) then
Message(parser_e_cant_have_published); Message(parser_e_cant_have_published);
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
pd:=parse_proc_dec(aktclass); pd:=parse_proc_dec(aktobjectdef);
{ this is for error recovery as well as forward } { this is for error recovery as well as forward }
{ interface mappings, i.e. mapping to a method } { interface mappings, i.e. mapping to a method }
@ -658,11 +665,11 @@ implementation
{ add procdef options to objectdef options } { add procdef options to objectdef options }
if (po_msgint in pd.procoptions) then if (po_msgint in pd.procoptions) then
include(aktclass.objectoptions,oo_has_msgint); include(aktobjectdef.objectoptions,oo_has_msgint);
if (po_msgstr in pd.procoptions) then if (po_msgstr in pd.procoptions) then
include(aktclass.objectoptions,oo_has_msgstr); include(aktobjectdef.objectoptions,oo_has_msgstr);
if (po_virtualmethod in pd.procoptions) then if (po_virtualmethod in pd.procoptions) then
include(aktclass.objectoptions,oo_has_virtual); include(aktobjectdef.objectoptions,oo_has_virtual);
chkcpp(pd); chkcpp(pd);
end; end;
@ -679,14 +686,14 @@ implementation
_CONSTRUCTOR : _CONSTRUCTOR :
begin begin
if (sp_published in current_object_option) and if (sp_published in current_object_option) and
not(oo_can_have_published in aktclass.objectoptions) then not(oo_can_have_published in aktobjectdef.objectoptions) then
Message(parser_e_cant_have_published); Message(parser_e_cant_have_published);
if not(sp_public in current_object_option) and if not(sp_public in current_object_option) and
not(sp_published in current_object_option) then not(sp_published in current_object_option) then
Message(parser_w_constructor_should_be_public); Message(parser_w_constructor_should_be_public);
if is_interface(aktclass) then if is_interface(aktobjectdef) then
Message(parser_e_no_con_des_in_interfaces); Message(parser_e_no_con_des_in_interfaces);
oldparse_only:=parse_only; oldparse_only:=parse_only;
@ -700,7 +707,7 @@ implementation
{ add procdef options to objectdef options } { add procdef options to objectdef options }
if (po_virtualmethod in pd.procoptions) then if (po_virtualmethod in pd.procoptions) then
include(aktclass.objectoptions,oo_has_virtual); include(aktobjectdef.objectoptions,oo_has_virtual);
chkcpp(pd); chkcpp(pd);
{ Support hint directives } { Support hint directives }
@ -715,13 +722,13 @@ implementation
_DESTRUCTOR : _DESTRUCTOR :
begin begin
if (sp_published in current_object_option) and if (sp_published in current_object_option) and
not(oo_can_have_published in aktclass.objectoptions) then not(oo_can_have_published in aktobjectdef.objectoptions) then
Message(parser_e_cant_have_published); Message(parser_e_cant_have_published);
if there_is_a_destructor then if there_is_a_destructor then
Message(parser_n_only_one_destructor); Message(parser_n_only_one_destructor);
if is_interface(aktclass) then if is_interface(aktobjectdef) then
Message(parser_e_no_con_des_in_interfaces); Message(parser_e_no_con_des_in_interfaces);
if not(sp_public in current_object_option) then if not(sp_public in current_object_option) then
@ -739,7 +746,7 @@ implementation
{ add procdef options to objectdef options } { add procdef options to objectdef options }
if (po_virtualmethod in pd.procoptions) then if (po_virtualmethod in pd.procoptions) then
include(aktclass.objectoptions,oo_has_virtual); include(aktobjectdef.objectoptions,oo_has_virtual);
chkcpp(pd); chkcpp(pd);
@ -764,25 +771,24 @@ implementation
end; end;
{ generate vmt space if needed } { generate vmt space if needed }
if not(oo_has_vmt in aktclass.objectoptions) and if not(oo_has_vmt in aktobjectdef.objectoptions) and
(([oo_has_virtual,oo_has_constructor,oo_has_destructor]*aktclass.objectoptions<>[]) or (([oo_has_virtual,oo_has_constructor,oo_has_destructor]*aktobjectdef.objectoptions<>[]) or
(classtype in [odt_class]) (classtype in [odt_class])
) then ) then
aktclass.insertvmt; aktobjectdef.insertvmt;
if is_interface(aktclass) then if is_interface(aktobjectdef) then
setinterfacemethodoptions; setinterfacemethodoptions;
{ reset } { return defined objectdef }
testcurobject:=0; result:=aktobjectdef;
curobjectname:='';
typecanbeforward:=storetypecanbeforward;
{ restore old state }
symtablestack:=symtablestack.next;
aktobjectdef:=nil;
current_object_option:=old_object_option;
object_dec:=aktclass; { restore old state }
aktobjectdef:=nil;
testcurobject:=0;
typecanbeforward:=storetypecanbeforward;
symtablestack:=symtablestack.next;
current_object_option:=old_object_option;
end; end;
end. end.

39
compiler/ptype.pas
View File

@ -36,7 +36,6 @@ interface
{ hack, which allows to use the current parsed } { hack, which allows to use the current parsed }
{ object type as function argument type } { object type as function argument type }
testcurobject : byte; testcurobject : byte;
curobjectname : stringid;
{ reads a string, file type or a type id and returns a name and } { reads a string, file type or a type id and returns a name and }
{ tdef } { tdef }
@ -85,18 +84,19 @@ implementation
s:=pattern; s:=pattern;
sorg:=orgpattern; sorg:=orgpattern;
pos:=akttokenpos; pos:=akttokenpos;
{ classes can be used also in classes } { use of current parsed object:
if (curobjectname=pattern) and is_class_or_interface(aktobjectdef) then - classes can be used also in classes
- objects can be parameters }
if (token=_ID) and
assigned(aktobjectdef) and
(aktobjectdef.objname^=pattern) and
(
(testcurobject=2) or
is_class_or_interface(aktobjectdef)
)then
begin begin
tt.setdef(aktobjectdef);
consume(_ID); consume(_ID);
exit;
end;
{ objects can be parameters }
if (testcurobject=2) and (curobjectname=pattern) then
begin
tt.setdef(aktobjectdef); tt.setdef(aktobjectdef);
consume(_ID);
exit; exit;
end; end;
{ try to load the symbol to see if it's a unitsym. Use the { try to load the symbol to see if it's a unitsym. Use the
@ -260,20 +260,21 @@ implementation
pt1,pt2 : tnode; pt1,pt2 : tnode;
lv,hv : TConstExprInt; lv,hv : TConstExprInt;
begin begin
{ use of current parsed object ? } { use of current parsed object:
if (token=_ID) and (testcurobject=2) and (curobjectname=pattern) then - classes can be used also in classes
- objects can be parameters }
if (token=_ID) and
assigned(aktobjectdef) and
(aktobjectdef.objname^=pattern) and
(
(testcurobject=2) or
is_class_or_interface(aktobjectdef)
)then
begin begin
consume(_ID); consume(_ID);
tt.setdef(aktobjectdef); tt.setdef(aktobjectdef);
exit; exit;
end; end;
{ classes can be used also in classes }
if (curobjectname=pattern) and is_class_or_interface(aktobjectdef) then
begin
tt.setdef(aktobjectdef);
consume(_ID);
exit;
end;
{ we can't accept a equal in type } { we can't accept a equal in type }
pt1:=comp_expr(not(ignore_equal)); pt1:=comp_expr(not(ignore_equal));
if (token=_POINTPOINT) then if (token=_POINTPOINT) then

7
rtl/inc/objpash.inc
View File

@ -53,9 +53,12 @@
type type
TextFile = Text; TextFile = Text;
{ now the let's declare the base classes for the class object } { now the let's declare the base classes for the class object
{ model } model. The compiler expects TObject and IUnknown to be defined
first as forward classes }
TObject = class; TObject = class;
IUnknown = interface;
TClass = class of tobject; TClass = class of tobject;
PClass = ^tclass; PClass = ^tclass;

18
tests/webtbf/tw4569a.pp Executable file
View File

@ -0,0 +1,18 @@
{ %fail }
{ Source provided for Free Pascal Bug Report 4569 }
{ Submitted by "Vincent Snijders" on 2005-12-06 }
{ e-mail: vsnijders@quicknet.nl }
program fpcdos;
{$mode objfpc}
type
TMyClassA = class;
TMyClassA = class(TMyClassA)
procedure DoSomething; override;
end;
begin
end.

23
tests/webtbf/tw4569b.pp Executable file
View File

@ -0,0 +1,23 @@
{ %fail }
{ Source provided for Free Pascal Bug Report 4569 }
{ Submitted by "Vincent Snijders" on 2005-12-06 }
{ e-mail: vsnijders@quicknet.nl }
program fpcdos;
{$mode objfpc}
type
TMyClassB = class;
TMyClassC = class;
TMyClassB = class(TMyClassC)
procedure DoSomething; override;
end;
TMyClassC = class(TMyClassB)
procedure DoSomething; override;
end;
begin
end.