paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-20 10:49:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/z80@45131 -
This commit is contained in:
nickysn 2020-04-26 22:33:58 +00:00
commit 6f6598712f
69 changed files with 2205 additions and 832 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
.gitattributes vendored
View File

@ -14782,6 +14782,36 @@ tests/test/tfpu5.pp svneol=native#text/plain
tests/test/tfpuover.pp svneol=native#text/plain tests/test/tfpuover.pp svneol=native#text/plain
tests/test/tfwork1.pp svneol=native#text/plain tests/test/tfwork1.pp svneol=native#text/plain
tests/test/tfwork2.pp svneol=native#text/plain tests/test/tfwork2.pp svneol=native#text/plain
tests/test/tgenconst1.pp svneol=native#text/pascal
tests/test/tgenconst10.pp svneol=native#text/pascal
tests/test/tgenconst11.pp svneol=native#text/pascal
tests/test/tgenconst12.pp svneol=native#text/pascal
tests/test/tgenconst13.pp svneol=native#text/pascal
tests/test/tgenconst14.pp svneol=native#text/pascal
tests/test/tgenconst15.pp svneol=native#text/pascal
tests/test/tgenconst16.pp svneol=native#text/pascal
tests/test/tgenconst17.pp svneol=native#text/pascal
tests/test/tgenconst18.pp svneol=native#text/pascal
tests/test/tgenconst19.pp svneol=native#text/pascal
tests/test/tgenconst2.pp svneol=native#text/pascal
tests/test/tgenconst20.pp svneol=native#text/pascal
tests/test/tgenconst21.pp svneol=native#text/pascal
tests/test/tgenconst22.pp svneol=native#text/pascal
tests/test/tgenconst23.pp svneol=native#text/pascal
tests/test/tgenconst24.pp svneol=native#text/pascal
tests/test/tgenconst25.pp svneol=native#text/pascal
tests/test/tgenconst26.pp svneol=native#text/pascal
tests/test/tgenconst27.pp svneol=native#text/pascal
tests/test/tgenconst28.pp svneol=native#text/pascal
tests/test/tgenconst29.pp svneol=native#text/pascal
tests/test/tgenconst3.pp svneol=native#text/pascal
tests/test/tgenconst30.pp svneol=native#text/pascal
tests/test/tgenconst4.pp svneol=native#text/pascal
tests/test/tgenconst5.pp svneol=native#text/pascal
tests/test/tgenconst6.pp svneol=native#text/pascal
tests/test/tgenconst7.pp svneol=native#text/pascal
tests/test/tgenconst8.pp svneol=native#text/pascal
tests/test/tgenconst9.pp svneol=native#text/pascal
tests/test/tgenconstraint1.pp svneol=native#text/pascal tests/test/tgenconstraint1.pp svneol=native#text/pascal
tests/test/tgenconstraint10.pp svneol=native#text/pascal tests/test/tgenconstraint10.pp svneol=native#text/pascal
tests/test/tgenconstraint11.pp svneol=native#text/pascal tests/test/tgenconstraint11.pp svneol=native#text/pascal
@ -16411,6 +16441,7 @@ tests/webtbf/tw36631b.pp svneol=native#text/pascal
tests/webtbf/tw36652.pp svneol=native#text/pascal tests/webtbf/tw36652.pp svneol=native#text/pascal
tests/webtbf/tw36720.pp svneol=native#text/pascal tests/webtbf/tw36720.pp svneol=native#text/pascal
tests/webtbf/tw3680.pp svneol=native#text/plain tests/webtbf/tw3680.pp svneol=native#text/plain
tests/webtbf/tw36975.pp svneol=native#text/pascal
tests/webtbf/tw3716.pp svneol=native#text/plain tests/webtbf/tw3716.pp svneol=native#text/plain
tests/webtbf/tw3738.pp svneol=native#text/plain tests/webtbf/tw3738.pp svneol=native#text/plain
tests/webtbf/tw3740.pp svneol=native#text/plain tests/webtbf/tw3740.pp svneol=native#text/plain

8
compiler/defcmp.pas
View File

@ -345,9 +345,13 @@ implementation
internalerror(2012091302); internalerror(2012091302);
symfrom:=ttypesym(tstoreddef(def_from).genericparas[i]); symfrom:=ttypesym(tstoreddef(def_from).genericparas[i]);
symto:=ttypesym(tstoreddef(def_to).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); 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; diff:=true;
if diff then if diff then
break; break;

2
compiler/htypechk.pas
View File

@ -2779,7 +2779,7 @@ implementation
internalerror(2015060301); internalerror(2015060301);
{ check whether the given parameters are compatible { check whether the given parameters are compatible
to the def's constraints } 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; exit;
def:=generate_specialization_phase2(spezcontext,pd,false,''); def:=generate_specialization_phase2(spezcontext,pd,false,'');
case def.typ of case def.typ of

5
compiler/msg/errore.msg
View File

@ -1617,7 +1617,7 @@ parser_e_generic_constraints_not_allowed_here=03355_E_Generic constraint not all
% %
# Type Checking # Type Checking
# #
# 04127 is the last used one # 04128 is the last used one
# #
% \section{Type checking errors} % \section{Type checking errors}
% This section lists all errors that can occur when type checking is % This section lists all errors that can occur when type checking is
@ -2061,6 +2061,9 @@ type_e_forward_interface_type_does_not_match=04127_E_The interface type of the f
% When declaring an interface forward, the interface type must be the same as at the actual declaration of the interface. % When declaring an interface forward, the interface type must be the same as at the actual declaration of the interface.
% This is in particular important with regard to the parent interface which implicitly sets the interface type for the % This is in particular important with regard to the parent interface which implicitly sets the interface type for the
% child interface. % child interface.
type_e_generic_const_type_not_allowed=04128_E_Type not allowed for generic constant parameter: $1
% Only types that can also be used (indirectly) for untyped constants can be used as a
% type for a generic constant parameter.
% \end{description} % \end{description}
# #
# Symtable # Symtable

5
compiler/msgidx.inc
View File

@ -584,6 +584,7 @@ const
type_w_empty_constant_range_set=04125; type_w_empty_constant_range_set=04125;
type_e_cblock_callconv=04126; type_e_cblock_callconv=04126;
type_e_forward_interface_type_does_not_match=04127; type_e_forward_interface_type_does_not_match=04127;
type_e_generic_const_type_not_allowed=04128;
sym_e_id_not_found=05000; sym_e_id_not_found=05000;
sym_f_internal_error_in_symtablestack=05001; sym_f_internal_error_in_symtablestack=05001;
sym_e_duplicate_id=05002; sym_e_duplicate_id=05002;
@ -1125,9 +1126,9 @@ const
option_info=11024; option_info=11024;
option_help_pages=11025; option_help_pages=11025;
MsgTxtSize = 85143; MsgTxtSize = 85203;
MsgIdxMax : array[1..20] of longint=( MsgIdxMax : array[1..20] of longint=(
28,106,356,128,99,63,143,36,223,68, 28,106,356,129,99,63,143,36,223,68,
62,20,30,1,1,1,1,1,1,1 62,20,30,1,1,1,1,1,1,1
); );

1006
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

4
compiler/ncnv.pas
View File

@ -3102,7 +3102,8 @@ implementation
{ for constant values on absolute variables, swapping is required } { for constant values on absolute variables, swapping is required }
if (target_info.endian = endian_big) and (nf_absolute in flags) then if (target_info.endian = endian_big) and (nf_absolute in flags) then
swap_const_value(tordconstnode(left).value,tordconstnode(left).resultdef.size); 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 } { swap value back, but according to new type }
if (target_info.endian = endian_big) and (nf_absolute in flags) then if (target_info.endian = endian_big) and (nf_absolute in flags) then
swap_const_value(tordconstnode(left).value,resultdef.size); swap_const_value(tordconstnode(left).value,resultdef.size);
@ -3219,6 +3220,7 @@ implementation
end; end;
if (convtype=tc_int_2_int) and (left.nodetype=typeconvn) and (ttypeconvnode(left).convtype=tc_bool_2_int) then if (convtype=tc_int_2_int) and (left.nodetype=typeconvn) and (ttypeconvnode(left).convtype=tc_bool_2_int) then
begin begin
ttypeconvnode(left).totypedef:=resultdef;
ttypeconvnode(left).resultdef:=resultdef; ttypeconvnode(left).resultdef:=resultdef;
result:=left; result:=left;
left:=nil; left:=nil;

41
compiler/ncon.pas
View File

@ -306,6 +306,7 @@ implementation
p1 : tnode; p1 : tnode;
len : longint; len : longint;
pc : pchar; pc : pchar;
value_set : pconstset;
begin begin
p1:=nil; p1:=nil;
case p.consttyp of case p.consttyp of
@ -331,18 +332,50 @@ implementation
constwstring : constwstring :
p1:=cstringconstnode.createunistr(pcompilerwidestring(p.value.valueptr)); p1:=cstringconstnode.createunistr(pcompilerwidestring(p.value.valueptr));
constreal : 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 : 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 : 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 : constnil :
p1:=cnilnode.create; p1:=cnilnode.create;
constguid : 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 else
internalerror(200205103); internalerror(200205103);
end; 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; genconstsymtree:=p1;
end; end;

5
compiler/nmat.pas
View File

@ -131,7 +131,10 @@ implementation
end; end;
if rv = 0 then if rv = 0 then
begin 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 } { recover }
tordconstnode(right).value := 1; tordconstnode(right).value := 1;
end; end;

20
compiler/node.pas
View File

@ -276,10 +276,13 @@ interface
nf_block_with_exit, nf_block_with_exit,
{ tloadvmtaddrnode } { 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 { node is derived from generic parameter }
type is written to the PPU. So before adding more than 32 elements, 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 either move some flags to specific nodes, or stream a normalset
to the ppu to the ppu
} }
@ -1380,6 +1383,9 @@ implementation
constructor tunarynode.create(t:tnodetype;l : tnode); constructor tunarynode.create(t:tnodetype;l : tnode);
begin begin
inherited create(t); 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; left:=l;
end; end;
@ -1482,7 +1488,10 @@ implementation
constructor tbinarynode.create(t:tnodetype;l,r : tnode); constructor tbinarynode.create(t:tnodetype;l,r : tnode);
begin begin
inherited create(t,l); inherited create(t,l);
right:=r { transfer generic paramater flag }
if assigned(r) and (nf_generic_para in r.flags) then
include(flags,nf_generic_para);
right:=r;
end; end;
@ -1635,6 +1644,9 @@ implementation
constructor ttertiarynode.create(_t:tnodetype;l,r,t : tnode); constructor ttertiarynode.create(_t:tnodetype;l,r,t : tnode);
begin begin
inherited create(_t,l,r); inherited create(_t,l,r);
{ transfer generic parameter flag }
if assigned(t) and (nf_generic_para in t.flags) then
include(flags,nf_generic_para);
third:=t; third:=t;
end; end;

5
compiler/nset.pas
View File

