-- --
-- 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- --
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;
-----------------------
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
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.
-- 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.
(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 --
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;
end if;
Generate_Reference_To_Formals (Designator);
+ Check_Eliminated (Designator);
end Analyze_Abstract_Subprogram_Declaration;
----------------------------------------
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
-------------------------------------
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));
-- 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;
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)
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",
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;
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;
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
& "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;
if Style_Check then
Style.Check_Identifier (Body_Id, Gen_Id);
end if;
+
End_Generic;
end Analyze_Generic_Subprogram_Body;
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 --
----------------------------
procedure Analyze_Call_And_Resolve;
-- Do Analyze and Resolve calls for procedure call
+ -- At end, check illegal order dependence.
------------------------------
-- Analyze_Call_And_Resolve --
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;
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;
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
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
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
-- 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);
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;
-- 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.
-- 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
procedure Check_Anonymous_Return is
Decl : Node_Id;
+ Par : Node_Id;
Scop : Entity_Id;
begin
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,
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;
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;
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);
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 --
-----------------------
("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);
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.
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
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;
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
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,
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
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;
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;
-- 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);
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);
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
-- 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;
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);
or else Is_Child_Unit (S)
then
return False;
+
elsif Ekind (S) = E_Package
and then Has_Forward_Instantiation (S)
then
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;
-- 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;
--------------------
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)
case Ctype is
when Type_Conformant =>
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("not type conformant with declaration#!", Enode);
when Mode_Conformant =>
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;
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
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
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
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
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 --
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)
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
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;
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
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;
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);
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
-- 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
-- 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 --
-- 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;
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;
(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
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))
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 :=
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 --
-----------------------------
-- 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
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;
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
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);
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
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));
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));
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
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
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.
-- instance of) a generic type.
Formal := First_Formal (Prev_E);
-
while Present (Formal) loop
F_Typ := Base_Type (Etype (Formal));
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;
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;
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
-- 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
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)
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
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
E := Homonym (E);
end loop;
- <<Add_New_Entity>>
-
-- On exit, we know that S is a new entity
Enter_Overloaded_Entity (S);
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;
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 --
---------------------------
(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
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
-- 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
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,
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);
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;
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
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);
OSDN Git Service
