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

* relaxation of r42272: again only show warnings rather than errors for

Browse Source 
out-of-range constants, because of the comments mentioned in #35753
    (except for enums, as apparently Delphi does the same)
  * added range check warnings about explicit type casts that throw away
    bits (e.g. byte($fff)), without giving warnings for most common cases
    (like cardinal(-1))
  * fixed masking/sign exting constant array indices (must be based on index
    range type size/signedness rather than on array size/"signedness")

git-svn-id: trunk@42275 -
This commit is contained in:
Jonas Maebe 2019-06-23 14:12:33 +00:00
parent b1a41aa5b8
commit c038e4c3f2
9 changed files with 143 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -14918,6 +14918,7 @@ tests/webtbf/tw35348.pp svneol=native#text/pascal
tests/webtbf/tw3553.pp svneol=native#text/plain
tests/webtbf/tw3562.pp svneol=native#text/plain
tests/webtbf/tw35671.pp svneol=native#text/plain
tests/webtbf/tw35753.pp svneol=native#text/plain
tests/webtbf/tw3583.pp svneol=native#text/plain
tests/webtbf/tw3626.pp svneol=native#text/plain
tests/webtbf/tw3631.pp svneol=native#text/plain

2
compiler/defcmp.pas
View File

@ -1986,7 +1986,7 @@ implementation
if (def1.typ = orddef) and (def2.typ = orddef) then
Begin
{ see p.47 of Turbo Pascal 7.01 manual for the separation of types }
{ range checking for case statements is done with testrange }
{ range checking for case statements is done with adaptrange }
case torddef(def1).ordtype of
u8bit,u16bit,u32bit,u64bit,
s8bit,s16bit,s32bit,s64bit :

132
compiler/defutil.pas
View File

