Fix for Mantis #21350

+ pgenutil.pas: 
    add a procedure which adds a type symbol to a non-Delphi-mode generic class or record which has the same name as the unit global dummy symbol for that generic. I don't know why I had that idea earlier as this will simplify some of the conditions in the parser again (I haven't changed these yet, but I hope to do that at least when I start working on generic functions).
* pgenutil.pas, generate_specialization:
    correctly handle "specialize TSomeGeneric<T>" as method parameter in a generic with the newly added rename symbol
* pdecobj.pas, object_dec & ptype.pas, record_dec: 
    call the procedure to add the rename symbol (the procedure checks whether the mode is correct)
* ppu.pas: 
    increase PPU version so that we don't use non-Delphi mode units with generics, but without the rename symbol
+ added tests:
    the one in webtbs are for classes/objects and those in test are for records

git-svn-id: trunk@21603 -
This commit is contained in:
svenbarth 2012-06-14 07:07:28 +00:00
parent e8c7635d49
commit d2fabd2a22
9 changed files with 247 additions and 3 deletions

4
.gitattributes vendored
View File

@ -10712,6 +10712,8 @@ tests/test/tgeneric72.pp svneol=native#text/pascal
tests/test/tgeneric73.pp svneol=native#text/pascal
tests/test/tgeneric74.pp svneol=native#text/pascal
tests/test/tgeneric75.pp svneol=native#text/pascal
tests/test/tgeneric76.pp svneol=native#text/pascal
tests/test/tgeneric77.pp svneol=native#text/pascal
tests/test/tgeneric8.pp svneol=native#text/plain
tests/test/tgeneric9.pp svneol=native#text/plain
tests/test/tgoto.pp svneol=native#text/plain
@ -12599,6 +12601,8 @@ tests/webtbs/tw2128.pp svneol=native#text/plain
tests/webtbs/tw2129.pp svneol=native#text/plain
tests/webtbs/tw2129b.pp svneol=native#text/plain
tests/webtbs/tw2131.pp svneol=native#text/plain
tests/webtbs/tw21350a.pp svneol=native#text/pascal
tests/webtbs/tw21350b.pp svneol=native#text/pascal
tests/webtbs/tw21443.pp svneol=native#text/plain
tests/webtbs/tw2145.pp svneol=native#text/plain
tests/webtbs/tw21457.pp svneol=native#text/pascal

View File

@ -1409,6 +1409,10 @@ implementation
include(current_structdef.defoptions, df_generic);
parse_generic:=(df_generic in current_structdef.defoptions);
{ in non-Delphi modes we need a strict private symbol without type
count and type parameters in the name to simply resolving }
maybe_insert_generic_rename_symbol(n,genericlist);
{ parse list of parent classes }
{ for record helpers in mode Delphi this is not allowed }
if not (is_objectpascal_helper(current_objectdef) and

View File

@ -29,12 +29,15 @@ interface
uses
{ common }
cclasses,
{ global }
globtype,
{ symtable }
symtype,symdef,symbase;
procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string);
function parse_generic_parameters:TFPObjectList;
procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList);
procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfpobjectlist);
type
tspecializationstate = record
@ -51,7 +54,7 @@ uses
{ common }
cutils,fpccrc,
{ global }
globals,globtype,tokens,verbose,
globals,tokens,verbose,
{ symtable }
symconst,symsym,symtable,
{ modules }
@ -257,7 +260,8 @@ uses
genname:=symname;
{ in case of non-Delphi mode the type name could already be a generic
def (but maybe the wrong one) }
if assigned(genericdef) and (df_generic in genericdef.defoptions) then
if assigned(genericdef) and
([df_generic,df_specialization]*genericdef.defoptions<>[]) then
begin
{ remove the type count suffix from the generic's name }
for i:=Length(genname) downto 1 do
@ -266,6 +270,15 @@ uses
genname:=copy(genname,1,i-1);
break;
end;
{ in case of a specialization we've only reached the specialization
checksum yet }
if df_specialization in genericdef.defoptions then
for i:=length(genname) downto 1 do
if genname[i]='$' then
begin
genname:=copy(genname,1,i-1);
break;
end;
end;
genname:=genname+'$'+countstr;
ugenname:=upper(genname);
@ -587,6 +600,40 @@ uses
end;
end;
procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfpobjectlist);
var
gensym : ttypesym;
begin
{ for generics in non-Delphi modes we insert a private type symbol
that has the same base name as the currently parsed generic and
that references this defs }
if not (m_delphi in current_settings.modeswitches) and
(
(
parse_generic and
assigned(genericlist) and
(genericlist.count>0)
) or
(
assigned(current_specializedef) and
assigned(current_structdef.genericdef) and
(current_structdef.genericdef.typ in [objectdef,recorddef]) and
(pos('$',name)>0)
)
) then
begin
{ we need to pass nil as def here, because the constructor wants
to set the typesym of the def which is not what we want }
gensym:=ttypesym.create(copy(name,1,pos('$',name)-1),nil);
gensym.typedef:=current_structdef;
include(gensym.symoptions,sp_internal);
{ the symbol should be only visible to the generic class
itself }
gensym.visibility:=vis_strictprivate;
symtablestack.top.insert(gensym);
end;
end;
procedure specialization_init(genericdef:tdef;var state: tspecializationstate);
var
pu : tused_unit;