@ -424,8 +424,9 @@ implementation
{ both types must be compatible } { both types must be compatible }
if compare_defs(left.resultdef,right.resultdef,left.nodetype)=te_incompatible then if compare_defs(left.resultdef,right.resultdef,left.nodetype)=te_incompatible then
IncompatibleTypes(left.resultdef,right.resultdef); IncompatibleTypes(left.resultdef,right.resultdef);
{ Check if only when its a constant set } { check if only when its a constant set and
if (left.nodetype=ordconstn) and (right.nodetype=ordconstn) then 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 begin
{ upper limit must be greater or equal than lower limit } { upper limit must be greater or equal than lower limit }
if (tordconstnode(left).value>tordconstnode(right).value) and if (tordconstnode(left).value>tordconstnode(right).value) and

5
compiler/pass_1.pas
View File

@ -62,6 +62,7 @@ implementation
procedure typecheckpass_internal_loop(var p : tnode; out node_changed: boolean); procedure typecheckpass_internal_loop(var p : tnode; out node_changed: boolean);
var var
hp : tnode; hp : tnode;
oldflags : tnodeflags;
begin begin
codegenerror:=false; codegenerror:=false;
repeat repeat
@ -73,9 +74,13 @@ implementation
if assigned(hp) then if assigned(hp) then
begin begin
node_changed:=true; node_changed:=true;
oldflags:=p.flags;
p.free; p.free;
{ switch to new node } { switch to new node }
p:=hp; p:=hp;
{ transfer generic paramter flag }
if nf_generic_para in oldflags then
include(p.flags,nf_generic_para);
end; end;
until not assigned(hp) or until not assigned(hp) or
assigned(hp.resultdef); assigned(hp.resultdef);

26
compiler/pdecl.pas
View File

@ -135,7 +135,10 @@ implementation
setconstn : setconstn :
begin begin
new(ps); new(ps);
ps^:=tsetconstnode(p).value_set^; if assigned(tsetconstnode(p).value_set) then
ps^:=tsetconstnode(p).value_set^
else
ps^:=[];
hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef); hp:=cconstsym.create_ptr(orgname,constset,ps,p.resultdef);
end; end;
pointerconstn : pointerconstn :
@ -185,8 +188,22 @@ implementation
end; end;
end; end;
else 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; 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; current_tokenpos:=storetokenpos;
p.free; p.free;
readconstant:=hp; readconstant:=hp;
@ -716,8 +733,9 @@ implementation
{ we are not freeing the type parameters, so register them } { we are not freeing the type parameters, so register them }
for i:=0 to generictypelist.count-1 do for i:=0 to generictypelist.count-1 do
begin begin
ttypesym(generictypelist[i]).register_sym; tstoredsym(generictypelist[i]).register_sym;
tstoreddef(ttypesym(generictypelist[i]).typedef).register_def; if tstoredsym(generictypelist[i]).typ=typesym then
tstoreddef(ttypesym(generictypelist[i]).typedef).register_def;
end; end;
str(generictypelist.Count,s); str(generictypelist.Count,s);

32
compiler/pdecsub.pas
View File

@ -628,7 +628,7 @@ implementation
for i:=0 to genericparams.count-1 do for i:=0 to genericparams.count-1 do
begin begin
sym:=ttypesym(genericparams[i]); sym:=ttypesym(genericparams[i]);
if tstoreddef(sym.typedef).is_registered then if (sym.typ<>constsym) and tstoreddef(sym.typedef).is_registered then
begin begin
sym.typedef.free; sym.typedef.free;
sym.typedef:=nil; sym.typedef:=nil;
@ -813,9 +813,11 @@ implementation
function check_generic_parameters(def:tstoreddef):boolean; function check_generic_parameters(def:tstoreddef):boolean;
var var
i : longint; i : longint;
decltype, declsym,
impltype : ttypesym; implsym : tsym;
impltype : ttypesym absolute implsym;
implname : tsymstr; implname : tsymstr;
fileinfo : tfileposinfo;
begin begin
result:=true; result:=true;
if not assigned(def.genericparas) then if not assigned(def.genericparas) then
@ -826,18 +828,23 @@ implementation
internalerror(2018090104); internalerror(2018090104);
for i:=0 to def.genericparas.count-1 do for i:=0 to def.genericparas.count-1 do
begin begin
decltype:=ttypesym(def.genericparas[i]); declsym:=tsym(def.genericparas[i]);
impltype:=ttypesym(genericparams[i]); implsym:=tsym(genericparams[i]);
implname:=upper(genericparams.nameofindex(i)); implname:=upper(genericparams.nameofindex(i));
if decltype.name<>implname then if declsym.name<>implname then
begin begin
messagepos1(impltype.fileinfo,sym_e_generic_type_param_mismatch,impltype.realname); messagepos1(implsym.fileinfo,sym_e_generic_type_param_mismatch,implsym.realname);
messagepos1(decltype.fileinfo,sym_e_generic_type_param_decl,decltype.realname); messagepos1(declsym.fileinfo,sym_e_generic_type_param_decl,declsym.realname);
result:=false; result:=false;
end; end;
if df_genconstraint in impltype.typedef.defoptions then if ((implsym.typ=typesym) and (df_genconstraint in impltype.typedef.defoptions)) or
(implsym.typ=constsym) then
begin begin
messagepos(tstoreddef(impltype.typedef).genconstraintdata.fileinfo,parser_e_generic_constraints_not_allowed_here); if implsym.typ=constsym then
fileinfo:=impltype.fileinfo
else
fileinfo:=tstoreddef(impltype.typedef).genconstraintdata.fileinfo;
messagepos(fileinfo,parser_e_generic_constraints_not_allowed_here);
result:=false; result:=false;
end; end;
end; end;
@ -1127,8 +1134,9 @@ implementation
{ register the parameters } { register the parameters }
for i:=0 to genericparams.count-1 do for i:=0 to genericparams.count-1 do
begin begin
ttypesym(genericparams[i]).register_sym; tsym(genericparams[i]).register_sym;
tstoreddef(ttypesym(genericparams[i]).typedef).register_def; if tsym(genericparams[i]).typ=typesym then
tstoreddef(ttypesym(genericparams[i]).typedef).register_def;
end; end;
insert_generic_parameter_types(pd,nil,genericparams); insert_generic_parameter_types(pd,nil,genericparams);
{ the list is no longer required } { the list is no longer required }

4
compiler/pdecvar.pas
View File

@ -1707,6 +1707,10 @@ implementation
hdef:=generrordef; hdef:=generrordef;
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 } { Process procvar directives }
if maybe_parse_proc_directives(hdef) then if maybe_parse_proc_directives(hdef) then
semicoloneaten:=true; semicoloneaten:=true;

17
compiler/pexpr.pas
View File

@ -447,6 +447,9 @@ implementation
{ no packed bit support for these things } { no packed bit support for these things }
if l=in_bitsizeof_x then if l=in_bitsizeof_x then
statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sizesinttype,true)); 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 end
else else
begin begin
@ -467,6 +470,9 @@ implementation
end end
else else
statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sizesinttype,true); 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 not needed !}
p1.destroy; p1.destroy;
end; end;
@ -4247,7 +4253,10 @@ implementation
gendef:=generate_specialization_phase2(spezcontext,tstoreddef(gendef),false,''); gendef:=generate_specialization_phase2(spezcontext,tstoreddef(gendef),false,'');
spezcontext.free; spezcontext.free;
spezcontext:=nil; spezcontext:=nil;
gensym:=gendef.typesym; if gendef.typ=errordef then
gensym:=generrorsym
else
gensym:=gendef.typesym;
end; end;
procdef: procdef:
begin begin
@ -4601,7 +4610,7 @@ implementation
filepos : tfileposinfo; filepos : tfileposinfo;
oldafterassignment, oldafterassignment,
updatefpos : boolean; updatefpos : boolean;
oldflags : tnodeflags;
begin begin
oldafterassignment:=afterassignment; oldafterassignment:=afterassignment;
p1:=sub_expr(opcompare,[ef_accept_equal],nil); p1:=sub_expr(opcompare,[ef_accept_equal],nil);
@ -4658,10 +4667,14 @@ implementation
else else
updatefpos:=false; updatefpos:=false;
end; end;
oldflags:=p1.flags;
{ get the resultdef for this expression } { get the resultdef for this expression }
if not assigned(p1.resultdef) and if not assigned(p1.resultdef) and
dotypecheck then dotypecheck then
do_typecheckpass(p1); do_typecheckpass(p1);
{ transfer generic paramter flag }
if nf_generic_para in oldflags then
include(p1.flags,nf_generic_para);
afterassignment:=oldafterassignment; afterassignment:=oldafterassignment;
if updatefpos then if updatefpos then
p1.fileinfo:=filepos; p1.fileinfo:=filepos;

6
compiler/pgentype.pas
View File

@ -42,7 +42,7 @@ type
tspecializationcontext=class tspecializationcontext=class
public public
genericdeflist : tfpobjectlist; paramlist : tfpobjectlist;
poslist : tfplist; poslist : tfplist;
prettyname : ansistring; prettyname : ansistring;
specializename : ansistring; specializename : ansistring;
@ -58,7 +58,7 @@ implementation
constructor tspecializationcontext.create; constructor tspecializationcontext.create;
begin begin
genericdeflist:=tfpobjectlist.create(false); paramlist:=tfpobjectlist.create(false);
poslist:=tfplist.create; poslist:=tfplist.create;
end; end;
@ -66,7 +66,7 @@ destructor tspecializationcontext.destroy;
var var
i : longint; i : longint;
begin begin
genericdeflist.free; paramlist.free;
for i:=0 to poslist.count-1 do for i:=0 to poslist.count-1 do
dispose(pfileposinfo(poslist[i])); dispose(pfileposinfo(poslist[i]));
poslist.free; poslist.free;

705
compiler/pgenutil.pas
View File

