paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-17 19:49:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

* patch by Aleksa Todorovic which adds the ability to reference current generic class. Each reference to current generic class is "translated" to appropriate specialization of that generic class. There are two tests as part of the patch to test that it works. The patch, also, rejects declaring generic inside another generic. 0010479 is easy to implement with this patch applied, resolves #11777

Browse Source 
git-svn-id: trunk@16423 -
This commit is contained in:
florian 2010-11-24 21:57:41 +00:00
parent 1f61b5b30c
commit d30952b408
14 changed files with 549 additions and 377 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -9279,6 +9279,8 @@ tests/test/tgeneric18.pp svneol=native#text/pascal
tests/test/tgeneric19.pp svneol=native#text/pascal
tests/test/tgeneric2.pp svneol=native#text/plain
tests/test/tgeneric20.pp svneol=native#text/pascal
tests/test/tgeneric21.pp svneol=native#text/pascal
tests/test/tgeneric22.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

4
compiler/fmodule.pas
View File

@ -579,6 +579,8 @@ implementation
begin
current_procinfo:=nil;
current_objectdef:=nil;
current_genericdef:=nil;
current_specializedef:=nil;
end;
{ release procinfo tree }
while assigned(procinfo) do
@ -659,6 +661,8 @@ implementation
begin
current_procinfo:=nil;
current_objectdef:=nil;
current_genericdef:=nil;
current_specializedef:=nil;
end;
{ release procinfo tree }
while assigned(procinfo) do

5
compiler/msg/errore.msg
View File

@ -1336,6 +1336,11 @@ parser_e_no_procvarnested_const=03296_E_Typed constants of the type 'procedure i
% procedural variable contains a reference to a nested procedure/function.
% Therefore such typed constants can only be initialized with global
% functions/procedures since these do not require a parent frame pointer.
parser_f_no_generic_inside_generic=03297_F_Declaration of generic class inside another generic class is not allowed
% At the moment, scanner supports recording of only one token buffer at the time
% (guarded by internal error 200511173 in tscannerfile.startrecordtokens).
% Since generics are implemented by recording tokens, it is not possible to
% have declaration of generic class inside another generic class.
% \end{description}
#
# Type Checking

5
compiler/msgidx.inc
View File

@ -385,6 +385,7 @@ const
parser_e_objc_enumerator_2_0=03294;
parser_e_objc_missing_enumeration_defs=03295;
parser_e_no_procvarnested_const=03296;
parser_f_no_generic_inside_generic=03297;
type_e_mismatch=04000;
type_e_incompatible_types=04001;
type_e_not_equal_types=04002;
@ -870,9 +871,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 57808;
MsgTxtSize = 57889;
MsgIdxMax : array[1..20] of longint=(
24,88,297,97,82,54,111,22,202,63,
24,88,298,97,82,54,111,22,202,63,
49,20,1,1,1,1,1,1,1,1
);

738
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

4
compiler/parser.pas
View File

@ -65,6 +65,8 @@ implementation
current_asmdata:=nil;
current_procinfo:=nil;
current_objectdef:=nil;
current_genericdef:=nil;
current_specializedef:=nil;
loaded_units:=TLinkedList.Create;
@ -137,6 +139,8 @@ implementation
current_procinfo:=nil;
current_asmdata:=nil;
current_objectdef:=nil;
current_genericdef:=nil;
current_specializedef:=nil;
{ unload units }
if assigned(loaded_units) then

3
compiler/pdecl.pas
View File

@ -443,6 +443,9 @@ implementation
{ Generic type declaration? }
if isgeneric then
begin
if assigned(current_genericdef) then
Message(parser_f_no_generic_inside_generic);
consume(_LSHARPBRACKET);
generictypelist:=parse_generic_parameters;
consume(_RSHARPBRACKET);

15
compiler/pdecobj.pas
View File

