diff options
| author | svenbarth <svenbarth@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2020-04-25 22:12:35 +0000 |
|---|---|---|
| committer | svenbarth <svenbarth@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2020-04-25 22:12:35 +0000 |
| commit | 3ba1f1aac5cf84e29a21dc14356e79bc03e12ffc (patch) | |
| tree | fdfc7b0ffcc2e8472da5616c2449514d3942d075 | |
| parent | 8b0c364e7dbc9f36cf350ffc3fb6ac477e79bd2e (diff) | |
| download | fpc-3ba1f1aac5cf84e29a21dc14356e79bc03e12ffc.tar.gz | |
* fix for Mantis #35140: apply patch by Ryan Joseph together with some further changes by me to add support for constant parameters in generics
+ added tests
git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@45080 3ad0048d-3df7-0310-abae-a5850022a9f2
52 files changed, 1462 insertions, 274 deletions
diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 67f3119557..e4e15182ab 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -345,9 +345,13 @@ implementation internalerror(2012091302); symfrom:=ttypesym(tstoreddef(def_from).genericparas[i]); symto:=ttypesym(tstoreddef(def_to).genericparas[i]); - if not (symfrom.typ=typesym) or not (symto.typ=typesym) then + if not (symfrom.typ in [typesym,constsym]) or not (symto.typ in [typesym,constsym]) then internalerror(2012121401); - if not equal_defs(ttypesym(symfrom).typedef,ttypesym(symto).typedef) then + if symto.typ<>symfrom.typ then + diff:=true + else if (symfrom.typ=constsym) and (symto.typ=constsym) and not equal_constsym(tconstsym(symfrom),tconstsym(symto),true) then + diff:=true + else if not equal_defs(ttypesym(symfrom).typedef,ttypesym(symto).typedef) then diff:=true; if diff then break; diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas index 743ec69b10..b989fb2259 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2779,7 +2779,7 @@ implementation internalerror(2015060301); { check whether the given parameters are compatible to the def's constraints } - if not check_generic_constraints(pd,spezcontext.genericdeflist,spezcontext.poslist) then + if not check_generic_constraints(pd,spezcontext.paramlist,spezcontext.poslist) then exit; def:=generate_specialization_phase2(spezcontext,pd,false,''); case def.typ of diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 32053b4adb..deb2ab96c3 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -3102,7 +3102,8 @@ implementation { for constant values on absolute variables, swapping is required } if (target_info.endian = endian_big) and (nf_absolute in flags) then swap_const_value(tordconstnode(left).value,tordconstnode(left).resultdef.size); - adaptrange(resultdef,tordconstnode(left).value,([nf_internal,nf_absolute]*flags)<>[],nf_explicit in flags,cs_check_range in localswitches); + if not(nf_generic_para in flags) then + adaptrange(resultdef,tordconstnode(left).value,([nf_internal,nf_absolute]*flags)<>[],nf_explicit in flags,cs_check_range in localswitches); { swap value back, but according to new type } if (target_info.endian = endian_big) and (nf_absolute in flags) then swap_const_value(tordconstnode(left).value,resultdef.size); diff --git a/compiler/ncon.pas b/compiler/ncon.pas index 61255c6c48..f723750917 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -306,6 +306,7 @@ implementation p1 : tnode; len : longint; pc : pchar; + value_set : pconstset; begin p1:=nil; case p.consttyp of @@ -331,18 +332,50 @@ implementation constwstring : p1:=cstringconstnode.createunistr(pcompilerwidestring(p.value.valueptr)); constreal : - p1:=crealconstnode.create(pbestreal(p.value.valueptr)^,p.constdef); + begin + if (sp_generic_para in p.symoptions) and not (sp_generic_const in p.symoptions) then + p1:=crealconstnode.create(default(bestreal),p.constdef) + else + p1:=crealconstnode.create(pbestreal(p.value.valueptr)^,p.constdef); + end; constset : - p1:=csetconstnode.create(pconstset(p.value.valueptr),p.constdef); + begin + if sp_generic_const in p.symoptions then + begin + new(value_set); + value_set^:=pconstset(p.value.valueptr)^; + p1:=csetconstnode.create(value_set,p.constdef); + end + else if sp_generic_para in p.symoptions then + begin + new(value_set); + p1:=csetconstnode.create(value_set,p.constdef); + end + else + p1:=csetconstnode.create(pconstset(p.value.valueptr),p.constdef); + end; constpointer : - p1:=cpointerconstnode.create(p.value.valueordptr,p.constdef); + begin + if sp_generic_para in p.symoptions then + p1:=cpointerconstnode.create(default(tconstptruint),p.constdef) + else + p1:=cpointerconstnode.create(p.value.valueordptr,p.constdef); + end; constnil : p1:=cnilnode.create; constguid : - p1:=cguidconstnode.create(pguid(p.value.valueptr)^); + begin + if sp_generic_para in p.symoptions then + p1:=cguidconstnode.create(default(tguid)) + else + p1:=cguidconstnode.create(pguid(p.value.valueptr)^); + end; else internalerror(200205103); end; + { transfer generic param flag from symbol to node } + if sp_generic_para in p.symoptions then + include(p1.flags,nf_generic_para); genconstsymtree:=p1; end; diff --git a/compiler/nmat.pas b/compiler/nmat.pas index b4a51f2521..91ce6726d2 100644 --- a/compiler/nmat.pas +++ b/compiler/nmat.pas @@ -131,7 +131,10 @@ implementation end; if rv = 0 then begin - Message(parser_e_division_by_zero); + { if the node is derived from a generic const parameter + then don't issue an error } + if not (nf_generic_para in flags) then + Message(parser_e_division_by_zero); { recover } tordconstnode(right).value := 1; end; diff --git a/compiler/node.pas b/compiler/node.pas index 0c2ba4efbb..2b81f63377 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -276,10 +276,13 @@ interface nf_block_with_exit, { tloadvmtaddrnode } - nf_ignore_for_wpo { we know that this loadvmtaddrnode cannot be used to construct a class instance } + nf_ignore_for_wpo, { we know that this loadvmtaddrnode cannot be used to construct a class instance } - { WARNING: there are now 31 elements in this type, and a set of this - type is written to the PPU. So before adding more than 32 elements, + { node is derived from generic parameter } + nf_generic_para + + { WARNING: there are now 32 elements in this type, and a set of this + type is written to the PPU. So before adding more elements, either move some flags to specific nodes, or stream a normalset to the ppu } @@ -1380,6 +1383,9 @@ implementation constructor tunarynode.create(t:tnodetype;l : tnode); begin inherited create(t); + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para); left:=l; end; @@ -1482,7 +1488,10 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; @@ -1635,6 +1644,9 @@ implementation constructor ttertiarynode.create(_t:tnodetype;l,r,t : tnode); begin inherited create(_t,l,r); + { transfer generic parameter flag } + if assigned(t) and (nf_generic_para in t.flags) then + include(flags,nf_generic_para); third:=t; end; diff --git a/compiler/nset.pas b/compiler/nset.pas index 0832b97b20..0b31de9342 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -424,8 +424,9 @@ implementation { both types must be compatible } if compare_defs(left.resultdef,right.resultdef,left.nodetype)=te_incompatible then IncompatibleTypes(left.resultdef,right.resultdef); - { Check if only when its a constant set } - if (left.nodetype=ordconstn) and (right.nodetype=ordconstn) then + { check if only when its a constant set and + ignore range nodes which are generic parameter derived } + if not (nf_generic_para in flags) and (left.nodetype=ordconstn) and (right.nodetype=ordconstn) then begin { upper limit must be greater or equal than lower limit } if (tordconstnode(left).value>tordconstnode(right).value) and diff --git a/compiler/pass_1.pas b/compiler/pass_1.pas index adbc6d1a42..0e80d10f22 100644 --- a/compiler/pass_1.pas +++ b/compiler/pass_1.pas @@ -62,6 +62,7 @@ implementation procedure typecheckpass_internal_loop(var p : tnode; out node_changed: boolean); var hp : tnode; + oldflags : tnodeflags; begin codegenerror:=false; repeat @@ -73,9 +74,13 @@ implementation if assigned(hp) then begin node_changed:=true; + oldflags:=p.flags; p.free; { switch to new node } p:=hp; + { transfer generic paramter flag } + if nf_generic_para in oldflags then + include(p.flags,nf_generic_para); end; until not assigned(hp) or assigned(hp.resultdef); diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index e42574044e..1c52d152e3 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -135,7 +135,10 @@ implementation setconstn : begin new(ps); - ps^:=tsetconstnode(p).value_set^; + if assigned(tsetconstnode(p).value_set) then + ps^:=tsetconstnode(p).value_set^ + else + ps^:=[]; hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); end; pointerconstn : @@ -185,8 +188,22 @@ implementation end; end; else - Message(parser_e_illegal_expression); + begin + { the node is from a generic parameter constant and is + untyped so we need to pass a placeholder constant + instead of givng an error } + if nf_generic_para in p.flags then + hp:=cconstsym.create_ord(orgname,constnil,0,p.resultdef) + else + Message(parser_e_illegal_expression); + end; end; + { transfer generic param flag from node to symbol } + if nf_generic_para in p.flags then + begin + include(hp.symoptions,sp_generic_const); + include(hp.symoptions,sp_generic_para); + end; current_tokenpos:=storetokenpos; p.free; readconstant:=hp; @@ -716,8 +733,9 @@ implementation { we are not freeing the type parameters, so register them } for i:=0 to generictypelist.count-1 do begin - ttypesym(generictypelist[i]).register_sym; - tstoreddef(ttypesym(generictypelist[i]).typedef).register_def; + tstoredsym(generictypelist[i]).register_sym; + if tstoredsym(generictypelist[i]).typ=typesym then + tstoreddef(ttypesym(generictypelist[i]).typedef).register_def; end; str(generictypelist.Count,s); diff --git a/compiler/pdecsub.pas b/compiler/pdecsub.pas index 7e750eb8bc..45b42857f5 100644 --- a/compiler/pdecsub.pas +++ b/compiler/pdecsub.pas @@ -628,7 +628,7 @@ implementation for i:=0 to genericparams.count-1 do begin sym:=ttypesym(genericparams[i]); - if tstoreddef(sym.typedef).is_registered then + if (sym.typ<>constsym) and tstoreddef(sym.typedef).is_registered then begin sym.typedef.free; sym.typedef:=nil; @@ -813,9 +813,11 @@ implementation function check_generic_parameters(def:tstoreddef):boolean; var i : longint; - decltype, - impltype : ttypesym; + declsym, + implsym : tsym; + impltype : ttypesym absolute implsym; implname : tsymstr; + fileinfo : tfileposinfo; begin result:=true; if not assigned(def.genericparas) then @@ -826,18 +828,23 @@ implementation internalerror(2018090104); for i:=0 to def.genericparas.count-1 do begin - decltype:=ttypesym(def.genericparas[i]); - impltype:=ttypesym(genericparams[i]); + declsym:=tsym(def.genericparas[i]); + implsym:=tsym(genericparams[i]); implname:=upper(genericparams.nameofindex(i)); - if decltype.name<>implname then + if declsym.name<>implname then begin - messagepos1(impltype.fileinfo,sym_e_generic_type_param_mismatch,impltype.realname); - messagepos1(decltype.fileinfo,sym_e_generic_type_param_decl,decltype.realname); + messagepos1(implsym.fileinfo,sym_e_generic_type_param_mismatch,implsym.realname); + messagepos1(declsym.fileinfo,sym_e_generic_type_param_decl,declsym.realname); result:=false; end; - if df_genconstraint in impltype.typedef.defoptions then + if ((implsym.typ=typesym) and (df_genconstraint in impltype.typedef.defoptions)) or + (implsym.typ=constsym) then begin - messagepos(tstoreddef(impltype.typedef).genconstraintdata.fileinfo,parser_e_generic_constraints_not_allowed_here); + if implsym.typ=constsym then + fileinfo:=impltype.fileinfo + else + fileinfo:=tstoreddef(impltype.typedef).genconstraintdata.fileinfo; + messagepos(fileinfo,parser_e_generic_constraints_not_allowed_here); result:=false; end; end; @@ -1127,8 +1134,9 @@ implementation { register the parameters } for i:=0 to genericparams.count-1 do begin - ttypesym(genericparams[i]).register_sym; - tstoreddef(ttypesym(genericparams[i]).typedef).register_def; + tsym(genericparams[i]).register_sym; + if tsym(genericparams[i]).typ=typesym then + tstoreddef(ttypesym(genericparams[i]).typedef).register_def; end; insert_generic_parameter_types(pd,nil,genericparams); { the list is no longer required } diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index 85c47b5132..57f2cf5c1f 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -1707,6 +1707,10 @@ implementation hdef:=generrordef; end; + { field type is a generic param so set a flag in the struct } + if assigned(hdef.typesym) and (sp_generic_para in hdef.typesym.symoptions) then + include(current_structdef.defoptions,df_has_generic_fields); + { Process procvar directives } if maybe_parse_proc_directives(hdef) then semicoloneaten:=true; diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 250c96c668..95eb9a7eb8 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -447,6 +447,9 @@ implementation { no packed bit support for these things } if l=in_bitsizeof_x then statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sizesinttype,true)); + { type sym is a generic parameter } + if assigned(p1.resultdef.typesym) and (sp_generic_para in p1.resultdef.typesym.symoptions) then + include(statement_syssym.flags,nf_generic_para); end else begin @@ -467,6 +470,9 @@ implementation end else statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sizesinttype,true); + { type def is a struct with generic fields } + if df_has_generic_fields in p1.resultdef.defoptions then + include(statement_syssym.flags,nf_generic_para); { p1 not needed !} p1.destroy; end; @@ -4247,7 +4253,10 @@ implementation gendef:=generate_specialization_phase2(spezcontext,tstoreddef(gendef),false,''); spezcontext.free; spezcontext:=nil; - gensym:=gendef.typesym; + if gendef.typ=errordef then + gensym:=generrorsym + else + gensym:=gendef.typesym; end; procdef: begin @@ -4601,7 +4610,7 @@ implementation filepos : tfileposinfo; oldafterassignment, updatefpos : boolean; - + oldflags : tnodeflags; begin oldafterassignment:=afterassignment; p1:=sub_expr(opcompare,[ef_accept_equal],nil); @@ -4658,10 +4667,14 @@ implementation else updatefpos:=false; end; + oldflags:=p1.flags; { get the resultdef for this expression } if not assigned(p1.resultdef) and dotypecheck then do_typecheckpass(p1); + { transfer generic paramter flag } + if nf_generic_para in oldflags then + include(p1.flags,nf_generic_para); afterassignment:=oldafterassignment; if updatefpos then p1.fileinfo:=filepos; diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78f6..948353298d 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -42,7 +42,7 @@ type tspecializationcontext=class public - genericdeflist : tfpobjectlist; + paramlist : tfpobjectlist; poslist : tfplist; prettyname : ansistring; specializename : ansistring; @@ -58,7 +58,7 @@ implementation constructor tspecializationcontext.create; begin - genericdeflist:=tfpobjectlist.create(false); + paramlist:=tfpobjectlist.create(false); poslist:=tfplist.create; end; @@ -66,7 +66,7 @@ destructor tspecializationcontext.destroy; var i : longint; begin - genericdeflist.free; + paramlist.free; for i:=0 to poslist.count-1 do dispose(pfileposinfo(poslist[i])); poslist.free; diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas index e8489726aa..e73f112fa9 100644 --- a/compiler/pgenutil.pas +++ b/compiler/pgenutil.pas @@ -42,9 +42,9 @@ uses function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;symname:string):tdef;inline; function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef; function generate_specialization_phase2(context:tspecializationcontext;genericdef:tstoreddef;parse_class_parent:boolean;_prettyname:ansistring):tdef; - function check_generic_constraints(genericdef:tstoreddef;paradeflist:tfpobjectlist;poslist:tfplist):boolean; + function check_generic_constraints(genericdef:tstoreddef;paramlist:tfpobjectlist;poslist:tfplist):boolean; function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist; - function parse_generic_specialization_types(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean; + 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); procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfphashobjectlist); function generate_generic_name(const name:tidstring;specializename:ansistring;owner_hierarchy:string):tidstring; @@ -65,16 +65,148 @@ uses { common } cutils,fpccrc, { global } - globals,tokens,verbose,finput, + globals,tokens,verbose,finput,constexp, { symtable } - symconst,symsym,symtable,defcmp,procinfo, + symconst,symsym,symtable,defcmp,defutil,procinfo, { modules } fmodule, - node,nobj, + node,nobj,ncon, { parser } scanner, pbase,pexpr,pdecsub,ptype,psub,pparautl; + type + tdeftypeset = set of tdeftyp; + const + tgeneric_param_const_types : tdeftypeset = [orddef,stringdef,arraydef,floatdef,setdef,pointerdef,enumdef]; + tgeneric_param_nodes : tnodetypeset = [typen,ordconstn,stringconstn,realconstn,setconstn,niln]; + + function get_generic_param_def(sym:tsym):tdef; + begin + if sym.typ=constsym then + result:=tconstsym(sym).constdef + else + result:=ttypesym(sym).typedef; + end; + + function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue):boolean; + begin + if (value.valueord<param2.low) or (value.valueord>param2.high) then + result:=false + else + result:=true; + end; + + function compare_generic_params(param1,param2:tdef;constparamsym:tconstsym):boolean; + begin + if (param1.typ=orddef) and (param2.typ=orddef) then + begin + if is_boolean(param2) then + result:=is_boolean(param1) + else if is_char(param2) then + result:=is_char(param1) + else if compare_orddef_by_range(torddef(param1),torddef(param2),constparamsym.value) then + result:=true + else + result:=false; + end + { arraydef is string constant so it's compatible with stringdef } + else if (param1.typ=arraydef) and (param2.typ=stringdef) then + result:=true + { integer ords are compatible with float } + else if (param1.typ=orddef) and is_integer(param1) and (param2.typ=floatdef) then + result:=true + { undefined def is compatible with all types } + else if param2.typ=undefineddef then + result:=true + { sets require stricter checks } + else if is_set(param2) then + result:=equal_defs(param1,param2) + else + result:=param1.typ=param2.typ; + end; + + function create_generic_constsym(fromdef:tdef;node:tnode;out prettyname:string):tconstsym; + const + undefinedname = 'undefined'; + var + sym : tconstsym; + setdef : tsetdef; + enumsym : tsym; + enumname : string; + sp : pchar; + ps : ^tconstset; + pd : ^bestreal; + i : integer; + begin + if node=nil then + internalerror(2020011401); + case node.nodetype of + ordconstn: + begin + sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef); + prettyname:=tostr(tordconstnode(node).value.svalue); + end; + stringconstn: + begin + getmem(sp,tstringconstnode(node).len+1); + move(tstringconstnode(node).value_str^,sp^,tstringconstnode(node).len+1); + sym:=cconstsym.create_string(undefinedname,conststring,sp,tstringconstnode(node).len,fromdef); + prettyname:=''''+tstringconstnode(node).value_str+''''; + end; + realconstn: + begin + new(pd); + pd^:=trealconstnode(node).value_real; + sym:=cconstsym.create_ptr(undefinedname,constreal,pd,fromdef); + prettyname:=realtostr(trealconstnode(node).value_real); + end; + setconstn: + begin + new(ps); + ps^:=tsetconstnode(node).value_set^; + sym:=cconstsym.create_ptr(undefinedname,constset,ps,fromdef); + setdef:=tsetdef(tsetconstnode(node).resultdef); + prettyname:='['; + for i := setdef.setbase to setdef.setmax do + if i in tsetconstnode(node).value_set^ then + begin + if setdef.elementdef.typ=enumdef then + enumsym:=tenumdef(setdef.elementdef).int2enumsym(i) + else + enumsym:=nil; + if assigned(enumsym) then + enumname:=enumsym.realname + else if setdef.elementdef.typ=orddef then + begin + if torddef(setdef.elementdef).ordtype=uchar then + enumname:=chr(i) + else + enumname:=tostr(i); + end + else + enumname:=tostr(i); + if length(prettyname) > 1 then + prettyname:=prettyname+','+enumname + else + prettyname:=prettyname+enumname; + end; + prettyname:=prettyname+']'; + end; + niln: + begin + { only "nil" is available for pointer constants } + sym:=cconstsym.create_ord(undefinedname,constnil,0,fromdef); + prettyname:='nil'; + end; + else + internalerror(2019021601); + end; + { the sym needs an owner for later checks so use the typeparam owner } + sym.owner:=fromdef.owner; + include(sym.symoptions,sp_generic_const); + result:=sym; + end; procedure maybe_add_waiting_unit(tt:tdef); var @@ -104,203 +236,231 @@ uses end; end; - function check_generic_constraints(genericdef:tstoreddef;paradeflist:tfpobjectlist;poslist:tfplist):boolean; + function check_generic_constraints(genericdef:tstoreddef;paramlist:tfpobjectlist;poslist:tfplist):boolean; var i,j, intfcount : longint; formaldef, paradef : tstoreddef; + genparadef : tdef; objdef, paraobjdef, formalobjdef : tobjectdef; intffound : boolean; filepos : tfileposinfo; + is_const : boolean; begin { check whether the given specialization parameters fit to the eventual constraints of the generic } if not assigned(genericdef.genericparas) or (genericdef.genericparas.count=0) then internalerror(2012101001); - if genericdef.genericparas.count<>paradeflist.count then + if genericdef.genericparas.count<>paramlist.count then internalerror(2012101002); - if paradeflist.count<>poslist.count then + if paramlist.count<>poslist.count then internalerror(2012120801); result:=true; for i:=0 to genericdef.genericparas.count-1 do begin filepos:=pfileposinfo(poslist[i])^; - formaldef:=tstoreddef(ttypesym(genericdef.genericparas[i]).typedef); - if formaldef.typ=undefineddef then - { the parameter is of unspecified type, so no need to check } - continue; - if not (df_genconstraint in formaldef.defoptions) or - not assigned(formaldef.genconstraintdata) then - internalerror(2013021602); - paradef:=tstoreddef(paradeflist[i]); - { undefineddef is compatible with anything } - if formaldef.typ=undefineddef then - continue; - if paradef.typ<>formaldef.typ then + paradef:=tstoreddef(get_generic_param_def(tsym(paramlist[i]))); + is_const:=tsym(paramlist[i]).typ=constsym; + genparadef:=genericdef.get_generic_param_def(i); + { validate const params } + if not genericdef.is_generic_param_const(i) and is_const then begin - case formaldef.typ of - recorddef: - { delphi has own fantasy about record constraint - (almost non-nullable/non-nilable value type) } - if m_delphi in current_settings.modeswitches then - case paradef.typ of - floatdef,enumdef,orddef: - continue; - objectdef: - if tobjectdef(paradef).objecttype=odt_object then - continue - else - MessagePos(filepos,type_e_record_type_expected); + MessagePos(filepos,type_e_mismatch); + exit(false); + end + else if genericdef.is_generic_param_const(i) then + begin + { param type mismatch (type <> const) } + if genericdef.is_generic_param_const(i)<>is_const then + begin + MessagePos(filepos,type_e_mismatch); + exit(false); + end; + { type constrained param doesn't match type } + if not compare_generic_params(paradef,genericdef.get_generic_param_def(i),tconstsym(paramlist[i])) then + begin + MessagePos2(filepos,type_e_incompatible_types,FullTypeName(paradef,genparadef),FullTypeName(genparadef,paradef)); + exit(false); + end; + end; + { test constraints for non-const params } + if not genericdef.is_generic_param_const(i) then + begin + formaldef:=tstoreddef(ttypesym(genericdef.genericparas[i]).typedef); + if formaldef.typ=undefineddef then + { the parameter is of unspecified type, so no need to check } + continue; + if not (df_genconstraint in formaldef.defoptions) or + not assigned(formaldef.genconstraintdata) then + internalerror(2013021602); + { undefineddef is compatible with anything } + if formaldef.typ=undefineddef then + continue; + if paradef.typ<>formaldef.typ then + begin + case formaldef.typ of + recorddef: + { delphi has own fantasy about record constraint + (almost non-nullable/non-nilable value type) } + if m_delphi in current_settings.modeswitches then + case paradef.typ of + floatdef,enumdef,orddef: + continue; + objectdef: + if tobjectdef(paradef).objecttype=odt_object then + continue + else + MessagePos(filepos,type_e_record_type_expected); + else + MessagePos(filepos,type_e_record_type_expected); + end else MessagePos(filepos,type_e_record_type_expected); - end - else - MessagePos(filepos,type_e_record_type_expected); - objectdef: - case tobjectdef(formaldef).objecttype of - odt_class, - odt_javaclass: - MessagePos1(filepos,type_e_class_type_expected,paradef.typename); - odt_interfacecom, - odt_interfacecorba, - odt_dispinterface, - odt_interfacejava: - MessagePos1(filepos,type_e_interface_type_expected,paradef.typename); + objectdef: + case tobjectdef(formaldef).objecttype of + odt_class, + odt_javaclass: + MessagePos1(filepos,type_e_class_type_expected,paradef.typename); + odt_interfacecom, + odt_interfacecorba, + odt_dispinterface, + odt_interfacejava: + MessagePos1(filepos,type_e_interface_type_expected,paradef.typename); + else + internalerror(2012101003); + end; + errordef: + { ignore } + ; else - internalerror(2012101003); + internalerror(2012101004); end; - errordef: - { ignore } - ; - else - internalerror(2012101004); - end; - result:=false; - end - else - begin - { the paradef types are the same, so do special checks for the - cases in which they are needed } - if formaldef.typ=objectdef then + result:=false; + end + else begin - paraobjdef:=tobjectdef(paradef); - formalobjdef:=tobjectdef(formaldef); - if not (formalobjdef.objecttype in [odt_class,odt_javaclass,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface]) then - internalerror(2012101102); - if formalobjdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface] then + { the paradef types are the same, so do special checks for the + cases in which they are needed } + if formaldef.typ=objectdef then begin - { this is either a concerete interface or class type (the - latter without specific implemented interfaces) } - case paraobjdef.objecttype of - odt_interfacecom, - odt_interfacecorba, - odt_interfacejava, - odt_dispinterface: - begin - if (oo_is_forward in paraobjdef.objectoptions) and - (paraobjdef.objecttype=formalobjdef.objecttype) and - (df_genconstraint in formalobjdef.defoptions) and - ( - (formalobjdef.objecttype=odt_interfacecom) and - (formalobjdef.childof=interface_iunknown) - ) - or - ( - (formalobjdef.objecttype=odt_interfacecorba) and - (formalobjdef.childof=nil) - ) then - continue; - if not def_is_related(paraobjdef,formalobjdef.childof) then + paraobjdef:=tobjectdef(paradef); + formalobjdef:=tobjectdef(formaldef); + if not (formalobjdef.objecttype in [odt_class,odt_javaclass,odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface]) then + internalerror(2012101102); + if formalobjdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_interfacejava,odt_dispinterface] then + begin + { this is either a concerete interface or class type (the + latter without specific implemented interfaces) } + case paraobjdef.objecttype of + odt_interfacecom, + odt_interfacecorba, + odt_interfacejava, + odt_dispinterface: begin - MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename); - result:=false; + if (oo_is_forward in paraobjdef.objectoptions) and + (paraobjdef.objecttype=formalobjdef.objecttype) and + (df_genconstraint in formalobjdef.defoptions) and + ( + (formalobjdef.objecttype=odt_interfacecom) and + (formalobjdef.childof=interface_iunknown) + ) + or + ( + (formalobjdef.objecttype=odt_interfacecorba) and + (formalobjdef.childof=nil) + ) then + continue; + if not def_is_related(paraobjdef,formalobjdef.childof) then + begin + MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename); + result:=false; + end; end; - end; - odt_class, - odt_javaclass: - begin - objdef:=paraobjdef; - intffound:=false; - while assigned(objdef) do + odt_class, + odt_javaclass: begin - for j:=0 to objdef.implementedinterfaces.count-1 do - if timplementedinterface(objdef.implementedinterfaces[j]).intfdef=formalobjdef.childof then - begin - intffound:=true; + objdef:=paraobjdef; + intffound:=false; + while assigned(objdef) do + begin + for j:=0 to objdef.implementedinterfaces.count-1 do + if timplementedinterface(objdef.implementedinterfaces[j]).intfdef=formalobjdef.childof then + begin + intffound:=true; + break; + end; + if intffound then break; - end; - if intffound then - break; - objdef:=objdef.childof; + objdef:=objdef.childof; + end; + result:=intffound; + if not result then + MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,formalobjdef.childof.typename); + end; + else + begin + MessagePos1(filepos,type_e_class_or_interface_type_expected,paraobjdef.typename); + result:=false; end; - result:=intffound; - if not result then - MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,formalobjdef.childof.typename); - end; - else - begin - MessagePos1(filepos,type_e_class_or_interface_type_expected,paraobjdef.typename); - result:=false; end; - end; - end - else - begin - { this is either a "class" or a concrete instance with - or without implemented interfaces } - if not (paraobjdef.objecttype in [odt_class,odt_javaclass]) then - begin - MessagePos1(filepos,type_e_class_type_expected,paraobjdef.typename); - result:=false; - continue; - end; - { for forward declared classes we allow pure TObject/class declarations } - if (oo_is_forward in paraobjdef.objectoptions) and - (df_genconstraint in formaldef.defoptions) then - begin - if (formalobjdef.childof=class_tobject) and - not formalobjdef.implements_any_interfaces then - continue; - end; - if assigned(formalobjdef.childof) and - not def_is_related(paradef,formalobjdef.childof) then - begin - MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename); - result:=false; - end; - intfcount:=0; - for j:=0 to formalobjdef.implementedinterfaces.count-1 do + end + else begin - objdef:=paraobjdef; - while assigned(objdef) do + { this is either a "class" or a concrete instance with + or without implemented interfaces } + if not (paraobjdef.objecttype in [odt_class,odt_javaclass]) then + begin + MessagePos1(filepos,type_e_class_type_expected,paraobjdef.typename); + result:=false; + continue; + end; + { for forward declared classes we allow pure TObject/class declarations } + if (oo_is_forward in paraobjdef.objectoptions) and + (df_genconstraint in formaldef.defoptions) then begin - intffound:=assigned( - find_implemented_interface(objdef, - timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef - ) - ); + if (formalobjdef.childof=class_tobject) and + not formalobjdef.implements_any_interfaces then + continue; + end; + if assigned(formalobjdef.childof) and + not def_is_related(paradef,formalobjdef.childof) then + begin + MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename); + result:=false; + end; + intfcount:=0; + for j:=0 to formalobjdef.implementedinterfaces.count-1 do + begin + objdef:=paraobjdef; + while assigned(objdef) do + begin + intffound:=assigned( + find_implemented_interface(objdef, + timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef + ) + ); + if intffound then + break; + objdef:=objdef.childof; + end; if intffound then - break; - objdef:=objdef.childof; + inc(intfcount) + else + MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef.typename); end; - if intffound then - inc(intfcount) - else - MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef.typename); + if intfcount<>formalobjdef.implementedinterfaces.count then + result:=false; end; - if intfcount<>formalobjdef.implementedinterfaces.count then - result:=false; end; end; end; end; end; - - function parse_generic_specialization_types_internal(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean; + function parse_generic_specialization_types_internal(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean; var old_block_type : tblock_type; first : boolean; @@ -310,9 +470,11 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + constprettyname : string; + validparam : boolean; begin result:=true; - if genericdeflist=nil then + if paramlist=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 @@ -324,7 +486,7 @@ uses first:=not assigned(parsedtype); if assigned(parsedtype) then begin - genericdeflist.Add(parsedtype); + paramlist.Add(parsedtype.typesym); module:=find_module_from_symtable(parsedtype.owner); if not assigned(module) then internalerror(2016112801); @@ -350,8 +512,10 @@ uses consume(_COMMA); block_type:=bt_type; tmpparampos:=current_filepos; - typeparam:=factor(false,[ef_type_only]); - if typeparam.nodetype=typen then + typeparam:=factor(false,[ef_accept_equal]); + { determine if the typeparam node is a valid type or const } + validparam:=typeparam.nodetype in tgeneric_param_nodes; + if validparam then begin if tstoreddef(typeparam.resultdef).is_generic and ( @@ -367,31 +531,46 @@ uses end; if typeparam.resultdef.typ<>errordef then begin - if not assigned(typeparam.resultdef.typesym) then + if (typeparam.nodetype=typen) and not assigned(typeparam.resultdef.typesym) then message(type_e_generics_cannot_reference_itself) else if (typeparam.resultdef.typ<>errordef) then begin - genericdeflist.Add(typeparam.resultdef); + { all non-type nodes are considered const } + if typeparam.nodetype<>typen then + paramlist.Add(create_generic_constsym(typeparam.resultdef,typeparam,constprettyname)) + else + begin + constprettyname:=''; + paramlist.Add(typeparam.resultdef.typesym); + end; module:=find_module_from_symtable(typeparam.resultdef.owner); if not assigned(module) then internalerror(2016112802); namepart:='_$'+hexstr(module.moduleid,8)+'$$'+typeparam.resultdef.unique_id_str; + if constprettyname<>'' then + namepart:=namepart+'$$'+constprettyname; { we use the full name of the type to uniquely identify it } - if (symtablestack.top.symtabletype=parasymtable) and - (symtablestack.top.defowner.typ=procdef) and - (typeparam.resultdef.owner=symtablestack.top) then + if typeparam.nodetype=typen then begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else - begin - prettynamepart:=typeparam.resultdef.fullownerhierarchyname(true); + if (symtablestack.top.symtabletype=parasymtable) and + (symtablestack.top.defowner.typ=procdef) and + (typeparam.resultdef.owner=symtablestack.top) then + begin + { special handling for specializations inside generic function declarations } + prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; + end + else + begin + prettynamepart:=typeparam.resultdef.fullownerhierarchyname(true); + end; end; specializename:=specializename+namepart; if not first then prettyname:=prettyname+','; - prettyname:=prettyname+prettynamepart+typeparam.resultdef.typesym.prettyname; + if constprettyname<>'' then + prettyname:=prettyname+constprettyname + else + prettyname:=prettyname+prettynamepart+typeparam.resultdef.typesym.prettyname; end; end else @@ -411,12 +590,12 @@ uses end; - function parse_generic_specialization_types(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean; + function parse_generic_specialization_types(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring):boolean; var dummypos : tfileposinfo; begin FillChar(dummypos, SizeOf(tfileposinfo), 0); - result:=parse_generic_specialization_types_internal(genericdeflist,poslist,prettyname,specializename,nil,dummypos); + result:=parse_generic_specialization_types_internal(paramlist,poslist,prettyname,specializename,nil,dummypos); end; @@ -502,7 +681,7 @@ uses context:=tspecializationcontext.create; { Parse type parameters } - err:=not parse_generic_specialization_types_internal(context.genericdeflist,context.poslist,context.prettyname,context.specializename,parsedtype,parsedpos); + err:=not parse_generic_specialization_types_internal(context.paramlist,context.poslist,context.prettyname,context.specializename,parsedtype,parsedpos); if err then begin if not try_to_consume(_GT) then @@ -556,7 +735,7 @@ uses { search a generic with the given count of params } countstr:=''; - str(context.genericdeflist.Count,countstr); + str(context.paramlist.Count,countstr); genname:=genname+'$'+countstr; ugenname:=upper(genname); @@ -681,6 +860,8 @@ uses tempst : tglobalsymtable; psym, srsym : tsym; + paramdef1, + paramdef2, def : tdef; old_block_type : tblock_type; state : tspecializationstate; @@ -708,7 +889,7 @@ uses pd:=nil; - if not check_generic_constraints(genericdef,context.genericdeflist,context.poslist) then + if not check_generic_constraints(genericdef,context.paramlist,context.poslist) then begin { the parameters didn't fit the constraints, so don't continue with the specialization } @@ -724,20 +905,19 @@ uses else prettyname:=genericdef.typesym.prettyname; prettyname:=prettyname+'<'+context.prettyname+'>'; - generictypelist:=tfphashobjectlist.create(false); { build the list containing the types for the generic params } if not assigned(genericdef.genericparas) then internalerror(2013092601); - if context.genericdeflist.count<>genericdef.genericparas.count then + if context.paramlist.count<>genericdef.genericparas.count then internalerror(2013092603); for i:=0 to genericdef.genericparas.Count-1 do begin srsym:=tsym(genericdef.genericparas[i]); if not (sp_generic_para in srsym.symoptions) then internalerror(2013092602); - generictypelist.add(srsym.realname,tdef(context.genericdeflist[i]).typesym); + generictypelist.add(srsym.realname,context.paramlist[i]); end; { Special case if we are referencing the current defined object } @@ -792,11 +972,33 @@ uses allequal:=true; for i:=0 to generictypelist.count-1 do begin - if not equal_defs(ttypesym(generictypelist[i]).typedef,ttypesym(tstoreddef(def).genericparas[i]).typedef) then + if tsym(generictypelist[i]).typ<>tsym(tstoreddef(def).genericparas[i]).typ then + begin + allequal:=false; + break; + end; + if tsym(generictypelist[i]).typ=constsym then + paramdef1:=tconstsym(generictypelist[i]).constdef + else + paramdef1:=ttypesym(generictypelist[i]).typedef; + if tsym(tstoreddef(def).genericparas[i]).typ=constsym then + paramdef2:=tconstsym(tstoreddef(def).genericparas[i]).constdef + else + paramdef2:=ttypesym(tstoreddef(def).genericparas[i]).typedef; + if not equal_defs(paramdef2,paramdef2) then begin allequal:=false; break; end; + if (tsym(generictypelist[i]).typ=constsym) and + ( + (tconstsym(generictypelist[i]).consttyp<>tconstsym(tstoreddef(def).genericparas[i]).consttyp) or + not same_constvalue(tconstsym(generictypelist[i]).consttyp,tconstsym(generictypelist[i]).value,tconstsym(tstoreddef(def).genericparas[i]).value) + ) then + begin + allequal:=false; + break; + end; end; if allequal then begin @@ -1159,25 +1361,43 @@ uses function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist; var - generictype : ttypesym; - i,firstidx : longint; + generictype : tstoredsym; + i,firstidx,const_list_index : longint; srsymtable : tsymtable; basedef,def : tdef; defname : tidstring; + allowconst, allowconstructor, + is_const, doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; fileinfo : tfileposinfo; + last_token : ttoken; + last_type_pos : tfileposinfo; begin result:=tfphashobjectlist.create(false); firstidx:=0; + const_list_index:=0; old_block_type:=block_type; block_type:=bt_type; + allowconst:=true; + is_const:=false; + last_token:=NOTOKEN; + last_type_pos:=current_filepos; repeat + if allowconst and try_to_consume(_CONST) then + begin + allowconst:=false; + is_const:=true; + const_list_index:=result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype); + if is_const then + generictype:=cconstsym.create_undefined(orgpattern,cundefinedtype) + else + generictype:=ctypesym.create(orgpattern,cundefinedtype); { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); @@ -1185,7 +1405,43 @@ uses end; consume(_ID); fileinfo:=current_tokenpos; - if try_to_consume(_COLON) then + { const restriction } + if is_const and try_to_consume(_COLON) then + begin + def:=nil; + { parse the type and assign the const type to generictype } + single_type(def,[]); + for i:=const_list_index to result.count-1 do + begin + { finalize constant information once type is known } + if assigned(def) and (def.typ in tgeneric_param_const_types) then + begin + case def.typ of + orddef, + enumdef: + tconstsym(result[i]).consttyp:=constord; + stringdef: + tconstsym(result[i]).consttyp:=conststring; + floatdef: + tconstsym(result[i]).consttyp:=constreal; + setdef: + tconstsym(result[i]).consttyp:=constset; + { pointer always refers to nil with constants } + pointerdef: + tconstsym(result[i]).consttyp:=constnil; + else + internalerror(2020011402); + end; + tconstsym(result[i]).constdef:=def; + end + else + Message(type_e_mismatch); + end; + { after type restriction const list terminates } + is_const:=false; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then Message(parser_e_generic_constraints_not_allowed_here); @@ -1302,6 +1558,7 @@ uses basedef:=cobjectdef.create(tobjectdef(def).objecttype,defname,tobjectdef(def),false); constraintdata.interfaces.delete(0); end; + if basedef.typ<>errordef then with tstoreddef(basedef) do begin @@ -1328,21 +1585,34 @@ uses begin { two different typeless parameters are considered as incompatible } for i:=firstidx to result.count-1 do - begin - ttypesym(result[i]).typedef:=cundefineddef.create(false); - ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]); - end; + if tsym(result[i]).typ<>constsym then + begin + ttypesym(result[i]).typedef:=cundefineddef.create(false); + ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]); + end; { a semicolon terminates a type parameter group } firstidx:=result.count; end; end; + if token=_SEMICOLON then + begin + is_const:=false; + allowconst:=true; + end; + last_token:=token; + last_type_pos:=current_filepos; until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); + { if the constant parameter is not terminated then the type restriction was + not specified and we need to give an error } + if is_const then + consume(_COLON); { two different typeless parameters are considered as incompatible } for i:=firstidx to result.count-1 do - begin - ttypesym(result[i]).typedef:=cundefineddef.create(false); - ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]); - end; + if tsym(result[i]).typ<>constsym then + begin + ttypesym(result[i]).typedef:=cundefineddef.create(false); + ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]); + end; block_type:=old_block_type; end; @@ -1350,7 +1620,9 @@ uses procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist); var i : longint; - generictype,sym : ttypesym; + generictype : tstoredsym; + generictypedef : tdef; + sym : tsym; st : tsymtable; begin def.genericdef:=genericdef; @@ -1375,10 +1647,23 @@ uses def.genericparas:=tfphashobjectlist.create(false); for i:=0 to genericlist.count-1 do begin - generictype:=ttypesym(genericlist[i]); + generictype:=tstoredsym(genericlist[i]); if assigned(generictype.owner) then begin - sym:=ctypesym.create(genericlist.nameofindex(i),generictype.typedef); + if generictype.typ=typesym then + sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef) + else if generictype.typ=constsym then + { generictype is a constsym that was created in create_generic_constsym + during phase 1 so we pass this directly without copying } + begin + sym:=generictype; + { the sym name is still undefined so we set it to match + the generic param name so it's accessible } + sym.realname:=genericlist.nameofindex(i); + include(sym.symoptions,sp_generic_const); + end + else + internalerror(2019021602); { type parameters need to be added as strict private } sym.visibility:=vis_strictprivate; st.insert(sym); @@ -1386,13 +1671,17 @@ uses end else begin - if (generictype.typedef.typ=undefineddef) and (generictype.typedef<>cundefinedtype) then + if generictype.typ=typesym then begin - { the generic parameters were parsed before the genericdef existed thus the - undefineddefs were added as part of the parent symtable } - if assigned(generictype.typedef.owner) then - generictype.typedef.owner.DefList.Extract(generictype.typedef); - generictype.typedef.changeowner(st); + generictypedef:=ttypesym(generictype).typedef; + if (generictypedef.typ=undefineddef) and (generictypedef<>cundefinedtype) then + begin + { the generic parameters were parsed before the genericdef existed thus the + undefineddefs were added as part of the parent symtable } + if assigned(generictypedef.owner) then + generictypedef.owner.DefList.Extract(generictypedef); + generictypedef.changeowner(st); + end; end; st.insert(generictype); include(generictype.symoptions,sp_generic_para); diff --git a/compiler/pparautl.pas b/compiler/pparautl.pas index b61173d50c..936806b141 100644 --- a/compiler/pparautl.pas +++ b/compiler/pparautl.pas @@ -631,27 +631,48 @@ implementation function check_generic_parameters(fwpd,currpd:tprocdef):boolean; var i : longint; - fwtype, - currtype : ttypesym; + fwsym, + currsym : tsym; + currtype : ttypesym absolute currsym; + fileinfo : tfileposinfo; begin result:=true; if fwpd.genericparas.count<>currpd.genericparas.count then internalerror(2018090101); for i:=0 to fwpd.genericparas.count-1 do begin - fwtype:=ttypesym(fwpd.genericparas[i]); - currtype:=ttypesym(currpd.genericparas[i]); - if fwtype.name<>currtype.name then + fwsym:=tsym(fwpd.genericparas[i]); + currsym:=tsym(currpd.genericparas[i]); + if fwsym.name<>currsym.name then begin - messagepos1(currtype.fileinfo,sym_e_generic_type_param_mismatch,currtype.realname); - messagepos1(fwtype.fileinfo,sym_e_generic_type_param_decl,fwtype.realname); + messagepos1(currsym.fileinfo,sym_e_generic_type_param_mismatch,currsym.realname); + messagepos1(fwsym.fileinfo,sym_e_generic_type_param_decl,fwsym.realname); result:=false; end; - if (fwpd.interfacedef or assigned(fwpd.struct)) and (df_genconstraint in currtype.typedef.defoptions) then + if (fwpd.interfacedef or assigned(fwpd.struct)) and + ( + ((currsym.typ=typesym) and (df_genconstraint in currtype.typedef.defoptions)) or + (currsym.typ=constsym) + ) then begin - messagepos(tstoreddef(currtype.typedef).genconstraintdata.fileinfo,parser_e_generic_constraints_not_allowed_here); + if currsym.typ=constsym then + fileinfo:=currsym.fileinfo + else + fileinfo:=tstoreddef(currtype.typedef).genconstraintdata.fileinfo; + messagepos(fileinfo,parser_e_generic_constraints_not_allowed_here); result:=false; end; + if not fwpd.interfacedef and not assigned(fwpd.struct) and + (fwsym.typ=constsym) then + begin + { without modeswitch RepeatForward we need to check here + if the type of the constants match } + if (currsym.typ<>constsym) or not equal_defs(tconstsym(fwsym).constdef,tconstsym(currsym).constdef) then + begin + messagepos1(currpd.fileinfo,parser_e_header_dont_match_forward,currpd.fullprocname(false)); + result:=false; + end; + end; end; end; @@ -659,8 +680,10 @@ implementation function equal_generic_procdefs(fwpd,currpd:tprocdef):boolean; var i : longint; - fwtype, - currtype : ttypesym; + fwsym, + currsym : tsym; + fwtype : ttypesym absolute fwsym; + currtype : ttypesym absolute currsym; foundretdef : boolean; begin result:=false; @@ -677,14 +700,36 @@ implementation foundretdef:=false; for i:=0 to fwpd.genericparas.count-1 do begin - fwtype:=ttypesym(fwpd.genericparas[i]); - currtype:=ttypesym(currpd.genericparas[i]); + fwsym:=tsym(fwpd.genericparas[i]); + currsym:=tsym(currpd.genericparas[i]); { if the type in the currpd isn't a pure undefineddef (thus there are constraints and the fwpd was declared in the interface, then we can stop right there } - if fwpd.interfacedef and ((currtype.typedef.typ<>undefineddef) or (df_genconstraint in currtype.typedef.defoptions)) then + if fwpd.interfacedef and + ( + (currsym.typ=constsym) or + ((currsym.typ=typesym) and + ( + (currtype.typedef.typ<>undefineddef) or + (df_genconstraint in currtype.typedef.defoptions) + ) + ) + )then exit; - if not foundretdef then + if not fwpd.interfacedef then + begin + if (fwsym.typ=constsym) and (currsym.typ=constsym) then + begin + { check whether the constant type for forward functions match } + if not equal_defs(tconstsym(fwsym).constdef,tconstsym(currsym).constdef) then + exit; + end + else if (fwsym.typ=constsym) then + { if the forward sym is a constant, the implementation needs to be one + as well } + exit; + end; + if not foundretdef and (fwsym.typ=typesym) then begin { if the returndef is the same as this parameter's def then this needs to be the case for both procdefs } diff --git a/compiler/ppu.pas b/compiler/ppu.pas index 2fc15500d2..49c6e47647 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -50,7 +50,7 @@ const CurrentPPUVersion = 207; { for any other changes to the ppu format, increase this version number (it's a cardinal) } - CurrentPPULongVersion = 8; + CurrentPPULongVersion = 9; { unit flags } uf_big_endian = $000004; diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index ed9a3c9005..d81e151821 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -361,7 +361,9 @@ implementation procedure check_range(hp:tnode; fordef: tdef); begin if (hp.nodetype=ordconstn) and - (fordef.typ<>errordef) then + (fordef.typ<>errordef) and + { the node was derived from a generic parameter so ignore range check } + not(nf_generic_para in hp.flags) then adaptrange(fordef,tordconstnode(hp).value,false,false,true); end; diff --git a/compiler/ptype.pas b/compiler/ptype.pas index ab3db2b048..86e7dff317 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1316,6 +1316,7 @@ implementation procedure array_dec(is_packed:boolean;genericdef:tstoreddef;genericlist:tfphashobjectlist); var + isgeneric : boolean; lowval, highval : TConstExprInt; indexdef : tdef; @@ -1362,6 +1363,7 @@ implementation lowval:=0; highval:=1; indexdef:=def; + isgeneric:=true; end; else Message(sym_e_error_in_type_def); @@ -1409,6 +1411,7 @@ implementation begin { defaults } indexdef:=generrordef; + isgeneric:=false; { use defaults which don't overflow the compiler } lowval:=0; highval:=0; @@ -1424,12 +1427,15 @@ implementation else begin pt:=expr(true); + isgeneric:=false; if pt.nodetype=typen then setdefdecl(pt.resultdef) else begin if pt.nodetype=rangen then begin + if nf_generic_para in pt.flags then + isgeneric:=true; { pure ordconstn expressions can be checked for generics as well, but don't give an error in case of parsing a generic if that isn't yet the case } @@ -1446,7 +1452,9 @@ implementation highval:=tordconstnode(trangenode(pt).right).value; if highval<lowval then begin - Message(parser_e_array_lower_less_than_upper_bound); + { ignore error if node is generic param } + if not (nf_generic_para in pt.flags) then + Message(parser_e_array_lower_less_than_upper_bound); highval:=lowval; end else if (lowval<int64(low(asizeint))) or @@ -1494,6 +1502,8 @@ implementation end; if is_packed then include(arrdef.arrayoptions,ado_IsBitPacked); + if isgeneric then + include(arrdef.arrayoptions,ado_IsGeneric); if token=_COMMA then consume(_COMMA) diff --git a/compiler/symconst.pas b/compiler/symconst.pas index 08951b97ca..116b70883a 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -212,8 +212,9 @@ type generic is encountered to ease inline specializations, etc; those symbols can be "overridden" with a completely different symbol } - sp_explicitrename { this is used to keep track of type renames created + sp_explicitrename, { this is used to keep track of type renames created by the user } + sp_generic_const ); tsymoptions=set of tsymoption; @@ -241,7 +242,10 @@ type { internal def that's not for any export } df_internal, { the local def is referenced from a public function } - df_has_global_ref + df_has_global_ref, + { the def was derived with generic type or const fields so the size + of the def can not be determined } + df_has_generic_fields ); tdefoptions=set of tdefoption; @@ -567,7 +571,8 @@ type ado_IsArrayOfConst, // array of const ado_IsConstString, // string constant ado_IsBitPacked, // bitpacked array - ado_IsVector // Vector + ado_IsVector, // Vector + ado_IsGeneric // the index of the array is generic (meaning that the size is not yet known) ); tarraydefoptions=set of tarraydefoption; diff --git a/compiler/symdef.pas b/compiler/symdef.pas index a07584ab0a..09c58a09f3 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -175,6 +175,9 @@ interface function is_generic:boolean; { same as above for specializations } function is_specialization:boolean; + { generic utilities } + function is_generic_param_const(index:integer):boolean;inline; + function get_generic_param_def(index:integer):tdef;inline; { registers this def in the unit's deflist; no-op if already registered } procedure register_def; override; { add the def to the top of the symtable stack if it's not yet owned @@ -2407,14 +2410,32 @@ implementation for i:=0 to genericparas.count-1 do begin sym:=tsym(genericparas[i]); - if sym.typ<>symconst.typesym then + { sym must be either a type or const } + if not (sym.typ in [symconst.typesym,symconst.constsym]) then internalerror(2014050903); if sym.owner.defowner<>self then exit(false); + if (sym.typ=symconst.constsym) and (sp_generic_const in sym.symoptions) then + exit(false); end; end; + function tstoreddef.is_generic_param_const(index:integer):boolean; + begin + result:=tsym(genericparas[index]).typ=constsym; + end; + + + function tstoreddef.get_generic_param_def(index:integer):tdef; + begin + if tsym(genericparas[index]).typ=constsym then + result:=tconstsym(genericparas[index]).constdef + else + result:=ttypesym(genericparas[index]).typedef; + end; + + function tstoreddef.is_specialization: boolean; var i : longint; @@ -2430,10 +2451,13 @@ implementation for i:=0 to genericparas.count-1 do begin sym:=tsym(genericparas[i]); - if sym.typ<>symconst.typesym then + { sym must be either a type or const } + if not (sym.typ in [symconst.typesym,symconst.constsym]) then internalerror(2014050904); if sym.owner.defowner<>self then exit(true); + if (sym.typ=symconst.constsym) and (sp_generic_const in sym.symoptions) then + exit(true); end; result:=false; end; @@ -4179,7 +4203,7 @@ implementation ppufile.getderef(rangedefderef); lowrange:=ppufile.getasizeint; highrange:=ppufile.getasizeint; - ppufile.getset(tppuset1(arrayoptions)); + ppufile.getset(tppuset2(arrayoptions)); ppuload_platform(ppufile); symtable:=tarraysymtable.create(self); tarraysymtable(symtable).ppuload(ppufile) @@ -4219,7 +4243,7 @@ implementation ppufile.putderef(rangedefderef); ppufile.putasizeint(lowrange); ppufile.putasizeint(highrange); - ppufile.putset(tppuset1(arrayoptions)); + ppufile.putset(tppuset2(arrayoptions)); writeentry(ppufile,ibarraydef); tarraysymtable(symtable).ppuwrite(ppufile); end; @@ -4339,6 +4363,7 @@ implementation (ado_IsDynamicArray in arrayoptions) or (ado_IsConvertedPointer in arrayoptions) or (ado_IsConstructor in arrayoptions) or + (ado_IsGeneric in arrayoptions) or (highrange<lowrange) ) and (size=-1) then @@ -4543,7 +4568,8 @@ implementation fullparas, paramname : ansistring; module : tmodule; - sym : ttypesym; + sym : tsym; + def : tdef; i : longint; begin { we want at least enough space for an ellipsis } @@ -4552,15 +4578,21 @@ implementation fullparas:=''; for i:=0 to genericparas.count-1 do begin - sym:=ttypesym(genericparas[i]); + sym:=tsym(genericparas[i]); module:=find_module_from_symtable(sym.owner); if not assigned(module) then internalerror(2014121202); + if not (sym.typ in [constsym,symconst.typesym]) then + internalerror(2020042501); + if sym.typ=constsym then + def:=tconstsym(sym).constdef + else + def:=ttypesym(sym).typedef; paramname:=module.realmodulename^; - if sym.typedef.typ in [objectdef,recorddef] then - paramname:=paramname+'.'+tabstractrecorddef(sym.typedef).rttiname + if def.typ in [objectdef,recorddef] then + paramname:=paramname+'.'+tabstractrecorddef(def).rttiname else - paramname:=paramname+'.'+sym.typedef.typename; + paramname:=paramname+'.'+def.typename; if length(fullparas)+commacount[i>0]+length(paramname)>maxlength then begin if i>0 then diff --git a/compiler/symsym.pas b/compiler/symsym.pas index 30f6a10f14..ced5c4fc62 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -401,6 +401,7 @@ interface constructor create_ptr(const n : string;t : tconsttyp;v : pointer;def:tdef);virtual; constructor create_string(const n : string;t : tconsttyp;str:pchar;l:longint;def:tdef);virtual; constructor create_wstring(const n : string;t : tconsttyp;pw:pcompilerwidestring);virtual; + constructor create_undefined(const n : string;def:tdef);virtual; constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -491,6 +492,8 @@ interface procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);inline; procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring;filepos:tfileposinfo); + function same_constvalue(consttyp:tconsttyp;const value1,value2:tconstvalue):boolean; + implementation uses @@ -528,6 +531,30 @@ implementation end; + function same_constvalue(consttyp:tconsttyp;const value1,value2:tconstvalue):boolean; + begin + case consttyp of + constnone, + constnil: + result:=true; + constord: + result:=value1.valueord=value2.valueord; + constpointer: + result:=value1.valueordptr=value2.valueordptr; + conststring, + constreal, + constset, + constresourcestring, + constwstring, + constguid: begin + if value1.len<>value2.len then + exit(false); + result:=CompareByte(value1.valueptr^,value2.valueptr^,value1.len)=0; + end; + end; + end; + + procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring); begin check_hints(srsym,symoptions,deprecatedmsg,current_filepos); @@ -1618,7 +1645,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2426,6 +2452,15 @@ implementation end; + constructor tconstsym.create_undefined(const n : string;def: tdef); + begin + inherited create(constsym,n); + fillchar(value,sizeof(value),#0); + consttyp:=constnone; + constdef:=def; + end; + + constructor tconstsym.ppuload(ppufile:tcompilerppufile); var pd : pbestreal; diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp index b1724d13df..3c424725f3 100644 --- a/compiler/utils/ppuutils/ppudump.pp +++ b/compiler/utils/ppuutils/ppudump.pp @@ -1683,7 +1683,8 @@ const (mask:sp_generic_para; str:'Generic Parameter'), (mask:sp_has_deprecated_msg; str:'Has Deprecated Message'), (mask:sp_generic_dummy; str:'Generic Dummy'), - (mask:sp_explicitrename; str:'Explicit Rename') + (mask:sp_explicitrename; str:'Explicit Rename'), + (mask:sp_generic_const; str:'Generic Constant Parameter') ); var symoptions : tsymoptions; @@ -2739,7 +2740,8 @@ const (mask:df_not_registered_no_free; str:'Unregistered/No free (invalid)'), (mask:df_llvm_no_struct_packing; str:'LLVM unpacked struct'), (mask:df_internal; str:'Internal'), - (mask:df_has_global_ref; str:'Has Global Ref') + (mask:df_has_global_ref; str:'Has Global Ref'), + (mask:df_has_generic_fields; str:'Has generic fields') ); defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=( (mask:ds_vmt_written; str:'VMT Written'), @@ -3263,14 +3265,15 @@ const { ado_IsArrayOfConst } 'ArrayOfConst', { ado_IsConstString } 'ConstString', { ado_IsBitPacked } 'BitPacked', - { ado_IsVector } 'Vector' + { ado_IsVector } 'Vector', + { ado_IsGeneric } 'Generic' ); var symoptions: tarraydefoptions; i: tarraydefoption; first: boolean; begin - ppufile.getset(tppuset1(symoptions)); + ppufile.getset(tppuset2(symoptions)); if symoptions<>[] then begin if ado_IsDynamicArray in symoptions then Include(ArrayDef.Options, aoDynamic); diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 0000000000..1cf3be5037 --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,39 @@ +{ %NORUN } +{$mode objfpc} +{ + test all possible constants +} +program tgenconst1; + +type + TEnums = (Blaise, Pascal); + kNames = set of TEnums; + kChars = set of char; + +type + generic TBoolean<const U: boolean> = record end; + generic TString<const U: string> = record end; + generic TFloat<const U: single> = record end; + generic TInteger<const U: integer> = record end; + generic TChar<const U: char> = record end; + generic TByte<const U: byte> = record end; + generic TQWord<const U: QWord> = record end; + generic TEnum<const U: TEnums> = record end; + generic TNames<const U: kNames> = record end; + generic TChars<const U: kChars> = record end; + generic TPointer<const U: pointer> = record end; + +var + a: specialize TBoolean<true>; + b: specialize TString<'string'>; + c: specialize TFloat<1>; + d: specialize TInteger<10>; + e: specialize TByte<255>; + f: specialize TChar<'a'>; + g: specialize TEnum<Pascal>; + h: specialize TNames<[Blaise,Pascal]>; + i: specialize TChars<['a','b']>; + j: specialize TQWord<10>; + k: specialize TPointer<nil>; +begin +end. diff --git a/tests/test/tgenconst10.pp b/tests/test/tgenconst10.pp new file mode 100644 index 0000000000..eecb0bf162 --- /dev/null +++ b/tests/test/tgenconst10.pp @@ -0,0 +1,14 @@ +{%FAIL} +{$mode objfpc} +{ + test type mismatch when specializing generic type with constant value +} +program tgenconst10; + +type + generic TByte<T> = record end; + +var + a: specialize TByte<10>; +begin +end. diff --git a/tests/test/tgenconst11.pp b/tests/test/tgenconst11.pp new file mode 100644 index 0000000000..5895fd00c7 --- /dev/null +++ b/tests/test/tgenconst11.pp @@ -0,0 +1,13 @@ +{%FAIL} +{$mode objfpc} +{ + test def compare fail with specialized types +} +program tgenconst11; +type + generic TConst<const U: integer> = class end; +var + a:specialize TConst<10>; +begin + a:=specialize TConst<'string'>.Create; +end
\ No newline at end of file diff --git a/tests/test/tgenconst12.pp b/tests/test/tgenconst12.pp new file mode 100644 index 0000000000..24fa5c802e --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,15 @@ +{ %NORUN } +{$mode objfpc} +{ + test def compare with specialized types +} +program tgenconst12; + +type + generic TTest<const U: integer> = class + end; + +type + ATest = specialize TTest<100>; +begin +end. diff --git a/tests/test/tgenconst13.pp b/tests/test/tgenconst13.pp new file mode 100644 index 0000000000..13235d1437 --- /dev/null +++ b/tests/test/tgenconst13.pp @@ -0,0 +1,51 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +{ + test advanced record constants assigned from generic constant values +} +program tgenconst13; + +type + kNames = set of (Blaise,Pascal); + kChars = set of char; +type + generic TBoolean<const U: boolean> = record const value = U; end; + generic TString<const U: string> = record const value = U; end; + generic TFloat<const U: single> = record const value = U; end; + generic TInteger<const U: integer> = record const value = U; end; + generic TByte<const U: byte> = record const value = U; end; + generic TChar<const U: char> = record const value = U; end; + generic TQWord<const U: QWord> = record const value = U; end; + generic TNames<const U: kNames> = record const value = U; end; + generic TChars<const U: kChars> = record const value = U; end; + +procedure Test(failed: boolean); inline; +begin + if failed then + begin + writeln('failed!'); + halt(-1); + end; +end; + +var + g0: specialize TBoolean<true>; + g1: specialize TString<'string'>; + g2: specialize TFloat<10.5>; + g3: specialize TInteger<10>; + g4: specialize TByte<255>; + g5: specialize TChar<'a'>; + g6: specialize TQWord<1000000000>; + g7: specialize TNames<[Blaise,Pascal]>; + g8: specialize TChars<['a','b']>; +begin + Test(g0.value <> true); + Test(g1.value <> 'string'); + Test(g2.value <> 10.5); + Test(g3.value <> 10); + Test(g4.value <> 255); + Test(g5.value <> 'a'); + Test(g6.value <> 1000000000); + Test(g7.value <> [Blaise,Pascal]); + Test(g8.value <> ['a','b']); +end. diff --git a/tests/test/tgenconst14.pp b/tests/test/tgenconst14.pp new file mode 100644 index 0000000000..64e5af91b7 --- /dev/null +++ b/tests/test/tgenconst14.pp @@ -0,0 +1,42 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +{ + test binary operators with generic constant params +} +program tgenconst14; + +type + generic TBinaryOp<const I: Integer> = record + const + d0 = I + I; + d1 = I - I; + d2 = I * I; + d3 = I / I; + d4 = I div I; + d5 = I mod I; + d6 = I and I; + d7 = I or I; + d8 = I shl 2; + d9 = I shr 2; + end; + +procedure Check(aExpected, aActual: Integer; aErrorCode: LongInt); +begin + if aExpected <> aActual then + Halt(aErrorCode); +end; + +var + op: specialize TBinaryOp<100>; +begin + Check(op.d0, 100 + 100, 1); + Check(op.d1, 100 - 100, 2); + Check(op.d2, 100 * 100, 3); + Check(Trunc(op.d3), Trunc(100 / 100), 4); + Check(op.d4, 100 div 100, 5); + Check(op.d5, 100 mod 100, 6); + Check(op.d6, 100 and 100, 7); + Check(op.d7, 100 or 100, 8); + Check(op.d8, 100 shl 2, 9); + Check(op.d9, 100 shr 2, 10); +end. diff --git a/tests/test/tgenconst15.pp b/tests/test/tgenconst15.pp new file mode 100644 index 0000000000..5eea8571b4 --- /dev/null +++ b/tests/test/tgenconst15.pp @@ -0,0 +1,15 @@ +{%FAIL} +{$mode objfpc} +{$modeswitch advancedrecords} +{ + test binary operator error with wrong constant type +} +program tgenconst15; + +type + generic TInt<const I: string> = record + const c = I div I; + end; + +begin +end.
\ No newline at end of file diff --git a/tests/test/tgenconst16.pp b/tests/test/tgenconst16.pp new file mode 100644 index 0000000000..dcfa89df2f --- /dev/null +++ b/tests/test/tgenconst16.pp @@ -0,0 +1,79 @@ +{ %NORUN } +{$mode objfpc} +{$modeswitch advancedrecords} +{ + various operator tests +} +program tgenconst16; + +type + Day = (mon,tue,wed,thu,fri,sat,sun); + Days = set of Day; + generic TSet<const I: Days> = record + const + d0 = I + I; // Union + d1 = I - I; // Difference + d2 = I * I; // Intersection + d3 = I >< I; // Symmetric difference + d4 = I <= I; // Contains + d5 = mon in I; + end; + generic TArray<const I: integer> = record + type + t0 = array[0..I - 1] of integer; + t1 = array[0..high(I)] of integer; + t2 = array[0..low(I)] of integer; + t3 = array[0..sizeof(I)] of integer; + public + d0: array[0..I - 1] of integer; + d1: array[0..high(I)] of integer; + d2: array[0..low(I)] of integer; + d3: array[0..sizeof(I)] of integer; + end; + generic TUnaryOp<const I: integer> = record + const + d0 = -I; + d1 = +I; + d2 = not I; + end; + generic TBinaryOp<const I: integer> = record + const + // Arithmetic operators + // https://freepascal.org/docs-html/ref/refsu45.html + d0 = I + I; + d1 = I - I; + d2 = I * I; + d3 = I / I; + d4 = I div I; + d5 = I mod I; + // Boolean operators + // https://freepascal.org/docs-html/ref/refsu47.html + d6 = I and I; + d7 = I or I; + d8 = I xor I; + // Logical operators + // https://freepascal.org/docs-html/ref/refsu46.html + d9 = I shl I; + d10 = I shr I; + d11 = I << I; + d12 = I >> I; + // Relational operators + // https://freepascal.org/docs-html/ref/refsu50.html#x153-17500012.8.6 + d13 = I <> I; + d14 = I < I; + d15 = I > I; + d16 = I <= I; + d17 = I >= I; + d18 = I = I; + end; + generic TOther<const I: integer> = record + procedure DoThis(param: integer = I); + end; + +procedure TOther.DoThis(param: integer = I); +begin + writeln(param, ' default:', I); +end; + +begin +end. diff --git a/tests/test/tgenconst17.pp b/tests/test/tgenconst17.pp new file mode 100644 index 0000000000..ac91913e79 --- /dev/null +++ b/tests/test/tgenconst17.pp @@ -0,0 +1,27 @@ +{ %NORUN } +{$mode objfpc} +{$modeswitch advancedrecords} +{ + testing range checking for arrays and for-loops +} + +program tgenconst17; + +type + generic TStaticList<T; const Length: SizeUInt> = record + Values: array[0..Length - 1] of T; + procedure Display; + end; + +procedure TStaticList.Display; +var + I, n: SizeUInt; +begin + for I := 0 to Length - 1 do + WriteLn(Values[I]); +end; + +var + list: specialize TStaticList<Integer, 20>; +begin +end. diff --git a/tests/test/tgenconst18.pp b/tests/test/tgenconst18.pp new file mode 100644 index 0000000000..b539384759 --- /dev/null +++ b/tests/test/tgenconst18.pp @@ -0,0 +1,12 @@ +{%FAIL} +{$mode objfpc} +{ + test undefined constants which must be typed +} +program tgenconst18; + +type + generic TUndefined<const U> = record end; + +begin +end. diff --git a/tests/test/tgenconst19.pp b/tests/test/tgenconst19.pp new file mode 100644 index 0000000000..146e05416e --- /dev/null +++ b/tests/test/tgenconst19.pp @@ -0,0 +1,24 @@ +{ %NORUN } +unit tgenconst19; + +{$mode objfpc} + +interface + +generic procedure Test<const A, B: LongInt>; +generic procedure Test2<const A, B: LongInt>; + +implementation + +{ currently it does not matter whether , or ; is used in the definition (Delphi + compatible) } + +generic procedure Test<A, B>; +begin +end; + +generic procedure Test2<A; B>; +begin +end; + +end. diff --git a/tests/test/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 0000000000..7189ca7195 --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,14 @@ +{ %NORUN } +{$mode objfpc} +{ + test lists of types/contants +} +program tgenconst2; + +type + generic TMoreThanOne<T1,T2;const U1,U2:integer> = record end; + +var + a: specialize TMoreThanOne<integer,string,10,10>; +begin +end. diff --git a/tests/test/tgenconst20.pp b/tests/test/tgenconst20.pp new file mode 100644 index 0000000000..26b36d6984 --- /dev/null +++ b/tests/test/tgenconst20.pp @@ -0,0 +1,24 @@ +{ %NORUN } +unit tgenconst20; + +{$mode delphi} + +interface + +procedure Test<const A, B: LongInt>; +procedure Test2<const A, B: LongInt>; + +implementation + +{ currently it does not matter whether , or ; is used in the definition (Delphi + compatible) } + +procedure Test<A, B>; +begin +end; + +procedure Test2<A; B>; +begin +end; + +end. diff --git a/tests/test/tgenconst21.pp b/tests/test/tgenconst21.pp new file mode 100644 index 0000000000..eae6248eee --- /dev/null +++ b/tests/test/tgenconst21.pp @@ -0,0 +1,16 @@ +unit tgenconst21; + +{$mode objfpc} + +interface + +implementation + +generic procedure Test<A; const N: LongInt>; forward; + +generic procedure Test<A; const N: LongInt>; +begin +end; + +end. + diff --git a/tests/test/tgenconst22.pp b/tests/test/tgenconst22.pp new file mode 100644 index 0000000000..433cc50492 --- /dev/null +++ b/tests/test/tgenconst22.pp @@ -0,0 +1,16 @@ +unit tgenconst22; + +{$mode delphi} + +interface + +implementation + +procedure Test<A; const N: LongInt>; forward; + +procedure Test<A; const N: LongInt>; +begin +end; + +end. + diff --git a/tests/test/tgenconst23.pp b/tests/test/tgenconst23.pp new file mode 100644 index 0000000000..2592ac32a7 --- /dev/null +++ b/tests/test/tgenconst23.pp @@ -0,0 +1,19 @@ +{ %FAIL } + +unit tgenconst23; + +{$mode objfpc} + +interface + +implementation + +generic procedure Test<A; const N: LongInt>; forward; + +generic procedure Test<A; const N: String>; +begin +end; + + +end. + diff --git a/tests/test/tgenconst24.pp b/tests/test/tgenconst24.pp new file mode 100644 index 0000000000..8e3c082e8b --- /dev/null +++ b/tests/test/tgenconst24.pp @@ -0,0 +1,19 @@ +{ %FAIL } + +unit tgenconst24; + +{$mode delphi} + +interface + +implementation + +procedure Test<A; const N: LongInt>; forward; + +procedure Test<A; const N: String>; +begin +end; + + +end. + diff --git a/tests/test/tgenconst25.pp b/tests/test/tgenconst25.pp new file mode 100644 index 0000000000..23897e78aa --- /dev/null +++ b/tests/test/tgenconst25.pp @@ -0,0 +1,18 @@ +{ %FAIL } + +unit tgenconst25; + +{$mode objfpc} + +interface + +implementation + +generic procedure Test<A; const N: LongInt>; forward; + +generic procedure Test<A; N>; +begin +end; + +end. + diff --git a/tests/test/tgenconst26.pp b/tests/test/tgenconst26.pp new file mode 100644 index 0000000000..629ce36b23 --- /dev/null +++ b/tests/test/tgenconst26.pp @@ -0,0 +1,18 @@ +{ %FAIL } + +unit tgenconst26; + +{$mode delphi} + +interface + +implementation + +procedure Test<A; const N: LongInt>; forward; + +procedure Test<A; N>; +begin +end; + +end. + diff --git a/tests/test/tgenconst27.pp b/tests/test/tgenconst27.pp new file mode 100644 index 0000000000..f31725d5b9 --- /dev/null +++ b/tests/test/tgenconst27.pp @@ -0,0 +1,17 @@ +{ %FAIL } + +unit tgenconst27; + +{$mode objfpc} + +interface + +generic procedure Test<const A: LongInt>; + +implementation + +generic procedure Test<const A: LongInt>; +begin +end; + +end. diff --git a/tests/test/tgenconst28.pp b/tests/test/tgenconst28.pp new file mode 100644 index 0000000000..56bb48f987 --- /dev/null +++ b/tests/test/tgenconst28.pp @@ -0,0 +1,17 @@ +{ %FAIL } + +unit tgenconst28; + +{$mode delphi} + +interface + +procedure Test<const A: LongInt>; + +implementation + +procedure Test<const A: LongInt>; +begin +end; + +end. diff --git a/tests/test/tgenconst29.pp b/tests/test/tgenconst29.pp new file mode 100644 index 0000000000..0e235771df --- /dev/null +++ b/tests/test/tgenconst29.pp @@ -0,0 +1,14 @@ +{ %NORUN } +program tgenconst29; + +{$mode objfpc} + +type + TRange = 3..4; + + generic TTest<const U: TRange> = record end; + +var + t: specialize TTest<3>; +begin +end. diff --git a/tests/test/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 0000000000..a85ede2169 --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,20 @@ +{ %NORUN } +{$mode objfpc} +{$modeswitch advancedrecords} +{ + test integer constants in static array ranges +} +program tgenconst3; + +type + generic TList<T;const U:integer> = record + const + max = U; + public + m_list: array[0..max-1] of T; + end; + +var + list: specialize TList<integer,128>; +begin +end. diff --git a/tests/test/tgenconst30.pp b/tests/test/tgenconst30.pp new file mode 100644 index 0000000000..07f3274dad --- /dev/null +++ b/tests/test/tgenconst30.pp @@ -0,0 +1,14 @@ +{ %FAIL } +program tgenconst30; + +{$mode objfpc} + +type + TRange = 3..4; + + generic TTest<const U: TRange> = record end; + +var + t: specialize TTest<2>; +begin +end. diff --git a/tests/test/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 0000000000..d401150ed2 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,15 @@ +{ %NORUN } +{$mode objfpc} +{ + test constants in generic procedures +} +program tgenconst4; + +generic procedure DoThis<T;const U:string>(msg: string = U); +begin + writeln(msg, ' sizeof:',sizeof(t), ' default: ', U); +end; + +begin + specialize DoThis<integer,'genparam'>('hello world'); +end. diff --git a/tests/test/tgenconst5.pp b/tests/test/tgenconst5.pp new file mode 100644 index 0000000000..56976549cb --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,28 @@ +{ %NORUN } +{$mode objfpc} +{ + test nested generic records with constants +} +program tgenconst5; + +type + generic THelperA<const U:integer> = record + list: array[0..U-1] of byte; + end; + +type + generic THelperB<T> = record + value: T; + end; + +type + generic TList<T; const U:integer> = record + helperA: specialize THelperA<U>; + helperB: specialize THelperB<T>; + end; + +var + list: specialize TList<integer,32>; +begin + writeln('sizeof:',sizeof(list)); +end. diff --git a/tests/test/tgenconst6.pp b/tests/test/tgenconst6.pp new file mode 100644 index 0000000000..03d056ffd8 --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,25 @@ +{ %NORUN } +{$mode delphi} +{ + test delphi mode +} +program tgenconst6; + +type + TList<T; const U: integer> = class + list: array[0..U-1] of T; + function capacity: integer; + end; + +function TList<T; U>.capacity: integer; +begin + result := U; +end; + +var + nums:TList<integer,16>; + strs:TList<string,16>; +begin + nums := TList<integer,16>.Create; + strs := TList<string,16>.Create; +end. diff --git a/tests/test/tgenconst7.pp b/tests/test/tgenconst7.pp new file mode 100644 index 0000000000..22bd037ebf --- /dev/null +++ b/tests/test/tgenconst7.pp @@ -0,0 +1,14 @@ +{%FAIL} +{$mode objfpc} +{ + test type mismatch when specializing constant values +} +program tgenconst7; + +type + generic TInteger<const U: integer> = record end; + +var + a: specialize TInteger<'string'>; +begin +end. diff --git a/tests/test/tgenconst8.pp b/tests/test/tgenconst8.pp new file mode 100644 index 0000000000..418ba3c63e --- /dev/null +++ b/tests/test/tgenconst8.pp @@ -0,0 +1,14 @@ +{%FAIL} +{$mode objfpc} +{ + test out of range error with constants +} +program tgenconst8; + +type + generic TByte<const U: Byte> = record end; + +var + a: specialize TByte<300>; +begin +end. diff --git a/tests/test/tgenconst9.pp b/tests/test/tgenconst9.pp new file mode 100644 index 0000000000..8438b70cb6 --- /dev/null +++ b/tests/test/tgenconst9.pp @@ -0,0 +1,12 @@ +{%FAIL} +{$mode objfpc} +{ + test type mismatch when specializing constants with types +} +program tgenconst9; +type + generic TByte<const U: Byte> = record end; +var + a: specialize TByte<string>; +begin +end. |