mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 14:39:36 +01:00
* fixed some problems of previous commit
This commit is contained in:
florian
parent
0cfa0419bd
commit
1ba347c47d
@ -1041,12 +1041,22 @@ implementation
|
||||
procedure writeinterfaceids(c : pobjectdef);
|
||||
var
|
||||
i: longint;
|
||||
s1,s2 : string;
|
||||
begin
|
||||
if c^.owner^.name=nil then
|
||||
s1:=''
|
||||
else
|
||||
s1:=c^.owner^.name^;
|
||||
if c^.objname=nil then
|
||||
s2:=''
|
||||
else
|
||||
s2:=upper(c^.objname^);
|
||||
s1:=s1+'$_'+s2;
|
||||
if c^.isiidguidvalid then
|
||||
begin
|
||||
if (cs_create_smart in aktmoduleswitches) then
|
||||
datasegment^.concat(new(pai_cut,init));
|
||||
datasegment^.concat(new(pai_symbol,initname_global(c^.vmt_mangledname+'$_IID',0)));
|
||||
datasegment^.concat(new(pai_symbol,initname_global('IID$_'+s1,0)));
|
||||
datasegment^.concat(new(pai_const,init_32bit(c^.iidguid.D1)));
|
||||
datasegment^.concat(new(pai_const,init_16bit(c^.iidguid.D2)));
|
||||
datasegment^.concat(new(pai_const,init_16bit(c^.iidguid.D3)));
|
||||
@ -1055,7 +1065,7 @@ implementation
|
||||
end;
|
||||
if (cs_create_smart in aktmoduleswitches) then
|
||||
datasegment^.concat(new(pai_cut,init));
|
||||
datasegment^.concat(new(pai_symbol,initname_global(c^.vmt_mangledname+'$_IIDSTR',0)));
|
||||
datasegment^.concat(new(pai_symbol,initname_global('IIDSTR$_'+s1,0)));
|
||||
datasegment^.concat(new(pai_const,init_8bit(length(c^.iidstr^))));
|
||||
datasegment^.concat(new(pai_string,init(c^.iidstr^)));
|
||||
end;
|
||||
@ -1063,7 +1073,10 @@ implementation
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.10 2000-11-04 14:25:19 florian
|
||||
Revision 1.11 2000-11-04 17:31:00 florian
|
||||
* fixed some problems of previous commit
|
||||
|
||||
Revision 1.10 2000/11/04 14:25:19 florian
|
||||
+ merged Attila's changes for interfaces, not tested yet
|
||||
|
||||
Revision 1.9 2000/11/01 23:04:37 peter
|
||||
|
||||
@ -755,13 +755,12 @@ implementation
|
||||
classtype:=odt_cppclass;
|
||||
consume(_CPPCLASS);
|
||||
end;
|
||||
{$ifdef SUPPORT_INTERFACE}
|
||||
_INTERFACE:
|
||||
begin
|
||||
if aktinterfacetype=it_interfacecom then
|
||||
objecttype:=odt_interfacecom
|
||||
classtype:=odt_interfacecom
|
||||
else {it_interfacecorba}
|
||||
objecttype:=odt_interfacecorba;
|
||||
classtype:=odt_interfacecorba;
|
||||
consume(_INTERFACE);
|
||||
{ forward declaration }
|
||||
if not(assigned(fd)) and (token=_SEMICOLON) then
|
||||
@ -769,14 +768,13 @@ implementation
|
||||
{ also anonym objects aren't allow (o : object a : longint; end;) }
|
||||
if n='' then
|
||||
Message(parser_f_no_anonym_objects);
|
||||
aktclass:=new(pobjectdef,init(objecttype,n,nil));
|
||||
aktclass:=new(pobjectdef,init(classtype,n,nil));
|
||||
if (cs_compilesystem in aktmoduleswitches) and
|
||||
(objecttype=odt_interfacecom) and (n='IUNKNOWN') then
|
||||
(classtype=odt_interfacecom) and (n='IUNKNOWN') then
|
||||
interface_iunknown:=aktclass;
|
||||
aktclass^.objectoptions:=aktclass^.objectoptions+[oo_is_forward];
|
||||
end;
|
||||
end;
|
||||
{$endif SUPPORT_INTERFACE}
|
||||
_CLASS:
|
||||
begin
|
||||
classtype:=odt_class;
|
||||
@ -856,6 +854,30 @@ implementation
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure readinterfaceiid;
|
||||
var
|
||||
tt: ttype;
|
||||
p : tnode;
|
||||
isiidguidvalid: boolean;
|
||||
|
||||
begin
|
||||
p:=comp_expr(true);
|
||||
do_firstpass(p);
|
||||
if p.nodetype=stringconstn then
|
||||
begin
|
||||
aktclass^.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? }
|
||||
p.free;
|
||||
aktclass^.isiidguidvalid:=string2guid(aktclass^.iidstr^,aktclass^.iidguid);
|
||||
if (classtype=odt_interfacecom) and not aktclass^.isiidguidvalid then
|
||||
Message(parser_e_improper_guid_syntax);
|
||||
end
|
||||
else
|
||||
begin
|
||||
p.free;
|
||||
Message(cg_e_illegal_expression);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure readparentclasses;
|
||||
|
||||
begin
|
||||
@ -915,10 +937,17 @@ implementation
|
||||
consume(_RKLAMMER);
|
||||
end
|
||||
{ if no parent class, then a class get tobject as parent }
|
||||
else if classtype=odt_class then
|
||||
else if classtype in [odt_class,odt_interfacecom] then
|
||||
setclassparent
|
||||
else
|
||||
aktclass:=new(pobjectdef,init(classtype,n,nil));
|
||||
{ read GUID }
|
||||
if (classtype in [odt_interfacecom,odt_interfacecorba]) and
|
||||
try_to_consume(_LECKKLAMMER) then
|
||||
begin
|
||||
readinterfaceiid;
|
||||
consume(_RECKKLAMMER);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure chkcpp;
|
||||
@ -932,30 +961,6 @@ implementation
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure readinterfaceiid;
|
||||
var
|
||||
tt: ttype;
|
||||
p : tnode;
|
||||
isiidguidvalid: boolean;
|
||||
|
||||
begin
|
||||
p:=comp_expr(true);
|
||||
do_firstpass(p);
|
||||
if p.nodetype=stringconstn then
|
||||
begin
|
||||
aktclass^.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? }
|
||||
p.free;
|
||||
aktclass^.isiidguidvalid:=string2guid(aktclass^.iidstr^,aktclass^.iidguid);
|
||||
if (classtype=odt_interfacecom) and not aktclass^.isiidguidvalid then
|
||||
Message(parser_e_improper_guid_syntax);
|
||||
end
|
||||
else
|
||||
begin
|
||||
p.free;
|
||||
Message(cg_e_illegal_expression);
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
temppd : pprocdef;
|
||||
begin
|
||||
@ -1122,7 +1127,7 @@ implementation
|
||||
{ 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
|
||||
(classtype=odt_class)
|
||||
(classtype in [odt_class])
|
||||
) then
|
||||
aktclass^.insertvmt;
|
||||
if (cs_create_smart in aktmoduleswitches) then
|
||||
@ -1152,7 +1157,10 @@ implementation
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.5 2000-11-04 14:25:20 florian
|
||||
Revision 1.6 2000-11-04 17:31:00 florian
|
||||
* fixed some problems of previous commit
|
||||
|
||||
Revision 1.5 2000/11/04 14:25:20 florian
|
||||
+ merged Attila's changes for interfaces, not tested yet
|
||||
|
||||
Revision 1.4 2000/10/31 22:02:49 peter
|
||||
|
||||
Loading…
Reference in New Issue
Block a user