paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 19:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged revision(s) 44172, 44188, 45457 - 45458, 45645, 46218, 46953 from trunk:

Browse Source 
r46953
* fix for Mantis #37806: allow undefineddefs for Include() and Exclude() + added tests
---------------------
r46218
* fix for Mantis #37187: inside generics the constant code in pexpr does not handle all cases and thus current_procinfo needs to be checked as well + added test
---------------------
r45645
* correctly set the generic related defoptions for an outlined procdef
---------------------
r45458
  * make more use of is_typeparam
---------------------
r45457
  * constrained type parameters are not undefined defs, resolves #37107
---------------------
r44188
* keep track of the fileposinfo for generic constraints
---------------------
r44172
* only resolve a dummy symbol if it is a type symbol (thus truly a dummy symbol) + added tests
---------------------

git-svn-id: branches/fixes_3_2@47802 -
This commit is contained in:
svenbarth 2020-12-17 21:31:16 +00:00
parent b9fe6b9612
commit e6ad8a0dfa
13 changed files with 275 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored
View File

@ -12930,8 +12930,11 @@ tests/tbs/tb0659g.pp svneol=native#text/pascal
tests/tbs/tb0665.pp svneol=native#text/pascal
tests/tbs/tb0666a.pp svneol=native#text/pascal
tests/tbs/tb0666b.pp svneol=native#text/pascal
tests/tbs/tb0668a.pp svneol=native#text/pascal
tests/tbs/tb0668b.pp svneol=native#text/pascal
tests/tbs/tb0669.pp svneol=native#text/pascal
tests/tbs/tb0676.pp svneol=native#text/pascal
tests/tbs/tb0677.pp svneol=native#text/pascal
tests/tbs/tb0678.pp svneol=native#text/pascal
tests/tbs/tb205.pp svneol=native#text/plain
tests/tbs/tb610.pp svneol=native#text/pascal
@ -17770,7 +17773,9 @@ tests/webtbs/tw3708.pp svneol=native#text/plain
tests/webtbs/tw37085.pp svneol=native#text/pascal
tests/webtbs/tw37095.pp svneol=native#text/plain
tests/webtbs/tw37095d/uw37095.pp svneol=native#text/plain
tests/webtbs/tw37107.pp svneol=native#text/pascal
tests/webtbs/tw37154.pp svneol=native#text/pascal
tests/webtbs/tw37187.pp svneol=native#text/pascal
tests/webtbs/tw3719.pp svneol=native#text/plain
tests/webtbs/tw3721.pp svneol=native#text/plain
tests/webtbs/tw37218.pp svneol=native#text/pascal
@ -17792,6 +17797,7 @@ tests/webtbs/tw3774.pp svneol=native#text/plain
tests/webtbs/tw3777.pp svneol=native#text/plain
tests/webtbs/tw3778.pp svneol=native#text/plain
tests/webtbs/tw3780.pp svneol=native#text/plain
tests/webtbs/tw37806.pp svneol=native#text/pascal
tests/webtbs/tw3782.pp svneol=native#text/plain
tests/webtbs/tw37949.pp svneol=native#text/pascal
tests/webtbs/tw3796.pp svneol=native#text/plain

2
compiler/defutil.pas
View File

@ -1687,7 +1687,7 @@ implementation
function is_typeparam(def : tdef) : boolean;{$ifdef USEINLINE}inline;{$endif}
begin
result:=(def.typ=undefineddef);
result:=(def.typ=undefineddef) or (df_genconstraint in def.defoptions);
end;

224
compiler/ninl.pas
View File

