From d7a44b14423c7751db39957227377d5909fde72e Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 23 Jul 2012 10:29:15 +0200 Subject: [PATCH] [multiple changes] 2012-07-23 Ed Schonberg * sem_ch4.adb (Analyze_Selected_Component): When checking for potential ambiguities with class-wide operations on synchronized types, attach the copied node properly to the tree, to prevent errors during expansion. 2012-07-23 Yannick Moy * sem_ch5.adb (Analyze_Loop_Statement): Make sure the loop body is analyzed in Alfa mode. 2012-07-23 Ed Schonberg * sem_res.adb: Adjust previous change. 2012-07-23 Vincent Pucci * sem_ch9.adb (Allows_Lock_Free_Implementation): Flag Lock_Free_Given renames previous flag Complain. Description updated. Henceforth, catch every error messages issued by this routine when Lock_Free_Given is True. Declaration restriction updated: No non-elementary parameter instead (even in parameter) New subprogram body restrictions implemented: No allocator, no address, import or export rep items, no delay statement, no goto statement, no quantified expression and no dereference of access value. 2012-07-23 Hristian Kirtchev * 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. From-SVN: r189775 --- gcc/ada/ChangeLog | 41 ++++++++ gcc/ada/checks.adb | 58 ++++++----- gcc/ada/exp_attr.adb | 12 ++- gcc/ada/exp_ch9.adb | 6 +- gcc/ada/sem_ch4.adb | 18 +++- gcc/ada/sem_ch5.adb | 10 +- gcc/ada/sem_ch9.adb | 275 +++++++++++++++++++++++++++++++++++++++++---------- gcc/ada/sem_res.adb | 7 +- gcc/ada/sem_util.adb | 9 +- 9 files changed, 342 insertions(+), 94 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c504dea..a25e8e1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,46 @@ 2012-07-23 Ed Schonberg + * sem_ch4.adb (Analyze_Selected_Component): When checking for + potential ambiguities with class-wide operations on synchronized + types, attach the copied node properly to the tree, to prevent + errors during expansion. + +2012-07-23 Yannick Moy + + * sem_ch5.adb (Analyze_Loop_Statement): Make sure the loop body + is analyzed in Alfa mode. + +2012-07-23 Ed Schonberg + + * sem_res.adb: Adjust previous change. + +2012-07-23 Vincent Pucci + + * sem_ch9.adb (Allows_Lock_Free_Implementation): Flag + Lock_Free_Given renames previous flag Complain. Description + updated. Henceforth, catch every error messages issued by this + routine when Lock_Free_Given is True. Declaration restriction + updated: No non-elementary parameter instead (even in parameter) + New subprogram body restrictions implemented: No allocator, + no address, import or export rep items, no delay statement, + no goto statement, no quantified expression and no dereference + of access value. + +2012-07-23 Hristian Kirtchev + + * 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. + +2012-07-23 Ed Schonberg + * par-ch6.adb (P_Mode): in Ada 2005, a mode indicator can apply to a formal object of an anonymous access type. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 195b69e..6ac5533 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -3151,6 +3151,9 @@ package body Checks is 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 @@ package body Checks is 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 @@ package body Checks is 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 @@ package body Checks is -- 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 @@ package body Checks is -- 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 @@ package body Checks is 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); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 69c77a8..ae7def7 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5372,6 +5372,13 @@ package body Exp_Attr is 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 @@ package body Exp_Attr is -- (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))), diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 2930604..c8a3094 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -3188,7 +3188,7 @@ package body Exp_Ch9 is Rewrite (Stmt, Make_Implicit_If_Statement (N, - Condition => + Condition => Make_Function_Call (Loc, Name => New_Reference_To (Try_Write, Loc), @@ -3379,9 +3379,9 @@ package body Exp_Ch9 is Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Defining_Identifier (Comp_Decl), - Subtype_Mark => + Subtype_Mark => New_Occurrence_Of (Comp_Type, Loc), - Name => + Name => New_Reference_To (Desired_Comp, Loc))); -- Wrap any return or raise statements in Stmts in same the manner diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 843f67b..ed046f4 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4222,13 +4222,21 @@ package body Sem_Ch4 is -- Duplicate the call. This is required to avoid problems with -- the tree transformations performed by Try_Object_Operation. + -- Set properly the parent of the copied call, because it is + -- about to be reanalyzed. - and then - Try_Object_Operation - (N => Sinfo.Name (New_Copy_Tree (Parent (N))), - CW_Test_Only => True) then - return; + declare + Par : constant Node_Id := New_Copy_Tree (Parent (N)); + + begin + Set_Parent (Par, Parent (Parent (N))); + if Try_Object_Operation + (Sinfo.Name (Par), CW_Test_Only => True) + then + return; + end if; + end; end if; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 749393b..da0e901 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2633,14 +2633,14 @@ package body Sem_Ch5 is -- types the actual subtype of the components will only be determined -- when the cursor declaration is analyzed. - -- If the expander is not active, then we want to analyze the loop body - -- now even in the Ada 2012 iterator case, since the rewriting will not - -- be done. Insert the loop variable in the current scope, if not done - -- when analysing the iteration scheme. + -- If the expander is not active, or in Alfa mode, then we want to + -- analyze the loop body now even in the Ada 2012 iterator case, since + -- the rewriting will not be done. Insert the loop variable in the + -- current scope, if not done when analysing the iteration scheme. if No (Iter) or else No (Iterator_Specification (Iter)) - or else not Expander_Active + or else not Full_Expander_Active then if Present (Iter) and then Present (Iterator_Specification (Iter)) diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 49a163b..1420ba8 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -68,24 +69,30 @@ package body Sem_Ch9 is function Allows_Lock_Free_Implementation (N : Node_Id; - Complain : Boolean := False) return Boolean; + Lock_Free_Given : Boolean := False) return Boolean; -- This routine returns True iff N satisfies the following list of lock- -- free restrictions for protected type declaration and protected body: -- -- 1) Protected type declaration -- May not contain entries - -- Component types must support atomic compare and exchange + -- Protected subprogram declarations may not have non-elementary + -- parameters. -- -- 2) Protected Body -- Each protected subprogram body within N must satisfy: -- May reference only one protected component -- May not reference non-constant entities outside the protected -- subprogram scope. - -- May not reference non-elementary out parameters - -- May not contain loop statements or procedure calls + -- May not contain address representation items, allocators and + -- quantified expressions. + -- May not contain delay, goto, loop and procedure call + -- statements. + -- May not contain exported and imported entities + -- May not dereference access values -- Function calls and attribute references must be static -- - -- If Complain is True, an error message is issued when False is returned + -- If Lock_Free_Given is True, an error message is issued when False is + -- returned. procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); -- Given either a protected definition or a task definition in D, check @@ -115,22 +122,32 @@ package body Sem_Ch9 is ------------------------------------- function Allows_Lock_Free_Implementation - (N : Node_Id; - Complain : Boolean := False) return Boolean + (N : Node_Id; + Lock_Free_Given : Boolean := False) return Boolean is + Errors_Count : Nat; + -- Errors_Count is a count of errors detected by the compiler so far + -- when Lock_Free_Given is True. + begin pragma Assert (Nkind_In (N, N_Protected_Type_Declaration, N_Protected_Body)); -- The lock-free implementation is currently enabled through a debug - -- flag. When Complain is True, an aspect Lock_Free forces the lock-free - -- implementation. In that case, the debug flag is not needed. + -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the + -- lock-free implementation. In that case, the debug flag is not needed. - if not Complain and then not Debug_Flag_9 then + if not Lock_Free_Given and then not Debug_Flag_9 then return False; end if; + -- Get the number of errors detected by the compiler so far + + if Lock_Free_Given then + Errors_Count := Serious_Errors_Detected; + end if; + -- Protected type declaration case if Nkind (N) = N_Protected_Type_Declaration then @@ -150,14 +167,14 @@ package body Sem_Ch9 is -- restrictions. if Nkind (Decl) = N_Entry_Declaration then - if Complain then + if Lock_Free_Given then Error_Msg_N ("entry not allowed when Lock_Free given", Decl); + else + return False; end if; - return False; - - -- Non-elementary out parameters in protected procedure are not + -- Non-elementary parameters in protected procedure are not -- allowed by the lock-free restrictions. elsif Nkind (Decl) = N_Subprogram_Declaration @@ -176,18 +193,17 @@ package body Sem_Ch9 is begin Par := First (Par_Specs); while Present (Par) loop - if Out_Present (Par) - and then not Is_Elementary_Type - (Etype (Parameter_Type (Par))) + if not Is_Elementary_Type + (Etype (Defining_Identifier (Par))) then - if Complain then + if Lock_Free_Given then Error_Msg_NE - ("non-elementary out parameter& not allowed " + ("non-elementary parameter& not allowed " & "when Lock_Free given", Par, Defining_Identifier (Par)); + else + return False; end if; - - return False; end if; Next (Par); @@ -240,6 +256,10 @@ package body Sem_Ch9 is Comp : Entity_Id := Empty; -- Track the current component which the body references + Errors_Count : Nat; + -- Errors_Count is a count of errors detected by the compiler + -- so far when Lock_Free_Given is True. + function Check_Node (N : Node_Id) return Traverse_Result; -- Check that node N meets the lock free restrictions @@ -248,6 +268,7 @@ package body Sem_Ch9 is ---------------- function Check_Node (N : Node_Id) return Traverse_Result is + Kind : constant Node_Kind := Nkind (N); -- The following function belongs in sem_eval ??? @@ -310,51 +331,123 @@ package body Sem_Ch9 is begin if Is_Procedure then - -- Attribute references must be static or denote a static - -- function. + -- Allocators restricted + + if Kind = N_Allocator then + if Lock_Free_Given then + Error_Msg_N ("allocator not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Aspects Address, Export and Import restricted + + elsif Kind = N_Aspect_Specification then + declare + Asp_Name : constant Name_Id := + Chars (Identifier (N)); + Asp_Id : constant Aspect_Id := + Get_Aspect_Id (Asp_Name); + + begin + if Asp_Id = Aspect_Address + or else Asp_Id = Aspect_Export + or else Asp_Id = Aspect_Import + then + Error_Msg_Name_1 := Asp_Name; + + if Lock_Free_Given then + Error_Msg_N ("aspect% not allowed", N); + return Skip; + end if; + + return Abandon; + end if; + end; + + -- Address attribute definition clause restricted + + elsif Kind = N_Attribute_Definition_Clause + and then Get_Attribute_Id (Chars (N)) = + Attribute_Address + then + Error_Msg_Name_1 := Chars (N); + + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("% clause not allowed", N); + end if; + + return Skip; + end if; + + return Abandon; - if Nkind (N) = N_Attribute_Reference + -- Non-static Attribute references that don't denote a + -- static function restricted. + + elsif Kind = N_Attribute_Reference and then not Is_Static_Expression (N) and then not Is_Static_Function (N) then - if Complain then + if Lock_Free_Given then Error_Msg_N ("non-static attribute reference not allowed", N); + return Skip; end if; return Abandon; - -- Function calls must be static + -- Delay statements restricted - elsif Nkind (N) = N_Function_Call - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N ("non-static function call not allowed", - N); + elsif Kind in N_Delay_Statement then + if Lock_Free_Given then + Error_Msg_N ("delay not allowed", N); + return Skip; end if; return Abandon; - -- Loop statements and procedure calls are prohibited + -- Explicit dereferences restricted (i.e. dereferences of + -- access values). - elsif Nkind (N) = N_Loop_Statement then - if Complain then - Error_Msg_N ("loop not allowed", N); + elsif Kind = N_Explicit_Dereference then + if Lock_Free_Given then + Error_Msg_N ("explicit dereference not allowed", N); + return Skip; end if; return Abandon; - elsif Nkind (N) = N_Procedure_Call_Statement then - if Complain then - Error_Msg_N ("procedure call not allowed", N); + -- Non-static function calls restricted + + elsif Kind = N_Function_Call + and then not Is_Static_Expression (N) + then + if Lock_Free_Given then + Error_Msg_N ("non-static function call not allowed", + N); + return Skip; + end if; + + return Abandon; + + -- Goto statements restricted + + elsif Kind = N_Goto_Statement then + if Lock_Free_Given then + Error_Msg_N ("goto statement not allowed", N); + return Skip; end if; return Abandon; -- References - elsif Nkind (N) = N_Identifier + elsif Kind = N_Identifier and then Present (Entity (N)) then declare @@ -372,15 +465,75 @@ package body Sem_Ch9 is and then not Scope_Within_Or_Same (Scope (Id), Protected_Body_Subprogram (Sub_Id)) then - if Complain then + if Lock_Free_Given then Error_Msg_NE ("reference to global variable& not " & "allowed", N, Id); + return Skip; + end if; + + return Abandon; + end if; + end; + + -- Loop statements restricted + + elsif Kind = N_Loop_Statement then + if Lock_Free_Given then + Error_Msg_N ("loop not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Pragmas Export and Import restricted + + elsif Kind = N_Pragma then + declare + Prag_Name : constant Name_Id := Pragma_Name (N); + Prag_Id : constant Pragma_Id := + Get_Pragma_Id (Prag_Name); + + begin + if Prag_Id = Pragma_Export + or else Prag_Id = Pragma_Import + then + Error_Msg_Name_1 := Prag_Name; + + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("pragma% not allowed", N); + end if; + + return Skip; end if; return Abandon; end if; end; + + -- Procedure call statements restricted + + elsif Kind = N_Procedure_Call_Statement then + if Lock_Free_Given then + Error_Msg_N ("procedure call not allowed", N); + return Skip; + end if; + + return Abandon; + + -- Quantified expression restricted + + elsif Kind = N_Quantified_Expression then + if Lock_Free_Given then + Error_Msg_N ("quantified expression not allowed", + N); + return Skip; + end if; + + return Abandon; end if; end if; @@ -388,7 +541,7 @@ package body Sem_Ch9 is -- reference only one component of the protected type, plus -- the type of the component must support atomic operation. - if Nkind (N) = N_Identifier + if Kind = N_Identifier and then Present (Entity (N)) then declare @@ -441,11 +594,12 @@ package body Sem_Ch9 is when 8 | 16 | 32 | 64 => null; when others => - if Complain then + if Lock_Free_Given then Error_Msg_NE ("type of& must support atomic " & "operations", N, Comp_Id); + return Skip; end if; return Abandon; @@ -458,10 +612,11 @@ package body Sem_Ch9 is Comp := Comp_Id; elsif Comp /= Comp_Id then - if Complain then + if Lock_Free_Given then Error_Msg_N ("only one protected component allowed", N); + return Skip; end if; return Abandon; @@ -479,7 +634,16 @@ package body Sem_Ch9 is -- Start of processing for Satisfies_Lock_Free_Requirements begin - if Check_All_Nodes (Sub_Body) = OK then + -- Get the number of errors detected by the compiler so far + + if Lock_Free_Given then + Errors_Count := Serious_Errors_Detected; + end if; + + if Check_All_Nodes (Sub_Body) = OK + and then (not Lock_Free_Given + or else Errors_Count = Serious_Errors_Detected) + then -- Establish a relation between the subprogram body and the -- unique protected component it references. @@ -503,12 +667,12 @@ package body Sem_Ch9 is if Nkind (Decl) = N_Subprogram_Body and then not Satisfies_Lock_Free_Requirements (Decl) then - if Complain then + if Lock_Free_Given then Error_Msg_N - ("body not allowed when Lock_Free given", Decl); + ("illegal body when Lock_Free given", Decl); + else + return False; end if; - - return False; end if; Next (Decl); @@ -516,6 +680,15 @@ package body Sem_Ch9 is end Protected_Body_Case; end if; + -- When Lock_Free is given, check if no error has been detected during + -- the process. + + if Lock_Free_Given + and then Errors_Count /= Serious_Errors_Detected + then + return False; + end if; + return True; end Allows_Lock_Free_Implementation; @@ -1611,7 +1784,7 @@ package body Sem_Ch9 is -- otherwise Allows_Lock_Free_Implementation issues an error message. if Uses_Lock_Free (Spec_Id) then - if not Allows_Lock_Free_Implementation (N, Complain => True) then + if not Allows_Lock_Free_Implementation (N, True) then return; end if; @@ -1886,7 +2059,7 @@ package body Sem_Ch9 is end if; end; - if not Allows_Lock_Free_Implementation (N, Complain => True) then + if not Allows_Lock_Free_Implementation (N, True) then return; end if; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5f25a86..65c64f2 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7071,7 +7071,8 @@ package body Sem_Res is if Is_Overloaded (P) then -- Use the context type to select the prefix that has the correct - -- designated type. + -- designated type. Keep the first match, which will be the inner- + -- most. Get_First_Interp (P, I, It); @@ -7079,7 +7080,9 @@ package body Sem_Res is if Is_Access_Type (It.Typ) and then Covers (Typ, Designated_Type (It.Typ)) then - P_Typ := It.Typ; + if No (P_Typ) then + P_Typ := It.Typ; + end if; -- Remove access types that do not match, but preserve access -- to subprogram interpretations, in case a further dereference diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index bd53144..8675d54 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4500,7 +4500,8 @@ package body Sem_Util is 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 @@ package body Sem_Util is -- 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; -- 2.7.4