@ -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;symname:string):tdef;inline;
function generate_specialization_phase1(out context:tspecializationcontext;genericdef:tdef;parsedtype:tdef;symname:string;parsedpos:tfileposinfo):tdef; 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 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_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 insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
procedure maybe_insert_generic_rename_symbol(const name:tidstring;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; function generate_generic_name(const name:tidstring;specializename:ansistring;owner_hierarchy:string):tidstring;
@ -65,16 +65,148 @@ uses
{ common } { common }
cutils,fpccrc, cutils,fpccrc,
{ global } { global }
globals,tokens,verbose,finput, globals,tokens,verbose,finput,constexp,
{ symtable } { symtable }
symconst,symsym,symtable,defcmp,procinfo, symconst,symsym,symtable,defcmp,defutil,procinfo,
{ modules } { modules }
fmodule, fmodule,
node,nobj, node,nobj,ncon,
{ parser } { parser }
scanner, scanner,
pbase,pexpr,pdecsub,ptype,psub,pparautl; pbase,pexpr,pdecsub,ptype,psub,pparautl;
type
tdeftypeset = set of tdeftyp;
const
tgeneric_param_const_types : tdeftypeset = [orddef,stringdef,floatdef,setdef,pointerdef,enumdef];
tgeneric_param_nodes : tnodetypeset = [typen,ordconstn,stringconstn,realconstn,setconstn,niln];
function get_generic_param_def(sym:tsym):tdef;
begin
if sym.typ=constsym then
result:=tconstsym(sym).constdef
else
result:=ttypesym(sym).typedef;
end;
function compare_orddef_by_range(param1,param2:torddef;value:tconstvalue):boolean;
begin
if (value.valueord<param2.low) or (value.valueord>param2.high) then
result:=false
else
result:=true;
end;
function compare_generic_params(param1,param2:tdef;constparamsym:tconstsym):boolean;
begin
if (param1.typ=orddef) and (param2.typ=orddef) then
begin
if is_boolean(param2) then
result:=is_boolean(param1)
else if is_char(param2) then
result:=is_char(param1)
else if compare_orddef_by_range(torddef(param1),torddef(param2),constparamsym.value) then
result:=true
else
result:=false;
end
{ arraydef is string constant so it's compatible with stringdef }
else if (param1.typ=arraydef) and (param2.typ=stringdef) then
result:=true
{ integer ords are compatible with float }
else if (param1.typ=orddef) and is_integer(param1) and (param2.typ=floatdef) then
result:=true
{ undefined def is compatible with all types }
else if param2.typ=undefineddef then
result:=true
{ sets require stricter checks }
else if is_set(param2) then
result:=equal_defs(param1,param2)
else
result:=param1.typ=param2.typ;
end;
function create_generic_constsym(fromdef:tdef;node:tnode;out prettyname:string):tconstsym;
const
undefinedname = 'undefined';
var
sym : tconstsym;
setdef : tsetdef;
enumsym : tsym;
enumname : string;
sp : pchar;
ps : ^tconstset;
pd : ^bestreal;
i : integer;
begin
if node=nil then
internalerror(2020011401);
case node.nodetype of
ordconstn:
begin
sym:=cconstsym.create_ord(undefinedname,constord,tordconstnode(node).value,fromdef);
prettyname:=tostr(tordconstnode(node).value.svalue);
end;
stringconstn:
begin
getmem(sp,tstringconstnode(node).len+1);
move(tstringconstnode(node).value_str^,sp^,tstringconstnode(node).len+1);
sym:=cconstsym.create_string(undefinedname,conststring,sp,tstringconstnode(node).len,fromdef);
prettyname:=''''+tstringconstnode(node).value_str+'''';
end;
realconstn:
begin
new(pd);
pd^:=trealconstnode(node).value_real;
sym:=cconstsym.create_ptr(undefinedname,constreal,pd,fromdef);
prettyname:=realtostr(trealconstnode(node).value_real);
end;
setconstn:
begin
new(ps);
ps^:=tsetconstnode(node).value_set^;
sym:=cconstsym.create_ptr(undefinedname,constset,ps,fromdef);
setdef:=tsetdef(tsetconstnode(node).resultdef);
prettyname:='[';
for i := setdef.setbase to setdef.setmax do
if i in tsetconstnode(node).value_set^ then
begin
if setdef.elementdef.typ=enumdef then
enumsym:=tenumdef(setdef.elementdef).int2enumsym(i)
else
enumsym:=nil;
if assigned(enumsym) then
enumname:=enumsym.realname
else if setdef.elementdef.typ=orddef then
begin
if torddef(setdef.elementdef).ordtype=uchar then
enumname:=chr(i)
else
enumname:=tostr(i);
end
else
enumname:=tostr(i);
if length(prettyname) > 1 then
prettyname:=prettyname+','+enumname
else
prettyname:=prettyname+enumname;
end;
prettyname:=prettyname+']';
end;
niln:
begin
{ only "nil" is available for pointer constants }
sym:=cconstsym.create_ord(undefinedname,constnil,0,fromdef);
prettyname:='nil';
end;
else
internalerror(2019021601);
end;
{ the sym needs an owner for later checks so use the typeparam owner }
sym.owner:=fromdef.owner;
include(sym.symoptions,sp_generic_const);
result:=sym;
end;
procedure maybe_add_waiting_unit(tt:tdef); procedure maybe_add_waiting_unit(tt:tdef);
var var
@ -104,203 +236,231 @@ uses
end; end;
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 var
i,j, i,j,
intfcount : longint; intfcount : longint;
formaldef, formaldef,
paradef : tstoreddef; paradef : tstoreddef;
genparadef : tdef;
objdef, objdef,
paraobjdef, paraobjdef,
formalobjdef : tobjectdef; formalobjdef : tobjectdef;
intffound : boolean; intffound : boolean;
filepos : tfileposinfo; filepos : tfileposinfo;
is_const : boolean;
begin begin
{ check whether the given specialization parameters fit to the eventual { check whether the given specialization parameters fit to the eventual
constraints of the generic } constraints of the generic }
if not assigned(genericdef.genericparas) or (genericdef.genericparas.count=0) then if not assigned(genericdef.genericparas) or (genericdef.genericparas.count=0) then
internalerror(2012101001); internalerror(2012101001);
if genericdef.genericparas.count<>paradeflist.count then if genericdef.genericparas.count<>paramlist.count then
internalerror(2012101002); internalerror(2012101002);
if paradeflist.count<>poslist.count then if paramlist.count<>poslist.count then
internalerror(2012120801); internalerror(2012120801);
result:=true; result:=true;
for i:=0 to genericdef.genericparas.count-1 do for i:=0 to genericdef.genericparas.count-1 do
begin begin
filepos:=pfileposinfo(poslist[i])^; filepos:=pfileposinfo(poslist[i])^;
formaldef:=tstoreddef(ttypesym(genericdef.genericparas[i]).typedef); paradef:=tstoreddef(get_generic_param_def(tsym(paramlist[i])));
if formaldef.typ=undefineddef then is_const:=tsym(paramlist[i]).typ=constsym;
{ the parameter is of unspecified type, so no need to check } genparadef:=genericdef.get_generic_param_def(i);
continue; { validate const params }
if not (df_genconstraint in formaldef.defoptions) or if not genericdef.is_generic_param_const(i) and is_const then
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
begin begin
case formaldef.typ of MessagePos(filepos,type_e_mismatch);
recorddef: exit(false);
{ delphi has own fantasy about record constraint end
(almost non-nullable/non-nilable value type) } else if genericdef.is_generic_param_const(i) then
if m_delphi in current_settings.modeswitches then begin
case paradef.typ of { param type mismatch (type <> const) }
floatdef,enumdef,orddef: if genericdef.is_generic_param_const(i)<>is_const then
continue; begin
objectdef: MessagePos(filepos,type_e_mismatch);
if tobjectdef(paradef).objecttype=odt_object then exit(false);
continue end;
else { type constrained param doesn't match type }
MessagePos(filepos,type_e_record_type_expected); 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 else
MessagePos(filepos,type_e_record_type_expected); MessagePos(filepos,type_e_record_type_expected);
end objectdef:
else case tobjectdef(formaldef).objecttype of
MessagePos(filepos,type_e_record_type_expected); odt_class,
objectdef: odt_javaclass:
case tobjectdef(formaldef).objecttype of MessagePos1(filepos,type_e_class_type_expected,paradef.typename);
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(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
begin
{ this is either a concerete interface or class type (the
latter without specific implemented interfaces) }
case paraobjdef.objecttype of
odt_interfacecom, odt_interfacecom,
odt_interfacecorba, odt_interfacecorba,
odt_interfacejava, odt_dispinterface,
odt_dispinterface: odt_interfacejava:
begin MessagePos1(filepos,type_e_interface_type_expected,paradef.typename);
if (oo_is_forward in paraobjdef.objectoptions) and else
(paraobjdef.objecttype=formalobjdef.objecttype) and internalerror(2012101003);
(df_genconstraint in formalobjdef.defoptions) and end;
( errordef:
(formalobjdef.objecttype=odt_interfacecom) and { ignore }
(formalobjdef.childof=interface_iunknown) ;
) else
or internalerror(2012101004);
( end;
(formalobjdef.objecttype=odt_interfacecorba) and result:=false;
(formalobjdef.childof=nil) end
) then else
continue; begin
if not def_is_related(paraobjdef,formalobjdef.childof) 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
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 begin
MessagePos2(filepos,type_e_incompatible_types,paraobjdef.typename,formalobjdef.childof.typename); 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;
odt_class,
odt_javaclass:
begin
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;
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; result:=false;
end; end;
end; end;
odt_class, end
odt_javaclass: else
begin
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;
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;
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 begin
MessagePos1(filepos,type_e_class_type_expected,paraobjdef.typename); { this is either a "class" or a concrete instance with
result:=false; or without implemented interfaces }
continue; if not (paraobjdef.objecttype in [odt_class,odt_javaclass]) then
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 begin
intffound:=assigned( MessagePos1(filepos,type_e_class_type_expected,paraobjdef.typename);
find_implemented_interface(objdef, result:=false;
timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef continue;
)
);
if intffound then
break;
objdef:=objdef.childof;
end; end;
if intffound then { for forward declared classes we allow pure TObject/class declarations }
inc(intfcount) if (oo_is_forward in paraobjdef.objectoptions) and
else (df_genconstraint in formaldef.defoptions) then
MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef.typename); 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
inc(intfcount)
else
MessagePos2(filepos,parser_e_class_doesnt_implement_interface,paraobjdef.typename,timplementedinterface(formalobjdef.implementedinterfaces[j]).intfdef.typename);
end;
if intfcount<>formalobjdef.implementedinterfaces.count then
result:=false;
end; end;
if intfcount<>formalobjdef.implementedinterfaces.count then
result:=false;
end; end;
end; end;
end; end;
end; end;
end; end;
function parse_generic_specialization_types_internal(paramlist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean;
function parse_generic_specialization_types_internal(genericdeflist:tfpobjectlist;poslist:tfplist;out prettyname,specializename:ansistring;parsedtype:tdef;parsedpos:tfileposinfo):boolean;
var var
old_block_type : tblock_type; old_block_type : tblock_type;
first : boolean; first : boolean;
@ -310,9 +470,11 @@ uses
namepart : string; namepart : string;
prettynamepart : ansistring; prettynamepart : ansistring;
module : tmodule; module : tmodule;
constprettyname : string;
validparam : boolean;
begin begin
result:=true; result:=true;
if genericdeflist=nil then if paramlist=nil then
internalerror(2012061401); internalerror(2012061401);
{ set the block type to type, so that the parsed type are returned as { 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 ttypenode (e.g. classes are in non type-compatible blocks returned as
@ -324,7 +486,7 @@ uses
first:=not assigned(parsedtype); first:=not assigned(parsedtype);
if assigned(parsedtype) then if assigned(parsedtype) then
begin begin
genericdeflist.Add(parsedtype); paramlist.Add(parsedtype.typesym);
module:=find_module_from_symtable(parsedtype.owner); module:=find_module_from_symtable(parsedtype.owner);
if not assigned(module) then if not assigned(module) then
internalerror(2016112801); internalerror(2016112801);
@ -350,8 +512,10 @@ uses
consume(_COMMA); consume(_COMMA);
block_type:=bt_type; block_type:=bt_type;
tmpparampos:=current_filepos; tmpparampos:=current_filepos;
typeparam:=factor(false,[ef_type_only]); typeparam:=factor(false,[ef_accept_equal]);
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 begin
if tstoreddef(typeparam.resultdef).is_generic and if tstoreddef(typeparam.resultdef).is_generic and
( (
@ -367,31 +531,46 @@ uses
end; end;
if typeparam.resultdef.typ<>errordef then if typeparam.resultdef.typ<>errordef then
begin 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) message(type_e_generics_cannot_reference_itself)
else if (typeparam.resultdef.typ<>errordef) then else if (typeparam.resultdef.typ<>errordef) then
begin 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); module:=find_module_from_symtable(typeparam.resultdef.owner);
if not assigned(module) then if not assigned(module) then
internalerror(2016112802); internalerror(2016112802);
namepart:='_$'+hexstr(module.moduleid,8)+'$$'+typeparam.resultdef.unique_id_str; 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 } { we use the full name of the type to uniquely identify it }
if (symtablestack.top.symtabletype=parasymtable) and if typeparam.nodetype=typen then
(symtablestack.top.defowner.typ=procdef) and
(typeparam.resultdef.owner=symtablestack.top) then
begin begin
{ special handling for specializations inside generic function declarations } if (symtablestack.top.symtabletype=parasymtable) and
prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname; (symtablestack.top.defowner.typ=procdef) and
end (typeparam.resultdef.owner=symtablestack.top) then
else begin
begin { special handling for specializations inside generic function declarations }
prettynamepart:=typeparam.resultdef.fullownerhierarchyname(true); prettynamepart:=tdef(symtablestack.top.defowner).fullownerhierarchyname(true)+tprocdef(symtablestack.top.defowner).procsym.prettyname;
end
else
begin
prettynamepart:=typeparam.resultdef.fullownerhierarchyname(true);
end;
end; end;
specializename:=specializename+namepart; specializename:=specializename+namepart;
if not first then if not first then
prettyname:=prettyname+','; 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;
end end
else else
@ -411,12 +590,12 @@ uses
end; 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 var
dummypos : tfileposinfo; dummypos : tfileposinfo;
begin begin
FillChar(dummypos, SizeOf(tfileposinfo), 0); 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; end;
@ -502,7 +681,7 @@ uses
context:=tspecializationcontext.create; context:=tspecializationcontext.create;
{ Parse type parameters } { 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 if err then
begin begin
if not try_to_consume(_GT) then if not try_to_consume(_GT) then
@ -556,7 +735,7 @@ uses
{ search a generic with the given count of params } { search a generic with the given count of params }
countstr:=''; countstr:='';
str(context.genericdeflist.Count,countstr); str(context.paramlist.Count,countstr);
genname:=genname+'$'+countstr; genname:=genname+'$'+countstr;
ugenname:=upper(genname); ugenname:=upper(genname);
@ -681,6 +860,8 @@ uses
tempst : tglobalsymtable; tempst : tglobalsymtable;
psym, psym,
srsym : tsym; srsym : tsym;
paramdef1,
paramdef2,
def : tdef; def : tdef;
old_block_type : tblock_type; old_block_type : tblock_type;
state : tspecializationstate; state : tspecializationstate;
@ -708,7 +889,7 @@ uses
pd:=nil; 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 begin
{ the parameters didn't fit the constraints, so don't continue with the { the parameters didn't fit the constraints, so don't continue with the
specialization } specialization }
@ -724,20 +905,19 @@ uses
else else
prettyname:=genericdef.typesym.prettyname; prettyname:=genericdef.typesym.prettyname;
prettyname:=prettyname+'<'+context.prettyname+'>'; prettyname:=prettyname+'<'+context.prettyname+'>';
generictypelist:=tfphashobjectlist.create(false); generictypelist:=tfphashobjectlist.create(false);
{ build the list containing the types for the generic params } { build the list containing the types for the generic params }
if not assigned(genericdef.genericparas) then if not assigned(genericdef.genericparas) then
internalerror(2013092601); internalerror(2013092601);
if context.genericdeflist.count<>genericdef.genericparas.count then if context.paramlist.count<>genericdef.genericparas.count then
internalerror(2013092603); internalerror(2013092603);
for i:=0 to genericdef.genericparas.Count-1 do for i:=0 to genericdef.genericparas.Count-1 do
begin begin
srsym:=tsym(genericdef.genericparas[i]); srsym:=tsym(genericdef.genericparas[i]);
if not (sp_generic_para in srsym.symoptions) then if not (sp_generic_para in srsym.symoptions) then
internalerror(2013092602); internalerror(2013092602);
generictypelist.add(srsym.realname,tdef(context.genericdeflist[i]).typesym); generictypelist.add(srsym.realname,context.paramlist[i]);
end; end;
{ Special case if we are referencing the current defined object } { Special case if we are referencing the current defined object }
@ -792,11 +972,33 @@ uses
allequal:=true; allequal:=true;
for i:=0 to generictypelist.count-1 do for i:=0 to generictypelist.count-1 do
begin begin
if not equal_defs(ttypesym(generictypelist[i]).typedef,ttypesym(tstoreddef(def).genericparas[i]).typedef) then if tsym(generictypelist[i]).typ<>tsym(tstoreddef(def).genericparas[i]).typ then
begin begin
allequal:=false; allequal:=false;
break; break;
end; end;
if tsym(generictypelist[i]).typ=constsym then
paramdef1:=tconstsym(generictypelist[i]).constdef
else
paramdef1:=ttypesym(generictypelist[i]).typedef;
if tsym(tstoreddef(def).genericparas[i]).typ=constsym then
paramdef2:=tconstsym(tstoreddef(def).genericparas[i]).constdef
else
paramdef2:=ttypesym(tstoreddef(def).genericparas[i]).typedef;
if not equal_defs(paramdef2,paramdef2) then
begin
allequal:=false;
break;
end;
if (tsym(generictypelist[i]).typ=constsym) and
(
(tconstsym(generictypelist[i]).consttyp<>tconstsym(tstoreddef(def).genericparas[i]).consttyp) or
not same_constvalue(tconstsym(generictypelist[i]).consttyp,tconstsym(generictypelist[i]).value,tconstsym(tstoreddef(def).genericparas[i]).value)
) then
begin
allequal:=false;
break;
end;
end; end;
if allequal then if allequal then
begin begin
@ -1159,25 +1361,43 @@ uses
function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist; function parse_generic_parameters(allowconstraints:boolean):tfphashobjectlist;
var var
generictype : ttypesym; generictype : tstoredsym;
i,firstidx : longint; i,firstidx,const_list_index : longint;
srsymtable : tsymtable; srsymtable : tsymtable;
basedef,def : tdef; basedef,def : tdef;
defname : tidstring; defname : tidstring;
allowconst,
allowconstructor, allowconstructor,
is_const,
doconsume : boolean; doconsume : boolean;
constraintdata : tgenericconstraintdata; constraintdata : tgenericconstraintdata;
old_block_type : tblock_type; old_block_type : tblock_type;
fileinfo : tfileposinfo; fileinfo : tfileposinfo;
last_token : ttoken;
last_type_pos : tfileposinfo;
begin begin
result:=tfphashobjectlist.create(false); result:=tfphashobjectlist.create(false);
firstidx:=0; firstidx:=0;
const_list_index:=0;
old_block_type:=block_type; old_block_type:=block_type;
block_type:=bt_type; block_type:=bt_type;
allowconst:=true;
is_const:=false;
last_token:=NOTOKEN;
last_type_pos:=current_filepos;
repeat repeat
if allowconst and try_to_consume(_CONST) then
begin
allowconst:=false;
is_const:=true;
const_list_index:=result.count;
end;
if token=_ID then if token=_ID then
begin begin
generictype:=ctypesym.create(orgpattern,cundefinedtype); if is_const then
generictype:=cconstsym.create_undefined(orgpattern,cundefinedtype)
else
generictype:=ctypesym.create(orgpattern,cundefinedtype);
{ type parameters need to be added as strict private } { type parameters need to be added as strict private }
generictype.visibility:=vis_strictprivate; generictype.visibility:=vis_strictprivate;
include(generictype.symoptions,sp_generic_para); include(generictype.symoptions,sp_generic_para);
@ -1185,7 +1405,43 @@ uses
end; end;
consume(_ID); consume(_ID);
fileinfo:=current_tokenpos; fileinfo:=current_tokenpos;
if try_to_consume(_COLON) then { const restriction }
if is_const and try_to_consume(_COLON) then
begin
def:=nil;
{ parse the type and assign the const type to generictype }
single_type(def,[]);
for i:=const_list_index to result.count-1 do
begin
{ finalize constant information once type is known }
if assigned(def) and (def.typ in tgeneric_param_const_types) then
begin
case def.typ of
orddef,
enumdef:
tconstsym(result[i]).consttyp:=constord;
stringdef:
tconstsym(result[i]).consttyp:=conststring;
floatdef:
tconstsym(result[i]).consttyp:=constreal;
setdef:
tconstsym(result[i]).consttyp:=constset;
{ pointer always refers to nil with constants }
pointerdef:
tconstsym(result[i]).consttyp:=constnil;
else
internalerror(2020011402);
end;
tconstsym(result[i]).constdef:=def;
end
else
Message1(type_e_generic_const_type_not_allowed,def.fulltypename);
end;
{ after type restriction const list terminates }
is_const:=false;
end
{ type restriction }
else if try_to_consume(_COLON) then
begin begin
if not allowconstraints then if not allowconstraints then
Message(parser_e_generic_constraints_not_allowed_here); Message(parser_e_generic_constraints_not_allowed_here);
@ -1302,6 +1558,7 @@ uses
basedef:=cobjectdef.create(tobjectdef(def).objecttype,defname,tobjectdef(def),false); basedef:=cobjectdef.create(tobjectdef(def).objecttype,defname,tobjectdef(def),false);
constraintdata.interfaces.delete(0); constraintdata.interfaces.delete(0);
end; end;
if basedef.typ<>errordef then if basedef.typ<>errordef then
with tstoreddef(basedef) do with tstoreddef(basedef) do
begin begin
@ -1328,21 +1585,34 @@ uses
begin begin
{ two different typeless parameters are considered as incompatible } { two different typeless parameters are considered as incompatible }
for i:=firstidx to result.count-1 do for i:=firstidx to result.count-1 do
begin if tsym(result[i]).typ<>constsym then
ttypesym(result[i]).typedef:=cundefineddef.create(false); begin
ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]); ttypesym(result[i]).typedef:=cundefineddef.create(false);
end; ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]);
end;
{ a semicolon terminates a type parameter group } { a semicolon terminates a type parameter group }
firstidx:=result.count; firstidx:=result.count;
end; end;
end; end;
if token=_SEMICOLON then
begin
is_const:=false;
allowconst:=true;
end;
last_token:=token;
last_type_pos:=current_filepos;
until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON)); 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 } { two different typeless parameters are considered as incompatible }
for i:=firstidx to result.count-1 do for i:=firstidx to result.count-1 do
begin if tsym(result[i]).typ<>constsym then
ttypesym(result[i]).typedef:=cundefineddef.create(false); begin
ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]); ttypesym(result[i]).typedef:=cundefineddef.create(false);
end; ttypesym(result[i]).typedef.typesym:=ttypesym(result[i]);
end;
block_type:=old_block_type; block_type:=old_block_type;
end; end;
@ -1350,7 +1620,9 @@ uses
procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist); procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:tfphashobjectlist);
var var
i : longint; i : longint;
generictype,sym : ttypesym; generictype : tstoredsym;
generictypedef : tdef;
sym : tsym;
st : tsymtable; st : tsymtable;
begin begin
def.genericdef:=genericdef; def.genericdef:=genericdef;
@ -1375,10 +1647,23 @@ uses
def.genericparas:=tfphashobjectlist.create(false); def.genericparas:=tfphashobjectlist.create(false);
for i:=0 to genericlist.count-1 do for i:=0 to genericlist.count-1 do
begin begin
generictype:=ttypesym(genericlist[i]); generictype:=tstoredsym(genericlist[i]);
if assigned(generictype.owner) then if assigned(generictype.owner) then
begin 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 } { type parameters need to be added as strict private }
sym.visibility:=vis_strictprivate; sym.visibility:=vis_strictprivate;
st.insert(sym); st.insert(sym);
@ -1386,13 +1671,17 @@ uses
end end
else else
begin begin
if (generictype.typedef.typ=undefineddef) and (generictype.typedef<>cundefinedtype) then if generictype.typ=typesym then
begin begin
{ the generic parameters were parsed before the genericdef existed thus the generictypedef:=ttypesym(generictype).typedef;
undefineddefs were added as part of the parent symtable } if (generictypedef.typ=undefineddef) and (generictypedef<>cundefinedtype) then
if assigned(generictype.typedef.owner) then begin
generictype.typedef.owner.DefList.Extract(generictype.typedef); { the generic parameters were parsed before the genericdef existed thus the
generictype.typedef.changeowner(st); undefineddefs were added as part of the parent symtable }
if assigned(generictypedef.owner) then
generictypedef.owner.DefList.Extract(generictypedef);
generictypedef.changeowner(st);
end;
end; end;
st.insert(generictype); st.insert(generictype);
include(generictype.symoptions,sp_generic_para); include(generictype.symoptions,sp_generic_para);

