From fa41b6ffe382bfb75d6b28c48227230e3c20b01b Mon Sep 17 00:00:00 2001
From: paul <paul@idefix.freepascal.org>
Date: Tue, 4 Jan 2011 18:20:40 +0000
Subject: [PATCH] compiler: allow generic classes to derive from generic
classes and generic interfaces - change id_type to single_type in
readImplementedInterfacesAndProtocols to allow use of interface
specializations inside class parent block - change single_type boolean
arguments to set, add stoParseClassParent option to that set - move
parse_generic variable assignment from parse_object_members to outer routine
to setup it before parsing class parents - return paticular generic in
generate_specialization instead of undefineddef to pass class/interface
checks inside parent class block - add test for delphi mode - modify
tw11431 to be syntatically correct
git-svn-id: trunk@16706 -
---
.gitattributes | 1 +
compiler/pdecobj.pas | 23 ++++++++++----------
compiler/pdecsub.pas | 8 +++----
compiler/pdecvar.pas | 8 +++----
compiler/ptype.pas | 45 ++++++++++++++++++++++++----------------
tests/test/tgeneric29.pp | 39 ++++++++++++++++++++++++++++++++++
tests/webtbs/tw11431.pp | 2 +-
7 files changed, 87 insertions(+), 39 deletions(-)
create mode 100644 tests/test/tgeneric29.pp
diff --git a/.gitattributes b/.gitattributes
index 081fdf1794..79ac491bd6 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -9418,6 +9418,7 @@ tests/test/tgeneric25.pp svneol=native#text/pascal
tests/test/tgeneric26.pp svneol=native#text/pascal
tests/test/tgeneric27.pp svneol=native#text/pascal
tests/test/tgeneric28.pp svneol=native#text/pascal
+tests/test/tgeneric29.pp svneol=native#text/pascal
tests/test/tgeneric3.pp svneol=native#text/plain
tests/test/tgeneric4.pp svneol=native#text/plain
tests/test/tgeneric5.pp svneol=native#text/plain
diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas
index 07cc077815..d900674618 100644
--- a/compiler/pdecobj.pas
+++ b/compiler/pdecobj.pas
@@ -306,7 +306,8 @@ implementation
begin
while try_to_consume(_COMMA) do
begin
- id_type(hdef,false);
+ { use single_type instead of id_type for specialize support }
+ single_type(hdef,[stoAllowTypeDef,stoParseClassParent]);
if (hdef.typ<>objectdef) then
begin
if intf then
@@ -442,7 +443,7 @@ implementation
begin
consume(_LKLAMMER);
{ use single_type instead of id_type for specialize support }
- single_type(hdef,false,false);
+ single_type(hdef,[stoAllowTypeDef, stoParseClassParent]);
if (not assigned(hdef)) or
(hdef.typ<>objectdef) then
begin
@@ -662,8 +663,7 @@ implementation
var
pd : tprocdef;
has_destructor,
- oldparse_only,
- old_parse_generic: boolean;
+ oldparse_only: boolean;
object_member_blocktype : tblock_type;
fields_allowed, is_classdef, classfields: boolean;
vdoptions: tvar_dec_options;
@@ -673,9 +673,6 @@ implementation
(token=_SEMICOLON) then
exit;
- old_parse_generic:=parse_generic;
-
- parse_generic:=(df_generic in current_structdef.defoptions);
{ in "publishable" classes the default access type is published }
if (oo_can_have_published in current_structdef.objectoptions) then
current_structdef.symtable.currentvisibility:=vis_published
@@ -1016,9 +1013,6 @@ implementation
consume(_ID); { Give a ident expected message, like tp7 }
end;
until false;
-
- { restore }
- parse_generic:=old_parse_generic;
end;
@@ -1027,10 +1021,12 @@ implementation
old_current_structdef: tabstractrecorddef;
old_current_genericdef,
old_current_specializedef: tstoreddef;
+ old_parse_generic: boolean;
begin
old_current_structdef:=current_structdef;
old_current_genericdef:=current_genericdef;
old_current_specializedef:=current_specializedef;
+ old_parse_generic:=parse_generic;
current_structdef:=nil;
current_genericdef:=nil;
@@ -1129,14 +1125,16 @@ implementation
if not(objecttype in [odt_objcclass,odt_objcprotocol,odt_objccategory]) then
parse_object_options;
+ symtablestack.push(current_structdef.symtable);
+ insert_generic_parameter_types(current_structdef,genericdef,genericlist);
+ parse_generic:=(df_generic in current_structdef.defoptions);
+
{ parse list of parent classes }
parse_parent_classes;
{ parse optional GUID for interfaces }
parse_guid;
- symtablestack.push(current_structdef.symtable);
- insert_generic_parameter_types(current_structdef,genericdef,genericlist);
{ parse and insert object members }
parse_object_members;
symtablestack.pop(current_structdef.symtable);
@@ -1171,6 +1169,7 @@ implementation
current_structdef:=old_current_structdef;
current_genericdef:=old_current_genericdef;
current_specializedef:=old_current_specializedef;
+ parse_generic:=old_parse_generic;
end;
end.
diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas
index 71507e8784..dd5cbfb035 100644
--- a/compiler/pdecsub.pas
+++ b/compiler/pdecsub.pas
@@ -593,7 +593,7 @@ implementation
begin
block_type:=bt_var_type;
consume(_COLON);
- single_type(pv.returndef,false,false);
+ single_type(pv.returndef,[]);
block_type:=bt_var;
end;
hdef:=pv;
@@ -641,7 +641,7 @@ implementation
else
begin
{ define field type }
- single_type(arrayelementdef,false,false);
+ single_type(arrayelementdef,[]);
tarraydef(hdef).elementdef:=arrayelementdef;
end;
end
@@ -655,7 +655,7 @@ implementation
else
begin
block_type:=bt_var_type;
- single_type(hdef,false,false);
+ single_type(hdef,[]);
block_type:=bt_var;
end;
@@ -1211,7 +1211,7 @@ implementation
if assigned(current_structdef) and (df_specialization in current_structdef.defoptions) then
current_specializedef:=current_structdef;
end;
- single_type(pd.returndef,false,false);
+ single_type(pd.returndef,[]);
if is_dispinterface(pd.struct) and not is_automatable(pd.returndef) then
Message1(type_e_not_automatable,pd.returndef.typename);
diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas
index 6dff496bd8..ed60bf3d8f 100644
--- a/compiler/pdecvar.pas
+++ b/compiler/pdecvar.pas
@@ -384,11 +384,11 @@ implementation
{ define range and type of range }
hdef:=tarraydef.create(0,-1,s32inttype);
{ define field type }
- single_type(arraytype,false,false);
+ single_type(arraytype,[]);
tarraydef(hdef).elementdef:=arraytype;
end
else
- single_type(hdef,false,false);
+ single_type(hdef,[]);
end
else
hdef:=cformaltype;
@@ -417,7 +417,7 @@ implementation
if (token=_COLON) or (paranr>0) or (astruct=nil) then
begin
consume(_COLON);
- single_type(p.propdef,false,false);
+ single_type(p.propdef,[]);
if is_dispinterface(astruct) and not is_automatable(p.propdef) then
Message1(type_e_not_automatable,p.propdef.typename);
@@ -728,7 +728,7 @@ implementation
{ Parse possible "implements" keyword }
if not is_record(astruct) and try_to_consume(_IMPLEMENTS) then
begin
- single_type(def,false,false);
+ single_type(def,[]);
if not(is_interface(def)) then
message(parser_e_class_implements_must_be_interface);
diff --git a/compiler/ptype.pas b/compiler/ptype.pas
index e2fff9ad9c..b253f00cba 100644
--- a/compiler/ptype.pas
+++ b/compiler/ptype.pas
@@ -29,13 +29,17 @@ interface
globtype,cclasses,
symtype,symdef,symbase;
+ type
+ TSingleTypeOption=(stoIsForwardDef,stoAllowTypeDef,stoParseClassParent);
+ TSingleTypeOptions=set of TSingleTypeOption;
+
procedure resolve_forward_types;
{ reads a type identifier }
procedure id_type(var def : tdef;isforwarddef:boolean);
{ reads a string, file type or a type identifier }
- procedure single_type(var def:tdef;isforwarddef,allowtypedef:boolean);
+ procedure single_type(var def:tdef;options:TSingleTypeOptions);
{ reads any type declaration, where the resulting type will get name as type identifier }
procedure read_named_type(var def:tdef;const name : TIDString;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean);
@@ -136,7 +140,7 @@ implementation
end;
- procedure generate_specialization(var tt:tdef);
+ procedure generate_specialization(var tt:tdef;parse_class_parent:boolean);
var
st : TSymtable;
srsym : tsym;
@@ -177,6 +181,8 @@ implementation
of generic and specialization might not be equally sized which
is later assumed }
tt:=tundefineddef.create;
+ if parse_class_parent then
+ tt:=genericdef;
onlyparsepara:=true;
end;
@@ -438,7 +444,7 @@ implementation
end;
- procedure single_type(var def:tdef;isforwarddef,allowtypedef:boolean);
+ procedure single_type(var def:tdef;options:TSingleTypeOptions);
var
t2 : tdef;
dospecialize,
@@ -449,17 +455,17 @@ implementation
again:=false;
case token of
_STRING:
- string_dec(def,allowtypedef);
+ string_dec(def,stoAllowTypeDef in options);
_FILE:
begin
consume(_FILE);
if (token=_OF) then
begin
- if not(allowtypedef) then
+ if not(stoAllowTypeDef in options) then
Message(parser_e_no_local_para_def);
consume(_OF);
- single_type(t2,false,false);
+ single_type(t2,[]);
if is_managed_type(t2) then
Message(parser_e_no_refcounted_typed_file);
def:=tfiledef.createtyped(t2);
@@ -472,7 +478,7 @@ implementation
begin
if try_to_consume(_SPECIALIZE) then
begin
- if not(allowtypedef) then
+ if not(stoAllowTypeDef in options) then
begin
Message(parser_e_no_local_para_def);
@@ -489,7 +495,7 @@ implementation
end
else
begin
- id_type(def,isforwarddef);
+ id_type(def,stoIsForwardDef in options);
{ handle types inside classes, e.g. TNode.TLongint }
while (token=_POINT) do
begin
@@ -502,7 +508,7 @@ implementation
begin
symtablestack.push(tabstractrecorddef(def).symtable);
consume(_POINT);
- id_type(t2,isforwarddef);
+ id_type(t2,stoIsForwardDef in options);
symtablestack.pop(tabstractrecorddef(def).symtable);
def:=t2;
end
@@ -519,8 +525,10 @@ implementation
end;
end;
until not again;
+ if (stoAllowTypeDef in options)and(m_delphi in current_settings.modeswitches) then
+ dospecialize:=token=_LSHARPBRACKET;
if dospecialize then
- generate_specialization(def)
+ generate_specialization(def,stoParseClassParent in options)
else
begin
if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
@@ -990,7 +998,7 @@ implementation
if (m_delphi in current_settings.modeswitches) then
dospecialize:=token=_LSHARPBRACKET;
if dospecialize then
- generate_specialization(def)
+ generate_specialization(def,false)
else
begin
if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
@@ -1236,7 +1244,8 @@ implementation
current_genericdef:=old_current_genericdef;
current_specializedef:=old_current_specializedef;
end;
-
+ const
+ SingleTypeOptionsInTypeBlock:array[Boolean] of TSingleTypeOptions = ([],[stoIsForwardDef]);
var
p : tnode;
hdef : tdef;
@@ -1254,7 +1263,7 @@ implementation
case token of
_STRING,_FILE:
begin
- single_type(def,false,true);
+ single_type(def,[stoAllowTypeDef]);
end;
_LKLAMMER:
begin
@@ -1362,7 +1371,7 @@ implementation
_CARET:
begin
consume(_CARET);
- single_type(tt2,(block_type=bt_type),false);
+ single_type(tt2,SingleTypeOptionsInTypeBlock[block_type=bt_type]);
def:=tpointerdef.create(tt2);
if tt2.typ=forwarddef then
current_module.checkforwarddefs.add(def);
@@ -1383,7 +1392,7 @@ implementation
else if token=_SET then
set_dec
else if token=_FILE then
- single_type(def,false,true)
+ single_type(def,[stoAllowTypeDef])
else
begin
oldpackrecords:=current_settings.packrecords;
@@ -1429,7 +1438,7 @@ implementation
) then
begin
consume(_OF);
- single_type(hdef,(block_type=bt_type),false);
+ single_type(hdef,SingleTypeOptionsInTypeBlock[block_type=bt_type]);
if is_class(hdef) or
is_objcclass(hdef) then
def:=tclassrefdef.create(hdef)
@@ -1502,7 +1511,7 @@ implementation
if is_func then
begin
consume(_COLON);
- single_type(pd.returndef,false,false);
+ single_type(pd.returndef,[]);
end;
if try_to_consume(_OF) then
begin
@@ -1536,7 +1545,7 @@ implementation
if (token=_KLAMMERAFFE) and (m_iso in current_settings.modeswitches) then
begin
consume(_KLAMMERAFFE);
- single_type(tt2,(block_type=bt_type),false);
+ single_type(tt2,SingleTypeOptionsInTypeBlock[block_type=bt_type]);
def:=tpointerdef.create(tt2);
if tt2.typ=forwarddef then
current_module.checkforwarddefs.add(def);
diff --git a/tests/test/tgeneric29.pp b/tests/test/tgeneric29.pp
new file mode 100644
index 0000000000..141210d755
--- /dev/null
+++ b/tests/test/tgeneric29.pp
@@ -0,0 +1,39 @@
+program tgeneric29;
+
+{$mode delphi}
+
+type
+ IGenericInterface<T> = interface
+ function DoSomething(Arg: T): T;
+ end;
+
+ TGenericClass<T> = class(TInterfacedObject, IGenericInterface<T>)
+ F: T;
+ type
+ Intf = IGenericInterface<Integer>;
+ function DoSomething(Arg: T): T;
+ function Test(Arg: Intf): Intf;
+ end;
+
+ TGenericRecord<T> = record
+ F: T;
+ end;
+
+ TGenericArray<T> = array of T;
+
+function TGenericClass{<T>}.DoSomething(Arg: T): T;
+begin
+ Result := Arg;
+end;
+
+function TGenericClass{<T>}.Test(Arg: Intf): Intf;
+begin
+ Result := Arg;
+end;
+
+var
+ ClassSpecialize: TGenericClass<Integer>;
+ RecordSpecialize: TGenericRecord<Integer>;
+ ArraySpecialize: TGenericArray<Integer>;
+begin
+end.
diff --git a/tests/webtbs/tw11431.pp b/tests/webtbs/tw11431.pp
index e2dd238c2f..21965f8e5c 100644
--- a/tests/webtbs/tw11431.pp
+++ b/tests/webtbs/tw11431.pp
@@ -10,7 +10,7 @@ type
generic IGenericCollection<_T> = interface
end;
- generic CGenericCollection<_T> = class( IGenericCollection)
+ generic CGenericCollection<_T> = class(TInterfacedObject, specialize IGenericCollection<_T>)
end;
implementation