X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch6.adb;h=90e81f98b9a58236443330f1d958c2c85c693f3d;hp=79d45c974d7c99543af55ff72cf4ee75b547a6fa;hb=7717ea00902734bd90371e34af23d0b73287f875;hpb=449a120bd17a77cf35e15443328424bfbbb28197 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 79d45c974d7..90e81f98b9a 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -47,8 +47,11 @@ with Nlists; use Nlists; 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; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; @@ -95,7 +98,7 @@ package body Sem_Ch6 is ----------------------- procedure Analyze_Return_Statement (N : Node_Id); - -- Common processing for simple_ and extended_return_statements + -- Common processing for simple and extended return statements procedure Analyze_Function_Return (N : Node_Id); -- Subsidiary to Analyze_Return_Statement. Called when the return statement @@ -103,9 +106,13 @@ package body Sem_Ch6 is procedure Analyze_Return_Type (N : Node_Id); -- Subsidiary to Process_Formals: analyze subtype mark in function - -- specification, in a context where the formals are visible and hide + -- specification in a context where the formals are visible and hide -- outer homographs. + procedure Analyze_Subprogram_Body_Helper (N : Node_Id); + -- Does all the real work of Analyze_Subprogram_Body. This is split out so + -- that we can use RETURN but not skip the debug output at the end. + procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); -- Analyze a generic subprogram body. N is the body to be analyzed, and -- Gen_Id is the defining entity Id for the corresponding spec. @@ -159,6 +166,13 @@ package body Sem_Ch6 is -- True otherwise. Proc is the entity for the procedure case and is used -- in posting the warning message. + procedure Check_Untagged_Equality (Eq_Op : Entity_Id); + -- In Ada 2012, a primitive equality operator on an untagged record type + -- must appear before the type is frozen, and have the same visibility as + -- that of the type. This procedure checks that this rule is met, and + -- otherwise emits an error on the subprogram declaration and a warning + -- on the earlier freeze point if it is easy to locate. + procedure Enter_Overloaded_Entity (S : Entity_Id); -- This procedure makes S, a new overloaded entity, into the first visible -- entity with that name. @@ -187,16 +201,16 @@ package body Sem_Ch6 is (N : Node_Id; Spec_Id : Entity_Id; Body_Id : Entity_Id); - -- Called from Analyze_Body to deal with scanning post conditions for the - -- body and assembling and inserting the _postconditions procedure. N is - -- the node for the subprogram body and Body_Id/Spec_Id are the entities - -- for the body and separate spec (if there is no separate spec, Spec_Id - -- is Empty). + -- Called from Analyze[_Generic]_Subprogram_Body to deal with scanning post + -- conditions for the body and assembling and inserting the _postconditions + -- procedure. N is the node for the subprogram body and Body_Id/Spec_Id are + -- the entities for the body and separate spec (if there is no separate + -- spec, Spec_Id is Empty). procedure Set_Formal_Validity (Formal_Id : Entity_Id); -- Formal_Id is an formal parameter entity. This procedure deals with - -- setting the proper validity status for this entity, which depends - -- on the kind of parameter and the validity checking mode. + -- setting the proper validity status for this entity, which depends on + -- the kind of parameter and the validity checking mode. ------------------------------ -- Analyze_Return_Statement -- @@ -269,9 +283,10 @@ package body Sem_Ch6 is Push_Scope (Stm_Entity); end if; - -- Check that pragma No_Return is obeyed + -- 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) then + if No_Return (Scope_Id) and then Comes_From_Source (N) then Error_Msg_N ("RETURN statement not allowed (No_Return)", N); end if; @@ -365,6 +380,7 @@ package body Sem_Ch6 is end if; Generate_Reference_To_Formals (Designator); + Check_Eliminated (Designator); end Analyze_Abstract_Subprogram_Declaration; ---------------------------------------- @@ -456,7 +472,7 @@ package body Sem_Ch6 is if Is_Limited_Type (R_Type) and then Comes_From_Source (N) and then not In_Instance_Body - and then not OK_For_Limited_Init_In_05 (Expr) + and then not OK_For_Limited_Init_In_05 (R_Type, Expr) then -- Error in Ada 2005 @@ -506,10 +522,10 @@ package body Sem_Ch6 is ------------------------------------- procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is - Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); - R_Stm_Type : constant Entity_Id := Etype (Return_Obj); - -- Subtype given in the extended return statement; - -- this must match R_Type. + Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); + + R_Stm_Type : constant Entity_Id := Etype (Return_Obj); + -- Subtype given in the extended return statement (must match R_Type) Subtype_Ind : constant Node_Id := Object_Definition (Original_Node (Obj_Decl)); @@ -534,7 +550,7 @@ package body Sem_Ch6 is -- True if type of the return object is an anonymous access type begin - -- First, avoid cascade errors: + -- First, avoid cascaded errors if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then return; @@ -575,12 +591,24 @@ package body Sem_Ch6 is Error_Msg_N ("must use anonymous access type", Subtype_Ind); end if; - -- Subtype_indication case; check that the types are the same, and - -- statically match if appropriate. A null exclusion may be present - -- on the return type, on the function specification, on the object - -- declaration or on the subtype itself. + -- Subtype indication case: check that the return object's type is + -- covered by the result type, and that the subtypes statically match + -- when the result subtype is constrained. Also handle record types + -- with unknown discriminants for which we have built the underlying + -- record view. Coverage is needed to allow specific-type return + -- objects when the result type is class-wide (see AI05-32). + + elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type)) + or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type)) + and then + Covers + (Base_Type (R_Type), + Underlying_Record_View (Base_Type (R_Stm_Type)))) + then + -- A null exclusion may be present on the return type, on the + -- function specification, on the object declaration or on the + -- subtype itself. - elsif Base_Type (R_Stm_Type) = Base_Type (R_Type) then if Is_Access_Type (R_Type) and then (Can_Never_Be_Null (R_Type) @@ -592,7 +620,11 @@ package body Sem_Ch6 is Subtype_Ind); end if; - if Is_Constrained (R_Type) then + -- AI05-103: for elementary types, subtypes must statically match + + if Is_Constrained (R_Type) + or else Is_Access_Type (R_Type) + then if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then Error_Msg_N ("subtype must statically match function result subtype", @@ -600,28 +632,8 @@ package body Sem_Ch6 is end if; end if; - -- If the function's result type doesn't match the return object - -- entity's type, then we check for the case where the result type - -- is class-wide, and allow the declaration if the type of the object - -- definition matches the class-wide type. This prevents rejection - -- in the case where the object declaration is initialized by a call - -- to a build-in-place function with a specific result type and the - -- object entity had its type changed to that specific type. This is - -- also allowed in the case where Obj_Decl does not come from source, - -- which can occur for an expansion of a simple return statement of - -- a build-in-place class-wide function when the result expression - -- has a specific type, because a return object with a specific type - -- is created. (Note that the ARG believes that return objects should - -- be allowed to have a type covered by a class-wide result type in - -- any case, so once that relaxation is made (see AI05-32), the above - -- check for type compatibility should be changed to test Covers - -- rather than equality, and the following special test will no - -- longer be needed. ???) - - elsif Is_Class_Wide_Type (R_Type) - and then - (R_Type = Etype (Object_Definition (Original_Node (Obj_Decl))) - or else not Comes_From_Source (Obj_Decl)) + elsif Etype (Base_Type (R_Type)) = R_Stm_Type + and then Is_Null_Extension (Base_Type (R_Type)) then null; @@ -681,6 +693,11 @@ package body Sem_Ch6 is end if; end if; + -- Mark the return object as referenced, since the return is an + -- implicit reference of the object. + + Set_Referenced (Defining_Identifier (Obj_Decl)); + Check_References (Stm_Entity); end; end if; @@ -728,12 +745,13 @@ package body Sem_Ch6 is end if; end if; - if (Is_Class_Wide_Type (Etype (Expr)) - or else Is_Dynamically_Tagged (Expr)) - and then not Is_Class_Wide_Type (R_Type) - then - Error_Msg_N - ("dynamically tagged expression not allowed!", Expr); + -- Check incorrect use of dynamically tagged expression + + if Is_Tagged_Type (R_Type) then + Check_Dynamically_Tagged_Expression + (Expr => Expr, + Typ => R_Type, + Related_Nod => N); end if; -- ??? A real run-time accessibility check is needed in cases @@ -767,6 +785,11 @@ package body Sem_Ch6 is & "null-excluding return?", Reason => CE_Null_Not_Allowed); end if; + + -- Apply checks suggested by AI05-0144 (dangerous order dependence) + -- (Disabled for now) + + -- Check_Order_Dependence; end if; end Analyze_Function_Return; @@ -972,6 +995,7 @@ package body Sem_Ch6 is if Style_Check then Style.Check_Identifier (Body_Id, Gen_Id); end if; + End_Generic; end Analyze_Generic_Subprogram_Body; @@ -1018,6 +1042,31 @@ package body Sem_Ch6 is Analyze (Explicit_Actual_Parameter (N)); end Analyze_Parameter_Association; + -------------------------------------- + -- Analyze_Parameterized_Expression -- + -------------------------------------- + + procedure Analyze_Parameterized_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + LocX : constant Source_Ptr := Sloc (Expression (N)); + + begin + -- This is one of the occasions on which we write things during semantic + -- analysis. Transform the parameterized expression into an equivalent + -- subprogram body, and then analyze that. + + Rewrite (N, + Make_Subprogram_Body (Loc, + Specification => Specification (N), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (LocX, + Statements => New_List ( + Make_Simple_Return_Statement (LocX, + Expression => Expression (N)))))); + Analyze (N); + end Analyze_Parameterized_Expression; + ---------------------------- -- Analyze_Procedure_Call -- ---------------------------- @@ -1031,6 +1080,7 @@ package body Sem_Ch6 is procedure Analyze_Call_And_Resolve; -- Do Analyze and Resolve calls for procedure call + -- At end, check illegal order dependence. ------------------------------ -- Analyze_Call_And_Resolve -- @@ -1041,6 +1091,11 @@ package body Sem_Ch6 is if Nkind (N) = N_Procedure_Call_Statement then Analyze_Call (N); Resolve (N, Standard_Void_Type); + + -- Apply checks suggested by AI05-0144 (Disabled for now) + + -- Check_Order_Dependence; + else Analyze (N); end if; @@ -1068,9 +1123,13 @@ package body Sem_Ch6 is return; end if; - -- If error analyzing prefix, then set Any_Type as result and return + -- If there is an error analyzing the name (which may have been + -- rewritten if the original call was in prefix notation) then error + -- has been emitted already, mark node and return. - if Etype (P) = Any_Type then + if Error_Posted (N) + or else Etype (Name (N)) = Any_Type + then Set_Etype (N, Any_Type); return; end if; @@ -1280,6 +1339,10 @@ package body Sem_Ch6 is Set_Is_Local_Anonymous_Access (Typ); Set_Etype (Designator, Typ); + -- Ada 2005 (AI-231): Ensure proper usage of null exclusion + + Null_Exclusion_Static_Checks (N); + -- Subtype_Mark case else @@ -1287,6 +1350,58 @@ package body Sem_Ch6 is Typ := Entity (Result_Definition (N)); Set_Etype (Designator, Typ); + -- Ada 2005 (AI-231): Ensure proper usage of null exclusion + + Null_Exclusion_Static_Checks (N); + + -- If a null exclusion is imposed on the result type, then create + -- a null-excluding itype (an access subtype) and use it as the + -- function's Etype. Note that the null exclusion checks are done + -- right before this, because they don't get applied to types that + -- do not come from source. + + if Is_Access_Type (Typ) + and then Null_Exclusion_Present (N) + then + Set_Etype (Designator, + Create_Null_Excluding_Itype + (T => Typ, + Related_Nod => N, + Scope_Id => Scope (Current_Scope))); + + -- The new subtype must be elaborated before use because + -- it is visible outside of the function. However its base + -- type may not be frozen yet, so the reference that will + -- force elaboration must be attached to the freezing of + -- the base type. + + -- If the return specification appears on a proper body, + -- the subtype will have been created already on the spec. + + if Is_Frozen (Typ) then + if Nkind (Parent (N)) = N_Subprogram_Body + and then Nkind (Parent (Parent (N))) = N_Subunit + then + null; + else + Build_Itype_Reference (Etype (Designator), Parent (N)); + end if; + + else + Ensure_Freeze_Node (Typ); + + declare + IR : constant Node_Id := Make_Itype_Reference (Sloc (N)); + begin + Set_Itype (IR, Etype (Designator)); + Append_Freeze_Actions (Typ, New_List (IR)); + end; + end if; + + else + Set_Etype (Designator, Typ); + end if; + if Ekind (Typ) = E_Incomplete_Type and then Is_Value_Type (Typ) then @@ -1297,15 +1412,11 @@ package body Sem_Ch6 is and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) then - Error_Msg_N - ("invalid use of incomplete type", Result_Definition (N)); + Error_Msg_NE + ("invalid use of incomplete type&", Designator, Typ); end if; end if; - -- Ada 2005 (AI-231): Ensure proper usage of null exclusion - - Null_Exclusion_Static_Checks (N); - -- Case where result definition does indicate an error else @@ -1317,12 +1428,48 @@ package body Sem_Ch6 is -- Analyze_Subprogram_Body -- ----------------------------- + procedure Analyze_Subprogram_Body (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Body_Spec : constant Node_Id := Specification (N); + Body_Id : constant Entity_Id := Defining_Entity (Body_Spec); + + begin + if Debug_Flag_C then + Write_Str ("==> subprogram body "); + Write_Name (Chars (Body_Id)); + Write_Str (" from "); + Write_Location (Loc); + Write_Eol; + Indent; + end if; + + Trace_Scope (N, Body_Id, " Analyze subprogram: "); + + -- The real work is split out into the helper, so it can do "return;" + -- without skipping the debug output: + + Analyze_Subprogram_Body_Helper (N); + + if Debug_Flag_C then + Outdent; + Write_Str ("<== subprogram body "); + Write_Name (Chars (Body_Id)); + Write_Str (" from "); + Write_Location (Loc); + Write_Eol; + end if; + end Analyze_Subprogram_Body; + + ------------------------------------ + -- Analyze_Subprogram_Body_Helper -- + ------------------------------------ + -- This procedure is called for regular subprogram bodies, generic bodies, -- and for subprogram stubs of both kinds. In the case of stubs, only the -- specification matters, and is used to create a proper declaration for -- the subprogram, or to perform conformance checks. - procedure Analyze_Subprogram_Body (N : Node_Id) is + procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Body_Deleted : constant Boolean := False; Body_Spec : constant Node_Id := Specification (N); @@ -1330,7 +1477,6 @@ package body Sem_Ch6 is Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); Conformant : Boolean; HSS : Node_Id; - Missing_Ret : Boolean; P_Ent : Entity_Id; Prot_Typ : Entity_Id := Empty; Spec_Id : Entity_Id; @@ -1357,7 +1503,7 @@ package body Sem_Ch6 is -- the case where there is no separate spec. procedure Check_Anonymous_Return; - -- (Ada 2005): if a function returns an access type that denotes a task, + -- Ada 2005: if a function returns an access type that denotes a task, -- or a type that contains tasks, we must create a master entity for -- the anonymous type, which typically will be used in an allocator -- in the body of the function. @@ -1372,6 +1518,10 @@ package body Sem_Ch6 is -- If pragma does not appear after the body, check whether there is -- an inline pragma before any local declarations. + procedure Check_Missing_Return; + -- Checks for a function with a no return statements, and also performs + -- the warning checks implemented by Check_Returns. + function Disambiguate_Spec return Entity_Id; -- When a primitive is declared between the private view and the full -- view of a concurrent type which implements an interface, a special @@ -1402,6 +1552,7 @@ package body Sem_Ch6 is procedure Check_Anonymous_Return is Decl : Node_Id; + Par : Node_Id; Scop : Entity_Id; begin @@ -1413,8 +1564,18 @@ package body Sem_Ch6 is if Ekind (Scop) = E_Function and then Ekind (Etype (Scop)) = E_Anonymous_Access_Type - and then Has_Task (Designated_Type (Etype (Scop))) + and then not Is_Thunk (Scop) + and then (Has_Task (Designated_Type (Etype (Scop))) + or else + (Is_Class_Wide_Type (Designated_Type (Etype (Scop))) + 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, @@ -1435,6 +1596,25 @@ package body Sem_Ch6 is Set_Master_Id (Etype (Scop), Defining_Identifier (Decl)); Set_Has_Master_Entity (Scop); + + -- Now mark the containing scope as a task master + + Par := N; + while Nkind (Par) /= N_Compilation_Unit loop + Par := Parent (Par); + pragma Assert (Present (Par)); + + -- If we fall off the top, we are at the outer level, and + -- the environment task is our effective master, so nothing + -- to mark. + + if Nkind_In + (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body) + then + Set_Is_Task_Master (Par, True); + exit; + end if; + end loop; end if; end Check_Anonymous_Return; @@ -1494,9 +1674,7 @@ package body Sem_Ch6 is if Present (Prag) then if Present (Spec_Id) then - if List_Containing (N) = - List_Containing (Unit_Declaration_Node (Spec_Id)) - then + if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then Analyze (Prag); end if; @@ -1505,10 +1683,12 @@ package body Sem_Ch6 is declare Subp : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars (Body_Id)); + Make_Defining_Identifier (Loc, Chars (Body_Id)); Decl : constant Node_Id := - Make_Subprogram_Declaration (Loc, - Specification => New_Copy_Tree (Specification (N))); + Make_Subprogram_Declaration (Loc, + Specification => + New_Copy_Tree (Specification (N))); + begin Set_Defining_Unit_Name (Specification (Decl), Subp); @@ -1534,6 +1714,46 @@ package body Sem_Ch6 is end if; end Check_Inline_Pragma; + -------------------------- + -- Check_Missing_Return -- + -------------------------- + + procedure Check_Missing_Return is + Id : Entity_Id; + Missing_Ret : Boolean; + + begin + if Nkind (Body_Spec) = N_Function_Specification then + if Present (Spec_Id) then + Id := Spec_Id; + else + Id := Body_Id; + end if; + + if Return_Present (Id) then + Check_Returns (HSS, 'F', Missing_Ret); + + if Missing_Ret then + Set_Has_Missing_Return (Id); + end if; + + elsif (Is_Generic_Subprogram (Id) + or else not Is_Machine_Code_Subprogram (Id)) + and then not Body_Deleted + then + Error_Msg_N ("missing RETURN statement in function body", N); + end if; + + -- If procedure with No_Return, check returns + + elsif Nkind (Body_Spec) = N_Procedure_Specification + and then Present (Spec_Id) + and then No_Return (Spec_Id) + then + Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); + end if; + end Check_Missing_Return; + ----------------------- -- Disambiguate_Spec -- ----------------------- @@ -1716,16 +1936,19 @@ package body Sem_Ch6 is ("subprogram & overrides predefined operator ", Body_Spec, Spec_Id); - -- If this is not a primitive operation the overriding indicator - -- is altogether illegal. + -- If this is not a primitive operation or protected subprogram, + -- then the overriding indicator is altogether illegal. - elsif not Is_Primitive (Spec_Id) then - Error_Msg_N ("overriding indicator only allowed " & - "if subprogram is primitive", - Body_Spec); + elsif not Is_Primitive (Spec_Id) + and then Ekind (Scope (Spec_Id)) /= E_Protected_Type + then + Error_Msg_N + ("overriding indicator only allowed " & + "if subprogram is primitive", + Body_Spec); end if; - elsif Style_Check + elsif Style_Check -- ??? incorrect use of Style_Check! and then Is_Overriding_Operation (Spec_Id) then pragma Assert (Unit_Declaration_Node (Body_Id) = N); @@ -1733,19 +1956,9 @@ package body Sem_Ch6 is end if; end Verify_Overriding_Indicator; - -- Start of processing for Analyze_Subprogram_Body + -- Start of processing for Analyze_Subprogram_Body_Helper begin - if Debug_Flag_C then - Write_Str ("==== Compiling subprogram body "); - Write_Name (Chars (Body_Id)); - Write_Str (" from "); - Write_Location (Loc); - Write_Eol; - end if; - - Trace_Scope (N, Body_Id, " Analyze subprogram: "); - -- Generic subprograms are handled separately. They always have a -- generic specification. Determine whether current scope has a -- previous declaration. @@ -1765,6 +1978,12 @@ package body Sem_Ch6 is Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); Analyze_Generic_Subprogram_Body (N, Spec_Id); + + if Nkind (N) = N_Subprogram_Body then + HSS := Handled_Statement_Sequence (N); + Check_Missing_Return; + end if; + return; else @@ -1868,71 +2087,22 @@ package body Sem_Ch6 is Check_Inline_Pragma (Spec_Id); - -- Case of 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. + -- 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. if No (Spec_Id) and then Comes_From_Source (N) and then Is_Protected_Type (Current_Scope) then - declare - Decl : Node_Id; - Plist : List_Id; - Formal : Entity_Id; - New_Spec : Node_Id; - - 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 - Plist := Copy_Parameter_List (Body_Id); - else - Plist := No_List; - end if; + Spec_Id := Build_Private_Protected_Declaration (N); + end if; - if Nkind (Body_Spec) = N_Procedure_Specification then - New_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)), - Parameter_Specifications => Plist); - else - New_Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)), - Parameter_Specifications => Plist, - Result_Definition => - New_Occurrence_Of (Etype (Body_Id), Loc)); - end if; + -- If a separate spec is present, then deal with freezing issues - Decl := - Make_Subprogram_Declaration (Loc, - Specification => New_Spec); - Insert_Before (N, Decl); - Spec_Id := Defining_Unit_Name (New_Spec); - - -- 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); - Analyze (Decl); - Set_Has_Completion (Spec_Id); - Set_Convention (Spec_Id, Convention_Protected); - end; - - elsif Present (Spec_Id) then + if Present (Spec_Id) then Spec_Decl := Unit_Declaration_Node (Spec_Id); Verify_Overriding_Indicator; @@ -1959,8 +2129,13 @@ package body Sem_Ch6 is end if; end if; + -- Mark presence of postcondition procedure in current scope and mark + -- the procedure itself as needing debug info. The latter is important + -- when analyzing decision coverage (for example, for MC/DC coverage). + if Chars (Body_Id) = Name_uPostconditions then Set_Has_Postconditions (Current_Scope); + Set_Debug_Info_Needed (Body_Id); end if; -- Place subprogram on scope stack, and make formals visible. If there @@ -2010,6 +2185,15 @@ package body Sem_Ch6 is then Conformant := True; + -- Conversely, the spec may have been generated for specless body + -- with an inline pragma. + + elsif Comes_From_Source (N) + and then not Comes_From_Source (Spec_Id) + and then Has_Pragma_Inline (Spec_Id) + then + Conformant := True; + else Check_Conformance (Body_Id, Spec_Id, @@ -2338,41 +2522,7 @@ package body Sem_Ch6 is end if; end if; - -- If function, check return statements - - if Nkind (Body_Spec) = N_Function_Specification then - declare - Id : Entity_Id; - - begin - if Present (Spec_Id) then - Id := Spec_Id; - else - Id := Body_Id; - end if; - - if Return_Present (Id) then - Check_Returns (HSS, 'F', Missing_Ret); - - if Missing_Ret then - Set_Has_Missing_Return (Id); - end if; - - elsif not Is_Machine_Code_Subprogram (Id) - and then not Body_Deleted - then - Error_Msg_N ("missing RETURN statement in function body", N); - end if; - end; - - -- If procedure with No_Return, check returns - - elsif Nkind (Body_Spec) = N_Procedure_Specification - and then Present (Spec_Id) - and then No_Return (Spec_Id) - then - Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); - end if; + Check_Missing_Return; -- Now we are going to check for variables that are never modified in -- the body of the procedure. But first we deal with a special case @@ -2499,55 +2649,110 @@ package body Sem_Ch6 is Check_References (Body_Id); end if; end; - end Analyze_Subprogram_Body; + end Analyze_Subprogram_Body_Helper; ------------------------------------ -- Analyze_Subprogram_Declaration -- ------------------------------------ procedure Analyze_Subprogram_Declaration (N : Node_Id) is - Designator : constant Entity_Id := - Analyze_Subprogram_Specification (Specification (N)); + Loc : constant Source_Ptr := Sloc (N); + Designator : Entity_Id; + Form : Node_Id; Scop : constant Entity_Id := Current_Scope; + Null_Body : Node_Id := Empty; -- Start of processing for Analyze_Subprogram_Declaration begin - Generate_Definition (Designator); + -- For a null procedure, capture the profile before analysis, for + -- expansion at the freeze point and at each point of call. + -- The body will only be used if the procedure has preconditions. + -- In that case the body is analyzed at the freeze point. + + if Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + and then Expander_Active + then + Null_Body := + Make_Subprogram_Body (Loc, + Specification => + New_Copy_Tree (Specification (N)), + Declarations => + New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Make_Null_Statement (Loc)))); - -- Check for RCI unit subprogram declarations for illegal inlined - -- subprograms and subprograms having access parameter or limited - -- parameter without Read and Write attributes (RM E.2.3(12-13)). + -- Create new entities for body and formals - Validate_RCI_Subprogram_Declaration (N); + Set_Defining_Unit_Name (Specification (Null_Body), + Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); + Set_Corresponding_Body (N, Defining_Entity (Null_Body)); + + Form := First (Parameter_Specifications (Specification (Null_Body))); + while Present (Form) loop + Set_Defining_Identifier (Form, + Make_Defining_Identifier (Loc, + Chars (Defining_Identifier (Form)))); + Next (Form); + end loop; - Trace_Scope - (N, - Defining_Entity (N), - " Analyze subprogram spec: "); + if Is_Protected_Type (Current_Scope) then + Error_Msg_N ("protected operation cannot be a null procedure", N); + end if; + end if; + + Designator := Analyze_Subprogram_Specification (Specification (N)); + Generate_Definition (Designator); if Debug_Flag_C then - Write_Str ("==== Compiling subprogram spec "); + Write_Str ("==> subprogram spec "); Write_Name (Chars (Designator)); Write_Str (" from "); Write_Location (Sloc (N)); Write_Eol; + Indent; end if; + if Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) + then + Set_Has_Completion (Designator); + + if Present (Null_Body) then + Set_Corresponding_Body (N, Defining_Entity (Null_Body)); + Set_Body_To_Inline (N, Null_Body); + Set_Is_Inlined (Designator); + end if; + end if; + + Validate_RCI_Subprogram_Declaration (N); New_Overloaded_Entity (Designator); Check_Delayed_Subprogram (Designator); - -- If the type of the first formal of the current subprogram is a non - -- generic tagged private type , mark the subprogram as being a private - -- primitive. + -- If the type of the first formal of the current subprogram is a + -- nongeneric tagged private type, mark the subprogram as being a + -- private primitive. Ditto if this is a function with controlling + -- result, and the return type is currently private. In both cases, + -- the type of the controlling argument or result must be in the + -- current scope for the operation to be primitive. + + if Has_Controlling_Result (Designator) + and then Is_Private_Type (Etype (Designator)) + and then Scope (Etype (Designator)) = Current_Scope + and then not Is_Generic_Actual_Type (Etype (Designator)) + then + Set_Is_Private_Primitive (Designator); - if Present (First_Formal (Designator)) then + elsif Present (First_Formal (Designator)) then declare Formal_Typ : constant Entity_Id := Etype (First_Formal (Designator)); begin Set_Is_Private_Primitive (Designator, Is_Tagged_Type (Formal_Typ) + and then Scope (Formal_Typ) = Current_Scope and then Is_Private_Type (Formal_Typ) and then not Is_Generic_Actual_Type (Formal_Typ)); end; @@ -2639,19 +2844,13 @@ package body Sem_Ch6 is Generate_Reference_To_Formals (Designator); Check_Eliminated (Designator); - -- Ada 2005: if procedure is declared with "is null" qualifier, - -- it requires no body. - - if Nkind (Specification (N)) = N_Procedure_Specification - and then Null_Present (Specification (N)) - then - Set_Has_Completion (Designator); - Set_Is_Inlined (Designator); - - if Is_Protected_Type (Current_Scope) then - Error_Msg_N - ("protected operation cannot be a null procedure", N); - end if; + if Debug_Flag_C then + Outdent; + Write_Str ("<== subprogram spec "); + Write_Name (Chars (Designator)); + Write_Str (" from "); + Write_Location (Sloc (N)); + Write_Eol; end if; end Analyze_Subprogram_Declaration; @@ -2693,12 +2892,15 @@ package body Sem_Ch6 is -- inherited interface operation, and the controlling type is -- a synchronized type, replace the type with its corresponding -- record, to match the proper signature of an overriding operation. + -- Same processing for an access parameter whose designated type is + -- derived from a synchronized interface. if Ada_Version >= Ada_05 then declare Formal : Entity_Id; Formal_Typ : Entity_Id; Rec_Typ : Entity_Id; + Desig_Typ : Entity_Id; begin Formal := First_Formal (Designator); @@ -2713,6 +2915,19 @@ package body Sem_Ch6 is if Present (Interfaces (Rec_Typ)) then Set_Etype (Formal, Rec_Typ); end if; + + elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then + Desig_Typ := Designated_Type (Formal_Typ); + + if Is_Concurrent_Type (Desig_Typ) + and then Present (Corresponding_Record_Type (Desig_Typ)) + then + Rec_Typ := Corresponding_Record_Type (Desig_Typ); + + if Present (Interfaces (Rec_Typ)) then + Set_Directly_Designated_Type (Formal_Typ, Rec_Typ); + end if; + end if; end if; Next_Formal (Formal); @@ -2722,8 +2937,18 @@ package body Sem_Ch6 is End_Scope; + -- The subprogram scope is pushed and popped around the processing of + -- the return type for consistency with call above to Process_Formals + -- (which itself can call Analyze_Return_Type), and to ensure that any + -- itype created for the return type will be associated with the proper + -- scope. + elsif Nkind (N) = N_Function_Specification then + Push_Scope (Designator); + Analyze_Return_Type (N); + + End_Scope; end if; if Nkind (N) = N_Function_Specification then @@ -2736,19 +2961,32 @@ package body Sem_Ch6 is -- Ada 2005 (AI-251): If the return type is abstract, verify that -- the subprogram is abstract also. This does not apply to renaming -- declarations, where abstractness is inherited. + -- In case of primitives associated with abstract interface types -- the check is applied later (see Analyze_Subprogram_Declaration). - if Is_Abstract_Type (Etype (Designator)) - and then not Is_Interface (Etype (Designator)) - and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration - and then Nkind (Parent (N)) /= - N_Abstract_Subprogram_Declaration - and then - (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration + if not Nkind_In (Parent (N), N_Subprogram_Renaming_Declaration, + N_Abstract_Subprogram_Declaration, + N_Formal_Abstract_Subprogram_Declaration) then - Error_Msg_N - ("function that returns abstract type must be abstract", N); + if Is_Abstract_Type (Etype (Designator)) + and then not Is_Interface (Etype (Designator)) + then + Error_Msg_N + ("function that returns abstract type must be abstract", N); + + -- Ada 2012 (AI-0073): extend this test to subprograms with an + -- access result whose designated type is abstract. + + elsif Nkind (Result_Definition (N)) = N_Access_Definition + and then + not Is_Class_Wide_Type (Designated_Type (Etype (Designator))) + and then Is_Abstract_Type (Designated_Type (Etype (Designator))) + and then Ada_Version >= Ada_12 + then + Error_Msg_N ("function whose access result designates " + & "abstract type must be abstract", N); + end if; end if; end if; @@ -2942,6 +3180,15 @@ package body Sem_Ch6 is and then Has_Excluded_Statement (Statements (S)) then return True; + + elsif Nkind (S) = N_Extended_Return_Statement then + if Has_Excluded_Statement + (Statements (Handled_Statement_Sequence (S))) + or else Present + (Exception_Handlers (Handled_Statement_Sequence (S))) + then + return True; + end if; end if; Next (S); @@ -2964,6 +3211,7 @@ package body Sem_Ch6 is or else Is_Child_Unit (S) then return False; + elsif Ekind (S) = E_Package and then Has_Forward_Instantiation (S) then @@ -3008,12 +3256,33 @@ package body Sem_Ch6 is return Abandon; end if; + -- A return statement within an extended return is a noop + -- after inlining. + + elsif No (Expression (N)) + and then Nkind (Parent (Parent (N))) = + N_Extended_Return_Statement + then + return OK; + else -- Expression has wrong form return Abandon; end if; + -- We can only inline a build-in-place function if + -- it has a single extended return. + + elsif Nkind (N) = N_Extended_Return_Statement then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + else + return Abandon; + end if; + else return OK; end if; @@ -3024,11 +3293,18 @@ package body Sem_Ch6 is -- Start of processing for Has_Single_Return begin - return Check_All_Returns (N) = OK - and then Present (Declarations (N)) - and then Present (First (Declarations (N))) - and then Chars (Expression (Return_Statement)) = - Chars (Defining_Identifier (First (Declarations (N)))); + if Check_All_Returns (N) /= OK then + return False; + + elsif Nkind (Return_Statement) = N_Extended_Return_Statement then + return True; + + else + return Present (Declarations (N)) + and then Present (First (Declarations (N))) + and then Chars (Expression (Return_Statement)) = + Chars (Defining_Identifier (First (Declarations (N)))); + end if; end Has_Single_Return; -------------------- @@ -3245,10 +3521,9 @@ package body Sem_Ch6 is procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is begin - -- Do not emit warning if this is a predefined unit which is not - -- the main unit. With validity checks enabled, some predefined - -- subprograms may contain nested subprograms and become ineligible - -- for inlining. + -- Do not emit warning if this is a predefined unit which is not the + -- main unit. With validity checks enabled, some predefined subprograms + -- may contain nested subprograms and become ineligible for inlining. if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp))) and then not In_Extended_Main_Source_Unit (Subp) @@ -3312,7 +3587,7 @@ package body Sem_Ch6 is case Ctype is when Type_Conformant => - Error_Msg_N + Error_Msg_N -- CODEFIX ("not type conformant with declaration#!", Enode); when Mode_Conformant => @@ -3337,11 +3612,11 @@ package body Sem_Ch6 is when Fully_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then - Error_Msg_N + Error_Msg_N -- CODEFIX ("not fully conformant with operation inherited#!", Enode); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("not fully conformant with declaration#!", Enode); end if; end case; @@ -3440,7 +3715,6 @@ package body Sem_Ch6 is Error_Msg_Name_1 := Chars (New_Id); Error_Msg_Name_2 := Name_Ada + Convention_Id'Pos (Convention (New_Id)); - Conformance_Error ("\prior declaration for% has convention %!"); else @@ -3500,6 +3774,29 @@ package body Sem_Ch6 is Set_Error_Posted (New_Formal); return; end if; + + -- 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); + + -- Mark error posted on the new formal to avoid duplicated + -- complaint about types not matching. + + Set_Error_Posted (New_Formal); + end if; + end if; end if; -- Ada 2005 (AI-423): Possible access [sub]type and itype match. This @@ -3641,6 +3938,11 @@ package body Sem_Ch6 is or else Is_Access_Constant (Etype (Old_Formal)) /= Is_Access_Constant (Etype (New_Formal))) + + -- Do not complain if error already posted on New_Formal. This + -- avoids some redundant error messages. + + and then not Error_Posted (New_Formal) then -- It is allowed to omit the null-exclusion in case of stream -- attribute subprograms. We recognize stream subprograms @@ -3811,26 +4113,29 @@ package body Sem_Ch6 is Error_Msg_Name_2 := Get_Convention_Name (Convention (Op)); Error_Msg_Sloc := Sloc (Op); - if Comes_From_Source (Op) then + if Comes_From_Source (Op) or else No (Alias (Op)) then if not Is_Overriding_Operation (Op) then Error_Msg_N ("\\primitive % defined #", Typ); else - Error_Msg_N ("\\overriding operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\overriding operation % with " & + "convention % defined #", Typ); end if; else pragma Assert (Present (Alias (Op))); Error_Msg_Sloc := Sloc (Alias (Op)); - Error_Msg_N ("\\inherited operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\inherited operation % with " & + "convention % defined #", Typ); end if; Error_Msg_Name_1 := Chars (Op); Error_Msg_Name_2 := Get_Convention_Name (Convention (Iface_Prim)); Error_Msg_Sloc := Sloc (Iface_Prim); - Error_Msg_N ("\\overridden operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\overridden operation % with " & + "convention % defined #", Typ); -- Avoid cascading errors @@ -3887,7 +4192,9 @@ package body Sem_Ch6 is procedure Possible_Freeze (T : Entity_Id); -- T is the type of either a formal parameter or of the return type. -- If T is not yet frozen and needs a delayed freeze, then the - -- subprogram itself must be delayed. + -- subprogram itself must be delayed. If T is the limited view of an + -- incomplete type the subprogram must be frozen as well, because + -- T may depend on local types that have not been frozen yet. --------------------- -- Possible_Freeze -- @@ -3895,9 +4202,7 @@ package body Sem_Ch6 is procedure Possible_Freeze (T : Entity_Id) is begin - if Has_Delayed_Freeze (T) - and then not Is_Frozen (T) - then + if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then Set_Has_Delayed_Freeze (Designator); elsif Is_Access_Type (T) @@ -3905,7 +4210,11 @@ package body Sem_Ch6 is and then not Is_Frozen (Designated_Type (T)) then Set_Has_Delayed_Freeze (Designator); + + elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then + Set_Has_Delayed_Freeze (Designator); end if; + end Possible_Freeze; -- Start of processing for Check_Delayed_Subprogram @@ -3985,7 +4294,8 @@ package body Sem_Ch6 is procedure Conformance_Error (Msg : String; N : Node_Id) is begin Error_Msg_Sloc := Sloc (Prev_Loc); - Error_Msg_N ("not fully conformant with declaration#!", N); + Error_Msg_N -- CODEFIX + ("not fully conformant with declaration#!", N); Error_Msg_NE (Msg, N, N); end Conformance_Error; @@ -4007,6 +4317,20 @@ package body Sem_Ch6 is else Analyze (Discriminant_Type (New_Discr)); New_Discr_Type := Etype (Discriminant_Type (New_Discr)); + + -- Ada 2005: if the discriminant definition carries a null + -- exclusion, create an itype to check properly for consistency + -- with partial declaration. + + if Is_Access_Type (New_Discr_Type) + and then Null_Exclusion_Present (New_Discr) + then + New_Discr_Type := + Create_Null_Excluding_Itype + (T => New_Discr_Type, + Related_Nod => New_Discr, + Scope_Id => Current_Scope); + end if; end if; if not Conforming_Types @@ -4161,6 +4485,13 @@ package body Sem_Ch6 is elsif Ekind (Subp) = E_Entry then Decl := Parent (Subp); + -- No point in analyzing a malformed operator + + elsif Nkind (Subp) = N_Defining_Operator_Symbol + and then Error_Posted (Subp) + then + return; + else Decl := Unit_Declaration_Node (Subp); end if; @@ -4180,7 +4511,79 @@ package body Sem_Ch6 is return; end if; - if Present (Overridden_Subp) then + -- 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 + -- source of confusion that is worth diagnosing. Controlling formals + -- often carry names that reflect the type, and it is not worthwhile + -- requiring that their names match. + + if Present (Overridden_Subp) + and then Nkind (Subp) /= N_Defining_Operator_Symbol + then + declare + Form1 : Entity_Id; + Form2 : Entity_Id; + + begin + Form1 := First_Formal (Subp); + Form2 := First_Formal (Overridden_Subp); + + -- If the overriding operation is a synchronized operation, skip + -- the first parameter of the overridden operation, which is + -- implicit in the new one. If the operation is declared in the + -- body it is not primitive and all formals must match. + + if Is_Concurrent_Type (Scope (Subp)) + and then Is_Tagged_Type (Scope (Subp)) + and then not Has_Completion (Scope (Subp)) + then + Form2 := Next_Formal (Form2); + end if; + + if Present (Form1) then + Form1 := Next_Formal (Form1); + Form2 := Next_Formal (Form2); + end if; + + while Present (Form1) loop + if not Is_Controlling_Formal (Form1) + and then Present (Next_Formal (Form2)) + and then Chars (Form1) = Chars (Next_Formal (Form2)) + then + Error_Msg_Node_2 := Alias (Overridden_Subp); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_NE + ("& does not match corresponding formal of&#", + Form1, Form1); + exit; + end if; + + Next_Formal (Form1); + Next_Formal (Form2); + end loop; + end; + end if; + + -- If there is an overridden subprogram, then check that there is no + -- "not overriding" indicator, and mark the subprogram as overriding. + -- This is not done if the overridden subprogram is marked as hidden, + -- which can occur for the case of inherited controlled operations + -- (see Derive_Subprogram), unless the inherited subprogram's parent + -- subprogram is not itself hidden. (Note: This condition could probably + -- be simplified, leaving out the testing for the specific controlled + -- cases, but it seems safer and clearer this way, and echoes similar + -- special-case tests of this kind in other places.) + + if Present (Overridden_Subp) + and then (not Is_Hidden (Overridden_Subp) + or else + ((Chars (Overridden_Subp) = Name_Initialize + or else Chars (Overridden_Subp) = Name_Adjust + or else Chars (Overridden_Subp) = Name_Finalize) + and then Present (Alias (Overridden_Subp)) + and then not Is_Hidden (Alias (Overridden_Subp)))) + then if Must_Not_Override (Spec) then Error_Msg_Sloc := Sloc (Overridden_Subp); @@ -4196,12 +4599,22 @@ package body Sem_Ch6 is Set_Is_Overriding_Operation (Subp); end if; - if Style_Check and then not Must_Override (Spec) then + -- If primitive flag is set or this is a protected operation, then + -- the operation is overriding at the point of its declaration, so + -- warn if necessary. Otherwise it may have been declared before the + -- operation it overrides and no check is required. + + if Style_Check + and then not Must_Override (Spec) + and then (Is_Primitive + or else Ekind (Scope (Subp)) = E_Protected_Type) + then Style.Missing_Overriding (Decl, Subp); end if; - -- If Subp is an operator, it may override a predefined operation. - -- In that case overridden_subp is empty because of our implicit + -- If Subp is an operator, it may override a predefined operation, if + -- it is defined in the same scope as the type to which it applies. + -- In that case Overridden_Subp is empty because of our implicit -- representation for predefined operators. We have to check whether the -- signature of Subp matches that of a predefined operator. Note that -- first argument provides the name of the operator, and the second @@ -4211,36 +4624,64 @@ package body Sem_Ch6 is -- explicit overridden operation. elsif Nkind (Subp) = N_Defining_Operator_Symbol then + declare + Typ : constant Entity_Id := + Base_Type (Etype (First_Formal (Subp))); - if Must_Not_Override (Spec) then - if not Is_Primitive then - Error_Msg_N - ("overriding indicator only allowed " - & "if subprogram is primitive", Subp); + Can_Override : constant Boolean := + Operator_Matches_Spec (Subp, Subp) + and then Scope (Subp) = Scope (Typ) + and then not Is_Class_Wide_Type (Typ); - elsif Operator_Matches_Spec (Subp, Subp) then - Error_Msg_NE - ("subprogram & overrides predefined operator ", Spec, Subp); - end if; + begin + if Must_Not_Override (Spec) then + + -- If this is not a primitive or a protected subprogram, then + -- "not overriding" is illegal. + + if not Is_Primitive + and then Ekind (Scope (Subp)) /= E_Protected_Type + then + Error_Msg_N + ("overriding indicator only allowed " + & "if subprogram is primitive", Subp); + + elsif Can_Override then + Error_Msg_NE + ("subprogram& overrides predefined operator ", Spec, Subp); + end if; - elsif Must_Override (Spec) then - if Is_Overriding_Operation (Subp) then + elsif Must_Override (Spec) then + if Is_Overriding_Operation (Subp) then + null; + + elsif not Can_Override then + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); + end if; + + elsif not Error_Posted (Subp) + and then Style_Check + and then Can_Override + and then + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Subp))) + then Set_Is_Overriding_Operation (Subp); - elsif not Operator_Matches_Spec (Subp, Subp) then - Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); - end if; + -- If style checks are enabled, indicate that the indicator is + -- missing. However, at the point of declaration, the type of + -- which this is a primitive operation may be private, in which + -- case the indicator would be premature. - elsif not Error_Posted (Subp) - and then Style_Check - and then Operator_Matches_Spec (Subp, Subp) - and then - not Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Subp))) - then - Set_Is_Overriding_Operation (Subp); - Style.Missing_Overriding (Decl, Subp); - end if; + if Has_Private_Declaration (Etype (Subp)) + or else Has_Private_Declaration (Etype (First_Formal (Subp))) + then + null; + else + Style.Missing_Overriding (Decl, Subp); + end if; + end if; + end; elsif Must_Override (Spec) then if Ekind (Subp) = E_Entry then @@ -5064,6 +5505,14 @@ package body Sem_Ch6 is -- and also returned as the result. These formals are always of mode IN. -- The new formal has the type Typ, is declared in Scope, and its name -- is given by a concatenation of the name of Assoc_Entity and Suffix. + -- The following suffixes are currently used. They should not be changed + -- without coordinating with CodePeer, which makes use of these to + -- provide better messages. + + -- O denotes the Constrained bit. + -- L denotes the accessibility level. + -- BIP_xxx denotes an extra formal for a build-in-place function. See + -- the full list in exp_ch6.BIP_Formal_Kind. ---------------------- -- Add_Extra_Formal -- @@ -5152,7 +5601,7 @@ package body Sem_Ch6 is -- generated stream attributes do get passed through because extra -- build-in-place formals are needed in some cases (limited 'Input). - if Is_Predefined_Dispatching_Operation (E) then + if Is_Predefined_Internal_Operation (E) then goto Test_For_BIP_Extras; end if; @@ -5190,7 +5639,7 @@ package body Sem_Ch6 is and then not Is_Indefinite_Subtype (Formal_Type) then Set_Extra_Constrained - (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "F")); + (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); end if; end if; @@ -5222,16 +5671,8 @@ package body Sem_Ch6 is (No (P_Formal) or else Present (Extra_Accessibility (P_Formal))) then - -- Temporary kludge: for now we avoid creating the extra formal - -- for access parameters of protected operations because of - -- problem with the case of internal protected calls. ??? - - if Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Definition - and then Nkind (Parent (Parent (Parent (E)))) /= N_Protected_Body - then - Set_Extra_Accessibility - (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "F")); - end if; + Set_Extra_Accessibility + (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L")); end if; -- This label is required when skipping extra formal generation for @@ -5260,15 +5701,16 @@ package body Sem_Ch6 is begin -- In the case of functions with unconstrained result subtypes, - -- add a 3-state formal indicating whether the return object is - -- allocated by the caller (0), or should be allocated by the - -- callee on the secondary stack (1) or in the global heap (2). - -- For the moment we just use Natural for the type of this formal. - -- Note that this formal isn't usually needed in the case where - -- the result subtype is constrained, but it is needed when the - -- function has a tagged result, because generally such functions - -- can be called in a dispatching context and such calls must be - -- handled like calls to a class-wide function. + -- add a 4-state formal indicating whether the return object is + -- allocated by the caller (1), or should be allocated by the + -- callee on the secondary stack (2), in the global heap (3), or + -- in a user-defined storage pool (4). For the moment we just use + -- Natural for the type of this formal. Note that this formal + -- isn't usually needed in the case where the result subtype is + -- constrained, but it is needed when the function has a tagged + -- result, because generally such functions can be called in a + -- dispatching context and such calls must be handled like calls + -- to a class-wide function. if not Is_Constrained (Underlying_Type (Result_Subt)) or else Is_Tagged_Type (Underlying_Type (Result_Subt)) @@ -5279,19 +5721,18 @@ package body Sem_Ch6 is E, BIP_Formal_Suffix (BIP_Alloc_Form)); end if; - -- In the case of functions whose result type has controlled - -- parts, we have an extra formal of type - -- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That - -- is, we are passing a pointer to a finalization list (which is - -- itself a pointer). This extra formal is then passed along to - -- Move_Final_List in case of successful completion of a return - -- statement. We cannot pass an 'in out' parameter, because we - -- need to update the finalization list during an abort-deferred - -- region, rather than using copy-back after the function - -- returns. This is true even if we are able to get away with - -- having 'in out' parameters, which are normally illegal for - -- functions. This formal is also needed when the function has - -- a tagged result. + -- For functions whose result type has controlled parts, we have + -- an extra formal of type System.Finalization_Implementation. + -- Finalizable_Ptr_Ptr. That is, we are passing a pointer to a + -- finalization list (which is itself a pointer). This extra + -- formal is then passed along to Move_Final_List in case of + -- successful completion of a return statement. We cannot pass an + -- 'in out' parameter, because we need to update the finalization + -- list during an abort-deferred region, rather than using + -- copy-back after the function returns. This is true even if we + -- are able to get away with having 'in out' parameters, which are + -- normally illegal for functions. This formal is also needed when + -- the function has a tagged result. if Needs_BIP_Final_List (E) then Discard := @@ -5425,6 +5866,51 @@ package body Sem_Ch6 is end Enter_Overloaded_Entity; ----------------------------- + -- Check_Untagged_Equality -- + ----------------------------- + + procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is + Typ : constant Entity_Id := Etype (First_Formal (Eq_Op)); + Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op); + Obj_Decl : Node_Id; + + begin + if Nkind (Decl) = N_Subprogram_Declaration + and then Is_Record_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + if Is_Frozen (Typ) then + Error_Msg_NE + ("equality operator must be declared " + & "before type& is frozen", Eq_Op, Typ); + + Obj_Decl := Next (Parent (Typ)); + while Present (Obj_Decl) + and then Obj_Decl /= Decl + loop + if Nkind (Obj_Decl) = N_Object_Declaration + and then Etype (Defining_Identifier (Obj_Decl)) = Typ + then + Error_Msg_NE ("type& is frozen by declaration?", + Obj_Decl, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after this " + & "point ('R'M 4.5.2 (9.8)) (Ada 2012))?", Obj_Decl); + exit; + end if; + + Next (Obj_Decl); + end loop; + + elsif not In_Same_List (Parent (Typ), Decl) + and then not Is_Limited_Type (Typ) + then + Error_Msg_N ("equality operator appears too late", Eq_Op); + end if; + end if; + end Check_Untagged_Equality; + + ----------------------------- -- Find_Corresponding_Spec -- ----------------------------- @@ -5493,8 +5979,8 @@ package body Sem_Ch6 is -- that was created for an operation inherited by a null -- extension, it may be overridden by a body without a previous -- spec (one more reason why these should be shunned). In that - -- case remove the generated body, because the current one is - -- the explicit overriding. + -- case remove the generated body if present, because the + -- current one is the explicit overriding. elsif Ekind (E) = E_Function and then Ada_Version >= Ada_05 @@ -5505,15 +5991,20 @@ package body Sem_Ch6 is then Set_Has_Completion (E, False); - if Expander_Active then + if Expander_Active + and then Nkind (Parent (E)) = N_Function_Specification + then Remove (Unit_Declaration_Node - (Corresponding_Body (Unit_Declaration_Node (E)))); + (Corresponding_Body (Unit_Declaration_Node (E)))); + return E; - -- If expansion is disabled, the wrapper function has not - -- been generated, and this is the standard case of a late - -- body overriding an inherited operation. + -- If expansion is disabled, or if the wrapper function has + -- not been generated yet, this a late body overriding an + -- inherited operation, or it is an overriding by some other + -- declaration before the controlling result is frozen. In + -- either case this is a declaration of a new entity. else return Empty; @@ -5744,8 +6235,9 @@ package body Sem_Ch6 is when N_Aggregate => return FCL (Expressions (E1), Expressions (E2)) - and then FCL (Component_Associations (E1), - Component_Associations (E2)); + and then + FCL (Component_Associations (E1), + Component_Associations (E2)); when N_Allocator => if Nkind (Expression (E1)) = N_Qualified_Expression @@ -5809,12 +6301,44 @@ package body Sem_Ch6 is and then FCE (Left_Opnd (E1), Left_Opnd (E2)) and then FCE (Right_Opnd (E1), Right_Opnd (E2)); - when N_And_Then | N_Or_Else | N_Membership_Test => + when N_Short_Circuit | N_Membership_Test => return FCE (Left_Opnd (E1), Left_Opnd (E2)) and then FCE (Right_Opnd (E1), Right_Opnd (E2)); + when N_Case_Expression => + declare + Alt1 : Node_Id; + Alt2 : Node_Id; + + begin + if not FCE (Expression (E1), Expression (E2)) then + return False; + + else + Alt1 := First (Alternatives (E1)); + Alt2 := First (Alternatives (E2)); + loop + if Present (Alt1) /= Present (Alt2) then + return False; + elsif No (Alt1) then + return True; + end if; + + if not FCE (Expression (Alt1), Expression (Alt2)) + or else not FCL (Discrete_Choices (Alt1), + Discrete_Choices (Alt2)) + then + return False; + end if; + + Next (Alt1); + Next (Alt2); + end loop; + end if; + end; + when N_Character_Literal => return Char_Literal_Value (E1) = Char_Literal_Value (E2); @@ -5822,7 +6346,8 @@ package body Sem_Ch6 is when N_Component_Association => return FCL (Choices (E1), Choices (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Conditional_Expression => return @@ -5843,13 +6368,15 @@ package body Sem_Ch6 is when N_Function_Call => return FCE (Name (E1), Name (E2)) - and then FCL (Parameter_Associations (E1), - Parameter_Associations (E2)); + and then + FCL (Parameter_Associations (E1), + Parameter_Associations (E2)); when N_Indexed_Component => return FCE (Prefix (E1), Prefix (E2)) - and then FCL (Expressions (E1), Expressions (E2)); + and then + FCL (Expressions (E1), Expressions (E2)); when N_Integer_Literal => return (Intval (E1) = Intval (E2)); @@ -5873,12 +6400,14 @@ package body Sem_Ch6 is when N_Qualified_Expression => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Range => return FCE (Low_Bound (E1), Low_Bound (E2)) - and then FCE (High_Bound (E1), High_Bound (E2)); + and then + FCE (High_Bound (E1), High_Bound (E2)); when N_Real_Literal => return (Realval (E1) = Realval (E2)); @@ -5886,12 +6415,14 @@ package body Sem_Ch6 is when N_Selected_Component => return FCE (Prefix (E1), Prefix (E2)) - and then FCE (Selector_Name (E1), Selector_Name (E2)); + and then + FCE (Selector_Name (E1), Selector_Name (E2)); when N_Slice => return FCE (Prefix (E1), Prefix (E2)) - and then FCE (Discrete_Range (E1), Discrete_Range (E2)); + and then + FCE (Discrete_Range (E1), Discrete_Range (E2)); when N_String_Literal => declare @@ -5920,17 +6451,20 @@ package body Sem_Ch6 is when N_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Unary_Op => return Entity (E1) = Entity (E2) - and then FCE (Right_Opnd (E1), Right_Opnd (E2)); + and then + FCE (Right_Opnd (E1), Right_Opnd (E2)); when N_Unchecked_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); -- All other node types cannot appear in this context. Strictly -- we should raise a fatal internal error. Instead we just ignore @@ -6086,8 +6620,8 @@ package body Sem_Ch6 is or else Etype (Prim) = Etype (Iface_Prim) or else not Has_Controlling_Result (Prim) then - return Type_Conformant (Prim, Iface_Prim, - Skip_Controlling_Formals => True); + return Type_Conformant + (Iface_Prim, Prim, Skip_Controlling_Formals => True); -- Case of a function returning an interface, or an access to one. -- Check that the return types correspond. @@ -6224,7 +6758,6 @@ package body Sem_Ch6 is -- instance of) a generic type. Formal := First_Formal (Prev_E); - while Present (Formal) loop F_Typ := Base_Type (Etype (Formal)); @@ -6535,20 +7068,39 @@ package body Sem_Ch6 is and then (not Is_Overriding or else not Is_Abstract_Subprogram (E)) then - Error_Msg_N ("abstract subprograms must be visible " - & "(RM 3.9.3(10))!", S); + Error_Msg_N + ("abstract subprograms must be visible " + & "(RM 3.9.3(10))!", S); elsif Ekind (S) = E_Function - and then Is_Tagged_Type (T) - and then T = Base_Type (Etype (S)) and then not Is_Overriding then - Error_Msg_N - ("private function with tagged result must" - & " override visible-part function", S); - Error_Msg_N - ("\move subprogram to the visible part" - & " (RM 3.9.3(10))", S); + if Is_Tagged_Type (T) + and then T = Base_Type (Etype (S)) + then + Error_Msg_N + ("private function with tagged result must" + & " override visible-part function", S); + Error_Msg_N + ("\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. + + elsif Ekind (Etype (S)) = E_Anonymous_Access_Type + and then Is_Tagged_Type (Designated_Type (Etype (S))) + and then + not Is_Class_Wide_Type (Designated_Type (Etype (S))) + and then Ada_Version >= Ada_12 + then + Error_Msg_N + ("private function with controlling access result " + & "must override visible-part function", S); + Error_Msg_N + ("\move subprogram to the visible part" + & " (RM 3.9.3(10))", S); + end if; end if; end if; end Check_Private_Overriding; @@ -6909,6 +7461,7 @@ package body Sem_Ch6 is or else not Is_Overloadable (Subp) or else not Is_Primitive (Subp) or else not Is_Dispatching_Operation (Subp) + or else not Present (Find_Dispatching_Type (Subp)) or else not Is_Interface (Find_Dispatching_Type (Subp)) then null; @@ -7076,6 +7629,53 @@ package body Sem_Ch6 is E := Current_Entity_In_Scope (S); + -- Ada 2005 (AI-251): Derivation of abstract interface primitives. + -- They are directly added to the list of primitive operations of + -- Derived_Type, unless this is a rederivation in the private part + -- of an operation that was already derived in the visible part of + -- the current package. + + if Ada_Version >= Ada_05 + and then Present (Derived_Type) + and then Present (Alias (S)) + and then Is_Dispatching_Operation (Alias (S)) + and then Present (Find_Dispatching_Type (Alias (S))) + and then Is_Interface (Find_Dispatching_Type (Alias (S))) + then + -- For private types, when the full-view is processed we propagate to + -- the full view the non-overridden entities whose attribute "alias" + -- references an interface primitive. These entities were added by + -- Derive_Subprograms to ensure that interface primitives are + -- covered. + + -- Inside_Freeze_Actions is non zero when S corresponds with an + -- internal entity that links an interface primitive with its + -- covering primitive through attribute Interface_Alias (see + -- Add_Internal_Interface_Entities) + + if Inside_Freezing_Actions = 0 + and then Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Nkind (Parent (E)) = N_Private_Extension_Declaration + and then Nkind (Parent (S)) = N_Full_Type_Declaration + and then Full_View (Defining_Identifier (Parent (E))) + = Defining_Identifier (Parent (S)) + and then Alias (E) = Alias (S) + then + Check_Operation_From_Private_View (S, E); + Set_Is_Dispatching_Operation (S); + + -- Common case + + else + Enter_Overloaded_Entity (S); + Check_Dispatching_Operation (S, Empty); + Check_For_Primitive_Subprogram (Is_Primitive_Subp); + end if; + + return; + end if; + -- If there is no homonym then this is definitely not overriding if No (E) then @@ -7151,19 +7751,6 @@ package body Sem_Ch6 is -- E exists and is overloadable else - -- Ada 2005 (AI-251): Derivation of abstract interface primitives - -- need no check against the homonym chain. They are directly added - -- to the list of primitive operations of Derived_Type. - - if Ada_Version >= Ada_05 - and then Present (Derived_Type) - and then Is_Dispatching_Operation (Alias (S)) - and then Present (Find_Dispatching_Type (Alias (S))) - and then Is_Interface (Find_Dispatching_Type (Alias (S))) - then - goto Add_New_Entity; - end if; - Check_Synchronized_Overriding (S, Overridden_Subp); -- Loop through E and its homonyms to determine if any of them is @@ -7240,9 +7827,9 @@ package body Sem_Ch6 is return; - -- Within an instance, the renaming declarations for - -- actual subprograms may become ambiguous, but they do - -- not hide each other. + -- Within an instance, the renaming declarations for actual + -- subprograms may become ambiguous, but they do not hide each + -- other. elsif Ekind (E) /= E_Entry and then not Comes_From_Source (E) @@ -7254,8 +7841,8 @@ package body Sem_Ch6 is or else Nkind (Unit_Declaration_Node (E)) /= N_Subprogram_Renaming_Declaration) then - -- A subprogram child unit is not allowed to override - -- an inherited subprogram (10.1.1(20)). + -- A subprogram child unit is not allowed to override an + -- inherited subprogram (10.1.1(20)). if Is_Child_Unit (S) then Error_Msg_N @@ -7391,10 +7978,22 @@ package body Sem_Ch6 is Set_Is_Overriding_Operation (S); Check_Overriding_Indicator (S, E, Is_Primitive => True); - -- Indicate that S overrides the operation from which - -- E is inherited. - - if Comes_From_Source (S) then + -- If S is a user-defined subprogram or a null procedure + -- expanded to override an inherited null procedure, then + -- indicate that E overrides the operation from which S + -- is inherited. It seems odd that Overridden_Operation + -- isn't set in all cases where Is_Overriding_Operation + -- is true, but doing so causes infinite loops in the + -- compiler for implicit overriding subprograms. ??? + + if Comes_From_Source (S) + or else + (Present (Parent (S)) + and then + Nkind (Parent (S)) = N_Procedure_Specification + and then + Null_Present (Parent (S))) + then if Present (Alias (E)) then Set_Overridden_Operation (S, Alias (E)); else @@ -7509,8 +8108,6 @@ package body Sem_Ch6 is E := Homonym (E); end loop; - <> - -- On exit, we know that S is a new entity Enter_Overloaded_Entity (S); @@ -7542,6 +8139,10 @@ package body Sem_Ch6 is and then not Is_Dispatching_Operation (S) then Make_Inequality_Operator (S); + + if Ada_Version >= Ada_12 then + Check_Untagged_Equality (S); + end if; end if; end New_Overloaded_Entity; @@ -7563,11 +8164,36 @@ package body Sem_Ch6 is First_Out_Param : Entity_Id := Empty; -- Used for setting Is_Only_Out_Parameter + function Designates_From_With_Type (Typ : Entity_Id) return Boolean; + -- Determine whether an access type designates a type coming from a + -- limited view. + function Is_Class_Wide_Default (D : Node_Id) return Boolean; -- Check whether the default has a class-wide type. After analysis the -- default has the type of the formal, so we must also check explicitly -- for an access attribute. + ------------------------------- + -- Designates_From_With_Type -- + ------------------------------- + + function Designates_From_With_Type (Typ : Entity_Id) return Boolean is + Desig : Entity_Id := Typ; + + begin + if Is_Access_Type (Desig) then + Desig := Directly_Designated_Type (Desig); + end if; + + if Is_Class_Wide_Type (Desig) then + Desig := Root_Type (Desig); + end if; + + return + Ekind (Desig) = E_Incomplete_Type + and then From_With_Type (Desig); + end Designates_From_With_Type; + --------------------------- -- Is_Class_Wide_Default -- --------------------------- @@ -7610,10 +8236,28 @@ package body Sem_Ch6 is (Is_Class_Wide_Type (Formal_Type) and then Is_Incomplete_Type (Root_Type (Formal_Type))) then - -- Ada 2005 (AI-326): Tagged incomplete types allowed + -- Ada 2005 (AI-326): Tagged incomplete types allowed in + -- primitive operations, as long as their completion is + -- in the same declarative part. If in the private part + -- this means that the type cannot be a Taft-amendment type. + -- Check is done on package exit. For access to subprograms, + -- the use is legal for Taft-amendment types. if Is_Tagged_Type (Formal_Type) then - null; + if Ekind (Scope (Current_Scope)) = E_Package + and then In_Private_Part (Scope (Current_Scope)) + and then not From_With_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) + then + Append_Elmt + (Current_Scope, + Private_Dependents (Base_Type (Formal_Type))); + end if; + end if; -- Special handling of Value_Type for CIL case @@ -7623,15 +8267,13 @@ package body Sem_Ch6 is elsif not Nkind_In (Parent (T), N_Access_Function_Definition, N_Access_Procedure_Definition) then - Error_Msg_N ("invalid use of incomplete type", Param_Spec); - - -- An incomplete type that is not tagged is allowed in an - -- access-to-subprogram type only if it is a local declaration - -- with a forthcoming completion (3.10.1 (9.2/2)). + Error_Msg_NE + ("invalid use of incomplete type&", + Param_Spec, Formal_Type); - elsif Scope (Formal_Type) /= Scope (Current_Scope) then - Error_Msg_N - ("invalid use of limited view of type", Param_Spec); + -- Further checks on the legality of incomplete types + -- in formal parts must be delayed until the freeze point + -- of the enclosing subprogram or access to subprogram. end if; elsif Ekind (Formal_Type) = E_Void then @@ -7741,13 +8383,22 @@ package body Sem_Ch6 is -- is also class-wide. if Ekind (Formal_Type) = E_Anonymous_Access_Type - and then not From_With_Type (Formal_Type) + and then not Designates_From_With_Type (Formal_Type) and then Is_Class_Wide_Default (Default) and then not Is_Class_Wide_Type (Designated_Type (Formal_Type)) then Error_Msg_N ("access to class-wide expression not allowed here", Default); end if; + + -- Check incorrect use of dynamically tagged expressions + + if Is_Tagged_Type (Formal_Type) then + Check_Dynamically_Tagged_Expression + (Expr => Default, + Typ => Formal_Type, + Related_Nod => Default); + end if; end if; -- Ada 2005 (AI-231): Static checks @@ -7898,7 +8549,7 @@ package body Sem_Ch6 is Prag := Spec_PPC_List (Spec_Id); while Present (Prag) loop if Pragma_Name (Prag) = Name_Precondition - and then PPC_Enabled (Prag) + and then Pragma_Enabled (Prag) then -- Add pragma Check at the start of the declarations of N. -- Note that this processing reverses the order of the list, @@ -7955,12 +8606,12 @@ package body Sem_Ch6 is Next (Prag); - -- Not a pragma, if comes from source, then end scan + -- Not a pragma, if comes from source, then end scan elsif Comes_From_Source (Prag) then exit; - -- Skip stuff not coming from source + -- Skip stuff not coming from source else Next (Prag); @@ -7977,7 +8628,7 @@ package body Sem_Ch6 is Prag := Spec_PPC_List (Spec_Id); while Present (Prag) loop if Pragma_Name (Prag) = Name_Postcondition - and then PPC_Enabled (Prag) + and then Pragma_Enabled (Prag) then if Plist = No_List then Plist := Empty_List; @@ -7995,7 +8646,7 @@ package body Sem_Ch6 is end if; -- If we had any postconditions and expansion is enabled, build - -- the Postconditions procedure. + -- the _Postconditions procedure. if Present (Plist) and then Expander_Active @@ -8013,20 +8664,36 @@ package body Sem_Ch6 is Parms := No_List; end if; - Prepend_To (Declarations (N), - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => + declare + Post_Proc : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => Name_uPostconditions), - Parameter_Specifications => Parms), + Chars => Name_uPostconditions); + -- The entity for the _Postconditions procedure + begin + Prepend_To (Declarations (N), + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Post_Proc, + Parameter_Specifications => Parms), - Declarations => Empty_List, + Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Plist))); + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Plist))); + + -- If this is a procedure, set the Postcondition_Proc attribute on + -- the proper defining entity for the subprogram. + + if Etype (Subp) = Standard_Void_Type then + if Present (Spec_Id) then + Set_Postcondition_Proc (Spec_Id, Post_Proc); + else + Set_Postcondition_Proc (Body_Id, Post_Proc); + end if; + end if; + end; if Present (Spec_Id) then Set_Has_Postconditions (Spec_Id);