* converted range checking for open arrays/array of const from the code

    generator to the typecheck pass, so that it also works for platforms
    that use the parentfpstruct way to handle accesses to nested frames
    in case the array has been migrated to such a parentfpstruct
   o additionally, the number of comparisons for such range checks
     has been reduced from 3 (for signed indices) or 2 (for unsigned
     indices) to 1 in all cases
   o the range checking code is disabled for the JVM target, as the
     JVM automatically range checks all array accesses itself anyway

git-svn-id: trunk@34034 -

.gitattributes

@@ -15634,6 +15634,11 @@ tests/webtbs/tw8935.pp svneol=native#text/plain
 tests/webtbs/tw8950.pp svneol=native#text/plain
 tests/webtbs/tw8975.pp svneol=native#text/plain
 tests/webtbs/tw8975a.pp svneol=native#text/plain
+tests/webtbs/tw8975b.pp svneol=native#text/plain
+tests/webtbs/tw8975c.pp svneol=native#text/plain
+tests/webtbs/tw8975d.pp svneol=native#text/plain
+tests/webtbs/tw8975e.pp svneol=native#text/plain
+tests/webtbs/tw8975f.pp svneol=native#text/plain
 tests/webtbs/tw8977.pp svneol=native#text/plain
 tests/webtbs/tw9025.pp svneol=native#text/plain
 tests/webtbs/tw9026.pp svneol=native#text/plain

compiler/jvm/njvmmem.pas

@@ -57,6 +57,9 @@ interface
        end;
 
        tjvmvecnode = class(tcgvecnode)
+        protected
+          function gen_array_rangecheck: tnode; override;
+        public
          function pass_1: tnode; override;
          procedure pass_generate_code;override;
        end;
@@ -355,6 +358,13 @@ implementation
                              TJVMVECNODE
 *****************************************************************************}
 
+    function tjvmvecnode.gen_array_rangecheck: tnode;
+      begin
+        { JVM does the range checking for us }
+        result:=nil;
+      end;
+
+
     function tjvmvecnode.pass_1: tnode;
       var
         psym: tsym;

compiler/ncgmem.pas

@@ -767,43 +767,7 @@ implementation
            exit;
          paraloc1.init;
          paraloc2.init;