@ -945,10 +945,16 @@ implementation
function object_dec(objecttype:tobjecttyp;const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList;fd : tobjectdef) : tobjectdef;
var
old_current_objectdef : tobjectdef;
old_current_genericdef : tobjectdef;
old_current_specializedef : tobjectdef;
begin
old_current_objectdef:=current_objectdef;
old_current_genericdef:=current_genericdef;
old_current_specializedef:=current_specializedef;
current_objectdef:=nil;
current_genericdef:=nil;
current_specializedef:=nil;
{ objects and class types can't be declared local }
if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable,objectsymtable]) and
@ -1002,6 +1008,13 @@ implementation
end;
end;
{ usage of specialized type inside its generic template }
if assigned(genericdef) then
current_specializedef:=current_objectdef
{ reject declaration of generic class inside generic class }
else if assigned(genericlist) then
current_genericdef:=current_objectdef;
{ set published flag in $M+ mode, it can also be inherited and will
be added when the parent class set with tobjectdef.set_parent (PFV) }
if (cs_generate_rtti in current_settings.localswitches) and
@ -1068,6 +1081,8 @@ implementation
{ restore old state }
current_objectdef:=old_current_objectdef;
current_genericdef:=old_current_genericdef;
current_specializedef:=old_current_specializedef;
end;
end.

24
compiler/pdecsub.pas
View File

@ -735,7 +735,9 @@ implementation
popclass : boolean;
ImplIntf : TImplementedInterface;
old_parse_generic : boolean;
old_current_objectdef: tobjectdef;
old_current_objectdef,
old_current_genericdef,
old_current_specializedef : tobjectdef;
begin
{ Save the position where this procedure really starts }
procstartfilepos:=current_tokenpos;
@ -1003,7 +1005,13 @@ implementation
begin
symtablestack.push(pd._class.symtable);
old_current_objectdef:=current_objectdef;
old_current_genericdef:=current_genericdef;
old_current_specializedef:=current_specializedef;
current_objectdef:=pd._class;
if assigned(current_objectdef) and (df_generic in current_objectdef.defoptions) then
current_genericdef:=current_objectdef;
if assigned(current_objectdef) and (df_specialization in current_objectdef.defoptions) then
current_specializedef:=current_objectdef;
popclass:=true;
end;
{ Add parameter symtable }
@ -1015,6 +1023,8 @@ implementation
if popclass then
begin
current_objectdef:=old_current_objectdef;
current_genericdef:=old_current_genericdef;
current_specializedef:=old_current_specializedef;
symtablestack.pop(pd._class.symtable);
end;
end;
@ -1030,7 +1040,9 @@ implementation
locationstr: string;
old_parse_generic,
popclass: boolean;
old_current_objectdef: tobjectdef;
old_current_objectdef,
old_current_genericdef,
old_current_specializedef: tobjectdef;
begin
locationstr:='';
pd:=nil;
@ -1057,7 +1069,13 @@ implementation
popclass:=true;
parse_generic:=(df_generic in pd._class.defoptions);
old_current_objectdef:=current_objectdef;
old_current_genericdef:=current_genericdef;
old_current_specializedef:=current_specializedef;
current_objectdef:=pd._class;
if assigned(current_objectdef) and (df_generic in current_objectdef.defoptions) then
current_genericdef:=current_objectdef;
if assigned(current_objectdef) and (df_specialization in current_objectdef.defoptions) then
current_specializedef:=current_objectdef;
end;
single_type(pd.returndef,false,false);
@ -1067,6 +1085,8 @@ implementation
if popclass then
begin
current_objectdef:=old_current_objectdef;
current_genericdef:=old_current_genericdef;
current_specializedef:=old_current_specializedef;
symtablestack.pop(pd._class.symtable);
end;
dec(testcurobject);

26
compiler/psub.pas
View File