75
compiler/pparautl.pas
View File

@ -631,27 +631,48 @@ implementation
function check_generic_parameters(fwpd,currpd:tprocdef):boolean; function check_generic_parameters(fwpd,currpd:tprocdef):boolean;
var var
i : longint; i : longint;
fwtype, fwsym,
currtype : ttypesym; currsym : tsym;
currtype : ttypesym absolute currsym;
fileinfo : tfileposinfo;
begin begin
result:=true; result:=true;
if fwpd.genericparas.count<>currpd.genericparas.count then if fwpd.genericparas.count<>currpd.genericparas.count then
internalerror(2018090101); internalerror(2018090101);
for i:=0 to fwpd.genericparas.count-1 do for i:=0 to fwpd.genericparas.count-1 do
begin begin
fwtype:=ttypesym(fwpd.genericparas[i]); fwsym:=tsym(fwpd.genericparas[i]);
currtype:=ttypesym(currpd.genericparas[i]); currsym:=tsym(currpd.genericparas[i]);
if fwtype.name<>currtype.name then if fwsym.name<>currsym.name then
begin begin
messagepos1(currtype.fileinfo,sym_e_generic_type_param_mismatch,currtype.realname); messagepos1(currsym.fileinfo,sym_e_generic_type_param_mismatch,currsym.realname);
messagepos1(fwtype.fileinfo,sym_e_generic_type_param_decl,fwtype.realname); messagepos1(fwsym.fileinfo,sym_e_generic_type_param_decl,fwsym.realname);
result:=false; result:=false;
end; end;
if (fwpd.interfacedef or assigned(fwpd.struct)) and (df_genconstraint in currtype.typedef.defoptions) then if (fwpd.interfacedef or assigned(fwpd.struct)) and
(
((currsym.typ=typesym) and (df_genconstraint in currtype.typedef.defoptions)) or
(currsym.typ=constsym)
) then
begin begin
messagepos(tstoreddef(currtype.typedef).genconstraintdata.fileinfo,parser_e_generic_constraints_not_allowed_here); if currsym.typ=constsym then
fileinfo:=currsym.fileinfo
else
fileinfo:=tstoreddef(currtype.typedef).genconstraintdata.fileinfo;
messagepos(fileinfo,parser_e_generic_constraints_not_allowed_here);
result:=false; result:=false;
end; end;
if not fwpd.interfacedef and not assigned(fwpd.struct) and
(fwsym.typ=constsym) then
begin
{ without modeswitch RepeatForward we need to check here
if the type of the constants match }
if (currsym.typ<>constsym) or not equal_defs(tconstsym(fwsym).constdef,tconstsym(currsym).constdef) then
begin
messagepos1(currpd.fileinfo,parser_e_header_dont_match_forward,currpd.fullprocname(false));
result:=false;
end;
end;
end; end;
end; end;
@ -659,8 +680,10 @@ implementation
function equal_generic_procdefs(fwpd,currpd:tprocdef):boolean; function equal_generic_procdefs(fwpd,currpd:tprocdef):boolean;
var var
i : longint; i : longint;
fwtype, fwsym,
currtype : ttypesym; currsym : tsym;
fwtype : ttypesym absolute fwsym;
currtype : ttypesym absolute currsym;
foundretdef : boolean; foundretdef : boolean;
begin begin
result:=false; result:=false;
@ -677,14 +700,36 @@ implementation
foundretdef:=false; foundretdef:=false;
for i:=0 to fwpd.genericparas.count-1 do for i:=0 to fwpd.genericparas.count-1 do
begin begin
fwtype:=ttypesym(fwpd.genericparas[i]); fwsym:=tsym(fwpd.genericparas[i]);
currtype:=ttypesym(currpd.genericparas[i]); currsym:=tsym(currpd.genericparas[i]);
{ if the type in the currpd isn't a pure undefineddef (thus there { if the type in the currpd isn't a pure undefineddef (thus there
are constraints and the fwpd was declared in the interface, then are constraints and the fwpd was declared in the interface, then
we can stop right there } we can stop right there }
if fwpd.interfacedef and ((currtype.typedef.typ<>undefineddef) or (df_genconstraint in currtype.typedef.defoptions)) then if fwpd.interfacedef and
(
(currsym.typ=constsym) or
((currsym.typ=typesym) and
(
(currtype.typedef.typ<>undefineddef) or
(df_genconstraint in currtype.typedef.defoptions)
)
)
)then
exit; exit;
if not foundretdef then if not fwpd.interfacedef then
begin
if (fwsym.typ=constsym) and (currsym.typ=constsym) then
begin
{ check whether the constant type for forward functions match }
if not equal_defs(tconstsym(fwsym).constdef,tconstsym(currsym).constdef) then
exit;
end
else if (fwsym.typ=constsym) then
{ if the forward sym is a constant, the implementation needs to be one
as well }
exit;
end;
if not foundretdef and (fwsym.typ=typesym) then
begin begin
{ if the returndef is the same as this parameter's def then this { if the returndef is the same as this parameter's def then this
needs to be the case for both procdefs } needs to be the case for both procdefs }

