re PR ada/42253 (run time crash on null for thin pointers)

PR ada/42253
	* gcc-interface/utils2.c (build_binary_op) <EQ_EXPR>: Assert that fat
	pointer base types are variant of each other.  Apply special treatment
	for null to fat pointer types in all cases.

From-SVN: r157107

gcc/ada/ChangeLog

@@ -1,3 +1,10 @@
+2010-02-27  Eric Botcazou  <ebotcazou@adacore.com>
+
+	PR ada/42253
+	* gcc-interface/utils2.c (build_binary_op) <EQ_EXPR>: Assert that fat
+	pointer base types are variant of each other.  Apply special treatment
+	for null to fat pointer types in all cases.
+
 2010-01-28  Pascal Obry  <obry@adacore.com>
 
 	* s-win32.ads: Add some missing constants.

gcc/ada/gcc-interface/utils2.c

@@ -834,26 +834,28 @@ build_binary_op (enum tree_code op_code, tree result_type,
 	  return result;
 	}
 
-      /* Otherwise, the base types must be the same unless the objects are
-	 fat pointers or records.  If we have records, use the best type and
-	 convert both operands to that type.  */
+      /* Otherwise, the base types must be the same, unless they are both fat
+	 pointer types or record types.  In the latter case, use the best type
+	 and convert both operands to that type.  */
       if (left_base_type != right_base_type)
 	{
 	  if (TYPE_IS_FAT_POINTER_P (left_base_type)
-	      && TYPE_IS_FAT_POINTER_P (right_base_type)
-	      && TYPE_MAIN_VARIANT (left_base_type)
-		 == TYPE_MAIN_VARIANT (right_base_type))
-	    best_type = left_base_type;
+	      && TYPE_IS_FAT_POINTER_P (right_base_type))
+	    {
+	      gcc_assert (TYPE_MAIN_VARIANT (left_base_type)
+			  == TYPE_MAIN_VARIANT (right_base_type));
+	      best_type = left_base_type;
+	    }
+
 	  else if (TREE_CODE (left_base_type) == RECORD_TYPE
 		   && TREE_CODE (right_base_type) == RECORD_TYPE)
 	    {
-	      /* The only way these are permitted to be the same is if both
-		 types have the same name.  In that case, one of them must
-		 not be self-referential.  Use that one as the best type.
-		 Even better is if one is of fixed size.  */
+	      /* The only way this is permitted is if both types have the same
+		 name.  In that case, one of them must not be self-referential.
+		 Use it as the best type.  Even better with a fixed size.  */
 	      gcc_assert (TYPE_NAME (left_base_type)
-			  && (TYPE_NAME (left_base_type)
-			      == TYPE_NAME (right_base_type)));
+			  && TYPE_NAME (left_base_type)
+			     == TYPE_NAME (right_base_type));
 
 	      if (TREE_CONSTANT (TYPE_SIZE (left_base_type)))
 		best_type = left_base_type;
@@ -866,34 +868,34 @@ build_binary_op (enum tree_code op_code, tree result_type,
 	      else
 		gcc_unreachable ();
 	    }
+
 	  else
 	    gcc_unreachable ();
 
 	  left_operand = convert (best_type, left_operand);
 	  right_operand = convert (best_type, right_operand);
 	}
-
-      /* If we are comparing a fat pointer against zero, we need to
-	 just compare the data pointer.  */
-      else if (TYPE_IS_FAT_POINTER_P (left_base_type)
-	       && TREE_CODE (right_operand) == CONSTRUCTOR
-	       && integer_zerop (VEC_index (constructor_elt,
-					    CONSTRUCTOR_ELTS (right_operand),
-					    0)
-				 ->value))
-	{
-	  right_operand = build_component_ref (left_operand, NULL_TREE,
-					       TYPE_FIELDS (left_base_type),
-					       false);
-	  left_operand = convert (TREE_TYPE (right_operand),
-				  integer_zero_node);
-	}
       else
 	{
 	  left_operand = convert (left_base_type, left_operand);
 	  right_operand = convert (right_base_type, right_operand);
 	}
 
+      /* If we are comparing a fat pointer against zero, we just need to
+	 compare the data pointer.  */
+      if (TYPE_IS_FAT_POINTER_P (left_base_type)
+	  && TREE_CODE (right_operand) == CONSTRUCTOR
+	  && integer_zerop (VEC_index (constructor_elt,
+				       CONSTRUCTOR_ELTS (right_operand),
+				       0)->value))
+	{
+	  left_operand
+	    = build_component_ref (left_operand, NULL_TREE,
+				   TYPE_FIELDS (left_base_type), false);
+	  right_operand
+	    = convert (TREE_TYPE (left_operand), integer_zero_node);
+	}
+
       modulus = NULL_TREE;
       break;
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,10 @@
+2010-02-27  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/thin_pointer.ad[sb]: Rename into...
+	* gnat.dg/thin_pointer1.ad[sb]: ...this.
+	* gnat.dg/thin_pointer2.adb: New test.
+	* gnat.dg/thin_pointer2_pkg.ad[sb]: New helper.
+
 2010-02-26  Manuel López-Ibáñez  <manu@gcc.gnu.org>
 
 	PR c/20631

gcc/testsuite/gnat.dg/thin_pointer1.adb

@@ -1,11 +1,11 @@
 -- { dg-do compile }
 -- { dg-options "-O" }
 
-package body Thin_Pointer is
+package body Thin_Pointer1 is
 
    procedure Set_Buffer (AD : Buf_Ptr; Buffer : Stream_ptr) is
    begin
       AD.B.A := Buffer (Buffer'First)'Address;
    end Set_Buffer;
 
-end Thin_Pointer;
+end Thin_Pointer1;

gcc/testsuite/gnat.dg/thin_pointer1.ads

@@ -1,6 +1,6 @@
 with System;
 
-package Thin_Pointer is
+package Thin_Pointer1 is
 
    type Stream is array (Integer range <>) of Character;
 
@@ -19,4 +19,4 @@ package Thin_Pointer is
 
    procedure Set_Buffer (AD : Buf_Ptr; Buffer : Stream_ptr);
 
-end Thin_Pointer;
+end Thin_Pointer1;

gcc/testsuite/gnat.dg/thin_pointer2.adb

@@ -0,0 +1,13 @@
+-- PR ada/42253
+-- Testcase by Duncan Sands <baldrick@gcc.gnu.org>
+
+-- { dg-do run }
+
+with Thin_Pointer2_Pkg; use Thin_Pointer2_Pkg;
+
+procedure Thin_Pointer2 is
+begin
+   if F /= '*' then
+      raise Program_Error;
+   end if;
+end;

gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb

@@ -0,0 +1,18 @@
+package body Thin_Pointer2_Pkg is
+
+   type SB is access constant String;
+
+   function Inner (S : SB) return Character is
+   begin
+      if S /= null and then S'Length > 0 then
+         return S (S'First);
+      end if;
+      return '*';
+   end;
+
+   function F return Character is
+   begin
+      return Inner (SB (S));
+   end;
+
+end Thin_Pointer2_Pkg;

gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads

@@ -0,0 +1,9 @@
+package Thin_Pointer2_Pkg is
+
+   type SA is access String;
+   for SA'Size use Standard'Address_Size;
+   S : SA;
+
+   function F return Character;
+
+end Thin_Pointer2_Pkg;