diff options
Diffstat (limited to 'gcc/ada/sem_case.adb')
| -rw-r--r-- | gcc/ada/sem_case.adb | 224 |
1 files changed, 179 insertions, 45 deletions
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 27a5c67..6701776 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -26,6 +26,8 @@ with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -65,7 +67,7 @@ package body Sem_Case is -- 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 +97,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 +105,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; @@ -598,7 +600,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 @@ -714,7 +716,7 @@ package body Sem_Case is end if; end if; end if; - end Check_Choices; + end Check_Choice_Set; ------------------ -- Choice_Image -- @@ -799,11 +801,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 @@ -975,11 +976,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. @@ -992,20 +993,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 @@ -1042,9 +1166,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) @@ -1166,12 +1287,22 @@ 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. @@ -1210,7 +1341,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 @@ -1226,7 +1357,6 @@ package body Sem_Case is else Choice := First (Discrete_Choices (Alt)); while Present (Choice) loop - Delete_Choice := False; Analyze (Choice); Kind := Nkind (Choice); @@ -1244,9 +1374,19 @@ package body Sem_Case is elsif Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)) then + -- We have to make sure the subtype is frozen, it must be + -- before we can do the following analyses on choices! + + Insert_Actions + (N, Freeze_Entity (Entity (Choice), Choice)); + + -- 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); @@ -1285,6 +1425,8 @@ package body Sem_Case is Next (P); end loop; end; + + Set_Has_SP_Choice (Alt); end if; -- Not predicated subtype case @@ -1318,7 +1460,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); @@ -1348,7 +1491,7 @@ package body Sem_Case is elsif Kind = N_Others_Choice then if not (Choice = First (Discrete_Choices (Alt)) and then Choice = Last (Discrete_Choices (Alt)) - and then Alt = Last (Get_Alternatives (N))) + and then Alt = Last (Alternatives)) then Error_Msg_N ("the choice OTHERS must appear alone and last", @@ -1366,18 +1509,9 @@ package body Sem_Case is Check (Choice, Choice, Choice); end if; - -- Move to next choice, deleting the current one if the - -- flag requesting this deletion is set True. + -- Move to next choice - declare - C : constant Node_Id := Choice; - begin - Next (Choice); - - if Delete_Choice then - Remove (C); - end if; - end; + Next (Choice); end loop; Process_Associated_Node (Alt); @@ -1407,7 +1541,7 @@ package body Sem_Case is end loop; end; - Check_Choices + Check_Choice_Set (Choice_Table, Bounds_Type, Subtyp, @@ -1426,8 +1560,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; |