2
compiler/ppu.pas
View File

@ -50,7 +50,7 @@ const
CurrentPPUVersion = 207; CurrentPPUVersion = 207;
{ for any other changes to the ppu format, increase this version number { for any other changes to the ppu format, increase this version number
(it's a cardinal) } (it's a cardinal) }
CurrentPPULongVersion = 8; CurrentPPULongVersion = 9;
{ unit flags } { unit flags }
uf_big_endian = $000004; uf_big_endian = $000004;

4
compiler/pstatmnt.pas
View File

@ -361,7 +361,9 @@ implementation
procedure check_range(hp:tnode; fordef: tdef); procedure check_range(hp:tnode; fordef: tdef);
begin begin
if (hp.nodetype=ordconstn) and 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); adaptrange(fordef,tordconstnode(hp).value,false,false,true);
end; end;

12
compiler/ptype.pas
View File

@ -1316,6 +1316,7 @@ implementation
procedure array_dec(is_packed:boolean;genericdef:tstoreddef;genericlist:tfphashobjectlist); procedure array_dec(is_packed:boolean;genericdef:tstoreddef;genericlist:tfphashobjectlist);
var var
isgeneric : boolean;
lowval, lowval,
highval : TConstExprInt; highval : TConstExprInt;
indexdef : tdef; indexdef : tdef;
@ -1362,6 +1363,7 @@ implementation
lowval:=0; lowval:=0;
highval:=1; highval:=1;
indexdef:=def; indexdef:=def;
isgeneric:=true;
end; end;
else else
Message(sym_e_error_in_type_def); Message(sym_e_error_in_type_def);
@ -1409,6 +1411,7 @@ implementation
begin begin
{ defaults } { defaults }
indexdef:=generrordef; indexdef:=generrordef;
isgeneric:=false;
{ use defaults which don't overflow the compiler } { use defaults which don't overflow the compiler }
lowval:=0; lowval:=0;
highval:=0; highval:=0;
@ -1424,12 +1427,15 @@ implementation
else else
begin begin
pt:=expr(true); pt:=expr(true);
isgeneric:=false;
if pt.nodetype=typen then if pt.nodetype=typen then
setdefdecl(pt.resultdef) setdefdecl(pt.resultdef)
else else
begin begin
if pt.nodetype=rangen then if pt.nodetype=rangen then
begin begin
if nf_generic_para in pt.flags then
isgeneric:=true;
{ pure ordconstn expressions can be checked for { pure ordconstn expressions can be checked for
generics as well, but don't give an error in case generics as well, but don't give an error in case
of parsing a generic if that isn't yet the case } of parsing a generic if that isn't yet the case }
@ -1446,7 +1452,9 @@ implementation
highval:=tordconstnode(trangenode(pt).right).value; highval:=tordconstnode(trangenode(pt).right).value;
if highval<lowval then if highval<lowval then
begin 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; highval:=lowval;
end end
else if (lowval<int64(low(asizeint))) or else if (lowval<int64(low(asizeint))) or
@ -1494,6 +1502,8 @@ implementation
end; end;
if is_packed then if is_packed then
include(arrdef.arrayoptions,ado_IsBitPacked); include(arrdef.arrayoptions,ado_IsBitPacked);
if isgeneric then
include(arrdef.arrayoptions,ado_IsGeneric);
if token=_COMMA then if token=_COMMA then
consume(_COMMA) consume(_COMMA)

11
compiler/symconst.pas
View File

@ -212,8 +212,9 @@ type
generic is encountered to ease inline generic is encountered to ease inline
specializations, etc; those symbols can be specializations, etc; those symbols can be
"overridden" with a completely different symbol } "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 } by the user }
sp_generic_const
); );
tsymoptions=set of tsymoption; tsymoptions=set of tsymoption;
@ -241,7 +242,10 @@ type
{ internal def that's not for any export } { internal def that's not for any export }
df_internal, df_internal,
{ the local def is referenced from a public function } { 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; tdefoptions=set of tdefoption;
@ -567,7 +571,8 @@ type
ado_IsArrayOfConst, // array of const ado_IsArrayOfConst, // array of const
ado_IsConstString, // string constant ado_IsConstString, // string constant
ado_IsBitPacked, // bitpacked array 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; tarraydefoptions=set of tarraydefoption;

54
compiler/symdef.pas
View File

@ -175,6 +175,9 @@ interface
function is_generic:boolean; function is_generic:boolean;
{ same as above for specializations } { same as above for specializations }
function is_specialization:boolean; 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 } { registers this def in the unit's deflist; no-op if already registered }
procedure register_def; override; procedure register_def; override;
{ add the def to the top of the symtable stack if it's not yet owned { add the def to the top of the symtable stack if it's not yet owned
@ -2407,14 +2410,32 @@ implementation
for i:=0 to genericparas.count-1 do for i:=0 to genericparas.count-1 do
begin begin
sym:=tsym(genericparas[i]); 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); internalerror(2014050903);
if sym.owner.defowner<>self then if sym.owner.defowner<>self then
exit(false); exit(false);
if (sym.typ=symconst.constsym) and (sp_generic_const in sym.symoptions) then
exit(false);
end; end;
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; function tstoreddef.is_specialization: boolean;
var var
i : longint; i : longint;
@ -2430,10 +2451,13 @@ implementation
for i:=0 to genericparas.count-1 do for i:=0 to genericparas.count-1 do
begin begin
sym:=tsym(genericparas[i]); 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); internalerror(2014050904);
if sym.owner.defowner<>self then if sym.owner.defowner<>self then
exit(true); exit(true);
if (sym.typ=symconst.constsym) and (sp_generic_const in sym.symoptions) then
exit(true);
end; end;
result:=false; result:=false;
end; end;
@ -4179,7 +4203,7 @@ implementation
ppufile.getderef(rangedefderef); ppufile.getderef(rangedefderef);
lowrange:=ppufile.getasizeint; lowrange:=ppufile.getasizeint;
highrange:=ppufile.getasizeint; highrange:=ppufile.getasizeint;
ppufile.getset(tppuset1(arrayoptions)); ppufile.getset(tppuset2(arrayoptions));
ppuload_platform(ppufile); ppuload_platform(ppufile);
symtable:=tarraysymtable.create(self); symtable:=tarraysymtable.create(self);
tarraysymtable(symtable).ppuload(ppufile) tarraysymtable(symtable).ppuload(ppufile)
@ -4219,7 +4243,7 @@ implementation
ppufile.putderef(rangedefderef); ppufile.putderef(rangedefderef);
ppufile.putasizeint(lowrange); ppufile.putasizeint(lowrange);
ppufile.putasizeint(highrange); ppufile.putasizeint(highrange);
ppufile.putset(tppuset1(arrayoptions)); ppufile.putset(tppuset2(arrayoptions));
writeentry(ppufile,ibarraydef); writeentry(ppufile,ibarraydef);
tarraysymtable(symtable).ppuwrite(ppufile); tarraysymtable(symtable).ppuwrite(ppufile);
end; end;
@ -4339,6 +4363,7 @@ implementation
(ado_IsDynamicArray in arrayoptions) or (ado_IsDynamicArray in arrayoptions) or
(ado_IsConvertedPointer in arrayoptions) or (ado_IsConvertedPointer in arrayoptions) or
(ado_IsConstructor in arrayoptions) or (ado_IsConstructor in arrayoptions) or
(ado_IsGeneric in arrayoptions) or
(highrange<lowrange) (highrange<lowrange)
) and ) and
(size=-1) then (size=-1) then
@ -4543,7 +4568,8 @@ implementation
fullparas, fullparas,
paramname : ansistring; paramname : ansistring;
module : tmodule; module : tmodule;
sym : ttypesym; sym : tsym;
def : tdef;
i : longint; i : longint;
begin begin
{ we want at least enough space for an ellipsis } { we want at least enough space for an ellipsis }
@ -4552,15 +4578,21 @@ implementation
fullparas:=''; fullparas:='';
for i:=0 to genericparas.count-1 do for i:=0 to genericparas.count-1 do
begin begin
sym:=ttypesym(genericparas[i]); sym:=tsym(genericparas[i]);
module:=find_module_from_symtable(sym.owner); module:=find_module_from_symtable(sym.owner);
if not assigned(module) then if not assigned(module) then
internalerror(2014121202); internalerror(2014121202);
paramname:=module.realmodulename^; if not (sym.typ in [constsym,symconst.typesym]) then
if sym.typedef.typ in [objectdef,recorddef] then internalerror(2020042501);
paramname:=paramname+'.'+tabstractrecorddef(sym.typedef).rttiname if sym.typ=constsym then
def:=tconstsym(sym).constdef
else else
paramname:=paramname+'.'+sym.typedef.typename; def:=ttypesym(sym).typedef;
paramname:=module.realmodulename^;
if def.typ in [objectdef,recorddef] then
paramname:=paramname+'.'+tabstractrecorddef(def).rttiname
else
paramname:=paramname+'.'+def.typename;
if length(fullparas)+commacount[i>0]+length(paramname)>maxlength then if length(fullparas)+commacount[i>0]+length(paramname)>maxlength then
begin begin
if i>0 then if i>0 then
@ -5958,7 +5990,7 @@ implementation
if AValue then if AValue then
include(implprocoptions,pio_empty) include(implprocoptions,pio_empty)
else else
include(implprocoptions,pio_empty); exclude(implprocoptions,pio_empty);
end; end;

