diff options
Diffstat (limited to 'gcc/ada/sem_res.adb')
| -rw-r--r-- | gcc/ada/sem_res.adb | 1563 |
1 files changed, 826 insertions, 737 deletions
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 21cbe0a..50a4287 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -177,6 +178,7 @@ package body Sem_Res is procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Declare_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); @@ -226,6 +228,12 @@ package body Sem_Res is -- is the context type, which is used when the operation is a protected -- function with no arguments, and the return value is indexed. + procedure Resolve_Implicit_Dereference (P : Node_Id); + -- Called when P is the prefix of an indexed component, or of a selected + -- component, or of a slice. If P is of an access type, we unconditionally + -- rewrite it as an explicit dereference. This ensures that the expander + -- and the code generator have a fully explicit tree to work with. + procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); -- A call to a user-defined intrinsic operator is rewritten as a call to -- the corresponding predefined operator, with suitable conversions. Note @@ -265,8 +273,7 @@ package body Sem_Res is procedure Simplify_Type_Conversion (N : Node_Id); -- Called after N has been resolved and evaluated, but before range checks - -- have been applied. Currently simplifies a combination of floating-point - -- to integer conversion and Rounding or Truncation attribute. + -- have been applied. This rewrites the conversion into a simpler form. function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; -- A universal_fixed expression in an universal context is unambiguous if @@ -448,8 +455,8 @@ package body Sem_Res is and then not (Nkind (Parent (P)) = N_Subtype_Indication and then - Nkind_In (Parent (Parent (P)), N_Component_Definition, - N_Subtype_Declaration) + Nkind (Parent (Parent (P))) in N_Component_Definition + | N_Subtype_Declaration and then Paren_Count (N) = 0) then Error_Msg_N @@ -573,8 +580,8 @@ package body Sem_Res is -- Legal case is in index or discriminant constraint - elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, - N_Discriminant_Association) + elsif Nkind (PN) in N_Index_Or_Discriminant_Constraint + | N_Discriminant_Association then if Paren_Count (N) > 0 then Error_Msg_N @@ -595,9 +602,8 @@ package body Sem_Res is else D := PN; P := Parent (PN); - while not Nkind_In (P, N_Component_Declaration, - N_Subtype_Indication, - N_Entry_Declaration) + while Nkind (P) not in + N_Component_Declaration | N_Subtype_Indication | N_Entry_Declaration loop D := P; P := Parent (P); @@ -610,8 +616,8 @@ package body Sem_Res is -- course a double fault. if (Nkind (P) = N_Subtype_Indication - and then Nkind_In (Parent (P), N_Component_Definition, - N_Derived_Type_Definition) + and then Nkind (Parent (P)) in N_Component_Definition + | N_Derived_Type_Definition and then D = Constraint (P)) -- The constraint itself may be given by a subtype indication, @@ -803,12 +809,12 @@ package body Sem_Res is function Is_Conditional_Statement (N : Node_Id) return Boolean is begin return - Nkind_In (N, N_And_Then, - N_Case_Expression, - N_Case_Statement, - N_If_Expression, - N_If_Statement, - N_Or_Else); + Nkind (N) in N_And_Then + | N_Case_Expression + | N_Case_Statement + | N_If_Expression + | N_If_Statement + | N_Or_Else; end Is_Conditional_Statement; ------------------------------- @@ -834,7 +840,7 @@ package body Sem_Res is begin return Nkind (HSS) = N_Handled_Sequence_Of_Statements - and then Nkind_In (Parent (HSS), N_Entry_Body, N_Subprogram_Body) + and then Nkind (Parent (HSS)) in N_Entry_Body | N_Subprogram_Body and then Is_List_Member (N) and then List_Containing (N) = Statements (HSS); end Is_Immediately_Within_Body; @@ -1142,9 +1148,8 @@ package body Sem_Res is -- functions, this is never a parameterless call (RM 4.1.4(6)). if Nkind (Parent (N)) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Parent (N)), Name_Address, - Name_Code_Address, - Name_Access) + and then Attribute_Name (Parent (N)) + in Name_Address | Name_Code_Address | Name_Access then return False; end if; @@ -1194,9 +1199,9 @@ package body Sem_Res is and then Ekind (Entity (N)) = E_Procedure and then not Is_Overloaded (N) and then - Nkind_In (Parent (N), N_Parameter_Association, - N_Function_Call, - N_Procedure_Call_Statement) + Nkind (Parent (N)) in N_Parameter_Association + | N_Function_Call + | N_Procedure_Call_Statement then return; end if; @@ -1231,8 +1236,8 @@ package body Sem_Res is (Nkind (N) = N_Selected_Component and then (Ekind (Entity (Selector_Name (N))) = E_Function or else - (Ekind_In (Entity (Selector_Name (N)), E_Entry, - E_Procedure) + (Ekind (Entity (Selector_Name (N))) in + E_Entry | E_Procedure and then Is_Overloaded (Selector_Name (N))))) -- If one of the above three conditions is met, rewrite as call. Apply @@ -1540,9 +1545,9 @@ package body Sem_Res is elsif In_Instance then null; - elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) - and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) - and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) + elsif Op_Name in Name_Op_Multiply | Name_Op_Divide + and then Is_Fixed_Point_Type (Etype (Act1)) + and then Is_Fixed_Point_Type (Etype (Act2)) then if Pack /= Standard_Standard then Error := True; @@ -1552,8 +1557,9 @@ package body Sem_Res is -- available. elsif Ada_Version >= Ada_2005 - and then Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) - and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type + and then Op_Name in Name_Op_Eq | Name_Op_Ne + and then (Is_Anonymous_Access_Type (Etype (Act1)) + or else Is_Anonymous_Access_Type (Etype (Act2))) then null; @@ -1662,7 +1668,7 @@ package body Sem_Res is and then not In_Instance then if Is_Fixed_Point_Type (Typ) - and then Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) + and then Op_Name in Name_Op_Multiply | Name_Op_Divide then -- Already checked above @@ -1699,7 +1705,7 @@ package body Sem_Res is -- the equality node will not resolve any remaining ambiguity, and it -- assumes that the first operand is not overloaded. - if Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) + if Op_Name in Name_Op_Eq | Name_Op_Ne and then Ekind (Func) = E_Function and then Is_Overloaded (Act1) then @@ -1752,78 +1758,6 @@ package body Sem_Res is else Resolve (N, Typ); end if; - - -- If in ASIS_Mode, propagate operand types to original actuals of - -- function call, which would otherwise not be fully resolved. If - -- the call has already been constant-folded, nothing to do. We - -- relocate the operand nodes rather than copy them, to preserve - -- original_node pointers, given that the operands themselves may - -- have been rewritten. If the call was itself a rewriting of an - -- operator node, nothing to do. - - if ASIS_Mode - and then Nkind (N) in N_Op - and then Nkind (Original_Node (N)) = N_Function_Call - then - declare - L : Node_Id; - R : constant Node_Id := Right_Opnd (N); - - Old_First : constant Node_Id := - First (Parameter_Associations (Original_Node (N))); - Old_Sec : Node_Id; - - begin - if Is_Binary then - L := Left_Opnd (N); - Old_Sec := Next (Old_First); - - -- If the original call has named associations, replace the - -- explicit actual parameter in the association with the proper - -- resolved operand. - - if Nkind (Old_First) = N_Parameter_Association then - if Chars (Selector_Name (Old_First)) = - Chars (First_Entity (Op_Id)) - then - Rewrite (Explicit_Actual_Parameter (Old_First), - Relocate_Node (L)); - else - Rewrite (Explicit_Actual_Parameter (Old_First), - Relocate_Node (R)); - end if; - - else - Rewrite (Old_First, Relocate_Node (L)); - end if; - - if Nkind (Old_Sec) = N_Parameter_Association then - if Chars (Selector_Name (Old_Sec)) = - Chars (First_Entity (Op_Id)) - then - Rewrite (Explicit_Actual_Parameter (Old_Sec), - Relocate_Node (L)); - else - Rewrite (Explicit_Actual_Parameter (Old_Sec), - Relocate_Node (R)); - end if; - - else - Rewrite (Old_Sec, Relocate_Node (R)); - end if; - - else - if Nkind (Old_First) = N_Parameter_Association then - Rewrite (Explicit_Actual_Parameter (Old_First), - Relocate_Node (R)); - else - Rewrite (Old_First, Relocate_Node (R)); - end if; - end if; - end; - - Set_Parent (Original_Node (N), Parent (N)); - end if; end Make_Call_Into_Operator; ------------------- @@ -2209,6 +2143,12 @@ package body Sem_Res is return; end Resolution_Failed; + Literal_Aspect_Map : + constant array (N_Numeric_Or_String_Literal) of Aspect_Id := + (N_Integer_Literal => Aspect_Integer_Literal, + N_Real_Literal => Aspect_Real_Literal, + N_String_Literal => Aspect_String_Literal); + -- Start of processing for Resolve begin @@ -2220,9 +2160,9 @@ package body Sem_Res is -- access-to-subprogram type. if Nkind (N) = N_Attribute_Reference - and then Nam_In (Attribute_Name (N), Name_Access, - Name_Unrestricted_Access, - Name_Unchecked_Access) + and then Attribute_Name (N) in Name_Access + | Name_Unrestricted_Access + | Name_Unchecked_Access and then Comes_From_Source (N) and then Is_Entity_Name (Prefix (N)) and then Is_Subprogram (Entity (Prefix (N))) @@ -2344,10 +2284,18 @@ package body Sem_Res is Check_Parameterless_Call (N); -- The resolution of an Expression_With_Actions is determined by - -- its Expression. + -- its Expression, but if the node comes from source it is a + -- Declare_Expression and requires scope management. if Nkind (N) = N_Expression_With_Actions then - Resolve (Expression (N), Typ); + if Comes_From_Source (N) + and then N = Original_Node (N) + then + Resolve_Declare_Expression (N, Typ); + + else + Resolve (Expression (N), Typ); + end if; Found := True; Expr_Type := Etype (Expression (N)); @@ -2632,10 +2580,10 @@ package body Sem_Res is Set_Entity (N, Seen); Generate_Reference (Seen, N); - elsif Nkind_In (N, N_Case_Expression, - N_Character_Literal, - N_Delta_Aggregate, - N_If_Expression) + elsif Nkind (N) in N_Case_Expression + | N_Character_Literal + | N_Delta_Aggregate + | N_If_Expression then Set_Etype (N, Expr_Type); @@ -2701,15 +2649,15 @@ package body Sem_Res is -- with a name that is an explicit dereference, there is -- nothing to be done at this point. - elsif Nkind_In (N, N_Attribute_Reference, - N_And_Then, - N_Explicit_Dereference, - N_Identifier, - N_Indexed_Component, - N_Or_Else, - N_Range, - N_Selected_Component, - N_Slice) + elsif Nkind (N) in N_Attribute_Reference + | N_And_Then + | N_Explicit_Dereference + | N_Identifier + | N_Indexed_Component + | N_Or_Else + | N_Range + | N_Selected_Component + | N_Slice or else Nkind (Name (N)) = N_Explicit_Dereference then null; @@ -2826,6 +2774,17 @@ package body Sem_Res is elsif Nkind (N) = N_Aggregate and then Etype (N) = Any_Composite then + if Ada_Version >= Ada_2020 + and then Has_Aspect (Typ, Aspect_Aggregate) + then + Resolve_Container_Aggregate (N, Typ); + + if Expander_Active then + Expand (N); + end if; + return; + end if; + -- Disable expansion in any case. If there is a type mismatch -- it may be fatal to try to expand the aggregate. The flag -- would otherwise be set to false when the error is posted. @@ -2912,6 +2871,80 @@ package body Sem_Res is end; end if; + -- Rewrite Literal as a call if the corresponding literal aspect + -- is set. + + if Nkind (N) in N_Numeric_Or_String_Literal + and then Present + (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))) + then + declare + function Literal_Text (N : Node_Id) return String_Id; + -- Returns the text of a literal node + + ------------------- + -- Literal_Text -- + ------------------- + + function Literal_Text (N : Node_Id) return String_Id is + begin + pragma Assert (Nkind (N) in N_Numeric_Or_String_Literal); + + if Nkind (N) = N_String_Literal then + return Strval (N); + else + return String_From_Numeric_Literal (N); + end if; + end Literal_Text; + + Lit_Aspect : constant Aspect_Id := + Literal_Aspect_Map (Nkind (N)); + + Callee : constant Entity_Id := + Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); + + Loc : constant Source_Ptr := Sloc (N); + + Name : constant Node_Id := + Make_Identifier (Loc, Chars (Callee)); + + Param : constant Node_Id := + Make_String_Literal (Loc, Literal_Text (N)); + + Params : constant List_Id := New_List (Param); + + Call : Node_Id := + Make_Function_Call + (Sloc => Loc, + Name => Name, + Parameter_Associations => Params); + begin + Set_Entity (Name, Callee); + Set_Is_Overloaded (Name, False); + if Lit_Aspect = Aspect_String_Literal then + Set_Etype (Param, Standard_Wide_Wide_String); + else + Set_Etype (Param, Standard_String); + end if; + Set_Etype (Call, Etype (Callee)); + + -- Conversion needed in case of an inherited aspect + -- of a derived type. + -- + -- ??? Need to do something different here for downward + -- tagged conversion case (which is only possible in the + -- case of a null extension); the current call to + -- Convert_To results in an error message about an illegal + -- downward conversion. + + Call := Convert_To (Typ, Call); + + Rewrite (N, Call); + end; + Analyze_And_Resolve (N, Typ); + return; + end if; + -- Looks like we have a type error, but check for special case -- of Address wanted, integer found, with the configuration pragma -- Allow_Integer_Address active. If we have this case, introduce @@ -2925,7 +2958,7 @@ package body Sem_Res is return; -- Under relaxed RM semantics silently replace occurrences of null - -- by System.Address_Null. + -- by System.Null_Address. elsif Null_To_Null_Address_Convert_OK (N, Typ) then Replace_Null_By_Null_Address (N); @@ -3000,7 +3033,7 @@ package body Sem_Res is Resolution_Failed; return; - -- Only one intepretation + -- Only one interpretation else -- In Ada 2005, if we have something like "X : T := 2 + 2;", where @@ -3395,7 +3428,7 @@ package body Sem_Res is procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id); -- Emit an error concerning the illegal usage of an effectively volatile - -- object in interfering context (SPARK RM 7.13(12)). + -- object in interfering context (SPARK RM 7.1.3(10)). procedure Insert_Default; -- If the actual is missing in a call, insert in the actuals list @@ -3680,7 +3713,7 @@ package body Sem_Res is then Error_Msg_N ("volatile object cannot appear in this context (SPARK " - & "RM 7.1.3(11))", N); + & "RM 7.1.3(10))", N); return Skip; end if; end if; @@ -4077,69 +4110,107 @@ package body Sem_Res is and then not Is_Class_Wide_Type (Etype (Expression (A))) and then not Is_Interface (Etype (A)) then - if Ekind (F) = E_In_Out_Parameter - and then Is_Array_Type (Etype (F)) - then - -- In a view conversion, the conversion must be legal in - -- both directions, and thus both component types must be - -- aliased, or neither (4.6 (8)). + declare + Expr_Typ : constant Entity_Id := Etype (Expression (A)); - -- The extra rule in 4.6 (24.9.2) seems unduly restrictive: - -- the privacy requirement should not apply to generic - -- types, and should be checked in an instance. ARG query - -- is in order ??? + begin + -- Check RM 4.6 (24.2/2) - if Has_Aliased_Components (Etype (Expression (A))) /= - Has_Aliased_Components (Etype (F)) + if Is_Array_Type (Etype (F)) + and then Is_View_Conversion (A) then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); + -- In a view conversion, the conversion must be legal in + -- both directions, and thus both component types must be + -- aliased, or neither (4.6 (8)). - -- Comment here??? what set of cases??? + -- Check RM 4.6 (24.8/2) - elsif - not Same_Ancestor (Etype (F), Etype (Expression (A))) - then - -- Check view conv between unrelated by ref array types + if Has_Aliased_Components (Expr_Typ) /= + Has_Aliased_Components (Etype (F)) + then + -- This normally illegal conversion is legal in an + -- expanded instance body because of RM 12.3(11). + -- At runtime, conversion must create a new object. + + if not In_Instance then + Error_Msg_N + ("both component types in a view conversion must" + & " be aliased, or neither", A); + end if; - if Is_By_Reference_Type (Etype (F)) - or else Is_By_Reference_Type (Etype (Expression (A))) + -- Check RM 4.6 (24/3) + + elsif not Same_Ancestor (Etype (F), Expr_Typ) then + -- Check view conv between unrelated by ref array + -- types. + + if Is_By_Reference_Type (Etype (F)) + or else Is_By_Reference_Type (Expr_Typ) + then + Error_Msg_N + ("view conversion between unrelated by reference " + & "array types not allowed (\'A'I-00246)", A); + + -- In Ada 2005 mode, check view conversion component + -- type cannot be private, tagged, or volatile. Note + -- that we only apply this to source conversions. The + -- generated code can contain conversions which are + -- not subject to this test, and we cannot extract the + -- component type in such cases since it is not + -- present. + + elsif Comes_From_Source (A) + and then Ada_Version >= Ada_2005 + then + declare + Comp_Type : constant Entity_Id := + Component_Type (Expr_Typ); + begin + if (Is_Private_Type (Comp_Type) + and then not Is_Generic_Type (Comp_Type)) + or else Is_Tagged_Type (Comp_Type) + or else Is_Volatile (Comp_Type) + then + Error_Msg_N + ("component type of a view conversion " & + "cannot be private, tagged, or volatile" & + " (RM 4.6 (24))", + Expression (A)); + end if; + end; + end if; + end if; + + -- AI12-0074 & AI12-0377 + -- Check 6.4.1: If the mode is out, the actual parameter is + -- a view conversion, and the type of the formal parameter + -- is a scalar type, then either: + -- - the target and operand type both do not have the + -- Default_Value aspect specified; or + -- - the target and operand type both have the + -- Default_Value aspect specified, and there shall exist + -- a type (other than a root numeric type) that is an + -- ancestor of both the target type and the operand + -- type. + + elsif Ekind (F) = E_Out_Parameter + and then Is_Scalar_Type (Etype (F)) + then + if Has_Default_Aspect (Etype (F)) /= + Has_Default_Aspect (Expr_Typ) then Error_Msg_N - ("view conversion between unrelated by reference " - & "array types not allowed (\'A'I-00246)", A); - - -- In Ada 2005 mode, check view conversion component - -- type cannot be private, tagged, or volatile. Note - -- that we only apply this to source conversions. The - -- generated code can contain conversions which are - -- not subject to this test, and we cannot extract the - -- component type in such cases since it is not present. - - elsif Comes_From_Source (A) - and then Ada_Version >= Ada_2005 + ("view conversion requires Default_Value on both " & + "types (RM 6.4.1)", A); + elsif Has_Default_Aspect (Expr_Typ) + and then not Same_Ancestor (Etype (F), Expr_Typ) then - declare - Comp_Type : constant Entity_Id := - Component_Type - (Etype (Expression (A))); - begin - if (Is_Private_Type (Comp_Type) - and then not Is_Generic_Type (Comp_Type)) - or else Is_Tagged_Type (Comp_Type) - or else Is_Volatile (Comp_Type) - then - Error_Msg_N - ("component type of a view conversion cannot" - & " be private, tagged, or volatile" - & " (RM 4.6 (24))", - Expression (A)); - end if; - end; + Error_Msg_N + ("view conversion between unrelated types with " + & "Default_Value not allowed (RM 6.4.1)", A); end if; end if; - end if; + end; -- Resolve expression if conversion is all OK @@ -4349,71 +4420,6 @@ package body Sem_Res is ("invalid use of untagged formal incomplete type", A); end if; - if Comes_From_Source (Original_Node (N)) - and then Nkind_In (Original_Node (N), N_Function_Call, - N_Procedure_Call_Statement) - then - -- In formal mode, check that actual parameters matching - -- formals of tagged types are objects (or ancestor type - -- conversions of objects), not general expressions. - - if Is_Actual_Tagged_Parameter (A) then - if Is_SPARK_05_Object_Reference (A) then - null; - - elsif Nkind (A) = N_Type_Conversion then - declare - Operand : constant Node_Id := Expression (A); - Operand_Typ : constant Entity_Id := Etype (Operand); - Target_Typ : constant Entity_Id := A_Typ; - - begin - if not Is_SPARK_05_Object_Reference (Operand) then - Check_SPARK_05_Restriction - ("object required", Operand); - - -- In formal mode, the only view conversions are those - -- involving ancestor conversion of an extended type. - - elsif not - (Is_Tagged_Type (Target_Typ) - and then not Is_Class_Wide_Type (Target_Typ) - and then Is_Tagged_Type (Operand_Typ) - and then not Is_Class_Wide_Type (Operand_Typ) - and then Is_Ancestor (Target_Typ, Operand_Typ)) - then - if Ekind_In - (F, E_Out_Parameter, E_In_Out_Parameter) - then - Check_SPARK_05_Restriction - ("ancestor conversion is the only permitted " - & "view conversion", A); - else - Check_SPARK_05_Restriction - ("ancestor conversion required", A); - end if; - - else - null; - end if; - end; - - else - Check_SPARK_05_Restriction ("object required", A); - end if; - - -- In formal mode, the only view conversions are those - -- involving ancestor conversion of an extended type. - - elsif Nkind (A) = N_Type_Conversion - and then Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) - then - Check_SPARK_05_Restriction - ("ancestor conversion is the only permitted view " - & "conversion", A); - end if; - end if; - -- has warnings suppressed, then we reset Never_Set_In_Source for -- the calling entity. The reason for this is to catch cases like -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram @@ -4551,7 +4557,7 @@ package body Sem_Res is -- Apply appropriate constraint/predicate checks for IN [OUT] case - if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then + if Ekind (F) in E_In_Parameter | E_In_Out_Parameter then -- Apply predicate tests except in certain special cases. Note -- that it might be more consistent to apply these only when @@ -4633,7 +4639,7 @@ package body Sem_Res is -- Checks for OUT parameters and IN OUT parameters - if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then + if Ekind (F) in E_Out_Parameter | E_In_Out_Parameter then -- If there is a type conversion, make sure the return value -- meets the constraints of the variable before the conversion. @@ -4646,6 +4652,7 @@ package body Sem_Res is -- This is for Starlet only though, so long obsolete. if Mechanism (F) = By_Reference + and then Ekind (Nam) = E_Procedure and then Is_Valued_Procedure (Nam) then null; @@ -4871,7 +4878,7 @@ package body Sem_Res is -- An effectively volatile object may act as an actual when the -- corresponding formal is of a non-scalar effectively volatile - -- type (SPARK RM 7.1.3(11)). + -- type (SPARK RM 7.1.3(10)). if not Is_Scalar_Type (Etype (F)) and then Is_Effectively_Volatile (Etype (F)) @@ -4880,7 +4887,7 @@ package body Sem_Res is -- An effectively volatile object may act as an actual in a -- call to an instance of Unchecked_Conversion. - -- (SPARK RM 7.1.3(11)). + -- (SPARK RM 7.1.3(10)). elsif Is_Unchecked_Conversion_Instance (Nam) then null; @@ -4890,7 +4897,7 @@ package body Sem_Res is elsif Is_Effectively_Volatile_Object (A) then Error_Msg_N ("volatile object cannot act as actual in a call (SPARK " - & "RM 7.1.3(11))", A); + & "RM 7.1.3(10))", A); -- Otherwise the actual denotes an expression. Inspect the -- expression and flag each effectively volatile object with @@ -4951,7 +4958,7 @@ package body Sem_Res is if Comes_From_Source (Nam) and then Is_Ghost_Entity (Nam) - and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter) + and then Ekind (F) in E_In_Out_Parameter | E_Out_Parameter and then Is_Entity_Name (A) and then Present (Entity (A)) and then not Is_Ghost_Entity (Entity (A)) @@ -5092,7 +5099,7 @@ package body Sem_Res is Expr := Next (First (Expressions (Disc_Exp))); if Present (Expr) then Check_Allocator_Discrim_Accessibility_Exprs (Expr, Alloc_Typ); - Expr := Next (Expr); + Next (Expr); if Present (Expr) then Check_Allocator_Discrim_Accessibility_Exprs (Expr, Alloc_Typ); @@ -5158,8 +5165,9 @@ package body Sem_Res is ("class-wide allocator not allowed for this access type", N); end if; - Resolve (Expression (E), Etype (E)); - Check_Non_Static_Context (Expression (E)); + -- Do a full resolution to apply constraint and predicate checks + + Resolve_Qualified_Expression (E, Etype (E)); Check_Unset_Reference (Expression (E)); -- Allocators generated by the build-in-place expansion mechanism @@ -5193,16 +5201,6 @@ package body Sem_Res is end if; end if; - -- A qualified expression requires an exact match of the type. Class- - -- wide matching is not allowed. - - if (Is_Class_Wide_Type (Etype (Expression (E))) - or else Is_Class_Wide_Type (Etype (E))) - and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) - then - Wrong_Type (Expression (E), Etype (E)); - end if; - -- Calls to build-in-place functions are not currently supported in -- allocators for access types associated with a simple storage pool. -- Supporting such allocators may require passing additional implicit @@ -5247,7 +5245,7 @@ package body Sem_Res is Aggr := Original_Node (Expression (E)); if Has_Discriminants (Subtyp) - and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) + and then Nkind (Aggr) in N_Aggregate | N_Extension_Aggregate then Discrim := First_Discriminant (Base_Type (Subtyp)); @@ -5604,18 +5602,18 @@ package body Sem_Res is -- N is the expression after "delta" in a fixed_point_definition; -- see RM-3.5.9(6): - return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, - N_Decimal_Fixed_Point_Definition, + return Nkind (Parent (N)) in N_Ordinary_Fixed_Point_Definition + | N_Decimal_Fixed_Point_Definition -- N is one of the bounds in a real_range_specification; -- see RM-3.5.7(5): - N_Real_Range_Specification, + | N_Real_Range_Specification -- N is the expression of a delta_constraint; -- see RM-J.3(3): - N_Delta_Constraint); + | N_Delta_Constraint; end Expected_Type_Is_Any_Real; ----------------------------- @@ -5697,7 +5695,7 @@ package body Sem_Res is -- a conversion will be applied to each operand, so resolve it -- with its own type. - if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then + if Nkind (Parent (N)) in N_Op_Divide | N_Op_Multiply then Resolve (N); else @@ -5785,7 +5783,7 @@ package body Sem_Res is -- involving a fixed-point operand) the conditional expression must -- resolve to a unique visible fixed_point type, normally Duration. - elsif Nkind_In (N, N_Case_Expression, N_If_Expression) + elsif Nkind (N) in N_Case_Expression | N_If_Expression and then Etype (N) = Universal_Real and then Is_Fixed_Point_Type (B_Typ) then @@ -5850,7 +5848,7 @@ package body Sem_Res is and then (Is_Integer_Or_Universal (L) or else Is_Integer_Or_Universal (R)))) - and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) + and then Nkind (N) in N_Op_Multiply | N_Op_Divide then if TL = Universal_Integer or else TR = Universal_Integer then Check_For_Visible_Operator (N, B_Typ); @@ -5896,8 +5894,8 @@ package body Sem_Res is then if B_Typ = Universal_Fixed and then not Expected_Type_Is_Any_Real (N) - and then not Nkind_In (Parent (N), N_Type_Conversion, - N_Unchecked_Type_Conversion) + and then Nkind (Parent (N)) not in + N_Type_Conversion | N_Unchecked_Type_Conversion then Error_Msg_N ("type cannot be determined from context!", N); Error_Msg_N ("\explicit conversion to result type required", N); @@ -5908,9 +5906,8 @@ package body Sem_Res is else if Ada_Version = Ada_83 and then Etype (N) = Universal_Fixed - and then not - Nkind_In (Parent (N), N_Type_Conversion, - N_Unchecked_Type_Conversion) + and then Nkind (Parent (N)) not in + N_Type_Conversion | N_Unchecked_Type_Conversion then Error_Msg_N ("(Ada 83) fixed-point operation needs explicit " @@ -5989,20 +5986,6 @@ package body Sem_Res is Analyze_Dimension (N); Eval_Arithmetic_Op (N); - -- In SPARK, a multiplication or division with operands of fixed point - -- types must be qualified or explicitly converted to identify the - -- result type. - - if (Is_Fixed_Point_Type (Etype (L)) - or else Is_Fixed_Point_Type (Etype (R))) - and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) - and then - not Nkind_In (Parent (N), N_Qualified_Expression, N_Type_Conversion) - then - Check_SPARK_05_Restriction - ("operation should be qualified or explicitly converted", N); - end if; - -- Set overflow and division checking bit if Nkind (N) in N_Op then @@ -6012,7 +5995,7 @@ package body Sem_Res is -- Give warning if explicit division by zero - if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) + if Nkind (N) in N_Op_Divide | N_Op_Rem | N_Op_Mod and then not Division_Checks_Suppressed (Etype (N)) then Rop := Right_Opnd (N); @@ -6093,7 +6076,7 @@ package body Sem_Res is -- if both operands can be negative. if Restriction_Check_Required (No_Implicit_Conditionals) - and then Nkind_In (N, N_Op_Rem, N_Op_Mod) + and then Nkind (N) in N_Op_Rem | N_Op_Mod then declare Lo : Uint; @@ -6243,9 +6226,8 @@ package body Sem_Res is -- operations use the same circuitry because the name in the call -- can be an arbitrary expression with special resolution rules. - elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) - or else (Is_Entity_Name (Subp) - and then Ekind_In (Entity (Subp), E_Entry, E_Entry_Family)) + elsif Nkind (Subp) in N_Selected_Component | N_Indexed_Component + or else (Is_Entity_Name (Subp) and then Is_Entry (Entity (Subp))) then Resolve_Entry_Call (N, Typ); @@ -6293,26 +6275,6 @@ package body Sem_Res is end loop; end if; - if Is_Access_Subprogram_Type (Base_Type (Etype (Nam))) - and then not Is_Access_Subprogram_Type (Base_Type (Typ)) - and then Nkind (Subp) /= N_Explicit_Dereference - and then Present (Parameter_Associations (N)) - then - -- The prefix is a parameterless function call that returns an access - -- to subprogram. If parameters are present in the current call, add - -- add an explicit dereference. We use the base type here because - -- within an instance these may be subtypes. - - -- The dereference is added either in Analyze_Call or here. Should - -- be consolidated ??? - - Set_Is_Overloaded (Subp, False); - Set_Etype (Subp, Etype (Nam)); - Insert_Explicit_Dereference (Subp); - Nam := Designated_Type (Etype (Nam)); - Resolve (Subp, Nam); - end if; - -- Check that a call to Current_Task does not occur in an entry body if Is_RTE (Nam, RE_Current_Task) then @@ -6381,30 +6343,6 @@ package body Sem_Res is end if; end if; - -- If the SPARK_05 restriction is active, we are not allowed - -- to have a call to a subprogram before we see its completion. - - if not Has_Completion (Nam) - and then Restriction_Check_Required (SPARK_05) - - -- Don't flag strange internal calls - - and then Comes_From_Source (N) - and then Comes_From_Source (Nam) - - -- Only flag calls in extended main source - - and then In_Extended_Main_Source_Unit (Nam) - and then In_Extended_Main_Source_Unit (N) - - -- Exclude enumeration literals from this processing - - and then Ekind (Nam) /= E_Enumeration_Literal - then - Check_SPARK_05_Restriction - ("call to subprogram cannot appear before its body", N); - end if; - -- Check that this is not a call to a protected procedure or entry from -- within a protected function. @@ -6565,7 +6503,6 @@ package body Sem_Res is Set_Etype (Prefix (N), Ret_Type); Set_Etype (N, Typ); - Resolve_Indexed_Component (N, Typ); if Legacy_Elaboration_Checks then Check_Elab_Call (Prefix (N)); @@ -6577,6 +6514,8 @@ package body Sem_Res is -- the ABE Processing phase. Build_Call_Marker (Prefix (N)); + + Resolve_Indexed_Component (N, Typ); end if; end if; @@ -6639,21 +6578,12 @@ package body Sem_Res is if Comes_From_Source (N) then Scop := Current_Scope; - -- Check violation of SPARK_05 restriction which does not permit - -- a subprogram body to contain a call to the subprogram directly. - - if Restriction_Check_Required (SPARK_05) - and then Same_Or_Aliased_Subprograms (Nam, Scop) - then - Check_SPARK_05_Restriction - ("subprogram may not contain direct call to itself", N); - end if; - -- Issue warning for possible infinite recursion in the absence -- of the No_Recursion restriction. if Same_Or_Aliased_Subprograms (Nam, Scop) and then not Restriction_Active (No_Recursion) + and then not Is_Static_Function (Scop) and then Check_Infinite_Recursion (N) then -- Here we detected and flagged an infinite recursion, so we do @@ -6671,6 +6601,19 @@ package body Sem_Res is Scope_Loop : while Scop /= Standard_Standard loop if Same_Or_Aliased_Subprograms (Nam, Scop) then + -- Ada 202x (AI12-0075): Static functions are never allowed + -- to make a recursive call, as specified by 6.8(5.4/5). + + if Is_Static_Function (Scop) then + Error_Msg_N + ("recursive call not allowed in static expression " + & "function", N); + + Set_Error_Posted (Scop); + + exit Scope_Loop; + end if; + -- Although in general case, recursion is not statically -- checkable, the case of calling an immediately containing -- subprogram is easy to catch. @@ -6714,8 +6657,8 @@ package body Sem_Res is begin P := Prev (N); while Present (P) loop - if not Nkind_In (P, N_Assignment_Statement, - N_Raise_Constraint_Error) + if Nkind (P) not in N_Assignment_Statement + | N_Raise_Constraint_Error then exit Scope_Loop; end if; @@ -6808,6 +6751,11 @@ package body Sem_Res is -- is already present. It may not be available if e.g. the subprogram is -- declared in a child instance. + -- g) If the subprogram is a static expression function and the call is + -- a static call (the actuals are all static expressions), then we never + -- want to create a transient scope (this could occur in the case of a + -- static string-returning call). + if Is_Inlined (Nam) and then Has_Pragma_Inline (Nam) and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration @@ -6819,6 +6767,7 @@ package body Sem_Res is or else Is_Build_In_Place_Function (Nam) or else Is_Intrinsic_Subprogram (Nam) or else Is_Inlinable_Expression_Function (Nam) + or else Is_Static_Function_Call (N) then null; @@ -6826,7 +6775,7 @@ package body Sem_Res is -- secondary stack (or any other one). elsif Expander_Active - and then Ekind_In (Nam, E_Function, E_Subprogram_Type) + and then Ekind (Nam) in E_Function | E_Subprogram_Type and then Requires_Transient_Scope (Etype (Nam)) and then not Is_Ignored_Ghost_Entity (Nam) then @@ -6925,7 +6874,7 @@ package body Sem_Res is F := First_Formal (Nam); A := First_Actual (N); while Present (F) and then Present (A) loop - if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) + if Ekind (F) in E_Out_Parameter | E_In_Out_Parameter and then Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) @@ -7006,17 +6955,6 @@ package body Sem_Res is Check_For_Eliminated_Subprogram (Subp, Nam); - -- In formal mode, the primitive operations of a tagged type or type - -- extension do not include functions that return the tagged type. - - if Nkind (N) = N_Function_Call - and then Is_Tagged_Type (Etype (N)) - and then Is_Entity_Name (Name (N)) - and then Is_Inherited_Operation_For_Type (Entity (Name (N)), Etype (N)) - then - Check_SPARK_05_Restriction ("function not inherited", N); - end if; - -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is -- class-wide and the call dispatches on result in a context that does -- not provide a tag, the call raises Program_Error. @@ -7094,12 +7032,26 @@ package body Sem_Res is Warn_On_Overlapping_Actuals (Nam, N); + -- Ada 202x (AI12-0075): If the call is a static call to a static + -- expression function, then we want to "inline" the call, replacing + -- it with the folded static result. This is not done if the checking + -- for a potentially static expression is enabled or if an error has + -- been posted on the call (which may be due to the check for recursive + -- calls, in which case we don't want to fall into infinite recursion + -- when doing the inlining). + + if not Checking_Potentially_Static_Expression + and then Is_Static_Function_Call (N) + and then not Error_Posted (Ultimate_Alias (Nam)) + then + Inline_Static_Function_Call (N, Ultimate_Alias (Nam)); + -- In GNATprove mode, expansion is disabled, but we want to inline some -- subprograms to facilitate formal verification. Indirect calls through -- a subprogram type or within a generic cannot be inlined. Inlining is -- performed only for calls subject to SPARK_Mode on. - if GNATprove_Mode + elsif GNATprove_Mode and then SPARK_Mode = On and then Is_Overloadable (Nam) and then not Inside_A_Generic @@ -7449,20 +7401,6 @@ package body Sem_Res is Generate_Operator_Reference (N, T); Check_Low_Bound_Tested (N); - -- In SPARK, ordering operators <, <=, >, >= are not defined for Boolean - -- types or array types except String. - - if Is_Boolean_Type (T) then - Check_SPARK_05_Restriction - ("comparison is not defined on Boolean type", N); - - elsif Is_Array_Type (T) - and then Base_Type (T) /= Standard_String - then - Check_SPARK_05_Restriction - ("comparison is not defined on array types other than String", N); - end if; - -- Check comparison on unordered enumeration if Bad_Unordered_Enumeration_Reference (N, Etype (L)) then @@ -7491,6 +7429,49 @@ package body Sem_Res is end if; end Resolve_Comparison_Op; + -------------------------------- + -- Resolve_Declare_Expression -- + -------------------------------- + + procedure Resolve_Declare_Expression + (N : Node_Id; + Typ : Entity_Id) + is + Decl : Node_Id; + begin + -- Install the scope created for local declarations, if + -- any. The syntax allows a Declare_Expression with no + -- declarations, in analogy with block statements. + + Decl := First (Actions (N)); + + while Present (Decl) loop + exit when Nkind (Decl) = N_Object_Declaration; + Next (Decl); + end loop; + + if Present (Decl) then + Push_Scope (Scope (Defining_Identifier (Decl))); + + declare + E : Entity_Id := First_Entity (Current_Scope); + + begin + while Present (E) loop + Set_Current_Entity (E); + Set_Is_Immediately_Visible (E); + Next_Entity (E); + end loop; + end; + + Resolve (Expression (N), Typ); + End_Scope; + + else + Resolve (Expression (N), Typ); + end if; + end Resolve_Declare_Expression; + ----------------------------------------- -- Resolve_Discrete_Subtype_Indication -- ----------------------------------------- @@ -7595,6 +7576,10 @@ package body Sem_Res is -- Determine whether node Context denotes an assignment statement or an -- object declaration whose expression is node Expr. + function Is_Attribute_Expression (Expr : Node_Id) return Boolean; + -- Determine whether Expr is part of an N_Attribute_Reference + -- expression. + ---------------------------------------- -- Is_Assignment_Or_Object_Expression -- ---------------------------------------- @@ -7604,8 +7589,8 @@ package body Sem_Res is Expr : Node_Id) return Boolean is begin - if Nkind_In (Context, N_Assignment_Statement, - N_Object_Declaration) + if Nkind (Context) in + N_Assignment_Statement | N_Object_Declaration and then Expression (Context) = Expr then return True; @@ -7613,15 +7598,15 @@ package body Sem_Res is -- Check whether a construct that yields a name is the expression of -- an assignment statement or an object declaration. - elsif (Nkind_In (Context, N_Attribute_Reference, - N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) + elsif (Nkind (Context) in N_Attribute_Reference + | N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + | N_Slice and then Prefix (Context) = Expr) or else - (Nkind_In (Context, N_Type_Conversion, - N_Unchecked_Type_Conversion) + (Nkind (Context) in N_Type_Conversion + | N_Unchecked_Type_Conversion and then Expression (Context) = Expr) then return @@ -7637,6 +7622,24 @@ package body Sem_Res is end if; end Is_Assignment_Or_Object_Expression; + ----------------------------- + -- Is_Attribute_Expression -- + ----------------------------- + + function Is_Attribute_Expression (Expr : Node_Id) return Boolean is + N : Node_Id := Expr; + begin + while Present (N) loop + if Nkind (N) = N_Attribute_Reference then + return True; + end if; + + N := Parent (N); + end loop; + + return False; + end Is_Attribute_Expression; + -- Local variables E : constant Entity_Id := Entity (N); @@ -7707,8 +7710,8 @@ package body Sem_Res is -- array types (i.e. bounds and length) are legal. elsif Ekind (E) = E_Out_Parameter - and then (Nkind (Parent (N)) /= N_Attribute_Reference - or else Is_Scalar_Type (Etype (E))) + and then (Is_Scalar_Type (Etype (E)) + or else not Is_Attribute_Expression (Parent (N))) and then (Nkind (Parent (N)) in N_Op or else Nkind (Parent (N)) = N_Explicit_Dereference @@ -7768,7 +7771,7 @@ package body Sem_Res is -- An effectively volatile object subject to enabled properties -- Async_Writers or Effective_Reads must appear in non-interfering - -- context (SPARK RM 7.1.3(12)). + -- context (SPARK RM 7.1.3(10)). if Is_Object (E) and then Is_Effectively_Volatile (E) @@ -7778,7 +7781,7 @@ package body Sem_Res is then SPARK_Msg_N ("volatile object cannot appear in this context " - & "(SPARK RM 7.1.3(12))", N); + & "(SPARK RM 7.1.3(10))", N); end if; -- Check for possible elaboration issues with respect to reads of @@ -7854,7 +7857,7 @@ package body Sem_Res is -- to the discriminant of the same name in the target task. If the -- entry name is the target of a requeue statement and the entry is -- in the current protected object, the bound to be used is the - -- discriminal of the object (see Apply_Range_Checks for details of + -- discriminal of the object (see Apply_Range_Check for details of -- the transformation). ----------------------------- @@ -8014,10 +8017,23 @@ package body Sem_Res is if Nkind (Entry_Name) = N_Selected_Component then Resolve (Prefix (Entry_Name)); + Resolve_Implicit_Dereference (Prefix (Entry_Name)); else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); Nam := Entity (Selector_Name (Prefix (Entry_Name))); Resolve (Prefix (Prefix (Entry_Name))); + Resolve_Implicit_Dereference (Prefix (Prefix (Entry_Name))); + + -- We do not resolve the prefix because an Entry_Family has no type, + -- although it has the semantics of an array since it can be indexed. + -- In order to perform the associated range check, we would need to + -- build an array type on the fly and set it on the prefix, but this + -- would be wasteful since only the index type matters. Therefore we + -- attach this index type directly, so that Actual_Index_Expression + -- can pick it up later in order to generate the range check. + + Set_Etype (Prefix (Entry_Name), Actual_Index_Type (Nam)); + Index := First (Expressions (Entry_Name)); Resolve (Index, Entry_Index_Type (Nam)); @@ -8033,7 +8049,7 @@ package body Sem_Res is if Nkind (Index) = N_Parameter_Association then Error_Msg_N ("expect expression for entry index", Index); else - Apply_Range_Check (Index, Actual_Index_Type (Nam)); + Apply_Scalar_Range_Check (Index, Etype (Prefix (Entry_Name))); end if; end if; end Resolve_Entry; @@ -8159,7 +8175,7 @@ package body Sem_Res is end; end if; - if Ekind_In (Nam, E_Entry, E_Entry_Family) + if Is_Entry (Nam) and then Present (Contract_Wrapper (Nam)) and then Current_Scope /= Contract_Wrapper (Nam) then @@ -8230,7 +8246,7 @@ package body Sem_Res is Generate_Reference (Nam, Entry_Name, 's'); - if Ekind_In (Nam, E_Entry, E_Entry_Family) then + if Is_Entry (Nam) then Check_Potentially_Blocking_Operation (N); end if; @@ -8312,6 +8328,13 @@ package body Sem_Res is then Establish_Transient_Scope (N, Manage_Sec_Stack => True); end if; + + -- Now we know that this is not a call to a function that returns an + -- array type; moreover, we know the name of the called entry. Detect + -- overlapping actuals, just like for a subprogram call. + + Warn_On_Overlapping_Actuals (Nam, N); + end Resolve_Entry_Call; ------------------------- @@ -8447,13 +8470,11 @@ package body Sem_Res is S : Entity_Id; begin - if Ekind_In (Etype (R), E_Allocator_Type, - E_Access_Attribute_Type) + if Ekind (Etype (R)) in E_Allocator_Type | E_Access_Attribute_Type then Acc := Designated_Type (Etype (R)); - elsif Ekind_In (Etype (L), E_Allocator_Type, - E_Access_Attribute_Type) + elsif Ekind (Etype (L)) in E_Allocator_Type | E_Access_Attribute_Type then Acc := Designated_Type (Etype (L)); else @@ -8506,7 +8527,7 @@ package body Sem_Res is return; elsif T = Any_Access - or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type) + or else Ekind (T) in E_Allocator_Type | E_Access_Attribute_Type then T := Find_Unique_Access_Type; @@ -8523,10 +8544,8 @@ package body Sem_Res is -- Why no similar processing for case expressions??? elsif Ada_Version >= Ada_2012 - and then Ekind_In (Etype (L), E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) - and then Ekind_In (Etype (R), E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + and then Is_Anonymous_Access_Type (Etype (L)) + and then Is_Anonymous_Access_Type (Etype (R)) then Check_If_Expression (L); Check_If_Expression (R); @@ -8535,27 +8554,6 @@ package body Sem_Res is Resolve (L, T); Resolve (R, T); - -- In SPARK, equality operators = and /= for array types other than - -- String are only defined when, for each index position, the - -- operands have equal static bounds. - - if Is_Array_Type (T) then - - -- Protect call to Matching_Static_Array_Bounds to avoid costly - -- operation if not needed. - - if Restriction_Check_Required (SPARK_05) - and then Base_Type (T) /= Standard_String - and then Base_Type (Etype (L)) = Base_Type (Etype (R)) - and then Etype (L) /= Any_Composite -- or else L in error - and then Etype (R) /= Any_Composite -- or else R in error - and then not Matching_Static_Array_Bounds (Etype (L), Etype (R)) - then - Check_SPARK_05_Restriction - ("array types should have matching static bounds", N); - end if; - end if; - -- If the unique type is a class-wide type then it will be expanded -- into a dispatching call to the predefined primitive. Therefore we -- check here for potential violation of such restriction. @@ -8670,8 +8668,8 @@ package body Sem_Res is if Expander_Active and then - (Ekind_In (T, E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + (Ekind (T) in E_Anonymous_Access_Type + | E_Anonymous_Access_Subprogram_Type or else Is_Private_Type (T)) then if Etype (L) /= T then @@ -8827,18 +8825,102 @@ package body Sem_Res is ------------------------------------- procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is + + function OK_For_Static (Act : Node_Id) return Boolean; + -- True if Act is an action of a declare_expression that is allowed in a + -- static declare_expression. + + function All_OK_For_Static return Boolean; + -- True if all actions of N are allowed in a static declare_expression. + + function Get_Literal (Expr : Node_Id) return Node_Id; + -- Expr is an expression with compile-time-known value. This returns the + -- literal node that reprsents that value. + + function OK_For_Static (Act : Node_Id) return Boolean is + begin + case Nkind (Act) is + when N_Object_Declaration => + if Constant_Present (Act) + and then Is_Static_Expression (Expression (Act)) + then + return True; + end if; + + when N_Object_Renaming_Declaration => + if Statically_Names_Object (Name (Act)) then + return True; + end if; + + when others => + -- No other declarations, nor even pragmas, are allowed in a + -- declare expression, so if we see something else, it must be + -- an internally generated expression_with_actions. + null; + end case; + + return False; + end OK_For_Static; + + function All_OK_For_Static return Boolean is + Act : Node_Id := First (Actions (N)); + begin + while Present (Act) loop + if not OK_For_Static (Act) then + return False; + end if; + + Next (Act); + end loop; + + return True; + end All_OK_For_Static; + + function Get_Literal (Expr : Node_Id) return Node_Id is + pragma Assert (Compile_Time_Known_Value (Expr)); + Result : Node_Id; + begin + case Nkind (Expr) is + when N_Has_Entity => + if Ekind (Entity (Expr)) = E_Enumeration_Literal then + Result := Expr; + else + Result := Constant_Value (Entity (Expr)); + end if; + when N_Numeric_Or_String_Literal => + Result := Expr; + when others => + raise Program_Error; + end case; + + pragma Assert + (Nkind (Result) in N_Numeric_Or_String_Literal + or else Ekind (Entity (Result)) = E_Enumeration_Literal); + return Result; + end Get_Literal; + + Loc : constant Source_Ptr := Sloc (N); + begin Set_Etype (N, Typ); - -- If N has no actions, and its expression has been constant folded, - -- then rewrite N as just its expression. Note, we can't do this in - -- the general case of Is_Empty_List (Actions (N)) as this would cause - -- Expression (N) to be expanded again. + if Is_Empty_List (Actions (N)) then + pragma Assert (All_OK_For_Static); null; + end if; + + -- If the value of the expression is known at compile time, and all + -- of the actions (if any) are suitable, then replace the declare + -- expression with its expression. This allows the declare expression + -- as a whole to be static if appropriate. See AI12-0368. - if Is_Empty_List (Actions (N)) - and then Compile_Time_Known_Value (Expression (N)) - then - Rewrite (N, Expression (N)); + if Compile_Time_Known_Value (Expression (N)) then + if Is_Empty_List (Actions (N)) then + Rewrite (N, Expression (N)); + elsif All_OK_For_Static then + Rewrite + (N, New_Copy_Tree + (Get_Literal (Expression (N)), New_Sloc => Loc)); + end if; end if; end Resolve_Expression_With_Actions; @@ -8848,47 +8930,9 @@ package body Sem_Res is procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id) is Indexing : constant Node_Id := Generalized_Indexing (N); - Call : Node_Id; - Indexes : List_Id; - Pref : Node_Id; - begin - -- In ASIS mode, propagate the information about the indexes back to - -- to the original indexing node. The generalized indexing is either - -- a function call, or a dereference of one. The actuals include the - -- prefix of the original node, which is the container expression. - - if ASIS_Mode then - Resolve (Indexing, Typ); - Set_Etype (N, Etype (Indexing)); - Set_Is_Overloaded (N, False); - - Call := Indexing; - while Nkind_In (Call, N_Explicit_Dereference, N_Selected_Component) - loop - Call := Prefix (Call); - end loop; - - if Nkind (Call) = N_Function_Call then - Indexes := New_Copy_List (Parameter_Associations (Call)); - Pref := Remove_Head (Indexes); - Set_Expressions (N, Indexes); - - -- If expression is to be reanalyzed, reset Generalized_Indexing - -- to recreate call node, as is the case when the expression is - -- part of an expression function. - - if In_Spec_Expression then - Set_Generalized_Indexing (N, Empty); - end if; - - Set_Prefix (N, Pref); - end if; - - else - Rewrite (N, Indexing); - Resolve (N, Typ); - end if; + Rewrite (N, Indexing); + Resolve (N, Typ); end Resolve_Generalized_Indexing; --------------------------- @@ -9013,6 +9057,32 @@ package body Sem_Res is Analyze_Dimension (N); end Resolve_If_Expression; + ---------------------------------- + -- Resolve_Implicit_Dereference -- + ---------------------------------- + + procedure Resolve_Implicit_Dereference (P : Node_Id) is + Desig_Typ : Entity_Id; + + begin + -- In an instance the proper view may not always be correct for + -- private types, see e.g. Sem_Type.Covers for similar handling. + + if Is_Private_Type (Etype (P)) + and then Present (Full_View (Etype (P))) + and then Is_Access_Type (Full_View (Etype (P))) + and then In_Instance + then + Set_Etype (P, Full_View (Etype (P))); + end if; + + if Is_Access_Type (Etype (P)) then + Desig_Typ := Implicitly_Designated_Type (Etype (P)); + Insert_Explicit_Dereference (P); + Analyze_And_Resolve (P, Desig_Typ); + end if; + end Resolve_Implicit_Dereference; + ------------------------------- -- Resolve_Indexed_Component -- ------------------------------- @@ -9085,15 +9155,15 @@ package body Sem_Res is Resolve (Name, Array_Type); Array_Type := Get_Actual_Subtype_If_Available (Name); - -- If prefix is access type, dereference to get real array type. - -- Note: we do not apply an access check because the expander always - -- introduces an explicit dereference, and the check will happen there. + -- If the prefix's type is an access type, get to the real array type. + -- Note: we do not apply an access check because an explicit dereference + -- will be introduced later, and the check will happen there. if Is_Access_Type (Array_Type) then - Array_Type := Designated_Type (Array_Type); + Array_Type := Implicitly_Designated_Type (Array_Type); end if; - -- If name was overloaded, set component type correctly now + -- If name was overloaded, set component type correctly now. -- If a misplaced call to an entry family (which has no index types) -- return. Error will be diagnosed from calling context. @@ -9115,21 +9185,18 @@ package body Sem_Res is Resolve (Expr, Standard_Positive); else - while Present (Index) and Present (Expr) loop + while Present (Index) and then Present (Expr) loop Resolve (Expr, Etype (Index)); Check_Unset_Reference (Expr); - if Is_Scalar_Type (Etype (Expr)) then - Apply_Scalar_Range_Check (Expr, Etype (Index)); - else - Apply_Range_Check (Expr, Get_Actual_Subtype (Index)); - end if; + Apply_Scalar_Range_Check (Expr, Etype (Index)); Next_Index (Index); Next (Expr); end loop; end if; + Resolve_Implicit_Dereference (Prefix (N)); Analyze_Dimension (N); -- Do not generate the warning on suspicious index if we are analyzing @@ -9145,10 +9212,10 @@ package body Sem_Res is Eval_Indexed_Component (N); end if; - -- If the array type is atomic, and the component is not atomic, then - -- this is worth a warning, since we have a situation where the access - -- to the component may cause extra read/writes of the atomic array - -- object, or partial word accesses, which could be unexpected. + -- If the array type is atomic and the component is not, then this is + -- worth a warning before Ada 2020, since we have a situation where the + -- access to the component may cause extra read/writes of the atomic + -- object, or partial word accesses, both of which may be unexpected. if Nkind (N) = N_Indexed_Component and then Is_Atomic_Ref_With_Address (N) @@ -9157,6 +9224,7 @@ package body Sem_Res is and then Has_Atomic_Components (Entity (Prefix (N))))) and then not Is_Atomic (Component_Type (Array_Type)) + and then Ada_Version < Ada_2020 then Error_Msg_N ("??access to non-atomic component of atomic array", Prefix (N)); @@ -9198,7 +9266,7 @@ package body Sem_Res is Res : Node_Id; begin - if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then + if Nkind (Opnd) in N_Integer_Literal | N_Real_Literal then Res := Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (Btyp, Loc), @@ -9391,7 +9459,7 @@ package body Sem_Res is if Short_Circuit_And_Or and then B_Typ = Standard_Boolean - and then Nkind_In (N, N_Op_And, N_Op_Or) + and then Nkind (N) in N_Op_And | N_Op_Or then -- Mark the corresponding putative SCO operator as truly a logical -- (and short-circuit) operator. @@ -9432,34 +9500,6 @@ package body Sem_Res is Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); Eval_Logical_Op (N); - - -- In SPARK, logical operations AND, OR and XOR for arrays are defined - -- only when both operands have same static lower and higher bounds. Of - -- course the types have to match, so only check if operands are - -- compatible and the node itself has no errors. - - if Is_Array_Type (B_Typ) - and then Nkind (N) in N_Binary_Op - then - declare - Left_Typ : constant Node_Id := Etype (Left_Opnd (N)); - Right_Typ : constant Node_Id := Etype (Right_Opnd (N)); - - begin - -- Protect call to Matching_Static_Array_Bounds to avoid costly - -- operation if not needed. - - if Restriction_Check_Required (SPARK_05) - and then Base_Type (Left_Typ) = Base_Type (Right_Typ) - and then Left_Typ /= Any_Composite -- or Left_Opnd in error - and then Right_Typ /= Any_Composite -- or Right_Opnd in error - and then not Matching_Static_Array_Bounds (Left_Typ, Right_Typ) - then - Check_SPARK_05_Restriction - ("array types should have matching static bounds", N); - end if; - end; - end if; end Resolve_Logical_Op; --------------------------- @@ -9478,8 +9518,8 @@ package body Sem_Res is T : Entity_Id; procedure Resolve_Set_Membership; - -- Analysis has determined a unique type for the left operand. Use it to - -- resolve the disjuncts. + -- Analysis has determined a unique type for the left operand. Use it as + -- the basis to resolve the disjuncts. ---------------------------- -- Resolve_Set_Membership -- @@ -9487,18 +9527,17 @@ package body Sem_Res is procedure Resolve_Set_Membership is Alt : Node_Id; - Ltyp : Entity_Id; begin -- If the left operand is overloaded, find type compatible with not -- overloaded alternative of the right operand. + Alt := First (Alternatives (N)); if Is_Overloaded (L) then - Ltyp := Empty; - Alt := First (Alternatives (N)); + T := Empty; while Present (Alt) loop if not Is_Overloaded (Alt) then - Ltyp := Intersect_Types (L, Alt); + T := Intersect_Types (L, Alt); exit; else Next (Alt); @@ -9508,15 +9547,15 @@ package body Sem_Res is -- Unclear how to resolve expression if all alternatives are also -- overloaded. - if No (Ltyp) then + if No (T) then Error_Msg_N ("ambiguous expression", N); end if; else - Ltyp := Etype (L); + T := Intersect_Types (L, Alt); end if; - Resolve (L, Ltyp); + Resolve (L, T); Alt := First (Alternatives (N)); while Present (Alt) loop @@ -9527,7 +9566,7 @@ package body Sem_Res is if not Is_Entity_Name (Alt) or else not Is_Type (Entity (Alt)) then - Resolve (Alt, Ltyp); + Resolve (Alt, T); end if; Next (Alt); @@ -9535,7 +9574,7 @@ package body Sem_Res is -- Check for duplicates for discrete case - if Is_Discrete_Type (Ltyp) then + if Is_Discrete_Type (T) then declare type Ent is record Alt : Node_Id; @@ -9553,9 +9592,9 @@ package body Sem_Res is Alt := First (Alternatives (N)); while Present (Alt) loop if Is_OK_Static_Expression (Alt) - and then (Nkind_In (Alt, N_Integer_Literal, - N_Character_Literal) - or else Nkind (Alt) in N_Has_Entity) + and then Nkind (Alt) in N_Integer_Literal + | N_Character_Literal + | N_Has_Entity then Nalts := Nalts + 1; Alts (Nalts) := (Alt, Expr_Value (Alt)); @@ -9568,7 +9607,7 @@ package body Sem_Res is end loop; end if; - Alt := Next (Alt); + Next (Alt); end loop; end; end if; @@ -9578,11 +9617,11 @@ package body Sem_Res is -- equality for the type. This may be confusing to users, and the -- following warning appears useful for the most common case. - if Is_Scalar_Type (Ltyp) - and then Present (Get_User_Defined_Eq (Ltyp)) + if Is_Scalar_Type (Etype (L)) + and then Present (Get_User_Defined_Eq (Etype (L))) then Error_Msg_NE - ("membership test on& uses predefined equality?", N, Ltyp); + ("membership test on& uses predefined equality?", N, Etype (L)); Error_Msg_N ("\even if user-defined equality exists (RM 4.5.2 (28.1/3)?", N); end if; @@ -9817,11 +9856,6 @@ package body Sem_Res is exit when NN = N; NN := Parent (NN); end loop; - - if Base_Type (Etype (N)) /= Standard_String then - Check_SPARK_05_Restriction - ("result of concatenation should have type String", N); - end if; end Resolve_Op_Concat; --------------------------- @@ -9946,34 +9980,6 @@ package body Sem_Res is Resolve (Arg, Btyp); end if; - -- Concatenation is restricted in SPARK: each operand must be either a - -- string literal, the name of a string constant, a static character or - -- string expression, or another concatenation. Arg cannot be a - -- concatenation here as callers of Resolve_Op_Concat_Arg call it - -- separately on each final operand, past concatenation operations. - - if Is_Character_Type (Etype (Arg)) then - if not Is_OK_Static_Expression (Arg) then - Check_SPARK_05_Restriction - ("character operand for concatenation should be static", Arg); - end if; - - elsif Is_String_Type (Etype (Arg)) then - if not (Nkind_In (Arg, N_Identifier, N_Expanded_Name) - and then Is_Constant_Object (Entity (Arg))) - and then not Is_OK_Static_Expression (Arg) - then - Check_SPARK_05_Restriction - ("string operand for concatenation should be static", Arg); - end if; - - -- Do not issue error on an operand that is neither a character nor a - -- string, as the error is issued in Resolve_Op_Concat. - - else - null; - end if; - Check_Unset_Reference (Arg); end Resolve_Op_Concat_Arg; @@ -10241,7 +10247,7 @@ package body Sem_Res is begin if B_Typ = Standard_Boolean - and then Nkind_In (Opnd, N_Op_Eq, N_Op_Ne) + and then Nkind (Opnd) in N_Op_Eq | N_Op_Ne and then Is_Overloaded (Opnd) then Resolve_Equality_Op (Opnd, B_Typ); @@ -10299,19 +10305,6 @@ package body Sem_Res is begin Resolve (Expr, Target_Typ); - -- Protect call to Matching_Static_Array_Bounds to avoid costly - -- operation if not needed. - - if Restriction_Check_Required (SPARK_05) - and then Is_Array_Type (Target_Typ) - and then Is_Array_Type (Etype (Expr)) - and then Etype (Expr) /= Any_Composite -- or else Expr in error - and then not Matching_Static_Array_Bounds (Target_Typ, Etype (Expr)) - then - Check_SPARK_05_Restriction - ("array types should have matching static bounds", N); - end if; - -- A qualified expression requires an exact match of the type, class- -- wide matching is not allowed. However, if the qualifying type is -- specific and the expression has a class-wide type, it may still be @@ -10330,10 +10323,12 @@ package body Sem_Res is -- If the target type is unconstrained, then we reset the type of the -- result from the type of the expression. For other cases, the actual - -- subtype of the expression is the target type. + -- subtype of the expression is the target type. But we avoid doing it + -- for an allocator since this is not needed and might be problematic. if Is_Composite_Type (Target_Typ) and then not Is_Constrained (Target_Typ) + and then Nkind (Parent (N)) /= N_Allocator then Set_Etype (N, Etype (Expr)); end if; @@ -10347,31 +10342,19 @@ package body Sem_Res is -- check may convert an illegal static expression and result in warning -- rather than giving an error (e.g Integer'(Integer'Last + 1)). - if Nkind (N) = N_Qualified_Expression and then Is_Scalar_Type (Typ) then - Apply_Scalar_Range_Check (Expr, Typ); + if Nkind (N) = N_Qualified_Expression + and then Is_Scalar_Type (Target_Typ) + then + Apply_Scalar_Range_Check (Expr, Target_Typ); end if; - -- Finally, check whether a predicate applies to the target type. This - -- comes from AI12-0100. As for type conversions, check the enclosing - -- context to prevent an infinite expansion. + -- AI12-0100: Once the qualified expression is resolved, check whether + -- operand statisfies a static predicate of the target subtype, if any. + -- In the static expression case, a predicate check failure is an error. if Has_Predicates (Target_Typ) then - if Nkind (Parent (N)) = N_Function_Call - and then Present (Name (Parent (N))) - and then (Is_Predicate_Function (Entity (Name (Parent (N)))) - or else - Is_Predicate_Function_M (Entity (Name (Parent (N))))) - then - null; - - -- In the case of a qualified expression in an allocator, the check - -- is applied when expanding the allocator, so avoid redundant check. - - elsif Nkind (N) = N_Qualified_Expression - and then Nkind (Parent (N)) /= N_Allocator - then - Apply_Predicate_Check (N, Target_Typ); - end if; + Check_Expression_Against_Static_Predicate + (Expr, Target_Typ, Static_Failure_Is_Error => True); end if; end Resolve_Qualified_Expression; @@ -10436,13 +10419,8 @@ package body Sem_Res is begin Set_Etype (N, Typ); - -- The lower bound should be in Typ. The higher bound can be in Typ's - -- base type if the range is null. It may still be invalid if it is - -- higher than the lower bound. This is checked later in the context in - -- which the range appears. - Resolve (L, Typ); - Resolve (H, Base_Type (Typ)); + Resolve (H, Typ); -- Reanalyze the lower bound after both bounds have been analyzed, so -- that the range is known to be static or not by now. This may trigger @@ -10712,7 +10690,7 @@ package body Sem_Res is while Present (Comp1) and then Chars (Comp1) /= Chars (S) loop - Comp1 := Next_Entity (Comp1); + Next_Entity (Comp1); end loop; end if; @@ -10721,7 +10699,7 @@ package body Sem_Res is end if; end if; - Comp := Next_Entity (Comp); + Next_Entity (Comp); end loop; end if; @@ -10777,12 +10755,12 @@ package body Sem_Res is Generate_Reference (Entity (S), S, 'r'); end if; - -- If prefix is an access type, the node will be transformed into an - -- explicit dereference during expansion. The type of the node is the - -- designated type of that of the prefix. + -- If the prefix's type is an access type, get to the real record type. + -- Note: we do not apply an access check because an explicit dereference + -- will be introduced later, and the check will happen there. if Is_Access_Type (Etype (P)) then - T := Designated_Type (Etype (P)); + T := Implicitly_Designated_Type (Etype (P)); Check_Fully_Declared_Prefix (T, P); else @@ -10838,15 +10816,16 @@ package body Sem_Res is -- Note: No Eval processing is required, because the prefix is of a -- record type, or protected type, and neither can possibly be static. - -- If the record type is atomic, and the component is non-atomic, then - -- this is worth a warning, since we have a situation where the access - -- to the component may cause extra read/writes of the atomic array + -- If the record type is atomic and the component is not, then this is + -- worth a warning before Ada 2020, since we have a situation where the + -- access to the component may cause extra read/writes of the atomic -- object, or partial word accesses, both of which may be unexpected. if Nkind (N) = N_Selected_Component and then Is_Atomic_Ref_With_Address (N) and then not Is_Atomic (Entity (S)) and then not Is_Atomic (Etype (Entity (S))) + and then Ada_Version < Ada_2020 then Error_Msg_N ("??access to non-atomic component of atomic record", @@ -10856,6 +10835,7 @@ package body Sem_Res is Prefix (N)); end if; + Resolve_Implicit_Dereference (Prefix (N)); Analyze_Dimension (N); end Resolve_Selected_Component; @@ -10913,7 +10893,7 @@ package body Sem_Res is -- Set Comes_From_Source on L to preserve warnings for unset -- reference. - Set_Comes_From_Source (L, Comes_From_Source (Reloc_L)); + Preserve_Comes_From_Source (L, Reloc_L); end; end if; @@ -11086,9 +11066,12 @@ package body Sem_Res is Resolve (Name, Array_Type); + -- If the prefix's type is an access type, get to the real array type. + -- Note: we do not apply an access check because an explicit dereference + -- will be introduced later, and the check will happen there. + if Is_Access_Type (Array_Type) then - Apply_Access_Check (N); - Array_Type := Designated_Type (Array_Type); + Array_Type := Implicitly_Designated_Type (Array_Type); -- If the prefix is an access to an unconstrained array, we must use -- the actual subtype of the object to perform the index checks. The @@ -11232,6 +11215,7 @@ package body Sem_Res is Warn_On_Suspicious_Index (Name, High_Bound (Drange)); end if; + Resolve_Implicit_Dereference (Prefix (N)); Analyze_Dimension (N); Eval_Slice (N); end Resolve_Slice; @@ -11281,10 +11265,10 @@ package body Sem_Res is elsif Nkind (Parent (N)) = N_Op_Concat and then not Need_Check - and then not Nkind_In (Original_Node (N), N_Character_Literal, - N_Attribute_Reference, - N_Qualified_Expression, - N_Type_Conversion) + and then Nkind (Original_Node (N)) not in N_Character_Literal + | N_Attribute_Reference + | N_Qualified_Expression + | N_Type_Conversion then Subtype_Id := Typ; @@ -11570,14 +11554,14 @@ package body Sem_Res is -- precision. if Is_Fixed_Point_Type (Typ) - and then Nkind_In (Operand, N_Op_Divide, N_Op_Multiply) + and then Nkind (Operand) in N_Op_Divide | N_Op_Multiply and then Etype (Left_Opnd (Operand)) = Any_Fixed and then Etype (Right_Opnd (Operand)) = Any_Fixed then Set_Etype (Operand, Universal_Real); elsif Is_Numeric_Type (Typ) - and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) + and then Nkind (Operand) in N_Op_Multiply | N_Op_Divide and then (Etype (Right_Opnd (Operand)) = Universal_Real or else Etype (Left_Opnd (Operand)) = Universal_Real) @@ -11633,35 +11617,6 @@ package body Sem_Res is Resolve (Operand); - -- In SPARK, a type conversion between array types should be restricted - -- to types which have matching static bounds. - - -- Protect call to Matching_Static_Array_Bounds to avoid costly - -- operation if not needed. - - if Restriction_Check_Required (SPARK_05) - and then Is_Array_Type (Target_Typ) - and then Is_Array_Type (Operand_Typ) - and then Operand_Typ /= Any_Composite -- or else Operand in error - and then not Matching_Static_Array_Bounds (Target_Typ, Operand_Typ) - then - Check_SPARK_05_Restriction - ("array types should have matching static bounds", N); - end if; - - -- In formal mode, the operand of an ancestor type conversion must be an - -- object (not an expression). - - if Is_Tagged_Type (Target_Typ) - and then not Is_Class_Wide_Type (Target_Typ) - and then Is_Tagged_Type (Operand_Typ) - and then not Is_Class_Wide_Type (Operand_Typ) - and then Is_Ancestor (Target_Typ, Operand_Typ) - and then not Is_SPARK_05_Object_Reference (Operand) - then - Check_SPARK_05_Restriction ("object required", Operand); - end if; - Analyze_Dimension (N); -- Note: we do the Eval_Type_Conversion call before applying the @@ -11732,6 +11687,7 @@ package body Sem_Res is -- odd subtype coming from the bounds). if (Is_Entity_Name (Orig_N) + and then Present (Entity (Orig_N)) and then (Etype (Entity (Orig_N)) = Orig_T or else @@ -11767,11 +11723,11 @@ package body Sem_Res is -- newer language version. elsif Nkind (Orig_N) = N_Qualified_Expression - and then Nkind_In (Parent (N), N_Attribute_Reference, - N_Indexed_Component, - N_Selected_Component, - N_Slice, - N_Explicit_Dereference) + and then Nkind (Parent (N)) in N_Attribute_Reference + | N_Indexed_Component + | N_Selected_Component + | N_Slice + | N_Explicit_Dereference then null; @@ -11786,17 +11742,15 @@ package body Sem_Res is -- entity, give the name of the entity in the message. If not, -- just mention the expression. - -- Shoudn't we test Warn_On_Redundant_Constructs here ??? - else if Is_Entity_Name (Orig_N) then Error_Msg_Node_2 := Orig_T; Error_Msg_NE -- CODEFIX - ("??redundant conversion, & is of type &!", + ("?r?redundant conversion, & is of type &!", N, Entity (Orig_N)); else Error_Msg_NE - ("??redundant conversion, expression is of type&!", + ("?r?redundant conversion, expression is of type&!", N, Orig_T); end if; end if; @@ -11903,7 +11857,7 @@ package body Sem_Res is -- Handle subtypes - if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then + if Ekind (Opnd) in E_Protected_Subtype | E_Task_Subtype then Opnd := Etype (Opnd); end if; @@ -11924,11 +11878,13 @@ package body Sem_Res is end; end if; - -- Ada 2012: once the type conversion is resolved, check whether the - -- operand statisfies the static predicate of the target type. + -- Ada 2012: Once the type conversion is resolved, check whether the + -- operand statisfies a static predicate of the target subtype, if any. + -- In the static expression case, a predicate check failure is an error. if Has_Predicates (Target_Typ) then - Check_Expression_Against_Static_Predicate (N, Target_Typ); + Check_Expression_Against_Static_Predicate + (N, Target_Typ, Static_Failure_Is_Error => True); end if; -- If at this stage we have a real to integer conversion, make sure that @@ -11980,12 +11936,6 @@ package body Sem_Res is Hi : Uint; begin - if Is_Modular_Integer_Type (Typ) and then Nkind (N) /= N_Op_Not then - Error_Msg_Name_1 := Chars (Typ); - Check_SPARK_05_Restriction - ("unary operator not defined for modular type%", N); - end if; - -- Deal with intrinsic unary operators if Comes_From_Source (N) @@ -12065,7 +12015,7 @@ package body Sem_Res is -- mod. These are the cases where the grouping can affect results. if Paren_Count (Rorig) = 0 - and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) + and then Nkind (Rorig) in N_Op_Mod | N_Op_Multiply | N_Op_Divide then -- For mod, we always give the warning, since the value is -- affected by the parenthesization (e.g. (-5) mod 315 /= @@ -12147,7 +12097,7 @@ package body Sem_Res is -- overflow is impossible (divisor > 1) or we have a case of -- division by zero in any case. - if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) + if Nkind (Rorig) in N_Op_Divide | N_Op_Rem and then Compile_Time_Known_Value (Right_Opnd (Rorig)) and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 then @@ -12196,6 +12146,18 @@ package body Sem_Res is Resolve (Operand, Opnd_Type); + -- If the expression is a conversion to universal integer of an + -- an expression with an integer type, then we can eliminate the + -- intermediate conversion to universal integer. + + if Nkind (Operand) = N_Type_Conversion + and then Entity (Subtype_Mark (Operand)) = Universal_Integer + and then Is_Integer_Type (Etype (Expression (Operand))) + then + Rewrite (Operand, Relocate_Node (Expression (Operand))); + Analyze_And_Resolve (Operand); + end if; + -- In an inlined context, the unchecked conversion may be applied -- to a literal, in which case its type is the type of the context. -- (In other contexts conversions cannot apply to literals). @@ -12477,37 +12439,51 @@ package body Sem_Res is -- If the lower bound is not static we create a range for the string -- literal, using the index type and the known length of the literal. - -- The index type is not necessarily Positive, so the upper bound is - -- computed as T'Val (T'Pos (Low_Bound) + L - 1). + -- If the length is 1, then the upper bound is set to a mere copy of + -- the lower bound; or else, if the index type is a signed integer, + -- then the upper bound is computed as Low_Bound + L - 1; otherwise, + -- the upper bound is computed as T'Val (T'Pos (Low_Bound) + L - 1). else declare - Index_List : constant List_Id := New_List; - Index_Type : constant Entity_Id := Etype (First_Index (Typ)); - High_Bound : constant Node_Id := - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Val, - Prefix => - New_Occurrence_Of (Index_Type, Loc), - Expressions => New_List ( - Make_Op_Add (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Pos, - Prefix => - New_Occurrence_Of (Index_Type, Loc), - Expressions => - New_List (New_Copy_Tree (Low_Bound))), - Right_Opnd => - Make_Integer_Literal (Loc, - String_Length (Strval (N)) - 1)))); - + Length : constant Nat := String_Length (Strval (N)); + Index_List : constant List_Id := New_List; + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); Array_Subtype : Entity_Id; Drange : Node_Id; + High_Bound : Node_Id; Index : Node_Id; Index_Subtype : Entity_Id; begin + if Length = 1 then + High_Bound := New_Copy_Tree (Low_Bound); + + elsif Is_Signed_Integer_Type (Index_Type) then + High_Bound := + Make_Op_Add (Loc, + Left_Opnd => New_Copy_Tree (Low_Bound), + Right_Opnd => Make_Integer_Literal (Loc, Length - 1)); + + else + High_Bound := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Val, + Prefix => + New_Occurrence_Of (Index_Type, Loc), + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => + New_Occurrence_Of (Index_Type, Loc), + Expressions => + New_List (New_Copy_Tree (Low_Bound))), + Right_Opnd => + Make_Integer_Literal (Loc, Length - 1)))); + end if; + if Is_Integer_Type (Index_Type) then Set_String_Literal_Low_Bound (Subtype_Id, Make_Integer_Literal (Loc, 1)); @@ -12522,10 +12498,10 @@ package body Sem_Res is Attribute_Name => Name_First, Prefix => New_Occurrence_Of (Base_Type (Index_Type), Loc))); - Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type); end if; - Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id)); + Analyze_And_Resolve + (String_Literal_Low_Bound (Subtype_Id), Base_Type (Index_Type)); -- Build bona fide subtype for the string, and wrap it in an -- unchecked conversion, because the back end expects the @@ -12599,9 +12575,9 @@ package body Sem_Res is or else (Is_Fixed_Point_Type (Target_Typ) and then Conversion_OK (N))) and then Nkind (Operand) = N_Attribute_Reference - and then Nam_In (Attribute_Name (Operand), Name_Rounding, - Name_Machine_Rounding, - Name_Truncation) + and then Attribute_Name (Operand) in Name_Rounding + | Name_Machine_Rounding + | Name_Truncation then declare Truncate : constant Boolean := @@ -12611,6 +12587,30 @@ package body Sem_Res is Relocate_Node (First (Expressions (Operand)))); Set_Float_Truncate (N, Truncate); end; + + -- Special processing for the conversion of an integer literal to + -- a dynamic type: we first convert the literal to the root type + -- and then convert the result to the target type, the goal being + -- to avoid doing range checks in universal integer. + + elsif Is_Integer_Type (Target_Typ) + and then not Is_Generic_Type (Root_Type (Target_Typ)) + and then Nkind (Operand) = N_Integer_Literal + and then Opnd_Typ = Universal_Integer + then + Convert_To_And_Rewrite (Root_Type (Target_Typ), Operand); + Analyze_And_Resolve (Operand); + + -- If the expression is a conversion to universal integer of an + -- an expression with an integer type, then we can eliminate the + -- intermediate conversion to universal integer. + + elsif Nkind (Operand) = N_Type_Conversion + and then Entity (Subtype_Mark (Operand)) = Universal_Integer + and then Is_Integer_Type (Etype (Expression (Operand))) + then + Rewrite (Operand, Relocate_Node (Expression (Operand))); + Analyze_And_Resolve (Operand); end if; end; end if; @@ -12710,7 +12710,7 @@ package body Sem_Res is -- When the context is a type conversion, issue the warning on the -- expression of the conversion because it is the actual operation. - if Nkind_In (N, N_Type_Conversion, N_Unchecked_Type_Conversion) then + if Nkind (N) in N_Type_Conversion | N_Unchecked_Type_Conversion then ErrN := Expression (N); else ErrN := N; @@ -12757,6 +12757,18 @@ package body Sem_Res is -- are not rechecked because type visbility may lead to spurious errors, -- but conversions in an actual for a formal object must be checked. + function Is_Discrim_Of_Bad_Access_Conversion_Argument + (Expr : Node_Id) return Boolean; + -- Implicit anonymous-to-named access type conversions are not allowed + -- if the "statically deeper than" relationship does not apply to the + -- type of the conversion operand. See RM 8.6(28.1) and AARM 8.6(28.d). + -- We deal with most such cases elsewhere so that we can emit more + -- specific error messages (e.g., if the operand is an access parameter + -- or a saooaaat (stand-alone object of an anonymous access type)), but + -- here is where we catch the case where the operand is an access + -- discriminant selected from a dereference of another such "bad" + -- conversion argument. + function Valid_Tagged_Conversion (Target_Type : Entity_Id; Opnd_Type : Entity_Id) return Boolean; @@ -12859,6 +12871,73 @@ package body Sem_Res is end if; end In_Instance_Code; + -------------------------------------------------- + -- Is_Discrim_Of_Bad_Access_Conversion_Argument -- + -------------------------------------------------- + + function Is_Discrim_Of_Bad_Access_Conversion_Argument + (Expr : Node_Id) return Boolean + is + Exp_Type : Entity_Id := Base_Type (Etype (Expr)); + pragma Assert (Is_Access_Type (Exp_Type)); + + Associated_Node : Node_Id; + Deref_Prefix : Node_Id; + begin + if not Is_Anonymous_Access_Type (Exp_Type) then + return False; + end if; + + pragma Assert (Is_Itype (Exp_Type)); + Associated_Node := Associated_Node_For_Itype (Exp_Type); + + if Nkind (Associated_Node) /= N_Discriminant_Specification then + return False; -- not the type of an access discriminant + end if; + + -- return False if Expr not of form <prefix>.all.Some_Component + + if (Nkind (Expr) /= N_Selected_Component) + or else (Nkind (Prefix (Expr)) /= N_Explicit_Dereference) + then + -- conditional expressions, declare expressions ??? + return False; + end if; + + Deref_Prefix := Prefix (Prefix (Expr)); + Exp_Type := Base_Type (Etype (Deref_Prefix)); + + -- The "statically deeper relationship" does not apply + -- to generic formal access types, so a prefix of such + -- a type is a "bad" prefix. + + if Is_Generic_Formal (Exp_Type) then + return True; + + -- The "statically deeper relationship" does apply to + -- any other named access type. + + elsif not Is_Anonymous_Access_Type (Exp_Type) then + return False; + end if; + + pragma Assert (Is_Itype (Exp_Type)); + Associated_Node := Associated_Node_For_Itype (Exp_Type); + + -- The "statically deeper relationship" applies to some + -- anonymous access types and not to others. Return + -- True for the cases where it does not apply. Also check + -- recursively for the + -- <prefix>.all.Access_Discrim.all.Access_Discrim case, + -- where the correct result depends on <prefix>. + + return Nkind (Associated_Node) in + N_Procedure_Specification | -- access parameter + N_Function_Specification | -- access parameter + N_Object_Declaration -- saooaaat + or else Is_Discrim_Of_Bad_Access_Conversion_Argument (Deref_Prefix); + end Is_Discrim_Of_Bad_Access_Conversion_Argument; + ---------------------------- -- Valid_Array_Conversion -- ---------------------------- @@ -12929,9 +13008,9 @@ package body Sem_Res is -- checks that must be applied to such conversions to prevent -- out-of-scope references. - elsif Ekind_In - (Target_Comp_Base, E_Anonymous_Access_Type, - E_Anonymous_Access_Subprogram_Type) + elsif Ekind (Target_Comp_Base) in + E_Anonymous_Access_Type + | E_Anonymous_Access_Subprogram_Type and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) and then Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) @@ -13240,8 +13319,8 @@ package body Sem_Res is -- interface type. elsif Is_Access_Type (Opnd_Type) - and then Ekind_In (Target_Type, E_General_Access_Type, - E_Anonymous_Access_Type) + and then Ekind (Target_Type) in + E_General_Access_Type | E_Anonymous_Access_Type and then Is_Interface (Directly_Designated_Type (Target_Type)) then -- Check the static accessibility rule of 4.6(17). Note that the @@ -13321,7 +13400,7 @@ package body Sem_Res is if Is_Entity_Name (Operand) and then not Is_Local_Anonymous_Access (Opnd_Type) and then - Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) + Ekind (Entity (Operand)) in E_In_Parameter | E_Constant and then Present (Discriminal_Link (Entity (Operand))) then Conversion_Error_N @@ -13336,14 +13415,15 @@ package body Sem_Res is -- General and anonymous access types - elsif Ekind_In (Target_Type, E_General_Access_Type, - E_Anonymous_Access_Type) + elsif Ekind (Target_Type) in + E_General_Access_Type | E_Anonymous_Access_Type and then Conversion_Check (Is_Access_Type (Opnd_Type) - and then not - Ekind_In (Opnd_Type, E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type), + and then + Ekind (Opnd_Type) not in + E_Access_Subprogram_Type | + E_Access_Protected_Subprogram_Type, "must be an access-to-object type") then if Is_Access_Constant (Opnd_Type) @@ -13395,26 +13475,24 @@ package body Sem_Res is return False; -- Implicit conversions aren't allowed for anonymous access - -- parameters. The "not Is_Local_Anonymous_Access_Type" test - -- is done to exclude anonymous access results. + -- parameters. We exclude anonymous access results as well + -- as universal_access "=". elsif not Is_Local_Anonymous_Access (Opnd_Type) - and then Nkind_In (Associated_Node_For_Itype (Opnd_Type), - N_Function_Specification, - N_Procedure_Specification) + and then Nkind (Associated_Node_For_Itype (Opnd_Type)) in + N_Function_Specification | + N_Procedure_Specification + and then Nkind (Parent (N)) not in N_Op_Eq | N_Op_Ne then Conversion_Error_N - ("implicit conversion of anonymous access formal " + ("implicit conversion of anonymous access parameter " & "not allowed", Operand); return False; - -- This is a case where there's an enclosing object whose - -- to which the "statically deeper than" relationship does - -- not apply (such as an access discriminant selected from - -- a dereference of an access parameter). + -- Detect access discriminant values that are illegal + -- implicit anonymous-to-named access conversion operands. - elsif Object_Access_Level (Operand) - = Scope_Depth (Standard_Standard) + elsif Is_Discrim_Of_Bad_Access_Conversion_Argument (Operand) then Conversion_Error_N ("implicit conversion of anonymous access value " @@ -13426,7 +13504,7 @@ package body Sem_Res is -- implicit conversion is disallowed (by RM12-8.6(27.1/3)). elsif Type_Access_Level (Opnd_Type) > - Deepest_Type_Access_Level (Target_Type) + Deepest_Type_Access_Level (Target_Type) then Conversion_Error_N ("implicit conversion of anonymous access value " @@ -13435,8 +13513,19 @@ package body Sem_Res is end if; end if; + -- Check if the operand is deeper than the target type, taking + -- care to avoid the case where we are converting a result of a + -- function returning an anonymous access type since the "master + -- of the call" would be target type of the conversion unless + -- the target type is anonymous access as well - see RM 3.10.2 + -- (10.3/3). + elsif Type_Access_Level (Opnd_Type) > Deepest_Type_Access_Level (Target_Type) + and then (Nkind (Associated_Node_For_Itype (Opnd_Type)) /= + N_Function_Specification + or else Ekind (Target_Type) in + Anonymous_Access_Kind) then -- In an instance, this is a run-time check, but one we know -- will fail, so generate an appropriate warning. The raise @@ -13507,7 +13596,7 @@ package body Sem_Res is if Is_Entity_Name (Operand) and then - Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) + Ekind (Entity (Operand)) in E_In_Parameter | E_Constant and then Present (Discriminal_Link (Entity (Operand))) then Conversion_Error_N |