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

-- Zusammenführen von r42272 in ».«:

Browse Source 
U    compiler/defutil.pas
A    tests/webtbf/tw35671.pp
-- Aufzeichnung der Informationen für Zusammenführung von r42272 in ».«:
 U   .
-- Zusammenführen von r42274 in ».«:
U    compiler/cgbase.pas
-- Aufzeichnung der Informationen für Zusammenführung von r42274 in ».«:
 G   .
-- Zusammenführen von r42275 in ».«:
U    compiler/defcmp.pas
C    compiler/defutil.pas
U    compiler/ncnv.pas
U    compiler/ncon.pas
U    compiler/ngtcon.pas
U    compiler/ninl.pas
U    compiler/pstatmnt.pas
A    tests/webtbf/tw35753.pp
-- Aufzeichnung der Informationen für Zusammenführung von r42275 in ».«:
 G   .

git-svn-id: branches/fixes_3_2@43367 -
This commit is contained in:
florian 2019-11-02 18:07:58 +00:00
parent baa1603371
commit b6e7ebdd3c
11 changed files with 204 additions and 48 deletions

2
.gitattributes vendored
View File

@ -14689,6 +14689,8 @@ tests/webtbf/tw3502.pp svneol=native#text/plain
tests/webtbf/tw35149a.pp svneol=native#text/plain
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/cgbase.pas
View File

@ -309,7 +309,7 @@ interface
{ Invalid register number }
RS_INVALID = high(tsuperregister);
NR_INVALID = tregister($fffffffff);
NR_INVALID = tregister($ffffffff);
tcgsize2size : Array[tcgsize] of integer =
(0,

2
compiler/defcmp.pas
View File

@ -1956,7 +1956,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 :

174
compiler/defutil.pas
View File

@ -68,6 +68,9 @@ interface
procedure int_to_type(const v:TConstExprInt;var def:tdef);
{# Return true if the type (orddef or enumdef) spans its entire bitrange }
function spans_entire_range(def: tdef): boolean;
{# Returns true, if definition defines an integer type }
function is_integer(def : tdef) : boolean;
@ -283,15 +286,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;
@ -545,6 +558,47 @@ implementation
end;
function spans_entire_range(def: tdef): boolean;
var
lv, hv: Tconstexprint;
mask: qword;
size: longint;
begin
case def.typ of
orddef,
enumdef:
getrange(def,lv,hv);
else
internalerror(2019062203);
end;
size:=def.size;
case size of
1: mask:=$ff;
2: mask:=$ffff;
4: mask:=$ffffffff;
8: mask:=qword(-1);
else
internalerror(2019062204);
end;
result:=false;
if is_signed(def) then
begin
if (lv.uvalue and mask)<>(qword(1) shl (size*8-1)) then
exit;
if (hv.uvalue and mask)<>(mask shr 1) then
exit;
end
else
begin
if lv<>0 then
exit;
if hv.uvalue<>mask then
exit;
end;
result:=true;
end;
{ true if p is an integer }
function is_integer(def : tdef) : boolean;
begin
@ -1024,49 +1078,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 ((todef.typ=enumdef) and
{ delphi allows range check errors in
enumeration type casts FK }
not(m_delphi in current_settings.modeswitches)) or
(cs_check_range in current_settings.localswitches) or
forcerangecheck 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;
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);
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
@ -1097,6 +1188,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

@ -1452,9 +1452,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
@ -3026,12 +3030,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

@ -568,7 +568,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

@ -625,7 +625,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
@ -659,7 +659,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

@ -2431,13 +2431,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:
@ -2775,9 +2776,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

@ -221,8 +221,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
@ -250,7 +250,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;
@ -360,7 +360,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;

15
tests/webtbf/tw35671.pp Normal file
View File

@ -0,0 +1,15 @@
{ %fail }
program Project1;
{$mode delphi}
type
TSuit = (suHeart, suDiamond, suClub, suSpade);
TRedSuit = suHeart..suDiamond;
var
Suit: TRedSuit;
begin
// This should generate an error, but {$mode delphi} allows it
Suit := suClub;
end.

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.