paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-18 19:49:12 +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

402
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,92 +374,110 @@ implementation
procedure readparentclasses; procedure readparentclasses;
var var
hp : tobjectdef; intfchildof,
childof : tobjectdef;
tt : ttype;
hasparentdefined : boolean;
begin begin
hp:=nil; childof:=nil;
{ reads the parent class } intfchildof:=nil;
if try_to_consume(_LKLAMMER) then hasparentdefined:=false;
begin
id_type(tt,false); { reads the parent class }
childof:=tobjectdef(tt.def); if try_to_consume(_LKLAMMER) then
if (not assigned(childof)) or begin
(childof.deftype<>objectdef) then id_type(tt,false);
begin if (not assigned(tt.def)) or
if assigned(childof) then (tt.def.deftype<>objectdef) then
Message1(type_e_class_type_expected,childof.typename); begin
childof:=nil; if assigned(tt.def) then
aktclass:=tobjectdef.create(classtype,n,nil); Message1(type_e_class_type_expected,childof.typename);
end end
else else
begin begin
{ a mix of class, interfaces, objects and cppclasses childof:=tobjectdef(tt.def);
isn't allowed } { a mix of class, interfaces, objects and cppclasses
case classtype of isn't allowed }
odt_class: case classtype of
if not(is_class(childof)) then odt_class:
begin if not(is_class(childof)) then
if is_interface(childof) then begin
begin if is_interface(childof) then
{ we insert the interface after the child begin
is set, see below { we insert the interface after the child
} is set, see below
hp:=childof; }
childof:=class_tobject; intfchildof:=childof;
end childof:=class_tobject;
else end
Message(parser_e_mix_of_classes_and_objects); else
end; Message(parser_e_mix_of_classes_and_objects);
odt_interfacecorba, end;
odt_interfacecom: odt_interfacecorba,
if not(is_interface(childof)) then odt_interfacecom:
Message(parser_e_mix_of_classes_and_objects); if not(is_interface(childof)) then
odt_cppclass: Message(parser_e_mix_of_classes_and_objects);
if not(is_cppclass(childof)) then odt_cppclass:
Message(parser_e_mix_of_classes_and_objects); if not(is_cppclass(childof)) then
odt_object: Message(parser_e_mix_of_classes_and_objects);
if not(is_object(childof)) then odt_object:
Message(parser_e_mix_of_classes_and_objects); if not(is_object(childof)) then
odt_dispinterface: Message(parser_e_mix_of_classes_and_objects);
Message(parser_e_dispinterface_cant_have_parent); odt_dispinterface:
end; Message(parser_e_dispinterface_cant_have_parent);
{ the forward of the child must be resolved to get end;
correct field addresses } end;
if assigned(fd) then hasparentdefined:=true;
begin end;
if (oo_is_forward in childof.objectoptions) then
Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^); { if no parent class, then a class get tobject as parent }
aktclass:=fd; if not assigned(childof) then
{ we must inherit several options !! begin
this was missing !! case classtype of
all is now done in set_parent odt_class:
including symtable datasize setting PM } if aktobjectdef<>class_tobject then
fd.set_parent(childof); childof:=class_tobject;
end odt_interfacecom:
else if aktobjectdef<>interface_iunknown then
aktclass:=tobjectdef.create(classtype,n,childof); childof:=interface_iunknown;
if aktclass.objecttype=odt_class then end;
begin end;
if assigned(hp) then
handleimplementedinterface(hp); if assigned(childof) then
readimplementedinterfaces; begin
end; { Forbid not completly defined objects to be used as parents. This will
end; also prevent circular loops of classes, because we set the forward flag
consume(_RKLAMMER); at the start of the new definition and will reset it below after the
end parent has been set }
{ if no parent class, then a class get tobject as parent } if not(oo_is_forward in childof.objectoptions) then
else if classtype in [odt_class,odt_interfacecom] then aktobjectdef.set_parent(childof)
setclassparent else
else Message1(parser_e_forward_declaration_must_be_resolved,childof.objrealname^);
aktclass:=tobjectdef.create(classtype,n,nil); end;
{ read GUID }
if (classtype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) and { remove forward flag, is resolved }
try_to_consume(_LECKKLAMMER) then exclude(aktobjectdef.objectoptions,oo_is_forward);
begin
readinterfaceiid; if hasparentdefined then
consume(_RECKKLAMMER); begin
end if aktobjectdef.objecttype=odt_class then
else if (classtype=odt_dispinterface) then begin
message(parser_e_dispinterface_needs_a_guid); 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; end;
procedure chkcpp(pd:tprocdef); procedure chkcpp(pd:tprocdef);
@ -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
if n='' then aktobjectdef:=fd
Message(parser_f_no_anonym_objects); 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 } { 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.

51
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,19 +84,20 @@ 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); tt.setdef(aktobjectdef);
exit; exit;
end;
{ objects can be parameters }
if (testcurobject=2) and (curobjectname=pattern) then
begin
tt.setdef(aktobjectdef);
consume(_ID);
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
special searchsym_type that ignores records,objects and special searchsym_type that ignores records,objects and
@ -260,19 +260,20 @@ 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;
{ 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; 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));

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.