40
compiler/symsym.pas
View File

@ -401,6 +401,7 @@ interface
constructor create_ptr(const n : string;t : tconsttyp;v : pointer;def:tdef);virtual; 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_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_wstring(const n : string;t : tconsttyp;pw:pcompilerwidestring);virtual;
constructor create_undefined(const n : string;def:tdef);virtual;
constructor ppuload(ppufile:tcompilerppufile); constructor ppuload(ppufile:tcompilerppufile);
destructor destroy;override; destructor destroy;override;
procedure buildderef;override; procedure buildderef;override;
@ -491,6 +492,8 @@ interface
procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);inline; procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);inline;
procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring;filepos:tfileposinfo); procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring;filepos:tfileposinfo);
function same_constvalue(consttyp:tconsttyp;const value1,value2:tconstvalue):boolean;
implementation implementation
uses uses
@ -528,6 +531,30 @@ implementation
end; end;
function same_constvalue(consttyp:tconsttyp;const value1,value2:tconstvalue):boolean;
begin
case consttyp of
constnone,
constnil:
result:=true;
constord:
result:=value1.valueord=value2.valueord;
constpointer:
result:=value1.valueordptr=value2.valueordptr;
conststring,
constreal,
constset,
constresourcestring,
constwstring,
constguid: begin
if value1.len<>value2.len then
exit(false);
result:=CompareByte(value1.valueptr^,value2.valueptr^,value1.len)=0;
end;
end;
end;
procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring); procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);
begin begin
check_hints(srsym,symoptions,deprecatedmsg,current_filepos); check_hints(srsym,symoptions,deprecatedmsg,current_filepos);
@ -1618,7 +1645,6 @@ implementation
tparasymtable(parast).ppuwrite(ppufile); tparasymtable(parast).ppuwrite(ppufile);
end; end;
{**************************************************************************** {****************************************************************************
TABSTRACTVARSYM TABSTRACTVARSYM
****************************************************************************} ****************************************************************************}
@ -2426,6 +2452,15 @@ implementation
end; 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); constructor tconstsym.ppuload(ppufile:tcompilerppufile);
var var
pd : pbestreal; pd : pbestreal;
@ -2509,8 +2544,7 @@ implementation
destructor tconstsym.destroy; destructor tconstsym.destroy;
begin begin
case consttyp of case consttyp of
constnone: constnone,
internalerror(2019050703);
constord, constord,
constpointer, constpointer,
constnil: constnil:

7
compiler/systems.pas
View File

@ -1147,7 +1147,14 @@ begin
{$endif riscv64} {$endif riscv64}
{$ifdef xtensa} {$ifdef xtensa}
{$ifdef linux}
{$define default_target_set}
default_target(system_xtensa_linux);
{$endif}
{$ifndef default_target_set}
default_target(system_xtensa_embedded); default_target(system_xtensa_embedded);
{$endif ndef default_target_set}
{$endif xtensa} {$endif xtensa}
end; end;

11
compiler/utils/ppuutils/ppudump.pp
View File