@ -289,15 +289,25 @@ interface
{ true, if def is a signed int type, equal in size to the processor's native int size }
function is_nativesint(def : tdef) : boolean;
type
tperformrangecheck = (
rc_internal, { never at all, internal conversion }
rc_explicit, { no, but this is a user conversion and hence can still give warnings in some cases }
rc_default, { only if range checking is enabled }
rc_always { always }
);
{# If @var(l) isn't in the range of todef a range check error (if not explicit) is generated and
the value is placed within the range
}
procedure testrange(todef : tdef;var l : tconstexprint;explicit,forcerangecheck:boolean);
procedure adaptrange(todef : tdef;var l : tconstexprint; rangecheck: tperformrangecheck);
{ for when used with nf_explicit/nf_internal nodeflags }
procedure adaptrange(todef : tdef;var l : tconstexprint; internal, explicit: boolean);
{# Returns the range of def, where @var(l) is the low-range and @var(h) is
the high-range.
}
procedure getrange(def : tdef;out l, h : TConstExprInt);
procedure getrangedefmasksize(def: tdef; out rangedef: tdef; out mask: TConstExprInt; out size: longint);
{ Returns the range type of an ordinal type in the sense of ISO-10206 }
function get_iso_range_type(def: tdef): tdef;
@ -1086,51 +1096,86 @@ implementation
{ if l isn't in the range of todef a range check error (if not explicit) is generated and
the value is placed within the range }
procedure testrange(todef : tdef;var l : tconstexprint;explicit,forcerangecheck:boolean);
procedure adaptrange(todef : tdef;var l : tconstexprint; rangecheck: tperformrangecheck);
var
lv,hv: TConstExprInt;
lv,hv,oldval,sextval,mask: TConstExprInt;
rangedef: tdef;
rangedefsize: longint;
warned: boolean;
begin
{ for 64 bit types we need only to check if it is less than }
{ zero, if def is a qword node }
getrange(todef,lv,hv);
if (l<lv) or (l>hv) then
begin
if not explicit then
warned:=false;
if rangecheck in [rc_default,rc_always] then
begin
if (cs_check_range in current_settings.localswitches) or
forcerangecheck or
(not is_pasbool(todef) and
not spans_entire_range(todef)) then
if (rangecheck=rc_always) or
(todef.typ=enumdef) or
(cs_check_range in current_settings.localswitches) then
Message3(type_e_range_check_error_bounds,tostr(l),tostr(lv),tostr(hv))
else
Message3(type_w_range_check_error_bounds,tostr(l),tostr(lv),tostr(hv));
warned:=true;
end
{ give warnings about range errors with explicit typeconversions if the target
type does not span the entire range that can be represented by its bits
(subrange type or enum), because then the result is undefined }
else if (rangecheck<>rc_internal) and
(not is_pasbool(todef) and
not spans_entire_range(todef)) then
begin
Message3(type_w_range_check_error_bounds,tostr(l),tostr(lv),tostr(hv));
warned:=true;
end;
{ Fix the value to fit in the allocated space for this type of variable }
case longint(todef.size) of
1: l := l and $ff;
2: l := l and $ffff;
4: l := l and $ffffffff;
else
;
end;
oldval:=l;
getrangedefmasksize(todef,rangedef,mask,rangedefsize);
l:=l and mask;
{reset sign, i.e. converting -1 to qword changes the value to high(qword)}
l.signed:=false;
sextval:=0;
{ do sign extension if necessary (JM) }
if is_signed(todef) then
begin
case longint(todef.size) of
1: l.svalue := shortint(l.svalue);
2: l.svalue := smallint(l.svalue);
4: l.svalue := longint(l.svalue);
else
;
end;
l.signed:=true;
case rangedefsize of
1: sextval.svalue:=shortint(l.svalue);
2: sextval.svalue:=smallint(l.svalue);
4: sextval.svalue:=longint(l.svalue);
8: sextval.svalue:=l.svalue;
else
internalerror(201906230);
end;
sextval.signed:=true;
{ Detect if the type spans the entire range, but more bits were specified than
the type can contain, e.g. shortint($fff).
However, none of the following should result in a warning:
1) shortint($ff) (-> $ff -> $ff -> $ffff ffff ffff ffff)
2) shortint(longint(-1)) ($ffff ffff ffff ffff ffff -> $ff -> $ffff ffff ffff ffff
3) cardinal(-1) (-> $ffff ffff ffff ffff -> $ffff ffff)
}
if not warned and
(rangecheck<>rc_internal) and
(oldval.uvalue<>l.uvalue) and
(oldval.uvalue<>sextval.uvalue) then
begin
Message3(type_w_range_check_error_bounds,tostr(oldval),tostr(lv),tostr(hv));
end;
if is_signed(rangedef) then
l:=sextval;
end;
end;
procedure adaptrange(todef: tdef; var l: tconstexprint; internal, explicit: boolean);
begin
if internal then
adaptrange(todef, l, rc_internal)
else if explicit then
adaptrange(todef, l, rc_explicit)
else
adaptrange(todef, l, rc_default)
end;
{ return the range from def in l and h }
procedure getrange(def : tdef;out l, h : TConstExprInt);
begin
@ -1161,6 +1206,39 @@ implementation
end;
procedure getrangedefmasksize(def: tdef; out rangedef: tdef; out mask: TConstExprInt; out size: longint);
begin
case def.typ of
orddef, enumdef:
begin
rangedef:=def;
size:=def.size;
case size of
1: mask:=$ff;
2: mask:=$ffff;
4: mask:=$ffffffff;
8: mask:=$ffffffffffffffff;
else
internalerror(2019062305);
end;
end;
arraydef:
begin
rangedef:=tarraydef(def).rangedef;
getrangedefmasksize(rangedef,rangedef,mask,size);
end;
undefineddef:
begin
rangedef:=sizesinttype;
size:=rangedef.size;
mask:=-1;
end;
else
internalerror(2019062306);
end;
end;
function mmx_type(p : tdef) : tmmxtype;
begin
mmx_type:=mmxno;

16
compiler/ncnv.pas
View File

@ -1482,9 +1482,13 @@ implementation
result:=cpointerconstnode.create(TConstPtrUInt(v.uvalue),resultdef)
else
begin
if is_currency(left.resultdef) and
not(nf_internal in flags) then
v:=v div 10000;
if is_currency(left.resultdef) then
begin
if not(nf_internal in flags) then
v:=v div 10000;
end
else if (resultdef.typ in [orddef,enumdef]) then
adaptrange(resultdef,v,([nf_internal,nf_absolute]*flags)<>[],nf_explicit in flags);
result:=cordconstnode.create(v,resultdef,false);
end;
end
@ -3073,12 +3077,10 @@ implementation
end
else
begin
{ for constant values on absolute variables, swaping is required }
{ for constant values on absolute variables, swapping is required }
if (target_info.endian = endian_big) and (nf_absolute in flags) then
swap_const_value(tordconstnode(left).value,tordconstnode(left).resultdef.size);
if not(nf_internal in flags) then
testrange(resultdef,tordconstnode(left).value,(nf_explicit in flags)
or (nf_absolute in flags),false);
adaptrange(resultdef,tordconstnode(left).value,([nf_internal,nf_absolute]*flags)<>[],nf_explicit in flags);
{ swap value back, but according to new type }
if (target_info.endian = endian_big) and (nf_absolute in flags) then
swap_const_value(tordconstnode(left).value,resultdef.size);

