Browse Source

* evaluate the lower and upper bounds of for-loops in ISO mode using the
ISO-defined range type, instead of using the type of the iteration
variable (mantis #24318)

git-svn-id: trunk@37934 -

Jonas Maebe 7 years ago
parent
commit
a2217cedd5
4 changed files with 67 additions and 4 deletions
  1. 1 0
      .gitattributes
  2. 32 0
      compiler/defutil.pas
  3. 10 4
      compiler/nflw.pas
  4. 24 0
      tests/webtbs/tw24318.pp

+ 1 - 0
.gitattributes

@@ -15425,6 +15425,7 @@ tests/webtbs/tw24197.pp svneol=native#text/plain
 tests/webtbs/tw2421.pp svneol=native#text/plain
 tests/webtbs/tw2421.pp svneol=native#text/plain
 tests/webtbs/tw2423.pp svneol=native#text/plain
 tests/webtbs/tw2423.pp svneol=native#text/plain
 tests/webtbs/tw2425.pp svneol=native#text/plain
 tests/webtbs/tw2425.pp svneol=native#text/plain
+tests/webtbs/tw24318.pp svneol=native#text/plain
 tests/webtbs/tw2432.pp svneol=native#text/plain
 tests/webtbs/tw2432.pp svneol=native#text/plain
 tests/webtbs/tw2435.pp svneol=native#text/plain
 tests/webtbs/tw2435.pp svneol=native#text/plain
 tests/webtbs/tw2438.pp svneol=native#text/plain
 tests/webtbs/tw2438.pp svneol=native#text/plain

+ 32 - 0
compiler/defutil.pas

@@ -290,6 +290,9 @@ interface
     }
     }
     procedure getrange(def : tdef;out l, h : TConstExprInt);
     procedure getrange(def : tdef;out l, h : TConstExprInt);
 
 
+    { Returns the range type of an ordinal type in the sense of ISO-10206 }
+    function get_iso_range_type(def: tdef): tdef;
+
     { type being a vector? }
     { type being a vector? }
     function is_vector(p : tdef) : boolean;
     function is_vector(p : tdef) : boolean;
 
 
@@ -1114,6 +1117,35 @@ implementation
       end;
       end;
 
 
 
 
+    { The range-type of an ordinal-type that is a subrange-type shall be the host-type (see 6.4.2.4) of the subrange-type.
+      The range-type of an ordinal-type that is not a subrange-type shall be the ordinal-type.
+
+      The subrange-bounds shall be of compatible ordinal-types, and the range-type (see 6.4.2.1) of the ordinal-types shall
+      be designated the host-type of the subrange-type. }
+    function get_iso_range_type(def: tdef): tdef;
+      begin
+        result:=nil;
+        case def.typ of
+           orddef:
+             begin
+               if (torddef(def).low>=torddef(sinttype).low) and
+                  (torddef(def).high<=torddef(sinttype).high) then
+                 result:=sinttype
+               else
+                 range_to_type(torddef(def).low,torddef(def).high,result);
+             end;
+           enumdef:
+             begin
+               while assigned(tenumdef(def).basedef) do
+                 def:=tenumdef(def).basedef;
+               result:=def;
+             end
+           else
+             internalerror(2018010701);
+        end;
+      end;
+
+
     function is_vector(p : tdef) : boolean;
     function is_vector(p : tdef) : boolean;
       begin
       begin
         result:=(p.typ=arraydef) and
         result:=(p.typ=arraydef) and

+ 10 - 4
compiler/nflw.pas

@@ -1497,6 +1497,7 @@ implementation
     function tfornode.pass_typecheck:tnode;
     function tfornode.pass_typecheck:tnode;
       var
       var
         res : tnode;
         res : tnode;
+        rangedef: tdef;
       begin
       begin
          result:=nil;
          result:=nil;
          resultdef:=voidtype;
          resultdef:=voidtype;
@@ -1529,11 +1530,16 @@ implementation
 
 
          { Make sure that the loop var and the
          { Make sure that the loop var and the
            from and to values are compatible types }
            from and to values are compatible types }
-         check_ranges(right.fileinfo,right,left.resultdef);
-         inserttypeconv(right,left.resultdef);
+         if not(m_iso in current_settings.modeswitches) then
+           rangedef:=left.resultdef
+         else
+           rangedef:=get_iso_range_type(left.resultdef);
+
+         check_ranges(right.fileinfo,right,rangedef);
+         inserttypeconv(right,rangedef);
 
 
-         check_ranges(t1.fileinfo,t1,left.resultdef);
-         inserttypeconv(t1,left.resultdef);
+         check_ranges(t1.fileinfo,t1,rangedef);
+         inserttypeconv(t1,rangedef);
 
 
          if assigned(t2) then
          if assigned(t2) then
            typecheckpass(t2);
            typecheckpass(t2);

+ 24 - 0
tests/webtbs/tw24318.pp

@@ -0,0 +1,24 @@
+{$MODE ISO}
+
+{$r+}
+
+program range ( output );
+
+const  ttlow = 0;   tthigh  =  800;
+
+type   ttx = ttlow .. tthigh;
+
+var    ttop : ttx;
+
+procedure p ( low : ttx );
+var  high : ttx;
+begin
+   for high := low to ttop - 1 do
+     halt(1);
+end;
+
+begin
+   writeln(sizeof(ttop));
+   ttop := 0;
+   p( 1 );
+end.