View Issue Details
ID | Project | Category | View Status | Date Submitted | Last Update |
---|---|---|---|---|---|
0035140 | FPC | Patch | public | 2019-02-24 15:57 | 2020-09-05 03:44 |
Reporter | Ryan Joseph | Assigned To | Sven Barth | ||
Priority | normal | Severity | minor | Reproducibility | N/A |
Status | closed | Resolution | fixed | ||
Product Version | 3.3.1 | ||||
Fixed in Version | 3.3.1 | ||||
Summary | 0035140: Patch for constants in generics | ||||
Description | Feature which adds constants in generic parameters. Full source at https://github.com/genericptr/freepascal/tree/generic_constants | ||||
Additional Information | I merged the patch into a single file and removed commit history. This is my first patch submission so please let me know if you need me to correct my submission. I've included tests with the prefix tgenconst but I'm sure if these are done correctly (again my first time). | ||||
Tags | generics | ||||
Fixed in Revision | 45080 | ||||
FPCOldBugId | |||||
FPCTarget | - | ||||
Attached Files |
|
|
tgenconst-patch.txt (86,910 bytes)
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..64fdb156d0 --- /dev/null +++ b/.gitignore @@ -0,0 +1,23 @@ +# files +pp +fpmake +rtl/darwin/fpcmade.x86_64-darwin +fpmake_proc1 copy.inc +tests/*.x86_64-darwin +rtl/Package.fpc +tests/createlst +tests/gparmake + +# directories +lazbuild/ +x86_64-darwin/ +tests/tstunits/ +tests/utils + +# patterns +*.app +*.o +*.ppu +*.fpm +*.rsj +*.lst \ No newline at end of file diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 3f5882f762..793dbbbe76 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -175,7 +175,6 @@ implementation symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -337,9 +336,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 07c035dc26..bd51cebdf3 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -152,22 +152,22 @@ interface function token2managementoperator(optoken:ttoken):tmanagementoperator; { check operator args and result type } - - type - toverload_check_flag = ( - ocf_check_non_overloadable, { also check operators that are (currently) considered as - not overloadable (e.g. the "+" operator for dynamic arrays - if modeswitch arrayoperators is active) } - ocf_check_only { only check whether the operator is overloaded, but don't - modify the passed in node (return true if the operator is - overloaded, false otherwise) } - ); - toverload_check_flags = set of toverload_check_flag; - + + type + toverload_check_flag = ( + ocf_check_non_overloadable, { also check operators that are (currently) considered as + not overloadable (e.g. the "+" operator for dynamic arrays + if modeswitch arrayoperators is active) } + ocf_check_only { only check whether the operator is overloaded, but don't + modify the passed in node (return true if the operator is + overloaded, false otherwise) } + ); + toverload_check_flags = set of toverload_check_flag; + function isbinaryoperatoroverloadable(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype) : boolean; function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean; - function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; - function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; { Register Allocation } procedure make_not_regable(p : tnode; how: tregableinfoflags); @@ -515,9 +515,9 @@ implementation end; { <dyn. array> + <dyn. array> is handled by the compiler } - if (m_array_operators in current_settings.modeswitches) and - (treetyp=addn) and - (is_dynamic_array(ld) or is_dynamic_array(rd)) then + if (m_array_operators in current_settings.modeswitches) and + (treetyp=addn) and + (is_dynamic_array(ld) or is_dynamic_array(rd)) then begin allowed:=false; exit; @@ -720,7 +720,7 @@ implementation end; - function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; var ld : tdef; optoken : ttoken; @@ -742,11 +742,11 @@ implementation else inlinenumber:=in_none; - if not (ocf_check_non_overloadable in ocf) and not isunaryoperatoroverloadable(t.nodetype,inlinenumber,ld) then + if not (ocf_check_non_overloadable in ocf) and not isunaryoperatoroverloadable(t.nodetype,inlinenumber,ld) then exit; { operator overload is possible } - result:=not (ocf_check_only in ocf); + result:=not (ocf_check_only in ocf); optoken:=NOTOKEN; case t.nodetype of @@ -766,11 +766,11 @@ implementation end; if (optoken=NOTOKEN) then begin - if not (ocf_check_only in ocf) then - begin - CGMessage(parser_e_operator_not_overloaded); - t:=cnothingnode.create; - end; + if not (ocf_check_only in ocf) then + begin + CGMessage(parser_e_operator_not_overloaded); + t:=cnothingnode.create; + end; exit; end; @@ -790,11 +790,11 @@ implementation begin candidates.free; ppn.free; - if not (ocf_check_only in ocf) then - begin - CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); - t:=cnothingnode.create; - end; + if not (ocf_check_only in ocf) then + begin + CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); + t:=cnothingnode.create; + end; exit; end; @@ -811,16 +811,16 @@ implementation begin candidates.free; ppn.free; - if not (ocf_check_only in ocf) then - begin - CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); - t:=cnothingnode.create; - end; + if not (ocf_check_only in ocf) then + begin + CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); + t:=cnothingnode.create; + end; exit; end; { Multiple candidates left? } - if (cand_cnt>1) and not (ocf_check_only in ocf) then + if (cand_cnt>1) and not (ocf_check_only in ocf) then begin CGMessage(type_e_cant_choose_overload_function); {$ifdef EXTDEBUG} @@ -833,13 +833,13 @@ implementation end; candidates.free; - if ocf_check_only in ocf then - begin - ppn.free; - result:=true; - exit; - end; - + if ocf_check_only in ocf then + begin + ppn.free; + result:=true; + exit; + end; + addsymref(operpd.procsym); { the nil as symtable signs firstcalln that this is @@ -852,7 +852,7 @@ implementation end; - function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; var rd,ld : tdef; optoken : ttoken; @@ -945,14 +945,14 @@ implementation { load easier access variables } ld:=tbinarynode(t).left.resultdef; rd:=tbinarynode(t).right.resultdef; - if not (ocf_check_non_overloadable in ocf) and - not isbinaryoperatoroverloadable(t.nodetype,ld,tbinarynode(t).left.nodetype,rd,tbinarynode(t).right.nodetype) then + if not (ocf_check_non_overloadable in ocf) and + not isbinaryoperatoroverloadable(t.nodetype,ld,tbinarynode(t).left.nodetype,rd,tbinarynode(t).right.nodetype) then exit; { operator overload is possible } - { if we only check for the existance of the overload, then we assume that - it is not overloaded } - result:=not (ocf_check_only in ocf); + { if we only check for the existance of the overload, then we assume that + it is not overloaded } + result:=not (ocf_check_only in ocf); case t.nodetype of equaln: @@ -997,19 +997,19 @@ implementation optoken:=_OP_IN; else begin - if not (ocf_check_only in ocf) then - begin - CGMessage(parser_e_operator_not_overloaded); - t:=cnothingnode.create; - end; + if not (ocf_check_only in ocf) then + begin + CGMessage(parser_e_operator_not_overloaded); + t:=cnothingnode.create; + end; exit; end; end; - cand_cnt:=search_operator(optoken,(optoken<>_NE) and not (ocf_check_only in ocf)); + cand_cnt:=search_operator(optoken,(optoken<>_NE) and not (ocf_check_only in ocf)); { no operator found for "<>" then search for "=" operator } - if (cand_cnt=0) and (optoken=_NE) and not (ocf_check_only in ocf) then + if (cand_cnt=0) and (optoken=_NE) and not (ocf_check_only in ocf) then begin ppn.free; ppn:=nil; @@ -1021,15 +1021,15 @@ implementation if (cand_cnt=0) then begin ppn.free; - if not (ocf_check_only in ocf) then - t:=cnothingnode.create; - exit; - end; - - if ocf_check_only in ocf then - begin - ppn.free; - result:=true; + if not (ocf_check_only in ocf) then + t:=cnothingnode.create; + exit; + end; + + if ocf_check_only in ocf then + begin + ppn.free; + result:=true; exit; end; @@ -2697,7 +2697,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/ncon.pas b/compiler/ncon.pas index ae94637c28..e1617b3e96 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -311,11 +311,21 @@ implementation p1:=cpointerconstnode.create(p.value.valueordptr,p.constdef); constnil : p1:=cnilnode.create; + { constundefined is a placeholder for unrestricted generic const params + so we just treat it as a nil node. } + constundefined : + begin + p1:=cnilnode.create; + p1.resultdef := p.constdef; + end; constguid : p1:=cguidconstnode.create(pguid(p.value.valueptr)^); 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/node.pas b/compiler/node.pas index b8600000bf..f9ab8ec521 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -194,7 +194,8 @@ interface 'loadparentfpn', 'objcselectorn', 'objcprotocoln', - 'specializen'); + 'specializen' + ); { a set containing all const nodes } nodetype_const = [ordconstn, @@ -272,10 +273,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 } @@ -1078,7 +1082,12 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; diff --git a/compiler/nset.pas b/compiler/nset.pas index 6270ec582e..bd031e6a86 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -239,7 +239,7 @@ implementation internalerror(20021126); t:=self; - if isbinaryoverloaded(t,[]) then + if isbinaryoverloaded(t,[]) then begin result:=t; exit; @@ -392,8 +392,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/pdecl.pas b/compiler/pdecl.pas index c5b5bcc921..583d00c17b 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -141,18 +141,18 @@ implementation typen : begin if is_interface(p.resultdef) then - begin - if assigned(tobjectdef(p.resultdef).iidguid) then - begin - new(pg); - pg^:=tobjectdef(p.resultdef).iidguid^; - hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); - end - else - Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); - end - else - Message(parser_e_illegal_expression); + begin + if assigned(tobjectdef(p.resultdef).iidguid) then + begin + new(pg); + pg^:=tobjectdef(p.resultdef).iidguid^; + hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); + end + else + Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); + end + else + Message(parser_e_illegal_expression); end; inlinen: begin @@ -179,6 +179,9 @@ implementation else Message(parser_e_illegal_expression); end; + { transfer generic param flag from node to symbol } + if nf_generic_para in p.flags then + include(hp.symoptions,sp_generic_para); current_tokenpos:=storetokenpos; p.free; readconstant:=hp; @@ -507,8 +510,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/pdecvar.pas b/compiler/pdecvar.pas index 4d39397e46..8121d87853 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -1675,6 +1675,10 @@ implementation end; 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 bc0606ed4b..e6d9633ebd 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -446,6 +446,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,sinttype,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 @@ -466,6 +469,9 @@ implementation end else statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,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; @@ -4078,7 +4084,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 diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78f6..85270df256 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -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 7760a4e134..33daf3b06a 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; @@ -63,18 +63,163 @@ implementation uses { common } - cutils,fpccrc, + sysutils,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; + type + tdeftypeset = set of tdeftyp; + const + tgeneric_param_const_types:tdeftypeset = [orddef,stringdef,arraydef,floatdef,setdef,pointerdef,undefineddef]; + 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 is_generic_param_const(sym:tsym):boolean; + begin + if sym.typ = constsym then + result := tconstsym(sym).consttyp<>constundefined + else + result := false; + end; + + function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue): boolean; + begin + if (value.len<param2.low) or (value.len>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 + begin + sym:=cconstsym.create_undefined(undefinedname,fromdef); + sym.owner:=fromdef.owner; + prettyname:=''; + result:=sym; + exit; + end; + case node.nodetype of + ordconstn: + begin + sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef); + prettyname:=inttostr(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:=floattostr(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 us the typeparam owner } + sym.owner:=fromdef.owner; + result:=sym; + end; procedure maybe_add_waiting_unit(tt:tdef); var @@ -104,203 +249,232 @@ 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; + //paratype : tconsttyp; + 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:=is_generic_param_const(tsym(paramlist[i])); + 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 - intffound:=assigned( - find_implemented_interface(objdef, - timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef - ) - ); + 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 + 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 +484,12 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +501,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); @@ -351,7 +528,9 @@ uses block_type:=bt_type; tmpparampos:=current_filepos; typeparam:=factor(false,[ef_type_only]); - if typeparam.nodetype=typen then + { 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 +546,47 @@ 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 + 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 - begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else + if typeparam.nodetype = typen then 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 +606,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; @@ -578,7 +773,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 @@ -627,7 +822,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); @@ -656,7 +851,7 @@ uses result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -747,6 +942,7 @@ uses hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -755,7 +951,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 } @@ -771,20 +967,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 } @@ -1196,8 +1391,8 @@ 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; @@ -1205,22 +1400,87 @@ uses doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const := true; + const_list_index := result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype,false); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=tconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ttypesym.create(orgpattern,cundefinedtype,false); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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: + 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; + end; + tconstsym(result[i]).constdef:=def; + end + else + Message(type_e_mismatch); + end; + { after type restriction const list terminates } + is_const:=false; + end; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then { TODO } @@ -1335,6 +1595,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 @@ -1360,21 +1621,27 @@ 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 + is_const:=false; + last_token:=token; + last_type_pos:=current_filepos; until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); { 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; @@ -1382,7 +1649,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; @@ -1407,10 +1676,22 @@ 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,true); + if generictype.typ=typesym then + sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef,true) + 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); + end + else + internalerror(2019021602); { type parameters need to be added as strict private } sym.visibility:=vis_strictprivate; st.insert(sym); @@ -1418,13 +1699,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/ppu.pas b/compiler/ppu.pas index 10c42e7eb8..31011be3e8 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -43,7 +43,7 @@ type {$endif Test_Double_checksum} const - CurrentPPUVersion = 201; + CurrentPPUVersion = 203; { unit flags } uf_init = $000001; { unit has initialization section } diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 38e2526e9f..28cd0f94f8 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1436,7 +1436,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 diff --git a/compiler/ryan_ppcx64.lpi b/compiler/ryan_ppcx64.lpi new file mode 100644 index 0000000000..68008e4ab3 --- /dev/null +++ b/compiler/ryan_ppcx64.lpi @@ -0,0 +1,77 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasUsesSectionForAllUnits Value="False"/> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <LRSInOutputDirectory Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="ppcx64"/> + </General> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <DestinationDirectory Value="$(TestDir)\publishedproject\"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <Units Count="2"> + <Unit0> + <Filename Value="pp.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="pp"/> + </Unit0> + <Unit1> + <Filename Value="x86\aasmcpu.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="aasmcpu"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="x86_64\pp"/> + </Target> + <SearchPaths> + <IncludeFiles Value="x86_64"/> + <OtherUnitFiles Value="x86_64;x86;systems"/> + <UnitOutputDirectory Value="x86_64\lazbuild"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <CStyleOperator Value="False"/> + <AllowLabel Value="False"/> + <CPPInline Value="False"/> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> + <Other> + <Verbosity> + <ShowWarn Value="False"/> + <ShowNotes Value="False"/> + <ShowHints Value="False"/> + </Verbosity> + <ConfigFile> + <StopAfterErrCount Value="50"/> + </ConfigFile> + <CustomOptions Value="-dx86_64 -gw -godwarfcpp -Fl/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib"/> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> +</CONFIG> diff --git a/compiler/symconst.pas b/compiler/symconst.pas index a5ae7e0fb9..e02ce3a8ca 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -232,7 +232,10 @@ type because we have to access this information in the symtable unit } df_llvm_no_struct_packing, { internal def that's not for any export } - df_internal + df_internal, + { 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; @@ -651,7 +654,7 @@ type arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -692,7 +695,8 @@ type tconsttyp = (constnone, constord,conststring,constreal, constset,constpointer,constnil, - constresourcestring,constwstring,constguid + constresourcestring,constwstring,constguid, + constundefined ); { RTTI information to store } @@ -831,7 +835,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 4a260c46b9..0f7a2e4c06 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -129,6 +129,9 @@ interface function is_generic:boolean;inline; { same as above for specializations } function is_specialization:boolean;inline; + { 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 @@ -2197,13 +2200,26 @@ 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); 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 @@ -2220,12 +2236,12 @@ 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); end; - result:=false; end; end; diff --git a/compiler/symsym.pas b/compiler/symsym.pas index b21a5f9de9..04c07a5ec7 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -157,7 +157,7 @@ interface fprettyname : ansistring; constructor create(const n : string;def:tdef;doregister:boolean);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -392,6 +392,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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1581,7 +1582,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2344,6 +2344,13 @@ implementation value.len:=getlengthwidestring(pw); end; + constructor tconstsym.create_undefined(const n : string;def: tdef); + begin + inherited create(constsym,n,true); + fillchar(value, sizeof(value), #0); + consttyp:=constundefined; + constdef:=def; + end; constructor tconstsym.ppuload(ppufile:tcompilerppufile); var @@ -2416,7 +2423,8 @@ implementation new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil, + constundefined : ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2448,7 +2456,7 @@ implementation begin inherited; case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdefderef.build(constdef); constwstring: ; @@ -2461,7 +2469,7 @@ implementation procedure tconstsym.deref; begin case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdef:=tdef(constdefderef.resolve); constwstring: constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pcompilerwidestring(value.valueptr))); @@ -2476,7 +2484,8 @@ implementation inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil, + constundefined : ppufile.putderef(constdefderef); constord : begin @@ -2627,7 +2636,6 @@ implementation result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 796b2d6736..ae82024b03 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -2781,7 +2781,7 @@ implementation function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 0000000000..297b982b0f --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,33 @@ +{$mode objfpc} +program tgenconst1; + +type + kNames = set of (Blaise,Pascal); + 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 TUndefined<const U> = 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 TUndefined<nil>; + 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..f05a27718c --- /dev/null +++ b/tests/test/tgenconst10.pp @@ -0,0 +1,13 @@ +{%FAIL} + +{$mode objfpc} + +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..ea409bec9b --- /dev/null +++ b/tests/test/tgenconst11.pp @@ -0,0 +1,21 @@ +{%FAIL} +{$mode objfpc} +program tgenconst11; +type + TEnum = (aaa,bbb,ccc,ddd); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<20>.Create; + b:=specialize TConst<10.1>.Create; + c:=specialize TConst<'_string'>.Create; + d:=specialize TConst<[1,2,3,4]>.Create; + e:=specialize TConst<[aaa,bbb,ccc,ddd]>.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..8f591f6867 --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +program tgenconst12; + +type + generic TTest<const U> = class + class procedure DoThis; + end; + +class procedure TTest.DoThis; +begin +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..0d5f8b1813 --- /dev/null +++ b/tests/test/tgenconst13.pp @@ -0,0 +1,20 @@ +{$mode objfpc} +program tgenconst13; +type + TEnum = (aaa,bbb,ccc); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<10>.Create; + b:=specialize TConst<10.5>.Create; + c:=specialize TConst<'string'>.Create; + d:=specialize TConst<[1,2,3]>.Create; + e:=specialize TConst<[aaa,bbb,ccc]>.Create; +end. diff --git a/tests/test/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 0000000000..aa3a960634 --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,12 @@ +{$mode objfpc} +program tgenconst2; + +type + generic TStuff1<T1,T2;const U1,U2> = record end; + generic TStuff2<T1,T2;const U1,U2:integer> = record end; + +var + a: specialize TStuff1<integer,string,10,'string'>; + b: specialize TStuff2<integer,string,10,10>; +begin +end. diff --git a/tests/test/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 0000000000..aea0e307e2 --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 0000000000..a1fae00c43 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,11 @@ +{$mode objfpc} +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..63514a976c --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,24 @@ +{$mode objfpc} +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..3ee3785423 --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,21 @@ +{$mode delphi} +program tgenconst6; + +type + TList<T;const U> = 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..9d8e81ef05 --- /dev/null +++ b/tests/test/tgenconst7.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..75844f7181 --- /dev/null +++ b/tests/test/tgenconst8.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..939cb90302 --- /dev/null +++ b/tests/test/tgenconst9.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +program tgenconst9; + +type + generic TByte<const U: Byte> = record end; + +var + a: specialize TByte<string>; +begin +end. |
|
I have applied the patch and testing now. I would have put the tests in a separate patch, though. It is a nice feature. |
|
Ok thanks, I'll put tests in another patch next time. |
|
I think this is an awesome feature! A couple of things though: -Your patch doesn't look like it is in the "normal" SVN format that I believe is generally desired, and also seems to include extraneous files that wouldn't normally exist in a "clean" checkout (i.e. rtl/darwin/fpcmade.x86_64-darwin and such.) -When I went to test it by first checking out your github fork, then doing a merge to update that to the latest FPC trunk (as your fork is against a revision from a couple of months ago), and finally doing a full build, there was a couple of things you'd overlooked: A) In compiler/utils/ppuutils/ppudump.pp, in the constant array of "tdefopt" called "defopt" in the procedure "readcommondef", you hadn't added the necessary additional field to reflect your new "df_has_generic_fields" enum variant. My fix for that was to add the following code at line 1574: (mask:df_has_generic_fields; str:'Has generic fields') B) In compiler/pgenutil.pas, in the function "parse_generic_parameters", I got a build failure at first due to the compiler being built with "warnings as errors" by default as there was an "uninitialized" warning for the "last_type_pos" tfileposinfo variable, which you pass to MessagePos2 (depending on the outcome of an if statement) without assigning anything to it. I think there is a global "current_filepos" defined in compiler/globals.pas that might make more sense to use there, anyways? Once I got it built, it works quite well, however there seems to be a bit more that needs to be done as far as stability. Notably, doing <const T: Single> or <const T: Double> does not currently work at all and results in an immediate crash of the compiler for me. Other issues I encountered while testing various things: This code: program Test; {$mode Delphi} type TDiv<const I> = record public const Divided = I div I; end; begin end. makes this happen: test.pas(7,35) Error: Illegal expression test.pas(7,35) Error: Compilation raised exception internally and this code: program Test; {$mode Delphi} type TDiv<const I: SizeInt> = record public const Divided = I div I; end; begin end. makes this happen: test.pas(7,30) Error: Division by zero test.pas(11,4) Fatal: There were 1 errors compiling module, stopping Overall though again, I think this is a really useful feature and I for one have a lot of ideas in mind for it when it's fully ready. Keep up the good work! |
|
The patch format does not matter, a reference to a git branch rebased to current trunk is fine. However, it requires usefull split of commits and also commit messages. Examples: https://github.com/genericptr/freepascal/commit/2efec219041f23036508f9a35b8a7492404f29a8 Msg: "fixed .gitignore so tests are included " However, it contains a tests as well. https://github.com/genericptr/freepascal/commit/ec518542b2da7d7f016702a82b2d05349a01a6fb Msg: "first commit" this is not really helpfull. So rebasing, reordering and using good commit messages is for sure required. |
|
The patch (and the Git branch) also contains many apparent "no-op" changes, e.g. - function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; - function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; Please get rid of those as these add unnecessary noise which makes it harder to see real mistakes. |
|
gen-const.diff (68,610 bytes)
From e298c138a26964a9e960f868c8f821564ac52e55 Mon Sep 17 00:00:00 2001 From: Ryan Joseph <genericptr@gmail.com> Date: Tue, 6 Nov 2018 13:58:49 +0700 Subject: [PATCH] constants in generics --- compiler/defcmp.pas | 9 +- compiler/htypechk.pas | 2 +- compiler/ncon.pas | 10 + compiler/node.pas | 16 +- compiler/nset.pas | 5 +- compiler/pdecl.pas | 32 ++- compiler/pexpr.pas | 11 +- compiler/pgentype.pas | 8 +- compiler/pgenutil.pas | 540 ++++++++++++++++++++++++-------------- compiler/ptype.pas | 4 +- compiler/symconst.pas | 12 +- compiler/symdef.pas | 19 +- compiler/symsym.pas | 22 +- compiler/symtable.pas | 2 +- tests/test/tgenconst1.pp | 33 +++ tests/test/tgenconst10.pp | 13 + tests/test/tgenconst11.pp | 21 ++ tests/test/tgenconst12.pp | 16 ++ tests/test/tgenconst13.pp | 20 ++ tests/test/tgenconst2.pp | 12 + tests/test/tgenconst3.pp | 16 ++ tests/test/tgenconst4.pp | 11 + tests/test/tgenconst5.pp | 24 ++ tests/test/tgenconst6.pp | 21 ++ tests/test/tgenconst7.pp | 11 + tests/test/tgenconst8.pp | 11 + tests/test/tgenconst9.pp | 11 + 27 files changed, 667 insertions(+), 245 deletions(-) create mode 100644 tests/test/tgenconst1.pp create mode 100644 tests/test/tgenconst10.pp create mode 100644 tests/test/tgenconst11.pp create mode 100644 tests/test/tgenconst12.pp create mode 100644 tests/test/tgenconst13.pp create mode 100644 tests/test/tgenconst2.pp create mode 100644 tests/test/tgenconst3.pp create mode 100644 tests/test/tgenconst4.pp create mode 100644 tests/test/tgenconst5.pp create mode 100644 tests/test/tgenconst6.pp create mode 100644 tests/test/tgenconst7.pp create mode 100644 tests/test/tgenconst8.pp create mode 100644 tests/test/tgenconst9.pp diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 9fc5b29119..87797faf3e 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -175,7 +175,6 @@ implementation symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -345,9 +344,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 4e97f903a9..89d32fa966 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2705,7 +2705,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/ncon.pas b/compiler/ncon.pas index 392e11ea1d..90087c265f 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -311,11 +311,21 @@ implementation p1:=cpointerconstnode.create(p.value.valueordptr,p.constdef); constnil : p1:=cnilnode.create; + { constundefined is a placeholder for unrestricted generic const params + so we just treat it as a nil node. } + constundefined : + begin + p1:=cnilnode.create; + p1.resultdef := p.constdef; + end; constguid : p1:=cguidconstnode.create(pguid(p.value.valueptr)^); 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/node.pas b/compiler/node.pas index a0aad228eb..468907a886 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -274,10 +274,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 } @@ -1080,7 +1083,12 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; diff --git a/compiler/nset.pas b/compiler/nset.pas index 684eafd79a..e6e1d51a16 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -401,8 +401,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/pdecl.pas b/compiler/pdecl.pas index fcb19c2c3d..82c0160805 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -141,18 +141,18 @@ implementation typen : begin if is_interface(p.resultdef) then - begin - if assigned(tobjectdef(p.resultdef).iidguid) then - begin - new(pg); - pg^:=tobjectdef(p.resultdef).iidguid^; - hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); - end - else - Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); - end - else - Message(parser_e_illegal_expression); + begin + if assigned(tobjectdef(p.resultdef).iidguid) then + begin + new(pg); + pg^:=tobjectdef(p.resultdef).iidguid^; + hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); + end + else + Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); + end + else + Message(parser_e_illegal_expression); end; inlinen: begin @@ -179,6 +179,9 @@ implementation else Message(parser_e_illegal_expression); end; + { transfer generic param flag from node to symbol } + if nf_generic_para in p.flags then + include(hp.symoptions,sp_generic_para); current_tokenpos:=storetokenpos; p.free; readconstant:=hp; @@ -510,8 +513,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/pexpr.pas b/compiler/pexpr.pas index 251c613ef1..caf1ef2774 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -446,6 +446,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,sinttype,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 @@ -466,6 +469,9 @@ implementation end else statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,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; @@ -4167,7 +4173,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 diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78f6..85270df256 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -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 4e52761d73..4c634904a6 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; @@ -104,203 +104,232 @@ 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; + //paratype : tconsttyp; + 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:=is_generic_param_const(tsym(paramlist[i])); + 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 +339,12 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +356,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); @@ -351,7 +383,9 @@ uses block_type:=bt_type; tmpparampos:=current_filepos; typeparam:=factor(false,[ef_type_only]); - if typeparam.nodetype=typen then + { 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 +401,47 @@ 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 + 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 +461,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; @@ -578,7 +628,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 @@ -627,7 +677,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); @@ -656,7 +706,7 @@ uses result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -747,6 +797,7 @@ uses hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -755,7 +806,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 } @@ -771,20 +822,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 } @@ -1199,8 +1249,8 @@ 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; @@ -1208,22 +1258,87 @@ uses doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const := true; + const_list_index := result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype,false); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=tconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ttypesym.create(orgpattern,cundefinedtype,false); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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: + 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; + end; + tconstsym(result[i]).constdef:=def; + end + else + Message(type_e_mismatch); + end; + { after type restriction const list terminates } + is_const:=false; + end; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then { TODO } @@ -1338,6 +1453,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 @@ -1363,21 +1479,27 @@ 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 + is_const:=false; + last_token:=token; + last_type_pos:=current_filepos; until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); { 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; @@ -1385,7 +1507,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; @@ -1410,10 +1534,22 @@ 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,true); + if generictype.typ=typesym then + sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef,true) + 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); + end + else + internalerror(2019021602); { type parameters need to be added as strict private } sym.visibility:=vis_strictprivate; st.insert(sym); @@ -1421,13 +1557,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/ptype.pas b/compiler/ptype.pas index 5236f253f1..6b642803b8 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1436,7 +1436,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 diff --git a/compiler/symconst.pas b/compiler/symconst.pas index bf284cb58f..ad7424f60a 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -231,7 +231,10 @@ type because we have to access this information in the symtable unit } df_llvm_no_struct_packing, { internal def that's not for any export } - df_internal + df_internal, + { 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; @@ -659,7 +662,7 @@ type arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -700,7 +703,8 @@ type tconsttyp = (constnone, constord,conststring,constreal, constset,constpointer,constnil, - constresourcestring,constwstring,constguid + constresourcestring,constwstring,constguid, + constundefined ); { RTTI information to store } @@ -840,7 +844,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 7db695005e..4be6f572af 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -2293,13 +2293,26 @@ 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); 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 @@ -2316,12 +2329,12 @@ 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); end; - result:=false; end; end; diff --git a/compiler/symsym.pas b/compiler/symsym.pas index 2384509f47..2d0e499f54 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -157,7 +157,7 @@ interface fprettyname : ansistring; constructor create(const n : string;def:tdef;doregister:boolean);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -392,6 +392,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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1584,7 +1585,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2356,6 +2356,13 @@ implementation value.len:=getlengthwidestring(pw); end; + constructor tconstsym.create_undefined(const n : string;def: tdef); + begin + inherited create(constsym,n,true); + fillchar(value, sizeof(value), #0); + consttyp:=constundefined; + constdef:=def; + end; constructor tconstsym.ppuload(ppufile:tcompilerppufile); var @@ -2428,7 +2435,8 @@ implementation new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil, + constundefined : ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2460,7 +2468,7 @@ implementation begin inherited; case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdefderef.build(constdef); constwstring: ; @@ -2473,7 +2481,7 @@ implementation procedure tconstsym.deref; begin case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdef:=tdef(constdefderef.resolve); constwstring: constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pcompilerwidestring(value.valueptr))); @@ -2488,7 +2496,8 @@ implementation inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil, + constundefined : ppufile.putderef(constdefderef); constord : begin @@ -2641,7 +2650,6 @@ implementation result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff --git a/compiler/symtable.pas b/compiler/symtable.pas index c7abd7da58..906e2da4a3 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -2916,7 +2916,7 @@ implementation function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 0000000000..297b982b0f --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,33 @@ +{$mode objfpc} +program tgenconst1; + +type + kNames = set of (Blaise,Pascal); + 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 TUndefined<const U> = 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 TUndefined<nil>; + 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..f05a27718c --- /dev/null +++ b/tests/test/tgenconst10.pp @@ -0,0 +1,13 @@ +{%FAIL} + +{$mode objfpc} + +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..ea409bec9b --- /dev/null +++ b/tests/test/tgenconst11.pp @@ -0,0 +1,21 @@ +{%FAIL} +{$mode objfpc} +program tgenconst11; +type + TEnum = (aaa,bbb,ccc,ddd); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<20>.Create; + b:=specialize TConst<10.1>.Create; + c:=specialize TConst<'_string'>.Create; + d:=specialize TConst<[1,2,3,4]>.Create; + e:=specialize TConst<[aaa,bbb,ccc,ddd]>.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..8f591f6867 --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +program tgenconst12; + +type + generic TTest<const U> = class + class procedure DoThis; + end; + +class procedure TTest.DoThis; +begin +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..0d5f8b1813 --- /dev/null +++ b/tests/test/tgenconst13.pp @@ -0,0 +1,20 @@ +{$mode objfpc} +program tgenconst13; +type + TEnum = (aaa,bbb,ccc); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<10>.Create; + b:=specialize TConst<10.5>.Create; + c:=specialize TConst<'string'>.Create; + d:=specialize TConst<[1,2,3]>.Create; + e:=specialize TConst<[aaa,bbb,ccc]>.Create; +end. diff --git a/tests/test/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 0000000000..aa3a960634 --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,12 @@ +{$mode objfpc} +program tgenconst2; + +type + generic TStuff1<T1,T2;const U1,U2> = record end; + generic TStuff2<T1,T2;const U1,U2:integer> = record end; + +var + a: specialize TStuff1<integer,string,10,'string'>; + b: specialize TStuff2<integer,string,10,10>; +begin +end. diff --git a/tests/test/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 0000000000..aea0e307e2 --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 0000000000..a1fae00c43 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,11 @@ +{$mode objfpc} +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..63514a976c --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,24 @@ +{$mode objfpc} +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..3ee3785423 --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,21 @@ +{$mode delphi} +program tgenconst6; + +type + TList<T;const U> = 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..9d8e81ef05 --- /dev/null +++ b/tests/test/tgenconst7.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..75844f7181 --- /dev/null +++ b/tests/test/tgenconst8.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..939cb90302 --- /dev/null +++ b/tests/test/tgenconst9.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +program tgenconst9; + +type + generic TByte<const U: Byte> = record end; + +var + a: specialize TByte<string>; +begin +end. -- 2.17.2 (Apple Git-113) |
|
I uploaded a new patch which I made by applying the old one (to a new master repository I downloaded last week) and then squished the commit history into a single commit. Is that better? |
|
Regarding the "I div I" bug I think I just need to check for the nf_generic_para flag I added and ignore the warning. I had to do something similar for array syntax like array[0..I-1]. The / operator works however so that's interesting. |
|
gen-const-clean.diff (81,965 bytes)
From 57a8c0589a5c881dd55d36dbf03832cb024e3cf3 Mon Sep 17 00:00:00 2001 From: Ryan Joseph <genericptr@gmail.com> Date: Sun, 17 Mar 2019 16:57:25 -0400 Subject: [PATCH] constants in generics --- compiler/defcmp.pas | 9 +- compiler/htypechk.pas | 2 +- compiler/ncon.pas | 38 +- compiler/nmat.pas | 5 +- compiler/node.pas | 19 +- compiler/nset.pas | 5 +- compiler/pdecl.pas | 43 +- compiler/pdecvar.pas | 4 + compiler/pexpr.pas | 11 +- compiler/pgentype.pas | 8 +- compiler/pgenutil.pas | 693 ++++++++++++++++++++--------- compiler/ppu.pas | 2 +- compiler/ptype.pas | 4 +- compiler/symconst.pas | 12 +- compiler/symdef.pas | 22 +- compiler/symsym.pas | 22 +- compiler/symtable.pas | 2 +- compiler/utils/ppuutils/ppudump.pp | 3 +- tests/test/tgenconst1.pp | 33 ++ tests/test/tgenconst10.pp | 13 + tests/test/tgenconst11.pp | 21 + tests/test/tgenconst12.pp | 16 + tests/test/tgenconst13.pp | 20 + tests/test/tgenconst14.pp | 29 ++ tests/test/tgenconst15.pp | 30 ++ tests/test/tgenconst2.pp | 12 + tests/test/tgenconst3.pp | 16 + tests/test/tgenconst4.pp | 11 + tests/test/tgenconst5.pp | 24 + tests/test/tgenconst6.pp | 21 + tests/test/tgenconst7.pp | 11 + tests/test/tgenconst8.pp | 11 + tests/test/tgenconst9.pp | 11 + 33 files changed, 923 insertions(+), 260 deletions(-) create mode 100644 tests/test/tgenconst1.pp create mode 100644 tests/test/tgenconst10.pp create mode 100644 tests/test/tgenconst11.pp create mode 100644 tests/test/tgenconst12.pp create mode 100644 tests/test/tgenconst13.pp create mode 100644 tests/test/tgenconst14.pp create mode 100644 tests/test/tgenconst15.pp create mode 100644 tests/test/tgenconst2.pp create mode 100644 tests/test/tgenconst3.pp create mode 100644 tests/test/tgenconst4.pp create mode 100644 tests/test/tgenconst5.pp create mode 100644 tests/test/tgenconst6.pp create mode 100644 tests/test/tgenconst7.pp create mode 100644 tests/test/tgenconst8.pp create mode 100644 tests/test/tgenconst9.pp diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 3f5882f762..793dbbbe76 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -175,7 +175,6 @@ implementation symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -337,9 +336,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 07c035dc26..2358ea4b6d 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2697,7 +2697,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/ncon.pas b/compiler/ncon.pas index ae94637c28..fb5e94c09f 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -304,18 +304,48 @@ 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 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_para in p.symoptions then + p1:=csetconstnode.create(default(pconstset),p.constdef) + 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; + { constundefined is a placeholder for unrestricted generic const params + so we just treat it as a nil node. } + constundefined : + begin + p1:=cnilnode.create; + p1.resultdef := p.constdef; + end; 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 355b493da4..d10dff6128 100644 --- a/compiler/nmat.pas +++ b/compiler/nmat.pas @@ -129,7 +129,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 b8600000bf..f9ab8ec521 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -194,7 +194,8 @@ interface 'loadparentfpn', 'objcselectorn', 'objcprotocoln', - 'specializen'); + 'specializen' + ); { a set containing all const nodes } nodetype_const = [ordconstn, @@ -272,10 +273,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 } @@ -1078,7 +1082,12 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; diff --git a/compiler/nset.pas b/compiler/nset.pas index 6270ec582e..4360a7340d 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -392,8 +392,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/pdecl.pas b/compiler/pdecl.pas index c5b5bcc921..767eec22f7 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -126,9 +126,14 @@ implementation end; setconstn : begin - new(ps); - ps^:=tsetconstnode(p).value_set^; - hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); + if nf_generic_para in p.flags then + hp:=cconstsym.create_ptr(orgname,constset,nil,p.resultdef) + else + begin + new(ps); + ps^:=tsetconstnode(p).value_set^; + hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); + end; end; pointerconstn : begin @@ -141,18 +146,18 @@ implementation typen : begin if is_interface(p.resultdef) then - begin - if assigned(tobjectdef(p.resultdef).iidguid) then - begin - new(pg); - pg^:=tobjectdef(p.resultdef).iidguid^; - hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); - end - else - Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); - end - else - Message(parser_e_illegal_expression); + begin + if assigned(tobjectdef(p.resultdef).iidguid) then + begin + new(pg); + pg^:=tobjectdef(p.resultdef).iidguid^; + hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); + end + else + Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); + end + else + Message(parser_e_illegal_expression); end; inlinen: begin @@ -179,6 +184,9 @@ implementation else Message(parser_e_illegal_expression); end; + { transfer generic param flag from node to symbol } + if nf_generic_para in p.flags then + include(hp.symoptions,sp_generic_para); current_tokenpos:=storetokenpos; p.free; readconstant:=hp; @@ -507,8 +515,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/pdecvar.pas b/compiler/pdecvar.pas index 4d39397e46..8121d87853 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -1675,6 +1675,10 @@ implementation end; 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 bc0606ed4b..e6d9633ebd 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -446,6 +446,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,sinttype,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 @@ -466,6 +469,9 @@ implementation end else statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,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; @@ -4078,7 +4084,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 diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78f6..85270df256 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -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 7760a4e134..33daf3b06a 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; @@ -63,18 +63,163 @@ implementation uses { common } - cutils,fpccrc, + sysutils,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; + type + tdeftypeset = set of tdeftyp; + const + tgeneric_param_const_types:tdeftypeset = [orddef,stringdef,arraydef,floatdef,setdef,pointerdef,undefineddef]; + 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 is_generic_param_const(sym:tsym):boolean; + begin + if sym.typ = constsym then + result := tconstsym(sym).consttyp<>constundefined + else + result := false; + end; + + function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue): boolean; + begin + if (value.len<param2.low) or (value.len>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 + begin + sym:=cconstsym.create_undefined(undefinedname,fromdef); + sym.owner:=fromdef.owner; + prettyname:=''; + result:=sym; + exit; + end; + case node.nodetype of + ordconstn: + begin + sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef); + prettyname:=inttostr(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:=floattostr(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 us the typeparam owner } + sym.owner:=fromdef.owner; + result:=sym; + end; procedure maybe_add_waiting_unit(tt:tdef); var @@ -104,203 +249,232 @@ 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; + //paratype : tconsttyp; + 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:=is_generic_param_const(tsym(paramlist[i])); + 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 - intffound:=assigned( - find_implemented_interface(objdef, - timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef - ) - ); + 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 + 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 +484,12 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +501,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); @@ -351,7 +528,9 @@ uses block_type:=bt_type; tmpparampos:=current_filepos; typeparam:=factor(false,[ef_type_only]); - if typeparam.nodetype=typen then + { 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 +546,47 @@ 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 + 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 - begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else + if typeparam.nodetype = typen then 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 +606,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; @@ -578,7 +773,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 @@ -627,7 +822,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); @@ -656,7 +851,7 @@ uses result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -747,6 +942,7 @@ uses hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -755,7 +951,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 } @@ -771,20 +967,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 } @@ -1196,8 +1391,8 @@ 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; @@ -1205,22 +1400,87 @@ uses doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const := true; + const_list_index := result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype,false); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=tconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ttypesym.create(orgpattern,cundefinedtype,false); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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: + 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; + end; + tconstsym(result[i]).constdef:=def; + end + else + Message(type_e_mismatch); + end; + { after type restriction const list terminates } + is_const:=false; + end; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then { TODO } @@ -1335,6 +1595,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 @@ -1360,21 +1621,27 @@ 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 + is_const:=false; + last_token:=token; + last_type_pos:=current_filepos; until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); { 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; @@ -1382,7 +1649,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; @@ -1407,10 +1676,22 @@ 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,true); + if generictype.typ=typesym then + sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef,true) + 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); + end + else + internalerror(2019021602); { type parameters need to be added as strict private } sym.visibility:=vis_strictprivate; st.insert(sym); @@ -1418,13 +1699,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/ppu.pas b/compiler/ppu.pas index 10c42e7eb8..31011be3e8 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -43,7 +43,7 @@ type {$endif Test_Double_checksum} const - CurrentPPUVersion = 201; + CurrentPPUVersion = 203; { unit flags } uf_init = $000001; { unit has initialization section } diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 38e2526e9f..28cd0f94f8 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1436,7 +1436,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 diff --git a/compiler/symconst.pas b/compiler/symconst.pas index a5ae7e0fb9..e02ce3a8ca 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -232,7 +232,10 @@ type because we have to access this information in the symtable unit } df_llvm_no_struct_packing, { internal def that's not for any export } - df_internal + df_internal, + { 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; @@ -651,7 +654,7 @@ type arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -692,7 +695,8 @@ type tconsttyp = (constnone, constord,conststring,constreal, constset,constpointer,constnil, - constresourcestring,constwstring,constguid + constresourcestring,constwstring,constguid, + constundefined ); { RTTI information to store } @@ -831,7 +835,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 4a260c46b9..0f7a2e4c06 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -129,6 +129,9 @@ interface function is_generic:boolean;inline; { same as above for specializations } function is_specialization:boolean;inline; + { 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 @@ -2197,13 +2200,26 @@ 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); 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 @@ -2220,12 +2236,12 @@ 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); end; - result:=false; end; end; diff --git a/compiler/symsym.pas b/compiler/symsym.pas index b21a5f9de9..04c07a5ec7 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -157,7 +157,7 @@ interface fprettyname : ansistring; constructor create(const n : string;def:tdef;doregister:boolean);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -392,6 +392,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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1581,7 +1582,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2344,6 +2344,13 @@ implementation value.len:=getlengthwidestring(pw); end; + constructor tconstsym.create_undefined(const n : string;def: tdef); + begin + inherited create(constsym,n,true); + fillchar(value, sizeof(value), #0); + consttyp:=constundefined; + constdef:=def; + end; constructor tconstsym.ppuload(ppufile:tcompilerppufile); var @@ -2416,7 +2423,8 @@ implementation new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil, + constundefined : ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2448,7 +2456,7 @@ implementation begin inherited; case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdefderef.build(constdef); constwstring: ; @@ -2461,7 +2469,7 @@ implementation procedure tconstsym.deref; begin case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdef:=tdef(constdefderef.resolve); constwstring: constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pcompilerwidestring(value.valueptr))); @@ -2476,7 +2484,8 @@ implementation inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil, + constundefined : ppufile.putderef(constdefderef); constord : begin @@ -2627,7 +2636,6 @@ implementation result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 796b2d6736..ae82024b03 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -2781,7 +2781,7 @@ implementation function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp index 74fde5c6c2..80d9d4df11 100644 --- a/compiler/utils/ppuutils/ppudump.pp +++ b/compiler/utils/ppuutils/ppudump.pp @@ -1552,7 +1552,8 @@ const { this should never happen for defs stored to a ppu file } (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_internal; str:'Internal'), + (mask:df_has_generic_fields; str:'Has generic fields') ); defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=( (mask:ds_vmt_written; str:'VMT Written'), diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 0000000000..297b982b0f --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,33 @@ +{$mode objfpc} +program tgenconst1; + +type + kNames = set of (Blaise,Pascal); + 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 TUndefined<const U> = 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 TUndefined<nil>; + 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..f05a27718c --- /dev/null +++ b/tests/test/tgenconst10.pp @@ -0,0 +1,13 @@ +{%FAIL} + +{$mode objfpc} + +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..ea409bec9b --- /dev/null +++ b/tests/test/tgenconst11.pp @@ -0,0 +1,21 @@ +{%FAIL} +{$mode objfpc} +program tgenconst11; +type + TEnum = (aaa,bbb,ccc,ddd); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<20>.Create; + b:=specialize TConst<10.1>.Create; + c:=specialize TConst<'_string'>.Create; + d:=specialize TConst<[1,2,3,4]>.Create; + e:=specialize TConst<[aaa,bbb,ccc,ddd]>.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..8f591f6867 --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +program tgenconst12; + +type + generic TTest<const U> = class + class procedure DoThis; + end; + +class procedure TTest.DoThis; +begin +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..0d5f8b1813 --- /dev/null +++ b/tests/test/tgenconst13.pp @@ -0,0 +1,20 @@ +{$mode objfpc} +program tgenconst13; +type + TEnum = (aaa,bbb,ccc); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<10>.Create; + b:=specialize TConst<10.5>.Create; + c:=specialize TConst<'string'>.Create; + d:=specialize TConst<[1,2,3]>.Create; + e:=specialize TConst<[aaa,bbb,ccc]>.Create; +end. diff --git a/tests/test/tgenconst14.pp b/tests/test/tgenconst14.pp new file mode 100644 index 0000000000..7f98086630 --- /dev/null +++ b/tests/test/tgenconst14.pp @@ -0,0 +1,29 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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; + end; + +var + op: specialize TBinaryOp<100>; +begin + writeln(op.d0); + writeln(op.d1); + writeln(op.d2); + writeln(op.d3:1:1); + writeln(op.d4); + writeln(op.d5); + writeln(op.d6); + writeln(op.d7); +end. \ No newline at end of file diff --git a/tests/test/tgenconst15.pp b/tests/test/tgenconst15.pp new file mode 100644 index 0000000000..56744cd0a7 --- /dev/null +++ b/tests/test/tgenconst15.pp @@ -0,0 +1,30 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst15; + +type + kNames = set of (Blaise, Pascal); + generic TSet<const I: kNames> = record + const c = I; + end; + generic TString<const I: String> = record + const c = I; + end; + generic TWideString<const I: WideString> = record + const c = I; + end; + generic TSingle<const I: Single> = record + const c = I; + end; + generic TDouble<const I: Double> = record + const c = I; + end; + generic TReal<const I: Real> = record + const c = I; + end; + +var + a0: specialize TReal<100>; +begin + writeln(a0.c); +end. \ No newline at end of file diff --git a/tests/test/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 0000000000..aa3a960634 --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,12 @@ +{$mode objfpc} +program tgenconst2; + +type + generic TStuff1<T1,T2;const U1,U2> = record end; + generic TStuff2<T1,T2;const U1,U2:integer> = record end; + +var + a: specialize TStuff1<integer,string,10,'string'>; + b: specialize TStuff2<integer,string,10,10>; +begin +end. diff --git a/tests/test/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 0000000000..aea0e307e2 --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 0000000000..a1fae00c43 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,11 @@ +{$mode objfpc} +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..63514a976c --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,24 @@ +{$mode objfpc} +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..3ee3785423 --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,21 @@ +{$mode delphi} +program tgenconst6; + +type + TList<T;const U> = 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..9d8e81ef05 --- /dev/null +++ b/tests/test/tgenconst7.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..75844f7181 --- /dev/null +++ b/tests/test/tgenconst8.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..939cb90302 --- /dev/null +++ b/tests/test/tgenconst9.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +program tgenconst9; + +type + generic TByte<const U: Byte> = record end; + +var + a: specialize TByte<string>; +begin +end. -- 2.17.2 (Apple Git-113) |
|
I fixed those bugs reported by Akira and uploaded a new patch again (gen-const-clean.diff). I think I've got a good workflow to make the patches now but I'm not sure until they're reviewed. The process: - create a new repo from the existing development branch and delete any unwanted files. - squish all commits into one and rename as something useful - create patch using "git format-patch master --stdout > patch.diff" - create a new repo from master and apply the patch using "git am --reject patch.diff". I had to do this because bad line endings were inserted somehow (from the original sources I think!) and this cleaned them out. - create another patch from the final clean branch Very complicated and timely process so I hope they're good. |
|
Oops, I lied. The untyped const crash that was reported was actually not fixed. That operation is not supported (binary operators on untyped constants) but I'm not certain how to resolve it right now. The resulting constant is technically invalid but the compiler needs to just ignore it until the generic is specialized with an actual type. |
|
I was just about to make another comment about that as I've just tested the branch again, but looks like you've caught it! I agree that even if it cannot *work* in that case if the const is unconstrained by a type, it probably shouldn't literally crash the compiler. We're getting there though! |
|
Akira, I fixed these bugs and updated git if you would like to test I'd appreciate that. I added another test tgenconst16.pp which I think covered all the different ways constants can be used in generics but I'm not sure. Please tell me if you can think of anything else. |
|
gen-const-3-23.diff (96,712 bytes)
From 376a757c8340f9c8995c9ba25cc09400d0ce9280 Mon Sep 17 00:00:00 2001 From: Ryan Joseph <genericptr@gmail.com> Date: Tue, 6 Nov 2018 13:58:49 +0700 Subject: [PATCH] constants in generics --- .gitignore | 24 + compiler/defcmp.pas | 9 +- compiler/htypechk.pas | 132 +++--- compiler/ncon.pas | 42 +- compiler/nmat.pas | 5 +- compiler/node.pas | 22 +- compiler/nset.pas | 7 +- compiler/pdecl.pas | 53 ++- compiler/pdecvar.pas | 4 + compiler/pexpr.pas | 11 +- compiler/pgentype.pas | 8 +- compiler/pgenutil.pas | 693 ++++++++++++++++++++--------- compiler/ppu.pas | 2 +- compiler/ptype.pas | 4 +- compiler/symconst.pas | 12 +- compiler/symdef.pas | 22 +- compiler/symsym.pas | 22 +- compiler/symtable.pas | 2 +- compiler/utils/ppuutils/ppudump.pp | 3 +- tests/test/tgenconst1.pp | 33 ++ tests/test/tgenconst10.pp | 13 + tests/test/tgenconst11.pp | 21 + tests/test/tgenconst12.pp | 16 + tests/test/tgenconst13.pp | 20 + tests/test/tgenconst14.pp | 29 ++ tests/test/tgenconst15.pp | 30 ++ tests/test/tgenconst16.pp | 86 ++++ tests/test/tgenconst17.pp | 36 ++ tests/test/tgenconst18.pp | 12 + tests/test/tgenconst2.pp | 12 + tests/test/tgenconst3.pp | 16 + tests/test/tgenconst4.pp | 11 + tests/test/tgenconst5.pp | 24 + tests/test/tgenconst6.pp | 21 + tests/test/tgenconst7.pp | 11 + tests/test/tgenconst8.pp | 11 + tests/test/tgenconst9.pp | 11 + 37 files changed, 1163 insertions(+), 327 deletions(-) create mode 100644 .gitignore create mode 100644 tests/test/tgenconst1.pp create mode 100644 tests/test/tgenconst10.pp create mode 100644 tests/test/tgenconst11.pp create mode 100644 tests/test/tgenconst12.pp create mode 100644 tests/test/tgenconst13.pp create mode 100644 tests/test/tgenconst14.pp create mode 100644 tests/test/tgenconst15.pp create mode 100644 tests/test/tgenconst16.pp create mode 100644 tests/test/tgenconst17.pp create mode 100644 tests/test/tgenconst18.pp create mode 100644 tests/test/tgenconst2.pp create mode 100644 tests/test/tgenconst3.pp create mode 100644 tests/test/tgenconst4.pp create mode 100644 tests/test/tgenconst5.pp create mode 100644 tests/test/tgenconst6.pp create mode 100644 tests/test/tgenconst7.pp create mode 100644 tests/test/tgenconst8.pp create mode 100644 tests/test/tgenconst9.pp diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..a82c960cbe --- /dev/null +++ b/.gitignore @@ -0,0 +1,24 @@ +# files +.gitignore +pp +fpmake +rtl/darwin/fpcmade.x86_64-darwin +fpmake_proc1 copy.inc +tests/*.x86_64-darwin +rtl/Package.fpc +tests/createlst +tests/gparmake + +# directories +lazbuild/ +x86_64-darwin/ +tests/tstunits/ +tests/utils + +# patterns +*.app +*.o +*.ppu +*.fpm +*.rsj +*.lst \ No newline at end of file diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 3f5882f762..793dbbbe76 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -175,7 +175,6 @@ implementation symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -337,9 +336,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 07c035dc26..bd51cebdf3 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -152,22 +152,22 @@ interface function token2managementoperator(optoken:ttoken):tmanagementoperator; { check operator args and result type } - - type - toverload_check_flag = ( - ocf_check_non_overloadable, { also check operators that are (currently) considered as - not overloadable (e.g. the "+" operator for dynamic arrays - if modeswitch arrayoperators is active) } - ocf_check_only { only check whether the operator is overloaded, but don't - modify the passed in node (return true if the operator is - overloaded, false otherwise) } - ); - toverload_check_flags = set of toverload_check_flag; - + + type + toverload_check_flag = ( + ocf_check_non_overloadable, { also check operators that are (currently) considered as + not overloadable (e.g. the "+" operator for dynamic arrays + if modeswitch arrayoperators is active) } + ocf_check_only { only check whether the operator is overloaded, but don't + modify the passed in node (return true if the operator is + overloaded, false otherwise) } + ); + toverload_check_flags = set of toverload_check_flag; + function isbinaryoperatoroverloadable(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype) : boolean; function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean; - function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; - function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; { Register Allocation } procedure make_not_regable(p : tnode; how: tregableinfoflags); @@ -515,9 +515,9 @@ implementation end; { <dyn. array> + <dyn. array> is handled by the compiler } - if (m_array_operators in current_settings.modeswitches) and - (treetyp=addn) and - (is_dynamic_array(ld) or is_dynamic_array(rd)) then + if (m_array_operators in current_settings.modeswitches) and + (treetyp=addn) and + (is_dynamic_array(ld) or is_dynamic_array(rd)) then begin allowed:=false; exit; @@ -720,7 +720,7 @@ implementation end; - function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isunaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; var ld : tdef; optoken : ttoken; @@ -742,11 +742,11 @@ implementation else inlinenumber:=in_none; - if not (ocf_check_non_overloadable in ocf) and not isunaryoperatoroverloadable(t.nodetype,inlinenumber,ld) then + if not (ocf_check_non_overloadable in ocf) and not isunaryoperatoroverloadable(t.nodetype,inlinenumber,ld) then exit; { operator overload is possible } - result:=not (ocf_check_only in ocf); + result:=not (ocf_check_only in ocf); optoken:=NOTOKEN; case t.nodetype of @@ -766,11 +766,11 @@ implementation end; if (optoken=NOTOKEN) then begin - if not (ocf_check_only in ocf) then - begin - CGMessage(parser_e_operator_not_overloaded); - t:=cnothingnode.create; - end; + if not (ocf_check_only in ocf) then + begin + CGMessage(parser_e_operator_not_overloaded); + t:=cnothingnode.create; + end; exit; end; @@ -790,11 +790,11 @@ implementation begin candidates.free; ppn.free; - if not (ocf_check_only in ocf) then - begin - CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); - t:=cnothingnode.create; - end; + if not (ocf_check_only in ocf) then + begin + CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); + t:=cnothingnode.create; + end; exit; end; @@ -811,16 +811,16 @@ implementation begin candidates.free; ppn.free; - if not (ocf_check_only in ocf) then - begin - CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); - t:=cnothingnode.create; - end; + if not (ocf_check_only in ocf) then + begin + CGMessage2(parser_e_operator_not_overloaded_2,ld.typename,arraytokeninfo[optoken].str); + t:=cnothingnode.create; + end; exit; end; { Multiple candidates left? } - if (cand_cnt>1) and not (ocf_check_only in ocf) then + if (cand_cnt>1) and not (ocf_check_only in ocf) then begin CGMessage(type_e_cant_choose_overload_function); {$ifdef EXTDEBUG} @@ -833,13 +833,13 @@ implementation end; candidates.free; - if ocf_check_only in ocf then - begin - ppn.free; - result:=true; - exit; - end; - + if ocf_check_only in ocf then + begin + ppn.free; + result:=true; + exit; + end; + addsymref(operpd.procsym); { the nil as symtable signs firstcalln that this is @@ -852,7 +852,7 @@ implementation end; - function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; + function isbinaryoverloaded(var t : tnode;ocf:toverload_check_flags) : boolean; var rd,ld : tdef; optoken : ttoken; @@ -945,14 +945,14 @@ implementation { load easier access variables } ld:=tbinarynode(t).left.resultdef; rd:=tbinarynode(t).right.resultdef; - if not (ocf_check_non_overloadable in ocf) and - not isbinaryoperatoroverloadable(t.nodetype,ld,tbinarynode(t).left.nodetype,rd,tbinarynode(t).right.nodetype) then + if not (ocf_check_non_overloadable in ocf) and + not isbinaryoperatoroverloadable(t.nodetype,ld,tbinarynode(t).left.nodetype,rd,tbinarynode(t).right.nodetype) then exit; { operator overload is possible } - { if we only check for the existance of the overload, then we assume that - it is not overloaded } - result:=not (ocf_check_only in ocf); + { if we only check for the existance of the overload, then we assume that + it is not overloaded } + result:=not (ocf_check_only in ocf); case t.nodetype of equaln: @@ -997,19 +997,19 @@ implementation optoken:=_OP_IN; else begin - if not (ocf_check_only in ocf) then - begin - CGMessage(parser_e_operator_not_overloaded); - t:=cnothingnode.create; - end; + if not (ocf_check_only in ocf) then + begin + CGMessage(parser_e_operator_not_overloaded); + t:=cnothingnode.create; + end; exit; end; end; - cand_cnt:=search_operator(optoken,(optoken<>_NE) and not (ocf_check_only in ocf)); + cand_cnt:=search_operator(optoken,(optoken<>_NE) and not (ocf_check_only in ocf)); { no operator found for "<>" then search for "=" operator } - if (cand_cnt=0) and (optoken=_NE) and not (ocf_check_only in ocf) then + if (cand_cnt=0) and (optoken=_NE) and not (ocf_check_only in ocf) then begin ppn.free; ppn:=nil; @@ -1021,15 +1021,15 @@ implementation if (cand_cnt=0) then begin ppn.free; - if not (ocf_check_only in ocf) then - t:=cnothingnode.create; - exit; - end; - - if ocf_check_only in ocf then - begin - ppn.free; - result:=true; + if not (ocf_check_only in ocf) then + t:=cnothingnode.create; + exit; + end; + + if ocf_check_only in ocf then + begin + ppn.free; + result:=true; exit; end; @@ -2697,7 +2697,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/ncon.pas b/compiler/ncon.pas index ae94637c28..1e203f74d6 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -279,6 +279,7 @@ implementation p1 : tnode; len : longint; pc : pchar; + value_set : pconstset; begin p1:=nil; case p.consttyp of @@ -304,18 +305,51 @@ 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 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_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; + { constundefined is a placeholder for unrestricted generic const params + so we just treat it as a nil node. } + constundefined : + begin + p1:=cnilnode.create; + p1.resultdef:=p.constdef; + end; 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 355b493da4..d10dff6128 100644 --- a/compiler/nmat.pas +++ b/compiler/nmat.pas @@ -129,7 +129,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 b8600000bf..33a85b1493 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -194,7 +194,8 @@ interface 'loadparentfpn', 'objcselectorn', 'objcprotocoln', - 'specializen'); + 'specializen' + ); { a set containing all const nodes } nodetype_const = [ordconstn, @@ -272,10 +273,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 } @@ -983,6 +987,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; @@ -1078,7 +1085,12 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; diff --git a/compiler/nset.pas b/compiler/nset.pas index 6270ec582e..bd031e6a86 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -239,7 +239,7 @@ implementation internalerror(20021126); t:=self; - if isbinaryoverloaded(t,[]) then + if isbinaryoverloaded(t,[]) then begin result:=t; exit; @@ -392,8 +392,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/pdecl.pas b/compiler/pdecl.pas index c5b5bcc921..d7e80b928f 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -126,9 +126,14 @@ implementation end; setconstn : begin - new(ps); - ps^:=tsetconstnode(p).value_set^; - hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); + if nf_generic_para in p.flags then + hp:=cconstsym.create_ptr(orgname,constset,nil,p.resultdef) + else + begin + new(ps); + ps^:=tsetconstnode(p).value_set^; + hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); + end; end; pointerconstn : begin @@ -141,18 +146,18 @@ implementation typen : begin if is_interface(p.resultdef) then - begin - if assigned(tobjectdef(p.resultdef).iidguid) then - begin - new(pg); - pg^:=tobjectdef(p.resultdef).iidguid^; - hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); - end - else - Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); - end - else - Message(parser_e_illegal_expression); + begin + if assigned(tobjectdef(p.resultdef).iidguid) then + begin + new(pg); + pg^:=tobjectdef(p.resultdef).iidguid^; + hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); + end + else + Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); + end + else + Message(parser_e_illegal_expression); end; inlinen: begin @@ -177,8 +182,19 @@ 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 + include(hp.symoptions,sp_generic_para); current_tokenpos:=storetokenpos; p.free; readconstant:=hp; @@ -507,8 +523,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/pdecvar.pas b/compiler/pdecvar.pas index 4d39397e46..8121d87853 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -1675,6 +1675,10 @@ implementation end; 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 bc0606ed4b..e6d9633ebd 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -446,6 +446,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,sinttype,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 @@ -466,6 +469,9 @@ implementation end else statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,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; @@ -4078,7 +4084,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 diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78f6..85270df256 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -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 7760a4e134..ac6e59ce98 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; @@ -63,18 +63,163 @@ implementation uses { common } - cutils,fpccrc, + sysutils,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; + type + tdeftypeset = set of tdeftyp; + const + tgeneric_param_const_types : tdeftypeset = [orddef,stringdef,arraydef,floatdef,setdef,pointerdef,undefineddef]; + 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 is_generic_param_const(sym:tsym):boolean; + begin + if sym.typ=constsym then + result:=tconstsym(sym).consttyp<>constundefined + else + result:=false; + end; + + function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue):boolean; + begin + if (value.len<param2.low) or (value.len>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 + begin + sym:=cconstsym.create_undefined(undefinedname,fromdef); + sym.owner:=fromdef.owner; + prettyname:=''; + result:=sym; + exit; + end; + case node.nodetype of + ordconstn: + begin + sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef); + prettyname:=inttostr(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:=floattostr(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 us the typeparam owner } + sym.owner:=fromdef.owner; + result:=sym; + end; procedure maybe_add_waiting_unit(tt:tdef); var @@ -104,203 +249,232 @@ 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; + //paratype : tconsttyp; + 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:=is_generic_param_const(tsym(paramlist[i])); + 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 - intffound:=assigned( - find_implemented_interface(objdef, - timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef - ) - ); + 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 + 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 +484,12 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +501,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); @@ -351,7 +528,9 @@ uses block_type:=bt_type; tmpparampos:=current_filepos; typeparam:=factor(false,[ef_type_only]); - if typeparam.nodetype=typen then + { 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 +546,47 @@ 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 + 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 - begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else + if typeparam.nodetype = typen then 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 +606,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; @@ -578,7 +773,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 @@ -627,7 +822,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); @@ -656,7 +851,7 @@ uses result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -747,6 +942,7 @@ uses hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -755,7 +951,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 } @@ -771,20 +967,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 } @@ -1196,8 +1391,8 @@ 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; @@ -1205,22 +1400,87 @@ uses doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const := true; + const_list_index := result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype,false); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=tconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ttypesym.create(orgpattern,cundefinedtype,false); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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: + 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; + end; + tconstsym(result[i]).constdef:=def; + end + else + Message(type_e_mismatch); + end; + { after type restriction const list terminates } + is_const:=false; + end; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then { TODO } @@ -1335,6 +1595,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 @@ -1360,21 +1621,27 @@ 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 + is_const:=false; + last_token:=token; + last_type_pos:=current_filepos; until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); { 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; @@ -1382,7 +1649,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; @@ -1407,10 +1676,22 @@ 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,true); + if generictype.typ=typesym then + sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef,true) + 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); + end + else + internalerror(2019021602); { type parameters need to be added as strict private } sym.visibility:=vis_strictprivate; st.insert(sym); @@ -1418,13 +1699,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/ppu.pas b/compiler/ppu.pas index 10c42e7eb8..31011be3e8 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -43,7 +43,7 @@ type {$endif Test_Double_checksum} const - CurrentPPUVersion = 201; + CurrentPPUVersion = 203; { unit flags } uf_init = $000001; { unit has initialization section } diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 38e2526e9f..28cd0f94f8 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1436,7 +1436,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 diff --git a/compiler/symconst.pas b/compiler/symconst.pas index a5ae7e0fb9..e02ce3a8ca 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -232,7 +232,10 @@ type because we have to access this information in the symtable unit } df_llvm_no_struct_packing, { internal def that's not for any export } - df_internal + df_internal, + { 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; @@ -651,7 +654,7 @@ type arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -692,7 +695,8 @@ type tconsttyp = (constnone, constord,conststring,constreal, constset,constpointer,constnil, - constresourcestring,constwstring,constguid + constresourcestring,constwstring,constguid, + constundefined ); { RTTI information to store } @@ -831,7 +835,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 4a260c46b9..0f7a2e4c06 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -129,6 +129,9 @@ interface function is_generic:boolean;inline; { same as above for specializations } function is_specialization:boolean;inline; + { 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 @@ -2197,13 +2200,26 @@ 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); 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 @@ -2220,12 +2236,12 @@ 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); end; - result:=false; end; end; diff --git a/compiler/symsym.pas b/compiler/symsym.pas index b21a5f9de9..04c07a5ec7 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -157,7 +157,7 @@ interface fprettyname : ansistring; constructor create(const n : string;def:tdef;doregister:boolean);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -392,6 +392,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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1581,7 +1582,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2344,6 +2344,13 @@ implementation value.len:=getlengthwidestring(pw); end; + constructor tconstsym.create_undefined(const n : string;def: tdef); + begin + inherited create(constsym,n,true); + fillchar(value, sizeof(value), #0); + consttyp:=constundefined; + constdef:=def; + end; constructor tconstsym.ppuload(ppufile:tcompilerppufile); var @@ -2416,7 +2423,8 @@ implementation new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil, + constundefined : ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2448,7 +2456,7 @@ implementation begin inherited; case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdefderef.build(constdef); constwstring: ; @@ -2461,7 +2469,7 @@ implementation procedure tconstsym.deref; begin case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdef:=tdef(constdefderef.resolve); constwstring: constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pcompilerwidestring(value.valueptr))); @@ -2476,7 +2484,8 @@ implementation inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil, + constundefined : ppufile.putderef(constdefderef); constord : begin @@ -2627,7 +2636,6 @@ implementation result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 796b2d6736..ae82024b03 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -2781,7 +2781,7 @@ implementation function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp index 74fde5c6c2..80d9d4df11 100644 --- a/compiler/utils/ppuutils/ppudump.pp +++ b/compiler/utils/ppuutils/ppudump.pp @@ -1552,7 +1552,8 @@ const { this should never happen for defs stored to a ppu file } (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_internal; str:'Internal'), + (mask:df_has_generic_fields; str:'Has generic fields') ); defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=( (mask:ds_vmt_written; str:'VMT Written'), diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 0000000000..297b982b0f --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,33 @@ +{$mode objfpc} +program tgenconst1; + +type + kNames = set of (Blaise,Pascal); + 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 TUndefined<const U> = 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 TUndefined<nil>; + 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..f05a27718c --- /dev/null +++ b/tests/test/tgenconst10.pp @@ -0,0 +1,13 @@ +{%FAIL} + +{$mode objfpc} + +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..ea409bec9b --- /dev/null +++ b/tests/test/tgenconst11.pp @@ -0,0 +1,21 @@ +{%FAIL} +{$mode objfpc} +program tgenconst11; +type + TEnum = (aaa,bbb,ccc,ddd); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<20>.Create; + b:=specialize TConst<10.1>.Create; + c:=specialize TConst<'_string'>.Create; + d:=specialize TConst<[1,2,3,4]>.Create; + e:=specialize TConst<[aaa,bbb,ccc,ddd]>.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..8f591f6867 --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +program tgenconst12; + +type + generic TTest<const U> = class + class procedure DoThis; + end; + +class procedure TTest.DoThis; +begin +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..0d5f8b1813 --- /dev/null +++ b/tests/test/tgenconst13.pp @@ -0,0 +1,20 @@ +{$mode objfpc} +program tgenconst13; +type + TEnum = (aaa,bbb,ccc); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<10>.Create; + b:=specialize TConst<10.5>.Create; + c:=specialize TConst<'string'>.Create; + d:=specialize TConst<[1,2,3]>.Create; + e:=specialize TConst<[aaa,bbb,ccc]>.Create; +end. diff --git a/tests/test/tgenconst14.pp b/tests/test/tgenconst14.pp new file mode 100644 index 0000000000..7f98086630 --- /dev/null +++ b/tests/test/tgenconst14.pp @@ -0,0 +1,29 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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; + end; + +var + op: specialize TBinaryOp<100>; +begin + writeln(op.d0); + writeln(op.d1); + writeln(op.d2); + writeln(op.d3:1:1); + writeln(op.d4); + writeln(op.d5); + writeln(op.d6); + writeln(op.d7); +end. \ No newline at end of file diff --git a/tests/test/tgenconst15.pp b/tests/test/tgenconst15.pp new file mode 100644 index 0000000000..56744cd0a7 --- /dev/null +++ b/tests/test/tgenconst15.pp @@ -0,0 +1,30 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst15; + +type + kNames = set of (Blaise, Pascal); + generic TSet<const I: kNames> = record + const c = I; + end; + generic TString<const I: String> = record + const c = I; + end; + generic TWideString<const I: WideString> = record + const c = I; + end; + generic TSingle<const I: Single> = record + const c = I; + end; + generic TDouble<const I: Double> = record + const c = I; + end; + generic TReal<const I: Real> = record + const c = I; + end; + +var + a0: specialize TReal<100>; +begin + writeln(a0.c); +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..275867ce25 --- /dev/null +++ b/tests/test/tgenconst16.pp @@ -0,0 +1,86 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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> = 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> = record + const + d0 = -I; + d1 = +I; + d2 = not I; + end; + generic TBinaryOp<const I> = 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> = record + procedure DoThis(param: integer = I); + end; + +procedure TOther.DoThis(param: integer = I); +begin + writeln(param, ' default:', I); +end; + +var + t0: specialize TBinaryOp<100>; + t1: specialize TOther<100>; +begin + //writeln(op.d0); + //writeln(op.d1); + //writeln(op.d2); + //writeln(op.d3:1:1); + //writeln(op.d4); + //writeln(op.d5); + //writeln(op.d6); + //writeln(op.d7); +end. \ No newline at end of file diff --git a/tests/test/tgenconst17.pp b/tests/test/tgenconst17.pp new file mode 100644 index 0000000000..26dc2ee21f --- /dev/null +++ b/tests/test/tgenconst17.pp @@ -0,0 +1,36 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst17; + +type + generic TUnaryOp<const I: integer> = record + const + d0 = -I; + d1 = +I; + d2 = not I; + end; + 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 xor I; + d9 = I shl I; + d10 = I shr I; + d11 = I << I; + d12 = I >> I; + d13 = I <> I; + d14 = I < I; + d15 = I > I; + d16 = I <= I; + d17 = I >= I; + d18 = I = I; + end; + +begin +end. \ No newline at end of file diff --git a/tests/test/tgenconst18.pp b/tests/test/tgenconst18.pp new file mode 100644 index 0000000000..a4ba526803 --- /dev/null +++ b/tests/test/tgenconst18.pp @@ -0,0 +1,12 @@ +{%FAIL} +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst18; + +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/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 0000000000..aa3a960634 --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,12 @@ +{$mode objfpc} +program tgenconst2; + +type + generic TStuff1<T1,T2;const U1,U2> = record end; + generic TStuff2<T1,T2;const U1,U2:integer> = record end; + +var + a: specialize TStuff1<integer,string,10,'string'>; + b: specialize TStuff2<integer,string,10,10>; +begin +end. diff --git a/tests/test/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 0000000000..aea0e307e2 --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 0000000000..a1fae00c43 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,11 @@ +{$mode objfpc} +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..63514a976c --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,24 @@ +{$mode objfpc} +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..3ee3785423 --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,21 @@ +{$mode delphi} +program tgenconst6; + +type + TList<T;const U> = 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..9d8e81ef05 --- /dev/null +++ b/tests/test/tgenconst7.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..75844f7181 --- /dev/null +++ b/tests/test/tgenconst8.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..939cb90302 --- /dev/null +++ b/tests/test/tgenconst9.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +program tgenconst9; + +type + generic TByte<const U: Byte> = record end; + +var + a: specialize TByte<string>; +begin +end. -- 2.17.2 (Apple Git-113) |
|
|
|
I didn't get any feedback on the new bugs but I believe I fixed all of them and added some new tests which stress all the constant variations. This time I didn't remove the no-op lines in the patch because I believe the old line endings may be incorrect actually. Look at screenshot I sent from "Sublime Merge". It shows there's something different about the old line endings and I haven't seen them anywhere else so I think it may be good to replace them actually. |
|
It doesn't matter whether they are incorrect or not. Your issue has nothing to do with incorrect line endings in unrelated code. If they annoy you, then report them in a separate issue. Here they only make reviewing the real changes harder. |
|
Sorry about that, I've been busy for the past few days. I'll update my local copy again and give it a test right now. |
|
Ok, I'm back. Seems good to me! I tried really hard to break it / get it to crash, but it seems to handle everything properly now. |
|
patch_3_25.diff (87,689 bytes)
From c80227ed7597385d240aa7bdc1556798aa15ec20 Mon Sep 17 00:00:00 2001 From: Ryan Joseph <genericptr@gmail.com> Date: Tue, 6 Nov 2018 13:58:49 +0700 Subject: [PATCH] constants in generics --- .gitignore | 23 + compiler/defcmp.pas | 9 +- compiler/htypechk.pas | 2 +- compiler/ncon.pas | 42 +- compiler/nmat.pas | 5 +- compiler/node.pas | 22 +- compiler/nset.pas | 7 +- compiler/pdecl.pas | 53 ++- compiler/pdecvar.pas | 4 + compiler/pexpr.pas | 11 +- compiler/pgentype.pas | 8 +- compiler/pgenutil.pas | 693 ++++++++++++++++++++--------- compiler/ppu.pas | 2 +- compiler/ptype.pas | 4 +- compiler/symconst.pas | 12 +- compiler/symdef.pas | 22 +- compiler/symsym.pas | 22 +- compiler/symtable.pas | 2 +- compiler/utils/ppuutils/ppudump.pp | 3 +- tests/test/tgenconst1.pp | 33 ++ tests/test/tgenconst10.pp | 13 + tests/test/tgenconst11.pp | 21 + tests/test/tgenconst12.pp | 16 + tests/test/tgenconst13.pp | 20 + tests/test/tgenconst14.pp | 29 ++ tests/test/tgenconst15.pp | 30 ++ tests/test/tgenconst16.pp | 86 ++++ tests/test/tgenconst17.pp | 36 ++ tests/test/tgenconst18.pp | 12 + tests/test/tgenconst2.pp | 12 + tests/test/tgenconst3.pp | 16 + tests/test/tgenconst4.pp | 11 + tests/test/tgenconst5.pp | 24 + tests/test/tgenconst6.pp | 21 + tests/test/tgenconst7.pp | 11 + tests/test/tgenconst8.pp | 11 + tests/test/tgenconst9.pp | 11 + 37 files changed, 1097 insertions(+), 262 deletions(-) create mode 100644 .gitignore create mode 100644 tests/test/tgenconst1.pp create mode 100644 tests/test/tgenconst10.pp create mode 100644 tests/test/tgenconst11.pp create mode 100644 tests/test/tgenconst12.pp create mode 100644 tests/test/tgenconst13.pp create mode 100644 tests/test/tgenconst14.pp create mode 100644 tests/test/tgenconst15.pp create mode 100644 tests/test/tgenconst16.pp create mode 100644 tests/test/tgenconst17.pp create mode 100644 tests/test/tgenconst18.pp create mode 100644 tests/test/tgenconst2.pp create mode 100644 tests/test/tgenconst3.pp create mode 100644 tests/test/tgenconst4.pp create mode 100644 tests/test/tgenconst5.pp create mode 100644 tests/test/tgenconst6.pp create mode 100644 tests/test/tgenconst7.pp create mode 100644 tests/test/tgenconst8.pp create mode 100644 tests/test/tgenconst9.pp diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..64fdb156d0 --- /dev/null +++ b/.gitignore @@ -0,0 +1,23 @@ +# files +pp +fpmake +rtl/darwin/fpcmade.x86_64-darwin +fpmake_proc1 copy.inc +tests/*.x86_64-darwin +rtl/Package.fpc +tests/createlst +tests/gparmake + +# directories +lazbuild/ +x86_64-darwin/ +tests/tstunits/ +tests/utils + +# patterns +*.app +*.o +*.ppu +*.fpm +*.rsj +*.lst \ No newline at end of file diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 3f5882f762..793dbbbe76 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -175,7 +175,6 @@ implementation symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -337,9 +336,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 07c035dc26..2358ea4b6d 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2697,7 +2697,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/ncon.pas b/compiler/ncon.pas index ae94637c28..1e203f74d6 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -279,6 +279,7 @@ implementation p1 : tnode; len : longint; pc : pchar; + value_set : pconstset; begin p1:=nil; case p.consttyp of @@ -304,18 +305,51 @@ 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 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_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; + { constundefined is a placeholder for unrestricted generic const params + so we just treat it as a nil node. } + constundefined : + begin + p1:=cnilnode.create; + p1.resultdef:=p.constdef; + end; 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 355b493da4..d10dff6128 100644 --- a/compiler/nmat.pas +++ b/compiler/nmat.pas @@ -129,7 +129,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 b8600000bf..33a85b1493 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -194,7 +194,8 @@ interface 'loadparentfpn', 'objcselectorn', 'objcprotocoln', - 'specializen'); + 'specializen' + ); { a set containing all const nodes } nodetype_const = [ordconstn, @@ -272,10 +273,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 } @@ -983,6 +987,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; @@ -1078,7 +1085,12 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; diff --git a/compiler/nset.pas b/compiler/nset.pas index 6270ec582e..bd031e6a86 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -239,7 +239,7 @@ implementation internalerror(20021126); t:=self; - if isbinaryoverloaded(t,[]) then + if isbinaryoverloaded(t,[]) then begin result:=t; exit; @@ -392,8 +392,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/pdecl.pas b/compiler/pdecl.pas index c5b5bcc921..d7e80b928f 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -126,9 +126,14 @@ implementation end; setconstn : begin - new(ps); - ps^:=tsetconstnode(p).value_set^; - hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); + if nf_generic_para in p.flags then + hp:=cconstsym.create_ptr(orgname,constset,nil,p.resultdef) + else + begin + new(ps); + ps^:=tsetconstnode(p).value_set^; + hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); + end; end; pointerconstn : begin @@ -141,18 +146,18 @@ implementation typen : begin if is_interface(p.resultdef) then - begin - if assigned(tobjectdef(p.resultdef).iidguid) then - begin - new(pg); - pg^:=tobjectdef(p.resultdef).iidguid^; - hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); - end - else - Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); - end - else - Message(parser_e_illegal_expression); + begin + if assigned(tobjectdef(p.resultdef).iidguid) then + begin + new(pg); + pg^:=tobjectdef(p.resultdef).iidguid^; + hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); + end + else + Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); + end + else + Message(parser_e_illegal_expression); end; inlinen: begin @@ -177,8 +182,19 @@ 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 + include(hp.symoptions,sp_generic_para); current_tokenpos:=storetokenpos; p.free; readconstant:=hp; @@ -507,8 +523,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/pdecvar.pas b/compiler/pdecvar.pas index 4d39397e46..8121d87853 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -1675,6 +1675,10 @@ implementation end; 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 bc0606ed4b..e6d9633ebd 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -446,6 +446,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,sinttype,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 @@ -466,6 +469,9 @@ implementation end else statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,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; @@ -4078,7 +4084,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 diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78f6..85270df256 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -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 7760a4e134..ac6e59ce98 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; @@ -63,18 +63,163 @@ implementation uses { common } - cutils,fpccrc, + sysutils,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; + type + tdeftypeset = set of tdeftyp; + const + tgeneric_param_const_types : tdeftypeset = [orddef,stringdef,arraydef,floatdef,setdef,pointerdef,undefineddef]; + 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 is_generic_param_const(sym:tsym):boolean; + begin + if sym.typ=constsym then + result:=tconstsym(sym).consttyp<>constundefined + else + result:=false; + end; + + function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue):boolean; + begin + if (value.len<param2.low) or (value.len>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 + begin + sym:=cconstsym.create_undefined(undefinedname,fromdef); + sym.owner:=fromdef.owner; + prettyname:=''; + result:=sym; + exit; + end; + case node.nodetype of + ordconstn: + begin + sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef); + prettyname:=inttostr(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:=floattostr(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 us the typeparam owner } + sym.owner:=fromdef.owner; + result:=sym; + end; procedure maybe_add_waiting_unit(tt:tdef); var @@ -104,203 +249,232 @@ 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; + //paratype : tconsttyp; + 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:=is_generic_param_const(tsym(paramlist[i])); + 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 - intffound:=assigned( - find_implemented_interface(objdef, - timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef - ) - ); + 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 + 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 +484,12 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +501,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); @@ -351,7 +528,9 @@ uses block_type:=bt_type; tmpparampos:=current_filepos; typeparam:=factor(false,[ef_type_only]); - if typeparam.nodetype=typen then + { 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 +546,47 @@ 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 + 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 - begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else + if typeparam.nodetype = typen then 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 +606,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; @@ -578,7 +773,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 @@ -627,7 +822,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); @@ -656,7 +851,7 @@ uses result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -747,6 +942,7 @@ uses hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -755,7 +951,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 } @@ -771,20 +967,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 } @@ -1196,8 +1391,8 @@ 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; @@ -1205,22 +1400,87 @@ uses doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const := true; + const_list_index := result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype,false); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=tconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ttypesym.create(orgpattern,cundefinedtype,false); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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: + 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; + end; + tconstsym(result[i]).constdef:=def; + end + else + Message(type_e_mismatch); + end; + { after type restriction const list terminates } + is_const:=false; + end; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then { TODO } @@ -1335,6 +1595,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 @@ -1360,21 +1621,27 @@ 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 + is_const:=false; + last_token:=token; + last_type_pos:=current_filepos; until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); { 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; @@ -1382,7 +1649,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; @@ -1407,10 +1676,22 @@ 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,true); + if generictype.typ=typesym then + sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef,true) + 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); + end + else + internalerror(2019021602); { type parameters need to be added as strict private } sym.visibility:=vis_strictprivate; st.insert(sym); @@ -1418,13 +1699,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/ppu.pas b/compiler/ppu.pas index 10c42e7eb8..31011be3e8 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -43,7 +43,7 @@ type {$endif Test_Double_checksum} const - CurrentPPUVersion = 201; + CurrentPPUVersion = 203; { unit flags } uf_init = $000001; { unit has initialization section } diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 38e2526e9f..28cd0f94f8 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1436,7 +1436,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 diff --git a/compiler/symconst.pas b/compiler/symconst.pas index a5ae7e0fb9..e02ce3a8ca 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -232,7 +232,10 @@ type because we have to access this information in the symtable unit } df_llvm_no_struct_packing, { internal def that's not for any export } - df_internal + df_internal, + { 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; @@ -651,7 +654,7 @@ type arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -692,7 +695,8 @@ type tconsttyp = (constnone, constord,conststring,constreal, constset,constpointer,constnil, - constresourcestring,constwstring,constguid + constresourcestring,constwstring,constguid, + constundefined ); { RTTI information to store } @@ -831,7 +835,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 4a260c46b9..0f7a2e4c06 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -129,6 +129,9 @@ interface function is_generic:boolean;inline; { same as above for specializations } function is_specialization:boolean;inline; + { 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 @@ -2197,13 +2200,26 @@ 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); 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 @@ -2220,12 +2236,12 @@ 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); end; - result:=false; end; end; diff --git a/compiler/symsym.pas b/compiler/symsym.pas index b21a5f9de9..04c07a5ec7 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -157,7 +157,7 @@ interface fprettyname : ansistring; constructor create(const n : string;def:tdef;doregister:boolean);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -392,6 +392,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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1581,7 +1582,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2344,6 +2344,13 @@ implementation value.len:=getlengthwidestring(pw); end; + constructor tconstsym.create_undefined(const n : string;def: tdef); + begin + inherited create(constsym,n,true); + fillchar(value, sizeof(value), #0); + consttyp:=constundefined; + constdef:=def; + end; constructor tconstsym.ppuload(ppufile:tcompilerppufile); var @@ -2416,7 +2423,8 @@ implementation new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil, + constundefined : ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2448,7 +2456,7 @@ implementation begin inherited; case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdefderef.build(constdef); constwstring: ; @@ -2461,7 +2469,7 @@ implementation procedure tconstsym.deref; begin case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdef:=tdef(constdefderef.resolve); constwstring: constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pcompilerwidestring(value.valueptr))); @@ -2476,7 +2484,8 @@ implementation inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil, + constundefined : ppufile.putderef(constdefderef); constord : begin @@ -2627,7 +2636,6 @@ implementation result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 796b2d6736..ae82024b03 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -2781,7 +2781,7 @@ implementation function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp index 74fde5c6c2..80d9d4df11 100644 --- a/compiler/utils/ppuutils/ppudump.pp +++ b/compiler/utils/ppuutils/ppudump.pp @@ -1552,7 +1552,8 @@ const { this should never happen for defs stored to a ppu file } (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_internal; str:'Internal'), + (mask:df_has_generic_fields; str:'Has generic fields') ); defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=( (mask:ds_vmt_written; str:'VMT Written'), diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 0000000000..297b982b0f --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,33 @@ +{$mode objfpc} +program tgenconst1; + +type + kNames = set of (Blaise,Pascal); + 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 TUndefined<const U> = 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 TUndefined<nil>; + 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..f05a27718c --- /dev/null +++ b/tests/test/tgenconst10.pp @@ -0,0 +1,13 @@ +{%FAIL} + +{$mode objfpc} + +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..ea409bec9b --- /dev/null +++ b/tests/test/tgenconst11.pp @@ -0,0 +1,21 @@ +{%FAIL} +{$mode objfpc} +program tgenconst11; +type + TEnum = (aaa,bbb,ccc,ddd); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<20>.Create; + b:=specialize TConst<10.1>.Create; + c:=specialize TConst<'_string'>.Create; + d:=specialize TConst<[1,2,3,4]>.Create; + e:=specialize TConst<[aaa,bbb,ccc,ddd]>.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..8f591f6867 --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +program tgenconst12; + +type + generic TTest<const U> = class + class procedure DoThis; + end; + +class procedure TTest.DoThis; +begin +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..0d5f8b1813 --- /dev/null +++ b/tests/test/tgenconst13.pp @@ -0,0 +1,20 @@ +{$mode objfpc} +program tgenconst13; +type + TEnum = (aaa,bbb,ccc); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<10>.Create; + b:=specialize TConst<10.5>.Create; + c:=specialize TConst<'string'>.Create; + d:=specialize TConst<[1,2,3]>.Create; + e:=specialize TConst<[aaa,bbb,ccc]>.Create; +end. diff --git a/tests/test/tgenconst14.pp b/tests/test/tgenconst14.pp new file mode 100644 index 0000000000..7f98086630 --- /dev/null +++ b/tests/test/tgenconst14.pp @@ -0,0 +1,29 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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; + end; + +var + op: specialize TBinaryOp<100>; +begin + writeln(op.d0); + writeln(op.d1); + writeln(op.d2); + writeln(op.d3:1:1); + writeln(op.d4); + writeln(op.d5); + writeln(op.d6); + writeln(op.d7); +end. \ No newline at end of file diff --git a/tests/test/tgenconst15.pp b/tests/test/tgenconst15.pp new file mode 100644 index 0000000000..56744cd0a7 --- /dev/null +++ b/tests/test/tgenconst15.pp @@ -0,0 +1,30 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst15; + +type + kNames = set of (Blaise, Pascal); + generic TSet<const I: kNames> = record + const c = I; + end; + generic TString<const I: String> = record + const c = I; + end; + generic TWideString<const I: WideString> = record + const c = I; + end; + generic TSingle<const I: Single> = record + const c = I; + end; + generic TDouble<const I: Double> = record + const c = I; + end; + generic TReal<const I: Real> = record + const c = I; + end; + +var + a0: specialize TReal<100>; +begin + writeln(a0.c); +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..275867ce25 --- /dev/null +++ b/tests/test/tgenconst16.pp @@ -0,0 +1,86 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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> = 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> = record + const + d0 = -I; + d1 = +I; + d2 = not I; + end; + generic TBinaryOp<const I> = 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> = record + procedure DoThis(param: integer = I); + end; + +procedure TOther.DoThis(param: integer = I); +begin + writeln(param, ' default:', I); +end; + +var + t0: specialize TBinaryOp<100>; + t1: specialize TOther<100>; +begin + //writeln(op.d0); + //writeln(op.d1); + //writeln(op.d2); + //writeln(op.d3:1:1); + //writeln(op.d4); + //writeln(op.d5); + //writeln(op.d6); + //writeln(op.d7); +end. \ No newline at end of file diff --git a/tests/test/tgenconst17.pp b/tests/test/tgenconst17.pp new file mode 100644 index 0000000000..26dc2ee21f --- /dev/null +++ b/tests/test/tgenconst17.pp @@ -0,0 +1,36 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst17; + +type + generic TUnaryOp<const I: integer> = record + const + d0 = -I; + d1 = +I; + d2 = not I; + end; + 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 xor I; + d9 = I shl I; + d10 = I shr I; + d11 = I << I; + d12 = I >> I; + d13 = I <> I; + d14 = I < I; + d15 = I > I; + d16 = I <= I; + d17 = I >= I; + d18 = I = I; + end; + +begin +end. \ No newline at end of file diff --git a/tests/test/tgenconst18.pp b/tests/test/tgenconst18.pp new file mode 100644 index 0000000000..a4ba526803 --- /dev/null +++ b/tests/test/tgenconst18.pp @@ -0,0 +1,12 @@ +{%FAIL} +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst18; + +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/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 0000000000..aa3a960634 --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,12 @@ +{$mode objfpc} +program tgenconst2; + +type + generic TStuff1<T1,T2;const U1,U2> = record end; + generic TStuff2<T1,T2;const U1,U2:integer> = record end; + +var + a: specialize TStuff1<integer,string,10,'string'>; + b: specialize TStuff2<integer,string,10,10>; +begin +end. diff --git a/tests/test/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 0000000000..aea0e307e2 --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 0000000000..a1fae00c43 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,11 @@ +{$mode objfpc} +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..63514a976c --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,24 @@ +{$mode objfpc} +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..3ee3785423 --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,21 @@ +{$mode delphi} +program tgenconst6; + +type + TList<T;const U> = 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..9d8e81ef05 --- /dev/null +++ b/tests/test/tgenconst7.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..75844f7181 --- /dev/null +++ b/tests/test/tgenconst8.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..939cb90302 --- /dev/null +++ b/tests/test/tgenconst9.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +program tgenconst9; + +type + generic TByte<const U: Byte> = record end; + +var + a: specialize TByte<string>; +begin +end. -- 2.17.2 (Apple Git-113) |
|
Uploaded another patch with the line endings fixed. I was only able to edit the file in a plain text editor because the other programming editors I have all removed the bad line ending automatically. |
|
Any movement on this? |
|
Not yet but Sven was able to close another bug report of mine (assignment operator overloads) and getting close to committing multi-helpers mode switch. |
|
In the interest of moving this (very cool, and *fully working*) feature along, I merged the latest FPC trunk (literally from today) into a clean checkout of Ryan's branch, and created a patch (against only the compiler directory, which is all that's relevant here) that I've verified can be successfully applied back against a clean trunk checkout from the top-level "fpcsrc " directory with a command line of "patch -p 0 -i ./generic_constants_may4.patch". I've attached that patch here, as well as a tiny 7z file containing the "tgenconst" prefixed tests that Ryan wrote, which should be extracted to "fpcsrc/tests/test". generic_constants_may4.patch (71,526 bytes)
diff -ur compiler/defcmp.pas compiler/defcmp.pas --- compiler/defcmp.pas 2019-05-04 11:21:35.506321600 -0400 +++ compiler/defcmp.pas 2019-05-04 10:02:12.755701000 -0400 @@ -175,7 +175,6 @@ symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -345,9 +344,13 @@ 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 -ur compiler/htypechk.pas compiler/htypechk.pas --- compiler/htypechk.pas 2019-05-04 11:21:35.631332300 -0400 +++ compiler/htypechk.pas 2019-05-04 10:02:12.349417700 -0400 @@ -2723,7 +2723,7 @@ 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 -ur compiler/ncon.pas compiler/ncon.pas --- compiler/ncon.pas 2019-05-04 11:21:35.709462700 -0400 +++ compiler/ncon.pas 2019-05-04 10:02:03.520316200 -0400 @@ -279,6 +279,7 @@ p1 : tnode; len : longint; pc : pchar; + value_set : pconstset; begin p1:=nil; case p.consttyp of @@ -304,18 +305,51 @@ 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 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_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; + { constundefined is a placeholder for unrestricted generic const params + so we just treat it as a nil node. } + constundefined : + begin + p1:=cnilnode.create; + p1.resultdef:=p.constdef; + end; 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 -ur compiler/nmat.pas compiler/nmat.pas --- compiler/nmat.pas 2019-05-04 11:21:35.787594200 -0400 +++ compiler/nmat.pas 2019-05-04 10:02:02.879642000 -0400 @@ -129,7 +129,10 @@ 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 -ur compiler/node.pas compiler/node.pas --- compiler/node.pas 2019-05-04 11:21:35.881351800 -0400 +++ compiler/node.pas 2019-05-04 10:02:47.741464800 -0400 @@ -274,10 +274,13 @@ 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 } @@ -985,6 +988,9 @@ 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; @@ -1080,7 +1086,12 @@ constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; diff -ur compiler/nset.pas compiler/nset.pas --- compiler/nset.pas 2019-05-04 11:21:35.959483400 -0400 +++ compiler/nset.pas 2019-05-04 10:02:02.270218000 -0400 @@ -401,8 +401,9 @@ { 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 -ur compiler/pdecl.pas compiler/pdecl.pas --- compiler/pdecl.pas 2019-05-04 11:21:36.037614400 -0400 +++ compiler/pdecl.pas 2019-05-04 10:02:01.895188400 -0400 @@ -126,9 +126,14 @@ end; setconstn : begin - new(ps); - ps^:=tsetconstnode(p).value_set^; - hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); + if nf_generic_para in p.flags then + hp:=cconstsym.create_ptr(orgname,constset,nil,p.resultdef) + else + begin + new(ps); + ps^:=tsetconstnode(p).value_set^; + hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); + end; end; pointerconstn : begin @@ -141,18 +146,18 @@ typen : begin if is_interface(p.resultdef) then - begin - if assigned(tobjectdef(p.resultdef).iidguid) then - begin - new(pg); - pg^:=tobjectdef(p.resultdef).iidguid^; - hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); - end - else - Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); - end - else - Message(parser_e_illegal_expression); + begin + if assigned(tobjectdef(p.resultdef).iidguid) then + begin + new(pg); + pg^:=tobjectdef(p.resultdef).iidguid^; + hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); + end + else + Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); + end + else + Message(parser_e_illegal_expression); end; inlinen: begin @@ -177,8 +182,19 @@ 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 + include(hp.symoptions,sp_generic_para); current_tokenpos:=storetokenpos; p.free; readconstant:=hp; @@ -510,8 +526,9 @@ { 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 -ur compiler/pdecvar.pas compiler/pdecvar.pas --- compiler/pdecvar.pas 2019-05-04 11:21:36.100120600 -0400 +++ compiler/pdecvar.pas 2019-05-04 10:02:01.567037900 -0400 @@ -1705,6 +1705,10 @@ 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 -ur compiler/pexpr.pas compiler/pexpr.pas --- compiler/pexpr.pas 2019-05-04 11:21:36.178250700 -0400 +++ compiler/pexpr.pas 2019-05-04 10:02:01.192002400 -0400 @@ -446,6 +446,9 @@ { no packed bit support for these things } if l=in_bitsizeof_x then statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sinttype,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 @@ -466,6 +469,9 @@ end else statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,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; @@ -4167,7 +4173,10 @@ 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 diff -ur compiler/pgentype.pas compiler/pgentype.pas --- compiler/pgentype.pas 2019-05-04 11:21:36.240755700 -0400 +++ compiler/pgentype.pas 2019-05-04 10:01:26.150428600 -0400 @@ -28,7 +28,7 @@ uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -42,7 +42,7 @@ tspecializationcontext=class public - genericdeflist : tfpobjectlist; + paramlist : tfpobjectlist; poslist : tfplist; prettyname : ansistring; specializename : ansistring; @@ -58,7 +58,7 @@ constructor tspecializationcontext.create; begin - genericdeflist:=tfpobjectlist.create(false); + paramlist:=tfpobjectlist.create(false); poslist:=tfplist.create; end; @@ -66,7 +66,7 @@ var i : longint; begin - genericdeflist.free; + paramlist.free; for i:=0 to poslist.count-1 do dispose(pfileposinfo(poslist[i])); poslist.free; diff -ur compiler/pgenutil.pas compiler/pgenutil.pas --- compiler/pgenutil.pas 2019-05-04 11:21:36.303260700 -0400 +++ compiler/pgenutil.pas 2019-05-04 11:12:01.223659000 -0400 @@ -42,9 +42,9 @@ 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; @@ -63,18 +63,163 @@ uses { common } - cutils,fpccrc, + sysutils,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,undefineddef]; + 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 is_generic_param_const(sym:tsym):boolean; + begin + if sym.typ=constsym then + result:=tconstsym(sym).consttyp<>constundefined + else + result:=false; + end; + + function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue):boolean; + begin + if (value.len<param2.low) or (value.len>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 + begin + sym:=cconstsym.create_undefined(undefinedname,fromdef); + sym.owner:=fromdef.owner; + prettyname:=''; + result:=sym; + exit; + end; + case node.nodetype of + ordconstn: + begin + sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef); + prettyname:=inttostr(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:=floattostr(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 us the typeparam owner } + sym.owner:=fromdef.owner; + result:=sym; + end; procedure maybe_add_waiting_unit(tt:tdef); var @@ -104,203 +249,232 @@ 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; + //paratype : tconsttyp; + 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:=is_generic_param_const(tsym(paramlist[i])); + 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 - 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 + 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 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 +484,12 @@ namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +501,7 @@ 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); @@ -351,7 +528,9 @@ block_type:=bt_type; tmpparampos:=current_filepos; typeparam:=factor(false,[ef_type_only]); - if typeparam.nodetype=typen then + { 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 +546,47 @@ 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 + 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 - begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else + if typeparam.nodetype = typen then 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 +606,12 @@ 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; @@ -578,7 +773,7 @@ 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 @@ -627,7 +822,7 @@ { 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); @@ -656,7 +851,7 @@ result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -747,6 +942,7 @@ hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -755,7 +951,7 @@ 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 } @@ -771,20 +967,19 @@ 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 } @@ -1199,8 +1394,8 @@ 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; @@ -1208,22 +1403,88 @@ doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; + last_type_pos:=default(tfileposinfo); repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const := true; + const_list_index := result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype,false); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=tconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ttypesym.create(orgpattern,cundefinedtype,false); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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: + 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; + end; + tconstsym(result[i]).constdef:=def; + end + else + Message(type_e_mismatch); + end; + { after type restriction const list terminates } + is_const:=false; + end; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then { TODO } @@ -1338,6 +1599,7 @@ 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 @@ -1363,21 +1625,27 @@ 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 + is_const:=false; + last_token:=token; + last_type_pos:=current_filepos; until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); { 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; @@ -1385,7 +1653,9 @@ 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; @@ -1410,10 +1680,22 @@ 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,true); + if generictype.typ=typesym then + sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef,true) + 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); + end + else + internalerror(2019021602); { type parameters need to be added as strict private } sym.visibility:=vis_strictprivate; st.insert(sym); @@ -1421,13 +1703,17 @@ 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 -ur compiler/ptype.pas compiler/ptype.pas --- compiler/ptype.pas 2019-05-04 11:21:36.365935500 -0400 +++ compiler/ptype.pas 2019-05-04 10:02:00.801275500 -0400 @@ -1436,7 +1436,9 @@ 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 Only in compiler: ryan_ppcx64.lpi diff -ur compiler/symconst.pas compiler/symconst.pas --- compiler/symconst.pas 2019-05-04 11:21:36.428440800 -0400 +++ compiler/symconst.pas 2019-05-04 10:02:00.598133900 -0400 @@ -231,7 +231,10 @@ because we have to access this information in the symtable unit } df_llvm_no_struct_packing, { internal def that's not for any export } - df_internal + df_internal, + { 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; @@ -659,7 +662,7 @@ arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -700,7 +703,8 @@ tconsttyp = (constnone, constord,conststring,constreal, constset,constpointer,constnil, - constresourcestring,constwstring,constguid + constresourcestring,constwstring,constguid, + constundefined ); { RTTI information to store } @@ -840,7 +844,7 @@ 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff -ur compiler/symdef.pas compiler/symdef.pas --- compiler/symdef.pas 2019-05-04 11:21:36.490945500 -0400 +++ compiler/symdef.pas 2019-05-04 10:03:49.892616700 -0400 @@ -129,6 +129,9 @@ 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 @@ -2295,13 +2298,26 @@ 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); 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 @@ -2318,12 +2334,12 @@ 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); end; - result:=false; end; end; diff -ur compiler/symsym.pas compiler/symsym.pas --- compiler/symsym.pas 2019-05-04 11:21:36.537824600 -0400 +++ compiler/symsym.pas 2019-05-04 10:01:59.785568500 -0400 @@ -157,7 +157,7 @@ fprettyname : ansistring; constructor create(const n : string;def:tdef;doregister:boolean);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -392,6 +392,7 @@ 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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1584,7 +1585,6 @@ tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2356,6 +2356,13 @@ value.len:=getlengthwidestring(pw); end; + constructor tconstsym.create_undefined(const n : string;def: tdef); + begin + inherited create(constsym,n,true); + fillchar(value, sizeof(value), #0); + consttyp:=constundefined; + constdef:=def; + end; constructor tconstsym.ppuload(ppufile:tcompilerppufile); var @@ -2428,7 +2435,8 @@ new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil, + constundefined : ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2460,7 +2468,7 @@ begin inherited; case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdefderef.build(constdef); constwstring: ; @@ -2473,7 +2481,7 @@ procedure tconstsym.deref; begin case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdef:=tdef(constdefderef.resolve); constwstring: constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pcompilerwidestring(value.valueptr))); @@ -2488,7 +2496,8 @@ inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil, + constundefined : ppufile.putderef(constdefderef); constord : begin @@ -2641,7 +2650,6 @@ result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff -ur compiler/symtable.pas compiler/symtable.pas --- compiler/symtable.pas 2019-05-04 11:21:36.584702800 -0400 +++ compiler/symtable.pas 2019-05-04 10:01:59.738689700 -0400 @@ -2916,7 +2916,7 @@ function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff -ur compiler/utils/ppuutils/ppudump.pp compiler/utils/ppuutils/ppudump.pp --- compiler/utils/ppuutils/ppudump.pp 2019-05-04 11:21:36.631582400 -0400 +++ compiler/utils/ppuutils/ppudump.pp 2019-05-04 10:01:59.707422300 -0400 @@ -1561,7 +1561,8 @@ { this should never happen for defs stored to a ppu file } (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_internal; str:'Internal'), + (mask:df_has_generic_fields; str:'Has generic fields') ); defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=( (mask:ds_vmt_written; str:'VMT Written'), |
|
Also, for anyone who isn't aware of quite what this is about, here's a real example (in both {$mode ObjFPC} and {$mode Delphi}) that shows what it makes possible: program ConstMatrixExampleObjFPC; {$mode ObjFPC} {$modeswitch AdvancedRecords} type String3 = String[3]; generic TRawMatrix<T; const N: SizeUInt> = array[0..N-1] of array[0..N-1] of T; generic TMatrix<T; const N: SizeUInt> = record private type ArrayType = specialize TRawMatrix<T, N>; private Data: ArrayType; public class operator :=(constref Arr: ArrayType): TMatrix; inline; procedure Display; end; class operator TMatrix.:=(constref Arr: ArrayType): TMatrix; begin Result.Data := Arr; end; procedure TMatrix.Display; var I, J: SizeInt; begin WriteLn('['); for I := 0 to N - 1 do begin Write(' ['); for J := 0 to N - 2 do Write(Data[I, J], ', '); Write(Data[I, N - 1]); Writeln('] '); end; Write(']'); end; const RawMat: specialize TRawMatrix<String3, 4> = ( ('AAA', 'BBB', 'CCC', 'DDD'), ('EEE', 'FFF', 'GGG', 'HHH'), ('III', 'JJJ', 'KKK', 'LLL'), ('MMM', 'NNN', 'OOO', 'PPP') ); var Mat: specialize TMatrix<String3, 4>; begin Mat := RawMat; Mat.Display(); end. ///////// program ConstMatrixExampleDelphi; {$mode Delphi} type String3 = String[3]; TRawMatrix<T; const N: SizeUInt> = array[0..N-1] of array[0..N-1] of T; TMatrix<T; const N: SizeUInt> = record private type ArrayType = TRawMatrix<T, N>; private Data: ArrayType; public class operator Implicit(constref Arr: ArrayType): TMatrix<T, N>; inline; procedure Display; end; class operator TMatrix<T, N>.Implicit(constref Arr: ArrayType): TMatrix<T, N>; begin Result.Data := Arr; end; procedure TMatrix<T, N>.Display; var I, J: SizeInt; begin WriteLn('['); for I := 0 to N - 1 do begin Write(' ['); for J := 0 to N - 2 do Write(Data[I, J], ', '); Write(Data[I, N - 1]); Writeln('] '); end; Write(']'); end; const RawMat: TRawMatrix<String3, 4> = ( ('AAA', 'BBB', 'CCC', 'DDD'), ('EEE', 'FFF', 'GGG', 'HHH'), ('III', 'JJJ', 'KKK', 'LLL'), ('MMM', 'NNN', 'OOO', 'PPP') ); var Mat: TMatrix<String3, 4>; begin Mat := RawMat; Mat.Display(); end. |
|
Thanks for trying to help. I think it takes the compiler team months to get to all the patches so there's not much we can do. Sven almost got to one of my other patches (multi-helpers) but stalled out since then. |
|
No problem. The patch did kind of need to be updated either way FWIW, as it was against a now-oldish-by-trunk-standards revision that lacked some non-trivial changes made recently. Hopefully the more concise scope of the version I uploaded does make it easier for the relevant people to test sooner than later. |
|
That's a good point. I'm still pretty newbie with git so how should I go about keeping up to date with the original fork? I think you're supposed to pull from the upstream "remote" or something like that but I'm not sure. All my branches are out of date now so my patches are going to eventually be useless. Any general advice on this is supposed to work would be nice. |
|
IMO, at the minimum, if you at least keep the "master" or "upstream" branch (it's obvious which it is when looking at them directly) of your overall fork-repo up to date with simple pulls/fetches/whatever, it makes it a lot easier for anyone pulling your patches to quickly update them in-place against it. Otherwise, they (as I did) basically have to do a clean checkout of trunk separately, and use not-necessarily-VCS-specific tools to do a folder-based diff. Better than that is though just.... merge trunk into all your branches as often as you can. If there's conflicts, try to fix them (as you'd ultimately have to do regardless.) |
|
Still nothing on this? I'm happy to do another update / merge here, if that helps at all... |
|
It should be done as this: "Almighty Sven, I summon you. Please accept my gift and merge this code..." |
|
Is Sven the only person who actually applies patches? I don't know if this is pending code review or they simply don't have the time to apply the patch. Sven did look this all over pretty well I thought so I don't know what the delay is. He applied the multi-helpers patch already but this patch is significantly more intrusive. |
|
No. It's just Sven often responds much faster to our cries / summoning :) |
|
> this patch is significantly more intrusive. Is it though? I'm not sure I'd necessarily call adding functionality that simply didn't exist in any form previously, and certainly is only relevant if used intentionally "intrusive". |
|
I mean intrusive in terms of how much of the code base it touched. The patch is going to require more code review than the multi-helpers mode switch for example. That's probably we he's taking longer than usual. |
|
I was reading this page in the Swift documentation on "extension methods" recently, which includes an example of using them to implement unit-of-measurement conversion for the "Double" type: https://docs.swift.org/swift-book/LanguageGuide/Extensions.html#ID152 Extension methods in Swift are essentially the same thing as type helpers in Object Pascal, so of course you could also implement that using a type helper for Double in FPC. However: it would have to use functions, as there is no way to refer to "Self" with a type helper from the interface, meaning it could not be used to initialize constant values of any kind. This is where another handy use for *generic* constant types comes in (working example below, BTW): program Example; // using Delphi-mode here as a matter of preference... {$mode Delphi} type Meters<const Value: Double> = record public const ToKilometers = Value / 1000; Unconverted = Value; ToCentimeters = Value * 100; ToMillimeters = Value * 1000; ToFeet = Value * 3.28084; end; procedure Test; type TenMeters = Meters<10>; const KILOMETER_VALUE = TenMeters.ToKilometers; UNCONVERTED_VALUE = TenMeters.Unconverted; CENTIMETER_VALUE = TenMeters.ToCentimeters; MILLIMETER_VALUE = TenMeters.ToMillimeters; FOOT_VALUE = TenMeters.ToFeet; begin WriteLn(KILOMETER_VALUE : 0 : 4); WriteLn(UNCONVERTED_VALUE); WriteLn(CENTIMETER_VALUE); WriteLn(MILLIMETER_VALUE); WriteLn(FOOT_VALUE : 0 : 4); end; begin Test(); end. Lots of neat stuff you can do with this feature, in general. |
|
Came across a couple of additional bugs with this functionality while doing some more experiments with it yesterday. For generic constant parameters with floating-point constraints, e.g. something like the following: FloatOps<const Value: Double> = record public const Squared = Value * Value; // other stuff here probably end; When passed a number with any kind of decimal place (such as, say, 12.56 or 19.23423 as opposed to just 12 or 19) like so: WriteLn(FloatOps<12.56>.Squared); the value is for some reason not registered correctly and always winds up as 0. Floating point constraints *do* work fine with values containing no trailing period, however, e.g. the following: WriteLn(FloatOps<12>.Squared); does print 144 like you'd expect. Also, there appears to still be a few range-checking oversights with regards to unsigned type constraints. For example, if you have: TStaticList<T; const Length: SizeUInt> public Values: array[0..Length - 1] of T; procedure Display; end; procedure TStaticList<T, Length>.Display; var I: SizeUInt; begin for I := 0 to Length - 1 do WriteLn(Values[I]); end; you will get "range check error while evaluating constants" *not* at the array declaration (so that's fixed, which is good) but in the procedure body, which still at that point seems to interpret "Length" as 0, and since Length is unsigned, doing Length - 1 as the high parameter for the unsigned loop variable takes it out of range. Would be very interested in any further work you might feel like doing on this feature, as the implications for increased optimization opportunities that it provides are pretty significant IMO. The fact that it works as well as it does already, and has the capabilities it does is extremely impressive though, do note. For example, the developers of Rust are currently implementing something similar, but as it stands now their implementation is pretty horribly broken in a variety of ways (to the extent that it regularly crashes the Rust compiler) and will by the nature of that language's design never be able to be combined with stuff like compile-time string concatenation the way this FPC take on the concept can. |
|
Thanks, I look into these later when I have some time. |
|
ok, fixed those bugs and added 2 tests. Transferring generic parameter constants to structure member constants was broken in other areas also so it's good I got this fixed (tests included now). As for for-loops there was just a missing range check which needed to be included. patch_7_20.diff (94,414 bytes)
From 173ee8d64e4dec40db5f7346e311bd26d4bf3766 Mon Sep 17 00:00:00 2001 From: Ryan Joseph <genericptr@gmail.com> Date: Tue, 6 Nov 2018 13:58:49 +0700 Subject: [PATCH] constants in generics --- compiler/defcmp.pas | 9 +- compiler/htypechk.pas | 2 +- compiler/ncnv.pas | 2 +- compiler/ncon.pas | 48 +- compiler/nmat.pas | 5 +- compiler/node.pas | 22 +- compiler/nset.pas | 7 +- compiler/pass_1.pas | 5 + compiler/pdecl.pas | 54 ++- compiler/pdecvar.pas | 4 + compiler/pexpr.pas | 17 +- compiler/pgentype.pas | 8 +- compiler/pgenutil.pas | 697 ++++++++++++++++++++--------- compiler/ppu.pas | 2 +- compiler/pstatmnt.pas | 7 +- compiler/ptype.pas | 4 +- compiler/symconst.pas | 15 +- compiler/symdef.pas | 22 +- compiler/symsym.pas | 22 +- compiler/symtable.pas | 2 +- compiler/utils/ppuutils/ppudump.pp | 4 +- tests/test/tgenconst1.pp | 33 ++ tests/test/tgenconst10.pp | 13 + tests/test/tgenconst11.pp | 21 + tests/test/tgenconst12.pp | 16 + tests/test/tgenconst13.pp | 20 + tests/test/tgenconst14.pp | 29 ++ tests/test/tgenconst15.pp | 30 ++ tests/test/tgenconst16.pp | 86 ++++ tests/test/tgenconst17.pp | 36 ++ tests/test/tgenconst18.pp | 12 + tests/test/tgenconst19.pp | 49 ++ tests/test/tgenconst2.pp | 12 + tests/test/tgenconst20.pp | 24 + tests/test/tgenconst3.pp | 16 + tests/test/tgenconst4.pp | 11 + tests/test/tgenconst5.pp | 24 + tests/test/tgenconst6.pp | 21 + tests/test/tgenconst7.pp | 11 + tests/test/tgenconst8.pp | 11 + tests/test/tgenconst9.pp | 11 + 41 files changed, 1176 insertions(+), 268 deletions(-) create mode 100644 tests/test/tgenconst1.pp create mode 100644 tests/test/tgenconst10.pp create mode 100644 tests/test/tgenconst11.pp create mode 100644 tests/test/tgenconst12.pp create mode 100644 tests/test/tgenconst13.pp create mode 100644 tests/test/tgenconst14.pp create mode 100644 tests/test/tgenconst15.pp create mode 100644 tests/test/tgenconst16.pp create mode 100644 tests/test/tgenconst17.pp create mode 100644 tests/test/tgenconst18.pp create mode 100644 tests/test/tgenconst19.pp create mode 100644 tests/test/tgenconst2.pp create mode 100644 tests/test/tgenconst20.pp create mode 100644 tests/test/tgenconst3.pp create mode 100644 tests/test/tgenconst4.pp create mode 100644 tests/test/tgenconst5.pp create mode 100644 tests/test/tgenconst6.pp create mode 100644 tests/test/tgenconst7.pp create mode 100644 tests/test/tgenconst8.pp create mode 100644 tests/test/tgenconst9.pp diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 3f5882f762..793dbbbe76 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -175,7 +175,6 @@ implementation symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -337,9 +336,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 07c035dc26..2358ea4b6d 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2697,7 +2697,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 31135872da..cb246b6fc6 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -3033,7 +3033,7 @@ implementation { for constant values on absolute variables, swaping is required } if (target_info.endian = endian_big) and (nf_absolute in flags) then swap_const_value(tordconstnode(left).value,tordconstnode(left).resultdef.size); - if not(nf_internal in flags) then + if not((nf_internal in flags) or (nf_generic_para in flags)) then testrange(resultdef,tordconstnode(left).value,(nf_explicit in flags) or (nf_absolute in flags),false); { swap value back, but according to new type } diff --git a/compiler/ncon.pas b/compiler/ncon.pas index ae94637c28..fadf704935 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -279,6 +279,7 @@ implementation p1 : tnode; len : longint; pc : pchar; + value_set : pconstset; begin p1:=nil; case p.consttyp of @@ -304,18 +305,57 @@ 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; + { constundefined is a placeholder for unrestricted generic const params + so we just treat it as a nil node. } + constundefined : + begin + p1:=cnilnode.create; + p1.resultdef:=p.constdef; + end; 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 355b493da4..d10dff6128 100644 --- a/compiler/nmat.pas +++ b/compiler/nmat.pas @@ -129,7 +129,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 b8600000bf..33a85b1493 100644 --- a/compiler/node.pas +++ b/compiler/node.pas @@ -194,7 +194,8 @@ interface 'loadparentfpn', 'objcselectorn', 'objcprotocoln', - 'specializen'); + 'specializen' + ); { a set containing all const nodes } nodetype_const = [ordconstn, @@ -272,10 +273,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 } @@ -983,6 +987,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; @@ -1078,7 +1085,12 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; diff --git a/compiler/nset.pas b/compiler/nset.pas index 6270ec582e..bd031e6a86 100644 --- a/compiler/nset.pas +++ b/compiler/nset.pas @@ -239,7 +239,7 @@ implementation internalerror(20021126); t:=self; - if isbinaryoverloaded(t,[]) then + if isbinaryoverloaded(t,[]) then begin result:=t; exit; @@ -392,8 +392,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 b9f7f847ee..ed314072e1 100644 --- a/compiler/pass_1.pas +++ b/compiler/pass_1.pas @@ -66,6 +66,7 @@ implementation oldverbosity : longint; oldpos : tfileposinfo; hp : tnode; + oldflags : tnodeflags; begin node_changed:=false; if (p.resultdef=nil) then @@ -83,9 +84,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); { run typecheckpass } typecheckpass(p); end; diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index c5b5bcc921..81c71a09a3 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -120,14 +120,15 @@ implementation end; realconstn : begin - new(pd); - pd^:=trealconstnode(p).value_real; - hp:=cconstsym.create_ptr(orgname,constreal,pd,p.resultdef); + new(pd); + pd^:=trealconstnode(p).value_real; + hp:=cconstsym.create_ptr(orgname,constreal,pd,p.resultdef); end; setconstn : begin new(ps); - ps^:=tsetconstnode(p).value_set^; + if assigned(tsetconstnode(p).value_set) then + ps^:=tsetconstnode(p).value_set^; hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); end; pointerconstn : @@ -141,18 +142,18 @@ implementation typen : begin if is_interface(p.resultdef) then - begin - if assigned(tobjectdef(p.resultdef).iidguid) then - begin - new(pg); - pg^:=tobjectdef(p.resultdef).iidguid^; - hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); - end - else - Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); - end - else - Message(parser_e_illegal_expression); + begin + if assigned(tobjectdef(p.resultdef).iidguid) then + begin + new(pg); + pg^:=tobjectdef(p.resultdef).iidguid^; + hp:=cconstsym.create_ptr(orgname,constguid,pg,p.resultdef); + end + else + Message1(parser_e_interface_has_no_guid,tobjectdef(p.resultdef).objrealname^); + end + else + Message(parser_e_illegal_expression); end; inlinen: begin @@ -177,8 +178,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; @@ -507,8 +522,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/pdecvar.pas b/compiler/pdecvar.pas index 4d39397e46..8121d87853 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -1675,6 +1675,10 @@ implementation end; 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 bc0606ed4b..3c1c527297 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -446,6 +446,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,sinttype,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 @@ -466,6 +469,9 @@ implementation end else statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sinttype,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; @@ -4078,7 +4084,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 @@ -4417,7 +4426,7 @@ implementation filepos : tfileposinfo; oldafterassignment, updatefpos : boolean; - + oldflags : tnodeflags; begin oldafterassignment:=afterassignment; p1:=sub_expr(opcompare,[ef_accept_equal],nil); @@ -4474,6 +4483,10 @@ implementation else updatefpos:=false; end; + oldflags:=p1.flags; + { transfer generic paramter flag } + if nf_generic_para in oldflags then + include(p1.flags,nf_generic_para); { get the resultdef for this expression } if not assigned(p1.resultdef) and dotypecheck then diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78f6..85270df256 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -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 7760a4e134..5addd281fd 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; @@ -63,18 +63,164 @@ implementation uses { common } - cutils,fpccrc, + sysutils,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; + type + tdeftypeset = set of tdeftyp; + const + tgeneric_param_const_types : tdeftypeset = [orddef,stringdef,arraydef,floatdef,setdef,pointerdef,undefineddef]; + 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 is_generic_param_const(sym:tsym):boolean; + begin + if sym.typ=constsym then + result:=tconstsym(sym).consttyp<>constundefined + else + result:=false; + end; + + function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue):boolean; + begin + if (value.len<param2.low) or (value.len>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 + begin + sym:=cconstsym.create_undefined(undefinedname,fromdef); + sym.owner:=fromdef.owner; + prettyname:=''; + result:=sym; + exit; + end; + case node.nodetype of + ordconstn: + begin + sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef); + prettyname:=inttostr(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:=floattostr(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 us 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 +250,232 @@ 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; + //paratype : tconsttyp; + 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:=is_generic_param_const(tsym(paramlist[i])); + 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 - intffound:=assigned( - find_implemented_interface(objdef, - timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef - ) - ); + 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 + 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 +485,12 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +502,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 +528,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 +547,47 @@ 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 + 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 - begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else + if typeparam.nodetype = typen then 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 +607,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; @@ -578,7 +774,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 @@ -627,7 +823,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); @@ -656,7 +852,7 @@ uses result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -747,6 +943,7 @@ uses hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -755,7 +952,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 } @@ -771,20 +968,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 } @@ -1196,8 +1392,8 @@ 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; @@ -1205,22 +1401,87 @@ uses doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const:=true; + const_list_index:=result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype,false); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=tconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ttypesym.create(orgpattern,cundefinedtype,false); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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: + 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; + end; + tconstsym(result[i]).constdef:=def; + end + else + Message(type_e_mismatch); + end; + { after type restriction const list terminates } + is_const:=false; + end; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then { TODO } @@ -1335,6 +1596,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 @@ -1360,21 +1622,27 @@ 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 + is_const:=false; + last_token:=token; + last_type_pos:=current_filepos; until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); { 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; @@ -1382,7 +1650,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; @@ -1407,10 +1677,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,true); + if generictype.typ=typesym then + sym:=ctypesym.create(genericlist.nameofindex(i),ttypesym(generictype).typedef,true) + 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); @@ -1418,13 +1701,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/ppu.pas b/compiler/ppu.pas index 10c42e7eb8..31011be3e8 100644 --- a/compiler/ppu.pas +++ b/compiler/ppu.pas @@ -43,7 +43,7 @@ type {$endif Test_Double_checksum} const - CurrentPPUVersion = 201; + CurrentPPUVersion = 203; { unit flags } uf_init = $000001; { unit has initialization section } diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index f528168733..16b5860e9d 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -360,7 +360,12 @@ implementation begin if (hp.nodetype=ordconstn) and (fordef.typ<>errordef) then - testrange(fordef,tordconstnode(hp).value,false,true); + begin + { the node was derived from a generic parameter so ignore range check } + if nf_generic_para in hp.flags then + exit; + testrange(fordef,tordconstnode(hp).value,false,true); + end; end; function for_loop_create(hloopvar: tnode): tnode; diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 38e2526e9f..28cd0f94f8 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1436,7 +1436,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 diff --git a/compiler/symconst.pas b/compiler/symconst.pas index a5ae7e0fb9..d1411039fd 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -205,8 +205,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; @@ -232,7 +233,10 @@ type because we have to access this information in the symtable unit } df_llvm_no_struct_packing, { internal def that's not for any export } - df_internal + df_internal, + { 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; @@ -651,7 +655,7 @@ type arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -692,7 +696,8 @@ type tconsttyp = (constnone, constord,conststring,constreal, constset,constpointer,constnil, - constresourcestring,constwstring,constguid + constresourcestring,constwstring,constguid, + constundefined ); { RTTI information to store } @@ -831,7 +836,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 4a260c46b9..0f7a2e4c06 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -129,6 +129,9 @@ interface function is_generic:boolean;inline; { same as above for specializations } function is_specialization:boolean;inline; + { 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 @@ -2197,13 +2200,26 @@ 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); 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 @@ -2220,12 +2236,12 @@ 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); end; - result:=false; end; end; diff --git a/compiler/symsym.pas b/compiler/symsym.pas index b21a5f9de9..04c07a5ec7 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -157,7 +157,7 @@ interface fprettyname : ansistring; constructor create(const n : string;def:tdef;doregister:boolean);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -392,6 +392,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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1581,7 +1582,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2344,6 +2344,13 @@ implementation value.len:=getlengthwidestring(pw); end; + constructor tconstsym.create_undefined(const n : string;def: tdef); + begin + inherited create(constsym,n,true); + fillchar(value, sizeof(value), #0); + consttyp:=constundefined; + constdef:=def; + end; constructor tconstsym.ppuload(ppufile:tcompilerppufile); var @@ -2416,7 +2423,8 @@ implementation new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil, + constundefined : ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2448,7 +2456,7 @@ implementation begin inherited; case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdefderef.build(constdef); constwstring: ; @@ -2461,7 +2469,7 @@ implementation procedure tconstsym.deref; begin case consttyp of - constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid: + constnil,constord,constreal,constpointer,constset,conststring,constresourcestring,constguid,constundefined: constdef:=tdef(constdefderef.resolve); constwstring: constdef:=carraydef.getreusable(cwidechartype,getlengthwidestring(pcompilerwidestring(value.valueptr))); @@ -2476,7 +2484,8 @@ implementation inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil, + constundefined : ppufile.putderef(constdefderef); constord : begin @@ -2627,7 +2636,6 @@ implementation result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 796b2d6736..ae82024b03 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -2781,7 +2781,7 @@ implementation function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp index 74fde5c6c2..dd1db81af7 100644 --- a/compiler/utils/ppuutils/ppudump.pp +++ b/compiler/utils/ppuutils/ppudump.pp @@ -1389,6 +1389,7 @@ const (mask:sp_has_deprecated_msg; str:'Has Deprecated Message'), (mask:sp_generic_dummy; str:'Generic Dummy'), (mask:sp_explicitrename; str:'Explicit Rename') + (mask:sp_generic_const; str:'Generic Constant Parameter'), ); var symoptions : tsymoptions; @@ -1552,7 +1553,8 @@ const { this should never happen for defs stored to a ppu file } (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_internal; str:'Internal'), + (mask:df_has_generic_fields; str:'Has generic fields') ); defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=( (mask:ds_vmt_written; str:'VMT Written'), diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 0000000000..297b982b0f --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,33 @@ +{$mode objfpc} +program tgenconst1; + +type + kNames = set of (Blaise,Pascal); + 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 TUndefined<const U> = 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 TUndefined<nil>; + 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..f05a27718c --- /dev/null +++ b/tests/test/tgenconst10.pp @@ -0,0 +1,13 @@ +{%FAIL} + +{$mode objfpc} + +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..ea409bec9b --- /dev/null +++ b/tests/test/tgenconst11.pp @@ -0,0 +1,21 @@ +{%FAIL} +{$mode objfpc} +program tgenconst11; +type + TEnum = (aaa,bbb,ccc,ddd); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<20>.Create; + b:=specialize TConst<10.1>.Create; + c:=specialize TConst<'_string'>.Create; + d:=specialize TConst<[1,2,3,4]>.Create; + e:=specialize TConst<[aaa,bbb,ccc,ddd]>.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..8f591f6867 --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +program tgenconst12; + +type + generic TTest<const U> = class + class procedure DoThis; + end; + +class procedure TTest.DoThis; +begin +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..0d5f8b1813 --- /dev/null +++ b/tests/test/tgenconst13.pp @@ -0,0 +1,20 @@ +{$mode objfpc} +program tgenconst13; +type + TEnum = (aaa,bbb,ccc); +type + generic TConst<const U> = class end; + +var + a:specialize TConst<10>; + b:specialize TConst<10.5>; + c:specialize TConst<'string'>; + d:specialize TConst<[1,2,3]>; + e:specialize TConst<[aaa,bbb,ccc]>; +begin + a:=specialize TConst<10>.Create; + b:=specialize TConst<10.5>.Create; + c:=specialize TConst<'string'>.Create; + d:=specialize TConst<[1,2,3]>.Create; + e:=specialize TConst<[aaa,bbb,ccc]>.Create; +end. diff --git a/tests/test/tgenconst14.pp b/tests/test/tgenconst14.pp new file mode 100644 index 0000000000..7f98086630 --- /dev/null +++ b/tests/test/tgenconst14.pp @@ -0,0 +1,29 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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; + end; + +var + op: specialize TBinaryOp<100>; +begin + writeln(op.d0); + writeln(op.d1); + writeln(op.d2); + writeln(op.d3:1:1); + writeln(op.d4); + writeln(op.d5); + writeln(op.d6); + writeln(op.d7); +end. \ No newline at end of file diff --git a/tests/test/tgenconst15.pp b/tests/test/tgenconst15.pp new file mode 100644 index 0000000000..56744cd0a7 --- /dev/null +++ b/tests/test/tgenconst15.pp @@ -0,0 +1,30 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst15; + +type + kNames = set of (Blaise, Pascal); + generic TSet<const I: kNames> = record + const c = I; + end; + generic TString<const I: String> = record + const c = I; + end; + generic TWideString<const I: WideString> = record + const c = I; + end; + generic TSingle<const I: Single> = record + const c = I; + end; + generic TDouble<const I: Double> = record + const c = I; + end; + generic TReal<const I: Real> = record + const c = I; + end; + +var + a0: specialize TReal<100>; +begin + writeln(a0.c); +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..275867ce25 --- /dev/null +++ b/tests/test/tgenconst16.pp @@ -0,0 +1,86 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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> = 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> = record + const + d0 = -I; + d1 = +I; + d2 = not I; + end; + generic TBinaryOp<const I> = 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> = record + procedure DoThis(param: integer = I); + end; + +procedure TOther.DoThis(param: integer = I); +begin + writeln(param, ' default:', I); +end; + +var + t0: specialize TBinaryOp<100>; + t1: specialize TOther<100>; +begin + //writeln(op.d0); + //writeln(op.d1); + //writeln(op.d2); + //writeln(op.d3:1:1); + //writeln(op.d4); + //writeln(op.d5); + //writeln(op.d6); + //writeln(op.d7); +end. \ No newline at end of file diff --git a/tests/test/tgenconst17.pp b/tests/test/tgenconst17.pp new file mode 100644 index 0000000000..26dc2ee21f --- /dev/null +++ b/tests/test/tgenconst17.pp @@ -0,0 +1,36 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst17; + +type + generic TUnaryOp<const I: integer> = record + const + d0 = -I; + d1 = +I; + d2 = not I; + end; + 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 xor I; + d9 = I shl I; + d10 = I shr I; + d11 = I << I; + d12 = I >> I; + d13 = I <> I; + d14 = I < I; + d15 = I > I; + d16 = I <= I; + d17 = I >= I; + d18 = I = I; + end; + +begin +end. \ No newline at end of file diff --git a/tests/test/tgenconst18.pp b/tests/test/tgenconst18.pp new file mode 100644 index 0000000000..a4ba526803 --- /dev/null +++ b/tests/test/tgenconst18.pp @@ -0,0 +1,12 @@ +{%FAIL} +{$mode objfpc} +{$modeswitch advancedrecords} +program tgenconst18; + +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/tgenconst19.pp b/tests/test/tgenconst19.pp new file mode 100644 index 0000000000..b7538b17a9 --- /dev/null +++ b/tests/test/tgenconst19.pp @@ -0,0 +1,49 @@ +{$mode objfpc} +{$modeswitch advancedrecords} + +program tgenconst19; + +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/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 0000000000..aa3a960634 --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,12 @@ +{$mode objfpc} +program tgenconst2; + +type + generic TStuff1<T1,T2;const U1,U2> = record end; + generic TStuff2<T1,T2;const U1,U2:integer> = record end; + +var + a: specialize TStuff1<integer,string,10,'string'>; + b: specialize TStuff2<integer,string,10,10>; +begin +end. diff --git a/tests/test/tgenconst20.pp b/tests/test/tgenconst20.pp new file mode 100644 index 0000000000..b87f0b2af1 --- /dev/null +++ b/tests/test/tgenconst20.pp @@ -0,0 +1,24 @@ +{$mode objfpc} +{$modeswitch advancedrecords} + +program tgenconst20; + +{ testing range checking for arrays and for-loops } +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/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 0000000000..aea0e307e2 --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +{$modeswitch advancedrecords} +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/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 0000000000..a1fae00c43 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,11 @@ +{$mode objfpc} +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..63514a976c --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,24 @@ +{$mode objfpc} +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..3ee3785423 --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,21 @@ +{$mode delphi} +program tgenconst6; + +type + TList<T;const U> = 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..9d8e81ef05 --- /dev/null +++ b/tests/test/tgenconst7.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..75844f7181 --- /dev/null +++ b/tests/test/tgenconst8.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +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..939cb90302 --- /dev/null +++ b/tests/test/tgenconst9.pp @@ -0,0 +1,11 @@ +{%FAIL} +{$mode objfpc} +program tgenconst9; + +type + generic TByte<const U: Byte> = record end; + +var + a: specialize TByte<string>; +begin +end. -- 2.17.2 (Apple Git-113) |
|
Question: I just merged an updated master branch into my local branch so I can make another patch but when I try to squash commits (to make a clean patch without commit history) git says "only commits reachable from HEAD can be modified". What should I do to keep my local branch up to date with the master branch? Squashing commits has been the only way I know of to make a clean patch that isn't filled with commit history but apparently merging branches makes this impossible now. Any advice would be great. |
|
Use "git rebase origin/master" instead of merging master into your branch. |
|
Thanks but it says it's already up to date (who knows what I'm doing wrong). I'm posting to the mail list so I don't overflow the bug report with discussion. My whole workflow is probably still wrong somewhere. |
|
The unsigned constraints problem and the zero-value floats one are definitely fixed now, so great job on that! There still seems to be some issues with floating point stuff in general, though. Specifically, this program just straight-up crashes the compiler for me: program Example; {$mode ObjFPC} {$modeswitch AdvancedRecords} {$Assertions On} type generic TFloatRange<const Low, High: Double> = record Value: Double; class function Make(const D: Double): TFloatRange; static; inline; class operator :=(const From: Double): TFloatRange; inline; end; class function TFloatRange.Make(const D: Double): TFloatRange; begin Assert((D >= Low) and (D <= High), 'Out of range!'); Result.Value := D; end; class operator TFloatRange.:=(const From: Double): TFloatRange; begin Result := TFloatRange.Make(From); end; var R: specialize TFloatRange<12.0, 24.0>; begin // Ok R := 14.0; // Out of range! R := 25.0; end. Let me know if you're able to reproduce the crash. |
|
No crash for me. Maybe the patch didn't apply right? You maybe saw my long thread on the list of me trying to figure out how to make better patches but I ran out of time and never got a solution. The patch is based on a pretty old revision so its getting harder to apply these things correctly. Hopefully the compiler team can actually accept this to the trunk soon. |
|
Hmm, seems to have been something with how I was building FPC. Your latest version fully merged into the latest trunk FPC does work fine for that program, after a clean build. One thing I should mention though, as I stated in this comment: https://bugs.freepascal.org/view.php?id=35140#c114506 your original version has *never* actually quite compiled successfully as written when building the compiler via the normal makefile method, as that sets "-Sew" (stop on warnings) which gets triggered by the "fileposinfo" thing I mentioned there. There's some additional breaking warnings introduced by the fact that case-statement-completeness is now checked in newer trunks too. I think maybe I should make up another patch of my tweaked / updated version and upload it here, like I did in May, to perhaps help speed things along with regards to making this cool feature official. |
|
We're in 2020 now at the patch is already pretty old and of date and needs updating. Is there anything we can do to help get this released? I submitted some other bug fix patches and I wanted to fix/finish the generic function specializations but it doesn't feel like these patches are getting considered and just collecting dust so it's kind of discouraging. I was looking forward to Bens multi line strings mode switch also but that seems to be in limbo also. Let me know if I can do a anything to help or get the process moving some more. Thanks. |
|
Comparing this feature to the multi line string one is unfair: The multi line string is highly controversial among core, this one is not. Here it's just about me finding the time to review and integrate it... However I noticed three things while skimming over the latest patch: - should you rebase your changes to current trunk, then you need to increase CurrentPPULongVersion instead of CurrentPPUVersion in unit ppu.pas - the test tgenconst11 is not as useful as you might think it is: using {%FAIL} you can only check for a single failure case as the testsuite only checks whether the compilation fails, not why it fails; so you need to handle each case of failure as a separate test - but that brings me to the third point: please get rid of the untyped constants, as I had written this back in November 2018 already ( https://lists.freepascal.org/pipermail/fpc-pascal/2018-November/055180.html ): === quote begin === Also thinking about the feature a bit it would be better to enforce the type of the constant during the generic's declaration. After all I can do different things with a string const, an ordinal const or a set const. So it would be better to use "const <NAME>: <TYPE>" where type can be any type that results in a tconstsym. After all the type of the constant inside the generic is usually fixed and those few cases were a variadic constant would be necessary could be handled by "TMyGeneric<T; const N: T>" (which would not work right now, but as we also need to support "TMyGeneric<T; S: SomeIntf<T>>" due to Delphi compatibility that would be handled by the same solution). This way you can also get rid of the cconstundefined and you can create a correct tconstsym right of the bat. === quote end === My intention was not for you to add typed constant generic parameters and leave the untyped ones in, but to get rid of the untyped ones altogether. If we should ever need the flexibility of untyped constants (and I don't want to open that can of worms until we know how the users will work with this feature) we can implement it in a typesafe way: TSomeGeneric<T; const N: T>. |
|
Ok, I'll make these changes and hopefully we can get moving on this. Just to confirm I'm removing this syntax: generic TUndefined<const U> = record end; and the accompanying code (which was significant). I think this was vestigial from before we decided to make type restrictions and I can't think of/remember any specific uses it may have so I'm happy to clean it out. |
|
Sven, if the there is no type specific what error should be given? Right now I just left it as: Syntax error, ":" expected but "" found MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_COLON].str,arraytokeninfo[last_token].str); |
|
The message is fine. This way the user will know (hopefully) that a type needs to follow. :) Well, if this leads to removing significant amount of code, then I'll have less to review :P |
|
I removed the undefined constants and updated the tests which you can quickly review at https://github.com/graemeg/freepascal/compare/master...genericptr:generic_constants?expand=1. I need to merge the upstream still and fix the PPU stuff + fix merge conflicts but that's a bit of hassle to keep redoing before it's reviewed. Are you able to see what you need from the GitHub branch I posted? I'll do the final changes once we're certain I got everything we need working. |
|
The changes look good so far. If you now rebase it and ensure that there are no regressions and your own tests work as well, then I'll hopefully find the time soon to finally integrate this. |
|
Here's the updated patch with merges from recent trunk. I'm learning more about git as I go along and found some better ways to make patches that didn't require squashing commits to hide commit history and making a new brach which I can delete unwanted files from. The current patch was made with: git diff master ':(exclude)*.gitignore' ':(exclude)*ryan_ppcx64.lpi' > patch.diff and previously I was using: git format-patch master --stdout > patch.diff Is the new patch format acceptable? It's far easier to make than the old method that required making a "clean" branch using the methods explained above. patch.diff (86,745 bytes)
diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 67f3119557..a61988d770 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -175,7 +175,6 @@ implementation symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -345,9 +344,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 e3b66a6f75..9ec84a240a 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2775,7 +2775,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 541e418d5d..863d3f60d5 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -3099,7 +3099,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 fd452ab4a4..7846666e03 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..1d91cf887b 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,12 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; 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 872e820cee..d8baee109d 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -128,14 +128,15 @@ implementation end; realconstn : begin - new(pd); - pd^:=trealconstnode(p).value_real; - hp:=cconstsym.create_ptr(orgname,constreal,pd,p.resultdef); + new(pd); + pd^:=trealconstnode(p).value_real; + hp:=cconstsym.create_ptr(orgname,constreal,pd,p.resultdef); end; setconstn : begin new(ps); - ps^:=tsetconstnode(p).value_set^; + if assigned(tsetconstnode(p).value_set) then + ps^:=tsetconstnode(p).value_set^; hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); end; pointerconstn : @@ -185,8 +186,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; @@ -715,8 +730,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 c6e1252f49..8296bfa2f3 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; 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 3727aef828..ed127d7cbf 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; @@ -4237,7 +4243,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 @@ -4591,7 +4600,7 @@ implementation filepos : tfileposinfo; oldafterassignment, updatefpos : boolean; - + oldflags : tnodeflags; begin oldafterassignment:=afterassignment; p1:=sub_expr(opcompare,[ef_accept_equal],nil); @@ -4648,6 +4657,10 @@ implementation else updatefpos:=false; end; + oldflags:=p1.flags; + { transfer generic paramter flag } + if nf_generic_para in oldflags then + include(p1.flags,nf_generic_para); { get the resultdef for this expression } if not assigned(p1.resultdef) and dotypecheck then diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78f6..85270df256 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -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 1069fb7c14..990137e9ba 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; @@ -63,18 +63,150 @@ implementation uses { common } - cutils,fpccrc, + sysutils,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.len<param2.low) or (value.len>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:=inttostr(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:=floattostr(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 us 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,232 @@ 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; + //paratype : tconsttyp; + 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 + 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 - intffound:=assigned( - find_implemented_interface(objdef, - timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef - ) - ); + 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 +471,12 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +488,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 +514,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 +533,47 @@ 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 + 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 - begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else + if typeparam.nodetype = typen then 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 +593,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; @@ -507,7 +689,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 @@ -561,7 +743,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); @@ -612,7 +794,7 @@ uses result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -705,6 +887,7 @@ uses hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -713,7 +896,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 } @@ -729,20 +912,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 } @@ -1164,8 +1346,8 @@ 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; @@ -1173,22 +1355,91 @@ uses doconsume : boolean; constraintdata : tgenericconstraintdata; old_block_type : tblock_type; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; + last_type_pos:=current_filepos; repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const:=true; + const_list_index:=result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=cconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ctypesym.create(orgpattern,cundefinedtype); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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; + end + { type restriction } + else if try_to_consume(_COLON) then begin if not allowconstraints then { TODO } @@ -1305,6 +1556,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 @@ -1330,21 +1582,31 @@ 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 + is_const:=false; + 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; @@ -1352,7 +1614,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; @@ -1377,10 +1641,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); @@ -1388,13 +1665,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/pstatmnt.pas b/compiler/pstatmnt.pas index e62d164f74..9bf65d6713 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..4498af68a6 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -1446,7 +1446,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 diff --git a/compiler/symconst.pas b/compiler/symconst.pas index 130fda9049..defbdce338 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -205,8 +205,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; @@ -234,7 +235,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; @@ -681,7 +685,7 @@ type arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -877,7 +881,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 0d2653edb3..489fe2a22d 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -173,6 +173,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 @@ -2396,13 +2399,26 @@ 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); 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 @@ -2419,12 +2435,12 @@ 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); end; - result:=false; end; end; diff --git a/compiler/symsym.pas b/compiler/symsym.pas index 30f6a10f14..3b23cd56c4 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -164,7 +164,7 @@ interface fprettyname : ansistring; constructor create(const n : string;def:tdef);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1618,7 +1619,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2424,7 +2424,14 @@ implementation constdefderef.reset; value.len:=getlengthwidestring(pw); 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 @@ -2497,7 +2504,7 @@ implementation new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil: ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2563,7 +2570,7 @@ implementation inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil: ppufile.putderef(constdefderef); constord : begin @@ -2716,7 +2723,6 @@ implementation result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 753c481109..4abbac76fe 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -2924,7 +2924,7 @@ implementation function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp index 916592f5ee..417e9169ce 100644 --- a/compiler/utils/ppuutils/ppudump.pp +++ b/compiler/utils/ppuutils/ppudump.pp @@ -1674,7 +1674,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; @@ -2730,7 +2731,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'), diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 0000000000..4b2c455126 --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,38 @@ +{$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..d92bc19466 --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,14 @@ +{$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..0e4ad6e61a --- /dev/null +++ b/tests/test/tgenconst14.pp @@ -0,0 +1,36 @@ +{$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 I; + d9 = I shr I; + end; + +var + op: specialize TBinaryOp<100>; +begin + writeln(op.d0); + writeln(op.d1); + writeln(op.d2); + writeln(op.d3:1:1); + writeln(op.d4); + writeln(op.d5); + writeln(op.d6); + writeln(op.d7); + writeln(op.d8); + writeln(op.d9); +end. \ No newline at end of file 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..258301621a --- /dev/null +++ b/tests/test/tgenconst16.pp @@ -0,0 +1,78 @@ +{$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. \ No newline at end of file diff --git a/tests/test/tgenconst17.pp b/tests/test/tgenconst17.pp new file mode 100644 index 0000000000..57782afd6d --- /dev/null +++ b/tests/test/tgenconst17.pp @@ -0,0 +1,26 @@ +{$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/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 0000000000..ccd68e4a40 --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,13 @@ +{$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/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 0000000000..c282e36f78 --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,19 @@ +{$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/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 0000000000..dfb66a19f5 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,14 @@ +{$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..1983bb7b19 --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,27 @@ +{$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..d51ef2fc06 --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,24 @@ +{$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; const U: integer>.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. |
|
Sorry never mind, I'm seeing what looks like noise and unrelated stuff in the patch. Maybe related to the diff command or the merging of old changes in the trunk. If you look at the GitHub compare page like before it has 5000+ changes files so it's going to be difficult for me see what those changes actually are. I suspect they're line endings but I can't be sure yet. |
|
You sure? That diff looks rather clean to me. The big changes in check_generic_constraints (if you mean that) is due to a change in identation level, so of course there is a big chunk of change. |
|
Good, I guess I don't know how to read the patches. I'm not sure how you review these but it looked hard to make sense of to me. EDIT: yes, the ident level made the noise. I got paranoid and didn't pay close enough attention. |
|
Sven, did you look at it? I think we should merge it before it gets unappliable again. |
|
Thank you Florian. :) It would be a bit of a relief to that this off the bug tracker so it doesn't keep demanding attention after I've forgotten little details. |
|
How did I miss that Ryan had updated this already in January?! O.o I'll try to take a look this weekend, but no promises as an emergency has come up (great timing -.- ) |
|
Please do! My list of immediate uses for this gets longer every day, haha. |
|
Also, WRT to the multi-line-strings thing, while I'll probably never quite understand why the feature is even slightly controversial at all amongst anyone (not just FPC developers) I am as I've said in the past fully committed to keeping it up to date until the end of time, if necessary. (On a related note, after checking it just now to see if I should upload a new copy of the patch, it turns out that the last copy I submitted is still mergeable! Presumably because I didn't really change that many files overall.) But yeah, I guess my hope is that the fact my implementation of multi-line-strings is IMO literally objectively better than any existing one in any other programming language (due to the customizability and error handling) will win people over in the end. |
|
The controversy around multi-line strings truly baffles me as well. Already since you made the patch I could have used it for: inline GLSL shaders, SQL commands and embedded Python scripts, none of which even need to white space. It's even more useful than constants in generics in my personal work. |
|
Please stay on topic (which the current bug report) in the comments of the bug tracker, the mailing list is for discussions. |
|
I've finally found the time to take a deeper look at these and run some tests myself. Thus I've noticed a few problems: - tgenconst8.pp compiles without an error, because in pgenutil.compare_orddef_by_range you compare the value's len field instead of the valueord field - tgenconst16.pp fails at least on 32-bit systems, because TArray.t1 and TArray.d1 are too large; I've fixed this by introducing a new arrayoption ado_IsGeneric that disables the size check in tarraydef.setelementdef and is set in ptype.read_named_type.array_dec if the array index is either a generic type or has the nf_generic_para flag set - another problem/inconsistency exists with implementations for routines declared in the interface: For forward declared functions/procedures it's clear that the constraints must be repeated as otherwise the compiler does not know what is going on, however when implementing a routine that's declared in the interface section this is less clear. For example type constraints must not be repeated. And currently mode non-Delphi modes behave like this: unit tgenconst19; {$mode objfpc} interface generic procedure Test<const T: LongInt>; implementation generic procedure Test2<const T: LongInt>; forward; generic procedure Test<T>; // fails if declared as <const T: LongInt> begin end; generic procedure Test2<const T: LongInt>; begin end; end. Delphi mode on the other hand allows this: unit tgenconst20; {$mode delphi} interface procedure Test<const T: LongInt>; implementation procedure Test2<const T: LongInt>; forward; procedure Test<const T: LongInt>; // <T> works as well begin end; procedure Test2<const T: LongInt>; begin end; end. I noticed this when looking at tgenconst6.pp where the constant constraint is repeated for the implementation as well. We should definitely solve this in a clear way, and so far I'm aware of three possibilities: - don't allow any constraints for the implemenation - require constant constraints for the implementation (in that case it would be different to type constraints) - require "const X" (without type) for the implementation In all three cases for generic routines this needs to be checked in proc_add_definition as only that knows whether it's a new routine, for a type (like in tgenconst6.pp) this needs to be checked in pdecsub once it's been determined whether the identifier is a type or a routine. My personal favorite would be the first point. I've attached the updated patch file (based on yesterday's trunk) generic-constants.patch (93,114 bytes)
diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 67f31195..a61988d7 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -175,7 +175,6 @@ implementation symtable,symsym,symcpu, defutil,symutil; - function compare_defs_ext(def_from,def_to : tdef; fromtreetype : tnodetype; var doconv : tconverttype; @@ -345,9 +344,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 e3b66a6f..9ec84a24 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2775,7 +2775,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 383525f7..5f90cbde 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 61255c6c..f7237509 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 fd452ab4..7846666e 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 0c2ba4ef..1d91cf88 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,12 @@ implementation constructor tbinarynode.create(t:tnodetype;l,r : tnode); begin inherited create(t,l); - right:=r + { transfer generic paramater flag } + if assigned(l) and (nf_generic_para in l.flags) then + include(flags,nf_generic_para) + else if assigned(r) and (nf_generic_para in r.flags) then + include(flags,nf_generic_para); + right:=r; end; diff --git a/compiler/nset.pas b/compiler/nset.pas index 0832b97b..0b31de93 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 adbc6d1a..0e80d10f 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 e4257404..aaac6fbb 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -128,14 +128,15 @@ implementation end; realconstn : begin - new(pd); - pd^:=trealconstnode(p).value_real; - hp:=cconstsym.create_ptr(orgname,constreal,pd,p.resultdef); + new(pd); + pd^:=trealconstnode(p).value_real; + hp:=cconstsym.create_ptr(orgname,constreal,pd,p.resultdef); end; setconstn : begin new(ps); - ps^:=tsetconstnode(p).value_set^; + if assigned(tsetconstnode(p).value_set) then + ps^:=tsetconstnode(p).value_set^; hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); end; pointerconstn : @@ -185,8 +186,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 +731,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 b3f6d4e5..ae27a129 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; diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index 85c47b51..57f2cf5c 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 250c96c6..00c7beae 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,6 +4667,10 @@ implementation else updatefpos:=false; end; + oldflags:=p1.flags; + { transfer generic paramter flag } + if nf_generic_para in oldflags then + include(p1.flags,nf_generic_para); { get the resultdef for this expression } if not assigned(p1.resultdef) and dotypecheck then diff --git a/compiler/pgentype.pas b/compiler/pgentype.pas index b2847c78..85270df2 100644 --- a/compiler/pgentype.pas +++ b/compiler/pgentype.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, - symtype,symbase; + symconst,symtype,symbase; const inline_specialization_block_types = [bt_type,bt_var_type,bt_const_type,bt_body]; @@ -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 e8489726..b1926f5a 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; @@ -63,18 +63,150 @@ implementation uses { common } - cutils,fpccrc, + sysutils,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:=inttostr(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:=floattostr(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 us 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,232 @@ 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; + //paratype : tconsttyp; + 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 + 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 - intffound:=assigned( - find_implemented_interface(objdef, - timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef - ) - ); + 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 +471,12 @@ uses namepart : string; prettynamepart : ansistring; module : tmodule; + //paramdef : tgenericparamdef; + 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 +488,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 +514,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 +533,47 @@ 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 + 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 - begin - { special handling for specializations inside generic function declarations } - prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; - end - else + if typeparam.nodetype = typen then 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 +593,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 +684,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 +738,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); @@ -607,7 +789,7 @@ uses result:=generrordef; exit; end; - + { we've found the correct def } if context.sym.typ=typesym then result:=tstoreddef(ttypesym(context.sym).typedef) @@ -700,6 +882,7 @@ uses hintsprocessed : boolean; pd : tprocdef; pdflags : tpdflags; + typedef : tstoreddef; begin if not assigned(context) then internalerror(2015052203); @@ -708,7 +891,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 +907,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 } @@ -1159,8 +1341,8 @@ 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; @@ -1169,23 +1351,92 @@ uses constraintdata : tgenericconstraintdata; old_block_type : tblock_type; fileinfo : tfileposinfo; + is_const,last_is_const : boolean; + 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; + is_const:=false; + last_is_const:=false; + last_token:=NOTOKEN; + last_type_pos:=current_filepos; repeat + if try_to_consume(_CONST) then + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + is_const:=true; + const_list_index:=result.count; + end; if token=_ID then begin - generictype:=ctypesym.create(orgpattern,cundefinedtype); + if is_const then + begin + { last param was type without semicolon terminator } + if (result.count>0) and not last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=cconstsym.create_undefined(orgpattern,cundefinedtype); + end + else + begin + { last param was const without semicolon terminator } + if (result.count>0) and last_is_const and (last_token<>_SEMICOLON) then + MessagePos2(last_type_pos,scan_f_syn_expected,arraytokeninfo[_SEMICOLON].str,arraytokeninfo[last_token].str); + generictype:=ctypesym.create(orgpattern,cundefinedtype); + end; { type parameters need to be added as strict private } generictype.visibility:=vis_strictprivate; include(generictype.symoptions,sp_generic_para); result.add(orgpattern,generictype); + last_is_const:=is_const; end; consume(_ID); fileinfo:=current_tokenpos; - if try_to_consume(_COLON) then + { const restriction } + if is_const then + begin + if 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; + 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 +1553,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 +1580,31 @@ 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 + is_const:=false; + 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 +1612,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 +1639,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 +1663,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/ppu.pas b/compiler/ppu.pas index 2fc15500..49c6e476 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 ed9a3c90..d81e1518 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 ab3db2b0..86e7dff3 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 08951b97..c8d1f6f7 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; @@ -690,7 +695,7 @@ type arraydef,recorddef,pointerdef,orddef, stringdef,enumdef,procdef,objectdef,errordef, filedef,formaldef,setdef,procvardef,floatdef, - classrefdef,forwarddef,variantdef,undefineddef + classrefdef,forwarddef,variantdef,genericconstdef,undefineddef ); { possible types for symtable entries } @@ -886,7 +891,7 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has 'abstractdef','arraydef','recorddef','pointerdef','orddef', 'stringdef','enumdef','procdef','objectdef','errordef', 'filedef','formaldef','setdef','procvardef','floatdef', - 'classrefdef','forwarddef','variantdef','undefineddef' + 'classrefdef','forwarddef','variantdef','genconstdef','undefineddef' ); EqualTypeName : array[tequaltype] of string[16] = ( diff --git a/compiler/symdef.pas b/compiler/symdef.pas index d3b231eb..f3aaad8c 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 @@ -2398,13 +2401,26 @@ 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); 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 @@ -2421,12 +2437,12 @@ 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); end; - result:=false; end; end; @@ -4170,7 +4186,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) @@ -4210,7 +4226,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; @@ -4330,6 +4346,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 diff --git a/compiler/symsym.pas b/compiler/symsym.pas index 30f6a10f..3b23cd56 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -164,7 +164,7 @@ interface fprettyname : ansistring; constructor create(const n : string;def:tdef);virtual; destructor destroy;override; - constructor ppuload(ppufile:tcompilerppufile); + constructor ppuload(ppufile:tcompilerppufile);virtual; { do not override this routine in platform-specific subclasses, override ppuwrite_platform instead } procedure ppuwrite(ppufile:tcompilerppufile);override;final; @@ -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); constructor ppuload(ppufile:tcompilerppufile); destructor destroy;override; procedure buildderef;override; @@ -1618,7 +1619,6 @@ implementation tparasymtable(parast).ppuwrite(ppufile); end; - {**************************************************************************** TABSTRACTVARSYM ****************************************************************************} @@ -2424,7 +2424,14 @@ implementation constdefderef.reset; value.len:=getlengthwidestring(pw); 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 @@ -2497,7 +2504,7 @@ implementation new(pguid(value.valueptr)); ppufile.getdata(value.valueptr^,sizeof(tguid)); end; - constnil : + constnil: ppufile.getderef(constdefderef); else Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp))); @@ -2563,7 +2570,7 @@ implementation inherited ppuwrite(ppufile); ppufile.putbyte(byte(consttyp)); case consttyp of - constnil : + constnil: ppufile.putderef(constdefderef); constord : begin @@ -2716,7 +2723,6 @@ implementation result:=inherited prettyname; end; - {**************************************************************************** TSYSSYM ****************************************************************************} diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 7db43af8..4704192b 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -2924,7 +2924,7 @@ implementation function generate_objectpascal_helper_key(def:tdef):string; begin - if not assigned(def) then + if not assigned(def) or (def.typ = errordef) then internalerror(2013020501); if def.typ in [recorddef,objectdef] then result:=make_mangledname('',tabstractrecorddef(def).symtable,'') diff --git a/compiler/utils/ppuutils/ppudump.pp b/compiler/utils/ppuutils/ppudump.pp index 29519c57..cd87d526 100644 --- a/compiler/utils/ppuutils/ppudump.pp +++ b/compiler/utils/ppuutils/ppudump.pp @@ -1676,7 +1676,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; @@ -2732,7 +2733,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'), @@ -3256,7 +3258,8 @@ const { ado_IsArrayOfConst } 'ArrayOfConst', { ado_IsConstString } 'ConstString', { ado_IsBitPacked } 'BitPacked', - { ado_IsVector } 'Vector' + { ado_IsVector } 'Vector', + { ado_IsGeneric } 'Generic' ); var symoptions: tarraydefoptions; diff --git a/tests/test/tgenconst1.pp b/tests/test/tgenconst1.pp new file mode 100644 index 00000000..4b2c4551 --- /dev/null +++ b/tests/test/tgenconst1.pp @@ -0,0 +1,38 @@ +{$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 00000000..eecb0bf1 --- /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 00000000..5895fd00 --- /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 00000000..d92bc194 --- /dev/null +++ b/tests/test/tgenconst12.pp @@ -0,0 +1,14 @@ +{$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 00000000..13235d14 --- /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 00000000..0e4ad6e6 --- /dev/null +++ b/tests/test/tgenconst14.pp @@ -0,0 +1,36 @@ +{$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 I; + d9 = I shr I; + end; + +var + op: specialize TBinaryOp<100>; +begin + writeln(op.d0); + writeln(op.d1); + writeln(op.d2); + writeln(op.d3:1:1); + writeln(op.d4); + writeln(op.d5); + writeln(op.d6); + writeln(op.d7); + writeln(op.d8); + writeln(op.d9); +end. \ No newline at end of file diff --git a/tests/test/tgenconst15.pp b/tests/test/tgenconst15.pp new file mode 100644 index 00000000..5eea8571 --- /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 00000000..25830162 --- /dev/null +++ b/tests/test/tgenconst16.pp @@ -0,0 +1,78 @@ +{$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. \ No newline at end of file diff --git a/tests/test/tgenconst17.pp b/tests/test/tgenconst17.pp new file mode 100644 index 00000000..57782afd --- /dev/null +++ b/tests/test/tgenconst17.pp @@ -0,0 +1,26 @@ +{$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 00000000..b5393847 --- /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/tgenconst2.pp b/tests/test/tgenconst2.pp new file mode 100644 index 00000000..ccd68e4a --- /dev/null +++ b/tests/test/tgenconst2.pp @@ -0,0 +1,13 @@ +{$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/tgenconst3.pp b/tests/test/tgenconst3.pp new file mode 100644 index 00000000..c282e36f --- /dev/null +++ b/tests/test/tgenconst3.pp @@ -0,0 +1,19 @@ +{$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/tgenconst4.pp b/tests/test/tgenconst4.pp new file mode 100644 index 00000000..dfb66a19 --- /dev/null +++ b/tests/test/tgenconst4.pp @@ -0,0 +1,14 @@ +{$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 00000000..1983bb7b --- /dev/null +++ b/tests/test/tgenconst5.pp @@ -0,0 +1,27 @@ +{$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 00000000..d51ef2fc --- /dev/null +++ b/tests/test/tgenconst6.pp @@ -0,0 +1,24 @@ +{$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; const U: integer>.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 00000000..22bd037e --- /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 00000000..418ba3c6 --- /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 00000000..8438b70c --- /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. |
|
Sven, did you fix the mentioned issues in the patch posted or do you need me to study these issues myself? I wanted to test tgenconst8 because I'm certain that it was given an error but I'm getting "Cannot find system type "__m64". Check if you use the correct run time library." Probably because I updated the compiler and I'm linking to the wrong RTL or something (any ideas?). |
|
The first two points are fixed in my patch. The third not yet. I first wanted to see what you think about the three variants I mentioned and then probably hand it back to you to fix it. If required I can provide you with separate patches for the two issues so that you can add them as commits to your repository. Regarding your error: you need to cleanly rebuild your trunk system with a release compiler. |
|
just had the chance to look at this and see now that constraints aren't allowed in the implementation so I guess we should be consistent. So I agree with your first point also. Thanks for fixing the bugs, you can do those so much faster than me. |
|
> Thanks for fixing the bugs, you can do those so much faster than me. You're still learning your way in the compiler. It was the same with me when I started, so do not despair ;) > just had the chance to look at this and see now that constraints aren't allowed in the implementation so I guess we should be consistent. So I agree with your first point also. Good. Do you want to give fixing this a try? |
|
Unless you can fix it quickly because I'll have to step around in the debugger. I still can't even figure out how to fix that error I mentioned before so I haven't been able to test anything yet. I'm traveling over the weekend but I can look at it after that. |
|
Sven, rebuilt my trunk compiler and got rid of that error on my dev compiler repo. 1) I'm seeing that I do indeed get an error with tgenconst8 but maybe it's not the right one? tgenconst8.pp:12:22: error: Incompatible types: got "SmallInt" expected "Byte" 2) Looking at the constraints issue I'm not actually not seeing what you want. The compiler already gives an error for constraints in the implementation section. This compiles just fine and isn't that what you want? Maybe you want the parser to accept <const T>? interface generic procedure Test<const T: LongInt>; implementation generic procedure Test<T>; begin end; end; 3) Btw, the error format seems to have changed again (tgenconst19.pas:13:19) where the column is after the line NAME:LINE:COLUMN. Is that a new permanent change? |
|
1) That is the error you generate in check_generic_constraints if compare_generic_params returns false. So regarding the code that is the correct error. Semantically another error might be better, but that is something that can be improved later on as well. 2) Did you test with mode Delphi? 3) I don't know what you mean. The error format as always been name, line, column (or at least for a long, long time). Where did you see something different? |
|
1) You said tgenconst8 compiles without an error right? I get "got "SmallInt" expected "Byte". Just to verify here is what I'm seeing in that file: {%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. 2) Both your tgenconst19 and tgenconst20 examples compile for me. Are they supposed to fail? 3) I'll follow up on the list, I'm seeing the error format changed but maybe there's an explanation. It feels like we're maybe out of synch in our code but I may just be confused. I'm not trying to escape responsibility for finishing my own patch, but you seem to know like you know exactly where to go to correct these remaining issues so maybe it's best you make the required changes? |
|
1) My patch fixes that issue already. With your changes as you had last posted them here, it compiled without error (see my explanation to find the location that changed) 2) As you agreed with me that we should not allow constant constraints for implementations of methods in the interface section tgenconst19 is fine, but tgenconst20 is supposed to fail as the Test<> function should not have any constraints in the implementation section. Did you compare my patch to your last patch? As I wrote, I did tackle the problems of tgenconst8 and tgenconst16, but not the problem mentioned in 2) |
|
1) This is why I wonder if we're using different code. "With your changes as you had last posted them here, it compiled without error ". but tgenconst8 has always given me an error. My last patch I posted was from 1-14 and I assume you're using that one but I never actually tried to use it myself on a fresh branch. Maybe it's bugged. 2) Oh, so tgenconst20 is supposed to fail because Delphi mode allows the constraints? I don't use Delphi mode and I thought that was valid syntax. Does this apply to tgenconst6 also? There's no implementation section but it's the same issue. I don't know how to fix this but I did look at the function you mentioned and I suspect there needs to be some change in the generic param parser also. I didn't apply your patch yet because I didn't see the need. Can I apply it right on top of my current branch or do I need to make a new branch? |
|
1) For me I didn't get an error. Maybe because you're working on a 64-bit target? It failed for me on i386-win32, because your code was simply wrong (just take a look at the location I mentioned). 2) Yes, tgenconst20 is supposed to fail (sorry, I didn't add the {%FAIL} yet, as it was just to highlight the problem). And as-is tgenconst6 is supposed to fail as well (though that test should be fixed to the correct syntax). You might want to use a new branch as mine is based on current trunk which had a few conflicting changes in pgenutil.pas since you had made your patch. Though as I said I can extract the changes I did and provide them as separate patches. |
|
I did a test with Delphi mode and I do indeed get a "Generic constraint not allowed here" error so we need to expand that to constants. Now that I see that error I should know where to look. I know you provided some functions (which I looked at and see how they do generic param comparisons) but I think this needs to be handled in the parser. Yes I developed on a 64 bit Mac but I'll take your word it's wrong. |
|
Yes, it needs to be handled in the parser. In pdecsub the code first checks whether the currently read part is a type or a method name. If the former then constraints are not allowed. If it's a plain method then it's only checked in proc_add_definition, cause a global function/procedure can have constraints if it's only declared in the implementation section (or in a program/library file). Take a look at the declarations of tconstvalue and tconstexprint: Tconstexprint=record overflow:boolean; case signed:boolean of false: (uvalue:qword); true: (svalue:int64); end; tconstvalue = record case integer of 0: (valueord : tconstexprint); 1: (valueordptr : tconstptruint); 2: (valueptr : pointer; len : longint); end; Your original code in pgenutil.compare_orddef_by_range used tconstvalue.len. Due to the memory layout different values will be accessed using tconstvalue.len on different platforms (32- vs. 64-bit, big vs. little endian). Not to mention that this was the wrong field anyway, cause an ordinal constant is provided by valueord. |
|
I found why I confused. My git repo was out of date and the "Generic constraint not allowed here" error must have been added later. I'm going to make a new branch and apply your changes but I don't know how! How do I apply your patch? I tried: patch < generic-constants.patch (macOS) but it keeps asking me which file to patch. I think "git am" will usually work like I want because I don't think you used git so I need to use the patch command I think. |
|
Yes, "Generic constraint not allowed here" was only added recently; before that it was simply "Illegal expression". To apply your patch I used "git apply thepatch.patch". I'd wager that you should be able to use that with mine just as well. |
|
I pulled changes from the master branch into a new clean branch which compiles and gave me the correct "Generic constraint not allowed here" error so I know I'm up to date. Then I tried first "git apply generic-constants.patch" but I get tons of errors. Does that make any sense to you? generic-constants.patch:52: space before tab in indent. adaptrange(resultdef,tordconstnode(left).value,([nf_internal,nf_absolute]*flags)<>[],nf_explicit in flags,cs_check_range in localswitches); generic-constants.patch:256: trailing whitespace. { the node is from a generic parameter constant and is generic-constants.patch:257: trailing whitespace. untyped so we need to pass a placeholder constant generic-constants.patch:259: trailing whitespace. if nf_generic_para in p.flags then generic-constants.patch:1010: trailing whitespace. else error: patch failed: compiler/defcmp.pas:175 error: compiler/defcmp.pas: patch does not apply error: patch failed: compiler/htypechk.pas:2775 [ ........ etc......... ] |
|
Sven I couldn't apply your patch still but I decided to jump in anyways and do what I can for now. Seems like a simple fix and I can just provide a couple line for you to copy/paste in. I may have just came across another bug in Delphi. Did you happen to fix this in your changes that I wasn't able to apply? I should be getting a type mismatch because the generic constraints don't match (integer and string) but I don't get any error in my branch. I'll fix this also unless you already did so. {%FAIL} unit tgenconst21; {$mode delphi} interface type TList<T; const U: integer> = class list: array[0..U-1] of T; function capacity: integer; end; implementation { type mismatch in generic constraint } function TList<T; const U: string>.capacity: integer; begin result := U; end; end. |
|
The bug I mentioned previously is also exhibited with plain generic types so I think it's not related to constants at all (try putting different constraints for "T" in the interface/implementation). Should we bother fixing this now or just make another bug report? I uploaded a text file to show 2 changes I mades in 2 functions. Is that all we need to do? Right now internal errors are shown but you can add proper error messages yourself if all we really need to do is copy/paste this into your branch. changes.txt (2,324 bytes)
// pdecsub.pas function check_generic_parameters(def:tstoreddef):boolean; var i : longint; decltype, impltype : ttypesym; implname : tsymstr; begin result:=true; if not assigned(def.genericparas) then internalerror(2018090102); if not assigned(genericparams) then internalerror(2018090103); if def.genericparas.count<>genericparams.count then internalerror(2018090104); for i:=0 to def.genericparas.count-1 do begin decltype:=ttypesym(def.genericparas[i]); impltype:=ttypesym(genericparams[i]); implname:=upper(genericparams.nameofindex(i)); { if the declared type is a const and the implemented type is also a const then we must issue an error because generic constraints are not allowed in the implementation (consts are always constrained). } if (decltype.typ=constsym) and (impltype.typ=constsym) then begin internalerror(666); result:=false; end; if decltype.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); result:=false; end; end; end; // pparautl.pas function check_generic_parameters(fwpd,currpd:tprocdef):boolean; var i : longint; fwtype, currtype : ttypesym; 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 begin messagepos1(currtype.fileinfo,sym_e_generic_type_param_mismatch,currtype.realname); messagepos1(fwtype.fileinfo,sym_e_generic_type_param_decl,fwtype.realname); result:=false; end; { generic constraints are not allowed in the implementation and consts are always constrained. } if (currtype.typ=constsym) and (fwtype.typ=constsym) then begin internalerror(666); result:=false; end; end; end; |
|
The check_generic_paras functions are only responsible for the names of the parameters. I should probably rename them... (and maybe unify them) Instead you should look at pparautl.proc_add_definition.equal_generic_procdefs. This is also where type constraints are handled. And regarding your comment 0035140:0121601: you won't need to check for this anymore in the future, cause it should be TList<T; U>.Capacity in the implementation section then (you'll have to add a check for that in pdecsub.parse_proc_head.check_generic_parameters where df_genconstraint is currently checked as well (this was added recently in trunk)). What you'll need to check however is this: generic procedure Foo<const U: Integer>; forward; generic procedure Foo<const U: String>; begin end; Here you'll have to make sure that proc_add_definition does not consider them as equal (the compiler will later on complain about a missing forward declaration then). And regarding the patch: did you make sure that your master is up to date? I tested with today's trunk and the result of "git apply generic-constants.patch" is this: PS E:\fpc\git> git apply X:\generic-constants.patch X:/generic-constants.patch:52: space before tab in indent. adaptrange(resultdef,tordconstnode(left).value,([nf_internal,nf_absolute]*flags)<>[],nf_explicit in flags,cs_check_range in localswitches); X:/generic-constants.patch:256: trailing whitespace. { the node is from a generic parameter constant and is X:/generic-constants.patch:257: trailing whitespace. untyped so we need to pass a placeholder constant X:/generic-constants.patch:259: trailing whitespace. if nf_generic_para in p.flags then X:/generic-constants.patch:1010: trailing whitespace. else warning: squelched 439 whitespace errors warning: 444 lines add whitespace errors. |
|
Ok, I think I get it now but could you post a set of new tests which include the changes you need? I want to be confident that I have it all since it's getting difficult to parse out of these comments. I'll change tgenconst6 so that the constraints are omitted, otherwise the test will fail after the changes are made. |
|
In proc_add_definition.check_generic_parameters I need to know if the procdef has a forward modifier or not, but how do I check for that? "fwpd.forwarddef" returns true for proc in the interface section, "po_forward in fwpd.procoptions" always returns false. |
|
I'll try to provide additional tests this weekend. In proc_add_definition.check_generic_parameters the parameter fwpd already is the forward declaration (either interface section or using "forward"). You only need to make sure that you're not dealing with a function declared in the interface section or inside a structured type by checking against fwpd.interfacedef and fwpd.struct. Just like the existing code there does (update your code if you can't see this: https://svn.freepascal.org/cgi-bin/viewvc.cgi/trunk/compiler/pparautl.pas?revision=44195&view=markup#l650 ). |
|
For forwards (with the "forward" directive) we need to actually parse the constraints and compare them but for interface/implementation we need to explicitly reject any constraints, right? I did all of this but I got stuck because I couldn't distinguish between the 2 procdefs. Does that make sense or am I missing something? I see you intended check_generic_parameters to be for comparing just the names but it's now branched into a way to reject proc pairs (current and forward) if they have constraints in the implementation (except for "forward" procs!). |
|
Yes, forward declarations require the constraints, so that the parser can check them (for interface routines and routines in structured types the "forward" declaration in the interface section / structured type will be enough). And the way to differentiate them is the tprocdef.interfacedef property. Ehm, sorry, I got a bit confused there with the patch you attached a few days ago, because there check_generic_parameters did not contain the check for constraints, but in trunk I had added that there (and thus I knew that the check should be somewhere, but I didn't remember where), so my comment about check_generic_parameters only checking for names is null and void. |
|
I probably need to see your tests first because I'm probably on the wrong track but here's my test I'm stuck on anyways. This is supposed to pass right? I have equal_generic_procdefs returning true and In check_generic_parameters I need to NOT issue an error because of the forward (otherwise I would issue an error because constraints are not allowed in the interface section). currpd-interfacedef and fwpd.interfacedef (when check_generic_parameters is called) both return false in that program. What am I doing wrong? Should be easy to know if the fwpd has forward directive but all the methods return else.unit tgenconst20; {$mode delphi} interface implementation procedure Test<const T: Integer>; forward; procedure Test<const T: Integer >; begin end; end. about the function name I was responding to what is perhaps a defunct comment: { check that the type parameter names for generic methods match; we check this here and not in equal_generic_procdefs as the defs might still be different due to their parameters, so we'd generate errors without any need } |
|
I think I was just being stupid and this is what you want. Correct? That would explain all my troubles I was having. The forward DOES accept constraints despite being the implementation section (the one exception to the rule) but the implemented procedure omits the constraints, as is the rule for all generic parameters. Please confirm this and I'll make the changes.implementation procedure Test<const T: Integer>; forward; procedure Test<T>; begin end; end. |
|
|
|
The comment is still mostly correct (it's mainly incomplete now). The purpose of the split between equal_generic_procdefs and check_generic_parameters is the following: the former is used by the code in proc_add_definition to find a potentially matching candidate. No errors are generated in equal_generic_procdefs as there might be another suitable candidate further down the list. Once a suitable candidate is found you essentially have a pair: the curpd which is the implementation that was found and the fwpd which either had been declared in the interface section (thus interfacedef returns true) or was declared in the implementation section with the forward directive (thus interfacedef returns false). There is no other case possible. Thus you can completely concentrate on whether both the forward and the implementation have the constraints (if interfacedef is false) or that only the fwpd has them (if interfacedef is true). I have attached a couple tests, I hope they cover everything or at least enough that we can finally finish this. :) |
|
Here are the changes I've made an I added 2 tests which got overlooked I believe. The changes are actually pretty trivial so are you able to integrate these by copy and pasting? I've left the errors as internalerror(x) so you can chose the correct messages. It should be easy to run the tests and see which error triggers where. Let me know if this works for you. |
|
Just as a little heads up: I have not forgotten you, I'm just currently busy with something else. I hope to come back to this (and the implicit specializations) soon. |
|
Sven, got a chance to look at this yet? Sorry to bother you but I don't want this to slip away from us again. I think it's basically done if you just change a couple error messages. |
|
A comprehensive test suite is still required? After all this is a quite a big feature. |
|
@Ryan: yes, sorry, my repository is still unclean... :/ @Thaddy: yes, there are tests. It's just me reintegrating it now. |
|
I finally had the time to commit this. There were some further problems (partially the locations of your checks regarding the forward defs, but also triggered exceptions in the compiler if it was compiled with -CR), but I decided that I didn't want to do a further roundtrip and instead fixed all those myself. Thank you for your patience regarding this. Next I will look at your array patch as that is simpler than the implicit specializations. Please test and close if okay. |
Date Modified | Username | Field | Change |
---|---|---|---|
2019-02-24 15:57 | Ryan Joseph | New Issue | |
2019-02-24 15:57 | Ryan Joseph | File Added: tgenconst-patch.txt | |
2019-02-25 11:14 | Thaddy de Koning | Note Added: 0114398 | |
2019-02-25 15:37 | Ryan Joseph | Note Added: 0114411 | |
2019-02-28 15:24 | Akira1364 | Note Added: 0114506 | |
2019-02-28 20:29 | Florian | Note Added: 0114518 | |
2019-03-01 14:49 | Sven Barth | Note Added: 0114537 | |
2019-03-16 16:59 | Ryan Joseph | File Added: gen-const.diff | |
2019-03-16 17:00 | Ryan Joseph | Note Added: 0114866 | |
2019-03-16 17:06 | Ryan Joseph | Note Added: 0114867 | |
2019-03-17 22:01 | Ryan Joseph | File Added: gen-const-clean.diff | |
2019-03-17 22:07 | Ryan Joseph | Note Added: 0114903 | |
2019-03-17 22:26 | Ryan Joseph | Note Added: 0114904 | |
2019-03-18 15:15 | Akira1364 | Note Added: 0114909 | |
2019-03-18 15:18 | Akira1364 | Note Edited: 0114909 | View Revisions |
2019-03-19 14:22 | Ryan Joseph | Note Added: 0114925 | |
2019-03-23 14:04 | Ryan Joseph | File Added: gen-const-3-23.diff | |
2019-03-23 14:05 | Ryan Joseph | File Added: bad-line-endings.png | |
2019-03-23 14:15 | Ryan Joseph | Note Added: 0114987 | |
2019-03-24 17:13 | Sven Barth | Note Added: 0115027 | |
2019-03-24 20:17 | Akira1364 | Note Added: 0115029 | |
2019-03-25 14:26 | Akira1364 | Note Added: 0115039 | |
2019-03-25 15:42 | Ryan Joseph | File Added: patch_3_25.diff | |
2019-03-25 15:43 | Ryan Joseph | Note Added: 0115042 | |
2019-04-07 04:19 | Akira1364 | Note Added: 0115290 | |
2019-04-07 04:24 | Ryan Joseph | Note Added: 0115291 | |
2019-05-04 17:55 | Akira1364 | File Added: generic_constants_may4.patch | |
2019-05-04 17:55 | Akira1364 | File Added: generic_constants_may4_tests.7z | |
2019-05-04 17:55 | Akira1364 | Note Added: 0115993 | |
2019-05-04 23:01 | Akira1364 | Note Added: 0116011 | |
2019-05-04 23:01 | Ryan Joseph | Note Added: 0116012 | |
2019-05-04 23:32 | Akira1364 | Note Added: 0116015 | |
2019-05-04 23:34 | Akira1364 | Note Edited: 0116011 | View Revisions |
2019-05-05 01:47 | Ryan Joseph | Note Added: 0116018 | |
2019-05-05 02:26 | Akira1364 | Note Added: 0116019 | |
2019-05-05 02:27 | Akira1364 | Note Edited: 0116019 | View Revisions |
2019-05-05 21:59 | Akira1364 | Note Edited: 0116019 | View Revisions |
2019-05-05 22:02 | Akira1364 | Note Edited: 0116011 | View Revisions |
2019-05-05 22:08 | Akira1364 | Note Edited: 0116011 | View Revisions |
2019-05-05 22:12 | Akira1364 | Note Edited: 0116011 | View Revisions |
2019-06-04 18:34 | Akira1364 | Note Added: 0116567 | |
2019-06-05 18:48 | Denis Golovan | Note Added: 0116582 | |
2019-06-05 23:32 | Ryan Joseph | Note Added: 0116583 | |
2019-06-06 12:35 | Denis Golovan | Note Added: 0116591 | |
2019-06-06 15:57 | Akira1364 | Note Added: 0116593 | |
2019-06-06 20:03 | Ryan Joseph | Note Added: 0116595 | |
2019-06-21 17:47 | Akira1364 | Note Added: 0116819 | |
2019-06-21 17:51 | Akira1364 | Note Edited: 0116819 | View Revisions |
2019-06-21 18:32 | Akira1364 | Note Edited: 0116819 | View Revisions |
2019-06-21 18:36 | Akira1364 | Note Edited: 0116819 | View Revisions |
2019-06-22 19:30 | Akira1364 | Note Edited: 0116819 | View Revisions |
2019-07-15 18:33 | Akira1364 | Note Added: 0117270 | |
2019-07-15 18:36 | Akira1364 | Note Edited: 0117270 | View Revisions |
2019-07-15 18:37 | Akira1364 | Note Edited: 0117270 | View Revisions |
2019-07-15 20:28 | Ryan Joseph | Note Added: 0117271 | |
2019-07-15 22:23 | Akira1364 | Note Edited: 0117270 | View Revisions |
2019-07-20 15:49 | Ryan Joseph | File Added: patch_7_20.diff | |
2019-07-20 15:49 | Ryan Joseph | Note Added: 0117327 | |
2019-07-20 18:28 | Ryan Joseph | Note Added: 0117328 | |
2019-07-20 18:48 | Denis Golovan | Note Added: 0117329 | |
2019-07-20 18:59 | Ryan Joseph | Note Added: 0117330 | |
2019-07-30 17:22 | Akira1364 | Note Added: 0117509 | |
2019-07-30 17:22 | Akira1364 | Note Edited: 0117509 | View Revisions |
2019-07-30 17:54 | Ryan Joseph | Note Added: 0117511 | |
2019-07-31 04:32 | Akira1364 | Note Added: 0117514 | |
2019-07-31 15:47 | Akira1364 | Note Edited: 0117514 | View Revisions |
2019-07-31 15:47 | Akira1364 | Note Edited: 0117514 | View Revisions |
2019-07-31 15:48 | Akira1364 | Note Edited: 0117514 | View Revisions |
2019-10-04 00:06 | Sven Barth | Tag Attached: generics | |
2020-01-12 04:15 | Ryan Joseph | Note Added: 0120351 | |
2020-01-13 22:19 | Sven Barth | Note Added: 0120414 | |
2020-01-14 03:14 | Ryan Joseph | Note Added: 0120419 | |
2020-01-14 04:34 | Ryan Joseph | Note Added: 0120420 | |
2020-01-14 13:59 | Sven Barth | Note Added: 0120430 | |
2020-01-14 14:37 | Ryan Joseph | Note Added: 0120432 | |
2020-01-14 16:09 | Sven Barth | Note Added: 0120436 | |
2020-01-15 07:04 | Ryan Joseph | File Added: patch.diff | |
2020-01-15 07:04 | Ryan Joseph | Note Added: 0120454 | |
2020-01-15 07:18 | Ryan Joseph | Note Added: 0120456 | |
2020-01-15 07:37 | Sven Barth | Note Added: 0120458 | |
2020-01-15 07:43 | Ryan Joseph | Note Added: 0120459 | |
2020-01-15 07:49 | Ryan Joseph | Note Edited: 0120459 | View Revisions |
2020-02-22 22:24 | Florian | Note Added: 0121197 | |
2020-02-23 14:59 | Ryan Joseph | Note Added: 0121204 | |
2020-02-28 17:33 | Sven Barth | Note Added: 0121258 | |
2020-03-01 02:19 | Akira1364 | Note Added: 0121286 | |
2020-03-01 02:35 | Akira1364 | Note Added: 0121287 | |
2020-03-01 04:47 | Ryan Joseph | Note Added: 0121288 | |
2020-03-01 10:01 | Florian | Note Added: 0121293 | |
2020-03-05 10:31 | Sven Barth | File Added: generic-constants.patch | |
2020-03-05 10:31 | Sven Barth | Note Added: 0121391 | |
2020-03-05 10:31 | Sven Barth | Assigned To | => Sven Barth |
2020-03-05 10:31 | Sven Barth | Status | new => assigned |
2020-03-05 10:32 | Sven Barth | Note Edited: 0121391 | View Revisions |
2020-03-05 10:33 | Sven Barth | Note Edited: 0121391 | View Revisions |
2020-03-05 10:34 | Sven Barth | Note Edited: 0121391 | View Revisions |
2020-03-05 10:36 | Sven Barth | Note Edited: 0121391 | View Revisions |
2020-03-05 14:02 | Ryan Joseph | Note Added: 0121397 | |
2020-03-05 16:23 | Sven Barth | Note Added: 0121399 | |
2020-03-05 16:24 | Sven Barth | Note Edited: 0121399 | View Revisions |
2020-03-06 02:29 | Ryan Joseph | Note Added: 0121406 | |
2020-03-06 10:28 | Sven Barth | Note Added: 0121409 | |
2020-03-06 15:13 | Ryan Joseph | Note Added: 0121417 | |
2020-03-08 04:57 | Ryan Joseph | Note Added: 0121448 | |
2020-03-08 04:57 | Ryan Joseph | Note Edited: 0121448 | View Revisions |
2020-03-09 11:38 | Sven Barth | Note Added: 0121488 | |
2020-03-09 14:22 | Ryan Joseph | Note Added: 0121491 | |
2020-03-09 17:53 | Sven Barth | Note Added: 0121496 | |
2020-03-10 02:48 | Ryan Joseph | Note Added: 0121518 | |
2020-03-10 09:48 | Sven Barth | Note Added: 0121527 | |
2020-03-10 13:02 | Ryan Joseph | Note Added: 0121530 | |
2020-03-12 10:12 | Sven Barth | Note Added: 0121566 | |
2020-03-13 05:51 | Ryan Joseph | Note Added: 0121578 | |
2020-03-13 09:55 | Sven Barth | Note Added: 0121582 | |
2020-03-13 10:05 | Ryan Joseph | Note Added: 0121583 | |
2020-03-14 10:00 | Ryan Joseph | Note Added: 0121601 | |
2020-03-14 14:40 | Ryan Joseph | File Added: changes.txt | |
2020-03-14 14:40 | Ryan Joseph | Note Added: 0121606 | |
2020-03-19 11:59 | Sven Barth | Note Added: 0121649 | |
2020-03-20 03:37 | Ryan Joseph | Note Added: 0121656 | |
2020-03-20 05:35 | Ryan Joseph | Note Added: 0121657 | |
2020-03-20 15:20 | Sven Barth | Note Added: 0121661 | |
2020-03-20 15:34 | Ryan Joseph | Note Added: 0121662 | |
2020-03-20 17:00 | Sven Barth | Note Added: 0121663 | |
2020-03-21 03:15 | Ryan Joseph | Note Added: 0121669 | |
2020-03-22 10:19 | Ryan Joseph | Note Added: 0121681 | |
2020-03-22 16:25 | Sven Barth | File Added: tgenconstX.zip | |
2020-03-22 16:25 | Sven Barth | Note Added: 0121684 | |
2020-03-23 09:21 | Ryan Joseph | File Added: changes.zip | |
2020-03-23 09:21 | Ryan Joseph | Note Added: 0121689 | |
2020-04-01 10:14 | Sven Barth | Note Added: 0121819 | |
2020-04-19 11:48 | Ryan Joseph | Note Added: 0122244 | |
2020-04-19 12:03 | Thaddy de Koning | Note Added: 0122246 | |
2020-04-19 12:21 | Sven Barth | Note Added: 0122248 | |
2020-04-26 00:15 | Sven Barth | Status | assigned => resolved |
2020-04-26 00:15 | Sven Barth | Resolution | open => fixed |
2020-04-26 00:15 | Sven Barth | Fixed in Version | => 3.3.1 |
2020-04-26 00:15 | Sven Barth | Fixed in Revision | => 45080 |
2020-04-26 00:15 | Sven Barth | FPCTarget | => - |
2020-04-26 00:15 | Sven Barth | Note Added: 0122430 | |
2020-09-05 03:44 | Ryan Joseph | Status | resolved => closed |