From 9e92ad49739943c6c8dcf6aec4b6eddf90020da4 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 10 Oct 2013 13:07:30 +0200 Subject: [PATCH] [multiple changes] 2013-10-10 Robert Dewar * exp_ch3.adb (Expand_N_Variant_Part): Expand statically predicated subtype which appears in Discrete_Choices list. * exp_ch5.adb (Expand_N_Case_Statement): Expand statically predicated subtype which appears in Discrete_Choices list of case statement alternative. * exp_util.ads, exp_util.adb (Expand_Static_Predicates_In_Choices): New procedure. * sem_case.adb: Minor reformatting (Analyze_Choices): Don't expand out Discrete_Choices that are names of subtypes with static predicates. This is now done in the analyzer so that the -gnatct tree is properly formed for ASIS. * sem_case.ads (Generic_Choices_Processing): Does not apply to aggregates any more, so change doc accordingly, and remove unneeded Get_Choices argument. * sem_ch3.adb (Analyze_Variant_Part): Remove no longer used Get_Choices argument in instantiation of Generic_Choices_Processing. * sem_ch4.adb (Analyze_Case_Expression): Remove no longer used Get_Choices argument in instantiation of Generic_Choices_Processing. * sem_ch5.adb (Analyze_Case_Statement): Remove no longer used Get_Choices argument in instantiation of Generic_Choices_Processing. * sinfo.ads: For N_Variant_Part, and N_Case_Statement_Alternative, document that choices that are names of statically predicated subtypes are expanded in the code generation tree passed to the back end, but not in the ASIS tree generated for -gnatct. 2013-10-10 Ed Schonberg * sem_ch7.adb: Revert previous change. 2013-10-10 Gary Dismukes * sem_ch13.adb (Analyze_Attribute_Definition_Clause): In the case where the Storage_Pool aspect is specified by an aspect clause and a renaming is used to capture the evaluation of the pool name, insert the renaming in front of the aspect's associated entity declaration rather than in front of the corresponding attribute definition (which hasn't been appended to the declaration list yet). 2013-10-10 Ed Schonberg * sem_ch6.adb (Is_Interface_Conformant): The controlling type of the interface operation is obtained from the ultimate alias of the interface primitive parameter, because that may be in fact an implicit inherited operation whose signature involves the type extension and not the desired interface. 2013-10-10 Ed Schonberg * par-ch13.adb (Aspect_Specifications_Present): In Ada 2012, recognize an aspect specification with a misspelled name if it is followed by a a comma or semicolon. 2013-10-10 Vadim Godunko * s-atocou.adb, s-atocou.ads, s-atocou-x86.adb, s-atocou-builtin.adb: Fix copyright notice. 2013-10-10 Yannick Moy * lib-xref-spark_specific.adb (Enclosing_Subprogram_Or_Package): Get enclosing subprogram for precondition/postcondition/contract cases. From-SVN: r203350 --- gcc/ada/ChangeLog | 68 +++++++++++++++++++++++++++++++++++++ gcc/ada/exp_ch3.adb | 26 ++++++++++---- gcc/ada/exp_ch5.adb | 18 ++++++---- gcc/ada/exp_util.adb | 63 ++++++++++++++++++++++++++++++++++ gcc/ada/exp_util.ads | 6 ++++ gcc/ada/lib-xref-spark_specific.adb | 23 +++++++++---- gcc/ada/par-ch13.adb | 10 ++++-- gcc/ada/s-atocou-builtin.adb | 2 +- gcc/ada/s-atocou-x86.adb | 2 +- gcc/ada/s-atocou.adb | 2 +- gcc/ada/s-atocou.ads | 2 +- gcc/ada/sem_case.adb | 57 ++++++++++++++----------------- gcc/ada/sem_case.ads | 36 ++++++++------------ gcc/ada/sem_ch13.adb | 12 ++++++- gcc/ada/sem_ch3.adb | 1 - gcc/ada/sem_ch4.adb | 6 ++-- gcc/ada/sem_ch5.adb | 1 - gcc/ada/sem_ch6.adb | 9 +++-- gcc/ada/sem_ch7.adb | 21 ++++-------- gcc/ada/sinfo.ads | 12 +++++++ 20 files changed, 275 insertions(+), 102 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 816aab3..fa6cf6b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,73 @@ 2013-10-10 Robert Dewar + * exp_ch3.adb (Expand_N_Variant_Part): Expand statically + predicated subtype which appears in Discrete_Choices list. + * exp_ch5.adb (Expand_N_Case_Statement): Expand statically + predicated subtype which appears in Discrete_Choices list of + case statement alternative. + * exp_util.ads, exp_util.adb (Expand_Static_Predicates_In_Choices): New + procedure. + * sem_case.adb: Minor reformatting (Analyze_Choices): Don't + expand out Discrete_Choices that are names of subtypes with + static predicates. This is now done in the analyzer so that the + -gnatct tree is properly formed for ASIS. + * sem_case.ads (Generic_Choices_Processing): Does not apply + to aggregates any more, so change doc accordingly, and remove + unneeded Get_Choices argument. + * sem_ch3.adb (Analyze_Variant_Part): Remove no + longer used Get_Choices argument in instantiation of + Generic_Choices_Processing. + * sem_ch4.adb (Analyze_Case_Expression): Remove no + longer used Get_Choices argument in instantiation of + Generic_Choices_Processing. + * sem_ch5.adb (Analyze_Case_Statement): Remove no + longer used Get_Choices argument in instantiation of + Generic_Choices_Processing. + * sinfo.ads: For N_Variant_Part, and N_Case_Statement_Alternative, + document that choices that are names of statically predicated + subtypes are expanded in the code generation tree passed to the + back end, but not in the ASIS tree generated for -gnatct. + +2013-10-10 Ed Schonberg + + * sem_ch7.adb: Revert previous change. + +2013-10-10 Gary Dismukes + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): In the case where + the Storage_Pool aspect is specified by an aspect clause and a + renaming is used to capture the evaluation of the pool name, + insert the renaming in front of the aspect's associated entity + declaration rather than in front of the corresponding attribute + definition (which hasn't been appended to the declaration + list yet). + +2013-10-10 Ed Schonberg + + * sem_ch6.adb (Is_Interface_Conformant): The controlling type + of the interface operation is obtained from the ultimate alias + of the interface primitive parameter, because that may be in + fact an implicit inherited operation whose signature involves + the type extension and not the desired interface. + +2013-10-10 Ed Schonberg + + * par-ch13.adb (Aspect_Specifications_Present): In Ada 2012, + recognize an aspect specification with a misspelled name if it + is followed by a a comma or semicolon. + +2013-10-10 Vadim Godunko + + * s-atocou.adb, s-atocou.ads, s-atocou-x86.adb, s-atocou-builtin.adb: + Fix copyright notice. + +2013-10-10 Yannick Moy + + * lib-xref-spark_specific.adb (Enclosing_Subprogram_Or_Package): Get + enclosing subprogram for precondition/postcondition/contract cases. + +2013-10-10 Robert Dewar + * gnat_rm.texi: Minor fix. 2013-10-10 Robert Dewar diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index a21de7e..bc4557d 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5846,23 +5846,35 @@ package body Exp_Ch3 is -- Expand_N_Variant_Part -- --------------------------- - -- If the last variant does not contain the Others choice, replace it with - -- an N_Others_Choice node since Gigi always wants an Others. Note that we - -- do not bother to call Analyze on the modified variant part, since its - -- only effect would be to compute the Others_Discrete_Choices node - -- laboriously, and of course we already know the list of choices that - -- corresponds to the others choice (it's the list we are replacing!) - procedure Expand_N_Variant_Part (N : Node_Id) is Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); Others_Node : Node_Id; + Variant : Node_Id; + begin + -- If the last variant does not contain the Others choice, replace it + -- with an N_Others_Choice node since Gigi always wants an Others. Note + -- that we do not bother to call Analyze on the modified variant part, + -- since its only effect would be to compute the Others_Discrete_Choices + -- node laboriously, and of course we already know the list of choices + -- corresponding to the others choice (it's the list we're replacing!) + if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then Others_Node := Make_Others_Choice (Sloc (Last_Var)); Set_Others_Discrete_Choices (Others_Node, Discrete_Choices (Last_Var)); Set_Discrete_Choices (Last_Var, New_List (Others_Node)); end if; + + -- Deal with any static predicates in the variant choices. Note that we + -- don't have to look at the last variant, since we know it is an others + -- choice, because we just rewrote it that way if necessary. + + Variant := First_Non_Pragma (Variants (N)); + while Variant /= Last_Var loop + Expand_Static_Predicates_In_Choices (Variant); + Next_Non_Pragma (Variant); + end loop; end Expand_N_Variant_Part; --------------------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 95e649a..b8b4038 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2537,7 +2537,11 @@ package body Exp_Ch5 is -- if statement, since this can result in subsequent optimizations. -- This helps not only with case statements in the source of a -- simple form, but also with generated code (discriminant check - -- functions in particular) + -- functions in particular). + + -- Note: it is OK to do this before expanding out choices for any + -- static predicates, since the if statement processing will handle + -- the static predicate case fine. elsif Len = 2 then Chlist := Discrete_Choices (First (Alternatives (N))); @@ -2617,12 +2621,14 @@ package body Exp_Ch5 is Set_Discrete_Choices (Last_Alt, New_List (Others_Node)); end if; - Alt := First (Alternatives (N)); - while Present (Alt) - and then Nkind (Alt) = N_Case_Statement_Alternative - loop + -- Deal with possible declarations of controlled objects, and also + -- with rewriting choice sequences for static predicate references. + + Alt := First_Non_Pragma (Alternatives (N)); + while Present (Alt) loop Process_Statements_For_Controlled_Objects (Alt); - Next (Alt); + Expand_Static_Predicates_In_Choices (Alt); + Next_Non_Pragma (Alt); end loop; end; end Expand_N_Case_Statement; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 795aaf4..a958b9f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1946,6 +1946,69 @@ package body Exp_Util is end if; end Evolve_Or_Else; + ----------------------------------------- + -- Expand_Static_Predicates_In_Choices -- + ----------------------------------------- + + procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is + pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant)); + + Choices : constant List_Id := Discrete_Choices (N); + + Choice : Node_Id; + Next_C : Node_Id; + P : Node_Id; + C : Node_Id; + + begin + Choice := First (Choices); + while Present (Choice) loop + Next_C := Next (Choice); + + -- Check for name of subtype with static predicate + + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + and then Has_Predicates (Entity (Choice)) + then + -- Loop through entries in predicate list, converting to choices + -- and inserting in the list before the current choice. Note that + -- if the list is empty, corresponding to a False predicate, then + -- no choices are inserted. + + P := First (Static_Predicate (Entity (Choice))); + while Present (P) loop + + -- If low bound and high bounds are equal, copy simple choice + + if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then + C := New_Copy (Low_Bound (P)); + + -- Otherwise copy a range + + else + C := New_Copy (P); + end if; + + -- Change Sloc to referencing choice (rather than the Sloc of + -- the predicate declarationo element itself). + + Set_Sloc (C, Sloc (Choice)); + Insert_Before (Choice, C); + Next (P); + end loop; + + -- Delete the predicated entry + + Remove (Choice); + end if; + + -- Move to next choice to check + + Choice := Next_C; + end loop; + end Expand_Static_Predicates_In_Choices; + ------------------------------ -- Expand_Subtype_From_Expr -- ------------------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 568b9f7..7ca7c01 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -377,6 +377,12 @@ package Exp_Util is -- indicating that no checks were required). The Sloc field of the -- constructed N_Or_Else node is copied from Cond1. + procedure Expand_Static_Predicates_In_Choices (N : Node_Id); + -- N is either a case alternative or a variant. The Discrete_Choices field + -- of N points to a list of choices. If any of these choices is the name + -- of a (statically) predicated subtype, then it is rewritten as the series + -- of choices that correspond to the values allowed for the subtype. + procedure Expand_Subtype_From_Expr (N : Node_Id; Unc_Type : Entity_Id; diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 7841313..e5a007b 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -1020,17 +1020,28 @@ package body SPARK_Specific is Result := Defining_Unit_Name (Specification (Result)); exit; - -- The enclosing subprogram for a pre- or postconditions should be - -- the subprogram to which the pragma is attached. This is not - -- always the case in the AST, as the pragma may be declared after - -- the declaration of the subprogram. Return Empty in this case. - when N_Pragma => + + -- The enclosing subprogram for a precondition, a + -- postcondition, or a contract case should be the subprogram + -- to which the pragma is attached, which can be found by + -- following previous elements in the list to which the + -- pragma belongs. + if Get_Pragma_Id (Result) = Pragma_Precondition or else Get_Pragma_Id (Result) = Pragma_Postcondition + or else + Get_Pragma_Id (Result) = Pragma_Contract_Cases then - return Empty; + if Is_List_Member (Result) + and then Present (Prev (Result)) + then + Result := Prev (Result); + else + Result := Parent (Result); + end if; + else Result := Parent (Result); end if; diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 26b8056..34d2f8f 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -78,15 +78,19 @@ package body Ch13 is -- are in Ada 2012 mode, Strict is False, and we consider that we have -- an aspect specification if the identifier is an aspect name (even if -- not followed by =>) or the identifier is not an aspect name but is - -- followed by =>. P_Aspect_Specifications will generate messages if the - -- aspect specification is ill-formed. + -- followed by =>, by a comma, or by a semicolon. The last two cases + -- correspond to (misspelled) Boolean aspects with a defaulted value of + -- True. P_Aspect_Specifications will generate messages if the aspect + -- specification is ill-formed. elsif not Strict then if Get_Aspect_Id (Token_Name) /= No_Aspect then Result := True; else Scan; -- past identifier - Result := Token = Tok_Arrow; + Result := Token = Tok_Arrow + or else Token = Tok_Comma + or else Token = Tok_Semicolon; end if; -- If earlier than Ada 2012, check for valid aspect identifier (possibly diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb index 5e31c18..a8ead62 100644 --- a/gcc/ada/s-atocou-builtin.adb +++ b/gcc/ada/s-atocou-builtin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, AdaCore -- +-- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-atocou-x86.adb b/gcc/ada/s-atocou-x86.adb index 2281e10..b85b402 100644 --- a/gcc/ada/s-atocou-x86.adb +++ b/gcc/ada/s-atocou-x86.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, AdaCore -- +-- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-atocou.adb b/gcc/ada/s-atocou.adb index 8650fe7..51cc79b 100644 --- a/gcc/ada/s-atocou.adb +++ b/gcc/ada/s-atocou.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, AdaCore -- +-- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-atocou.ads b/gcc/ada/s-atocou.ads index fc2fd43..55d6bf0 100644 --- a/gcc/ada/s-atocou.ads +++ b/gcc/ada/s-atocou.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2013, AdaCore -- +-- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 515d2a6..27a5c67 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -57,9 +57,9 @@ package body Sem_Case is -- to the choice node itself. type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; - -- Table type used to sort the choices present in a case statement, array - -- aggregate or record variant. The actual entries are stored in 1 .. Last, - -- but we have a 0 entry for convenience in sorting. + -- Table type used to sort the choices present in a case statement or + -- record variant. The actual entries are stored in 1 .. Last, but we + -- have a 0 entry for use in sorting. ----------------------- -- Local Subprograms -- @@ -145,8 +145,7 @@ package body Sem_Case is procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint); -- Emit an error message for each non-covered static predicate set. - -- Prev_Hi denotes the upper bound of the last choice that covered a - -- set. + -- Prev_Hi denotes the upper bound of the last choice covering a set. procedure Move_Choice (From : Natural; To : Natural); -- Move routine for sorting the Choice_Table @@ -263,7 +262,6 @@ package body Sem_Case is else Illegal_Range (Loc, Choice_Lo, Choice_Hi); Error := True; - return; end if; @@ -443,21 +441,21 @@ package body Sem_Case is if Nkind (Case_Node) = N_Variant_Part then Error_Msg_NE - ("bounds of & are not static," & - " alternatives must cover base type", Expr, Expr); + ("bounds of & are not static, " + & "alternatives must cover base type!", Expr, Expr); -- If this is a case statement, the expression may be non-static -- or else the subtype may be at fault. elsif Is_Entity_Name (Expr) then Error_Msg_NE - ("bounds of & are not static," & - " alternatives must cover base type", Expr, Expr); + ("bounds of & are not static, " + & "alternatives must cover base type!", Expr, Expr); else Error_Msg_N - ("subtype of expression is not static," - & " alternatives must cover base type!", Expr); + ("subtype of expression is not static, " + & "alternatives must cover base type!", Expr); end if; -- Otherwise the expression is not static, even if the bounds of the @@ -1220,10 +1218,13 @@ package body Sem_Case is if Nkind (Alt) = N_Pragma then Analyze (Alt); - -- Otherwise check each choice against its base type + -- Otherwise we have an alternative. In most cases the semantic + -- processing leaves the list of choices unchanged + + -- Check each choice against its base type else - Choice := First (Get_Choices (Alt)); + Choice := First (Discrete_Choices (Alt)); while Present (Choice) loop Delete_Choice := False; Analyze (Choice); @@ -1260,33 +1261,29 @@ package body Sem_Case is then Bad_Predicated_Subtype_Use ("cannot use subtype& with non-static " - & "predicate as case alternative", Choice, E, - Suggest_Static => True); + & "predicate as case alternative", + Choice, E, Suggest_Static => True); - -- Static predicate case + -- Static predicate case else declare - Copy : constant List_Id := Empty_List; - P : Node_Id; - C : Node_Id; + P : Node_Id; + C : Node_Id; begin -- Loop through entries in predicate list, - -- converting to choices. Note that if the + -- checking each entry. Note that if the -- list is empty, corresponding to a False - -- predicate, then no choices are inserted. + -- predicate, then no choices are checked. P := First (Static_Predicate (E)); while Present (P) loop C := New_Copy (P); Set_Sloc (C, Sloc (Choice)); - Append_To (Copy, C); + Check (C, Low_Bound (C), High_Bound (C)); Next (P); end loop; - - Insert_List_After (Choice, Copy); - Delete_Choice := True; end; end if; @@ -1306,8 +1303,6 @@ package body Sem_Case is Resolve_Discrete_Subtype_Indication (Choice, Expected_Type); - -- Here for other than predicated subtype case - if Etype (Choice) /= Any_Type then declare C : constant Node_Id := Constraint (Choice); @@ -1351,9 +1346,9 @@ package body Sem_Case is -- alternative and as its only choice. elsif Kind = N_Others_Choice then - if not (Choice = First (Get_Choices (Alt)) - and then Choice = Last (Get_Choices (Alt)) - and then Alt = Last (Get_Alternatives (N))) + if not (Choice = First (Discrete_Choices (Alt)) + and then Choice = Last (Discrete_Choices (Alt)) + and then Alt = Last (Get_Alternatives (N))) then Error_Msg_N ("the choice OTHERS must appear alone and last", diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads index ccee41f..d788afe 100644 --- a/gcc/ada/sem_case.ads +++ b/gcc/ada/sem_case.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,28 +40,22 @@ package Sem_Case is generic with function Get_Alternatives (N : Node_Id) return List_Id; - -- Function needed to get to the actual list of case statement - -- alternatives, or array aggregate component associations or - -- record variants from which we can then access the actual lists - -- of discrete choices. N is the node for the original construct - -- i.e. a case statement, an array aggregate or a record variant. - - with function Get_Choices (A : Node_Id) return List_Id; - -- Given a case statement alternative, array aggregate component - -- association or record variant A we need different access functions - -- to get to the actual list of discrete choices. + -- Function used to get the list of case statement alternatives or + -- record variants, from which we can then access the actual lists of + -- discrete choices. N is the node for the original construct (case + -- statement or a record variant). with procedure Process_Empty_Choice (Choice : Node_Id); - -- Processing to carry out for an empty Choice + -- Processing to carry out for an empty Choice. Set to No_Op (declared + -- above) if no such processing is required. with procedure Process_Non_Static_Choice (Choice : Node_Id); -- Processing to carry out for a non static Choice with procedure Process_Associated_Node (A : Node_Id); - -- Associated with each case alternative, aggregate component - -- association or record variant A there is a node or list of nodes - -- that need semantic processing. This routine implements that - -- processing. + -- Associated with each case alternative or record variant A there is + -- a node or list of nodes that need semantic processing. This routine + -- implements that processing. package Generic_Choices_Processing is @@ -70,12 +64,12 @@ package Sem_Case is Subtyp : Entity_Id; Raises_CE : out Boolean; Others_Present : out Boolean); - -- From a case expression, case statement, array aggregate or record - -- variant N, this routine analyzes the corresponding list of discrete - -- choices. Subtyp is the subtype of the discrete choices. The type - -- against which the discrete choices must be resolved is its base type. + -- From a case expression, case statement, or record variant N, this + -- routine analyzes the corresponding list of discrete choices. Subtyp + -- is the subtype of the discrete choices. The type against which the + -- discrete choices must be resolved is its base type. -- - -- In one of the bounds of a discrete choice raises a constraint + -- If one of the bounds of a discrete choice raises a constraint -- error the flag Raise_CE is set. -- -- Finally Others_Present is set to True if an Others choice is present diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 3a6b839..bc2be8b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4381,7 +4381,17 @@ package body Sem_Ch13 is Name => Expr); begin - Insert_Before (N, Rnode); + -- If the attribute definition clause comes from an aspect + -- clause, then insert the renaming before the associated + -- entity's declaration, since the attribute clause has + -- not yet been appended to the declaration list. + + if From_Aspect_Specification (N) then + Insert_Before (Parent (Entity (N)), Rnode); + else + Insert_Before (N, Rnode); + end if; + Analyze (Rnode); Set_Associated_Storage_Pool (U_Ent, Pool); end; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4965288..d230b11 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4602,7 +4602,6 @@ package body Sem_Ch3 is package Variant_Choices_Processing is new Generic_Choices_Processing (Get_Alternatives => Variants, - Get_Choices => Discrete_Choices, Process_Empty_Choice => No_OP, Process_Non_Static_Choice => Non_Static_Choice_Error, Process_Associated_Node => Process_Declarations); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9fcd6ac..0bd5685 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1318,7 +1318,6 @@ package body Sem_Ch4 is package Case_Choices_Processing is new Generic_Choices_Processing (Get_Alternatives => Alternatives, - Get_Choices => Discrete_Choices, Process_Empty_Choice => No_OP, Process_Non_Static_Choice => Non_Static_Choice_Error, Process_Associated_Node => No_OP); @@ -3962,8 +3961,8 @@ package body Sem_Ch4 is Next (Param); end loop; - -- One of the specs has additional formals, there is no match, - -- unless this may be an indexing of a parameterless call. + -- One of the specs has additional formals; there is no match, unless + -- this may be an indexing of a parameterless call. -- Note that when expansion is disabled, the corresponding record -- type of synchronized types is not constructed, so that there is @@ -3977,7 +3976,6 @@ package body Sem_Ch4 is and then not Expander_Active then return True; - else return False; end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2f8eced..81d2eec 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1045,7 +1045,6 @@ package body Sem_Ch5 is package Case_Choices_Processing is new Generic_Choices_Processing (Get_Alternatives => Alternatives, - Get_Choices => Discrete_Choices, Process_Empty_Choice => No_OP, Process_Non_Static_Choice => Non_Static_Choice_Error, Process_Associated_Node => Process_Statements); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7913d36..079aed8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9100,7 +9100,12 @@ package body Sem_Ch6 is Iface_Prim : Entity_Id; Prim : Entity_Id) return Boolean is - Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim); + -- The operation may in fact be an inherited (implicit) operation + -- rather than the original interface primitive, so retrieve the + -- ultimate ancestor. + + Iface : constant Entity_Id := + Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)); Typ : constant Entity_Id := Find_Dispatching_Type (Prim); function Controlling_Formal (Prim : Entity_Id) return Entity_Id; @@ -9185,7 +9190,7 @@ package body Sem_Ch6 is return False; else return - Type_Conformant (Prim, Iface_Prim, + Type_Conformant (Prim, Ultimate_Alias (Iface_Prim), Skip_Controlling_Formals => True); end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index b33a15e..5166830 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1170,7 +1170,7 @@ package body Sem_Ch7 is -- If one of the non-generic parents is itself on the scope -- stack, do not install its private declarations: they are -- installed in due time when the private part of that parent - -- is analyzed. + -- is analyzed. This is delicate ??? else while Present (Inst_Par) @@ -1178,20 +1178,11 @@ package body Sem_Ch7 is and then (not In_Open_Scopes (Inst_Par) or else not In_Private_Part (Inst_Par)) loop - if Nkind (Inst_Node) = N_Formal_Package_Declaration - or else - not Is_Ancestor_Package - (Inst_Par, Cunit_Entity (Current_Sem_Unit)) - then - Install_Private_Declarations (Inst_Par); - Set_Use (Private_Declarations - (Specification - (Unit_Declaration_Node (Inst_Par)))); - Inst_Par := Scope (Inst_Par); - - else - exit; - end if; + Install_Private_Declarations (Inst_Par); + Set_Use (Private_Declarations + (Specification + (Unit_Declaration_Node (Inst_Par)))); + Inst_Par := Scope (Inst_Par); end loop; exit; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 9d966bf..e3508ba 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -3084,6 +3084,12 @@ package Sinfo is -- Present_Expr (Uint3-Sem) -- Dcheck_Function (Node5-Sem) + -- Note: in the list of Discrete_Choices, the tree passed to the back + -- end does not have choice entries corresponding to names of statically + -- predicated subtypes. Such entries are always expanded out to the list + -- of equivalent values or ranges. The ASIS tree generated in -gnatct + -- mode does not have this expansion, and has the original choices. + --------------------------------- -- 3.8.1 Discrete Choice List -- --------------------------------- @@ -4382,6 +4388,12 @@ package Sinfo is -- Discrete_Choices (List4) -- Statements (List3) + -- Note: in the list of Discrete_Choices, the tree passed to the back + -- end does not have choice entries corresponding to names of statically + -- predicated subtypes. Such entries are always expanded out to the list + -- of equivalent values or ranges. The ASIS tree generated in -gnatct + -- mode does not have this expansion, and has the original choices. + ------------------------- -- 5.5 Loop Statement -- ------------------------- -- 2.7.4