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

    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 -

.gitattributes

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

compiler/defcmp.pas

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

compiler/defutil.pas

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

compiler/ncnv.pas

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

compiler/ncon.pas

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

compiler/ngtcon.pas

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

compiler/ninl.pas

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

compiler/pstatmnt.pas

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

tests/webtbf/tw35753.pp

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