From e050a019a278827a3ae9c0a32cdcb2dde00ce50d Mon Sep 17 00:00:00 2001 From: Sven/Sarah Barth Date: Fri, 28 Oct 2022 17:40:53 +0200 Subject: [PATCH] * fix #29859: ensure that it's correctly passed down into generate_specialization whether a unit name was provided for the specialization and if so search the generic only in that unit + added tests --- compiler/nbas.pas | 8 +++-- compiler/pdecsub.pas | 11 ++++++- compiler/pexpr.pas | 43 +++++++++++++++------------ compiler/pgenutil.pas | 60 ++++++++++++++++++++++++++------------ compiler/ptype.pas | 22 ++++++++------ tests/test/tgeneric108.pp | 49 +++++++++++++++++++++++++++++++ tests/test/tgeneric109.pp | 32 ++++++++++++++++++++ tests/test/tgeneric110.pp | 49 +++++++++++++++++++++++++++++++ tests/test/tgeneric111.pp | 49 +++++++++++++++++++++++++++++++ tests/test/ugeneric108a.pp | 28 ++++++++++++++++++ tests/test/ugeneric108b.pp | 28 ++++++++++++++++++ tests/webtbs/tw29859.pp | 17 +++++++++++ tests/webtbs/uw29859a.pp | 22 ++++++++++++++ tests/webtbs/uw29859b.pp | 22 ++++++++++++++ 14 files changed, 389 insertions(+), 51 deletions(-) create mode 100644 tests/test/tgeneric108.pp create mode 100644 tests/test/tgeneric109.pp create mode 100644 tests/test/tgeneric110.pp create mode 100644 tests/test/tgeneric111.pp create mode 100644 tests/test/ugeneric108a.pp create mode 100644 tests/test/ugeneric108b.pp create mode 100644 tests/webtbs/tw29859.pp create mode 100644 tests/webtbs/uw29859a.pp create mode 100644 tests/webtbs/uw29859b.pp diff --git a/compiler/nbas.pas b/compiler/nbas.pas index 308c643c09..96ab1891e1 100644 --- a/compiler/nbas.pas +++ b/compiler/nbas.pas @@ -55,7 +55,8 @@ interface sym:tsym; getaddr:boolean; inheriteddef:tdef; - constructor create(l:tnode;g:boolean;s:tsym);virtual; + unit_specific:boolean; + constructor create(l:tnode;g:boolean;s:tsym;u:boolean);virtual; constructor create_inherited(l:tnode;g:boolean;s:tsym;i:tdef);virtual; function pass_1:tnode;override; function pass_typecheck:tnode;override; @@ -485,16 +486,17 @@ implementation TSPECIALIZENODE *****************************************************************************} - constructor tspecializenode.create(l:tnode;g:boolean;s:tsym); + constructor tspecializenode.create(l:tnode;g:boolean;s:tsym;u:boolean); begin inherited create(specializen,l); sym:=s; getaddr:=g; + unit_specific:=u; end; constructor tspecializenode.create_inherited(l:tnode;g:boolean;s:tsym;i:tdef); begin - create(l,g,s); + create(l,g,s,false); inheriteddef:=i; end; diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index d891be0086..ce3a84ae38 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -707,6 +707,7 @@ implementation sym : ttypesym; typesrsym : tsym; typesrsymtable : tsymtable; + hierarchy, specializename, prettyname: ansistring; error : boolean; @@ -758,7 +759,15 @@ implementation exit; end; - genname:=generate_generic_name(sp,specializename,ttypesym(typesrsym).typedef.ownerhierarchyname); + module:=find_module_from_symtable(ttypesym(typesrsym).owner); + if not assigned(module) then + internalerror(2022102105); + + hierarchy:=ttypesym(typesrsym).typedef.ownerhierarchyname; + if hierarchy<>'' then + hierarchy:='.'+hierarchy; + + genname:=generate_generic_name(sp,specializename,module.modulename^+hierarchy); ugenname:=upper(genname); srsym:=search_object_name(ugenname,false); diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 32985b2c0b..f43f17884f 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -1592,7 +1592,7 @@ implementation end; - function handle_specialize_inline_specialization(var srsym:tsym;out srsymtable:tsymtable;out spezcontext:tspecializationcontext):boolean; + function handle_specialize_inline_specialization(var srsym:tsym;enforce_unit:boolean;out srsymtable:tsymtable;out spezcontext:tspecializationcontext):boolean; var spezdef : tdef; symname : tsymstr; @@ -1617,7 +1617,7 @@ implementation symname:=srsym.RealName else symname:=''; - spezdef:=generate_specialization_phase1(spezcontext,spezdef,symname,srsym.owner); + spezdef:=generate_specialization_phase1(spezcontext,spezdef,enforce_unit,symname,srsym.owner); case spezdef.typ of errordef: begin @@ -1721,7 +1721,7 @@ implementation if isspecialize then begin consume(_ID); - if not handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then + if not handle_specialize_inline_specialization(srsym,false,srsymtable,spezcontext) then begin result.free; result:=cerrornode.create; @@ -1764,7 +1764,7 @@ implementation if isspecialize and assigned(srsym) then begin consume(_ID); - if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then + if handle_specialize_inline_specialization(srsym,false,srsymtable,spezcontext) then erroroutresult:=false; end else @@ -1777,7 +1777,7 @@ implementation not (token in [_LT,_LSHARPBRACKET]) then check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg,savedfilepos) else - result:=cspecializenode.create(result,getaddr,srsym); + result:=cspecializenode.create(result,getaddr,srsym,false); erroroutresult:=false; end else @@ -2522,7 +2522,7 @@ implementation begin searchsym_in_record(structh,pattern,srsym,srsymtable); consume(_ID); - if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then + if handle_specialize_inline_specialization(srsym,false,srsymtable,spezcontext) then erroroutp1:=false; end; end @@ -2537,7 +2537,7 @@ implementation not (token in [_LT,_LSHARPBRACKET]) then check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg,old_current_filepos) else - p1:=cspecializenode.create(p1,getaddr,srsym); + p1:=cspecializenode.create(p1,getaddr,srsym,false); erroroutp1:=false; end else @@ -2698,7 +2698,7 @@ implementation begin searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,[ssf_search_helper]); consume(_ID); - if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then + if handle_specialize_inline_specialization(srsym,false,srsymtable,spezcontext) then erroroutp1:=false; end; end @@ -2713,7 +2713,7 @@ implementation not (token in [_LT,_LSHARPBRACKET]) then check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg,old_current_filepos) else - p1:=cspecializenode.create(p1,getaddr,srsym); + p1:=cspecializenode.create(p1,getaddr,srsym,false); erroroutp1:=false; end else @@ -2752,7 +2752,7 @@ implementation begin searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable,[ssf_search_helper]); consume(_ID); - if handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then + if handle_specialize_inline_specialization(srsym,false,srsymtable,spezcontext) then erroroutp1:=false; end; end @@ -2767,7 +2767,7 @@ implementation not (token in [_LT,_LSHARPBRACKET]) then check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg,old_current_filepos) else - p1:=cspecializenode.create(p1,getaddr,srsym); + p1:=cspecializenode.create(p1,getaddr,srsym,false); erroroutp1:=false; end else @@ -3052,7 +3052,7 @@ implementation begin if block_type in [bt_type,bt_const_type,bt_var_type] then begin - if not handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) or (srsym.typ=procsym) then + if not handle_specialize_inline_specialization(srsym,unit_found,srsymtable,spezcontext) or (srsym.typ=procsym) then begin spezcontext.free; result:=cerrornode.create; @@ -3071,7 +3071,7 @@ implementation end; end else - result:=cspecializenode.create(nil,getaddr,srsym) + result:=cspecializenode.create(nil,getaddr,srsym,unit_found) end else begin @@ -3108,7 +3108,7 @@ implementation (sp_generic_dummy in srsym.symoptions) and (token in [_LT,_LSHARPBRACKET]) then begin - result:=cspecializenode.create(nil,getaddr,srsym) + result:=cspecializenode.create(nil,getaddr,srsym,unit_found) end { check if it's a method/class method } else if is_member_read(srsym,srsymtable,result,hdef) then @@ -3380,9 +3380,11 @@ implementation end else begin + if not unit_found then + srsymtable:=nil; {$push} {$warn 5036 off} - hdef:=generate_specialization_phase1(spezcontext,nil,nil,orgstoredpattern,nil,dummypos); + hdef:=generate_specialization_phase1(spezcontext,nil,unit_found,nil,orgstoredpattern,srsymtable,dummypos); {$pop} if hdef=generrordef then begin @@ -3818,7 +3820,7 @@ implementation searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,[ssf_search_helper]); if isspecialize and assigned(srsym) then begin - if not handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then + if not handle_specialize_inline_specialization(srsym,false,srsymtable,spezcontext) then srsym:=nil; end; end; @@ -4406,7 +4408,8 @@ implementation function generate_inline_specialization(gendef:tdef;n:tnode;filepos:tfileposinfo;parseddef:tdef;gensym:tsym;p2:tnode):tnode; var again, - getaddr : boolean; + getaddr, + unitspecific : boolean; pload : tnode; spezcontext : tspecializationcontext; structdef, @@ -4418,6 +4421,7 @@ implementation getaddr:=tspecializenode(n).getaddr; pload:=tspecializenode(n).left; inheriteddef:=tabstractrecorddef(tspecializenode(n).inheriteddef); + unitspecific:=tspecializenode(n).unit_specific; tspecializenode(n).left:=nil; end else @@ -4425,12 +4429,13 @@ implementation getaddr:=false; pload:=nil; inheriteddef:=nil; + unitspecific:=false; end; if assigned(parseddef) and assigned(gensym) and assigned(p2) then - gendef:=generate_specialization_phase1(spezcontext,gendef,parseddef,gensym.realname,gensym.owner,p2.fileinfo) + gendef:=generate_specialization_phase1(spezcontext,gendef,unitspecific,parseddef,gensym.realname,gensym.owner,p2.fileinfo) else - gendef:=generate_specialization_phase1(spezcontext,gendef); + gendef:=generate_specialization_phase1(spezcontext,gendef,unitspecific); case gendef.typ of errordef: begin diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas index c33c8da72b..6275b59081 100644 --- a/compiler/pgenutil.pas +++ b/compiler/pgenutil.pas @@ -38,18 +38,18 @@ uses { symtable } symtype,symdef,symbase; - procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;const _prettyname:string;parsedtype:tdef;const symname:string;parsedpos:tfileposinfo);inline; - procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;const _prettyname:string);inline; - function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef):tdef;inline; - function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;const symname:string;symtable:tsymtable):tdef;inline; - function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;const symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef; + procedure generate_specialization(var tt:tdef;enforce_unit:boolean;parse_class_parent:boolean;const _prettyname:string;parsedtype:tdef;const symname:string;parsedpos:tfileposinfo);inline; + procedure generate_specialization(var tt:tdef;enforce_unit:boolean;parse_class_parent:boolean;const _prettyname:string);inline; + function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean):tdef;inline; + function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean;const symname:string;symtable:tsymtable):tdef;inline; + function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean;parsedtype:tdef;const symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef; function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;const _prettyname:ansistring):tdef; function check_generic_constraints(genericdef:tstoreddef;paramlist:tfpobjectlist;poslist:tfplist):boolean; function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist; function parse_generic_specialization_types(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean; procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist;isfwd:boolean); procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist); - function generate_generic_name(const name:tidstring;const specializename:ansistring;const owner_hierarchy:string):tidstring; + function generate_generic_name(const name:tidstring;const specializename:ansistring;const owner_hierarchy:ansistring):tidstring; procedure split_generic_name(const name:tidstring;out nongeneric:string;out count:longint); procedure add_generic_dummysym(sym:tsym); function resolve_generic_dummysym(const name:tidstring):tsym; @@ -641,12 +641,12 @@ uses end; - procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;const _prettyname:string); + procedure generate_specialization(var tt:tdef;enforce_unit:boolean;parse_class_parent:boolean;const _prettyname:string); var dummypos : tfileposinfo; begin FillChar(dummypos, SizeOf(tfileposinfo), 0); - generate_specialization(tt,parse_class_parent,_prettyname,nil,'',dummypos); + generate_specialization(tt,enforce_unit,parse_class_parent,_prettyname,nil,'',dummypos); end; @@ -1331,29 +1331,29 @@ uses callerparams.free; end; - function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef):tdef; + function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean):tdef; var dummypos : tfileposinfo; {$push} {$warn 5036 off} begin - result:=generate_specialization_phase1(context,genericdef,nil,'',nil,dummypos); + result:=generate_specialization_phase1(context,genericdef,enforce_unit,nil,'',nil,dummypos); end; {$pop} - function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;const symname:string;symtable:tsymtable):tdef; + function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean;const symname:string;symtable:tsymtable):tdef; var dummypos : tfileposinfo; {$push} {$warn 5036 off} begin - result:=generate_specialization_phase1(context,genericdef,nil,symname,symtable,dummypos); + result:=generate_specialization_phase1(context,genericdef,enforce_unit,nil,symname,symtable,dummypos); end; {$pop} - function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;const symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef; + function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;enforce_unit:boolean;parsedtype:tdef;const symname:string;symtable:tsymtable;parsedpos:tfileposinfo):tdef; var found, err : boolean; @@ -1362,6 +1362,7 @@ uses countstr,genname,ugenname : string; tmpstack : tfpobjectlist; symowner : tsymtable; + hmodule : tmodule; begin context:=nil; result:=nil; @@ -1488,6 +1489,17 @@ uses if not found then found:=searchsym(ugenname,context.sym,context.symtable); end + else if enforce_unit then + begin + if not assigned(symowner) then + internalerror(2022102101); + if not (symowner.symtabletype in [globalsymtable,recordsymtable]) then + internalerror(2022102102); + hmodule:=find_module_from_symtable(symowner); + if not assigned(hmodule) then + internalerror(2022102103); + found:=searchsym_in_module(hmodule,ugenname,context.sym,context.symtable); + end else found:=searchsym(ugenname,context.sym,context.symtable); @@ -1656,6 +1668,7 @@ uses var finalspecializename, ufinalspecializename : tidstring; + hierarchy, prettyname : ansistring; generictypelist : tfphashobjectlist; srsymtable, @@ -1705,7 +1718,17 @@ uses end; { build the new type's name } - finalspecializename:=generate_generic_name(context.genname,context.specializename,genericdef.ownerhierarchyname); + hierarchy:=genericdef.ownerhierarchyname; + if assigned(genericdef.owner) then + begin + hmodule:=find_module_from_symtable(genericdef.owner); + if not assigned(hmodule) then + internalerror(2022102801); + if hierarchy<>'' then + hierarchy:='.'+hierarchy; + hierarchy:=hmodule.modulename^+hierarchy; + end; + finalspecializename:=generate_generic_name(context.genname,context.specializename,hierarchy); ufinalspecializename:=upper(finalspecializename); if genericdef.typ=procdef then prettyname:=tprocdef(genericdef).procsym.prettyname @@ -1926,7 +1949,6 @@ uses not assigned(genericdef.generictokenbuf) ) then internalerror(200511171); - hmodule:=find_module_from_symtable(genericdef.owner); if hmodule=nil then internalerror(2012051202); oldcurrent_filepos:=current_filepos; @@ -2138,12 +2160,12 @@ uses end; - procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;const _prettyname:string;parsedtype:tdef;const symname:string;parsedpos:tfileposinfo); + procedure generate_specialization(var tt:tdef;enforce_unit:boolean;parse_class_parent:boolean;const _prettyname:string;parsedtype:tdef;const symname:string;parsedpos:tfileposinfo); var context : tspecializationcontext; genericdef : tstoreddef; begin - genericdef:=tstoreddef(generate_specialization_phase1(context,tt,parsedtype,symname,nil,parsedpos)); + genericdef:=tstoreddef(generate_specialization_phase1(context,tt,enforce_unit,parsedtype,symname,nil,parsedpos)); if genericdef<>generrordef then genericdef:=tstoreddef(generate_specialization_phase2(context,genericdef,parse_class_parent,_prettyname)); tt:=genericdef; @@ -2565,7 +2587,7 @@ uses end; end; - function generate_generic_name(const name:tidstring;const specializename:ansistring;const owner_hierarchy:string):tidstring; + function generate_generic_name(const name:tidstring;const specializename:ansistring;const owner_hierarchy:ansistring):tidstring; var crc : cardinal; begin @@ -2577,7 +2599,7 @@ uses if owner_hierarchy<>'' then begin crc:=UpdateCrc32(0,owner_hierarchy[1],length(owner_hierarchy)); - result:=result+'$crc'+hexstr(crc,8); + result:=result+'_crc'+hexstr(crc,8); end; end; diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 319861107b..f9b4a0af8c 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -242,7 +242,7 @@ implementation end; - procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms,allowunitsym:boolean;out srsym:tsym;out srsymtable:tsymtable;out is_specialize:boolean); forward; + procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms,allowunitsym:boolean;out srsym:tsym;out srsymtable:tsymtable;out is_specialize,is_unit_specific:boolean); forward; { def is the outermost type in which other types have to be searched @@ -262,7 +262,8 @@ implementation srsym: tsym; srsymtable: tsymtable; oldsymtablestack: TSymtablestack; - isspecialize : boolean; + isspecialize, + isunitspecific : boolean; begin if assigned(currentstructstack) then structstackindex:=currentstructstack.count-1 @@ -290,7 +291,7 @@ implementation symtablestack:=TSymtablestack.create; symtablestack.push(tabstractrecorddef(def).symtable); t2:=generrordef; - id_type(t2,isforwarddef,false,false,false,srsym,srsymtable,isspecialize); + id_type(t2,isforwarddef,false,false,false,srsym,srsymtable,isspecialize,isunitspecific); symtablestack.pop(tabstractrecorddef(def).symtable); symtablestack.free; symtablestack:=oldsymtablestack; @@ -298,7 +299,7 @@ implementation begin if not allowspecialization then Message(parser_e_no_local_para_def); - generate_specialization(t2,false,''); + generate_specialization(t2,isunitspecific,false,''); end; def:=t2; end; @@ -344,12 +345,12 @@ implementation result:=false; end; - procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms,allowunitsym:boolean;out srsym:tsym;out srsymtable:tsymtable;out is_specialize:boolean); + procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms,allowunitsym:boolean;out srsym:tsym;out srsymtable:tsymtable;out is_specialize,is_unit_specific:boolean); { reads a type definition } { to a appropriating tdef, s gets the name of } { the type to allow name mangling } var - is_unit_specific,not_a_type : boolean; + not_a_type : boolean; pos : tfileposinfo; s,sorg : TIDString; t : ttoken; @@ -357,6 +358,7 @@ implementation srsym:=nil; srsymtable:=nil; is_specialize:=false; + is_unit_specific:=false; s:=pattern; sorg:=orgpattern; pos:=current_tokenpos; @@ -478,6 +480,7 @@ implementation var t2 : tdef; + isunitspecific, isspecialize, dospecialize, again : boolean; @@ -485,6 +488,7 @@ implementation srsymtable : tsymtable; begin dospecialize:=false; + isunitspecific:=false; srsym:=nil; repeat again:=false; @@ -530,7 +534,7 @@ implementation end else begin - id_type(def,stoIsForwardDef in options,true,true,not dospecialize or ([stoAllowSpecialization,stoAllowTypeDef]*options=[]),srsym,srsymtable,isspecialize); + id_type(def,stoIsForwardDef in options,true,true,not dospecialize or ([stoAllowSpecialization,stoAllowTypeDef]*options=[]),srsym,srsymtable,isspecialize,isunitspecific); if isspecialize and dospecialize then internalerror(2015021301); if isspecialize then @@ -569,7 +573,7 @@ implementation begin if def.typ=forwarddef then def:=ttypesym(srsym).typedef; - generate_specialization(def,stoParseClassParent in options,''); + generate_specialization(def,isunitspecific,stoParseClassParent in options,''); parse_nested_types(def,stoIsForwardDef in options,[stoAllowSpecialization,stoAllowTypeDef]*options<>[],nil); end else @@ -1226,7 +1230,7 @@ implementation end; if dospecialize then begin - generate_specialization(def,false,name); + generate_specialization(def,false,false,name); { handle nested types } if assigned(def) then post_comp_expr_gendef(def); diff --git a/tests/test/tgeneric108.pp b/tests/test/tgeneric108.pp new file mode 100644 index 0000000000..e7e1325f1b --- /dev/null +++ b/tests/test/tgeneric108.pp @@ -0,0 +1,49 @@ +program tgeneric108; + +{$mode objfpc} + +uses + ugeneric108a, ugeneric108b; + +type + TTestA = ugeneric108a.specialize TTest; + TTestB = ugeneric108b.specialize TTest; + +function Test1: ugeneric108a.specialize TTest; +begin + Result.f := 1; +end; + +function Test2: ugeneric108b.specialize TTest; +begin + Result.f := 2; +end; + +var + a1: TTestA; + b1: TTestB; + a2: ugeneric108a.specialize TTest; + b2: ugeneric108b.specialize TTest; +begin + if a1.Test <> 1 then + Halt(1); + if b1.Test <> 2 then + Halt(2); + + if a2.Test <> 1 then + Halt(3); + if b2.Test <> 2 then + Halt(4); + + if ugeneric108a.specialize TTest.Test2 <> 1 then + Halt(5); + if ugeneric108b.specialize TTest.Test2 <> 2 then + Halt(6); + + a1 := Test1; + if a1.f <> 1 then + Halt(7); + b1 := Test2; + if b1.f <> 2 then + Halt(8); +end. diff --git a/tests/test/tgeneric109.pp b/tests/test/tgeneric109.pp new file mode 100644 index 0000000000..41f00d4c34 --- /dev/null +++ b/tests/test/tgeneric109.pp @@ -0,0 +1,32 @@ +program tgeneric109; + +{$mode objfpc} + +uses + ugeneric108b, ugeneric108a; + +type + TTestA = ugeneric108a.specialize TTest; + TTestB = ugeneric108b.specialize TTest; + +var + a1: TTestA; + b1: TTestB; + a2: ugeneric108a.specialize TTest; + b2: ugeneric108b.specialize TTest; +begin + if a1.Test <> 1 then + Halt(1); + if b1.Test <> 2 then + Halt(2); + + if a2.Test <> 1 then + Halt(3); + if b2.Test <> 2 then + Halt(4); + + if ugeneric108a.specialize TTest.Test2 <> 1 then + Halt(5); + if ugeneric108b.specialize TTest.Test2 <> 2 then + Halt(6); +end. diff --git a/tests/test/tgeneric110.pp b/tests/test/tgeneric110.pp new file mode 100644 index 0000000000..00b7712ee3 --- /dev/null +++ b/tests/test/tgeneric110.pp @@ -0,0 +1,49 @@ +program tgeneric110; + +{$mode delphi} + +uses + ugeneric108a, ugeneric108b; + +type + TTestA = ugeneric108a.TTest; + TTestB = ugeneric108b.TTest; + +function Test1: ugeneric108a.TTest; +begin + Result.f := 1; +end; + +function Test2: ugeneric108b.TTest; +begin + Result.f := 2; +end; + +var + a1: TTestA; + b1: TTestB; + a2: ugeneric108a.TTest; + b2: ugeneric108b.TTest; +begin + if a1.Test <> 1 then + Halt(1); + if b1.Test <> 2 then + Halt(2); + + if a2.Test <> 1 then + Halt(3); + if b2.Test <> 2 then + Halt(4); + + if ugeneric108a.TTest.Test2 <> 1 then + Halt(5); + if ugeneric108b.TTest.Test2 <> 2 then + Halt(6); + + a1 := Test1; + if a1.f <> 1 then + Halt(7); + b1 := Test2; + if b1.f <> 2 then + Halt(8); +end. diff --git a/tests/test/tgeneric111.pp b/tests/test/tgeneric111.pp new file mode 100644 index 0000000000..b1ad307350 --- /dev/null +++ b/tests/test/tgeneric111.pp @@ -0,0 +1,49 @@ +program tgeneric111; + +{$mode delphi} + +uses + ugeneric108b, ugeneric108a; + +type + TTestA = ugeneric108a.TTest; + TTestB = ugeneric108b.TTest; + +function Test1: ugeneric108a.TTest; +begin + Result.f := 1; +end; + +function Test2: ugeneric108b.TTest; +begin + Result.f := 2; +end; + +var + a1: TTestA; + b1: TTestB; + a2: ugeneric108a.TTest; + b2: ugeneric108b.TTest; +begin + if a1.Test <> 1 then + Halt(1); + if b1.Test <> 2 then + Halt(2); + + if a2.Test <> 1 then + Halt(3); + if b2.Test <> 2 then + Halt(4); + + if ugeneric108a.TTest.Test2 <> 1 then + Halt(5); + if ugeneric108b.TTest.Test2 <> 2 then + Halt(6); + + a1 := Test1; + if a1.f <> 1 then + Halt(7); + b1 := Test2; + if b1.f <> 2 then + Halt(8); +end. diff --git a/tests/test/ugeneric108a.pp b/tests/test/ugeneric108a.pp new file mode 100644 index 0000000000..d0e2ccf529 --- /dev/null +++ b/tests/test/ugeneric108a.pp @@ -0,0 +1,28 @@ +unit ugeneric108a; + +{$mode objfpc} +{$modeswitch advancedrecords} + +interface + +type + generic TTest = record + f: T; + function Test: LongInt; + class function Test2: LongInt; static; + end; + +implementation + +function TTest.Test: LongInt; +begin + Result := 1; +end; + +class function TTest.Test2: LongInt; +begin + Result := 1; +end; + +end. + diff --git a/tests/test/ugeneric108b.pp b/tests/test/ugeneric108b.pp new file mode 100644 index 0000000000..0a90558494 --- /dev/null +++ b/tests/test/ugeneric108b.pp @@ -0,0 +1,28 @@ +unit ugeneric108b; + +{$mode objfpc} +{$modeswitch advancedrecords} + +interface + +type + generic TTest = record + f: T; + function Test: LongInt; + class function Test2: LongInt; static; + end; + +implementation + +function TTest.Test: LongInt; +begin + Result := 2; +end; + +class function TTest.Test2: LongInt; +begin + Result := 2; +end; + +end. + diff --git a/tests/webtbs/tw29859.pp b/tests/webtbs/tw29859.pp new file mode 100644 index 0000000000..0bfcbe568a --- /dev/null +++ b/tests/webtbs/tw29859.pp @@ -0,0 +1,17 @@ +unit tw29859; + +{$mode delphi} + +interface + +uses + uw29859a, uw29859b; + +type + TMyIntegerRecord = uw29859a.TMyRecord; + TMyBooleanRecord = uw29859b.TMyRecord; + +implementation + +end. + diff --git a/tests/webtbs/uw29859a.pp b/tests/webtbs/uw29859a.pp new file mode 100644 index 0000000000..4153c86bf1 --- /dev/null +++ b/tests/webtbs/uw29859a.pp @@ -0,0 +1,22 @@ +unit uw29859a; + +{$mode delphi} + +interface + +type + TMyRecord = record + public + FValue: T; + class operator Add(A,B: TMyRecord): TMyRecord; + end; + +implementation + +class operator TMyRecord.Add(A,B: TMyRecord): TMyRecord; +begin + Result.FValue := A.FValue + B.FValue; +end; + +end. + diff --git a/tests/webtbs/uw29859b.pp b/tests/webtbs/uw29859b.pp new file mode 100644 index 0000000000..db21b6ff4f --- /dev/null +++ b/tests/webtbs/uw29859b.pp @@ -0,0 +1,22 @@ +unit uw29859b; + +{$mode delphi} + +interface + +type + TMyRecord = record + public + FValue: T; + class operator LogicalAnd(A: TMyRecord; B: Boolean): TMyRecord; + end; + +implementation + +class operator TMyRecord.LogicalAnd(A: TMyRecord; B: Boolean): TMyRecord; +begin + Result.FValue := A.FValue and B; + +end; + +end.