diff options
| -rw-r--r-- | gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst | 86 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 412 | ||||
| -rw-r--r-- | gcc/ada/gen_il-fields.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/gen_il-gen-gen_nodes.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 91 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 77 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/sem_case.adb | 1522 | ||||
| -rw-r--r-- | gcc/ada/sem_case.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 53 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 14 |
13 files changed, 2283 insertions, 11 deletions
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 74b9718..0d20496 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2235,6 +2235,92 @@ of GNAT specific extensions are recognized as follows: This new aggregate syntax for arrays and containers is provided under -gnatX to experiment and confirm this new language syntax. +* Casing on composite values + + The selector for a case statement may be of a composite type, subject to + some restrictions (described below). Aggregate syntax is used for choices + of such a case statement; however, in cases where a "normal" aggregate would + require a discrete value, a discrete subtype may be used instead; box + notation can also be used to match all values (but currently only + for discrete subcomponents). + + Consider this example: + + .. code-block:: ada + + type Rec is record + F1, F2 : Integer; + end record; + + procedure Caser_1 (X : Rec) is + begin + case X is + when (F1 => Positive, F2 => Positive) => + Do_This; + when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) => + Do_That; + when others => + Do_The_Other_Thing; + end case; + end Caser_1; + + If Caser_1 is called and both components of X are positive, then + Do_This will be called; otherwise, if either component is nonnegative + then Do_That will be called; otherwise, Do_The_Other_Thing will be called. + + If the set of values that match the choice(s) of an earlier alternative + overlaps the corresponding set of a later alternative, then the first + set shall be a proper subset of the second (and the later alternative + will not be executed if the earlier alternative "matches"). All possible + values of the composite type shall be covered. The composite type of the + selector shall be a nonlimited untagged undiscriminated record type, all + of whose subcomponent subtypes are either static discrete subtypes or + record types that meet the same restrictions. Support for arrays is + planned, but not yet implemented. + + In addition, pattern bindings are supported. This is a mechanism + for binding a name to a component of a matching value for use within + an alternative of a case statement. For a component association + that occurs within a case choice, the expression may be followed by + "is <identifier>". In the special case of a "box" component association, + the identifier may instead be provided within the box. Either of these + indicates that the given identifer denotes (a constant view of) the matching + subcomponent of the case selector. + + Consider this example (which uses type Rec from the previous example): + + .. code-block:: ada + + procedure Caser_2 (X : Rec) is + begin + case X is + when (F1 => Positive is Abc, F2 => Positive) => + Do_This (Abc) + when (F1 => Natural is N1, F2 => <N2>) | + (F1 => <N2>, F2 => Natural is N1) => + Do_That (Param_1 => N1, Param_2 => N2); + when others => + Do_The_Other_Thing; + end case; + end Caser_2; + + This example is the same as the previous one with respect to + determining whether Do_This, Do_That, or Do_The_Other_Thing will + be called. But for this version, Do_This takes a parameter and Do_That + takes two parameters. If Do_This is called, the actual parameter in the + call will be X.F1. + + If Do_That is called, the situation is more complex because there are two + choices for that alternative. If Do_That is called because the first choice + matched (i.e., because X.F1 is nonnegative and either X.F1 or X.F2 is zero + or negative), then the actual parameters of the call will be (in order) + X.F1 and X.F2. If Do_That is called because the second choice matched (and + the first one did not), then the actual parameters will be reversed. + + Within the choice list for single alternative, each choice must + define the same set of bindings and the component subtypes for + for a given identifer must all statically match. Currently, the case + of a binding for a nondiscrete component is not implemented. .. _Pragma-Extensions_Visible: diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 345baaf..8376ff7 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -54,6 +54,7 @@ with Ttypes; use Ttypes; with Sem; use Sem; with Sem_Aggr; use Sem_Aggr; with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; @@ -8515,6 +8516,11 @@ package body Exp_Aggr is elsif Is_Static_Dispatch_Table_Aggregate (N) then return; + + -- Case pattern aggregates need to remain as aggregates + + elsif Is_Case_Choice_Pattern (N) then + return; end if; -- If the pragma Aggregate_Individually_Assign is set, always convert to diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index c886607..cd9ab29 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -31,6 +31,7 @@ with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; +with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -39,6 +40,7 @@ with Exp_Dbug; use Exp_Dbug; with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Expander; use Expander; with Inline; use Inline; with Namet; use Namet; with Nlists; use Nlists; @@ -3031,7 +3033,415 @@ package body Exp_Ch5 is Choice : Node_Id; Chlist : List_Id; + function Expand_General_Case_Statement return Node_Id; + -- Expand a case statement whose selecting expression is not discrete + + ----------------------------------- + -- Expand_General_Case_Statement -- + ----------------------------------- + + function Expand_General_Case_Statement return Node_Id is + -- expand into a block statement + + Selector : constant Entity_Id := + Make_Temporary (Loc, 'J'); + + function Selector_Subtype_Mark return Node_Id is + (New_Occurrence_Of (Etype (Expr), Loc)); + + Renamed_Name : constant Node_Id := + (if Is_Name_Reference (Expr) + then Expr + else Make_Qualified_Expression (Loc, + Subtype_Mark => Selector_Subtype_Mark, + Expression => Expr)); + + Selector_Decl : constant Node_Id := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Selector, + Subtype_Mark => Selector_Subtype_Mark, + Name => Renamed_Name); + + First_Alt : constant Node_Id := First (Alternatives (N)); + + function Choice_Index_Decl_If_Needed return Node_Id; + -- If we are going to need a choice index object (that is, if + -- Multidefined_Bindings is true for at least one of the case + -- alternatives), then create and return that object's declaration. + -- Otherwise, return Empty; no need for a decl in that case because + -- it would never be referenced. + + --------------------------------- + -- Choice_Index_Decl_If_Needed -- + --------------------------------- + + function Choice_Index_Decl_If_Needed return Node_Id is + Alt : Node_Id := First_Alt; + begin + while Present (Alt) loop + if Multidefined_Bindings (Alt) then + return Make_Object_Declaration + (Sloc => Loc, + Defining_Identifier => + Make_Temporary (Loc, 'K'), + Object_Definition => + New_Occurrence_Of (Standard_Positive, Loc)); + end if; + + Next (Alt); + end loop; + return Empty; -- decl not needed + end Choice_Index_Decl_If_Needed; + + Choice_Index_Decl : constant Node_Id := Choice_Index_Decl_If_Needed; + + function Pattern_Match + (Pattern : Node_Id; + Object : Node_Id; + Choice_Index : Natural; + Alt : Node_Id; + Suppress_Choice_Index_Update : Boolean := False) return Node_Id; + -- Returns a Boolean-valued expression indicating a pattern match + -- for a given pattern and object. If Choice_Index is nonzero, + -- then Choice_Index is assigned to Choice_Index_Decl (unless + -- Suppress_Choice_Index_Update is specified, which should only + -- be the case for a recursive call where the caller has already + -- taken care of the update). Pattern occurs as a choice (or as a + -- subexpression of a choice) of the case statement alternative Alt. + + function Top_Level_Pattern_Match_Condition + (Alt : Node_Id) return Node_Id; + -- Returns a Boolean-valued expression indicating a pattern match + -- for the given alternative's list of choices. + + ------------------- + -- Pattern_Match -- + ------------------- + + function Pattern_Match + (Pattern : Node_Id; + Object : Node_Id; + Choice_Index : Natural; + Alt : Node_Id; + Suppress_Choice_Index_Update : Boolean := False) return Node_Id + is + function Update_Choice_Index return Node_Id is ( + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of + (Defining_Identifier (Choice_Index_Decl), Loc), + Expression => Make_Integer_Literal (Loc, Pos (Choice_Index)))); + + function PM + (Pattern : Node_Id; + Object : Node_Id; + Choice_Index : Natural := Pattern_Match.Choice_Index; + Alt : Node_Id := Pattern_Match.Alt; + Suppress_Choice_Index_Update : Boolean := + Pattern_Match.Suppress_Choice_Index_Update) return Node_Id + renames Pattern_Match; + -- convenient rename for recursive calls + + begin + if Choice_Index /= 0 and not Suppress_Choice_Index_Update then + pragma Assert (Present (Choice_Index_Decl)); + + -- Add Choice_Index update as a side effect of evaluating + -- this condition and try again, this time suppressing + -- Choice_Index update. + + return Make_Expression_With_Actions (Loc, + Actions => New_List (Update_Choice_Index), + Expression => + PM (Pattern, Object, + Suppress_Choice_Index_Update => True)); + end if; + + if Nkind (Pattern) in N_Has_Etype + and then Is_Discrete_Type (Etype (Pattern)) + and then Compile_Time_Known_Value (Pattern) + then + return Make_Op_Eq (Loc, + Object, + Make_Integer_Literal (Loc, Expr_Value (Pattern))); + end if; + + case Nkind (Pattern) is + when N_Aggregate => + return Result : Node_Id := + New_Occurrence_Of (Standard_True, Loc) + do + if Is_Array_Type (Etype (Pattern)) then + -- Calling Error_Msg_N during expansion is usually a + -- mistake but is ok for an "unimplemented" message. + Error_Msg_N + ("array-valued case choices unimplemented", + Pattern); + return; + end if; + + -- positional notation should have been normalized + pragma Assert (No (Expressions (Pattern))); + + declare + Component_Assoc : Node_Id + := First (Component_Associations (Pattern)); + Choice : Node_Id; + + function Subobject return Node_Id is + (Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Object), + Selector_Name => New_Occurrence_Of + (Entity (Choice), Loc))); + begin + while Present (Component_Assoc) loop + Choice := First (Choices (Component_Assoc)); + while Present (Choice) loop + pragma Assert + (Is_Entity_Name (Choice) + and then Ekind (Entity (Choice)) + in E_Discriminant | E_Component); + + if Box_Present (Component_Assoc) then + -- Box matches anything + + pragma Assert + (No (Expression (Component_Assoc))); + else + Result := Make_And_Then (Loc, + Left_Opnd => Result, + Right_Opnd => + PM (Pattern => + Expression + (Component_Assoc), + Object => Subobject)); + end if; + + -- If this component association defines + -- (in the case where the pattern matches) + -- the value of a binding object, then + -- prepend to the statement list for this + -- alternative an assignment to the binding + -- object. This assignment will be conditional + -- if there is more than one choice. + + if Binding_Chars (Component_Assoc) /= No_Name + then + declare + Decl_Chars : constant Name_Id := + Binding_Chars (Component_Assoc); + + Block_Stmt : constant Node_Id := + First (Statements (Alt)); + pragma Assert + (Nkind (Block_Stmt) = N_Block_Statement); + pragma Assert (No (Next (Block_Stmt))); + Decl : Node_Id + := First (Declarations (Block_Stmt)); + Def_Id : Node_Id := Empty; + + Assignment_Stmt : Node_Id; + Condition : Node_Id; + Prepended_Stmt : Node_Id; + begin + -- find the variable to be modified + while No (Def_Id) or else + Chars (Def_Id) /= Decl_Chars + loop + Def_Id := Defining_Identifier (Decl); + Next (Decl); + end loop; + + Assignment_Stmt := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of + (Def_Id, Loc), + Expression => Subobject); + + -- conditional if multiple choices + + if Present (Choice_Index_Decl) then + Condition := + Make_Op_Eq (Loc, + New_Occurrence_Of + (Defining_Identifier + (Choice_Index_Decl), Loc), + Make_Integer_Literal + (Loc, Int (Choice_Index))); + + Prepended_Stmt := + Make_If_Statement (Loc, + Condition => Condition, + Then_Statements => + New_List (Assignment_Stmt)); + else + -- assignment is unconditional + Prepended_Stmt := Assignment_Stmt; + end if; + + declare + HSS : constant Node_Id := + Handled_Statement_Sequence + (Block_Stmt); + begin + Prepend (Prepended_Stmt, + Statements (HSS)); + + Set_Analyzed (Block_Stmt, False); + Set_Analyzed (HSS, False); + end; + end; + end if; + + Next (Choice); + end loop; + + Next (Component_Assoc); + end loop; + end; + end return; + + when N_Qualified_Expression => + -- Make a copy for one of the two uses of Object; the choice + -- of where to use the original and where to use the copy + -- is arbitrary. + + return Make_And_Then (Loc, + Left_Opnd => Make_In (Loc, + Left_Opnd => New_Copy_Tree (Object), + Right_Opnd => New_Copy_Tree (Subtype_Mark (Pattern))), + Right_Opnd => + PM (Pattern => Expression (Pattern), + Object => Object)); + + when N_Identifier | N_Expanded_Name => + if Is_Type (Entity (Pattern)) then + return Make_In (Loc, + Left_Opnd => Object, + Right_Opnd => New_Occurrence_Of + (Entity (Pattern), Loc)); + end if; + + when N_Others_Choice => + return New_Occurrence_Of (Standard_True, Loc); + + when N_Type_Conversion => + -- aggregate expansion sometimes introduces conversions + if not Comes_From_Source (Pattern) + and then Base_Type (Etype (Pattern)) + = Base_Type (Etype (Expression (Pattern))) + then + return PM (Expression (Pattern), Object); + end if; + + when others => + null; + end case; + + -- Avoid cascading errors + pragma Assert (Serious_Errors_Detected > 0); + return New_Occurrence_Of (Standard_True, Loc); + end Pattern_Match; + + --------------------------------------- + -- Top_Level_Pattern_Match_Condition -- + --------------------------------------- + + function Top_Level_Pattern_Match_Condition + (Alt : Node_Id) return Node_Id + is + Top_Level_Object : constant Node_Id := + New_Occurrence_Of (Selector, Loc); + + Choices : constant List_Id := Discrete_Choices (Alt); + + First_Choice : constant Node_Id := First (Choices); + Subsequent : Node_Id := Next (First_Choice); + + Choice_Index : Natural := 0; + begin + if Multidefined_Bindings (Alt) then + Choice_Index := 1; + end if; + + return Result : Node_Id := + Pattern_Match (Pattern => First_Choice, + Object => Top_Level_Object, + Choice_Index => Choice_Index, + Alt => Alt) + do + while Present (Subsequent) loop + if Choice_Index /= 0 then + Choice_Index := Choice_Index + 1; + end if; + + Result := Make_Or_Else (Loc, + Left_Opnd => Result, + Right_Opnd => Pattern_Match + (Pattern => Subsequent, + Object => Top_Level_Object, + Choice_Index => Choice_Index, + Alt => Alt)); + Subsequent := Next (Subsequent); + end loop; + end return; + end Top_Level_Pattern_Match_Condition; + + function Elsif_Parts return List_Id; + -- Process subsequent alternatives + + ----------------- + -- Elsif_Parts -- + ----------------- + + function Elsif_Parts return List_Id is + Alt : Node_Id := First_Alt; + Result : constant List_Id := New_List; + begin + loop + Alt := Next (Alt); + exit when No (Alt); + + Append (Make_Elsif_Part (Loc, + Condition => Top_Level_Pattern_Match_Condition (Alt), + Then_Statements => Statements (Alt)), + Result); + end loop; + return Result; + end Elsif_Parts; + + If_Stmt : constant Node_Id := + Make_If_Statement (Loc, + Condition => Top_Level_Pattern_Match_Condition (First_Alt), + Then_Statements => Statements (First_Alt), + Elsif_Parts => Elsif_Parts); + -- Do we want an implicit "else raise Program_Error" here??? + -- Perhaps only if Exception-related restrictions are not in effect. + + Declarations : constant List_Id := New_List (Selector_Decl); + + begin + if Present (Choice_Index_Decl) then + Append_To (Declarations, Choice_Index_Decl); + end if; + + return Make_Block_Statement (Loc, + Declarations => Declarations, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (If_Stmt))); + end Expand_General_Case_Statement; + + -- Start of processing for Expand_N_Case_Statement + begin + if Extensions_Allowed and then not Is_Discrete_Type (Etype (Expr)) then + Rewrite (N, Expand_General_Case_Statement); + Analyze (N); + Expand (N); + return; + end if; + -- Check for the situation where we know at compile time which branch -- will be taken. @@ -3557,7 +3967,7 @@ package body Exp_Ch5 is --------------------------- -- First we deal with the case of C and Fortran convention boolean values, - -- with zero/non-zero semantics. + -- with zero/nonzero semantics. -- Second, we deal with the obvious rewriting for the cases where the -- condition of the IF is known at compile time to be True or False. diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 9c3bf34..91a610a 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -87,6 +87,7 @@ package Gen_IL.Fields is Aux_Decls_Node, Backwards_OK, Bad_Is_Detected, + Binding_Chars, Body_Required, Body_To_Inline, Box_Present, @@ -306,6 +307,7 @@ package Gen_IL.Fields is Low_Bound, Mod_Clause, More_Ids, + Multidefined_Bindings, Must_Be_Byte_Aligned, Must_Not_Freeze, Must_Not_Override, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 2405fd75..13bdd71 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -1213,7 +1213,8 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Case_Statement_Alternative, Node_Kind, (Sy (Discrete_Choices, List_Id), Sy (Statements, List_Id, Default_Empty_List), - Sm (Has_SP_Choice, Flag))); + Sm (Has_SP_Choice, Flag), + Sm (Multidefined_Bindings, Flag))); Cc (N_Compilation_Unit, Node_Kind, (Sy (Context_Items, List_Id), @@ -1241,6 +1242,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Expression, Node_Id, Default_Empty), Sy (Box_Present, Flag), Sy (Inherited_Discriminant, Flag), + Sy (Binding_Chars, Name_Id, Default_No_Name), Sm (Loop_Actions, List_Id), Sm (Was_Default_Init_Box_Association, Flag))); diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 7051aa6..38a56f7 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -3663,6 +3663,97 @@ now under -gnatX to confirm and potentially refine its usage and syntax. This new aggregate syntax for arrays and containers is provided under -gnatX to experiment and confirm this new language syntax. + +@item +Casing on composite values + +The selector for a case statement may be of a composite type, subject to +some restrictions (described below). Aggregate syntax is used for choices +of such a case statement; however, in cases where a "normal" aggregate would +require a discrete value, a discrete subtype may be used instead; box +notation can also be used to match all values (but currently only +for discrete subcomponents). + +Consider this example: + +@quotation + +@example +type Rec is record + F1, F2 : Integer; +end record; + +procedure Caser_1 (X : Rec) is +begin + case X is + when (F1 => Positive, F2 => Positive) => + Do_This; + when (F1 => Natural, F2 => <>) | (F1 => <>, F2 => Natural) => + Do_That; + when others => + Do_The_Other_Thing; + end case; +end Caser_1; +@end example +@end quotation + +If Caser_1 is called and both components of X are positive, then +Do_This will be called; otherwise, if either component is nonnegative +then Do_That will be called; otherwise, Do_The_Other_Thing will be called. + +If the set of values that match the choice(s) of an earlier alternative +overlaps the corresponding set of a later alternative, then the first +set shall be a proper subset of the second (and the later alternative +will not be executed if the earlier alternative "matches"). All possible +values of the composite type shall be covered. The composite type of the +selector shall be a nonlimited untagged undiscriminated record type, all +of whose subcomponent subtypes are either static discrete subtypes or +record types that meet the same restrictions. Support for arrays is +planned, but not yet implemented. + +In addition, pattern bindings are supported. This is a mechanism +for binding a name to a component of a matching value for use within +an alternative of a case statement. For a component association +that occurs within a case choice, the expression may be followed by +"is <identifier>". In the special case of a "box" component association, +the identifier may instead be provided within the box. Either of these +indicates that the given identifer denotes (a constant view of) the matching +subcomponent of the case selector. + +Consider this example (which uses type Rec from the previous example): + +@example +procedure Caser_2 (X : Rec) is +begin + case X is + when (F1 => Positive is Abc, F2 => Positive) => + Do_This (Abc) + when (F1 => Natural is N1, F2 => <N2>) | + (F1 => <N2>, F2 => Natural is N1) => + Do_That (Param_1 => N1, Param_2 => N2); + when others => + Do_The_Other_Thing; + end case; +end Caser_2; +@end example + +This example is the same as the previous one with respect to +determining whether Do_This, Do_That, or Do_The_Other_Thing will +be called. But for this version, Do_This takes a parameter and Do_That +takes two parameters. If Do_This is called, the actual parameter in the +call will be X.F1. + +If Do_That is called, the situation is more complex because there are two +choices for that alternative. If Do_That is called because the first choice +matched (i.e., because X.F1 is nonnegative and either X.F1 or X.F2 is zero +or negative), then the actual parameters of the call will be (in order) +X.F1 and X.F2. If Do_That is called because the second choice matched (and +the first one did not), then the actual parameters will be reversed. + +Within the choice list for single alternative, each choice must +define the same set of bindings and the component subtypes for +for a given identifer must all statically match. Currently, the case +of a binding for a nondiscrete component is not implemented. @end itemize @node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index ba128ec..20f8dd1 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1734,8 +1734,9 @@ package body Ch4 is -- aggregates (AI-287) function P_Record_Or_Array_Component_Association return Node_Id is - Assoc_Node : Node_Id; - + Assoc_Node : Node_Id; + Box_Present : Boolean := False; + Box_With_Identifier_Present : Boolean := False; begin -- A loop indicates an iterated_component_association @@ -1744,6 +1745,8 @@ package body Ch4 is end if; Assoc_Node := New_Node (N_Component_Association, Token_Ptr); + Set_Binding_Chars (Assoc_Node, No_Name); + Set_Choices (Assoc_Node, P_Discrete_Choice_List); Set_Sloc (Assoc_Node, Token_Ptr); TF_Arrow; @@ -1755,12 +1758,78 @@ package body Ch4 is Error_Msg_Ada_2005_Extension ("component association with '<'>"); + Box_Present := True; Set_Box_Present (Assoc_Node); - Scan; -- Past box - else + Scan; -- past box + elsif Token = Tok_Less then + declare + Scan_State : Saved_Scan_State; + Id : Node_Id; + begin + Save_Scan_State (Scan_State); + Scan; -- past "<" + if Token = Tok_Identifier then + Id := P_Defining_Identifier; + if Token = Tok_Greater then + if Extensions_Allowed then + Set_Box_Present (Assoc_Node); + Set_Binding_Chars (Assoc_Node, Chars (Id)); + Box_Present := True; + Box_With_Identifier_Present := True; + Scan; -- past ">" + else + Error_Msg + ("Identifier within box only supported under -gnatX", + Token_Ptr); + Box_Present := True; + -- Avoid cascading errors by ignoring the identifier + end if; + end if; + end if; + if not Box_Present then + -- it wasn't an "is <identifier>", so restore. + Restore_Scan_State (Scan_State); + end if; + end; + end if; + + if not Box_Present then Set_Expression (Assoc_Node, P_Expression); end if; + -- Check for "is <identifier>" for aggregate that is part of + -- a pattern for a general case statement. + + if Token = Tok_Is then + declare + Scan_State : Saved_Scan_State; + Id : Node_Id; + begin + Save_Scan_State (Scan_State); + Scan; -- past "is" + if Token = Tok_Identifier then + Id := P_Defining_Identifier; + + if not Extensions_Allowed then + Error_Msg + ("IS following component association" + & " only supported under -gnatX", + Token_Ptr); + elsif Box_With_Identifier_Present then + Error_Msg + ("Both identifier-in-box and trailing identifier" + & " specified for one component association", + Token_Ptr); + else + Set_Binding_Chars (Assoc_Node, Chars (Id)); + end if; + else + -- It wasn't an "is <identifier>", so restore. + Restore_Scan_State (Scan_State); + end if; + end; + end if; + return Assoc_Node; end P_Record_Or_Array_Component_Association; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index ae0c2be..d189ab7 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -48,6 +48,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch5; use Sem_Ch5; @@ -5190,7 +5191,18 @@ package body Sem_Aggr is -- replace the reference to the current instance by the target -- object of the aggregate. - if Present (Parent (Component)) + if Is_Case_Choice_Pattern (N) then + + -- Do not transform box component values in a case-choice + -- aggregate. + + Add_Association + (Component => Component, + Expr => Empty, + Assoc_List => New_Assoc_List, + Is_Box_Present => True); + + elsif Present (Parent (Component)) and then Nkind (Parent (Component)) = N_Component_Declaration and then Present (Expression (Parent (Component))) then diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index b8602aa..36db9a7 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -43,12 +43,14 @@ with Stand; use Stand; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; +with Table; with Tbuild; use Tbuild; with Uintp; use Uintp; with Ada.Unchecked_Deallocation; with GNAT.Heap_Sort_G; +with GNAT.Sets; package body Sem_Case is @@ -95,6 +97,114 @@ package body Sem_Case is -- Given a Pos value of enumeration type Ctype, returns the name -- ID of an appropriate string to be used in error message output. + package Composite_Case_Ops is + + function Scalar_Part_Count (Subtyp : Entity_Id) return Nat; + -- Given the composite type Subtyp of a case selector, returns the + -- number of scalar parts in an object of this type. This is the + -- dimensionality of the associated Cartesian product space. + + function Choice_Count (Alternatives : List_Id) return Nat; + -- The sum of the number of choices for each alternative in the given + -- list. + + generic + Case_Statement : Node_Id; + package Choice_Analysis is + + type Alternative_Id is + new Int range 1 .. List_Length (Alternatives (Case_Statement)); + type Choice_Id is + new Int range 1 .. Choice_Count (Alternatives (Case_Statement)); + type Part_Id is new Int range + 1 .. Scalar_Part_Count (Etype (Expression (Case_Statement))); + + type Discrete_Range_Info is + record + Low, High : Uint; + end record; + + type Composite_Range_Info is array (Part_Id) of Discrete_Range_Info; + + type Choice_Range_Info (Is_Others : Boolean := False) is + record + case Is_Others is + when False => + Ranges : Composite_Range_Info; + when True => + null; + end case; + end record; + + type Choices_Range_Info is array (Choice_Id) of Choice_Range_Info; + + package Value_Sets is + + type Value_Set is private; + -- A set of points in the Cartesian product space defined + -- by the composite type of the case selector. + -- Implemented as an access type. + + type Set_Comparison is + (Disjoint, Equal, Contains, Contained_By, Overlaps); + + function Compare (S1, S2 : Value_Set) return Set_Comparison; + -- If either argument (or both) is empty, result is Disjoint. + -- Otherwise, result is Equal if the two sets are equal. + + Empty : constant Value_Set; + + function Matching_Values + (Info : Composite_Range_Info) return Value_Set; + -- The Cartesian product of the given array of ranges + -- (excluding any values outside the Cartesian product of the + -- component ranges). + + procedure Union (Target : in out Value_Set; Source : Value_Set); + -- Add elements of Source into Target + + procedure Remove (Target : in out Value_Set; Source : Value_Set); + -- Remove elements of Source from Target + + function Complement_Is_Empty (Set : Value_Set) return Boolean; + -- Return True iff the set is "maximal", in the sense that it + -- includes every value in the Cartesian product of the + -- component ranges. + + procedure Free_Value_Sets; + -- Reclaim storage associated with implementation of this package. + + private + type Value_Set is new Natural; + -- An index for a table that will be declared in the package body. + + Empty : constant Value_Set := 0; + + end Value_Sets; + + type Single_Choice_Info (Is_Others : Boolean := False) is + record + Alternative : Alternative_Id; + case Is_Others is + when False => + Matches : Value_Sets.Value_Set; + when True => + null; + end case; + end record; + + type Choices_Info is array (Choice_Id) of Single_Choice_Info; + + function Analysis return Choices_Info; + -- Parse the case choices in order to determine the set of + -- matching values associated with each choice. + + type Bound_Values is array (Positive range <>) of Node_Id; + + end Choice_Analysis; + + end Composite_Case_Ops; + procedure Expand_Others_Choice (Case_Table : Choice_Table_Type; Others_Choice : Node_Id; @@ -980,6 +1090,1179 @@ package body Sem_Case is return Name_Find; end Choice_Image; + package body Composite_Case_Ops is + + function Static_Array_Length (Subtyp : Entity_Id) return Nat; + -- Given a one-dimensional constrained array subtype with + -- statically known bounds, return its length. + + ------------------------- + -- Static_Array_Length -- + ------------------------- + + function Static_Array_Length (Subtyp : Entity_Id) return Nat is + pragma Assert (Is_Constrained (Subtyp)); + pragma Assert (Number_Dimensions (Subtyp) = 1); + Index : constant Node_Id := First_Index (Subtyp); + pragma Assert (Is_OK_Static_Range (Index)); + Lo : constant Uint := Expr_Value (Low_Bound (Index)); + Hi : constant Uint := Expr_Value (High_Bound (Index)); + Len : constant Uint := UI_Max (0, (Hi - Lo) + 1); + begin + return UI_To_Int (Len); + end Static_Array_Length; + + ----------------------- + -- Scalar_Part_Count -- + ----------------------- + + function Scalar_Part_Count (Subtyp : Entity_Id) return Nat is + begin + if Is_Scalar_Type (Subtyp) then + return 1; + elsif Is_Array_Type (Subtyp) then + return Static_Array_Length (Subtyp) + * Scalar_Part_Count (Component_Type (Subtyp)); + elsif Is_Record_Type (Subtyp) then + pragma Assert (not Has_Discriminants (Subtyp)); + declare + Result : Nat := 0; + Comp : Entity_Id := First_Component (Subtyp); + begin + while Present (Comp) loop + Result := Result + Scalar_Part_Count (Etype (Comp)); + Next_Component (Comp); + end loop; + return Result; + end; + else + pragma Assert (False); + raise Program_Error; + end if; + end Scalar_Part_Count; + + ------------------ + -- Choice_Count -- + ------------------ + + function Choice_Count (Alternatives : List_Id) return Nat is + Result : Nat := 0; + Alt : Node_Id := First (Alternatives); + begin + while Present (Alt) loop + Result := Result + List_Length (Discrete_Choices (Alt)); + Next (Alt); + end loop; + return Result; + end Choice_Count; + + package body Choice_Analysis is + + function Component_Bounds_Info return Composite_Range_Info; + -- Returns the (statically known) bounds for each component. + -- The selector expression value (or any other value of the type + -- of the selector expression) can be thought of as a point in the + -- Cartesian product of these sets. + + function Parse_Choice (Choice : Node_Id; + Alt : Node_Id) return Choice_Range_Info; + -- Extract Choice_Range_Info from a Choice node + + --------------------------- + -- Component_Bounds_Info -- + --------------------------- + + function Component_Bounds_Info return Composite_Range_Info is + Result : Composite_Range_Info; + Next : Part_Id := 1; + Done : Boolean := False; + + procedure Update_Result (Info : Discrete_Range_Info); + -- Initialize first remaining uninitialized element of Result. + -- Also set Next and Done. + + ------------------- + -- Update_Result -- + ------------------- + + procedure Update_Result (Info : Discrete_Range_Info) is + begin + Result (Next) := Info; + if Next /= Part_Id'Last then + Next := Next + 1; + else + pragma Assert (not Done); + Done := True; + end if; + end Update_Result; + + procedure Traverse_Discrete_Parts (Subtyp : Entity_Id); + -- Traverse the given subtype, looking for discrete parts. + -- For an array subtype of length N, the element subtype + -- is traversed N times. For a record subtype, traverse + -- each component's subtype (once). When a discrete part is + -- found, call Update_Result. + + ----------------------------- + -- Traverse_Discrete_Parts -- + ----------------------------- + + procedure Traverse_Discrete_Parts (Subtyp : Entity_Id) is + begin + if Is_Discrete_Type (Subtyp) then + Update_Result + ((Low => Expr_Value (Type_Low_Bound (Subtyp)), + High => Expr_Value (Type_High_Bound (Subtyp)))); + elsif Is_Array_Type (Subtyp) then + for I in 1 .. Static_Array_Length (Subtyp) loop + Traverse_Discrete_Parts (Component_Type (Subtyp)); + end loop; + elsif Is_Record_Type (Subtyp) then + pragma Assert (not Has_Discriminants (Subtyp)); + declare + Comp : Entity_Id := First_Component (Subtyp); + begin + while Present (Comp) loop + Traverse_Discrete_Parts (Etype (Comp)); + Next_Component (Comp); + end loop; + end; + else + Error_Msg_N + ("case selector type having a non-discrete non-record" + & " non-array subcomponent type not implemented", + Expression (Case_Statement)); + end if; + end Traverse_Discrete_Parts; + begin + Traverse_Discrete_Parts (Etype (Expression (Case_Statement))); + pragma Assert (Done or else Serious_Errors_Detected > 0); + return Result; + end Component_Bounds_Info; + + Component_Bounds : constant Composite_Range_Info + := Component_Bounds_Info; + + package Case_Bindings is + + procedure Note_Binding + (Comp_Assoc : Node_Id; + Choice : Node_Id; + Alt : Node_Id); + -- Note_Binding is called once for each component association + -- that defines a binding (using either "A => B is X" or + -- "A => <X>" syntax); + + procedure Check_Bindings; + -- After all calls to Note_Binding, check that bindings are + -- ok (e.g., check consistency among different choices of + -- one alternative). + + end Case_Bindings; + + procedure Refresh_Binding_Info (Aggr : Node_Id); + -- The parser records binding-related info in the tree. + -- The choice nodes that we see here might not be (will never be?) + -- the original nodes that were produced by the parser. The info + -- recorded by the parser is missing in that case, so this + -- procedure recovers it. + -- + -- There are bugs here. In some cases involving nested aggregates, + -- the path back to the parser-created nodes is lost. In particular, + -- we may fail to detect an illegal case like + -- when (F1 | F2 => (Aa => Natural, Bb => Natural is X)) => + -- This should be rejected because it is binding X to both the + -- F1.Bb and to the F2.Bb subcomponents of the case selector. + -- It would be nice if the not-specific-to-pattern-matching + -- aggregate-processing code could remain unaware of the existence + -- of this binding-related info but perhaps that isn't possible. + + -------------------------- + -- Refresh_Binding_Info -- + -------------------------- + + procedure Refresh_Binding_Info (Aggr : Node_Id) is + Orig_Aggr : constant Node_Id := Original_Node (Aggr); + Orig_Comp : Node_Id := First (Component_Associations (Orig_Aggr)); + begin + if Aggr = Orig_Aggr then + return; + end if; + + while Present (Orig_Comp) loop + if Nkind (Orig_Comp) = N_Component_Association + and then Binding_Chars (Orig_Comp) /= No_Name + then + if List_Length (Choices (Orig_Comp)) /= 1 then + -- Conceivably this could be checked during parsing, + -- but checking is easier here. + + Error_Msg_N + ("binding shared by multiple components", Orig_Comp); + return; + end if; + + declare + Orig_Name : constant Name_Id := + Chars (First (Choices (Orig_Comp))); + Comp : Node_Id := First (Component_Associations (Aggr)); + Matching_Comp : Node_Id := Empty; + begin + while Present (Comp) loop + if Chars (First (Choices (Comp))) = Orig_Name then + pragma Assert (not Present (Matching_Comp)); + Matching_Comp := Comp; + end if; + + Next (Comp); + end loop; + + pragma Assert (Present (Matching_Comp)); + + Set_Binding_Chars + (Matching_Comp, + Binding_Chars (Orig_Comp)); + end; + end if; + + Next (Orig_Comp); + end loop; + end Refresh_Binding_Info; + + ------------------ + -- Parse_Choice -- + ------------------ + + function Parse_Choice (Choice : Node_Id; + Alt : Node_Id) return Choice_Range_Info + is + Result : Choice_Range_Info (Is_Others => False); + Ranges : Composite_Range_Info renames Result.Ranges; + Next_Part : Part_Id := 1; + Done : Boolean := False; + + procedure Update_Result (Discrete_Range : Discrete_Range_Info); + -- Initialize first remaining uninitialized element of Ranges. + -- Also set Next_Part and Done. + + ------------------- + -- Update_Result -- + ------------------- + + procedure Update_Result (Discrete_Range : Discrete_Range_Info) is + begin + pragma Assert (not Done); + Ranges (Next_Part) := Discrete_Range; + if Next_Part = Part_Id'Last then + Done := True; + else + Next_Part := Next_Part + 1; + end if; + end Update_Result; + + procedure Traverse_Choice (Expr : Node_Id); + -- Traverse a legal choice expression, looking for + -- values/ranges of discrete parts. Call Update_Result + -- for each. + + --------------------- + -- Traverse_Choice -- + --------------------- + + procedure Traverse_Choice (Expr : Node_Id) is + begin + if Nkind (Expr) = N_Qualified_Expression then + Traverse_Choice (Expression (Expr)); + + elsif Nkind (Expr) = N_Type_Conversion + and then not Comes_From_Source (Expr) + then + if Expr /= Original_Node (Expr) then + Traverse_Choice (Original_Node (Expr)); + else + Traverse_Choice (Expression (Expr)); + end if; + + elsif Nkind (Expr) = N_Aggregate then + if Is_Record_Type (Etype (Expr)) then + Refresh_Binding_Info (Aggr => Expr); + + declare + Comp : Node_Id := + First (Component_Associations (Expr)); + -- Ok to assume that components are in order here? + begin + while Present (Comp) loop + pragma Assert (List_Length (Choices (Comp)) = 1); + if Box_Present (Comp) then + declare + Comp_Type : constant Entity_Id := + Etype (First (Choices (Comp))); + begin + if Is_Discrete_Type (Comp_Type) then + declare + Low : constant Node_Id := + Type_Low_Bound (Comp_Type); + High : constant Node_Id := + Type_High_Bound (Comp_Type); + begin + Update_Result + ((Low => Expr_Value (Low), + High => Expr_Value (High))); + end; + else + -- Need to recursively traverse type + -- here, calling Update_Result for + -- each discrete subcomponent. + + Error_Msg_N + ("box values for nondiscrete pattern " + & "subcomponents unimplemented", Comp); + end if; + end; + else + Traverse_Choice (Expression (Comp)); + end if; + + if Binding_Chars (Comp) /= No_Name + then + Case_Bindings.Note_Binding + (Comp_Assoc => Comp, + Choice => Choice, + Alt => Alt); + end if; + + Next (Comp); + end loop; + end; + elsif Is_Array_Type (Etype (Expr)) then + if Is_Non_Empty_List (Component_Associations (Expr)) then + Error_Msg_N + ("non-positional array aggregate as/within case " + & "choice not implemented", Expr); + end if; + + declare + Subexpr : Node_Id := First (Expressions (Expr)); + begin + while Present (Subexpr) loop + Traverse_Choice (Subexpr); + Next (Subexpr); + end loop; + end; + else + raise Program_Error; + end if; + elsif Is_Discrete_Type (Etype (Expr)) then + if Nkind (Expr) in N_Has_Entity and then + Is_Type (Entity (Expr)) + then + declare + Low : constant Node_Id := + Type_Low_Bound (Entity (Expr)); + High : constant Node_Id := + Type_High_Bound (Entity (Expr)); + begin + Update_Result ((Low => Expr_Value (Low), + High => Expr_Value (High))); + end; + else + pragma Assert (Compile_Time_Known_Value (Expr)); + Update_Result ((Low | High => Expr_Value (Expr))); + end if; + else + Error_Msg_N + ("non-aggregate case choice subexpression which is not" + & " of a discrete type not implemented", Expr); + end if; + end Traverse_Choice; + + begin + if Nkind (Choice) = N_Others_Choice then + return (Is_Others => True); + end if; + Traverse_Choice (Choice); + + -- Avoid returning uninitialized garbage in error case + if not Done then + pragma Assert (Serious_Errors_Detected > 0); + Result.Ranges := (others => (Low => Uint_1, High => Uint_0)); + end if; + + return Result; + end Parse_Choice; + + package body Case_Bindings is + + type Binding is record + Comp_Assoc : Node_Id; + Choice : Node_Id; + Alt : Node_Id; + end record; + + type Binding_Index is new Natural; + + package Case_Bindings_Table is new Table.Table + (Table_Component_Type => Binding, + Table_Index_Type => Binding_Index, + Table_Low_Bound => 1, + Table_Initial => 16, + Table_Increment => 64, + Table_Name => "Composite_Case_Ops.Case_Bindings"); + + ------------------ + -- Note_Binding -- + ------------------ + + procedure Note_Binding + (Comp_Assoc : Node_Id; + Choice : Node_Id; + Alt : Node_Id) + is + begin + Case_Bindings_Table.Append + ((Comp_Assoc => Comp_Assoc, + Choice => Choice, + Alt => Alt)); + end Note_Binding; + + -------------------- + -- Check_Bindings -- + -------------------- + + procedure Check_Bindings + is + use Case_Bindings_Table; + begin + if Last = 0 then + -- no bindings to check + return; + end if; + + declare + Tab : Table_Type + renames Case_Bindings_Table.Table (1 .. Last); + + function Same_Id (Idx1, Idx2 : Binding_Index) + return Boolean is ( + Binding_Chars (Tab (Idx1).Comp_Assoc) = + Binding_Chars (Tab (Idx2).Comp_Assoc)); + + function Binding_Subtype (Idx : Binding_Index) + return Entity_Id is + (Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc)))); + begin + -- Verify that elements with given choice or alt value + -- are contiguous, and that elements with equal + -- choice values have same alt value. + + for Idx1 in 2 .. Tab'Last loop + if Tab (Idx1 - 1).Choice /= Tab (Idx1).Choice then + pragma Assert + (for all Idx2 in Idx1 + 1 .. Tab'Last => + Tab (Idx2).Choice /= Tab (Idx1 - 1).Choice); + else + pragma Assert (Tab (Idx1 - 1).Alt = Tab (Idx1).Alt); + end if; + if Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt then + pragma Assert + (for all Idx2 in Idx1 + 1 .. Tab'Last => + Tab (Idx2).Alt /= Tab (Idx1 - 1).Alt); + end if; + end loop; + + -- Check for user errors: + -- 1) Two choices for a given alternative shall define the + -- same set of names. Can't have + -- when (<X>, 0) | (0, <Y>) => + -- 2) A choice shall not define a name twice. Can't have + -- when (A => <X>, B => <X>, C => 0) => + -- 3) Two definitions of a name within one alternative + -- shall have statically matching component subtypes. + -- Can't have + -- type R is record Int : Integer; + -- Nat : Natural; end record; + -- case R'(...) is + -- when (<X>, 1) | (1, <X>) => + -- 4) A given binding shall match only one value. + -- Can't have + -- (Fld1 | Fld2 => (Fld => <X>)) + -- For now, this is enforced *very* conservatively + -- with respect to arrays - a binding cannot match + -- any part of an array. This is temporary. + + for Idx1 in Tab'Range loop + if Idx1 = 1 + or else Tab (Idx1 - 1).Alt /= Tab (Idx1).Alt + then + -- Process one alternative + declare + Alt_Start : constant Binding_Index := Idx1; + Alt : constant Node_Id := Tab (Alt_Start).Alt; + + First_Choice : constant Node_Id := + Nlists.First (Discrete_Choices (Alt)); + First_Choice_Bindings : Natural := 0; + begin + -- Check for duplicates within one choice, + -- and for choices with no bindings. + + if First_Choice /= Tab (Alt_Start).Choice then + Error_Msg_N ("binding(s) missing for choice", + First_Choice); + return; + end if; + + declare + Current_Choice : Node_Id := First_Choice; + Choice_Start : Binding_Index := Alt_Start; + begin + for Idx2 in Alt_Start .. Tab'Last loop + exit when Tab (Idx2).Alt /= Alt; + if Tab (Idx2).Choice = Current_Choice then + for Idx3 in Choice_Start .. Idx2 - 1 loop + if Same_Id (Idx2, Idx3) + then + Error_Msg_N + ("duplicate binding in choice", + Current_Choice); + return; + end if; + end loop; + else + Next (Current_Choice); + pragma Assert (Present (Current_Choice)); + Choice_Start := Idx2; + + if Tab (Idx2).Choice /= Current_Choice + then + Error_Msg_N + ("binding(s) missing for choice", + Current_Choice); + return; + end if; + end if; + end loop; + + -- If we made it through all the bindings + -- for this alternative but didn't make it + -- to the last choice, then bindings are + -- missing for all remaining choices. + -- We only complain about the first one. + + if Present (Next (Current_Choice)) then + Error_Msg_N + ("binding(s) missing for choice", + Next (Current_Choice)); + return; + end if; + end; + + -- Count bindings for first choice of alternative + + for FC_Idx in Alt_Start .. Tab'Last loop + exit when Tab (FC_Idx).Choice /= First_Choice; + First_Choice_Bindings := + First_Choice_Bindings + 1; + end loop; + + declare + Current_Choice : Node_Id := First_Choice; + Current_Choice_Bindings : Natural := 0; + begin + for Idx2 in Alt_Start .. Tab'Last loop + exit when Tab (Idx2).Alt /= Alt; + + -- If starting a new choice + + if Tab (Idx2).Choice /= Current_Choice then + + -- Check count for choice just finished + + if Current_Choice_Bindings + /= First_Choice_Bindings + then + Error_Msg_N + ("subsequent choice has different" + & " number of bindings than first" + & " choice", Current_Choice); + end if; + + Current_Choice := Tab (Idx2).Choice; + Current_Choice_Bindings := 1; + + -- Remember that Alt has both one or more + -- bindings and two or more choices; we'll + -- need to know this during expansion. + + Set_Multidefined_Bindings (Alt, True); + else + Current_Choice_Bindings := + Current_Choice_Bindings + 1; + end if; + + -- Check that first choice has binding with + -- matching name; check subtype consistency. + + declare + Found : Boolean := False; + begin + for FC_Idx in + Alt_Start .. + Alt_Start + Binding_Index + (First_Choice_Bindings - 1) + loop + if Same_Id (Idx2, FC_Idx) then + if not Subtypes_Statically_Match + (Binding_Subtype (Idx2), + Binding_Subtype (FC_Idx)) + then + Error_Msg_N + ("subtype of binding in " + & "subsequent choice does not " + & "match that in first choice", + Tab (Idx2).Comp_Assoc); + end if; + Found := True; + exit; + end if; + end loop; + + if not Found then + Error_Msg_N + ("binding defined in subsequent " + & "choice not defined in first " + & "choice", Current_Choice); + end if; + end; + + -- Check for illegal repeated binding + -- via an enclosing aggregate, as in + -- (F1 | F2 => (F3 => Natural is X, + -- F4 => Natural)) + -- where the inner aggregate would be ok. + + declare + Rover : Node_Id := Tab (Idx2).Comp_Assoc; + begin + while Rover /= Tab (Idx2).Choice loop + Rover := + (if Is_List_Member (Rover) then + Parent (List_Containing (Rover)) + else Parent (Rover)); + pragma Assert (Present (Rover)); + if Nkind (Rover) + = N_Component_Association + and then List_Length (Choices (Rover)) + > 1 + then + Error_Msg_N + ("binding shared by multiple " + & "enclosing components", + Tab (Idx2).Comp_Assoc); + end if; + end loop; + end; + end loop; + end; + + -- Construct the (unanalyzed) declarations for + -- the current alternative. Then analyze them. + + if First_Choice_Bindings > 0 then + declare + Loc : constant Source_Ptr := Sloc (Alt); + Declarations : constant List_Id := New_List; + Decl : Node_Id; + begin + for FC_Idx in + Alt_Start .. + Alt_Start + + Binding_Index (First_Choice_Bindings - 1) + loop + Decl := Make_Object_Declaration + (Sloc => Loc, + Defining_Identifier => + Make_Defining_Identifier + (Loc, + Binding_Chars + (Tab (FC_Idx).Comp_Assoc)), + Object_Definition => + New_Occurrence_Of + (Binding_Subtype (FC_Idx), Loc)); + + Append_To (Declarations, Decl); + end loop; + + declare + Old_Statements : constant List_Id := + Statements (Alt); + New_Statements : constant List_Id := + New_List; + + Block_Statement : constant Node_Id := + Make_Block_Statement (Sloc => Loc, + Declarations => Declarations, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements + (Loc, Old_Statements), + Has_Created_Identifier => True); + begin + Append_To + (New_Statements, Block_Statement); + + Set_Statements (Alt, New_Statements); + end; + end; + end if; + end; + end if; + end loop; + end; + end Check_Bindings; + end Case_Bindings; + + function Choice_Bounds_Info return Choices_Range_Info; + -- Returns mapping from any given Choice_Id value to that choice's + -- component-to-range map. + + ------------------------ + -- Choice_Bounds_Info -- + ------------------------ + + function Choice_Bounds_Info return Choices_Range_Info is + Result : Choices_Range_Info; + Alt : Node_Id := First (Alternatives (Case_Statement)); + C_Id : Choice_Id := 1; + begin + while Present (Alt) loop + declare + Choice : Node_Id := First (Discrete_Choices (Alt)); + begin + while Present (Choice) loop + Result (C_Id) := Parse_Choice (Choice, Alt => Alt); + + Next (Choice); + if C_Id /= Choice_Id'Last then + C_Id := C_Id + 1; + end if; + end loop; + end; + Next (Alt); + end loop; + + pragma Assert (C_Id = Choice_Id'Last); + + -- No more calls to Note_Binding, so time for checks. + Case_Bindings.Check_Bindings; + + return Result; + end Choice_Bounds_Info; + + Choices_Bounds : constant Choices_Range_Info := Choice_Bounds_Info; + + package body Value_Sets is + use GNAT; + + function Hash (Key : Uint) return Bucket_Range_Type is + (Bucket_Range_Type + (UI_To_Int (Key mod (Uint_2 ** Uint_31)))); + + package Uint_Sets is new GNAT.Sets.Membership_Sets + (Uint, "=", Hash); + + type Representative_Values_Array is + array (Part_Id) of Uint_Sets.Membership_Set; + + function Representative_Values_Init + return Representative_Values_Array; + -- Select the representative values for each Part_Id value. + -- This function is called exactly once, immediately after it + -- is declared. + + -------------------------------- + -- Representative_Values_Init -- + -------------------------------- + + function Representative_Values_Init + return Representative_Values_Array + is + -- For each range of each choice (as well as the range for the + -- component subtype, which is handled in the first loop), + -- insert the low bound of the range and the successor of + -- the high bound into the corresponding R_V element. + -- + -- The idea we are trying to capture here is somewhat tricky. + -- Given an arbitrary point P1 in the Cartesian product + -- of the Component_Bounds sets, we want to be able + -- to map that to a point P2 in the (smaller) Cartesian product + -- of the Representative_Values sets that has the property + -- that for every choice of the case statement, P1 matches + -- the choice if and only if P2 also matches. Given that, + -- we can implement the overlapping/containment/etc. rules + -- safely by just looking at (using brute force enumeration) + -- the (smaller) Cartesian product of the R_V sets. + -- We are never going to actually perform this point-to-point + -- mapping - just the fact that it exists is enough to ensure + -- we can safely look at just the R_V sets. + -- + -- The desired mapping can be implemented by mapping a point + -- P1 to a point P2 by reducing each of P1's coordinates down + -- to the largest element of the corresponding R_V set that is + -- less than or equal to the original coordinate value (such + -- an element Y will always exist because the R_V set for a + -- given component always includes the low bound of the + -- component subtype). It then suffices to show that every + -- choice in the case statement yields the same Boolean result + -- for P1 as for P2. + -- + -- Suppose the contrary. Then there is some particular + -- coordinate position X (i.e., a Part_Id value) and some + -- choice C where exactly one of P1(X) and P2(X) belongs to + -- the (contiguous) range associated with C(X); call that + -- range L .. H. We know that P2(X) <= P1(X) because the + -- mapping never increases coordinate values. Consider three + -- cases: P1(X) lies within the L .. H range, or it is greater + -- than H, or it is lower than L. + -- The third case is impossible because reducing a value that + -- is less than L can only produce another such value, + -- violating the "exactly one" assumption. The second + -- case is impossible because L belongs to the corresponding + -- R_V set, so P2(X) >= L and both values belong to the + -- range, again violating the "exactly one" assumption. + -- Finally, the third case is impossible because H+1 belongs + -- to the corresponding R_V set, so P2(X) > H, so neither + -- value belongs to the range, again violating the "exactly + -- one" assumption. So our initial supposition was wrong. QED. + + use Uint_Sets; + + Result : constant Representative_Values_Array + := (others => Uint_Sets.Create (Initial_Size => 32)); + + procedure Insert_Representative (Value : Uint; P : Part_Id); + -- Insert the given Value into the representative values set + -- for the given component if it belongs to the component's + -- subtype. Otherwise, do nothing. + + --------------------------- + -- Insert_Representative -- + --------------------------- + + procedure Insert_Representative (Value : Uint; P : Part_Id) is + begin + if Value >= Component_Bounds (P).Low and + Value <= Component_Bounds (P).High + then + Insert (Result (P), Value); + end if; + end Insert_Representative; + + begin + for P in Part_Id loop + Insert_Representative (Component_Bounds (P).Low, P); + end loop; + for C of Choices_Bounds loop + if not C.Is_Others then + for P in Part_Id loop + if C.Ranges (P).Low <= C.Ranges (P).High then + Insert_Representative (C.Ranges (P).Low, P); + Insert_Representative (C.Ranges (P).High + 1, P); + end if; + end loop; + end if; + end loop; + return Result; + end Representative_Values_Init; + + Representative_Values : constant Representative_Values_Array + := Representative_Values_Init; + -- We want to avoid looking at every point in the Cartesian + -- product of all component values. Instead we select, for each + -- component, a set of representative values and then look only + -- at the Cartesian product of those sets. A single value can + -- safely represent a larger enclosing interval if every choice + -- for that component either completely includes or completely + -- excludes the interval. The elements of this array will be + -- populated by a call to Initialize_Representative_Values and + -- will remain constant after that. + + type Value_Index_Base is new Natural; + + function Value_Index_Count return Value_Index_Base; + -- Returns the product of the sizes of the Representative_Values + -- sets (i.e., the size of the Cartesian product of the sets). + -- May return zero if one of the sets is empty. + -- This function is called exactly once, immediately after it + -- is declared. + + ----------------------- + -- Value_Index_Count -- + ----------------------- + + function Value_Index_Count return Value_Index_Base is + Result : Value_Index_Base := 1; + begin + for Set of Representative_Values loop + Result := Result * Value_Index_Base (Uint_Sets.Size (Set)); + end loop; + return Result; + end Value_Index_Count; + + Max_Value_Index : constant Value_Index_Base := Value_Index_Count; + + subtype Value_Index is Value_Index_Base range 1 .. Max_Value_Index; + type Value_Index_Set is array (Value_Index) of Boolean; + + package Value_Index_Set_Table is new Table.Table + (Table_Component_Type => Value_Index_Set, + Table_Index_Type => Value_Set, + Table_Low_Bound => 1, + Table_Initial => 16, + Table_Increment => 100, + Table_Name => "Composite_Case_Ops.Value_Sets"); + -- A nonzero Value_Set value is an index into this table. + + function Indexed (Index : Value_Set) return Value_Index_Set + is (Value_Index_Set_Table.Table.all (Index)); + + function Allocate_Table_Element (Initial_Value : Value_Index_Set) + return Value_Set; + -- Allocate and initialize a new table element; return its index. + + ---------------------------- + -- Allocate_Table_Element -- + ---------------------------- + + function Allocate_Table_Element (Initial_Value : Value_Index_Set) + return Value_Set + is + use Value_Index_Set_Table; + begin + Append (Initial_Value); + return Last; + end Allocate_Table_Element; + + procedure Assign_Table_Element (Index : Value_Set; + Value : Value_Index_Set); + -- Assign specified value to specified table element. + + -------------------------- + -- Assign_Table_Element -- + -------------------------- + + procedure Assign_Table_Element (Index : Value_Set; + Value : Value_Index_Set) + is + begin + Value_Index_Set_Table.Table.all (Index) := Value; + end Assign_Table_Element; + + ------------- + -- Compare -- + ------------- + + function Compare (S1, S2 : Value_Set) return Set_Comparison is + begin + if S1 = Empty or S2 = Empty then + return Disjoint; + elsif Indexed (S1) = Indexed (S2) then + return Equal; + else + declare + Intersection : constant Value_Index_Set + := Indexed (S1) and Indexed (S2); + begin + if (for all Flag of Intersection => not Flag) then + return Disjoint; + elsif Intersection = Indexed (S1) then + return Contained_By; + elsif Intersection = Indexed (S2) then + return Contains; + else + return Overlaps; + end if; + end; + end if; + end Compare; + + ------------------------- + -- Complement_Is_Empty -- + ------------------------- + + function Complement_Is_Empty (Set : Value_Set) return Boolean + is (Set /= Empty + and then (for all Flag of Indexed (Set) => Flag)); + + --------------------- + -- Free_Value_Sets -- + --------------------- + procedure Free_Value_Sets is + begin + Value_Index_Set_Table.Free; + end Free_Value_Sets; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Value_Set; Source : Value_Set) is + begin + if Source /= Empty then + if Target = Empty then + Target := Allocate_Table_Element (Indexed (Source)); + else + Assign_Table_Element + (Target, Indexed (Target) or Indexed (Source)); + end if; + end if; + end Union; + + ------------ + -- Remove -- + ------------ + + procedure Remove (Target : in out Value_Set; Source : Value_Set) is + begin + if Source /= Empty and Target /= Empty then + Assign_Table_Element + (Target, Indexed (Target) and not Indexed (Source)); + if (for all V of Indexed (Target) => not V) then + Target := Empty; + end if; + end if; + end Remove; + + --------------------- + -- Matching_Values -- + --------------------- + + function Matching_Values + (Info : Composite_Range_Info) return Value_Set + is + Matches : Value_Index_Set; + Next_Index : Value_Index := 1; + Done : Boolean := False; + Point : array (Part_Id) of Uint; + + procedure Test_Point_For_Match; + -- Point identifies a point in the Cartesian product of the + -- representative value sets. Record whether that Point + -- belongs to the product-of-ranges specified by Info. + + -------------------------- + -- Test_Point_For_Match -- + -------------------------- + + procedure Test_Point_For_Match is + function In_Range (Val : Uint; Rang : Discrete_Range_Info) + return Boolean is + ((Rang.Low <= Val) and then (Val <= Rang.High)); + begin + pragma Assert (not Done); + Matches (Next_Index) := + (for all P in Part_Id => In_Range (Point (P), Info (P))); + if Next_Index = Matches'Last then + Done := True; + else + Next_Index := Next_Index + 1; + end if; + end Test_Point_For_Match; + + procedure Test_Points (P : Part_Id); + -- Iterate over the Cartesian product of the representative + -- value sets, calling Test_Point_For_Match for each point. + + ----------------- + -- Test_Points -- + ----------------- + + procedure Test_Points (P : Part_Id) is + use Uint_Sets; + Iter : Iterator := Iterate (Representative_Values (P)); + begin + -- We could traverse here in sorted order, as opposed to + -- whatever order the set iterator gives us. + -- No need for that as long as every iteration over + -- a given representative values set yields the same order. + -- Not sorting is more efficient, but it makes it harder to + -- interpret a Value_Index_Set bit vector when debugging. + + while Has_Next (Iter) loop + Next (Iter, Point (P)); + + -- If we have finished building up a Point value, then + -- test it for matching. Otherwise, recurse to continue + -- building up a point value. + + if P = Part_Id'Last then + Test_Point_For_Match; + else + Test_Points (P + 1); + end if; + end loop; + end Test_Points; + + begin + Test_Points (1); + if (for all Flag of Matches => not Flag) then + return Empty; + end if; + return Allocate_Table_Element (Matches); + end Matching_Values; + + end Value_Sets; + + -------------- + -- Analysis -- + -------------- + + function Analysis return Choices_Info is + Result : Choices_Info; + Alt : Node_Id := First (Alternatives (Case_Statement)); + A_Id : Alternative_Id := 1; + C_Id : Choice_Id := 1; + begin + while Present (Alt) loop + declare + Choice : Node_Id := First (Discrete_Choices (Alt)); + begin + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + pragma Assert (Choices_Bounds (C_Id).Is_Others); + Result (C_Id) := + (Alternative => A_Id, + Is_Others => True); + else + Result (C_Id) := + (Alternative => A_Id, + Is_Others => False, + Matches => Value_Sets.Matching_Values + (Choices_Bounds (C_Id).Ranges)); + end if; + Next (Choice); + if C_Id /= Choice_Id'Last then + C_Id := C_Id + 1; + end if; + end loop; + end; + + Next (Alt); + if A_Id /= Alternative_Id'Last then + A_Id := A_Id + 1; + end if; + end loop; + + pragma Assert (A_Id = Alternative_Id'Last); + pragma Assert (C_Id = Choice_Id'Last); + + return Result; + end Analysis; + + end Choice_Analysis; + + end Composite_Case_Ops; + -------------------------- -- Expand_Others_Choice -- -------------------------- @@ -1379,6 +2662,15 @@ package body Sem_Case is -- later entry into the choices table so that they can be sorted -- later on. + procedure Check_Case_Pattern_Choices; + -- Check choices validity for the Ada extension case where the + -- selecting expression is not of a discrete type and so the + -- choices are patterns. + + procedure Check_Composite_Case_Selector; + -- Check that the (non-discrete) type of the expression being + -- cased on is suitable. + procedure Handle_Static_Predicate (Typ : Entity_Id; Lo : Node_Id; @@ -1500,6 +2792,195 @@ package body Sem_Case is Num_Choices := Num_Choices + 1; end Check; + -------------------------------- + -- Check_Case_Pattern_Choices -- + -------------------------------- + + procedure Check_Case_Pattern_Choices is + -- ??? Need to Free/Finalize value sets allocated here. + + package Ops is new Composite_Case_Ops.Choice_Analysis + (Case_Statement => N); + use Ops; + use Ops.Value_Sets; + + Empty : Value_Set renames Value_Sets.Empty; + -- Cope with hiding due to multiple use clauses + + Info : constant Choices_Info := Analysis; + Others_Seen : Boolean := False; + + begin + declare + Matches : array (Alternative_Id) of Value_Sets.Value_Set := + (others => Empty); + + Flag_Overlapping_Within_One_Alternative : constant Boolean := + False; + -- We may want to flag overlapping (perhaps with only a + -- warning) if the pattern binds an identifier, as in + -- when (Positive, <X>) | (Integer, <X>) => + + Covered : Value_Set := Empty; + -- The union of all alternatives seen so far + + begin + for Choice of Info loop + if Choice.Is_Others then + Others_Seen := True; + else + if Flag_Overlapping_Within_One_Alternative + and then (Compare (Matches (Choice.Alternative), + Choice.Matches) /= Disjoint) + then + Error_Msg_N + ("bad overlapping within one alternative", N); + end if; + + Union (Target => Matches (Choice.Alternative), + Source => Choice.Matches); + end if; + end loop; + + for A1 in Alternative_Id loop + for A2 in Alternative_Id + range A1 + 1 .. Alternative_Id'Last + loop + case Compare (Matches (A1), Matches (A2)) is + when Disjoint | Contained_By => + null; -- OK + when Overlaps => + declare + Uncovered_1, Uncovered_2 : Value_Set := Empty; + begin + Union (Uncovered_1, Matches (A1)); + Remove (Uncovered_1, Covered); + Union (Uncovered_2, Matches (A2)); + Remove (Uncovered_2, Covered); + + -- Recheck for overlap after removing choices + -- covered by earlier alternatives. + + case Compare (Uncovered_1, Uncovered_2) is + when Disjoint | Contained_By => + null; + when Contains | Overlaps | Equal => + Error_Msg_N + ("bad alternative overlapping", N); + end case; + end; + + when Equal => + Error_Msg_N ("alternatives match same values", N); + when Contains => + Error_Msg_N ("alternatives in wrong order", N); + end case; + end loop; + + Union (Target => Covered, Source => Matches (A1)); + end loop; + + if (not Others_Seen) and then not Complement_Is_Empty (Covered) + then + Error_Msg_N ("not all values are covered", N); + end if; + end; + + Ops.Value_Sets.Free_Value_Sets; + end Check_Case_Pattern_Choices; + + ----------------------------------- + -- Check_Composite_Case_Selector -- + ----------------------------------- + + procedure Check_Composite_Case_Selector is + -- Some of these restrictions will be relaxed eventually, but best + -- to initially err in the direction of being too restrictive. + + procedure Check_Component_Subtype (Subtyp : Entity_Id); + -- Recursively traverse subcomponent types to perform checks. + + ----------------------------- + -- Check_Component_Subtype -- + ----------------------------- + + procedure Check_Component_Subtype (Subtyp : Entity_Id) is + begin + if Has_Predicates (Subtyp) then + Error_Msg_N + ("subtype of case selector (or subcomponent thereof)" & + "has predicate", N); + elsif Is_Discrete_Type (Subtyp) then + if not Is_Static_Subtype (Subtyp) then + Error_Msg_N + ("discrete subtype of selector subcomponent is not " & + "a static subtype", N); + elsif Is_Enumeration_Type (Subtyp) + and then Has_Enumeration_Rep_Clause (Subtyp) + then + Error_Msg_N + ("enumeration type of selector subcomponent has " & + "an enumeration representation clause", N); + end if; + elsif Is_Array_Type (Subtyp) then + pragma Assert (Is_Constrained (Subtyp)); + + if Number_Dimensions (Subtyp) /= 1 then + Error_Msg_N + ("dimensionality of array type of case selector (or " & + "subcomponent thereof) is greater than 1", N); + elsif not Is_OK_Static_Range (First_Index (Subtyp)) then + Error_Msg_N + ("array subtype of case selector (or " & + "subcomponent thereof) has nonstatic constraint", N); + end if; + Check_Component_Subtype (Component_Type (Subtyp)); + elsif Is_Record_Type (Subtyp) then + if Has_Discriminants (Subtyp) then + Error_Msg_N + ("type of case selector (or subcomponent thereof)" & + "is discriminated", N); + else + declare + Comp : Entity_Id := First_Component (Subtyp); + begin + while Present (Comp) loop + Check_Component_Subtype (Etype (Comp)); + Next_Component (Comp); + end loop; + end; + end if; + else + Error_Msg_N + ("type of case selector (or subcomponent thereof) is " & + "not a discrete type, a record type, or an array type", + N); + end if; + end Check_Component_Subtype; + + begin + if not Is_Composite_Type (Subtyp) then + Error_Msg_N + ("case selector type neither discrete nor composite", N); + + elsif Is_Limited_Type (Subtyp) then + Error_Msg_N ("case selector type is limited", N); + + elsif Is_Class_Wide_Type (Subtyp) then + Error_Msg_N ("case selector type is class-wide", N); + + elsif Needs_Finalization (Subtyp) then + Error_Msg_N ("case selector type requires finalization", N); + + elsif Is_Array_Type (Subtyp) and not Is_Constrained (Subtyp) then + Error_Msg_N + ("case selector subtype is unconstrained array subtype", N); + + else + Check_Component_Subtype (Subtyp); + end if; + end Check_Composite_Case_Selector; + ----------------------------- -- Handle_Static_Predicate -- ----------------------------- @@ -1562,6 +3043,14 @@ package body Sem_Case is -- a complete mess. if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then + + -- Hold on, maybe it isn't a complete mess after all. + + if Extensions_Allowed and then Subtyp /= Any_Type then + Check_Composite_Case_Selector; + Check_Case_Pattern_Choices; + end if; + return; end if; @@ -1809,4 +3298,37 @@ package body Sem_Case is end Generic_Check_Choices; + ---------------------------- + -- Is_Case_Choice_Pattern -- + ---------------------------- + + function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean is + E : Node_Id := Expr; + begin + if not Extensions_Allowed then + return False; + end if; + + loop + case Nkind (E) is + when N_Case_Statement_Alternative + | N_Case_Expression_Alternative + => + -- We could return False if selecting expression is discrete, + -- but this doesn't seem to be worth the bother. + return True; + + when N_Empty + | N_Statement_Other_Than_Procedure_Call + | N_Procedure_Call_Statement + | N_Declaration + => + return False; + + when others => + E := Parent (E); + end case; + end loop; + end Is_Case_Choice_Pattern; + end Sem_Case; diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads index 7bde09d..3943cf2 100644 --- a/gcc/ada/sem_case.ads +++ b/gcc/ada/sem_case.ads @@ -147,4 +147,10 @@ package Sem_Case is -- the parent node (N_Variant, N_Case_Expression/Statement_Alternative). end Generic_Check_Choices; + + function Is_Case_Choice_Pattern (Expr : Node_Id) return Boolean; + -- GNAT language extensions allow casing on a non-discrete value, with + -- patterns as case choices. Return True iff Expr is such a pattern, or + -- a subexpression thereof. + end Sem_Case; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 2c0bb5f..4574ef9 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1412,6 +1412,9 @@ package body Sem_Ch5 is -- the case statement, and as a result it is not a good idea to output -- warning messages about unreachable code. + Is_General_Case_Statement : Boolean := False; + -- Set True (later) if type of case expression is not discrete + procedure Non_Static_Choice_Error (Choice : Node_Id); -- Error routine invoked by the generic instantiation below when the -- case statement has a non static choice. @@ -1453,6 +1456,12 @@ package body Sem_Ch5 is Ent : Entity_Id; begin + if Is_General_Case_Statement then + return; + -- Processing deferred in this case; decls associated with + -- pattern match bindings don't exist yet. + end if; + Unblocked_Exit_Count := Unblocked_Exit_Count + 1; Statements_Analyzed := True; @@ -1527,6 +1536,35 @@ package body Sem_Ch5 is Resolve (Exp); Exp_Type := Full_View (Etype (Exp)); + -- For Ada, overloading might be ok because subsequently filtering + -- out non-discretes may resolve the ambiguity. + -- But GNAT extensions allow casing on non-discretes. + + elsif Extensions_Allowed and then Is_Overloaded (Exp) then + + -- TBD: Generate better ambiguity diagnostics here. + -- It would be nice if we could generate all the right error + -- messages by calling "Resolve (Exp, Any_Type);" in the + -- same way that they are generated a few lines below by the + -- call "Analyze_And_Resolve (Exp, Any_Discrete);". + -- Unfortunately, Any_Type and Any_Discrete are not treated + -- consistently (specifically, by Sem_Type.Covers), so that + -- doesn't work. + + Error_Msg_N + ("selecting expression of general case statement is ambiguous", + Exp); + return; + + -- Check for a GNAT-extension "general" case statement (i.e., one where + -- the type of the selecting expression is not discrete). + + elsif Extensions_Allowed + and then not Is_Discrete_Type (Etype (Exp)) + then + Resolve (Exp, Etype (Exp)); + Exp_Type := Etype (Exp); + Is_General_Case_Statement := True; else Analyze_And_Resolve (Exp, Any_Discrete); Exp_Type := Etype (Exp); @@ -1579,6 +1617,21 @@ package body Sem_Ch5 is Analyze_Choices (Alternatives (N), Exp_Type); Check_Choices (N, Alternatives (N), Exp_Type, Others_Present); + if Is_General_Case_Statement then + -- Work normally done in Process_Statements was deferred; do that + -- deferred work now that Check_Choices has had a chance to create + -- any needed pattern-match-binding declarations. + declare + Alt : Node_Id := First (Alternatives (N)); + begin + while Present (Alt) loop + Unblocked_Exit_Count := Unblocked_Exit_Count + 1; + Analyze_Statements (Statements (Alt)); + Next (Alt); + end loop; + end; + end if; + if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3ca4569..32e71cc 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -57,6 +57,7 @@ with Sem; use Sem; with Sem_Aggr; use Sem_Aggr; with Sem_Attr; use Sem_Attr; with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; @@ -7768,10 +7769,12 @@ package body Sem_Res is -- Case of (sub)type name appearing in a context where an expression -- is expected. This is legal if occurrence is a current instance. - -- See RM 8.6 (17/3). + -- See RM 8.6 (17/3). It is also legal if the expression is + -- part of a choice pattern for a case stmt/expr having a + -- non-discrete selecting expression. elsif Is_Type (E) then - if Is_Current_Instance (N) then + if Is_Current_Instance (N) or else Is_Case_Choice_Pattern (N) then null; -- Any other use is an error diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index f62d2d1..5a4bb66 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -4114,6 +4114,7 @@ package Sinfo is -- Loop_Actions -- Box_Present -- Inherited_Discriminant + -- Binding_Chars -- Note: this structure is used for both record component associations -- and array component associations, since the two cases aren't always @@ -4121,7 +4122,11 @@ package Sinfo is -- list of selector names in the record aggregate case, or a list of -- discrete choices in the array aggregate case or an N_Others_Choice -- node (which appears as a singleton list). Box_Present gives support - -- to Ada 2005 (AI-287). + -- to Ada 2005 (AI-287). Binding_Chars is only set if GNAT extensions + -- are enabled and the given component association occurs within a + -- choice_expression; in this case, it is the Name_Id, if any, specified + -- via either of two syntactic forms: "Foo => Bar is Abc" or + -- "Foo => <Abc>". ---------------------------------- -- 4.3.1 Component Choice List -- @@ -5013,11 +5018,16 @@ package Sinfo is -- Discrete_Choices -- Statements -- Has_SP_Choice + -- Multidefined_Bindings -- 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. + -- of equivalent values or ranges. Multidefined_Bindings is True iff + -- more than one choice is present and each choice contains + -- at least one component association having a non-null Binding_Chars + -- attribute; this can only occur if GNAT extensions are enabled + -- and the type of the case selector is composite. ------------------------- -- 5.5 Loop Statement -- |