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 <kirtc...@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.
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;