paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 01:29:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

compiler: allow generic classes to derive from generic classes and generic interfaces

Browse Source 
- 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 -
This commit is contained in:
paul 2011-01-04 18:20:40 +00:00
parent 4cfcc7ae7b
commit fa41b6ffe3
7 changed files with 87 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -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

23
compiler/pdecobj.pas
View File

@ -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.

8
compiler/pdecsub.pas
View File

@ -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);

8
compiler/pdecvar.pas
View File

@ -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);

45
compiler/ptype.pas
View File

@ -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);

39
tests/test/tgeneric29.pp Normal file
View File

@ -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.

2
tests/webtbs/tw11431.pp
View File

@ -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