diff mbox

[Ada] Add extra exception info for validity checks

Message ID 20101022091455.GA4237@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 22, 2010, 9:14 a.m. UTC
This patch first changes the expansion of the 'Valid attribute so that it looks
more like a range check. This then allows us to reuse the existing machinery
for -gnateE for validity checks.

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-22  Arnaud Charlet  <charlet@adacore.com>

	* exp_attr.adb (Make_Range_Test): Generate a Range node instead of
	explicit comparisons, generates simpler expanded code.
	* a-except-2005.adb (Rcheck_06_Ext): New.
	* gcc-interface/trans.c (gigi, gnat_to_gnu): Handle validity checks
	like range checks.
diff mbox

Patch

Index: exp_attr.adb
===================================================================
--- exp_attr.adb	(revision 165803)
+++ exp_attr.adb	(working copy)
@@ -4711,9 +4711,7 @@  package body Exp_Attr is
 
          function Make_Range_Test return Node_Id;
          --  Build the code for a range test of the form
-         --    Btyp!(Pref) >= Btyp!(Ptyp'First)
-         --      and then
-         --    Btyp!(Pref) <= Btyp!(Ptyp'Last)
+         --    Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
 
          ---------------------
          -- Make_Range_Test --
@@ -4732,24 +4730,17 @@  package body Exp_Attr is
             end if;
 
             return
-              Make_And_Then (Loc,
-                Left_Opnd =>
-                  Make_Op_Ge (Loc,
-                    Left_Opnd =>
-                      Unchecked_Convert_To (Btyp, Temp),
-
-                    Right_Opnd =>
+              Make_In (Loc,
+                Left_Opnd  =>
+                  Unchecked_Convert_To (Btyp, Temp),
+                Right_Opnd =>
+                  Make_Range (Loc,
+                    Low_Bound =>
                       Unchecked_Convert_To (Btyp,
                         Make_Attribute_Reference (Loc,
                           Prefix => New_Occurrence_Of (Ptyp, Loc),
-                          Attribute_Name => Name_First))),
-
-                Right_Opnd =>
-                  Make_Op_Le (Loc,
-                    Left_Opnd =>
-                      Unchecked_Convert_To (Btyp, Temp),
-
-                    Right_Opnd =>
+                          Attribute_Name => Name_First)),
+                    High_Bound =>
                       Unchecked_Convert_To (Btyp,
                         Make_Attribute_Reference (Loc,
                           Prefix => New_Occurrence_Of (Ptyp, Loc),
Index: a-except-2005.adb
===================================================================
--- a-except-2005.adb	(revision 165803)
+++ a-except-2005.adb	(working copy)
@@ -469,6 +469,8 @@  package body Ada.Exceptions is
      (File : System.Address; Line, Column : Integer);
    procedure Rcheck_05_Ext
      (File : System.Address; Line, Column, Index, First, Last : Integer);
+   procedure Rcheck_06_Ext
+     (File : System.Address; Line, Column, Index, First, Last : Integer);
    procedure Rcheck_12_Ext
      (File : System.Address; Line, Column, Index, First, Last : Integer);
 
@@ -509,6 +511,7 @@  package body Ada.Exceptions is
 
    pragma Export (C, Rcheck_00_Ext, "__gnat_rcheck_00_ext");
    pragma Export (C, Rcheck_05_Ext, "__gnat_rcheck_05_ext");
+   pragma Export (C, Rcheck_06_Ext, "__gnat_rcheck_06_ext");
    pragma Export (C, Rcheck_12_Ext, "__gnat_rcheck_12_ext");
 
    --  None of these procedures ever returns (they raise an exception!). By
@@ -551,6 +554,7 @@  package body Ada.Exceptions is
 
    pragma No_Return (Rcheck_00_Ext);
    pragma No_Return (Rcheck_05_Ext);
+   pragma No_Return (Rcheck_06_Ext);
    pragma No_Return (Rcheck_12_Ext);
 
    ---------------------------------------------
@@ -1236,6 +1240,17 @@  package body Ada.Exceptions is
       Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
    end Rcheck_05_Ext;
 
+   procedure Rcheck_06_Ext
+     (File : System.Address; Line, Column, Index, First, Last : Integer)
+   is
+      Msg : constant String :=
+              Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF &
+              "value " & Image (Index) & " not in " & Image (First) &
+              ".." & Image (Last) & ASCII.NUL;
+   begin
+      Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address);
+   end Rcheck_06_Ext;
+
    procedure Rcheck_12_Ext
      (File : System.Address; Line, Column, Index, First, Last : Integer)
    is
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c	(revision 165803)
+++ gcc-interface/trans.c	(working copy)
@@ -482,8 +482,9 @@  gigi (Node_Id gnat_root, int max_gnat_no
 	gnat_raise_decls_ext[i]
 	  = build_raise_check (i, t,
 			       i == CE_Index_Check_Failed
-			       || i == CE_Range_Check_Failed ?
-			       exception_range : exception_column);
+			       || i == CE_Range_Check_Failed
+			       || i == CE_Invalid_Data
+			       ? exception_range : exception_column);
     }
 
   /* Set the types that GCC and Gigi use from the front end.  */
@@ -5518,7 +5519,8 @@  gnat_to_gnu (Node_Id gnat_node)
 		gnu_result = build_call_raise_column (reason, gnat_node);
 	      }
 	    else if ((reason == CE_Index_Check_Failed
-		      || reason == CE_Range_Check_Failed)
+		      || reason == CE_Range_Check_Failed
+		      || reason == CE_Invalid_Data)
 		     && Nkind (cond) == N_Op_Not
 		     && Nkind (Right_Opnd (cond)) == N_In
 		     && Nkind (Right_Opnd (Right_Opnd (cond))) == N_Range)