diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 423 |
1 files changed, 222 insertions, 201 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f9efdab2c0d..3b90fe82c7e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1663,9 +1663,9 @@ package body Sem_Util is return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; - when N_Op_Divide | - N_Op_Mod | - N_Op_Rem + when N_Op_Divide + | N_Op_Mod + | N_Op_Rem => if Do_Division_Check (Expr) or else @@ -1679,25 +1679,25 @@ package body Sem_Util is Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; - when N_Op_Add | - N_Op_And | - N_Op_Concat | - N_Op_Eq | - N_Op_Expon | - N_Op_Ge | - N_Op_Gt | - N_Op_Le | - N_Op_Lt | - N_Op_Multiply | - N_Op_Ne | - N_Op_Or | - N_Op_Rotate_Left | - N_Op_Rotate_Right | - N_Op_Shift_Left | - N_Op_Shift_Right | - N_Op_Shift_Right_Arithmetic | - N_Op_Subtract | - N_Op_Xor + when N_Op_Add + | N_Op_And + | N_Op_Concat + | N_Op_Eq + | N_Op_Expon + | N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + | N_Op_Multiply + | N_Op_Ne + | N_Op_Or + | N_Op_Rotate_Left + | N_Op_Rotate_Right + | N_Op_Shift_Left + | N_Op_Shift_Right + | N_Op_Shift_Right_Arithmetic + | N_Op_Subtract + | N_Op_Xor => if Do_Overflow_Check (Expr) then return False; @@ -2272,7 +2272,9 @@ package body Sem_Util is Collect_Identifiers (Low_Bound (N)); Collect_Identifiers (High_Bound (N)); - when N_Op | N_Membership_Test => + when N_Membership_Test + | N_Op + => declare Expr : Node_Id; @@ -2349,8 +2351,9 @@ package body Sem_Util is end loop; end; - when N_Subprogram_Call | - N_Entry_Call_Statement => + when N_Entry_Call_Statement + | N_Subprogram_Call + => declare Id : constant Entity_Id := Get_Function_Id (N); Formal : Node_Id; @@ -2371,8 +2374,9 @@ package body Sem_Util is end loop; end; - when N_Aggregate | - N_Extension_Aggregate => + when N_Aggregate + | N_Extension_Aggregate + => declare Assoc : Node_Id; Choice : Node_Id; @@ -2681,16 +2685,19 @@ package body Sem_Util is while Present (Elmt_2) loop if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then case Nkind (Parent (Node (Elmt_2))) is - when N_Aggregate | - N_Component_Association | - N_Component_Declaration => + when N_Aggregate + | N_Component_Association + | N_Component_Declaration + => Error_Msg_N ("value may be affected by call in other " & "component because they are evaluated " & "in unspecified order", Node (Elmt_2)); - when N_In | N_Not_In => + when N_In + | N_Not_In + => Error_Msg_N ("value may be affected by call in other " & "alternative because they are evaluated " @@ -5183,67 +5190,67 @@ package body Sem_Util is begin case Nkind (N) is - when N_Abstract_Subprogram_Declaration | - N_Expression_Function | - N_Formal_Subprogram_Declaration | - N_Generic_Package_Declaration | - N_Generic_Subprogram_Declaration | - N_Package_Declaration | - N_Subprogram_Body | - N_Subprogram_Body_Stub | - N_Subprogram_Declaration | - N_Subprogram_Renaming_Declaration + when N_Abstract_Subprogram_Declaration + | N_Expression_Function + | N_Formal_Subprogram_Declaration + | N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Subprogram_Body + | N_Subprogram_Body_Stub + | N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration => return Defining_Entity (Specification (N)); - when N_Component_Declaration | - N_Defining_Program_Unit_Name | - N_Discriminant_Specification | - N_Entry_Body | - N_Entry_Declaration | - N_Entry_Index_Specification | - N_Exception_Declaration | - N_Exception_Renaming_Declaration | - N_Formal_Object_Declaration | - N_Formal_Package_Declaration | - N_Formal_Type_Declaration | - N_Full_Type_Declaration | - N_Implicit_Label_Declaration | - N_Incomplete_Type_Declaration | - N_Loop_Parameter_Specification | - N_Number_Declaration | - N_Object_Declaration | - N_Object_Renaming_Declaration | - N_Package_Body_Stub | - N_Parameter_Specification | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Protected_Body | - N_Protected_Body_Stub | - N_Protected_Type_Declaration | - N_Single_Protected_Declaration | - N_Single_Task_Declaration | - N_Subtype_Declaration | - N_Task_Body | - N_Task_Body_Stub | - N_Task_Type_Declaration + when N_Component_Declaration + | N_Defining_Program_Unit_Name + | N_Discriminant_Specification + | N_Entry_Body + | N_Entry_Declaration + | N_Entry_Index_Specification + | N_Exception_Declaration + | N_Exception_Renaming_Declaration + | N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Type_Declaration + | N_Full_Type_Declaration + | N_Implicit_Label_Declaration + | N_Incomplete_Type_Declaration + | N_Loop_Parameter_Specification + | N_Number_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration + | N_Package_Body_Stub + | N_Parameter_Specification + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Protected_Body + | N_Protected_Body_Stub + | N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subtype_Declaration + | N_Task_Body + | N_Task_Body_Stub + | N_Task_Type_Declaration => return Defining_Identifier (N); when N_Subunit => return Defining_Entity (Proper_Body (N)); - when N_Function_Instantiation | - N_Function_Specification | - N_Generic_Function_Renaming_Declaration | - N_Generic_Package_Renaming_Declaration | - N_Generic_Procedure_Renaming_Declaration | - N_Package_Body | - N_Package_Instantiation | - N_Package_Renaming_Declaration | - N_Package_Specification | - N_Procedure_Instantiation | - N_Procedure_Specification + when N_Function_Instantiation + | N_Function_Specification + | N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + | N_Package_Body + | N_Package_Instantiation + | N_Package_Renaming_Declaration + | N_Package_Specification + | N_Procedure_Instantiation + | N_Procedure_Specification => declare Nam : constant Node_Id := Defining_Unit_Name (N); @@ -5272,8 +5279,9 @@ package body Sem_Util is end if; end; - when N_Block_Statement | - N_Loop_Statement => + when N_Block_Statement + | N_Loop_Statement + => return Entity (Identifier (N)); when others => @@ -5282,7 +5290,6 @@ package body Sem_Util is else raise Program_Error; end if; - end case; end Defining_Entity; @@ -5818,8 +5825,9 @@ package body Sem_Util is -- Treat the unchecked attributes as library-level - when Attribute_Unchecked_Access | - Attribute_Unrestricted_Access => + when Attribute_Unchecked_Access + | Attribute_Unrestricted_Access + => return Make_Level_Literal (Scope_Depth (Standard_Standard)); -- No other access-valued attributes @@ -7290,11 +7298,10 @@ package body Sem_Util is pragma Assert (Present (Alt)); end loop Search; - -- The above loop *must* terminate by finding a match, since - -- we know the case statement is valid, and the value of the - -- expression is known at compile time. When we fall out of - -- the loop, Alt points to the alternative that we know will - -- be selected at run time. + -- The above loop *must* terminate by finding a match, since we know the + -- case statement is valid, and the value of the expression is known at + -- compile time. When we fall out of the loop, Alt points to the + -- alternative that we know will be selected at run time. return Alt; end Find_Static_Alternative; @@ -7847,10 +7854,10 @@ package body Sem_Util is return Entity (N); else case Nkind (N) is - when N_Indexed_Component | - N_Slice | - N_Selected_Component => - + when N_Indexed_Component + | N_Selected_Component + | N_Slice + => -- If not generating code, a dereference may be left implicit. -- In thoses cases, return Empty. @@ -8933,10 +8940,10 @@ package body Sem_Util is Assn := First (Constraints (Constr)); while Present (Assn) loop case Nkind (Assn) is - when N_Subtype_Indication | - N_Range | - N_Identifier - => + when N_Identifier + | N_Range + | N_Subtype_Indication + => if Depends_On_Discriminant (Assn) then return True; end if; @@ -9518,19 +9525,21 @@ package body Sem_Util is function Has_Null_Exclusion (N : Node_Id) return Boolean is begin case Nkind (N) is - when N_Access_Definition | - N_Access_Function_Definition | - N_Access_Procedure_Definition | - N_Access_To_Object_Definition | - N_Allocator | - N_Derived_Type_Definition | - N_Function_Specification | - N_Subtype_Declaration => + when N_Access_Definition + | N_Access_Function_Definition + | N_Access_Procedure_Definition + | N_Access_To_Object_Definition + | N_Allocator + | N_Derived_Type_Definition + | N_Function_Specification + | N_Subtype_Declaration + => return Null_Exclusion_Present (N); - when N_Component_Definition | - N_Formal_Object_Declaration | - N_Object_Renaming_Declaration => + when N_Component_Definition + | N_Formal_Object_Declaration + | N_Object_Renaming_Declaration + => if Present (Subtype_Mark (N)) then return Null_Exclusion_Present (N); else pragma Assert (Present (Access_Definition (N))); @@ -9560,7 +9569,6 @@ package body Sem_Util is when others => return False; - end case; end Has_Null_Exclusion; @@ -12087,22 +12095,23 @@ package body Sem_Util is function Is_Declaration_Other_Than_Renaming (N : Node_Id) return Boolean is begin case Nkind (N) is - when N_Abstract_Subprogram_Declaration | - N_Exception_Declaration | - N_Expression_Function | - N_Full_Type_Declaration | - N_Generic_Package_Declaration | - N_Generic_Subprogram_Declaration | - N_Number_Declaration | - N_Object_Declaration | - N_Package_Declaration | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Subprogram_Declaration | - N_Subtype_Declaration => + when N_Abstract_Subprogram_Declaration + | N_Exception_Declaration + | N_Expression_Function + | N_Full_Type_Declaration + | N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Number_Declaration + | N_Object_Declaration + | N_Package_Declaration + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Subprogram_Declaration + | N_Subtype_Declaration + => return True; - when others => + when others => return False; end case; end Is_Declaration_Other_Than_Renaming; @@ -13283,7 +13292,9 @@ package body Sem_Util is else case Nkind (N) is - when N_Indexed_Component | N_Slice => + when N_Indexed_Component + | N_Slice + => return Is_Object_Reference (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N))); @@ -14219,16 +14230,17 @@ package body Sem_Util is function Is_Renaming_Declaration (N : Node_Id) return Boolean is begin case Nkind (N) is - when N_Exception_Renaming_Declaration | - N_Generic_Function_Renaming_Declaration | - N_Generic_Package_Renaming_Declaration | - N_Generic_Procedure_Renaming_Declaration | - N_Object_Renaming_Declaration | - N_Package_Renaming_Declaration | - N_Subprogram_Renaming_Declaration => + when N_Exception_Renaming_Declaration + | N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + | N_Object_Renaming_Declaration + | N_Package_Renaming_Declaration + | N_Subprogram_Renaming_Declaration + => return True; - when others => + when others => return False; end case; end Is_Renaming_Declaration; @@ -14397,23 +14409,27 @@ package body Sem_Util is pragma Assert (Nkind (Orig_N) in N_Subexpr); case Nkind (Orig_N) is - when N_Character_Literal | - N_Integer_Literal | - N_Real_Literal | - N_String_Literal => + when N_Character_Literal + | N_Integer_Literal + | N_Real_Literal + | N_String_Literal + => null; - when N_Identifier | - N_Expanded_Name => + when N_Expanded_Name + | N_Identifier + => if Is_Entity_Name (Orig_N) and then Present (Entity (Orig_N)) -- needed in some cases then case Ekind (Entity (Orig_N)) is - when E_Constant | - E_Enumeration_Literal | - E_Named_Integer | - E_Named_Real => + when E_Constant + | E_Enumeration_Literal + | E_Named_Integer + | E_Named_Real + => null; + when others => if Is_Type (Entity (Orig_N)) then null; @@ -14423,22 +14439,25 @@ package body Sem_Util is end case; end if; - when N_Qualified_Expression | - N_Type_Conversion => + when N_Qualified_Expression + | N_Type_Conversion + => Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); when N_Unary_Op => Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); - when N_Binary_Op | - N_Short_Circuit | - N_Membership_Test => + when N_Binary_Op + | N_Membership_Test + | N_Short_Circuit + => Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N)) and then Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); - when N_Aggregate | - N_Extension_Aggregate => + when N_Aggregate + | N_Extension_Aggregate + => if Nkind (Orig_N) = N_Extension_Aggregate then Is_Ok := Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); @@ -15037,7 +15056,9 @@ package body Sem_Util is else case Nkind (Orig_Node) is - when N_Indexed_Component | N_Slice => + when N_Indexed_Component + | N_Slice + => return Is_Variable_Prefix (Prefix (Orig_Node)); when N_Selected_Component => @@ -15397,9 +15418,9 @@ package body Sem_Util is -- Positional parameter for procedure or accept call - when N_Procedure_Call_Statement | - N_Accept_Statement - => + when N_Accept_Statement + | N_Procedure_Call_Statement + => declare Proc : Entity_Id; Form : Entity_Id; @@ -15487,7 +15508,6 @@ package body Sem_Util is when others => return False; - end case; end Known_To_Be_Assigned; @@ -15681,7 +15701,9 @@ package body Sem_Util is -- or slice is an lvalue, except if it is an access type, where we -- have an implicit dereference. - when N_Indexed_Component | N_Slice => + when N_Indexed_Component + | N_Slice + => if N /= Prefix (P) or else (Present (Etype (N)) and then Is_Access_Type (Etype (N))) then @@ -15704,9 +15726,9 @@ package body Sem_Util is -- In older versions of Ada function call arguments are never -- lvalues. In Ada 2012 functions can have in-out parameters. - when N_Subprogram_Call | - N_Entry_Call_Statement | - N_Accept_Statement + when N_Accept_Statement + | N_Entry_Call_Statement + | N_Subprogram_Call => if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then return False; @@ -15807,7 +15829,6 @@ package body Sem_Util is when others => return False; - end case; end May_Be_Lvalue; @@ -17746,7 +17767,6 @@ package body Sem_Util is else Return_Master_Scope_Depth_Of_Call : declare - function Innermost_Master_Scope_Depth (N : Node_Id) return Uint; -- Returns the scope depth of the given node's innermost @@ -17769,42 +17789,42 @@ package body Sem_Util is while Present (Node_Par) loop case Nkind (Node_Par) is - when N_Component_Declaration | - N_Entry_Declaration | - N_Formal_Object_Declaration | - N_Formal_Type_Declaration | - N_Full_Type_Declaration | - N_Incomplete_Type_Declaration | - N_Loop_Parameter_Specification | - N_Object_Declaration | - N_Protected_Type_Declaration | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Subtype_Declaration | - N_Function_Specification | - N_Procedure_Specification | - N_Task_Type_Declaration | - N_Body_Stub | - N_Generic_Instantiation | - N_Proper_Body | - N_Implicit_Label_Declaration | - N_Package_Declaration | - N_Single_Task_Declaration | - N_Subprogram_Declaration | - N_Generic_Declaration | - N_Renaming_Declaration | - N_Block_Statement | - N_Formal_Subprogram_Declaration | - N_Abstract_Subprogram_Declaration | - N_Entry_Body | - N_Exception_Declaration | - N_Formal_Package_Declaration | - N_Number_Declaration | - N_Package_Specification | - N_Parameter_Specification | - N_Single_Protected_Declaration | - N_Subunit => - + when N_Abstract_Subprogram_Declaration + | N_Block_Statement + | N_Body_Stub + | N_Component_Declaration + | N_Entry_Body + | N_Entry_Declaration + | N_Exception_Declaration + | N_Formal_Object_Declaration + | N_Formal_Package_Declaration + | N_Formal_Subprogram_Declaration + | N_Formal_Type_Declaration + | N_Full_Type_Declaration + | N_Function_Specification + | N_Generic_Declaration + | N_Generic_Instantiation + | N_Implicit_Label_Declaration + | N_Incomplete_Type_Declaration + | N_Loop_Parameter_Specification + | N_Number_Declaration + | N_Object_Declaration + | N_Package_Declaration + | N_Package_Specification + | N_Parameter_Specification + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Procedure_Specification + | N_Proper_Body + | N_Protected_Type_Declaration + | N_Renaming_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subprogram_Declaration + | N_Subtype_Declaration + | N_Subunit + | N_Task_Type_Declaration + => return Scope_Depth (Nearest_Dynamic_Scope (Defining_Entity (Node_Par))); @@ -20382,7 +20402,8 @@ package body Sem_Util is case Size is when 8 | 16 | 32 | 64 => return Size = UI_To_Int (Alignment (Typ)) * 8; - when others => + + when others => return False; end case; end Support_Atomic_Primitives; |