[Ada] fix bogus computation of empty array 'length

[Olivier Hainque]

We used to compute the 'length of an array as max (hb - lb + 1, 0),
which could overflow for some cases of empty arrays, e.g. when
lb == index_type'first.

We now compute it as (hb < lb) ? 0 : hb - lb + 1, which
could overflow as well but in many less cases (of extremely large
arrays) which we never encounter in practice.

The testcase below is expected to compile and run silently:

   procedure Q is

      type Vector is array (Integer range <>) of Integer;

      function Empty_Vector return Vector is
      begin
         return (2 .. Integer'First => 0);
      end;

      My_Vector : Vector := Empty_Vector;
      My_Length : Integer := My_Vector'Length;
   begin
      if My_Length /= 0 then
         raise Program_Error;
      end if;
   end;

Bootstrapped an regtested on x86_64-suse-linux.

2008-03-21  Olivier Hainque  <hainque@adacore.com>

        * trans.c (Attribute_to_gnu) <'length>: Compute as (hb < lb)
        ? 0 : hb - lb + 1 instead of max (hb - lb + 1, 0).

        * gnat.dg/empty_vector_length.adb: New testcase.

-------------- next part --------------
Index: testsuite/gnat.dg/empty_vector_length.adb
===================================================================
*** testsuite/gnat.dg/empty_vector_length.adb	(revision 0)
--- testsuite/gnat.dg/empty_vector_length.adb	(revision 0)
***************
*** 0 ****
--- 1,19 ----
+ --  { dg-do run }
+ --  { dg-options "-gnatp" }
+ 
+ procedure Empty_Vector_Length is
+ 
+    type Vector is array (Integer range <>) of Integer;
+ 
+    function Empty_Vector return Vector is
+    begin
+       return (2 .. Integer'First => 0);
+    end;
+ 
+    My_Vector : Vector := Empty_Vector;
+    My_Length : Integer := My_Vector'Length;
+ begin
+    if My_Length /= 0 then
+       raise Program_Error;
+    end if;
+ end;
Index: testsuite/ChangeLog
===================================================================
*** testsuite/ChangeLog	(revision 133420)
--- testsuite/ChangeLog	(working copy)
***************
*** 1,3 ****
--- 1,7 ----
+ 2008-03-21  Olivier Hainque  <hainque@adacore.com>
+ 
+ 	* gnat.dg/empty_vector_length.adb: New testcase.
+ 
  2008-03-20  Richard Guenther  <rguenther@suse.de>
  
  	* gcc.dg/tree-ssa/ssa-ccp-17.c: New testcase.
Index: ada/ChangeLog
===================================================================
*** ada/ChangeLog	(revision 133420)
--- ada/ChangeLog	(working copy)
***************
*** 1,4 ****
--- 1,9 ----
  2008-03-21  Olivier Hainque  <hainque@adacore.com>
+ 
+ 	* trans.c (Attribute_to_gnu) <'length>: Compute as (hb < lb)
+ 	? 0 : hb - lb + 1 instead of max (hb - lb + 1, 0).
+ 
+ 2008-03-21  Olivier Hainque  <hainque@adacore.com>
              Ed Schonberg  <schonberg@adacore.com>
  
  	* trans.c (addressable_p): Accept COND_EXPR when both arms
Index: ada/trans.c
===================================================================
*** ada/trans.c	(revision 133418)
--- ada/trans.c	(working copy)
*************** Attribute_to_gnu (Node_Id gnat_node, tre
*** 1181,1213 ****
  
  	else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
  	  {
- 	    tree gnu_compute_type;
- 
  	    if (pa && pa->length)
  	      {
  		gnu_result = pa->length;
  		break;
  	      }
  
! 	    gnu_compute_type
! 	      = signed_or_unsigned_type_for (0,
! 					     get_base_type (gnu_result_type));
! 
! 	    gnu_result
! 	      = build_binary_op
! 		(MAX_EXPR, gnu_compute_type,
! 		 build_binary_op
! 		 (PLUS_EXPR, gnu_compute_type,
! 		  build_binary_op
! 		  (MINUS_EXPR, gnu_compute_type,
! 		   convert (gnu_compute_type,
! 			    TYPE_MAX_VALUE
! 			    (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))),
! 		   convert (gnu_compute_type,
! 			    TYPE_MIN_VALUE
! 			    (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))))),
! 		  convert (gnu_compute_type, integer_one_node)),
! 		 convert (gnu_compute_type, integer_zero_node));
  	  }
  
  	/* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
--- 1181,1222 ----
  
  	else /* attribute == Attr_Range_Length || attribute == Attr_Length  */
  	  {
  	    if (pa && pa->length)
  	      {
  		gnu_result = pa->length;
  		break;
  	      }
+ 	    else
+ 	      {
+ 		tree gnu_compute_type
+ 		  = signed_or_unsigned_type_for
+ 		      (0, get_base_type (gnu_result_type));
+ 
+ 		tree index_type
+ 		  = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type));
+ 		tree lb
+ 		  = convert (gnu_compute_type, TYPE_MIN_VALUE (index_type));
+ 		tree hb
+ 		  = convert (gnu_compute_type, TYPE_MAX_VALUE (index_type));
+ 		
+ 		/* We used to compute the length as max (hb - lb + 1, 0),
+ 		   which could overflow for some cases of empty arrays, e.g.
+ 		   when lb == index_type'first.
+ 
+ 		   We now compute it as (hb < lb) ? 0 : hb - lb + 1, which
+ 		   could overflow as well, but only for extremely large arrays
+ 		   which we expect never to encounter in practice.  */
  
! 		gnu_result
! 		  = build3
! 		    (COND_EXPR, gnu_compute_type,
! 		     build_binary_op (LT_EXPR, gnu_compute_type, hb, lb),
! 		     convert (gnu_compute_type, integer_zero_node),
! 		     build_binary_op
! 		     (PLUS_EXPR, gnu_compute_type,
! 		      build_binary_op (MINUS_EXPR, gnu_compute_type, hb, lb),
! 		      convert (gnu_compute_type, integer_one_node)));
! 	      }
  	  }
  
  	/* If this has a PLACEHOLDER_EXPR, qualify it by the object we are