@ -806,7 +806,9 @@ implementation
old_current_procinfo : tprocinfo;
oldmaxfpuregisters : longint;
oldfilepos : tfileposinfo;
old_current_objectdef : tobjectdef;
old_current_objectdef,
old_current_genericdef,
old_current_specializedef : tobjectdef;
templist : TAsmList;
headertai : tai;
i : integer;
@ -1400,14 +1402,22 @@ implementation
old_current_procinfo : tprocinfo;
old_block_type : tblock_type;
st : TSymtable;
old_current_objectdef : tobjectdef;
old_current_objectdef,
old_current_genericdef,
old_current_specializedef : tobjectdef;
begin
old_current_procinfo:=current_procinfo;
old_block_type:=block_type;
old_current_objectdef:=current_objectdef;
old_current_genericdef:=current_genericdef;
old_current_specializedef:=current_specializedef;
current_procinfo:=self;
current_objectdef:=procdef._class;
if assigned(current_objectdef) and (df_generic in current_objectdef.defoptions) then
current_genericdef:=current_objectdef;
if assigned(current_objectdef) and (df_specialization in current_objectdef.defoptions) then
current_specializedef:=current_objectdef;
{ calculate the lexical level }
if procdef.parast.symtablelevel>maxnesting then
@ -1514,6 +1524,8 @@ implementation
{$endif state_tracking}
current_objectdef:=old_current_objectdef;
current_genericdef:=old_current_genericdef;
current_specializedef:=old_current_specializedef;
current_procinfo:=old_current_procinfo;
{ Restore old state }
@ -1657,7 +1669,9 @@ implementation
var
old_current_procinfo : tprocinfo;
old_current_objectdef : tobjectdef;
old_current_objectdef,
old_current_genericdef,
old_current_specializedef : tobjectdef;
pdflags : tpdflags;
pd,firstpd : tprocdef;
s : string;
@ -1665,11 +1679,15 @@ implementation
{ save old state }
old_current_procinfo:=current_procinfo;
old_current_objectdef:=current_objectdef;
old_current_genericdef:=current_genericdef;
old_current_specializedef:=current_specializedef;
{ reset current_procinfo.procdef to nil to be sure that nothing is writing
to another procdef }
current_procinfo:=nil;
current_objectdef:=nil;
current_genericdef:=nil;
current_specializedef:=nil;
{ parse procedure declaration }
pd:=parse_proc_dec(isclassmethod, old_current_objectdef);
@ -1798,6 +1816,8 @@ implementation
end;
current_objectdef:=old_current_objectdef;
current_genericdef:=old_current_genericdef;
current_specializedef:=old_current_specializedef;
current_procinfo:=old_current_procinfo;
end;

20
compiler/ptype.pas
View File

@ -492,7 +492,15 @@ implementation
generate_specialization(def)
else
begin
if (df_generic in def.defoptions) then
if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
begin
def:=current_specializedef
end
else if (def=current_genericdef) then
begin
def:=current_genericdef
end
else if (df_generic in def.defoptions) then
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;
@ -633,7 +641,15 @@ implementation
generate_specialization(def)
else
begin
if (df_generic in def.defoptions) then
if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
begin
def:=current_specializedef
end
else if (def=current_genericdef) then
begin
def:=current_genericdef
end
else if (df_generic in def.defoptions) then
begin
Message(parser_e_no_generics_as_types);
def:=generrordef;

2
compiler/symdef.pas
View File

@ -632,6 +632,8 @@ interface
var
current_objectdef : tobjectdef; { used for private functions check !! }
current_genericdef : tobjectdef; { used to reject declaration of generic class inside generic class }
current_specializedef : tobjectdef; { used to implement usage of generic class in itself }
{ default types }
generrordef, { error in definition }

12
tests/test/tgeneric21.pp Normal file
View File

@ -0,0 +1,12 @@
{ %fail }
{$mode objfpc}{$H+}
type
generic TOuter<T> = class(TObject)
public type
generic TInner<U> = class(TObject)
end;
end;
begin
end.

66
tests/test/tgeneric22.pp Normal file
View File

@ -0,0 +1,66 @@
{$mode objfpc}{$H+}
type
generic TGListItem<T> = class(TObject)
public var
FValue: T;
FNext: TGListItem;
procedure SetValue(Value: T);
function GetValue: T;
procedure Assign(Source: TGListItem);
function Merge(Other: TGListItem): TGListItem;
end;
procedure TGListItem.SetValue(Value: T);
begin
FValue := Value;
end;
function TGListItem.GetValue: T;
begin
Result := FValue;
end;
procedure TGListItem.Assign(Source: TGListItem);
begin
FNext := Source;
end;
function TGListItem.Merge(Other: TGListItem): TGListItem;
var
Temp: TGListItem;
begin
Temp := TGListItem.Create;
Temp.SetValue(FNext.GetValue + Other.FNext.GetValue);
Result := Temp;
end;
type
TIntListItem = specialize TGListItem<Integer>;
var
A, A2, B, B2: TIntListItem;
begin
A := TIntListItem.Create;
A2 := TIntListItem.Create;
A.Assign(A2);
if A.FNext <> A2 then
halt(1);
B := TIntListItem.Create;
B2 := TIntListItem.Create;
B.Assign(B2);
if B.FNext <> B2 then
halt(1);
A2.SetValue(5);
if A2.GetValue <> 5 then
halt(1);
B2.SetValue(7);
if B2.GetValue <> 7 then
halt(1);
if A.Merge(B).GetValue <> 12 then
halt(1);
end.