@ -725,7 +725,7 @@ implementation
readfunctype:=nil;
{ can't read/write types }
if (para.left.nodetype=typen) and not(ttypenode(para.left).typedef.typ=undefineddef) then
if (para.left.nodetype=typen) and not(is_typeparam(ttypenode(para.left).typedef)) then
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
@ -742,126 +742,124 @@ implementation
if inlinenumber in [in_write_x,in_writeln_x] then
{ prefer strings to chararrays }
maybe_convert_to_string(para.left);
case para.left.resultdef.typ of
stringdef :
name:=procprefixes[do_read]+tstringdef(para.left.resultdef).stringtypname;
pointerdef :
begin
if (not is_pchar(para.left.resultdef)) or do_read then
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
else
name:=procprefixes[do_read]+'pchar_as_pointer';
end;
floatdef :
begin
is_real:=true;
if Tfloatdef(para.left.resultdef).floattype=s64currency then
name := procprefixes[do_read]+'currency'
else
begin
name := procprefixes[do_read]+'float';
readfunctype:=pbestrealtype^;
end;
{ iso pascal needs a different handler }
if (m_isolike_io in current_settings.modeswitches) and do_read then
name:=name+'_iso';
end;
enumdef:
begin
name:=procprefixes[do_read]+'enum';
readfunctype:=s32inttype;
end;
orddef :
begin
case Torddef(para.left.resultdef).ordtype of
s8bit,
s16bit,
s32bit,
s64bit,
u8bit,
u16bit,
u32bit,
u64bit:
if is_typeparam(para.left.resultdef) then
error_para:=true
else
case para.left.resultdef.typ of
stringdef :
name:=procprefixes[do_read]+tstringdef(para.left.resultdef).stringtypname;
pointerdef :
begin
if (not is_pchar(para.left.resultdef)) or do_read then
begin
get_read_write_int_func(para.left.resultdef,func_suffix,readfunctype);
name := procprefixes[do_read]+func_suffix;
if (m_isolike_io in current_settings.modeswitches) and do_read then
name:=name+'_iso';
end;
uchar :
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
else
name:=procprefixes[do_read]+'pchar_as_pointer';
end;
floatdef :
begin
is_real:=true;
if Tfloatdef(para.left.resultdef).floattype=s64currency then
name := procprefixes[do_read]+'currency'
else
begin
name := procprefixes[do_read]+'char';
{ iso pascal needs a different handler }
if (m_isolike_io in current_settings.modeswitches) and do_read then
name:=name+'_iso';
readfunctype:=cansichartype;
name := procprefixes[do_read]+'float';
readfunctype:=pbestrealtype^;
end;
uwidechar :
begin
name := procprefixes[do_read]+'widechar';
readfunctype:=cwidechartype;
end;
scurrency:
begin
name := procprefixes[do_read]+'currency';
{ iso pascal needs a different handler }
if (m_isolike_io in current_settings.modeswitches) and do_read then
name:=name+'_iso';
readfunctype:=s64currencytype;
is_real:=true;
end;
pasbool1,
pasbool8,
pasbool16,
pasbool32,
pasbool64,
bool8bit,
bool16bit,
bool32bit,
bool64bit:
if do_read then
{ iso pascal needs a different handler }
if (m_isolike_io in current_settings.modeswitches) and do_read then
name:=name+'_iso';
end;
enumdef:
begin
name:=procprefixes[do_read]+'enum';
readfunctype:=s32inttype;
end;
orddef :
begin
case Torddef(para.left.resultdef).ordtype of
s8bit,
s16bit,
s32bit,
s64bit,
u8bit,
u16bit,
u32bit,
u64bit:
begin
get_read_write_int_func(para.left.resultdef,func_suffix,readfunctype);
name := procprefixes[do_read]+func_suffix;
if (m_isolike_io in current_settings.modeswitches) and do_read then
name:=name+'_iso';
end;
uchar :
begin
name := procprefixes[do_read]+'char';
{ iso pascal needs a different handler }
if (m_isolike_io in current_settings.modeswitches) and do_read then
name:=name+'_iso';
readfunctype:=cansichartype;
end;
uwidechar :
begin
name := procprefixes[do_read]+'widechar';
readfunctype:=cwidechartype;
end;
scurrency:
begin
name := procprefixes[do_read]+'currency';
{ iso pascal needs a different handler }
if (m_isolike_io in current_settings.modeswitches) and do_read then
name:=name+'_iso';
readfunctype:=s64currencytype;
is_real:=true;
end;
pasbool1,
pasbool8,
pasbool16,
pasbool32,
pasbool64,
bool8bit,
bool16bit,
bool32bit,
bool64bit:
if do_read then
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
else
begin
name := procprefixes[do_read]+'boolean';
readfunctype:=pasbool1type;
end
else
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
else
begin
name := procprefixes[do_read]+'boolean';
readfunctype:=pasbool1type;
end
end;
end;
end;
variantdef :
name:=procprefixes[do_read]+'variant';
arraydef :
begin
if is_chararray(para.left.resultdef) then
name := procprefixes[do_read]+'pchar_as_array'
else
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end;
end
end;
end;
variantdef :
name:=procprefixes[do_read]+'variant';
arraydef :
begin
if is_chararray(para.left.resultdef) then
name := procprefixes[do_read]+'pchar_as_array'
else
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end
end;
{ generic parameter }
undefineddef:
{ don't try to generate any code for a writeln on a generic parameter }
error_para:=true;
else
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end;
end;
else
begin
CGMessagePos(para.fileinfo,type_e_cant_read_write_type);
error_para := true;
end;
end;
{ iso pascal needs a different handler }
if (m_isolike_io in current_settings.modeswitches) and not(do_read) then
@ -2919,9 +2917,11 @@ implementation
in_sizeof_x:
begin
{ the constant evaluation of in_sizeof_x happens in pexpr where possible }
{ the constant evaluation of in_sizeof_x happens in pexpr where possible,
though for generics it can reach here as well }
set_varstate(left,vs_read,[]);
if (left.resultdef.typ<>undefineddef) and
assigned(current_procinfo) and
paramanager.push_high_param(vs_value,left.resultdef,current_procinfo.procdef.proccalloption) then
begin
{ this should be an open array or array of const, both of
@ -3401,7 +3401,7 @@ implementation
inserttypeconv(tcallparanode(tcallparanode(left).right).left,
tsetdef(left.resultdef).elementdef);
end
else
else if left.resultdef.typ<>undefineddef then
CGMessage(type_e_mismatch);
end;
in_pack_x_y_z,

4
compiler/pexpr.pas
View File

@ -440,7 +440,7 @@ implementation
is_open_string(p1.resultdef)
)) or
{ keep the function call if it is a type parameter to avoid arithmetic errors due to constant folding }
(p1.resultdef.typ=undefineddef) then
is_typeparam(p1.resultdef) then
begin
statement_syssym:=geninlinenode(in_sizeof_x,false,p1);
{ no packed bit support for these things }
@ -2959,11 +2959,11 @@ implementation
wasgenericdummy:=false;
if assigned(srsym) and
(sp_generic_dummy in srsym.symoptions) and
(srsym.typ=typesym) and
(
(
(m_delphi in current_settings.modeswitches) and
not (token in [_LT, _LSHARPBRACKET]) and
(srsym.typ=typesym) and
(ttypesym(srsym).typedef.typ=undefineddef)
)
or

4
compiler/pgenutil.pas
View File

@ -1259,6 +1259,7 @@ uses
doconsume : boolean;
constraintdata : tgenericconstraintdata;
old_block_type : tblock_type;
fileinfo : tfileposinfo;
begin
result:=tfphashobjectlist.create(false);
firstidx:=0;
@ -1274,6 +1275,7 @@ uses
result.add(orgpattern,generictype);
end;
consume(_ID);
fileinfo:=current_tokenpos;
if try_to_consume(_COLON) then
begin
if not allowconstraints then
@ -1281,6 +1283,7 @@ uses
Message(parser_e_illegal_expression{ parser_e_generic_constraints_not_allowed_here});
{ construct a name which can be used for a type specification }
constraintdata:=tgenericconstraintdata.create;
constraintdata.fileinfo:=fileinfo;
defname:='';
str(current_module.deflist.count,defname);
defname:='$gendef'+defname;
@ -1395,6 +1398,7 @@ uses
genconstraintdata:=tgenericconstraintdata.create;
genconstraintdata.flags:=constraintdata.flags;
genconstraintdata.interfaces.assign(constraintdata.interfaces);
genconstraintdata.fileinfo:=constraintdata.fileinfo;
include(defoptions,df_genconstraint);
end;

4
compiler/procdefutil.pas
View File

@ -65,6 +65,10 @@ implementation
symtablestack:=nil;
result:=cprocdef.create(max(normal_function_level,st.symtablelevel)+1,true);
result.returndef:=resultdef;
{ if the parent is a generic or a specialization, the new function is one
as well }
if st.symtabletype=localsymtable then
result.defoptions:=result.defoptions+(tstoreddef(st.defowner).defoptions*[df_generic,df_specialization]);
symtablestack:=oldsymtablestack;
st.insertdef(result);
result.struct:=astruct;

2
compiler/symdef.pas
View File

@ -50,6 +50,8 @@ interface
interfaces : tfpobjectlist;
interfacesderef : tfplist;
flags : tgenericconstraintflags;
{ only required while parsing }
fileinfo : tfileposinfo;
constructor create;
destructor destroy;override;
procedure ppuload(ppufile:tcompilerppufile);

20
tests/tbs/tb0668a.pp Normal file
View File

@ -0,0 +1,20 @@
{ %NORUN }
program tb0668a;
{$mode objfpc}
procedure FreeAndNil(var Obj);
begin
end;
generic procedure FreeAndNil<T: class>(var Obj: T);
begin
end;
var
t: TObject;
begin
FreeAndNil(t);
specialize FreeAndNil<TObject>(t);
end.

20
tests/tbs/tb0668b.pp Normal file
View File

@ -0,0 +1,20 @@
{ %NORUN }
program tb0668b;
{$mode objfpc}
generic procedure FreeAndNil<T: class>(var Obj: T);
begin
end;
procedure FreeAndNil(var Obj);
begin
end;
var
t: TObject;
begin
FreeAndNil(t);
specialize FreeAndNil<TObject>(t);
end.

40
tests/tbs/tb0677.pp Normal file
View File

@ -0,0 +1,40 @@
{ %NORUN }
program tb0677;
{$mode objfpc}
type
TEnum = (eOne, eTwo, eThree, eFour);
TSet = set of TEnum;
generic TTest<SetType, EnumType> = class
procedure Test;
end;
procedure TTest.Test;
var
s1: TSet;
s2: SetType;
e1: TEnum;
e2: EnumType;
begin
Include(s1, e1);
Exclude(s1, e1);
Include(s2, e1);
Exclude(s2, e1);
Include(s2, e2);
Exclude(s2, e2);
Include(s2, e1);
Exclude(s2, e2);
end;
type
TTestTypes = specialize TTest<TSet, TEnum>;
begin
end.

19
tests/webtbs/tw37107.pp Normal file
View File

@ -0,0 +1,19 @@
program genTest;
{$IFDEF FPC}{$mode Delphi}{$ENDIF}
type
TTest<T: Record> = class(TObject)
procedure testit();
end;
procedure TTest<T>.testit();
begin
WriteLn('=== ', 1 div SizeOf(T));
if SizeOf(T) > 0 then
WriteLn('I''m reachable!')
end;
begin
TTest<Char>.Create().TestIt();
end.

19
tests/webtbs/tw37187.pp Normal file
View File

@ -0,0 +1,19 @@
{ %NORUN }
program tw37187;
{$mode objfpc}
type
generic TTest<T: class> = class
arr: array[0..SizeOf(T)] of Byte;
end;
generic TTest2<T: class> = class
public type
TTestT = specialize TTest<T>;
end;
begin
end.

26
tests/webtbs/tw37806.pp Normal file
View File

@ -0,0 +1,26 @@
program tw37806;
{$mode delphi}
procedure TurnSetElem<TSet, TElem>(var aSet: TSet; aElem: TElem; aOn: Boolean);
begin
if aOn then
Include(aSet, aElem)
else
Exclude(aSet, aElem);
end;
type
TElem = (One, Two, Three, Four, Five);
TSet = set of TElem;
var
s: TSet = [];
begin
TurnSetElem<TSet, TElem>(s, Two, True);
TurnSetElem<TSet, TElem>(s, Five, True);
if not((Two in s) and (Five in s)) then
Halt(1);
//WriteLn('does not work');
end.