diff options
Diffstat (limited to 'gcc/ada/sem_case.adb')
| -rw-r--r-- | gcc/ada/sem_case.adb | 363 |
1 files changed, 271 insertions, 92 deletions
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 515d2a6009e..b3f47a6df9b 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -57,15 +57,15 @@ 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 -- ----------------------- - procedure Check_Choices + procedure Check_Choice_Set (Choice_Table : in out Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; @@ -95,7 +95,7 @@ package body Sem_Case is (Case_Table : Choice_Table_Type; Others_Choice : Node_Id; Choice_Type : Entity_Id); - -- The case table is the table generated by a call to Analyze_Choices + -- The case table is the table generated by a call to Check_Choices -- (with just 1 .. Last_Choice entries present). Others_Choice is a -- pointer to the N_Others_Choice node (this routine is only called if -- an others choice is present), and Choice_Type is the discrete type @@ -103,11 +103,11 @@ package body Sem_Case is -- determine the set of values covered by others. This choice list is -- set in the Others_Discrete_Choices field of the N_Others_Choice node. - ------------------- - -- Check_Choices -- - ------------------- + ---------------------- + -- Check_Choice_Set -- + ---------------------- - procedure Check_Choices + procedure Check_Choice_Set (Choice_Table : in out Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; @@ -126,6 +126,10 @@ package body Sem_Case is -- choice that covered a predicate set. Error denotes whether the check -- found an illegal intersection. + procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id); + -- Post message "duplication of choice value(s) bla bla at xx". Message + -- is posted at location C. Caller sets Error_Msg_Sloc for xx. + procedure Explain_Non_Static_Bound; -- Called when we find a non-static bound, requiring the base type to -- be covered. Provides where possible a helpful explanation of why the @@ -145,8 +149,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 @@ -238,6 +241,7 @@ package body Sem_Case is Choice_Hi : constant Uint := Expr_Value (Choice.Hi); Choice_Lo : constant Uint := Expr_Value (Choice.Lo); Loc : Source_Ptr; + LocN : Node_Id; Next_Hi : Uint; Next_Lo : Uint; Pred_Hi : Uint; @@ -249,11 +253,13 @@ package body Sem_Case is -- Find the proper error message location if Present (Choice.Node) then - Loc := Sloc (Choice.Node); + LocN := Choice.Node; else - Loc := Sloc (Case_Node); + LocN := Case_Node; end if; + Loc := Sloc (LocN); + if Present (Pred) then Pred_Lo := Expr_Value (Low_Bound (Pred)); Pred_Hi := Expr_Value (High_Bound (Pred)); @@ -263,16 +269,17 @@ package body Sem_Case is else Illegal_Range (Loc, Choice_Lo, Choice_Hi); Error := True; - return; end if; -- Step 1: Detect duplicate choices - if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) - or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) - then - Error_Msg ("duplication of choice value", Loc); + if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then + Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN); + Error := True; + + elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then + Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN); Error := True; -- Step 2: Detect full coverage @@ -312,8 +319,16 @@ package body Sem_Case is -- ^ illegal ^ elsif Pred_Lo < Choice_Lo and then Pred_Hi < Choice_Lo then - Missing_Choice (Pred_Lo, Pred_Hi); - Error := True; + if Others_Present then + + -- Current predicate set is covered by others clause. + + null; + + else + Missing_Choice (Pred_Lo, Pred_Hi); + Error := True; + end if; -- There may be several static predicate sets between the current -- one and the choice. Inspect the next static predicate set. @@ -377,7 +392,12 @@ package body Sem_Case is if Others_Present then Prev_Lo := Choice_Lo; Prev_Hi := Choice_Hi; - Next (Pred); + + -- Check whether predicate set is fully covered by choice + + if Pred_Hi = Choice_Hi then + Next (Pred); + end if; -- Choice_Lo Choice_Hi Pred_Hi -- +===========+===========+ @@ -422,6 +442,45 @@ package body Sem_Case is end if; end Check_Against_Predicate; + ---------------- + -- Dup_Choice -- + ---------------- + + procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id) is + begin + -- In some situations, we call this with a null range, and obviously + -- we don't want to complain in this case. + + if Lo > Hi then + return; + end if; + + -- Case of only one value that is missing + + if Lo = Hi then + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg_N ("duplication of choice value: ^#!", C); + else + Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); + Error_Msg_N ("duplication of choice value: %#!", C); + end if; + + -- More than one choice value, so print range of values + + else + if Is_Integer_Type (Bounds_Type) then + Error_Msg_Uint_1 := Lo; + Error_Msg_Uint_2 := Hi; + Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); + else + Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); + Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); + Error_Msg_N ("duplication of choice values: % .. %#!", C); + end if; + end if; + end Dup_Choice; + ------------------------------ -- Explain_Non_Static_Bound -- ------------------------------ @@ -443,21 +502,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 @@ -600,7 +659,7 @@ package body Sem_Case is Prev_Lo : Uint; Prev_Hi : Uint; - -- Start of processing for Check_Choices + -- Start of processing for Check_Choice_Set begin -- Choice_Table must start at 0 which is an unused location used by the @@ -693,10 +752,12 @@ package body Sem_Case is if Sloc (Prev_Choice) <= Sloc (Choice) then Error_Msg_Sloc := Sloc (Prev_Choice); - Error_Msg_N ("duplication of choice value#", Choice); + Dup_Choice + (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice); else Error_Msg_Sloc := Sloc (Choice); - Error_Msg_N ("duplication of choice value#", Prev_Choice); + Dup_Choice + (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice); end if; elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then @@ -708,15 +769,15 @@ package body Sem_Case is end if; end loop; - if not Others_Present and then Expr_Value (Bounds_Hi) > Choice_Hi then - Missing_Choice (Choice_Hi + 1, Bounds_Hi); + if not Others_Present and then Expr_Value (Bounds_Hi) > Prev_Hi then + Missing_Choice (Prev_Hi + 1, Bounds_Hi); - if Expr_Value (Bounds_Hi) > Choice_Hi + 1 then + if Expr_Value (Bounds_Hi) > Prev_Hi + 1 then Explain_Non_Static_Bound; end if; end if; end if; - end Check_Choices; + end Check_Choice_Set; ------------------ -- Choice_Image -- @@ -801,11 +862,10 @@ package body Sem_Case is Previous_Hi : Uint; function Build_Choice (Value1, Value2 : Uint) return Node_Id; - -- Builds a node representing the missing choices given by the - -- Value1 and Value2. A N_Range node is built if there is more than - -- one literal value missing. Otherwise a single N_Integer_Literal, - -- N_Identifier or N_Character_Literal is built depending on what - -- Choice_Type is. + -- Builds a node representing the missing choices given by Value1 and + -- Value2. A N_Range node is built if there is more than one literal + -- value missing. Otherwise a single N_Integer_Literal, N_Identifier + -- or N_Character_Literal is built depending on what Choice_Type is. function Lit_Of (Value : Uint) return Node_Id; -- Returns the Node_Id for the enumeration literal corresponding to the @@ -977,11 +1037,11 @@ package body Sem_Case is null; end No_OP; - -------------------------------- - -- Generic_Choices_Processing -- - -------------------------------- + ----------------------------- + -- Generic_Analyze_Choices -- + ----------------------------- - package body Generic_Choices_Processing is + package body Generic_Analyze_Choices is -- The following type is used to gather the entries for the choice -- table, so that we can then allocate the right length. @@ -994,20 +1054,143 @@ package body Sem_Case is Nxt : Link_Ptr; end record; - procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); - --------------------- -- Analyze_Choices -- --------------------- procedure Analyze_Choices - (N : Node_Id; - Subtyp : Entity_Id; - Raises_CE : out Boolean; - Others_Present : out Boolean) + (Alternatives : List_Id; + Subtyp : Entity_Id) + is + Choice_Type : constant Entity_Id := Base_Type (Subtyp); + -- The actual type against which the discrete choices are resolved. + -- Note that this type is always the base type not the subtype of the + -- ruling expression, index or discriminant. + + Expected_Type : Entity_Id; + -- The expected type of each choice. Equal to Choice_Type, except if + -- the expression is universal, in which case the choices can be of + -- any integer type. + + Alt : Node_Id; + -- A case statement alternative or a variant in a record type + -- declaration. + + Choice : Node_Id; + Kind : Node_Kind; + -- The node kind of the current Choice + + begin + -- Set Expected type (= choice type except for universal integer, + -- where we accept any integer type as a choice). + + if Choice_Type = Universal_Integer then + Expected_Type := Any_Integer; + else + Expected_Type := Choice_Type; + end if; + + -- Now loop through the case alternatives or record variants + + Alt := First (Alternatives); + while Present (Alt) loop + + -- If pragma, just analyze it + + if Nkind (Alt) = N_Pragma then + Analyze (Alt); + + -- 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 (Discrete_Choices (Alt)); + while Present (Choice) loop + Analyze (Choice); + Kind := Nkind (Choice); + + -- Choice is a Range + + if Kind = N_Range + or else (Kind = N_Attribute_Reference + and then Attribute_Name (Choice) = Name_Range) + then + Resolve (Choice, Expected_Type); + + -- Choice is a subtype name, nothing further to do now + + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + null; + + -- Choice is a subtype indication + + elsif Kind = N_Subtype_Indication then + Resolve_Discrete_Subtype_Indication + (Choice, Expected_Type); + + -- Others choice, no analysis needed + + elsif Kind = N_Others_Choice then + null; + + -- Only other possibility is an expression + + else + Resolve (Choice, Expected_Type); + end if; + + -- Move to next choice + + Next (Choice); + end loop; + + Process_Associated_Node (Alt); + end if; + + Next (Alt); + end loop; + end Analyze_Choices; + + end Generic_Analyze_Choices; + + --------------------------- + -- Generic_Check_Choices -- + --------------------------- + + package body Generic_Check_Choices is + + -- The following type is used to gather the entries for the choice + -- table, so that we can then allocate the right length. + + type Link; + type Link_Ptr is access all Link; + + type Link is record + Val : Choice_Bounds; + Nxt : Link_Ptr; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); + + ------------------- + -- Check_Choices -- + ------------------- + + procedure Check_Choices + (N : Node_Id; + Alternatives : List_Id; + Subtyp : Entity_Id; + Others_Present : out Boolean) is E : Entity_Id; + Raises_CE : Boolean; + -- Set True if one of the bounds of a choice raises CE + Enode : Node_Id; -- This is where we post error messages for bounds out of range @@ -1044,9 +1227,6 @@ package body Sem_Case is Kind : Node_Kind; -- The node kind of the current Choice - Delete_Choice : Boolean; - -- Set to True to delete the current choice - Others_Choice : Node_Id := Empty; -- Remember others choice if it is present (empty otherwise) @@ -1168,12 +1348,20 @@ package body Sem_Case is Num_Choices := Num_Choices + 1; end Check; - -- Start of processing for Analyze_Choices + -- Start of processing for Check_Choices begin Raises_CE := False; Others_Present := False; + -- If Subtyp is not a discrete type or there was some other error, + -- then don't try any semantic checking on the choices since we have + -- a complete mess. + + if not Is_Discrete_Type (Subtyp) or else Subtyp = Any_Type then + return; + end if; + -- If Subtyp is not a static subtype Ada 95 requires then we use the -- bounds of its base type to determine the values covered by the -- discrete choices. @@ -1212,7 +1400,7 @@ package body Sem_Case is -- Now loop through the case alternatives or record variants - Alt := First (Get_Alternatives (N)); + Alt := First (Alternatives); while Present (Alt) loop -- If pragma, just analyze it @@ -1220,13 +1408,14 @@ 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); Kind := Nkind (Choice); -- Choice is a Range @@ -1235,7 +1424,6 @@ package body Sem_Case is or else (Kind = N_Attribute_Reference and then Attribute_Name (Choice) = Name_Range) then - Resolve (Choice, Expected_Type); Check (Choice, Low_Bound (Choice), High_Bound (Choice)); -- Choice is a subtype name @@ -1243,9 +1431,13 @@ package body Sem_Case is elsif Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)) then + -- Check for inappropriate type + if not Covers (Expected_Type, Etype (Choice)) then Wrong_Type (Choice, Choice_Type); + -- Type is OK, so check further + else E := Entity (Choice); @@ -1260,34 +1452,32 @@ 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; + + Set_Has_SP_Choice (Alt); end if; -- Not predicated subtype case @@ -1306,8 +1496,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); @@ -1323,7 +1511,8 @@ package body Sem_Case is else if Is_OK_Static_Expression (L) - and then Is_OK_Static_Expression (H) + and then + Is_OK_Static_Expression (H) then if Expr_Value (L) > Expr_Value (H) then Process_Empty_Choice (Choice); @@ -1351,9 +1540,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 (Alternatives)) then Error_Msg_N ("the choice OTHERS must appear alone and last", @@ -1367,22 +1556,12 @@ package body Sem_Case is -- Only other possibility is an expression else - Resolve (Choice, Expected_Type); Check (Choice, Choice, Choice); end if; - -- Move to next choice, deleting the current one if the - -- flag requesting this deletion is set True. - - declare - C : constant Node_Id := Choice; - begin - Next (Choice); + -- Move to next choice - if Delete_Choice then - Remove (C); - end if; - end; + Next (Choice); end loop; Process_Associated_Node (Alt); @@ -1412,7 +1591,7 @@ package body Sem_Case is end loop; end; - Check_Choices + Check_Choice_Set (Choice_Table, Bounds_Type, Subtyp, @@ -1431,8 +1610,8 @@ package body Sem_Case is Choice_Type => Bounds_Type); end if; end; - end Analyze_Choices; + end Check_Choices; - end Generic_Choices_Processing; + end Generic_Check_Choices; end Sem_Case; |