@ -1687,7 +1687,8 @@ const
(mask:sp_generic_para; str:'Generic Parameter'), (mask:sp_generic_para; str:'Generic Parameter'),
(mask:sp_has_deprecated_msg; str:'Has Deprecated Message'), (mask:sp_has_deprecated_msg; str:'Has Deprecated Message'),
(mask:sp_generic_dummy; str:'Generic Dummy'), (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 var
symoptions : tsymoptions; symoptions : tsymoptions;
@ -2743,7 +2744,8 @@ const
(mask:df_not_registered_no_free; str:'Unregistered/No free (invalid)'), (mask:df_not_registered_no_free; str:'Unregistered/No free (invalid)'),
(mask:df_llvm_no_struct_packing; str:'LLVM unpacked struct'), (mask:df_llvm_no_struct_packing; str:'LLVM unpacked struct'),
(mask:df_internal; str:'Internal'), (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=( defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=(
(mask:ds_vmt_written; str:'VMT Written'), (mask:ds_vmt_written; str:'VMT Written'),
@ -3267,14 +3269,15 @@ const
{ ado_IsArrayOfConst } 'ArrayOfConst', { ado_IsArrayOfConst } 'ArrayOfConst',
{ ado_IsConstString } 'ConstString', { ado_IsConstString } 'ConstString',
{ ado_IsBitPacked } 'BitPacked', { ado_IsBitPacked } 'BitPacked',
{ ado_IsVector } 'Vector' { ado_IsVector } 'Vector',
{ ado_IsGeneric } 'Generic'
); );
var var
symoptions: tarraydefoptions; symoptions: tarraydefoptions;
i: tarraydefoption; i: tarraydefoption;
first: boolean; first: boolean;
begin begin
ppufile.getset(tppuset1(symoptions)); ppufile.getset(tppuset2(symoptions));
if symoptions<>[] then if symoptions<>[] then
begin begin
if ado_IsDynamicArray in symoptions then Include(ArrayDef.Options, aoDynamic); if ado_IsDynamicArray in symoptions then Include(ArrayDef.Options, aoDynamic);

3
compiler/version.pas
View File

@ -80,6 +80,9 @@ interface
{$ifdef cpuriscv32} {$ifdef cpuriscv32}
source_cpu_string = 'riscv32'; source_cpu_string = 'riscv32';
{$endif cpuriscv32} {$endif cpuriscv32}
{$ifdef cpuxtensa}
source_cpu_string = 'xtensa';
{$endif cpuxtensa}
function version_string:string; function version_string:string;
function full_version_string:string; function full_version_string:string;

2
compiler/xtensa/agcpugas.pas
View File

@ -173,7 +173,7 @@ unit agcpugas;
idtxt : 'AS'; idtxt : 'AS';
asmbin : 'as'; asmbin : 'as';
asmcmd : '-o $OBJ $EXTRAOPT $ASM --longcalls'; asmcmd : '-o $OBJ $EXTRAOPT $ASM --longcalls';
supported_targets : [system_xtensa_embedded]; supported_targets : [system_xtensa_embedded,system_xtensa_linux,system_xtensa_freertos];
flags : [af_needar,af_smartlink_sections,af_supports_dwarf,af_stabs_use_function_absolute_addresses]; flags : [af_needar,af_smartlink_sections,af_supports_dwarf,af_stabs_use_function_absolute_addresses];
labelprefix : '.L'; labelprefix : '.L';
labelmaxlen : -1; labelmaxlen : -1;

9
packages/fcl-passrc/src/pasresolver.pp
View File

@ -431,7 +431,8 @@ const
btArrayRangeTypes = btAllChars+btAllBooleans+btAllInteger; btArrayRangeTypes = btAllChars+btAllBooleans+btAllInteger;
btAllRanges = btArrayRangeTypes+[btRange]; btAllRanges = btArrayRangeTypes+[btRange];
btAllWithSubType = [btSet, btArrayLit, btArrayOrSet, btRange]; btAllWithSubType = [btSet, btArrayLit, btArrayOrSet, btRange];
btAllStandardTypes = [ btAllIntrinsicTypes = btAllInteger+btAllStringAndChars+btAllFloats+btAllBooleans;
btAllFPCTypes = [
btChar, btChar,
{$ifdef FPC_HAS_CPSTRING} {$ifdef FPC_HAS_CPSTRING}
btAnsiChar, btAnsiChar,
@ -2080,7 +2081,7 @@ type
// built in types and functions // built in types and functions
procedure ClearBuiltInIdentifiers; virtual; procedure ClearBuiltInIdentifiers; virtual;
procedure AddObjFPCBuiltInIdentifiers( procedure AddObjFPCBuiltInIdentifiers(
const TheBaseTypes: TResolveBaseTypes = btAllStandardTypes; const TheBaseTypes: TResolveBaseTypes = btAllFPCTypes;
const TheBaseProcs: TResolverBuiltInProcs = bfAllStandardProcs); virtual; const TheBaseProcs: TResolverBuiltInProcs = bfAllStandardProcs); virtual;
function AddBaseType(const aName: string; Typ: TResolverBaseType): TResElDataBaseType; function AddBaseType(const aName: string; Typ: TResolverBaseType): TResElDataBaseType;
function AddCustomBaseType(const aName: string; aClass: TResElDataBaseTypeClass): TPasUnresolvedSymbolRef; function AddCustomBaseType(const aName: string; aClass: TResElDataBaseTypeClass): TPasUnresolvedSymbolRef;
@ -10435,7 +10436,7 @@ begin
end; end;
end; end;
// default: search for type helpers // default: search for type helpers
if (LeftResolved.BaseType in btAllStandardTypes) if (LeftResolved.BaseType in btAllIntrinsicTypes)
or (LeftResolved.BaseType=btContext) or (LeftResolved.BaseType=btContext)
or (LeftResolved.BaseType=btCustom) then or (LeftResolved.BaseType=btCustom) then
begin begin
@ -22038,7 +22039,7 @@ begin
if LoType=nil then if LoType=nil then
RaiseMsg(20170216152004,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot, RaiseMsg(20170216152004,nExprTypeMustBeClassOrRecordTypeGot,sExprTypeMustBeClassOrRecordTypeGot,
[BaseTypeNames[ExprResolved.BaseType]],ErrorEl); [BaseTypeNames[ExprResolved.BaseType]],ErrorEl);
if (ExprResolved.BaseType in btAllStandardTypes) then if (ExprResolved.BaseType in btAllIntrinsicTypes) then
// ok // ok
else if (ExprResolved.BaseType=btContext) then else if (ExprResolved.BaseType=btContext) then
// ok // ok

4
packages/libffi/src/ffi.pp
View File

@ -272,8 +272,8 @@ const
FFI_TRAMPOLINE_SIZE = 20; FFI_TRAMPOLINE_SIZE = 20;
{$elseif defined(CPUMIPS64)} {$elseif defined(CPUMIPS64)}
FFI_TRAMPOLINE_SIZE = 56; FFI_TRAMPOLINE_SIZE = 56;
#endif {$elseif defined(CPUXTENSA)}
FFI_TRAMPOLINE_SIZE = 24;
{$endif} {$endif}
{ {

2
packages/os4units/src/clipboard.pas
View File

@ -13,7 +13,7 @@
**********************************************************************} **********************************************************************}
unit clipboard; unit clipboard;
{$PACKRECORDS 2}
interface interface
uses uses

43
packages/pastojs/src/fppas2js.pp
View File

@ -15106,42 +15106,39 @@ begin
ClassPath:=CreateReferencePath(ProcScope.ClassRecScope.Element,AContext,rpkPathAndName); ClassPath:=CreateReferencePath(ProcScope.ClassRecScope.Element,AContext,rpkPathAndName);
Call.AddArg(CreatePrimitiveDotExpr(ClassPath,PosEl)); Call.AddArg(CreatePrimitiveDotExpr(ClassPath,PosEl));
end; end;
if (ImplProc.Body.Functions.Count>0)
or aResolver.HasAnonymousFunctions(ImplProc.Body.Body) then
begin
// has nested procs -> add "var self = this;"
FuncContext.AddLocalVar(GetBIName(pbivnSelf),ThisPas);
SelfSt:=CreateVarStatement(GetBIName(pbivnSelf),
CreatePrimitiveDotExpr('this',ImplProc),ImplProc);
AddBodyStatement(SelfSt,PosEl);
if ImplProcScope.SelfArg<>nil then
begin
// redirect Pascal-Self to JS-Self
FuncContext.AddLocalVar(GetBIName(pbivnSelf),ImplProcScope.SelfArg);
end;
end
else if ImplProcScope.SelfArg<>nil then
begin
// no nested procs -> redirect Pascal-Self to JS-this
FuncContext.AddLocalVar('this',ImplProcScope.SelfArg);
end;
end end
else else
begin begin
// no "this" // "this" has no direct Pascal element
if ProcScope.ClassRecScope<>nil then if ProcScope.ClassRecScope<>nil then
begin begin
// static method -> hide local // static method
ClassOrRec:=ProcScope.ClassRecScope.Element; ClassOrRec:=ProcScope.ClassRecScope.Element;
LocalVar:=FuncContext.FindLocalIdentifier(ClassOrRec); LocalVar:=FuncContext.FindLocalIdentifier(ClassOrRec);
if (LocalVar<>nil) and (LocalVar.Name='this') then if (LocalVar<>nil) and (LocalVar.Name='this') then
// "this" is not the class -> hide it (absolute path will be used)
FuncContext.AddLocalVar(LocalVarHide,ClassOrRec); FuncContext.AddLocalVar(LocalVarHide,ClassOrRec);
end; end;
end;
if (ImplProc.Body.Functions.Count>0)
or aResolver.HasAnonymousFunctions(ImplProc.Body.Body) then
begin
// has nested procs -> add "var $Self = this;"
if ThisPas<>nil then
FuncContext.AddLocalVar(GetBIName(pbivnSelf),ThisPas);
SelfSt:=CreateVarStatement(GetBIName(pbivnSelf),
CreatePrimitiveDotExpr('this',ImplProc),ImplProc);
AddBodyStatement(SelfSt,PosEl);
if ImplProcScope.SelfArg<>nil then if ImplProcScope.SelfArg<>nil then
begin begin
// no nested procs -> redirect Pascal-Self to JS-this // redirect Pascal-Self to JS-Self
FuncContext.AddLocalVar('this',ImplProcScope.SelfArg); FuncContext.AddLocalVar(GetBIName(pbivnSelf),ImplProcScope.SelfArg);
end; end;
end
else if ImplProcScope.SelfArg<>nil then
begin
// no nested procs -> redirect Pascal-Self to JS-this
FuncContext.AddLocalVar('this',ImplProcScope.SelfArg);
end; end;
end; end;
{$IFDEF VerbosePas2JS} {$IFDEF VerbosePas2JS}

133
packages/pastojs/tests/tcmodules.pas
View File

@ -702,12 +702,14 @@ type
Procedure TestTypeHelper_Constructor; Procedure TestTypeHelper_Constructor;
Procedure TestTypeHelper_Word; Procedure TestTypeHelper_Word;
Procedure TestTypeHelper_Double; Procedure TestTypeHelper_Double;
Procedure TestTypeHelper_NativeInt;
Procedure TestTypeHelper_StringChar; Procedure TestTypeHelper_StringChar;
Procedure TestTypeHelper_JSValue; Procedure TestTypeHelper_JSValue;
Procedure TestTypeHelper_Array; Procedure TestTypeHelper_Array;
Procedure TestTypeHelper_EnumType; Procedure TestTypeHelper_EnumType;
Procedure TestTypeHelper_SetType; Procedure TestTypeHelper_SetType;
Procedure TestTypeHelper_InterfaceType; Procedure TestTypeHelper_InterfaceType;
Procedure TestTypeHelper_NestedSelf;
// proc types // proc types
Procedure TestProcType; Procedure TestProcType;
@ -24090,6 +24092,99 @@ begin
''])); '']));
end; end;
procedure TTestModule.TestTypeHelper_NativeInt;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' MaxInt = type nativeint;',
' THelperI = type helper for MaxInt',
' function ToStr: String;',
' end;',
' MaxUInt = type nativeuint;',
' THelperU = type helper for MaxUInt',
' function ToStr: String;',
' end;',
'function THelperI.ToStr: String;',
'begin',
' Result:=str(Self);',
'end;',
'function THelperU.ToStr: String;',
'begin',
' Result:=str(Self);',
'end;',
'procedure DoIt(s: string);',
'begin',
'end;',
'var i: MaxInt;',
'begin',
' DoIt(i.toStr);',
' DoIt(i.toStr());',
' (i*i).toStr;',
' DoIt((i*i).toStr);',
'']);
ConvertProgram;
CheckSource('TestTypeHelper_NativeInt',
LinesToStr([ // statements
'rtl.createHelper($mod, "THelperI", null, function () {',
' this.ToStr = function () {',
' var Result = "";',
' Result = "" + this.get();',
' return Result;',
' };',
'});',
'rtl.createHelper($mod, "THelperU", null, function () {',
' this.ToStr = function () {',
' var Result = "";',
' Result = "" + this.get();',
' return Result;',
' };',
'});',
'this.DoIt = function (s) {',
'};',
'this.i = 0;',
'']),
LinesToStr([ // $mod.$main
'$mod.DoIt($mod.THelperI.ToStr.call({',
' p: $mod,',
' get: function () {',
' return this.p.i;',
' },',
' set: function (v) {',
' this.p.i = v;',
' }',
'}));',
'$mod.DoIt($mod.THelperI.ToStr.call({',
' p: $mod,',
' get: function () {',
' return this.p.i;',
' },',
' set: function (v) {',
' this.p.i = v;',
' }',
'}));',
'$mod.THelperI.ToStr.call({',
' a: $mod.i * $mod.i,',
' get: function () {',
' return this.a;',
' },',
' set: function (v) {',
' rtl.raiseE("EPropReadOnly");',
' }',
'});',
'$mod.DoIt($mod.THelperI.ToStr.call({',
' a: $mod.i * $mod.i,',
' get: function () {',
' return this.a;',
' },',
' set: function (v) {',
' rtl.raiseE("EPropReadOnly");',
' }',
'}));',
'']));
end;
procedure TTestModule.TestTypeHelper_StringChar; procedure TTestModule.TestTypeHelper_StringChar;
begin begin
StartProgram(false); StartProgram(false);
@ -24597,6 +24692,44 @@ begin
''])); '']));
end; end;
procedure TTestModule.TestTypeHelper_NestedSelf;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' THelper = type helper for string',
' procedure Run(Value: string);',
' end;',
'procedure THelper.Run(Value: string);',
' function Sub(i: nativeint): boolean;',
' begin',
' Result:=Self[i+1]=Value[i];',
' end;',
'begin',
' if Self[3]=Value[4] then ;',
'end;',
'begin',
'']);
ConvertProgram;
CheckSource('TestTypeHelper_NestedSelf',
LinesToStr([ // statements
'rtl.createHelper($mod, "THelper", null, function () {',
' this.Run = function (Value) {',
' var $Self = this;',
' function Sub(i) {',
' var Result = false;',
' Result = $Self.get().charAt((i + 1) - 1) === Value.charAt(i - 1);',
' return Result;',
' };',
' if ($Self.get().charAt(2) === Value.charAt(3)) ;',
' };',
'});',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestModule.TestProcType; procedure TTestModule.TestProcType;
begin begin
StartProgram(false); StartProgram(false);

12
packages/rtl-console/src/amicommon/video.pp
View File

@ -584,11 +584,11 @@ begin
SmallForce or ForceCursorUpdate then SmallForce or ForceCursorUpdate then
begin begin
{$ifdef WITHBUFFERING} {$ifdef WITHBUFFERING}
DrawChar(BufRp, OldCursorY, OldCursorX, crHidden); DrawChar(BufRp, OldCursorX, OldCursorY, crHidden);
if CursorState then DrawChar(BufRp, CursorY, CursorX, CursorType); if CursorState then DrawChar(BufRp, CursorX, CursorY, CursorType);
{$else} {$else}
DrawChar(VideoWindow^.RPort, OldCursorY, OldCursorX, crHidden); DrawChar(VideoWindow^.RPort, OldCursorX, OldCursorY, crHidden);
if CursorState then DrawChar(VideoWindow^.RPort, CursorY, CursorX, CursorType); if CursorState then DrawChar(VideoWindow^.RPort, CursorX, CursorY, CursorType);
{$endif} {$endif}
OldCursorX := CursorX; OldCursorX := CursorX;
OldCursorY := CursorY; OldCursorY := CursorY;
@ -602,8 +602,8 @@ end;
procedure SysSetCursorPos(NewCursorX, NewCursorY: Word); procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
begin begin
CursorX := NewCursorY; CursorX := NewCursorX;
CursorY := NewCursorX; CursorY := NewCursorY;
SysUpdateScreen(False); SysUpdateScreen(False);
end; end;

2
packages/rtl-extra/src/linux/unixsock.inc
View File

@ -13,7 +13,7 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
} }
{$if not defined(cpux86_64) and not defined(cpuaarch64) and not defined(cpuriscv32) and not defined(cpuriscv64) and not defined(NO_SYSCALL_SOCKETCALL)} {$if not defined(cpux86_64) and not defined(cpuaarch64) and not defined(cpuriscv32) and not defined(cpuriscv64) and not defined(cpuxtensa) and not defined(NO_SYSCALL_SOCKETCALL)}
{$define NEED_SOCKETCALL} {$define NEED_SOCKETCALL}
{$endif} {$endif}

4
packages/rtl-extra/src/unix/ipc.pp
View File

@ -546,7 +546,7 @@ type
msg_lrpid : ipc_pid_t; msg_lrpid : ipc_pid_t;
pad1 : qword; pad1 : qword;
pad2 : qword; pad2 : qword;
{$ENDIF} {$ENDIF}
end; end;
{$else} {$else}
{$if defined(Darwin)} {$if defined(Darwin)}
@ -888,7 +888,7 @@ uses Syscall;
{$ifndef FPC_USE_LIBC} {$ifndef FPC_USE_LIBC}
{$if defined(Linux)} {$if defined(Linux)}
{$if defined(cpux86_64) or defined(cpuaarch64) or defined(cpuriscv32) or defined(cpuriscv64) or defined(NO_SYSCALL_IPC)} {$if defined(cpux86_64) or defined(cpuaarch64) or defined(cpuriscv32) or defined(cpuriscv64) or defined(cpuxtensa) or defined(NO_SYSCALL_IPC)}
{$i ipcsys.inc} {$i ipcsys.inc}
{$else} {$else}
{$i ipccall.inc} {$i ipccall.inc}

5
rtl/xtensa/setjump.inc
View File

@ -14,13 +14,12 @@
**********************************************************************} **********************************************************************}
function fpc_setjmp(var S : jmp_buf) : longint;assembler;[Public, alias : 'FPC_SETJMP'];nostackframe; compilerproc; function fpc_setjmp(var S : jmp_buf) : longint;assembler;[Public, alias : 'FPC_SETJMP']; compilerproc;
asm asm
movi a2,0
end; end;
procedure fpc_longjmp(var S : jmp_buf;value : longint);assembler;[Public, alias : 'FPC_LONGJMP']; compilerproc; procedure fpc_longjmp(var S : jmp_buf;value : longint);assembler;[Public, alias : 'FPC_LONGJMP']; compilerproc;
asm asm
end; end;

39
tests/test/tgenconst1.pp Normal file
View File

