diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 68 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 63 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/lib-xref-spark_specific.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/par-ch13.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/s-atocou-builtin.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/s-atocou-x86.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/s-atocou.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/s-atocou.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_case.adb | 57 | ||||
| -rw-r--r-- | gcc/ada/sem_case.ads | 36 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 21 | ||||
| -rw-r--r-- | 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 <dewar@adacore.com> + * 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 <schonberg@adacore.com> + + * sem_ch7.adb: Revert previous change. + +2013-10-10 Gary Dismukes <dismukes@adacore.com> + + * 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 <schonberg@adacore.com> + + * 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 <schonberg@adacore.com> + + * 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 <godunko@adacore.com> + + * s-atocou.adb, s-atocou.ads, s-atocou-x86.adb, s-atocou-builtin.adb: + Fix copyright notice. + +2013-10-10 Yannick Moy <moy@adacore.com> + + * lib-xref-spark_specific.adb (Enclosing_Subprogram_Or_Package): Get + enclosing subprogram for precondition/postcondition/contract cases. + +2013-10-10 Robert Dewar <dewar@adacore.com> + * gnat_rm.texi: Minor fix. 2013-10-10 Robert Dewar <dewar@adacore.com> 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 -- ------------------------- |