Patchwork [Ada] Crash on private enumeration type when compiling with -gnatVa

login
register
mail settings
Submitter Arnaud Charlet
Date July 23, 2012, 8:29 a.m.
Message ID <20120723082953.GA18938@adacore.com>
Download mbox | patch
Permalink /patch/172579/
State New
Headers show

Comments

Arnaud Charlet - July 23, 2012, 8:29 a.m.
This patch corrects the retrieval of the base type of an enumeration subtype.
In certain cases the base type may be a private type, therefore the compiler
must inspect its full view.

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

2012-07-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb (Determine_Range): Add local variable Btyp. Handle
	the case where the base type of an enumeration subtype is
	private. Replace all occurrences of Base_Type with Btyp.
	* exp_attr.adb (Attribute_Valid): Handle the case where the
	base type of an enumeration subtype is private. Replace all
	occurrences of Base_Type with Btyp.
	* sem_util.adb (Get_Enum_Lit_From_Pos): Add local variable
	Btyp. Handle the case where the base type of an enumeration
	subtype is private. Replace all occurrences of Base_Type with
	Btyp.

Patch

Index: exp_attr.adb
===================================================================
--- exp_attr.adb	(revision 189768)
+++ exp_attr.adb	(working copy)
@@ -5372,6 +5372,13 @@ 
 
          Validity_Checks_On := False;
 
+         --  Retrieve the base type. Handle the case where the base type is a
+         --  private enumeration type.
+
+         if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
+            Btyp := Full_View (Btyp);
+         end if;
+
          --  Floating-point case. This case is handled by the Valid attribute
          --  code in the floating-point attribute run-time library.
 
@@ -5472,15 +5479,14 @@ 
          --       (X >= type(X)'First and then type(X)'Last <= X)
 
          elsif Is_Enumeration_Type (Ptyp)
-           and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
+           and then Present (Enum_Pos_To_Rep (Btyp))
          then
             Tst :=
               Make_Op_Ge (Loc,
                 Left_Opnd =>
                   Make_Function_Call (Loc,
                     Name =>
-                      New_Reference_To
-                        (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
+                      New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc),
                     Parameter_Associations => New_List (
                       Pref,
                       New_Occurrence_Of (Standard_False, Loc))),
Index: checks.adb
===================================================================
--- checks.adb	(revision 189768)
+++ checks.adb	(working copy)
@@ -3151,6 +3151,9 @@ 
       Cindex : Cache_Index;
       --  Used to search cache
 
+      Btyp : Entity_Id;
+      --  Base type
+
       function OK_Operands return Boolean;
       --  Used for binary operators. Determines the ranges of the left and
       --  right operands, and if they are both OK, returns True, and puts
@@ -3267,6 +3270,15 @@ 
          Typ := Underlying_Type (Base_Type (Typ));
       end if;
 
+      --  Retrieve the base type. Handle the case where the base type is a
+      --  private enumeration type.
+
+      Btyp := Base_Type (Typ);
+
+      if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
+         Btyp := Full_View (Btyp);
+      end if;
+
       --  We use the actual bound unless it is dynamic, in which case use the
       --  corresponding base type bound if possible. If we can't get a bound
       --  then we figure we can't determine the range (a peculiar case, that
@@ -3280,8 +3292,8 @@ 
       if Compile_Time_Known_Value (Bound) then
          Lo := Expr_Value (Bound);
 
-      elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then
-         Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
+      elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then
+         Lo := Expr_Value (Type_Low_Bound (Btyp));
 
       else
          OK := False;
@@ -3296,8 +3308,8 @@ 
       --  always be compile time known. Again, it is not clear that this
       --  can ever be false, but no point in bombing.
 
-      if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then
-         Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ)));
+      if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then
+         Hbound := Expr_Value (Type_High_Bound (Btyp));
          Hi := Hbound;
 
       else
@@ -4744,17 +4756,17 @@ 
             --  associated subtype.
 
             Insert_Action (N,
-               Make_Raise_Constraint_Error (Loc,
-                 Condition =>
-                    Make_Not_In (Loc,
-                      Left_Opnd  =>
-                        Convert_To (Base_Type (Etype (Sub)),
-                          Duplicate_Subexpr_Move_Checks (Sub)),
-                      Right_Opnd =>
-                        Make_Attribute_Reference (Loc,
-                          Prefix         => New_Reference_To (Etype (A), Loc),
-                          Attribute_Name => Name_Range)),
-                 Reason => CE_Index_Check_Failed));
+              Make_Raise_Constraint_Error (Loc,
+                Condition =>
+                   Make_Not_In (Loc,
+                     Left_Opnd  =>
+                       Convert_To (Base_Type (Etype (Sub)),
+                         Duplicate_Subexpr_Move_Checks (Sub)),
+                     Right_Opnd =>
+                       Make_Attribute_Reference (Loc,
+                         Prefix         => New_Reference_To (Etype (A), Loc),
+                         Attribute_Name => Name_Range)),
+                Reason => CE_Index_Check_Failed));
          end if;
 
       --  General case
@@ -4831,14 +4843,14 @@ 
                   end if;
 
                   Insert_Action (N,
-                     Make_Raise_Constraint_Error (Loc,
-                       Condition =>
-                          Make_Not_In (Loc,
-                            Left_Opnd  =>
-                              Convert_To (Base_Type (Etype (Sub)),
-                                Duplicate_Subexpr_Move_Checks (Sub)),
-                            Right_Opnd => Range_N),
-                       Reason => CE_Index_Check_Failed));
+                    Make_Raise_Constraint_Error (Loc,
+                      Condition =>
+                         Make_Not_In (Loc,
+                           Left_Opnd  =>
+                             Convert_To (Base_Type (Etype (Sub)),
+                               Duplicate_Subexpr_Move_Checks (Sub)),
+                           Right_Opnd => Range_N),
+                      Reason => CE_Index_Check_Failed));
                end if;
 
                A_Idx := Next_Index (A_Idx);
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 189768)
+++ sem_util.adb	(working copy)
@@ -4500,7 +4500,8 @@ 
       Pos : Uint;
       Loc : Source_Ptr) return Node_Id
    is
-      Lit : Node_Id;
+      Btyp : Entity_Id := Base_Type (T);
+      Lit  : Node_Id;
 
    begin
       --  In the case where the literal is of type Character, Wide_Character
@@ -4522,7 +4523,11 @@ 
       --
 
       else
-         Lit := First_Literal (Base_Type (T));
+         if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
+            Btyp := Full_View (Btyp);
+         end if;
+
+         Lit := First_Literal (Btyp);
          for J in 1 .. UI_To_Int (Pos) loop
             Next_Literal (Lit);
          end loop;