diff options
Diffstat (limited to 'gcc/ada/sem_ch6.adb')
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 1174 |
1 files changed, 739 insertions, 435 deletions
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index eca0557..ed1c326 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.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- -- @@ -32,6 +32,7 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; +with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; @@ -51,7 +52,6 @@ with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; -with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; @@ -152,6 +152,16 @@ package body Sem_Ch6 is -- against a formal access-to-subprogram type so Get_Instance_Of must -- be called. + procedure Check_Formal_Subprogram_Conformance + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id; + Errmsg : Boolean; + Conforms : out Boolean); + -- Core implementation of Check_Formal_Subprogram_Conformance from spec. + -- Errmsg can be set to False to not emit error messages. + -- Conforms is set to True if there is conformance, False otherwise. + procedure Check_Limited_Return (N : Node_Id; Expr : Node_Id; @@ -225,8 +235,6 @@ package body Sem_Ch6 is Analyze_Subprogram_Specification (Specification (N)); begin - Check_SPARK_05_Restriction ("abstract subprogram is not allowed", N); - Generate_Definition (Subp_Id); -- Set the SPARK mode from the current context (may be overwritten later @@ -423,14 +431,6 @@ package body Sem_Ch6 is Relocate_Pragmas_To_Body (N); Analyze (N); - -- Once the aspects of the generated body have been analyzed, create - -- a copy for ASIS purposes and associate it with the original node. - - if Has_Aspects (N) then - Set_Aspect_Specifications (Orig_N, - New_Copy_List_Tree (Aspect_Specifications (N))); - end if; - -- Prev is the previous entity with the same name, but it is can -- be an unrelated spec that is not completed by the expression -- function. In that case the relevant entity is the one in the body. @@ -484,14 +484,6 @@ package body Sem_Ch6 is Analyze (N); - -- Once the aspects of the generated spec have been analyzed, create - -- a copy for ASIS purposes and associate it with the original node. - - if Has_Aspects (N) then - Set_Aspect_Specifications (Orig_N, - New_Copy_List_Tree (Aspect_Specifications (N))); - end if; - -- If aspect SPARK_Mode was specified on the body, it needs to be -- repeated both on the generated spec and the body. @@ -517,9 +509,14 @@ package body Sem_Ch6 is -- Within a generic preanalyze the original expression for name -- capture. The body is also generated but plays no role in -- this because it is not part of the original source. + -- If this is an ignored Ghost entity, analysis of the generated + -- body is needed to hide external references (as is done in + -- Analyze_Subprogram_Body) after which the the subprogram profile + -- can be frozen, which is needed to expand calls to such an ignored + -- Ghost subprogram. if Inside_A_Generic then - Set_Has_Completion (Def_Id); + Set_Has_Completion (Def_Id, not Is_Ignored_Ghost_Entity (Def_Id)); Push_Scope (Def_Id); Install_Formals (Def_Id); Preanalyze_Spec_Expression (Expr, Etype (Def_Id)); @@ -571,6 +568,50 @@ package body Sem_Ch6 is Check_Limited_Return (Original_Node (N), Expr, Typ); End_Scope; end if; + + -- In the case of an expression function marked with the + -- aspect Static, we need to check the requirement that the + -- function's expression is a potentially static expression. + -- This is done by making a full copy of the expression tree + -- and performing a special preanalysis on that tree with + -- the global flag Checking_Potentially_Static_Expression + -- enabled. If the resulting expression is static, then it's + -- OK, but if not, that means the expression violates the + -- requirements of the Ada 202x RM in 4.9(3.2/5-3.4/5) and + -- we flag an error. + + if Is_Static_Function (Def_Id) then + if not Is_Static_Expression (Expr) then + declare + Exp_Copy : constant Node_Id := New_Copy_Tree (Expr); + begin + Set_Checking_Potentially_Static_Expression (True); + + Preanalyze_Formal_Expression (Exp_Copy, Typ); + + if not Is_Static_Expression (Exp_Copy) then + Error_Msg_N + ("static expression function requires " + & "potentially static expression", Expr); + end if; + + Set_Checking_Potentially_Static_Expression (False); + end; + end if; + + -- We also make an additional copy of the expression and + -- replace the expression of the expression function with + -- this copy, because the currently present expression is + -- now associated with the body created for the static + -- expression function, which will later be analyzed and + -- possibly rewritten, and we need to have the separate + -- unanalyzed copy available for use with later static + -- calls. + + Set_Expression + (Original_Node (Subprogram_Spec (Def_Id)), + New_Copy_Tree (Expr)); + end if; end if; end; end if; @@ -694,7 +735,11 @@ package body Sem_Ch6 is R_Type : constant Entity_Id := Etype (Scope_Id); -- Function result subtype - procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id); + procedure Check_No_Return_Expression (Return_Expr : Node_Id); + -- Ada 2020: Check that the return expression in a No_Return function + -- meets the conditions specified by RM 6.5.1(5.1/5). + + procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id); -- Apply legality rule of 6.5 (5.9) to the access discriminants of an -- aggregate in a return statement. @@ -702,32 +747,62 @@ package body Sem_Ch6 is -- Check that the return_subtype_indication properly matches the result -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). - ------------------------------------ - -- Check_Return_Obj_Accessibility -- - ------------------------------------ + -------------------------------- + -- Check_No_Return_Expression -- + -------------------------------- + + procedure Check_No_Return_Expression (Return_Expr : Node_Id) is + Kind : constant Node_Kind := Nkind (Return_Expr); + + begin + if Kind = N_Raise_Expression then + return; + + elsif Kind = N_Function_Call + and then Is_Entity_Name (Name (Return_Expr)) + and then Ekind (Entity (Name (Return_Expr))) in + E_Function | E_Generic_Function + and then No_Return (Entity (Name (Return_Expr))) + then + return; + end if; - procedure Check_Return_Obj_Accessibility (Return_Stmt : Node_Id) is + Error_Msg_N + ("illegal expression in RETURN statement of No_Return function", + Return_Expr); + Error_Msg_N + ("\must be raise expression or call to No_Return (RM 6.5.1(5.1/5))", + Return_Expr); + end Check_No_Return_Expression; + + ------------------------------------------ + -- Check_Return_Construct_Accessibility -- + ------------------------------------------ + + procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is Assoc : Node_Id; Agg : Node_Id := Empty; Discr : Entity_Id; Expr : Node_Id; Obj : Node_Id; Process_Exprs : Boolean := False; - Return_Obj : Node_Id; + Return_Con : Node_Id; begin - -- Only perform checks on record types with access discriminants + -- Only perform checks on record types with access discriminants and + -- non-internally generated functions. if not Is_Record_Type (R_Type) or else not Has_Discriminants (R_Type) + or else not Comes_From_Source (Return_Stmt) then return; end if; -- We are only interested in return statements - if not Nkind_In (Return_Stmt, N_Extended_Return_Statement, - N_Simple_Return_Statement) + if Nkind (Return_Stmt) not in + N_Extended_Return_Statement | N_Simple_Return_Statement then return; end if; @@ -736,32 +811,47 @@ package body Sem_Ch6 is -- simple return statement the expression is part of the node. if Nkind (Return_Stmt) = N_Extended_Return_Statement then - Return_Obj := Last (Return_Object_Declarations (Return_Stmt)); + -- Obtain the object definition from the expanded extended return - -- We could be looking at something that's been expanded with - -- an initialzation procedure which we can safely ignore. + Return_Con := First (Return_Object_Declarations (Return_Stmt)); + while Present (Return_Con) loop + -- Inspect the original node to avoid object declarations + -- expanded into renamings. - if Nkind (Return_Obj) /= N_Object_Declaration then - return; - end if; + if Nkind (Original_Node (Return_Con)) = N_Object_Declaration + and then Comes_From_Source (Original_Node (Return_Con)) + then + exit; + end if; + + Nlists.Next (Return_Con); + end loop; + + pragma Assert (Present (Return_Con)); + + -- Could be dealing with a renaming + + Return_Con := Original_Node (Return_Con); else - Return_Obj := Return_Stmt; + Return_Con := Return_Stmt; end if; -- We may need to check an aggregate or a subtype indication -- depending on how the discriminants were specified and whether -- we are looking at an extended return statement. - if Nkind (Return_Obj) = N_Object_Declaration - and then Nkind (Object_Definition (Return_Obj)) + if Nkind (Return_Con) = N_Object_Declaration + and then Nkind (Object_Definition (Return_Con)) = N_Subtype_Indication then - Assoc := First (Constraints - (Constraint (Object_Definition (Return_Obj)))); + Assoc := Original_Node + (First + (Constraints + (Constraint (Object_Definition (Return_Con))))); else -- Qualified expressions may be nested - Agg := Original_Node (Expression (Return_Obj)); + Agg := Original_Node (Expression (Return_Con)); while Nkind (Agg) = N_Qualified_Expression loop Agg := Original_Node (Expression (Agg)); end loop; @@ -794,71 +884,89 @@ package body Sem_Ch6 is if Nkind (Assoc) = N_Attribute_Reference then Expr := Assoc; - elsif Nkind_In (Assoc, N_Component_Association, - N_Discriminant_Association) + elsif Nkind (Assoc) in + N_Component_Association | N_Discriminant_Association then Expr := Expression (Assoc); + else + Expr := Empty; end if; -- This anonymous access discriminant has an associated -- expression which needs checking. - if Nkind (Expr) = N_Attribute_Reference + if Present (Expr) + and then Nkind (Expr) = N_Attribute_Reference and then Attribute_Name (Expr) /= Name_Unrestricted_Access then -- Obtain the object to perform static checks on by moving -- up the prefixes in the expression taking into account - -- named access types. + -- named access types and renamed objects within the + -- expression. - Obj := Prefix (Expr); - while Nkind_In (Obj, N_Indexed_Component, - N_Selected_Component) + -- Note, this loop duplicates some of the logic in + -- Object_Access_Level since we have to check special rules + -- based on the context we are in (a return aggregate) + -- relating to formals of the current function. + + Obj := Original_Node (Prefix (Expr)); loop - -- When we encounter a named access type then we can - -- ignore accessibility checks on the dereference. + while Nkind (Obj) in N_Explicit_Dereference + | N_Indexed_Component + | N_Selected_Component + loop + -- When we encounter a named access type then we can + -- ignore accessibility checks on the dereference. - if Ekind (Etype (Prefix (Obj))) - in E_Access_Type .. - E_Access_Protected_Subprogram_Type - then - if Nkind (Obj) = N_Selected_Component then - Obj := Selector_Name (Obj); + if Ekind (Etype (Original_Node (Prefix (Obj)))) + in E_Access_Type .. + E_Access_Protected_Subprogram_Type + then + if Nkind (Obj) = N_Selected_Component then + Obj := Selector_Name (Obj); + else + Obj := Original_Node (Prefix (Obj)); + end if; + exit; end if; - exit; - end if; - -- Skip over the explicit dereference + Obj := Original_Node (Prefix (Obj)); + end loop; - if Nkind (Prefix (Obj)) = N_Explicit_Dereference then - Obj := Prefix (Prefix (Obj)); + if Nkind (Obj) = N_Selected_Component then + Obj := Selector_Name (Obj); + end if; - -- Otherwise move up to the next prefix + -- Check for renamings + pragma Assert (Is_Entity_Name (Obj)); + + if Present (Renamed_Object (Entity (Obj))) then + Obj := Renamed_Object (Entity (Obj)); else - Obj := Prefix (Obj); + exit; end if; end loop; - -- Do not check aliased formals or function calls. A - -- run-time check may still be needed ??? + -- Do not check aliased formals statically - if Is_Entity_Name (Obj) - and then Comes_From_Source (Obj) + if Is_Formal (Entity (Obj)) + and then (Is_Aliased (Entity (Obj)) + or else Ekind (Etype (Entity (Obj))) = + E_Anonymous_Access_Type) then - -- Explicitly aliased formals are allowed + null; - if Is_Formal (Entity (Obj)) - and then Is_Aliased (Entity (Obj)) - then - null; + -- Otherwise, handle the expression normally, avoiding the + -- special logic above, and call Object_Access_Level with + -- the original expression. - elsif Object_Access_Level (Obj) > - Scope_Depth (Scope (Scope_Id)) - then - Error_Msg_N - ("access discriminant in return aggregate would " - & "be a dangling reference", Obj); - end if; + elsif Object_Access_Level (Expr) > + Scope_Depth (Scope (Scope_Id)) + then + Error_Msg_N + ("access discriminant in return aggregate would " + & "be a dangling reference", Obj); end if; end if; end if; @@ -886,7 +994,7 @@ package body Sem_Ch6 is end if; end if; end loop; - end Check_Return_Obj_Accessibility; + end Check_Return_Construct_Accessibility; ------------------------------------- -- Check_Return_Subtype_Indication -- @@ -1048,8 +1156,7 @@ package body Sem_Ch6 is -- This early expansion is done only when the return statement is -- not part of a handled sequence of statements. - if Nkind_In (Expr, N_Aggregate, - N_Extension_Aggregate) + if Nkind (Expr) in N_Aggregate | N_Extension_Aggregate and then Needs_Finalization (R_Type) and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements then @@ -1081,7 +1188,7 @@ package body Sem_Ch6 is if Expander_Active and then Serious_Errors_Detected = 0 and then Is_Access_Type (R_Type) - and then not Nkind_In (Expr, N_Null, N_Raise_Expression) + and then Nkind (Expr) not in N_Null | N_Raise_Expression and then Is_Interface (Designated_Type (R_Type)) and then Is_Progenitor (Designated_Type (R_Type), Designated_Type (Etype (Expr))) @@ -1093,22 +1200,22 @@ package body Sem_Ch6 is Resolve (Expr, R_Type); Check_Limited_Return (N, Expr, R_Type); - Check_Return_Obj_Accessibility (N); - end if; + Check_Return_Construct_Accessibility (N); - -- RETURN only allowed in SPARK as the last statement in function + -- Ada 2020 (AI12-0269): Any return statement that applies to a + -- nonreturning function shall be a simple_return_statement with + -- an expression that is a raise_expression, or else a call on a + -- nonreturning function, or else a parenthesized expression of + -- one of these. - if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements - and then - (Nkind (Parent (Parent (N))) /= N_Subprogram_Body - or else Present (Next (N))) - then - Check_SPARK_05_Restriction - ("RETURN should be the last statement in function", N); + if Ada_Version >= Ada_2020 + and then No_Return (Scope_Id) + and then Comes_From_Source (N) + then + Check_No_Return_Expression (Original_Node (Expr)); + end if; end if; - else - Check_SPARK_05_Restriction ("extended RETURN is not allowed", N); Obj_Decl := Last (Return_Object_Declarations (N)); -- Analyze parts specific to extended_return_statement: @@ -1125,7 +1232,33 @@ package body Sem_Ch6 is -- object declaration. Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); - Analyze (Obj_Decl); + + -- Returning a build-in-place unconstrained array type we defer + -- the full analysis of the returned object to avoid generating + -- the corresponding constrained subtype; otherwise the bounds + -- would be created in the stack and a dangling reference would + -- be returned pointing to the bounds. We perform its preanalysis + -- to report errors on the initializing aggregate now (if any); + -- we also ensure its activation chain and Master variable are + -- defined (if tasks are being declared) since they are generated + -- as part of the analysis and expansion of the object declaration + -- at this stage. + + if Is_Array_Type (R_Type) + and then not Is_Constrained (R_Type) + and then Is_Build_In_Place_Function (Scope_Id) + and then Needs_BIP_Alloc_Form (Scope_Id) + and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate + then + Preanalyze (Obj_Decl); + + if Expander_Active then + Ensure_Activation_Chain_And_Master (Obj_Decl); + end if; + + else + Analyze (Obj_Decl); + end if; Check_Return_Subtype_Indication (Obj_Decl); @@ -1149,7 +1282,7 @@ package body Sem_Ch6 is Check_References (Stm_Entity); - Check_Return_Obj_Accessibility (N); + Check_Return_Construct_Accessibility (N); -- Check RM 6.5 (5.9/3) @@ -1168,6 +1301,18 @@ package body Sem_Ch6 is ("aliased only allowed for limited return objects", N); end if; end if; + + -- Ada 2020 (AI12-0269): Any return statement that applies to a + -- nonreturning function shall be a simple_return_statement. + + if Ada_Version >= Ada_2020 + and then No_Return (Scope_Id) + and then Comes_From_Source (N) + then + Error_Msg_N + ("extended RETURN statement not allowed in No_Return " + & "function", N); + end if; end; end if; @@ -1200,20 +1345,31 @@ package body Sem_Ch6 is -- The return value is converted to the return type of the function, -- which implies a predicate check if the return type is predicated. + -- We do not apply the check for an extended return statement because + -- Analyze_Object_Declaration has already done it on Obj_Decl above. -- We do not apply the check to a case expression because it will -- be expanded into a series of return statements, each of which -- will receive a predicate check. - if Nkind (Expr) /= N_Case_Expression then + if Nkind (N) /= N_Extended_Return_Statement + and then Nkind (Expr) /= N_Case_Expression + then Apply_Predicate_Check (Expr, R_Type); end if; -- Ada 2005 (AI-318-02): When the result type is an anonymous access -- type, apply an implicit conversion of the expression to that type -- to force appropriate static and run-time accessibility checks. + -- But we want to apply the checks to an extended return statement + -- only once, i.e. not to the simple return statement generated at + -- the end of its expansion because, prior to leaving the function, + -- the accessibility level of the return object changes to be a level + -- determined by the point of call (RM 3.10.2(10.8/3)). if Ada_Version >= Ada_2005 and then Ekind (R_Type) = E_Anonymous_Access_Type + and then (Nkind (N) = N_Extended_Return_Statement + or else not Comes_From_Extended_Return_Statement (N)) then Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr))); Analyze_And_Resolve (Expr, R_Type); @@ -1839,9 +1995,9 @@ package body Sem_Ch6 is -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls if Nkind (P) = N_Attribute_Reference - and then Nam_In (Attribute_Name (P), Name_Elab_Spec, - Name_Elab_Body, - Name_Elab_Subp_Body) + and then Attribute_Name (P) in Name_Elab_Spec + | Name_Elab_Body + | Name_Elab_Subp_Body then if Present (Actuals) then Error_Msg_N @@ -1867,6 +2023,10 @@ package body Sem_Ch6 is and then Comes_From_Source (N) then Error_Msg_N ("missing explicit dereference in call", N); + + elsif Ekind (Entity (P)) = E_Operator then + Error_Msg_Name_1 := Chars (P); + Error_Msg_N ("operator % cannot be used as a procedure", N); end if; Analyze_Call_And_Resolve; @@ -1927,9 +2087,8 @@ package body Sem_Ch6 is -- function, the context will select the operation whose type is Void. elsif Nkind (P) = N_Selected_Component - and then Ekind_In (Entity (Selector_Name (P)), E_Entry, - E_Function, - E_Procedure) + and then Ekind (Entity (Selector_Name (P))) + in E_Entry | E_Function | E_Procedure then -- When front-end inlining is enabled, as with SPARK_Mode, a call -- in prefix notation may still be missing its controlling argument, @@ -2028,8 +2187,8 @@ package body Sem_Ch6 is ------------------------------ procedure Analyze_Return_Statement (N : Node_Id) is - pragma Assert (Nkind_In (N, N_Extended_Return_Statement, - N_Simple_Return_Statement)); + pragma Assert + (Nkind (N) in N_Extended_Return_Statement | N_Simple_Return_Statement); Returns_Object : constant Boolean := Nkind (N) = N_Extended_Return_Statement @@ -2062,7 +2221,7 @@ package body Sem_Ch6 is for J in reverse 0 .. Scope_Stack.Last loop Result := Scope_Stack.Table (J).Entity; - exit when not Ekind_In (Result, E_Block, E_Loop) + exit when Ekind (Result) not in E_Block | E_Loop and then Chars (Result) /= Name_uPostconditions; end loop; @@ -2097,8 +2256,12 @@ package body Sem_Ch6 is -- Check that pragma No_Return is obeyed. Don't complain about the -- implicitly-generated return that is placed at the end. - if No_Return (Scope_Id) and then Comes_From_Source (N) then - Error_Msg_N ("RETURN statement not allowed (No_Return)", N); + if No_Return (Scope_Id) + and then Kind in E_Procedure | E_Generic_Procedure + and then Comes_From_Source (N) + then + Error_Msg_N + ("RETURN statement not allowed in No_Return procedure", N); end if; -- Warn on any unassigned OUT parameters if in procedure @@ -2109,17 +2272,17 @@ package body Sem_Ch6 is -- Check that functions return objects, and other things do not - if Kind = E_Function or else Kind = E_Generic_Function then + if Kind in E_Function | E_Generic_Function then if not Returns_Object then Error_Msg_N ("missing expression in return from function", N); end if; - elsif Kind = E_Procedure or else Kind = E_Generic_Procedure then + elsif Kind in E_Procedure | E_Generic_Procedure then if Returns_Object then Error_Msg_N ("procedure cannot return value (use function)", N); end if; - elsif Kind = E_Entry or else Kind = E_Entry_Family then + elsif Kind in E_Entry | E_Entry_Family then if Returns_Object then if Is_Protected_Type (Scope (Scope_Id)) then Error_Msg_N ("entry body cannot return value", N); @@ -2153,10 +2316,10 @@ package body Sem_Ch6 is Error_Msg_N ("illegal context for return statement", N); end if; - if Ekind_In (Kind, E_Function, E_Generic_Function) then + if Kind in E_Function | E_Generic_Function then Analyze_Function_Return (N); - elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then + elsif Kind in E_Procedure | E_Generic_Procedure then Set_Return_Present (Scope_Id); end if; @@ -2196,8 +2359,6 @@ package body Sem_Ch6 is if Result_Definition (N) /= Error then if Nkind (Result_Definition (N)) = N_Access_Definition then - Check_SPARK_05_Restriction - ("access result is not allowed", Result_Definition (N)); -- Ada 2005 (AI-254): Handle anonymous access to subprograms @@ -2227,14 +2388,6 @@ package body Sem_Ch6 is Typ := Entity (Result_Definition (N)); Set_Etype (Designator, Typ); - -- Unconstrained array as result is not allowed in SPARK - - if Is_Array_Type (Typ) and then not Is_Constrained (Typ) then - Check_SPARK_05_Restriction - ("returning an unconstrained array is not allowed", - Result_Definition (N)); - end if; - -- Ada 2005 (AI-231): Ensure proper usage of null exclusion Null_Exclusion_Static_Checks (N); @@ -2331,8 +2484,8 @@ package body Sem_Ch6 is null; elsif Nkind (Parent (N)) = N_Subprogram_Body - or else Nkind_In (Parent (Parent (N)), N_Accept_Statement, - N_Entry_Body) + or else Nkind (Parent (Parent (N))) in + N_Accept_Statement | N_Entry_Body then Error_Msg_NE ("invalid use of untagged incomplete type&", @@ -2459,6 +2612,15 @@ package body Sem_Ch6 is -- because it is specified directly on the body, or because it is -- inherited from the enclosing subprogram or package. + function Build_Internal_Protected_Declaration + (N : Node_Id) return Entity_Id; + -- A subprogram body without a previous spec that appears in a protected + -- body must be expanded separately to create a subprogram declaration + -- for it, in order to resolve internal calls to it from other protected + -- operations. + -- + -- Possibly factor this with Exp_Dist.Copy_Specification ??? + procedure Build_Subprogram_Declaration; -- Create a matching subprogram declaration for subprogram body N @@ -2507,6 +2669,12 @@ package body Sem_Ch6 is -- the not-yet-frozen types referenced by the simple return statement -- of the function as formally frozen. + procedure Move_Pragmas (From : Node_Id; To : Node_Id); + -- Find all suitable source pragmas at the top of subprogram body + -- From's declarations and move them after arbitrary node To. + -- One exception is pragma SPARK_Mode which is copied rather than moved, + -- as it applies to the body too. + procedure Restore_Limited_Views (Restore_List : Elist_Id); -- Undo the transformation done by Exchange_Limited_Views. @@ -2619,68 +2787,129 @@ package body Sem_Ch6 is return SPARK_Mode = On; end Body_Has_SPARK_Mode_On; - ---------------------------------- - -- Build_Subprogram_Declaration -- - ---------------------------------- + ------------------------------------------ + -- Build_Internal_Protected_Declaration -- + ------------------------------------------ - procedure Build_Subprogram_Declaration is - procedure Move_Pragmas (From : Node_Id; To : Node_Id); - -- Relocate certain categorization pragmas from the declarative list - -- of subprogram body From and insert them after node To. The pragmas - -- in question are: - -- Ghost - -- Volatile_Function - -- Also copy pragma SPARK_Mode if present in the declarative list - -- of subprogram body From and insert it after node To. This pragma - -- should not be moved, as it applies to the body too. + function Build_Internal_Protected_Declaration + (N : Node_Id) return Entity_Id + is + procedure Analyze_Pragmas (From : Node_Id); + -- Analyze all pragmas which follow arbitrary node From - ------------------ - -- Move_Pragmas -- - ------------------ + --------------------- + -- Analyze_Pragmas -- + --------------------- - procedure Move_Pragmas (From : Node_Id; To : Node_Id) is - Decl : Node_Id; - Next_Decl : Node_Id; + procedure Analyze_Pragmas (From : Node_Id) is + Decl : Node_Id; begin - pragma Assert (Nkind (From) = N_Subprogram_Body); - - -- The destination node must be part of a list, as the pragmas are - -- inserted after it. - - pragma Assert (Is_List_Member (To)); - - -- Inspect the declarations of the subprogram body looking for - -- specific pragmas. - - Decl := First (Declarations (N)); + Decl := Next (From); while Present (Decl) loop - Next_Decl := Next (Decl); - if Nkind (Decl) = N_Pragma then - if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then - Insert_After (To, New_Copy_Tree (Decl)); + Analyze_Pragma (Decl); - elsif Nam_In (Pragma_Name_Unmapped (Decl), - Name_Ghost, - Name_Volatile_Function) - then - Remove (Decl); - Insert_After (To, Decl); - end if; + -- No candidate pragmas are available for analysis + + else + exit; end if; - Decl := Next_Decl; + Next (Decl); end loop; - end Move_Pragmas; + end Analyze_Pragmas; -- Local variables + Body_Id : constant Entity_Id := Defining_Entity (N); + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + Formal : Entity_Id; + Formals : List_Id; + Spec : Node_Id; + Spec_Id : Entity_Id; + + -- Start of processing for Build_Internal_Protected_Declaration + + begin + Formal := First_Formal (Body_Id); + + -- The protected operation always has at least one formal, namely the + -- object itself, but it is only placed in the parameter list if + -- expansion is enabled. + + if Present (Formal) or else Expander_Active then + Formals := Copy_Parameter_List (Body_Id); + else + Formals := No_List; + end if; + + Spec_Id := + Make_Defining_Identifier (Sloc (Body_Id), + Chars => Chars (Body_Id)); + + -- Indicate that the entity comes from source, to ensure that cross- + -- reference information is properly generated. The body itself is + -- rewritten during expansion, and the body entity will not appear in + -- calls to the operation. + + Set_Comes_From_Source (Spec_Id, True); + + if Nkind (Specification (N)) = N_Procedure_Specification then + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Formals); + else + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Formals, + Result_Definition => + New_Occurrence_Of (Etype (Body_Id), Loc)); + end if; + + Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); + Set_Corresponding_Body (Decl, Body_Id); + Set_Corresponding_Spec (N, Spec_Id); + + Insert_Before (N, Decl); + + -- Associate all aspects and pragmas of the body with the spec. This + -- ensures that these annotations apply to the initial declaration of + -- the subprogram body. + + Move_Aspects (From => N, To => Decl); + Move_Pragmas (From => N, To => Decl); + + Analyze (Decl); + + -- The analysis of the spec may generate pragmas which require manual + -- analysis. Since the generation of the spec and the relocation of + -- the annotations is driven by the expansion of the stand-alone + -- body, the pragmas will not be analyzed in a timely manner. Do this + -- now. + + Analyze_Pragmas (Decl); + + -- This subprogram has convention Intrinsic as per RM 6.3.1(10/2) + -- ensuring in particular that 'Access is illegal. + + Set_Convention (Spec_Id, Convention_Intrinsic); + Set_Has_Completion (Spec_Id); + + return Spec_Id; + end Build_Internal_Protected_Declaration; + + ---------------------------------- + -- Build_Subprogram_Declaration -- + ---------------------------------- + + procedure Build_Subprogram_Declaration is Decl : Node_Id; Subp_Decl : Node_Id; - -- Start of processing for Build_Subprogram_Declaration - begin -- Create a matching subprogram spec using the profile of the body. -- The structure of the tree is identical, but has new entities for @@ -2807,22 +3036,8 @@ package body Sem_Ch6 is and then Is_Limited_Record (Designated_Type (Etype (Scop))))) and then Expander_Active - - -- Avoid cases with no tasking support - - and then RTE_Available (RE_Current_Master) - and then not Restriction_Active (No_Task_Hierarchy) then - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uMaster), - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Master_Id), Loc), - Expression => - Make_Explicit_Dereference (Loc, - New_Occurrence_Of (RTE (RE_Current_Master), Loc))); + Decl := Build_Master_Declaration (Loc); if Present (Declarations (N)) then Prepend (Decl, Declarations (N)); @@ -2844,8 +3059,8 @@ package body Sem_Ch6 is -- the environment task is our effective master, so nothing -- to mark. - if Nkind_In - (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) + if Nkind (Par) + in N_Task_Body | N_Block_Statement | N_Subprogram_Body then Set_Is_Task_Master (Par, True); exit; @@ -2953,7 +3168,7 @@ package body Sem_Ch6 is -- To ensure proper coverage when body is inlined, indicate -- whether the subprogram comes from source. - Set_Comes_From_Source (Subp, Comes_From_Source (N)); + Preserve_Comes_From_Source (Subp, N); if Present (First_Formal (Body_Id)) then Plist := Copy_Parameter_List (Body_Id); @@ -3046,42 +3261,6 @@ package body Sem_Ch6 is Check_Returns (HSS, 'P', Missing_Ret, Id); end if; end if; - - -- Special checks in SPARK mode - - if Nkind (Body_Spec) = N_Function_Specification then - - -- In SPARK mode, last statement of a function should be a return - - declare - Stat : constant Node_Id := Last_Source_Statement (HSS); - begin - if Present (Stat) - and then not Nkind_In (Stat, N_Simple_Return_Statement, - N_Extended_Return_Statement) - then - Check_SPARK_05_Restriction - ("last statement in function should be RETURN", Stat); - end if; - end; - - -- In SPARK mode, verify that a procedure has no return - - elsif Nkind (Body_Spec) = N_Procedure_Specification then - if Present (Spec_Id) then - Id := Spec_Id; - else - Id := Body_Id; - end if; - - -- Would be nice to point to return statement here, can we - -- borrow the Check_Returns procedure here ??? - - if Return_Present (Id) then - Check_SPARK_05_Restriction - ("procedure should not have RETURN", N); - end if; - end if; end Check_Missing_Return; ----------------------- @@ -3234,7 +3413,7 @@ package body Sem_Ch6 is -- Do not process subprogram bodies as they already use the non- -- limited view of types. - if not Ekind_In (Subp_Id, E_Function, E_Procedure) then + if Ekind (Subp_Id) not in E_Function | E_Procedure then return No_Elist; end if; @@ -3337,11 +3516,11 @@ package body Sem_Ch6 is if Is_Entity_Name (Node) and then Present (Entity (Node)) then Mask_Type (Etype (Entity (Node))); - if Ekind_In (Entity (Node), E_Component, E_Discriminant) then + if Ekind (Entity (Node)) in E_Component | E_Discriminant then Mask_Type (Scope (Entity (Node))); end if; - elsif Nkind_In (Node, N_Aggregate, N_Null, N_Type_Conversion) + elsif Nkind (Node) in N_Aggregate | N_Null | N_Type_Conversion and then Present (Etype (Node)) then Mask_Type (Etype (Node)); @@ -3367,6 +3546,76 @@ package body Sem_Ch6 is return Result; end Mask_Unfrozen_Types; + ------------------ + -- Move_Pragmas -- + ------------------ + + procedure Move_Pragmas (From : Node_Id; To : Node_Id) is + Decl : Node_Id; + Insert_Nod : Node_Id; + Next_Decl : Node_Id; + + begin + pragma Assert (Nkind (From) = N_Subprogram_Body); + + -- The pragmas are moved in an order-preserving fashion + + Insert_Nod := To; + + -- Inspect the declarations of the subprogram body and relocate all + -- candidate pragmas. + + Decl := First (Declarations (From)); + while Present (Decl) loop + + -- Preserve the following declaration for iteration purposes, due + -- to possible relocation of a pragma. + + Next_Decl := Next (Decl); + + if Nkind (Decl) = N_Pragma then + -- Copy pragma SPARK_Mode if present in the declarative list + -- of subprogram body From and insert it after node To. This + -- pragma should not be moved, as it applies to the body too. + + if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then + Insert_After (Insert_Nod, New_Copy_Tree (Decl)); + + -- Move relevant pragmas to the spec + + elsif Pragma_Name_Unmapped (Decl) in Name_Depends + | Name_Ghost + | Name_Global + | Name_Pre + | Name_Precondition + | Name_Post + | Name_Refined_Depends + | Name_Refined_Global + | Name_Refined_Post + | Name_Inline + | Name_Pure_Function + | Name_Volatile_Function + then + Remove (Decl); + Insert_After (Insert_Nod, Decl); + Insert_Nod := Decl; + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Decl) then + null; + + -- No candidate pragmas are available for relocation + + else + exit; + end if; + + Decl := Next_Decl; + end loop; + end Move_Pragmas; + --------------------------- -- Restore_Limited_Views -- --------------------------- @@ -3441,9 +3690,9 @@ package body Sem_Ch6 is -- expansion. As a result, we add an exception for this case. elsif not Present (Overridden_Operation (Spec_Id)) - and then not (Nam_In (Chars (Spec_Id), Name_Adjust, - Name_Finalize, - Name_Initialize) + and then not (Chars (Spec_Id) in Name_Adjust + | Name_Finalize + | Name_Initialize and then In_Instance) then Error_Msg_NE @@ -3659,6 +3908,8 @@ package body Sem_Ch6 is -- are legal and can be processed ahead of the body. -- We make two copies of the given spec, one for the new -- declaration, and one for the body. + -- ??? This should be conditioned on front-end inlining rather + -- than GNATprove_Mode. if No (Spec_Id) and then GNATprove_Mode @@ -3699,7 +3950,7 @@ package body Sem_Ch6 is Build_Subprogram_Declaration; -- If this is a function that returns a constrained array, and - -- we are generating SPARK_For_C, create subprogram declaration + -- we are generating C code, create subprogram declaration -- to simplify subsequent C generation. elsif No (Spec_Id) @@ -3786,15 +4037,15 @@ package body Sem_Ch6 is -- Deal with special case of a fully private operation in the body of -- the protected type. We must create a declaration for the subprogram, - -- in order to attach the protected subprogram that will be used in - -- internal calls. We exclude compiler generated bodies from the - -- expander since the issue does not arise for those cases. + -- in order to attach the subprogram that will be used in internal + -- calls. We exclude compiler generated bodies from the expander since + -- the issue does not arise for those cases. if No (Spec_Id) and then Comes_From_Source (N) and then Is_Protected_Type (Current_Scope) then - Spec_Id := Build_Private_Protected_Declaration (N); + Spec_Id := Build_Internal_Protected_Declaration (N); end if; -- If we are generating C and this is a function returning a constrained @@ -3839,8 +4090,8 @@ package body Sem_Ch6 is -- the freeze actions that include the bodies. In particular, extra -- formals for accessibility or for return-in-place may need to be -- generated. Freeze nodes, if any, are inserted before the current - -- body. These freeze actions are also needed in ASIS mode and in - -- Compile_Only mode to enable the proper back-end type annotations. + -- body. These freeze actions are also needed in Compile_Only mode to + -- enable the proper back-end type annotations. -- They are necessary in any case to ensure proper elaboration order -- in gigi. @@ -3849,7 +4100,6 @@ package body Sem_Ch6 is and then not Has_Completion (Spec_Id) and then Serious_Errors_Detected = 0 and then (Expander_Active - or else ASIS_Mode or else Operating_Mode = Check_Semantics or else Is_Ignored_Ghost_Entity (Spec_Id)) then @@ -4040,9 +4290,7 @@ package body Sem_Ch6 is -- Within an instance, add local renaming declarations so that -- gdb can retrieve the values of actuals more easily. This is - -- only relevant if generating code (and indeed we definitely - -- do not want these definitions -gnatc mode, because that would - -- confuse ASIS). + -- only relevant if generating code. if Is_Generic_Instance (Spec_Id) and then Is_Wrapper_Package (Current_Scope) @@ -4251,13 +4499,7 @@ package body Sem_Ch6 is -- Handle inlining - -- Note: Normally we don't do any inlining if expansion is off, since - -- we won't generate code in any case. An exception arises in GNATprove - -- mode where we want to expand some calls in place, even with expansion - -- disabled, since the inlining eases formal verification. - - if not GNATprove_Mode - and then Expander_Active + if Expander_Active and then Serious_Errors_Detected = 0 and then Present (Spec_Id) and then Has_Pragma_Inline (Spec_Id) @@ -4265,8 +4507,7 @@ package body Sem_Ch6 is -- Legacy implementation (relying on front-end inlining) if not Back_End_Inlining then - if (Has_Pragma_Inline_Always (Spec_Id) - and then not Opt.Disable_FE_Inline_Always) + if Has_Pragma_Inline_Always (Spec_Id) or else (Front_End_Inlining and then not Opt.Disable_FE_Inline) then @@ -4454,7 +4695,7 @@ package body Sem_Ch6 is then -- Generate the minimum accessibility level object - -- A60b : integer := integer'min(2, paramL); + -- A60b : natural := natural'min(1, paramL); declare Loc : constant Source_Ptr := Sloc (Body_Nod); @@ -4464,11 +4705,11 @@ package body Sem_Ch6 is Make_Temporary (Loc, 'A', Extra_Accessibility (Form)), Object_Definition => New_Occurrence_Of - (Standard_Integer, Loc), + (Standard_Natural, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of - (Standard_Integer, Loc), + (Standard_Natural, Loc), Attribute_Name => Name_Min, Expressions => New_List ( Make_Integer_Literal (Loc, @@ -4585,6 +4826,15 @@ package body Sem_Ch6 is elsif Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Body_Stub then null; + -- SPARK_Mode Off could complete no SPARK_Mode in a generic, either + -- as specified in source code, or because SPARK_Mode On is ignored + -- in an instance where the context is SPARK_Mode Off/Auto. + + elsif Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = Off + and then (Is_Generic_Unit (Spec_Id) or else In_Instance) + then + null; + else Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id)); Error_Msg_N ("incorrect application of SPARK_Mode #", N); @@ -4742,9 +4992,7 @@ package body Sem_Ch6 is -- Push_xxx_Error_Label to find the first real statement. Stm := First (Statements (HSS)); - while Nkind_In (Stm, N_Call_Marker, N_Label) - or else Nkind (Stm) in N_Push_xxx_Label - loop + while Nkind (Stm) in N_Call_Marker | N_Label | N_Push_xxx_Label loop Next (Stm); end loop; @@ -4898,8 +5146,6 @@ package body Sem_Ch6 is if Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) then - Check_SPARK_05_Restriction ("null procedure is not allowed", N); - -- Null procedures are allowed in protected types, following the -- recent AI12-0147. @@ -5163,15 +5409,6 @@ package body Sem_Ch6 is -- Start of processing for Analyze_Subprogram_Specification begin - -- User-defined operator is not allowed in SPARK, except as a renaming - - if Nkind (Defining_Unit_Name (N)) = N_Defining_Operator_Symbol - and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration - then - Check_SPARK_05_Restriction - ("user-defined operator is not allowed", N); - end if; - -- Proceed with analysis. Do not emit a cross-reference entry if the -- specification comes from an expression function, because it may be -- the completion of a previous declaration. If it is not, the cross- @@ -5311,14 +5548,12 @@ package body Sem_Ch6 is -- In case of primitives associated with abstract interface types -- the check is applied later (see Analyze_Subprogram_Declaration). - if not Nkind_In (Original_Node (Parent (N)), - N_Abstract_Subprogram_Declaration, - N_Formal_Abstract_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + if Nkind (Original_Node (Parent (N))) not in + N_Abstract_Subprogram_Declaration | + N_Formal_Abstract_Subprogram_Declaration | + N_Subprogram_Renaming_Declaration then - if Is_Abstract_Type (Etype (Designator)) - and then not Is_Interface (Etype (Designator)) - then + if Is_Abstract_Type (Etype (Designator)) then Error_Msg_N ("function that returns abstract type must be abstract", N); @@ -5365,10 +5600,11 @@ package body Sem_Ch6 is -- in the message, and also provides the location for posting the -- message in the absence of a specified Err_Loc location. - function Conventions_Match - (Id1 : Entity_Id; - Id2 : Entity_Id) return Boolean; - -- Determine whether the conventions of arbitrary entities Id1 and Id2 + function Conventions_Match (Id1, Id2 : Entity_Id) return Boolean; + -- True if the conventions of entities Id1 and Id2 match. + + function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean; + -- True if the null exclusions of two formals of anonymous access type -- match. ----------------------- @@ -5444,11 +5680,11 @@ package body Sem_Ch6 is -- the only way these may receive a convention is if they inherit -- the convention of a related subprogram. - if Ekind_In (Id1, E_Anonymous_Access_Subprogram_Type, - E_Subprogram_Type) + if Ekind (Id1) in E_Anonymous_Access_Subprogram_Type + | E_Subprogram_Type or else - Ekind_In (Id2, E_Anonymous_Access_Subprogram_Type, - E_Subprogram_Type) + Ekind (Id2) in E_Anonymous_Access_Subprogram_Type + | E_Subprogram_Type then return True; @@ -5459,13 +5695,56 @@ package body Sem_Ch6 is end if; end Conventions_Match; + --------------------------- + -- Null_Exclusions_Match -- + --------------------------- + + function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean is + begin + if not Is_Anonymous_Access_Type (Etype (F1)) + or else not Is_Anonymous_Access_Type (Etype (F2)) + then + return True; + end if; + + -- AI12-0289-1: Case of controlling access parameter; False if the + -- partial view is untagged, the full view is tagged, and no explicit + -- "not null". Note that at this point, we're processing the package + -- body, so private/full types have been swapped. The Sloc test below + -- is to detect the (legal) case where F1 comes after the full type + -- declaration. This part is disabled pre-2005, because "not null" is + -- not allowed on those language versions. + + if Ada_Version >= Ada_2005 + and then Is_Controlling_Formal (F1) + and then not Null_Exclusion_Present (Parent (F1)) + and then not Null_Exclusion_Present (Parent (F2)) + then + declare + D : constant Entity_Id := Directly_Designated_Type (Etype (F1)); + Partial_View_Of_Desig : constant Entity_Id := + Incomplete_Or_Partial_View (D); + begin + return No (Partial_View_Of_Desig) + or else Is_Tagged_Type (Partial_View_Of_Desig) + or else Sloc (D) < Sloc (F1); + end; + + -- Not a controlling parameter, or one or both views have an explicit + -- "not null". + + else + return Null_Exclusion_Present (Parent (F1)) = + Null_Exclusion_Present (Parent (F2)); + end if; + end Null_Exclusions_Match; + -- Local Variables Old_Type : constant Entity_Id := Etype (Old_Id); New_Type : constant Entity_Id := Etype (New_Id); Old_Formal : Entity_Id; New_Formal : Entity_Id; - Access_Types_Match : Boolean; Old_Formal_Base : Entity_Id; New_Formal_Base : Entity_Id; @@ -5557,22 +5836,19 @@ package body Sem_Ch6 is Error_Msg_Name_2 := Name_Ada + Convention_Id'Pos (Convention (New_Id)); Conformance_Error ("\prior declaration for% has convention %!"); + return; else Conformance_Error ("\calling conventions do not match!"); + return; end if; + else + Check_Formal_Subprogram_Conformance + (New_Id, Old_Id, Err_Loc, Errmsg, Conforms); - return; - - elsif Is_Formal_Subprogram (Old_Id) - or else Is_Formal_Subprogram (New_Id) - or else (Is_Subprogram (New_Id) - and then Present (Alias (New_Id)) - and then Is_Formal_Subprogram (Alias (New_Id))) - then - Conformance_Error - ("\formal subprograms are not subtype conformant " - & "(RM 6.3.1 (17/3))"); + if not Conforms then + return; + end if; end if; end if; @@ -5632,25 +5908,14 @@ package body Sem_Ch6 is -- Null exclusion must match - if Null_Exclusion_Present (Parent (Old_Formal)) - /= - Null_Exclusion_Present (Parent (New_Formal)) - then - -- Only give error if both come from source. This should be - -- investigated some time, since it should not be needed ??? - - if Comes_From_Source (Old_Formal) - and then - Comes_From_Source (New_Formal) - then - Conformance_Error - ("\null exclusion for& does not match", New_Formal); + if not Null_Exclusions_Match (Old_Formal, New_Formal) then + Conformance_Error + ("\null exclusion for& does not match", New_Formal); - -- Mark error posted on the new formal to avoid duplicated - -- complaint about types not matching. + -- Mark error posted on the new formal to avoid duplicated + -- complaint about types not matching. - Set_Error_Posted (New_Formal); - end if; + Set_Error_Posted (New_Formal); end if; end if; @@ -5674,57 +5939,6 @@ package body Sem_Ch6 is New_Formal_Base := Get_Instance_Of (New_Formal_Base); end if; - Access_Types_Match := Ada_Version >= Ada_2005 - - -- Ensure that this rule is only applied when New_Id is a - -- renaming of Old_Id. - - and then Nkind (Parent (Parent (New_Id))) = - N_Subprogram_Renaming_Declaration - and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity - and then Present (Entity (Name (Parent (Parent (New_Id))))) - and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id - - -- Now handle the allowed access-type case - - and then Is_Access_Type (Old_Formal_Base) - and then Is_Access_Type (New_Formal_Base) - - -- The type kinds must match. The only exception occurs with - -- multiple generics of the form: - - -- generic generic - -- type F is private; type A is private; - -- type F_Ptr is access F; type A_Ptr is access A; - -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); - -- package F_Pack is ... package A_Pack is - -- package F_Inst is - -- new F_Pack (A, A_Ptr, A_P); - - -- When checking for conformance between the parameters of A_P - -- and F_P, the type kinds of F_Ptr and A_Ptr will not match - -- because the compiler has transformed A_Ptr into a subtype of - -- F_Ptr. We catch this case in the code below. - - and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base) - or else - (Is_Generic_Type (Old_Formal_Base) - and then Is_Generic_Type (New_Formal_Base) - and then Is_Internal (New_Formal_Base) - and then Etype (Etype (New_Formal_Base)) = - Old_Formal_Base)) - and then Directly_Designated_Type (Old_Formal_Base) = - Directly_Designated_Type (New_Formal_Base) - and then ((Is_Itype (Old_Formal_Base) - and then (Can_Never_Be_Null (Old_Formal_Base) - or else Is_Access_Constant - (Old_Formal_Base))) - or else - (Is_Itype (New_Formal_Base) - and then (Can_Never_Be_Null (New_Formal_Base) - or else Is_Access_Constant - (New_Formal_Base)))); - -- Types must always match. In the visible part of an instance, -- usual overloading rules for dispatching operations apply, and -- we check base types (not the actual subtypes). @@ -5737,7 +5951,6 @@ package body Sem_Ch6 is T2 => Base_Type (Etype (New_Formal)), Ctype => Ctype, Get_Inst => Get_Inst) - and then not Access_Types_Match then Conformance_Error ("\type of & does not match!", New_Formal); return; @@ -5748,7 +5961,6 @@ package body Sem_Ch6 is T2 => New_Formal_Base, Ctype => Ctype, Get_Inst => Get_Inst) - and then not Access_Types_Match then -- Don't give error message if old type is Any_Type. This test -- avoids some cascaded errors, e.g. in case of a bad spec. @@ -5780,7 +5992,7 @@ package body Sem_Ch6 is if Ctype >= Mode_Conformant then if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then - if not Ekind_In (New_Id, E_Function, E_Procedure) + if Ekind (New_Id) not in E_Function | E_Procedure or else not Is_Primitive_Wrapper (New_Id) then Conformance_Error ("\mode of & does not match!", New_Formal); @@ -5791,7 +6003,11 @@ package body Sem_Ch6 is begin if Is_Protected_Type (Corresponding_Concurrent_Type (T)) then - Error_Msg_PT (New_Id, Ultimate_Alias (Old_Id)); + Conforms := False; + + if Errmsg then + Error_Msg_PT (New_Id, Ultimate_Alias (Old_Id)); + end if; else Conformance_Error ("\mode of & does not match!", New_Formal); @@ -5801,10 +6017,8 @@ package body Sem_Ch6 is return; - -- Part of mode conformance for access types is having the same - -- constant modifier. - - elsif Access_Types_Match + elsif Is_Access_Type (Old_Formal_Base) + and then Is_Access_Type (New_Formal_Base) and then Is_Access_Constant (Old_Formal_Base) /= Is_Access_Constant (New_Formal_Base) then @@ -5826,8 +6040,8 @@ package body Sem_Ch6 is -- (access formals in the bodies aren't marked Can_Never_Be_Null). if Ada_Version >= Ada_2005 - and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type - and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type + and then Is_Anonymous_Access_Type (Etype (Old_Formal)) + and then Is_Anonymous_Access_Type (Etype (New_Formal)) and then ((Can_Never_Be_Null (Etype (Old_Formal)) /= Can_Never_Be_Null (Etype (New_Formal)) @@ -6345,6 +6559,56 @@ package body Sem_Ch6 is end if; end Check_Discriminant_Conformance; + ----------------------------------------- + -- Check_Formal_Subprogram_Conformance -- + ----------------------------------------- + + procedure Check_Formal_Subprogram_Conformance + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id; + Errmsg : Boolean; + Conforms : out Boolean) + is + N : Node_Id; + begin + Conforms := True; + + if Is_Formal_Subprogram (Old_Id) + or else Is_Formal_Subprogram (New_Id) + or else (Is_Subprogram (New_Id) + and then Present (Alias (New_Id)) + and then Is_Formal_Subprogram (Alias (New_Id))) + then + if Present (Err_Loc) then + N := Err_Loc; + else + N := New_Id; + end if; + + Conforms := False; + + if Errmsg then + Error_Msg_Sloc := Sloc (Old_Id); + Error_Msg_N ("not subtype conformant with declaration#!", N); + Error_Msg_NE + ("\formal subprograms are not subtype conformant " + & "(RM 6.3.1 (17/3))", N, New_Id); + end if; + end if; + end Check_Formal_Subprogram_Conformance; + + procedure Check_Formal_Subprogram_Conformance + (New_Id : Entity_Id; + Old_Id : Entity_Id; + Err_Loc : Node_Id := Empty) + is + Ignore : Boolean; + begin + Check_Formal_Subprogram_Conformance + (New_Id, Old_Id, Err_Loc, True, Ignore); + end Check_Formal_Subprogram_Conformance; + ---------------------------- -- Check_Fully_Conformant -- ---------------------------- @@ -6497,11 +6761,11 @@ package body Sem_Ch6 is Decl := Unit_Declaration_Node (Subp); end if; - if Nkind_In (Decl, N_Subprogram_Body, - N_Subprogram_Body_Stub, - N_Subprogram_Declaration, - N_Abstract_Subprogram_Declaration, - N_Subprogram_Renaming_Declaration) + if Nkind (Decl) in N_Subprogram_Body + | N_Subprogram_Body_Stub + | N_Subprogram_Declaration + | N_Abstract_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration then Spec := Specification (Decl); @@ -6512,6 +6776,19 @@ package body Sem_Ch6 is return; end if; + -- An overriding indication is illegal on a subprogram declared + -- in a protected body, where there is no operation to override. + + if (Must_Override (Spec) or else Must_Not_Override (Spec)) + and then Is_List_Member (Decl) + and then Present (Parent (List_Containing (Decl))) + and then Nkind (Parent (List_Containing (Decl))) = N_Protected_Body + then + Error_Msg_N + ("illegal overriding indication in protected body", Decl); + return; + end if; + -- The overriding operation is type conformant with the overridden one, -- but the names of the formals are not required to match. If the names -- appear permuted in the overriding operation, this is a possible @@ -6584,9 +6861,9 @@ package body Sem_Ch6 is if Present (Overridden_Subp) and then (not Is_Hidden (Overridden_Subp) or else - (Nam_In (Chars (Overridden_Subp), Name_Initialize, - Name_Adjust, - Name_Finalize) + (Chars (Overridden_Subp) in Name_Initialize + | Name_Adjust + | Name_Finalize and then Present (Alias (Overridden_Subp)) and then (not Is_Hidden (Alias (Overridden_Subp)) or else In_Instance))) @@ -6888,12 +7165,10 @@ package body Sem_Ch6 is -- Don't count exception junk or else - (Nkind_In (Last_Stm, N_Goto_Statement, - N_Label, - N_Object_Declaration) + (Nkind (Last_Stm) in + N_Goto_Statement | N_Label | N_Object_Declaration and then Exception_Junk (Last_Stm)) - or else Nkind (Last_Stm) in N_Push_xxx_Label - or else Nkind (Last_Stm) in N_Pop_xxx_Label + or else Nkind (Last_Stm) in N_Push_xxx_Label | N_Pop_xxx_Label -- Inserted code, such as finalization calls, is irrelevant: we only -- need to check original source. @@ -7321,7 +7596,7 @@ package body Sem_Ch6 is function Is_Valid_Formal (F : Entity_Id) return Boolean is begin return - Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter) + Ekind (F) in E_In_Out_Parameter | E_Out_Parameter or else (Nkind (Parameter_Type (Parent (F))) = N_Access_Definition and then not Constant_Present (Parameter_Type (Parent (F)))); @@ -7398,10 +7673,10 @@ package body Sem_Ch6 is -- rest of the parameters. if not In_Scope then - Prim_Param := Next (Prim_Param); + Next (Prim_Param); end if; - Iface_Param := Next (Iface_Param); + Next (Iface_Param); while Present (Iface_Param) and then Present (Prim_Param) loop Iface_Id := Defining_Identifier (Iface_Param); Iface_Typ := Find_Parameter_Type (Iface_Param); @@ -7558,7 +7833,7 @@ package body Sem_Ch6 is -- Entries and procedures can override abstract or null interface -- procedures. - elsif Ekind_In (Def_Id, E_Entry, E_Procedure) + elsif Ekind (Def_Id) in E_Entry | E_Procedure and then Ekind (Subp) = E_Procedure and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), @@ -7578,7 +7853,7 @@ package body Sem_Ch6 is -- override, the first parameter of the overridden routine -- must be of mode "out", "in out", or access-to-variable. - if Ekind_In (Candidate, E_Entry, E_Procedure) + if Ekind (Candidate) in E_Entry | E_Procedure and then Is_Protected_Type (Typ) and then not Is_Valid_Formal (Formal) then @@ -7984,11 +8259,11 @@ package body Sem_Ch6 is -- or both could be access to protected subprograms. Are_Anonymous_Access_To_Subprogram_Types := - Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type) + Ekind (Type_1) in E_Anonymous_Access_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type and then - Ekind_In (Type_2, E_Anonymous_Access_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type); + Ekind (Type_2) in E_Anonymous_Access_Subprogram_Type + | E_Anonymous_Access_Protected_Subprogram_Type; -- Test anonymous access type case. For this case, static subtype -- matching is required for mode conformance (RM 6.3.1(15)). We check @@ -8401,6 +8676,9 @@ package body Sem_Ch6 is Add_Extra_Formal (E, RTE (RE_Master_Id), E, BIP_Formal_Suffix (BIP_Task_Master)); + + Set_Has_Master_Entity (E); + Discard := Add_Extra_Formal (E, RTE (RE_Activation_Chain_Access), @@ -8447,8 +8725,8 @@ package body Sem_Ch6 is -- to this are inherited operations from a parent type in which -- case the derived type acts as their parent. - if Nkind_In (Subp_Decl, N_Function_Specification, - N_Procedure_Specification) + if Nkind (Subp_Decl) in N_Function_Specification + | N_Procedure_Specification then Subp_Decl := Parent (Subp_Decl); end if; @@ -8662,7 +8940,7 @@ package body Sem_Ch6 is -- Warn unless genuine overloading. Do not emit warning on -- hiding predefined operators in Standard (these are either an - -- (artifact of our implicit declarations, or simple noise) but + -- artifact of our implicit declarations, or simple noise) but -- keep warning on a operator defined on a local subtype, because -- of the real danger that different operators may be applied in -- various parts of the program. @@ -8974,8 +9252,8 @@ package body Sem_Ch6 is -- conformant with it. That can occur in cases where an -- actual type causes unrelated homographs in the instance. - if Nkind_In (N, N_Subprogram_Body, - N_Subprogram_Renaming_Declaration) + if Nkind (N) in N_Subprogram_Body + | N_Subprogram_Renaming_Declaration and then Present (Homonym (E)) and then not Fully_Conformant (Designator, E) then @@ -9239,6 +9517,29 @@ package body Sem_Ch6 is end if; end FCO; + function User_Defined_Numeric_Literal_Mismatch return Boolean; + -- Usually literals with the same value like 12345 and 12_345 + -- or 123.0 and 123.00 conform, but not if they are + -- user-defined literals. + + ------------------------------------------- + -- User_Defined_Numeric_Literal_Mismatch -- + ------------------------------------------- + + function User_Defined_Numeric_Literal_Mismatch return Boolean is + E1_Is_User_Defined : constant Boolean := + Nkind (Given_E1) not in N_Integer_Literal | N_Real_Literal; + E2_Is_User_Defined : constant Boolean := + Nkind (Given_E2) not in N_Integer_Literal | N_Real_Literal; + + begin + pragma Assert (E1_Is_User_Defined = E2_Is_User_Defined); + + return E1_Is_User_Defined and then + not String_Equal (String_From_Numeric_Literal (E1), + String_From_Numeric_Literal (E2)); + end User_Defined_Numeric_Literal_Mismatch; + -- Local variables Result : Boolean; @@ -9500,7 +9801,8 @@ package body Sem_Ch6 is FCL (Expressions (E1), Expressions (E2)); when N_Integer_Literal => - return (Intval (E1) = Intval (E2)); + return (Intval (E1) = Intval (E2)) + and then not User_Defined_Numeric_Literal_Mismatch; when N_Null => return True; @@ -9586,7 +9888,8 @@ package body Sem_Ch6 is FCE (High_Bound (E1), High_Bound (E2)); when N_Real_Literal => - return (Realval (E1) = Realval (E2)); + return (Realval (E1) = Realval (E2)) + and then not User_Defined_Numeric_Literal_Mismatch; when N_Selected_Component => return @@ -10403,10 +10706,9 @@ package body Sem_Ch6 is H := Homonym (H); exit when not Present (H) or else Scope (H) /= Scope (S); - if Nkind_In - (Parent (H), - N_Private_Extension_Declaration, - N_Private_Type_Declaration) + if Nkind (Parent (H)) in + N_Private_Extension_Declaration | + N_Private_Type_Declaration and then Defining_Identifier (Parent (H)) = Partial_View then return True; @@ -10461,8 +10763,9 @@ package body Sem_Ch6 is ("\move subprogram to the visible part" & " (RM 3.9.3(10))", S); - -- AI05-0073: extend this test to the case of a - -- function with a controlling access result. + -- Ada 2012 (AI05-0073): Extend this check to the case + -- of a function whose result subtype is defined by an + -- access_definition designating specific tagged type. elsif Ekind (Etype (S)) = E_Anonymous_Access_Type and then Is_Tagged_Type (Designated_Type (Etype (S))) @@ -11217,6 +11520,18 @@ package body Sem_Ch6 is Inherit_Subprogram_Contract (E, S); end if; + -- When a dispatching operation overrides an inherited + -- subprogram, it shall be subtype conformant with the + -- inherited subprogram (RM 3.9.2 (10.2)). + + if Comes_From_Source (E) + and then Is_Dispatching_Operation (E) + and then Find_Dispatching_Type (S) + = Find_Dispatching_Type (E) + then + Check_Subtype_Conformant (E, S); + end if; + if Comes_From_Source (E) then Check_Overriding_Indicator (E, S, Is_Primitive => False); @@ -11531,14 +11846,6 @@ package body Sem_Ch6 is Check_Ghost_Overriding (S, Overridden_Subp); - -- Overloading is not allowed in SPARK, except for operators - - if Nkind (S) /= N_Defining_Operator_Symbol then - Error_Msg_Sloc := Sloc (Homonym (S)); - Check_SPARK_05_Restriction - ("overloading not allowed with entity#", S); - end if; - -- If S is a derived operation for an untagged type then by -- definition it's not a dispatching operation (even if the parent -- operation was dispatching), so Check_Dispatching_Operation is not @@ -11703,9 +12010,9 @@ package body Sem_Ch6 is and then not Is_Generic_Type (Formal_Type) and then not Is_Class_Wide_Type (Formal_Type) then - if not Nkind_In - (Parent (T), N_Access_Function_Definition, - N_Access_Procedure_Definition) + if Nkind (Parent (T)) not in + N_Access_Function_Definition | + N_Access_Procedure_Definition then Append_Elmt (Current_Scope, Private_Dependents (Base_Type (Formal_Type))); @@ -11722,8 +12029,8 @@ package body Sem_Ch6 is end if; end if; - elsif not Nkind_In (Parent (T), N_Access_Function_Definition, - N_Access_Procedure_Definition) + elsif Nkind (Parent (T)) not in N_Access_Function_Definition + | N_Access_Procedure_Definition then -- AI05-0151: Tagged incomplete types are allowed in all -- formal parts. Untagged incomplete types are not allowed @@ -11750,9 +12057,9 @@ package body Sem_Ch6 is then null; - elsif Nkind_In (Context, N_Accept_Statement, - N_Accept_Alternative, - N_Entry_Body) + elsif Nkind (Context) in N_Accept_Statement + | N_Accept_Alternative + | N_Entry_Body or else (Nkind (Context) = N_Subprogram_Body and then Comes_From_Source (Context)) then @@ -11870,9 +12177,6 @@ package body Sem_Ch6 is Default := Expression (Param_Spec); if Present (Default) then - Check_SPARK_05_Restriction - ("default expression is not allowed", Default); - if Out_Present (Param_Spec) then Error_Msg_N ("default initialization only allowed for IN parameters", @@ -11933,12 +12237,12 @@ package body Sem_Ch6 is -- these are not standard Ada legality rules. if SPARK_Mode = On then - if Ekind_In (Scope (Formal), E_Function, E_Generic_Function) then + if Ekind (Scope (Formal)) in E_Function | E_Generic_Function then -- A function cannot have a parameter of mode IN OUT or OUT -- (SPARK RM 6.1). - if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then + if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then Error_Msg_N ("function cannot have parameter of mode `OUT` or " & "`IN OUT`", Formal); @@ -11946,7 +12250,7 @@ package body Sem_Ch6 is -- A procedure cannot have an effectively volatile formal -- parameter of mode IN because it behaves as a constant - -- (SPARK RM 7.1.3(6)). -- ??? maybe 7.1.3(4) + -- (SPARK RM 7.1.3(4)). elsif Ekind (Scope (Formal)) = E_Procedure and then Ekind (Formal) = E_In_Parameter @@ -12255,13 +12559,13 @@ package body Sem_Ch6 is -- point of the call. if Out_Present (Spec) then - if Ekind_In (Id, E_Entry, E_Entry_Family) + if Is_Entry (Id) or else Is_Subprogram_Or_Generic_Subprogram (Id) then Set_Has_Out_Or_In_Out_Parameter (Id, True); end if; - if Ekind_In (Id, E_Function, E_Generic_Function) then + if Ekind (Id) in E_Function | E_Generic_Function then -- [IN] OUT parameters allowed for functions in Ada 2012 @@ -12443,12 +12747,12 @@ package body Sem_Ch6 is -- Verify that user-defined operators have proper number of arguments -- First case of operators which can only be unary - if Nam_In (Id, Name_Op_Not, Name_Op_Abs) then + if Id in Name_Op_Not | Name_Op_Abs then N_OK := (N = 1); -- Case of operators which can be unary or binary - elsif Nam_In (Id, Name_Op_Add, Name_Op_Subtract) then + elsif Id in Name_Op_Add | Name_Op_Subtract then N_OK := (N in 1 .. 2); -- All other operators can only be binary |