@ -0,0 +1,39 @@
{ %NORUN }
{$mode objfpc}
{
test all possible constants
}
program tgenconst1;
type
TEnums = (Blaise, Pascal);
kNames = set of TEnums;
kChars = set of char;
type
generic TBoolean<const U: boolean> = record end;
generic TString<const U: string> = record end;
generic TFloat<const U: single> = record end;
generic TInteger<const U: integer> = record end;
generic TChar<const U: char> = record end;
generic TByte<const U: byte> = record end;
generic TQWord<const U: QWord> = record end;
generic TEnum<const U: TEnums> = record end;
generic TNames<const U: kNames> = record end;
generic TChars<const U: kChars> = record end;
generic TPointer<const U: pointer> = record end;
var
a: specialize TBoolean<true>;
b: specialize TString<'string'>;
c: specialize TFloat<1>;
d: specialize TInteger<10>;
e: specialize TByte<255>;
f: specialize TChar<'a'>;
g: specialize TEnum<Pascal>;
h: specialize TNames<[Blaise,Pascal]>;
i: specialize TChars<['a','b']>;
j: specialize TQWord<10>;
k: specialize TPointer<nil>;
begin
end.

14
tests/test/tgenconst10.pp Normal file
View File

@ -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.

13
tests/test/tgenconst11.pp Normal file
View File

@ -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

15
tests/test/tgenconst12.pp Normal file
View File

@ -0,0 +1,15 @@
{ %NORUN }
{$mode objfpc}
{
test def compare with specialized types
}
program tgenconst12;
type
generic TTest<const U: integer> = class
end;
type
ATest = specialize TTest<100>;
begin
end.

51
tests/test/tgenconst13.pp Normal file
View File

@ -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.

42
tests/test/tgenconst14.pp Normal file
View File

@ -0,0 +1,42 @@
{$mode objfpc}
{$modeswitch advancedrecords}
{
test binary operators with generic constant params
}
program tgenconst14;
type
generic TBinaryOp<const I: Integer> = record
const
d0 = I + I;
d1 = I - I;
d2 = I * I;
d3 = I / I;
d4 = I div I;
d5 = I mod I;
d6 = I and I;
d7 = I or I;
d8 = I shl 2;
d9 = I shr 2;
end;
procedure Check(aExpected, aActual: Integer; aErrorCode: LongInt);
begin
if aExpected <> aActual then
Halt(aErrorCode);
end;
var
op: specialize TBinaryOp<100>;
begin
Check(op.d0, 100 + 100, 1);
Check(op.d1, 100 - 100, 2);
Check(op.d2, 100 * 100, 3);
Check(Trunc(op.d3), Trunc(100 / 100), 4);
Check(op.d4, 100 div 100, 5);
Check(op.d5, 100 mod 100, 6);
Check(op.d6, 100 and 100, 7);
Check(op.d7, 100 or 100, 8);
Check(op.d8, 100 shl 2, 9);
Check(op.d9, 100 shr 2, 10);
end.

15
tests/test/tgenconst15.pp Normal file
View File

@ -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.

79
tests/test/tgenconst16.pp Normal file
View File

@ -0,0 +1,79 @@
{ %NORUN }
{$mode objfpc}
{$modeswitch advancedrecords}
{
various operator tests
}
program tgenconst16;
type
Day = (mon,tue,wed,thu,fri,sat,sun);
Days = set of Day;
generic TSet<const I: Days> = record
const
d0 = I + I; // Union
d1 = I - I; // Difference
d2 = I * I; // Intersection
d3 = I >< I; // Symmetric difference
d4 = I <= I; // Contains
d5 = mon in I;
end;
generic TArray<const I: integer> = record
type
t0 = array[0..I - 1] of integer;
t1 = array[0..high(I)] of integer;
t2 = array[0..low(I)] of integer;
t3 = array[0..sizeof(I)] of integer;
public
d0: array[0..I - 1] of integer;
d1: array[0..high(I)] of integer;
d2: array[0..low(I)] of integer;
d3: array[0..sizeof(I)] of integer;
end;
generic TUnaryOp<const I: integer> = record
const
d0 = -I;
d1 = +I;
d2 = not I;
end;
generic TBinaryOp<const I: integer> = record
const
// Arithmetic operators
// https://freepascal.org/docs-html/ref/refsu45.html
d0 = I + I;
d1 = I - I;
d2 = I * I;
d3 = I / I;
d4 = I div I;
d5 = I mod I;
// Boolean operators
// https://freepascal.org/docs-html/ref/refsu47.html
d6 = I and I;
d7 = I or I;
d8 = I xor I;
// Logical operators
// https://freepascal.org/docs-html/ref/refsu46.html
d9 = I shl I;
d10 = I shr I;
d11 = I << I;
d12 = I >> I;
// Relational operators
// https://freepascal.org/docs-html/ref/refsu50.html#x153-17500012.8.6
d13 = I <> I;
d14 = I < I;
d15 = I > I;
d16 = I <= I;
d17 = I >= I;
d18 = I = I;
end;
generic TOther<const I: integer> = record
procedure DoThis(param: integer = I);
end;
procedure TOther.DoThis(param: integer = I);
begin
writeln(param, ' default:', I);
end;
begin
end.

27
tests/test/tgenconst17.pp Normal file
View File

@ -0,0 +1,27 @@
{ %NORUN }
{$mode objfpc}
{$modeswitch advancedrecords}
{
testing range checking for arrays and for-loops
}
program tgenconst17;
type
generic TStaticList<T; const Length: SizeUInt> = record
Values: array[0..Length - 1] of T;
procedure Display;
end;
procedure TStaticList.Display;
var
I, n: SizeUInt;
begin
for I := 0 to Length - 1 do
WriteLn(Values[I]);
end;
var
list: specialize TStaticList<Integer, 20>;
begin
end.

12
tests/test/tgenconst18.pp Normal file
View File

@ -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.

24
tests/test/tgenconst19.pp Normal file
View File

@ -0,0 +1,24 @@
{ %NORUN }
unit tgenconst19;
{$mode objfpc}
interface
generic procedure Test<const A, B: LongInt>;
generic procedure Test2<const A, B: LongInt>;
implementation
{ currently it does not matter whether , or ; is used in the definition (Delphi
compatible) }
generic procedure Test<A, B>;
begin
end;
generic procedure Test2<A; B>;
begin
end;
end.

14
tests/test/tgenconst2.pp Normal file
View File

@ -0,0 +1,14 @@
{ %NORUN }
{$mode objfpc}
{
test lists of types/contants
}
program tgenconst2;
type
generic TMoreThanOne<T1,T2;const U1,U2:integer> = record end;
var
a: specialize TMoreThanOne<integer,string,10,10>;
begin
end.

24
tests/test/tgenconst20.pp Normal file
View File

@ -0,0 +1,24 @@
{ %NORUN }
unit tgenconst20;
{$mode delphi}
interface
procedure Test<const A, B: LongInt>;
procedure Test2<const A, B: LongInt>;
implementation
{ currently it does not matter whether , or ; is used in the definition (Delphi
compatible) }
procedure Test<A, B>;
begin
end;
procedure Test2<A; B>;
begin
end;
end.

16
tests/test/tgenconst21.pp Normal file
View File

@ -0,0 +1,16 @@
unit tgenconst21;
{$mode objfpc}
interface
implementation
generic procedure Test<A; const N: LongInt>; forward;
generic procedure Test<A; const N: LongInt>;
begin
end;
end.

16
tests/test/tgenconst22.pp Normal file
View File

@ -0,0 +1,16 @@
unit tgenconst22;
{$mode delphi}
interface
implementation
procedure Test<A; const N: LongInt>; forward;
procedure Test<A; const N: LongInt>;
begin
end;
end.

19
tests/test/tgenconst23.pp Normal file
View File

@ -0,0 +1,19 @@
{ %FAIL }
unit tgenconst23;
{$mode objfpc}
interface
implementation
generic procedure Test<A; const N: LongInt>; forward;
generic procedure Test<A; const N: String>;
begin
end;
end.

19
tests/test/tgenconst24.pp Normal file
View File

@ -0,0 +1,19 @@
{ %FAIL }
unit tgenconst24;
{$mode delphi}
interface
implementation
procedure Test<A; const N: LongInt>; forward;
procedure Test<A; const N: String>;
begin
end;
end.

18
tests/test/tgenconst25.pp Normal file
View File

@ -0,0 +1,18 @@
{ %FAIL }
unit tgenconst25;
{$mode objfpc}
interface
implementation
generic procedure Test<A; const N: LongInt>; forward;
generic procedure Test<A; N>;
begin
end;
end.

18
tests/test/tgenconst26.pp Normal file
View File

@ -0,0 +1,18 @@
{ %FAIL }
unit tgenconst26;
{$mode delphi}
interface
implementation
procedure Test<A; const N: LongInt>; forward;
procedure Test<A; N>;
begin
end;
end.

17
tests/test/tgenconst27.pp Normal file
View File

@ -0,0 +1,17 @@
{ %FAIL }
unit tgenconst27;
{$mode objfpc}
interface
generic procedure Test<const A: LongInt>;
implementation
generic procedure Test<const A: LongInt>;
begin
end;
end.

17
tests/test/tgenconst28.pp Normal file
View File

@ -0,0 +1,17 @@
{ %FAIL }
unit tgenconst28;
{$mode delphi}
interface
procedure Test<const A: LongInt>;
implementation
procedure Test<const A: LongInt>;
begin
end;
end.

14
tests/test/tgenconst29.pp Normal file
View File

@ -0,0 +1,14 @@
{ %NORUN }
program tgenconst29;
{$mode objfpc}
type
TRange = 3..4;
generic TTest<const U: TRange> = record end;
var
t: specialize TTest<3>;
begin
end.

20
tests/test/tgenconst3.pp Normal file
View File

@ -0,0 +1,20 @@
{ %NORUN }
{$mode objfpc}
{$modeswitch advancedrecords}
{
test integer constants in static array ranges
}
program tgenconst3;
type
generic TList<T;const U:integer> = record
const
max = U;
public
m_list: array[0..max-1] of T;
end;
var
list: specialize TList<integer,128>;
begin
end.

14
tests/test/tgenconst30.pp Normal file
View File

@ -0,0 +1,14 @@
{ %FAIL }
program tgenconst30;
{$mode objfpc}
type
TRange = 3..4;
generic TTest<const U: TRange> = record end;
var
t: specialize TTest<2>;
begin
end.

15
tests/test/tgenconst4.pp Normal file
View File

@ -0,0 +1,15 @@
{ %NORUN }
{$mode objfpc}
{
test constants in generic procedures
}
program tgenconst4;
generic procedure DoThis<T;const U:string>(msg: string = U);
begin
writeln(msg, ' sizeof:',sizeof(t), ' default: ', U);
end;
begin
specialize DoThis<integer,'genparam'>('hello world');
end.

28
tests/test/tgenconst5.pp Normal file
View File

@ -0,0 +1,28 @@
{ %NORUN }
{$mode objfpc}
{
test nested generic records with constants
}
program tgenconst5;
type
generic THelperA<const U:integer> = record
list: array[0..U-1] of byte;
end;
type
generic THelperB<T> = record
value: T;
end;
type
generic TList<T; const U:integer> = record
helperA: specialize THelperA<U>;
helperB: specialize THelperB<T>;
end;
var
list: specialize TList<integer,32>;
begin
writeln('sizeof:',sizeof(list));
end.

25
tests/test/tgenconst6.pp Normal file
View File

@ -0,0 +1,25 @@
{ %NORUN }
{$mode delphi}
{
test delphi mode
}
program tgenconst6;
type
TList<T; const U: integer> = class
list: array[0..U-1] of T;
function capacity: integer;
end;
function TList<T; U>.capacity: integer;
begin
result := U;
end;
var
nums:TList<integer,16>;
strs:TList<string,16>;
begin
nums := TList<integer,16>.Create;
strs := TList<string,16>.Create;
end.

14
tests/test/tgenconst7.pp Normal file
View File

@ -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.

14
tests/test/tgenconst8.pp Normal file
View File

@ -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.

12
tests/test/tgenconst9.pp Normal file
View File

@ -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.

10
tests/webtbf/tw36975.pp Normal file
View File

@ -0,0 +1,10 @@
{ %FAIL }
program tw36975;
{$mode objfpc}{$H+}
type
generic TTest <T,const N:Tintegerarray> = class
end;
begin
end.