diff --git a/.gitattributes b/.gitattributes index dbfc856873..96e3e1c487 100644 --- a/.gitattributes +++ b/.gitattributes @@ -10717,6 +10717,8 @@ 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/tgeneric78.pp svneol=native#text/pascal +tests/test/tgeneric79.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 @@ -12591,6 +12593,8 @@ tests/webtbs/tw20995b.pp svneol=native#text/pascal tests/webtbs/tw20998.pp svneol=native#text/pascal tests/webtbs/tw21029.pp svneol=native#text/plain tests/webtbs/tw21044.pp svneol=native#text/pascal +tests/webtbs/tw21064a.pp svneol=native#text/pascal +tests/webtbs/tw21064b.pp svneol=native#text/pascal tests/webtbs/tw21073.pp svneol=native#text/plain tests/webtbs/tw2109.pp svneol=native#text/plain tests/webtbs/tw21091.pp svneol=native#text/pascal diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index 2fffdba62d..ad954a1b05 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -106,7 +106,7 @@ implementation objcutil, { parser } scanner, - pbase,pexpr,ptype,pdecl,pparautl + pbase,pexpr,ptype,pdecl,pparautl,pgenutil {$ifdef jvm} ,pjvm {$endif} @@ -680,8 +680,44 @@ implementation Message1(type_e_generic_declaration_does_not_match,genname); srsym:=nil; exit; + end + end; + end; + + procedure consume_generic_interface; + var + genparalist : tfpobjectlist; + prettyname, + specializename : ansistring; + genname, + ugenname : tidstring; + gencount : string; + begin + consume(_LSHARPBRACKET); + genparalist:=tfpobjectlist.create(false); + + if not parse_generic_specialization_types(genparalist,prettyname,specializename,nil) then + srsym:=generrorsym + else + begin + str(genparalist.count,gencount); + genname:=sp+'$'+gencount; + if not parse_generic then + genname:=generate_generic_name(genname,specializename); + ugenname:=upper(genname); + + srsym:=search_object_name(ugenname,false); + + if not assigned(srsym) then + begin + Message1(type_e_generic_declaration_does_not_match,sp+'<'+prettyname+'>'); + srsym:=nil; + exit; end; end; + + genparalist.free; + consume(_RSHARPBRACKET); end; begin @@ -700,16 +736,35 @@ implementation (astruct.typ=objectdef) and assigned(tobjectdef(astruct).ImplementedInterfaces) and (tobjectdef(astruct).ImplementedInterfaces.count>0) and - try_to_consume(_POINT) then + ( + (token = _POINT) or + (token = _LSHARPBRACKET) + ) then begin - srsym:=search_object_name(sp,true); + if token = _POINT then + begin + consume(_POINT); + srsym:=search_object_name(sp,true); + end + else + begin + consume_generic_interface; + consume(_POINT); + { srsym is now either an interface def or generrordef } + end; { qualifier is interface? } ImplIntf:=nil; if (srsym.typ=typesym) and (ttypesym(srsym).typedef.typ=objectdef) then ImplIntf:=tobjectdef(astruct).find_implemented_interface(tobjectdef(ttypesym(srsym).typedef)); if ImplIntf=nil then - Message(parser_e_interface_id_expected); + Message(parser_e_interface_id_expected) + else + { in case of a generic or specialized interface we need to use the + name of the def instead of the symbol, so that always the correct + name is used } + if [df_generic,df_specialization]*ttypesym(srsym).typedef.defoptions<>[] then + sp:=tobjectdef(ttypesym(srsym).typedef).objname^; { must be a directly implemented interface } if Assigned(ImplIntf.ImplementsGetter) then Message2(parser_e_implements_no_mapping,ImplIntf.IntfDef.typename,astruct.objrealname^); diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas index c26c0b0ada..a753a311de 100644 --- a/compiler/pgenutil.pas +++ b/compiler/pgenutil.pas @@ -36,8 +36,10 @@ uses procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string); function parse_generic_parameters:TFPObjectList; + function parse_generic_specialization_types(genericdeflist:tfpobjectlist;out prettyname,specializename:ansistring;parsedtype:tdef):boolean; procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList); procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfpobjectlist); + function generate_generic_name(const name:tidstring;specializename:ansistring):tidstring; type tspecializationstate = record @@ -190,59 +192,7 @@ uses genericdeflist:=TFPObjectList.Create(false); { Parse type parameters } - err:=false; - { set the block type to type, so that the parsed type are returned as - ttypenode (e.g. classes are in non type-compatible blocks returned as - tloadvmtaddrnode) } - old_block_type:=block_type; - { if parsedtype is set, then the first type identifer was already parsed - (happens in inline specializations) and thus we only need to parse - the remaining types and do as if the first one was already given } - first:=not assigned(parsedtype); - if assigned(parsedtype) then - begin - genericdeflist.Add(parsedtype); - specializename:='$'+parsedtype.typename; - prettyname:=parsedtype.typesym.prettyname; - end - else - begin - specializename:=''; - prettyname:=''; - end; - while not (token in [_GT,_RSHARPBRACKET]) do - begin - { "first" is set to false at the end of the loop! } - if not first then - consume(_COMMA); - block_type:=bt_type; - pt2:=factor(false,true); - if pt2.nodetype=typen then - begin - if df_generic in pt2.resultdef.defoptions then - Message(parser_e_no_generics_as_params); - genericdeflist.Add(pt2.resultdef); - if not assigned(pt2.resultdef.typesym) then - message(type_e_generics_cannot_reference_itself) - else - begin - specializename:=specializename+'$'+pt2.resultdef.typename; - if first then - prettyname:=prettyname+pt2.resultdef.typesym.prettyname - else - prettyname:=prettyname+','+pt2.resultdef.typesym.prettyname; - end; - end - else - begin - Message(type_e_type_id_expected); - err:=true; - end; - pt2.free; - first:=false; - end; - block_type:=old_block_type; - + err:=not parse_generic_specialization_types(genericdeflist,prettyname,specializename,parsedtype); if err then begin try_to_consume(_RSHARPBRACKET); @@ -305,8 +255,7 @@ uses genericdef:=tstoreddef(ttypesym(srsym).typedef); { build the new type's name } - crc:=UpdateCrc32(0,specializename[1],length(specializename)); - finalspecializename:=genname+'$crc'+hexstr(crc,8); + finalspecializename:=generate_generic_name(genname,specializename); ufinalspecializename:=upper(finalspecializename); prettyname:=genericdef.typesym.prettyname+'<'+prettyname+'>'; @@ -570,6 +519,67 @@ uses until not try_to_consume(_COMMA) ; end; + function parse_generic_specialization_types(genericdeflist:tfpobjectlist;out prettyname,specializename:ansistring;parsedtype:tdef):boolean; + var + old_block_type : tblock_type; + first : boolean; + typeparam : tnode; + begin + result:=true; + if genericdeflist=nil then + internalerror(2012061401); + { set the block type to type, so that the parsed type are returned as + ttypenode (e.g. classes are in non type-compatible blocks returned as + tloadvmtaddrnode) } + old_block_type:=block_type; + { if parsedtype is set, then the first type identifer was already parsed + (happens in inline specializations) and thus we only need to parse + the remaining types and do as if the first one was already given } + first:=not assigned(parsedtype); + if assigned(parsedtype) then + begin + genericdeflist.Add(parsedtype); + specializename:='$'+parsedtype.typename; + prettyname:=parsedtype.typesym.prettyname; + end + else + begin + specializename:=''; + prettyname:=''; + end; + while not (token in [_GT,_RSHARPBRACKET]) do + begin + { "first" is set to false at the end of the loop! } + if not first then + consume(_COMMA); + block_type:=bt_type; + typeparam:=factor(false,true); + if typeparam.nodetype=typen then + begin + if df_generic in typeparam.resultdef.defoptions then + Message(parser_e_no_generics_as_params); + genericdeflist.Add(typeparam.resultdef); + if not assigned(typeparam.resultdef.typesym) then + message(type_e_generics_cannot_reference_itself) + else + begin + specializename:=specializename+'$'+typeparam.resultdef.typename; + if first then + prettyname:=prettyname+typeparam.resultdef.typesym.prettyname + else + prettyname:=prettyname+','+typeparam.resultdef.typesym.prettyname; + end; + end + else + begin + Message(type_e_type_id_expected); + result:=false; + end; + typeparam.free; + first:=false; + end; + block_type:=old_block_type; + end; procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList); var @@ -634,6 +644,17 @@ uses end; end; + function generate_generic_name(const name:tidstring;specializename:ansistring):tidstring; + var + crc : cardinal; + begin + if specializename='' then + internalerror(2012061901); + { build the new type's name } + crc:=UpdateCrc32(0,specializename[1],length(specializename)); + result:=name+'$crc'+hexstr(crc,8); + end; + procedure specialization_init(genericdef:tdef;var state: tspecializationstate); var pu : tused_unit; diff --git a/tests/test/tgeneric78.pp b/tests/test/tgeneric78.pp new file mode 100644 index 0000000000..4addc2b12e --- /dev/null +++ b/tests/test/tgeneric78.pp @@ -0,0 +1,27 @@ +{ %NORUN } + +{ additional test based on 21064 } +program tgeneric78; + +{$mode delphi} + +type + IGenericIntf = interface + function SomeMethod: T; + end; + + TGenericClass = class(TInterfacedObject, IGenericIntf) + private + protected + function GenericIntf_SomeMethod: LongInt; + function IGenericIntf.SomeMethod = GenericIntf_SomeMethod; + end; + +function TGenericClass.GenericIntf_SomeMethod: LongInt; +begin +end; + +type + TGenericClassLongInt = TGenericClass; +begin +end. diff --git a/tests/test/tgeneric79.pp b/tests/test/tgeneric79.pp new file mode 100644 index 0000000000..da94c73e20 --- /dev/null +++ b/tests/test/tgeneric79.pp @@ -0,0 +1,27 @@ +{ %NORUN } + +{ additional test based on 21064 } +program tgeneric79; + +{$mode objfpc} + +type + generic IGenericIntf = interface + function SomeMethod: T; + end; + + generic TGenericClass = class(TInterfacedObject, specialize IGenericIntf) + private + protected + function GenericIntf_SomeMethod: LongInt; + function IGenericIntf.SomeMethod = GenericIntf_SomeMethod; + end; + +function TGenericClass.GenericIntf_SomeMethod: LongInt; +begin +end; + +type + TGenericClassLongInt = specialize TGenericClass; +begin +end. diff --git a/tests/webtbs/tw21064a.pp b/tests/webtbs/tw21064a.pp new file mode 100644 index 0000000000..e813aab427 --- /dev/null +++ b/tests/webtbs/tw21064a.pp @@ -0,0 +1,26 @@ +{ %NORUN } + +program tw21064a; + +{$mode delphi} + +type + IGenericIntf = interface + function SomeMethod: T; + end; + + TGenericClass = class(TInterfacedObject, IGenericIntf) + private + protected + function GenericIntf_SomeMethod: T; + function IGenericIntf.SomeMethod = GenericIntf_SomeMethod; + end; + +function TGenericClass.GenericIntf_SomeMethod: T; +begin +end; + +type + TGenericClassLongInt = TGenericClass; +begin +end. diff --git a/tests/webtbs/tw21064b.pp b/tests/webtbs/tw21064b.pp new file mode 100644 index 0000000000..64be8cc69c --- /dev/null +++ b/tests/webtbs/tw21064b.pp @@ -0,0 +1,28 @@ +{ %NORUN } + +program tw21064b; + +{$mode delphi} + +type + IGenericIntf = interface + function SomeMethod: T; + end; + + TGenericClass = class(TInterfacedObject, IGenericIntf) + private + type + IntfType = IGenericIntf; + protected + function GenericIntf_SomeMethod: T; + function IntfType.SomeMethod = GenericIntf_SomeMethod; + end; + +function TGenericClass.GenericIntf_SomeMethod: T; +begin +end; + +type + TGenericClassLongInt = TGenericClass; +begin +end.