-         if is_open_array(left.resultdef) or
-            is_array_of_const(left.resultdef) then
-          begin
-            { cdecl functions don't have high() so we can not check the range }
-            { (can't use current_procdef, since it may be a nested procedure) }
-            if not(tprocdef(tparasymtable(tparavarsym(tloadnode(get_open_const_array(left)).symtableentry).owner).defowner).proccalloption in cdecl_pocalls) then
-             begin
-               { Get high value }
-               hightree:=load_high_value_node(tparavarsym(tloadnode(get_open_const_array(left)).symtableentry));
-               { it must be available }
-               if not assigned(hightree) then
-                 internalerror(200212201);
-               firstpass(hightree);
-               secondpass(hightree);
-               { generate compares }
-{$ifndef cpuhighleveltarget}
-               if (right.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
-                 hreg:=cg.makeregsize(current_asmdata.CurrAsmList,right.location.register,OS_INT)
-               else
-{$endif not cpuhighleveltarget}
-                 begin
-                   hreg:=hlcg.getintregister(current_asmdata.CurrAsmList,ossinttype);
-                   hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,right.resultdef,ossinttype,right.location,hreg);
-                 end;
-               current_asmdata.getjumplabel(neglabel);
-               current_asmdata.getjumplabel(poslabel);
-               hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,ossinttype,OC_LT,0,hreg,poslabel);
-               hlcg.a_cmp_loc_reg_label(current_asmdata.CurrAsmList,osuinttype,OC_BE,hightree.location,hreg,neglabel);
-               hlcg.a_label(current_asmdata.CurrAsmList,poslabel);
-               hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_rangeerror',[],nil).resetiftemp;
-               hlcg.a_label(current_asmdata.CurrAsmList,neglabel);
-               { release hightree }
-               hightree.free;
-             end;
-          end
-         else
-          if is_dynamic_array(left.resultdef) then
+         if is_dynamic_array(left.resultdef) then
             begin
                pd:=search_system_proc('fpc_dynarray_rangecheck');
                paramanager.getintparaloc(current_asmdata.CurrAsmList,pd,1,paraloc1);

compiler/nmem.pas

@@ -117,6 +117,7 @@ interface
        tvecnode = class(tbinarynode)
        protected
           function first_arraydef: tnode; virtual;
+          function gen_array_rangecheck: tnode; virtual;
        public
           constructor create(l,r : tnode);virtual;
           function pass_1 : tnode;override;
@@ -154,7 +155,7 @@ implementation
       globtype,systems,constexp,
       cutils,verbose,globals,
       symconst,symbase,defutil,defcmp,
-      nbas,ninl,nutils,objcutil,
+      nadd,nbas,nflw,ninl,nutils,objcutil,
       wpobase,
 {$ifdef i8086}
       cpuinfo,
@@ -867,7 +868,6 @@ implementation
 
     function tvecnode.pass_typecheck:tnode;
       var
-         hightree: tnode;
          htype,elementdef,elementptrdef : tdef;
          newordtyp: tordtype;
          valid : boolean;
@@ -920,6 +920,23 @@ implementation
                     handle_variantarray in pexpr.pas. Therefore, encountering a variant array is an
                     internal error... }
                    internalerror(200707031)
+                 { open array and array constructor range checking is handled
+                   below at the node level, where the validity of the index
+                   will be checked -> use a regular type conversion to either
+                   the signed or unsigned native int type to prevent another
+                   range check from getting inserted here (unless the type is
+                   larger than the int type). Exception: if it's an ordinal
+                   constant, because then this check should be performed at
+                   compile time }
+                 else if is_open_array(left.resultdef) or
+                    is_array_constructor(left.resultdef) then
+                   begin
+                     if is_signed(right.resultdef) and
+                        not is_constnode(right) then
+                       inserttypeconv(right,sinttype)
+                     else
+                       inserttypeconv(right,uinttype)
+                   end
                  else if is_special_array(left.resultdef) then
                    {Arrays without a high bound (dynamic arrays, open arrays) are zero based,
                     convert indexes into these arrays to aword.}
@@ -1010,33 +1027,10 @@ implementation
                else
                  resultdef:=Tarraydef(left.resultdef).elementdef;
 
-               { if we are range checking an open array or array of const, we }
-               { need to load the high parameter. If the current procedure is }
-               { nested inside the procedure to which the open array/of const }
-               { was passed, then the high parameter must not be a regvar.    }
-               { So create a loadnode for the high parameter here and         }
-               { typecheck it, then the loadnode will make the high parameter }
-               { not regable. Otherwise this would only happen inside pass_2, }
-               { which is too late since by then the regvars are already      }
-               { assigned (pass_1 is also already too late, because then the  }
-               { regvars of the parent are also already assigned).            }
-               { webtbs/tw8975                                                }
-               if (cs_check_range in current_settings.localswitches) and
-                  (is_open_array(left.resultdef) or
-                   is_array_of_const(left.resultdef)) then
-                   begin
-                     { expect to find the load node }
-                     if get_open_const_array(left).nodetype<>loadn then
-                       internalerror(2014040601);
-                     { cdecl functions don't have high() so we can not check the range }
-                     { (can't use current_procdef, since it may be a nested procedure) }
-                     if not(tprocdef(tparasymtable(tparavarsym(tloadnode(get_open_const_array(left)).symtableentry).owner).defowner).proccalloption in cdecl_pocalls) then
-                       begin
-                         { load_high_value_node already typechecks }
-                         hightree:=load_high_value_node(tparavarsym(tloadnode(get_open_const_array(left)).symtableentry));
-                         hightree.free;
-                       end;
-                   end;
+               result:=gen_array_rangecheck;
+               if assigned(result) then
+                 exit;
+
                { in case of a bitpacked array of enums that are size 2 (due to
                  packenum 2) but whose values all fit in one byte, the size of
                  bitpacked array elements will be 1 byte while the resultdef of
@@ -1186,6 +1180,81 @@ implementation
             expectloc:=LOC_SUBSETREF;
       end;
 
+    function tvecnode.gen_array_rangecheck: tnode;
+    var
+      htype: tdef;
+      temp: ttempcreatenode;
+      stat: tstatementnode;
+      indextree: tnode;
+      hightree: tnode;
+    begin
+      result:=nil;
+
+      { Range checking an array of const/open array/dynamic array is
+        more complicated than regular arrays, because the bounds must
+        be checked dynamically. Additionally, in case of array of const
+        and open array we need the high parameter, which must not be
+        made a regvar in case this is a nested rountine relative to the
+        array parameter -> generate te check at the node tree level
+        rather than in the code generator }
+      if (cs_check_range in current_settings.localswitches) and
+         (is_open_array(left.resultdef) or
+          is_array_of_const(left.resultdef)) and
+         (right.nodetype<>rangen) then
+        begin
+          { expect to find the load node }
+          if get_open_const_array(left).nodetype<>loadn then
+            internalerror(2014040601);
+          { cdecl functions don't have high() so we can not check the range }
+          { (can't use current_procdef, since it may be a nested procedure) }
+          if not(tprocdef(tparasymtable(tparavarsym(tloadnode(get_open_const_array(left)).symtableentry).owner).defowner).proccalloption in cdecl_pocalls) then
+            begin
+              temp:=nil;
+              result:=internalstatements(stat);
+              { can't use node_complexity here, assumes that the code has
+                already been firstpassed }
+              if not is_const(right) then
+                begin
+                  temp:=ctempcreatenode.create(right.resultdef,right.resultdef.size,tt_persistent,true);
+                  addstatement(stat,temp);
+                  { needed so we can typecheck its temprefnodes }
+                  typecheckpass(tnode(temp));
+                  addstatement(stat,cassignmentnode.create(
+                    ctemprefnode.create(temp),right)
+                  );
+                  right:=ctemprefnode.create(temp);
+                  { right.resultdef is used below }
+                  typecheckpass(right);
+                end;
+              { range check will be made explicit here }
+              exclude(localswitches,cs_check_range);
+              hightree:=load_high_value_node(tparavarsym(tloadnode(
+                get_open_const_array(left)).symtableentry));
+              { make index unsigned so we only need one comparison;
+                lower bound is always zero for these arrays, but
+                hightree can be -1 in case the array was empty ->
+                add 1 before comparing (ignoring overflows) }
+              htype:=get_unsigned_inttype(right.resultdef);
+              inserttypeconv_explicit(hightree,htype);
+              hightree:=caddnode.create(addn,hightree,genintconstnode(1));
+              hightree.localswitches:=hightree.localswitches-[cs_check_range,
+                cs_check_overflow];
+              indextree:=ctypeconvnode.create_explicit(right.getcopy,htype);
+              { range error if index >= hightree+1 }
+              addstatement(stat,
+                cifnode.create_internal(
+                  caddnode.create_internal(gten,indextree,hightree),
+                  ccallnode.createintern('fpc_rangeerror',nil),
+                  nil
+                )
+              );
+              if assigned(temp) then
+                addstatement(stat,ctempdeletenode.create_normal_temp(temp));
+              addstatement(stat,self.getcopy);
+            end;
+        end;
+    end;
+
 
 {*****************************************************************************
                                TWITHNODE

tests/webtbs/tw8975b.pp

@@ -0,0 +1,38 @@
+{ %opt=-CRriot -O-2 -Ooregvar }
+
+{Internal FPC2.1.4 error, compile with fpc -B -dDebug -O3}
+procedure bug(var b: array of longint);
+var
+  l: longint;
+
+  procedure intern;
+  begin
+    if (b[l] <> 1) then {Fatal: Internal error 200409241}
+      halt(1);
+    inc(b[l]);
+    if (b[l] <> 2) then {Fatal: Internal error 200409241}
+      halt(2);
+
+    if (b[l+1] <> 2) then {Fatal: Internal error 200409241}
+      halt(3);
+    if (b[l+2] <> 3) then {Fatal: Internal error 200409241}
+      halt(4);
+    if (b[low(b)] <> 2) then {Fatal: Internal error 200409241}
+      halt(5);
+    if (b[low(b)+1] <> 2) then {Fatal: Internal error 200409241}
+      halt(6);
+    if (b[low(b)+2] <> 3) then {Fatal: Internal error 200409241}
+      halt(7);
+  end;
+begin
+  l:=0;
+  intern;
+end;
+
+const
+  a: array[1..3] of longint = (1,2,3);
+begin
+  bug(a);
+end.
+
+

tests/webtbs/tw8975c.pp

@@ -0,0 +1,25 @@
+{ %opt=-CRriot -O-2 -Ooregvar }
+{ %result=201 }
+
+{Internal FPC2.1.4 error, compile with fpc -B -dDebug -O3}
+procedure bug(var b: array of longint);
+var
+  l: longint;
+
+  procedure intern;
+  begin
+    if (b[l] <> 1) then {Fatal: Internal error 200409241}
+      halt(1);
+  end;
+begin
+  l:=-1;
+  intern;
+end;
+
+const
+  a: array[1..3] of longint = (1,2,3);
+begin
+  bug(a);
+end.
+
+

tests/webtbs/tw8975d.pp

@@ -0,0 +1,25 @@
+{ %opt=-CRriot -O-2 -Ooregvar }
+{ %result=201 }
+
+{Internal FPC2.1.4 error, compile with fpc -B -dDebug -O3}
+procedure bug(var b: array of longint);
+var
+  l: longint;
+
+  procedure intern;
+  begin
+    if (b[l] <> 1) then {Fatal: Internal error 200409241}
+      halt(1);
+  end;
+begin
+  l:=3;
+  intern;
+end;
+
+const
+  a: array[1..3] of longint = (1,2,3);
+begin
+  bug(a);
+end.
+
+

tests/webtbs/tw8975e.pp

@@ -0,0 +1,22 @@
+{ %opt=-CRriot -O-2 -Ooregvar }
+{ %fail }
+
+{Internal FPC2.1.4 error, compile with fpc -B -dDebug -O3}
+procedure bug(var b: array of longint);
+
+  procedure intern;
+  begin
+    if (b[low(b)-1] <> 1) then {Fatal: Internal error 200409241}
+      halt(1);
+  end;
+begin
+  intern;
+end;
+
+const
+  a: array[1..3] of longint = (1,2,3);
+begin
+  bug(a);
+end.
+
+

tests/webtbs/tw8975f.pp

@@ -0,0 +1,26 @@
+{ %opt=-CRriot -O-2 -Ooregvar }
+{ %result=201 }
+
+{Internal FPC2.1.4 error, compile with fpc -B -dDebug -O3}
+procedure bug(var b: array of longint);
+var
+  l: int64;
+
+  procedure intern;
+  begin
+    if (b[l] <> 1) then {Fatal: Internal error 200409241}
+      halt(1);
+  end;
+begin
+  { ensure the top bits are also checked and not truncated }
+  l:=int64(1) shl 32 + 1;
+  intern;
+end;
+
+const
+  a: array[1..3] of longint = (1,2,3);
+begin
+  bug(a);
+end.
+
+