2
compiler/ncon.pas
View File

@ -582,7 +582,7 @@ implementation
{ only do range checking when explicitly asked for it
and if the type can be range checked, see tests/tbs/tb0539.pp }
if (resultdef.typ in [orddef,enumdef]) then
testrange(resultdef,value,not rangecheck,false)
adaptrange(resultdef,value,nf_internal in flags, not rangecheck)
end;
function tordconstnode.pass_1 : tnode;

6
compiler/ngtcon.pas
View File

@ -627,7 +627,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
begin
if is_constboolnode(node) then
begin
testrange(def,tordconstnode(node).value,false,false);
adaptrange(def,tordconstnode(node).value,rc_default);
ftcb.emit_ord_const(tordconstnode(node).value.svalue,def)
end
else
@ -661,7 +661,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
begin
if is_constintnode(node) then
begin
testrange(def,tordconstnode(node).value,false,false);
adaptrange(def,tordconstnode(node).value,rc_default);
ftcb.emit_ord_const(tordconstnode(node).value.svalue,def);
end
else
@ -1074,7 +1074,7 @@ function get_next_varsym(def: tabstractrecorddef; const SymList:TFPHashObjectLis
if equal_defs(node.resultdef,def) or
is_subequal(node.resultdef,def) then
begin
testrange(def,tordconstnode(node).value,false,false);
adaptrange(def,tordconstnode(node).value,rc_default);
case longint(node.resultdef.size) of
1 : ftcb.emit_tai(Tai_const.Create_8bit(Byte(tordconstnode(node).value.svalue)),def);
2 : ftcb.emit_tai(Tai_const.Create_16bit(Word(tordconstnode(node).value.svalue)),def);

13
compiler/ninl.pas
View File

@ -2514,13 +2514,14 @@ implementation
else
vl:=tordconstnode(left).value-1;
if is_integer(left.resultdef) then
{ the type of the original integer constant is irrelevant,
it should be automatically adapted to the new value
(except when inlining) }
{ the type of the original integer constant is irrelevant,
it should be automatically adapted to the new value
(except when inlining) }
result:=create_simplified_ord_const(vl,resultdef,forinline)
else
{ check the range for enums, chars, booleans }
result:=cordconstnode.create(vl,left.resultdef,not(nf_internal in flags))
result:=cordconstnode.create(vl,left.resultdef,not(nf_internal in flags));
result.flags:=result.flags+(flags*[nf_internal]);
end;
addn,
subn:
@ -2866,9 +2867,9 @@ implementation
(index.left.nodetype = ordconstn) and
not is_special_array(unpackedarraydef) then
begin
testrange(unpackedarraydef,tordconstnode(index.left).value,false,false);
adaptrange(unpackedarraydef,tordconstnode(index.left).value,rc_default);
tempindex := tordconstnode(index.left).value + packedarraydef.highrange-packedarraydef.lowrange;
testrange(unpackedarraydef,tempindex,false,false);
adaptrange(unpackedarraydef,tempindex,rc_default);
end;
end;

8
compiler/pstatmnt.pas
View File

@ -223,8 +223,8 @@ implementation
CGMessage(parser_e_case_lower_less_than_upper_bound);
if not casedeferror then
begin
testrange(casedef,hl1,false,false);
testrange(casedef,hl2,false,false);
adaptrange(casedef,hl1,rc_default);
adaptrange(casedef,hl2,rc_default);
end;
end
else
@ -252,7 +252,7 @@ implementation
begin
hl1:=get_ordinal_value(p);
if not casedeferror then
testrange(casedef,hl1,false,false);
adaptrange(casedef,hl1,rc_default);
casenode.addlabel(blockid,hl1,hl1);
end;
end;
@ -362,7 +362,7 @@ implementation
begin
if (hp.nodetype=ordconstn) and
(fordef.typ<>errordef) then
testrange(fordef,tordconstnode(hp).value,false,true);
adaptrange(fordef,tordconstnode(hp).value,rc_always);
end;
function for_loop_create(hloopvar: tnode): tnode;

12
tests/webtbf/tw35753.pp Normal file
View File

@ -0,0 +1,12 @@
{ %fail }
{ %OPT=-vw -Sew }
type
TRegister = (
TRegisterLowEnum := Low(longint),
TRegisterHighEnum := High(longint)
);
const
NR_INVALID = tregister($fffffffff);
begin
end.