paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 12:23:24 +01: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/tw4445.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/uw0840a.pp svneol=native#text/plain
tests/webtbf/uw0840b.pp svneol=native#text/plain

402
compiler/pdecobj.pas
View File

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

51
compiler/ptype.pas
View File

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

7
rtl/inc/objpash.inc
View File

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