* fixed bug #4737 (check for potential range errors in for-loop

    assignment, report correct column for potential range errors of
    call parameters)
  * refactored code to check potential range check errors (check_ranges
    in htypechk)

git-svn-id: trunk@2501 -

.gitattributes

@@ -5987,6 +5987,7 @@ tests/webtbf/tw4619b.pp svneol=native#text/plain
 tests/webtbf/tw4647.pp svneol=native#text/plain
 tests/webtbf/tw4651.pp svneol=native#text/plain
 tests/webtbf/tw4695.pp svneol=native#text/plain
+tests/webtbf/tw4737.pp svneol=native#text/plain
 tests/webtbf/tw4757.pp svneol=native#text/plain
 tests/webtbf/tw4764.pp svneol=native#text/plain
 tests/webtbf/tw4777.pp svneol=native#text/plain

compiler/htypechk.pas

@@ -27,7 +27,7 @@ interface
 
     uses
       tokens,cpuinfo,
-      node,
+      node,globals,
       symconst,symtype,symdef,symsym,symbase;
 
     type
@@ -151,11 +151,13 @@ interface
 
     procedure check_hints(const srsym: tsym; const symoptions: tsymoptions);
 
+    procedure check_ranges(const location: tfileposinfo; source: tnode; destdef: tdef);
+
 implementation
 
     uses
        globtype,systems,
-       cutils,verbose,globals,
+       cutils,verbose,
        symtable,
        defutil,defcmp,
        nbas,ncnv,nld,nmem,ncal,nmat,ninl,nutils,
@@ -2204,16 +2206,39 @@ implementation
 
 
     procedure check_hints(const srsym: tsym; const symoptions: tsymoptions);
-     begin
-       if not assigned(srsym) then
-         internalerror(200602051);
-       if sp_hint_deprecated in symoptions then
-         Message1(sym_w_deprecated_symbol,srsym.realname);
-       if sp_hint_platform in symoptions then
-         Message1(sym_w_non_portable_symbol,srsym.realname);
-       if sp_hint_unimplemented in symoptions then
-         Message1(sym_w_non_implemented_symbol,srsym.realname);
-     end;
+      begin
+        if not assigned(srsym) then
+          internalerror(200602051);
+        if sp_hint_deprecated in symoptions then
+          Message1(sym_w_deprecated_symbol,srsym.realname);
+        if sp_hint_platform in symoptions then
+          Message1(sym_w_non_portable_symbol,srsym.realname);
+        if sp_hint_unimplemented in symoptions then
+          Message1(sym_w_non_implemented_symbol,srsym.realname);
+      end;
+
+
+    procedure check_ranges(const location: tfileposinfo; source: tnode; destdef: tdef);
+      begin
+        { check if the assignment may cause a range check error }
+        { if its not explicit, and only if the values are       }
+        { ordinals, enumdef and floatdef                        }
+        if assigned(destdef) and
+          (destdef.deftype in [enumdef,orddef,floatdef]) and
+          not is_boolean(destdef) and
+          assigned(source.resulttype.def) and
+          (source.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
+          not is_boolean(source.resulttype.def) then
+         begin
+           if (destdef.size < source.resulttype.def.size) then
+             begin
+               if (cs_check_range in aktlocalswitches) then
+                 MessagePos(location,type_w_smaller_possible_range_check)
+               else
+                 MessagePos(location,type_h_smaller_possible_range_check);
+             end;
+         end;
+      end;
 
 
 end.

compiler/ncal.pas

@@ -632,20 +632,7 @@ type
                        end
                       else
                        begin
-                         { for ordinals, floats and enums, verify if we might cause
-                           some range-check errors. }
-                         if (parasym.vartype.def.deftype in [enumdef,orddef,floatdef]) and
-                            (left.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
-                            (left.nodetype in [vecn,loadn,calln]) then
-                           begin
-                              if (left.resulttype.def.size>parasym.vartype.def.size) then
-                                begin
-                                  if (cs_check_range in aktlocalswitches) then
-                                     Message(type_w_smaller_possible_range_check)
-                                  else
-                                     Message(type_h_smaller_possible_range_check);
-                                end;
-                           end;
+                         check_ranges(left.fileinfo,left,parasym.vartype.def);
                          inserttypeconv(left,parasym.vartype);
                        end;
                       if codegenerror then

compiler/nflw.pas

@@ -730,7 +730,10 @@ implementation
 
          { Make sure that the loop var and the
            from and to values are compatible types }
+         check_ranges(right.fileinfo,right,left.resulttype.def);
          inserttypeconv(right,left.resulttype);
+
+         check_ranges(t1.fileinfo,t1,left.resulttype.def);
          inserttypeconv(t1,left.resulttype);
 
          if assigned(t2) then

compiler/nld.pas

@@ -481,11 +481,9 @@ implementation
       var
         hp : tnode;
         useshelper : boolean;
-        original_size : longint;
       begin
         result:=nil;
         resulttype:=voidtype;
-        original_size := 0;
 
         { must be made unique }
         set_unique(left);
@@ -630,35 +628,11 @@ implementation
          end
         else
           begin
-           { get the size before the type conversion - check for all nodes }
-           if assigned(right.resulttype.def) and
-              (right.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
-              (right.nodetype in [loadn,vecn,calln]) then
-             original_size := right.resulttype.def.size;
+           { check if the assignment may cause a range check error }
+           check_ranges(fileinfo,right,left.resulttype.def);
            inserttypeconv(right,left.resulttype);
           end;
 
-        { check if the assignment may cause a range check error }
-        { if its not explicit, and only if the values are       }
-        { ordinals, enumdef and floatdef                        }
-        if (right.nodetype = typeconvn) and
-           not (nf_explicit in ttypeconvnode(right).flags) then
-         begin
-            if assigned(left.resulttype.def) and
-              (left.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
-              not is_boolean(left.resulttype.def) then
-              begin
-                if (original_size <> 0) and
-                   (left.resulttype.def.size < original_size) then
-                  begin
-                    if (cs_check_range in aktlocalswitches) then
-                      Message(type_w_smaller_possible_range_check)
-                    else
-                      Message(type_h_smaller_possible_range_check);
-                  end;
-              end;
-         end;
-
         { call helpers for interface }
         if is_interfacecom(left.resulttype.def) then
          begin

tests/webtbf/tw4737.pp

@@ -0,0 +1,9 @@
+{ %fail }
+{ %OPT=-Seh -vh}
+
+var a:int64;
+i:integer;
+begin
+a:=0;
+for i:=a to 10 do;
+end.