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

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 -

.gitattributes

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

compiler/cgbase.pas

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

compiler/defcmp.pas

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

compiler/defutil.pas

@@ -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,46 +1078,83 @@ 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
+             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
-                case longint(todef.size) of
-                  1: l.svalue := shortint(l.svalue);
-                  2: l.svalue := smallint(l.svalue);
-                  4: l.svalue := longint(l.svalue);
+                 Message3(type_w_range_check_error_bounds,tostr(oldval),tostr(lv),tostr(hv));
                end;
-                l.signed:=true;
+              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;
 
 
@@ -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;

compiler/ncnv.pas

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

compiler/ncon.pas

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

compiler/ngtcon.pas

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

compiler/ninl.pas

@@ -2437,7 +2437,8 @@ implementation
                           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;
 

compiler/pstatmnt.pas

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

tests/webtbf/tw35671.pp

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

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.