Check_SPARK_Restriction ("abstract subprogram is not allowed", N);
Generate_Definition (Designator);
+ Set_Contract (Designator, Make_Contract (Sloc (Designator)));
Set_Is_Abstract_Subprogram (Designator);
New_Overloaded_Entity (Designator);
Check_Delayed_Subprogram (Designator);
end loop;
end if;
- -- Special processing for Elab_Spec and Elab_Body calls
+ -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
if Nkind (P) = N_Attribute_Reference
and then (Attribute_Name (P) = Name_Elab_Spec
- or else Attribute_Name (P) = Name_Elab_Body)
+ or else Attribute_Name (P) = Name_Elab_Body
+ or else Attribute_Name (P) = Name_Elab_Subp_Body)
then
if Present (Actuals) then
Error_Msg_N
-- In general, the spec will be frozen when we start analyzing the
-- body. However, for internally generated operations, such as
-- wrapper functions for inherited operations with controlling
- -- results, the spec may not have been frozen by the time we
- -- expand the freeze actions that include the bodies. In particular,
- -- extra formals for accessibility or for return-in-place may need
- -- to be generated. Freeze nodes, if any, are inserted before the
- -- current body.
+ -- results, the spec may not have been frozen by the time we expand
+ -- the freeze actions that include the bodies. In particular, extra
+ -- formals for accessibility or for return-in-place may need to be
+ -- generated. Freeze nodes, if any, are inserted before the current
+ -- body. These freeze actions are also needed in ASIS mode to enable
+ -- the proper back-annotations.
if not Is_Frozen (Spec_Id)
- and then Expander_Active
+ and then (Expander_Active or ASIS_Mode)
then
-- Force the generation of its freezing node to ensure proper
-- management of access types in the backend.
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Acts_As_Spec (N);
Generate_Definition (Body_Id);
+ Set_Contract (Body_Id, Make_Contract (Sloc (Body_Id)));
Generate_Reference
(Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
Generate_Reference_To_Formals (Body_Id);
-- raises an exception, but in any case it is not coming
-- back here, so turn on the flag.
- if Ekind (Ent) = E_Procedure
+ if Present (Ent)
+ and then Ekind (Ent) = E_Procedure
and then No_Return (Ent)
then
Set_Trivial_Subprogram (Stm);
Designator := Analyze_Subprogram_Specification (Specification (N));
Generate_Definition (Designator);
+ -- ??? why this call, already in Analyze_Subprogram_Specification
if Debug_Flag_C then
Write_Str ("==> subprogram spec ");
-- Proceed with analysis
Generate_Definition (Designator);
+ Set_Contract (Designator, Make_Contract (Sloc (Designator)));
if Nkind (N) = N_Function_Specification then
Set_Ekind (Designator, E_Function);
elsif Ekind (T) = E_Incomplete_Type and then From_With_Type (T) then
Set_Has_Delayed_Freeze (Designator);
+
+ -- AI05-0151: In Ada 2012, Incomplete types can appear in the profile
+ -- of a subprogram or entry declaration.
+
+ elsif Ekind (T) = E_Incomplete_Type
+ and then Ada_Version >= Ada_2012
+ then
+ Set_Has_Delayed_Freeze (Designator);
end if;
end Possible_Freeze;
-- Grouping (use of comma in param lists) must be the same
-- This is where we catch a misconformance like:
- -- A,B : Integer
+ -- A, B : Integer
-- A : Integer; B : Integer
-- which are represented identically in the tree except
end if;
-- In the case of functions whose result type needs finalization,
- -- add an extra formal of type Ada.Finalization.Heap_Management.
- -- Finalization_Collection_Ptr.
+ -- add an extra formal which represents the finalization master.
- if Needs_BIP_Collection (E) then
+ if Needs_BIP_Finalization_Master (E) then
Discard :=
Add_Extra_Formal
- (E, RTE (RE_Finalization_Collection_Ptr),
- E, BIP_Formal_Suffix (BIP_Collection));
+ (E, RTE (RE_Finalization_Master_Ptr),
+ E, BIP_Formal_Suffix (BIP_Finalization_Master));
end if;
-- If the result type contains tasks, we have two extra formals:
end if;
end if;
- if not Has_Completion (E) then
+ -- Ada 2012 (AI05-0165): For internally generated bodies of
+ -- null procedures locate the internally generated spec. We
+ -- enforce mode conformance since a tagged type may inherit
+ -- from interfaces several null primitives which differ only
+ -- in the mode of the formals.
+
+ if not (Comes_From_Source (E))
+ and then Is_Null_Procedure (E)
+ and then not Mode_Conformant (Designator, E)
+ then
+ null;
+
+ elsif not Has_Completion (E) then
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Corresponding_Spec (N, E);
end if;
Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim);
Typ : constant Entity_Id := Find_Dispatching_Type (Prim);
+ function Controlling_Formal (Prim : Entity_Id) return Entity_Id;
+ -- Return the controlling formal of Prim
+
+ ------------------------
+ -- Controlling_Formal --
+ ------------------------
+
+ function Controlling_Formal (Prim : Entity_Id) return Entity_Id is
+ E : Entity_Id := First_Entity (Prim);
+
+ begin
+ while Present (E) loop
+ if Is_Formal (E) and then Is_Controlling_Formal (E) then
+ return E;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return Empty;
+ end Controlling_Formal;
+
+ -- Local variables
+
+ Iface_Ctrl_F : constant Entity_Id := Controlling_Formal (Iface_Prim);
+ Prim_Ctrl_F : constant Entity_Id := Controlling_Formal (Prim);
+
+ -- Start of processing for Is_Interface_Conformant
+
begin
pragma Assert (Is_Subprogram (Iface_Prim)
and then Is_Subprogram (Prim)
then
return False;
- -- Case of a procedure, or a function that does not have a controlling
- -- result (I or access I).
+ -- The mode of the controlling formals must match
+
+ elsif Present (Iface_Ctrl_F)
+ and then Present (Prim_Ctrl_F)
+ and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F)
+ then
+ return False;
+
+ -- Case of a procedure, or a function whose result type matches the
+ -- result type of the interface primitive, or a function that has no
+ -- controlling result (I or access I).
elsif Ekind (Iface_Prim) = E_Procedure
or else Etype (Prim) = Etype (Iface_Prim)
begin
for J in Inherited'Range loop
- P := Spec_PPC_List (Inherited (J));
+ P := Spec_PPC_List (Contract (Inherited (J)));
+
while Present (P) loop
Error_Msg_Sloc := Sloc (P);
if Scope (E) /= Current_Scope then
null;
+ -- Ada 2012 (AI05-0165): For internally generated bodies of
+ -- null procedures locate the internally generated spec. We
+ -- enforce mode conformance since a tagged type may inherit
+ -- from interfaces several null primitives which differ only
+ -- in the mode of the formals.
+
+ elsif not Comes_From_Source (S)
+ and then Is_Null_Procedure (S)
+ and then not Mode_Conformant (E, S)
+ then
+ null;
+
-- Check if we have type conformance
elsif Type_Conformant (E, S) then
-- the body will be analyzed and converted when we scan the body
-- declarations below.
- Prag := Spec_PPC_List (Spec_Id);
+ Prag := Spec_PPC_List (Contract (Spec_Id));
while Present (Prag) loop
if Pragma_Name (Prag) = Name_Precondition then
-- Now deal with inherited preconditions
for J in Inherited'Range loop
- Prag := Spec_PPC_List (Inherited (J));
+ Prag := Spec_PPC_List (Contract (Inherited (J)));
while Present (Prag) loop
if Pragma_Name (Prag) = Name_Precondition
-- Loop through PPC pragmas from spec
- Prag := Spec_PPC_List (Spec);
+ Prag := Spec_PPC_List (Contract (Spec));
loop
if Pragma_Name (Prag) = Name_Postcondition
and then (not Class or else Class_Present (Prag))
-- Start of processing for Spec_Postconditions
begin
- if Present (Spec_PPC_List (Spec_Id)) then
+ if Present (Spec_PPC_List (Contract (Spec_Id))) then
Process_Post_Conditions (Spec_Id, Class => False);
end if;
-- Process inherited postconditions
for J in Inherited'Range loop
- if Present (Spec_PPC_List (Inherited (J))) then
+ if Present (Spec_PPC_List (Contract (Inherited (J)))) then
Process_Post_Conditions (Inherited (J), Class => True);
end if;
end loop;
Statements => Plist)));
Set_Ekind (Post_Proc, E_Procedure);
- Set_Is_Postcondition_Proc (Post_Proc);
-- If this is a procedure, set the Postcondition_Proc attribute on
-- the proper defining entity for the subprogram.
projects / gcc.git / blobdiff