View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion = 150;
CurrentPPUVersion = 151;
{ buffer sizes }
maxentrysize = 1024;

View File

@ -775,6 +775,10 @@ implementation
if old_parse_generic then
include(current_structdef.defoptions, df_generic);
parse_generic:=(df_generic in current_structdef.defoptions);
{ in non-Delphi modes we need a strict private symbol without type
count and type parameters in the name to simply resolving }
maybe_insert_generic_rename_symbol(n,genericlist);
if m_advanced_records in current_settings.modeswitches then
begin
parse_record_members;

45
tests/test/tgeneric76.pp Normal file
View File

@ -0,0 +1,45 @@
{$mode delphi}
unit tgeneric76;
interface
type
{ TPointEx }
TPointEx<T> = record
X, Y: T;
function Create(const AX, AY: T): TPointEx<T>;
class procedure Swap(var A, B: TPointEx<T>); static;
class procedure OrderByY(var A, B: TPointEx<T>); static;
end;
TPoint = TPointEx<integer>;
TPointF = TPointEx<single>;
implementation
function TPointEx<T>.Create(const AX, AY: T): TPointEx<T>;
begin
result.X:=AX;
result.Y:=AY;
end;
class procedure TPointEx<T>.Swap(var A, B: TPointEx<T>);
var
tmp: TPointEx<T>;
begin
tmp:=A;
A:=B;
B:=tmp;
end;
class procedure TPointEx<T>.OrderByY(var A, B: TPointEx<T>);
begin
if A.Y > B.Y then
TPointEx<T>.Swap(A,B);
end;
end.

48
tests/test/tgeneric77.pp Normal file
View File

@ -0,0 +1,48 @@
{$mode objfpc}{$h+}
{$modeswitch advancedrecords}
unit tgeneric77;
interface
type
{ TPointEx }
generic TPointEx<T> = record
X, Y: T;
function Create(const AX, AY: T): TPointEx;
class procedure Swap(var A, B: TPointEx); static;
class procedure OrderByY(var A, B: TPointEx); static;
end;
//TPoint = specialize TPointEx<integer>;
TPointF = specialize TPointEx<single>;
implementation
{ TPoint<T> }
function TPointEx.Create(const AX, AY: T): TPointEx;
begin
result.X:=AX;
result.Y:=AY;
end;
class procedure TPointEx.Swap(var A, B: TPointEx);
var
tmp: TPointEx;
begin
tmp:=A;
A:=B;
B:=tmp;
end;
class procedure TPointEx.OrderByY(var A, B: TPointEx);
begin
if A.Y > B.Y then
TPointEx.Swap(A,B);
end;
end.

45
tests/webtbs/tw21350a.pp Normal file
View File

@ -0,0 +1,45 @@
{$mode delphi}
unit tw21350a;
interface
type
{ TPointEx }
TPointEx<T> = object
X, Y: T;
function Create(const AX, AY: T): TPointEx<T>;
class procedure Swap(var A, B: TPointEx<T>); static;
class procedure OrderByY(var A, B: TPointEx<T>); static;
end;
TPoint = TPointEx<integer>;
TPointF = TPointEx<single>;
implementation
function TPointEx<T>.Create(const AX, AY: T): TPointEx<T>;
begin
result.X:=AX;
result.Y:=AY;
end;
class procedure TPointEx<T>.Swap(var A, B: TPointEx<T>);
var
tmp: TPointEx<T>;
begin
tmp:=A;
A:=B;
B:=tmp;
end;
class procedure TPointEx<T>.OrderByY(var A, B: TPointEx<T>);
begin
if A.Y > B.Y then
TPointEx<T>.Swap(A,B);
end;
end.

47
tests/webtbs/tw21350b.pp Normal file
View File

@ -0,0 +1,47 @@
{$mode objfpc}{$h+}
unit tw21350b;
interface
type
{ TPointEx }
generic TPointEx<T> = object
X, Y: T;
function Create(const AX, AY: T): TPointEx;
class procedure Swap(var A, B: TPointEx); static;
class procedure OrderByY(var A, B: TPointEx); static;
end;
//TPoint = specialize TPointEx<integer>;
TPointF = specialize TPointEx<single>;
implementation
{ TPoint<T> }
function TPointEx.Create(const AX, AY: T): TPointEx;
begin
result.X:=AX;
result.Y:=AY;
end;
class procedure TPointEx.Swap(var A, B: TPointEx);
var
tmp: TPointEx;
begin
tmp:=A;
A:=B;
B:=tmp;
end;
class procedure TPointEx.OrderByY(var A, B: TPointEx);
begin
if A.Y > B.Y then
TPointEx.Swap(A,B);
end;
end.