FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

einfo.adb: Flag245 is now used.

Browse source 
2008-07-30  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb: Flag245 is now used.
	(Is_Primitive_Wrapper, Set_Is_Primitive_Wrapper): Relax the assertion
	check to include functions.
	(Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms.
	(Wrapped_Entity, Set_Wrapped_Entity): Relax the assertion check to
	include functions.
	(Write_Entity_Flags): Move flag Is_Primitive, add Is_Private_Primitive
	to the list of displayed flags.

	* einfo.ads: Update comment on the usage of Is_Primitive_Wrapper and
	Wrapped_Entity. These two flags are now present in functions.
	New flag Is_Private_Primitive.
	(Is_Private_Primitive, Set_Is_Private_Primitive): New subprograms.

	* exp_ch9.adb:
	(Build_Wrapper_Bodies): New subprogram.
	(Build_Wrapper_Body): The spec and body have been moved to in
	Build_Wrapper_ Bodies. Code cleanup.
	(Build_Wrapper_Spec): Moved to the spec of Exp_Ch9. Code cleanup.
	Wrappers are now generated for primitives declared between the private
	and full view of a concurrent type that implements an interface.
	(Build_Wrapper_Specs): New subprogram.
	(Expand_N_Protected_Body): Code reformatting. Replace the wrapper body
	creation mechanism with a call to Build_Wrapper_Bodies.
	(Expand_N_Protected_Type_Declaration): Code reformatting. Replace the
	wrapper spec creation mechanism with a call to Build_Wrapper_Specs.
	(Expand_N_Task_Body): Replace the wrapper body creation
	mechanism with a call to Build_Wrapper_Bodies.
	(Expand_N_Task_Type_Declaration): Replace the wrapper spec
	creation mechanism with a call to Build_Wrapper_Specs.
	(Is_Private_Primitive_Subprogram): New subprogram.
	(Overriding_Possible): Code cleanup.
	(Replicate_Entry_Formals): Renamed to Replicate_Formals, code cleanup.

	* exp_ch9.ads (Build_Wrapper_Spec): Moved from the body of Exp_Ch9.

	* sem_ch3.adb: Add with and use clause for Exp_Ch9.
	(Process_Full_View): Build wrapper specs for all primitives
	that belong to a private view completed by a concurrent type
	implementing an interface.
	
	* sem_ch6.adb (Analyze_Subprogram_Body): When the current subprogram
	is a primitive of a
	concurrent type with a private view that implements an interface, try to
	find the proper spec.
	(Analyze_Subprogram_Declaration): Mark a subprogram as a private
	primitive if the type of its first parameter is a non-generic tagged
	private type.
	(Analyze_Subprogram_Specification): Code reformatting.
	(Disambiguate_Spec): New routine.
	(Find_Corresponding_Spec): Add a flag to controll the output of errors.
	(Is_Private_Concurrent_Primitive): New routine.

	* sem_ch6.ads:
	(Find_Corresponding_Spec): Add a formal to control the output of errors.

From-SVN: r138324
This commit is contained in:
Hristian Kirtchev 2008-07-30 17:53:21 +02:00 • committed by Arnaud Charlet
parent dc82959091
commit d44202ba07
7 changed files with 864 additions and 608 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
gcc/ada/einfo.adb
View file

@ -504,9 +504,8 @@ package body Einfo is
-- Optimize_Alignment_Time Flag242
-- Overlays_Constant Flag243
-- Is_RACW_Stub_Type Flag244
-- Is_Private_Primitive Flag245
-- (unused) Flag169
-- (unused) Flag245
-- (unused) Flag246
-- (unused) Flag247
@ -1929,7 +1928,8 @@ package body Einfo is
function Is_Primitive_Wrapper (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Procedure);
pragma Assert (Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure);
return Flag195 (Id);
end Is_Primitive_Wrapper;
@ -1944,6 +1944,13 @@ package body Einfo is
return Flag53 (Id);
end Is_Private_Descendant;
function Is_Private_Primitive (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure);
return Flag245 (Id);
end Is_Private_Primitive;
function Is_Protected_Interface (Id : E) return B is
begin
pragma Assert (Is_Interface (Id));
@ -2702,8 +2709,9 @@ package body Einfo is
function Wrapped_Entity (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Procedure
and then Is_Primitive_Wrapper (Id));
pragma Assert ((Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure)
and then Is_Primitive_Wrapper (Id));
return Node27 (Id);
end Wrapped_Entity;
@ -4372,7 +4380,8 @@ package body Einfo is
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
pragma Assert (Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure);
Set_Flag195 (Id, V);
end Set_Is_Primitive_Wrapper;
@ -4387,6 +4396,13 @@ package body Einfo is
Set_Flag53 (Id, V);
end Set_Is_Private_Descendant;
procedure Set_Is_Private_Primitive (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure);
Set_Flag245 (Id, V);
end Set_Is_Private_Primitive;
procedure Set_Is_Protected_Interface (Id : E; V : B := True) is
begin
pragma Assert (Is_Interface (Id));
@ -5168,8 +5184,9 @@ package body Einfo is
procedure Set_Wrapped_Entity (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Procedure
and then Is_Primitive_Wrapper (Id));
pragma Assert ((Ekind (Id) = E_Function
or else Ekind (Id) = E_Procedure)
and then Is_Primitive_Wrapper (Id));
Set_Node27 (Id, V);
end Set_Wrapped_Entity;
@ -7597,9 +7614,11 @@ package body Einfo is
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive", Flag218 (Id));
W ("Is_Primitive_Wrapper", Flag195 (Id));
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Private_Primitive", Flag245 (Id));
W ("Is_Protected_Interface", Flag198 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
@ -7666,7 +7685,6 @@ package body Einfo is
W ("Suppress_Init_Proc", Flag105 (Id));
W ("Suppress_Style_Checks", Flag165 (Id));
W ("Suppress_Value_Tracking_On_Call", Flag217 (Id));
W ("Is_Primitive", Flag218 (Id));
W ("Treat_As_Volatile", Flag41 (Id));
W ("Universal_Aliasing", Flag216 (Id));
W ("Used_As_Generic_Actual", Flag222 (Id));

22
gcc/ada/einfo.ads
View file

@ -2513,9 +2513,9 @@ package Einfo is
-- indicators in bodies.
-- Is_Primitive_Wrapper (Flag195)
-- Present in all entities. Set for procedure entries that are used as
-- primitive wrappers. which are generated by the expander to wrap
-- entries of protected or task types implementing a limited interface.
-- Present in functions and procedures created by the expander to serve
-- as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures.
-- Is_Prival (synthesized)
-- Applies to all entities, true for renamings of private protected
@ -2533,6 +2533,10 @@ package Einfo is
-- functions, procedures). Set if the library unit is itself a private
-- child unit, or if it is the descendent of a private child unit.
-- Is_Private_Primitive (Flag245)
-- Present in subprograms. Set if the first parameter of the subprogram
-- is of concurrent tagged type with a private view.
-- Is_Private_Type (synthesized)
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes
@ -3723,8 +3727,8 @@ package Einfo is
-- attribute when the limited-view is installed (Ada 2005: AI-217).
-- Wrapped_Entity (Node27)
-- Present in an E_Procedure classified as an Is_Primitive_Wrapper. Set
-- to the entity that is being wrapped.
-- Present in functions and procedures which have been classified as
-- Is_Primitive_Wrapper. Set to the entity being wrapper.
------------------
-- Access Kinds --
@ -5013,6 +5017,7 @@ package Einfo is
-- Protection_Object (Node23) (for concurrent kind)
-- Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
@ -5039,7 +5044,9 @@ package Einfo is
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Private_Primitive (Flag245) (non-generic case only)
-- Is_Pure (Flag44)
-- Is_Thunk (Flag225)
-- Is_Visible_Child_Unit (Flag116)
@ -5305,6 +5312,7 @@ package Einfo is
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Private_Primitive (Flag245) (non-generic case only)
-- Is_Pure (Flag44)
-- Is_Thunk (Flag225)
-- Is_Valued_Procedure (Flag127)
@ -5974,6 +5982,7 @@ package Einfo is
function Is_Primitive_Wrapper (Id : E) return B;
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Private_Primitive (Id : E) return B;
function Is_Protected_Interface (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
@ -6538,6 +6547,7 @@ package Einfo is
procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Private_Primitive (Id : E; V : B := True);
procedure Set_Is_Protected_Interface (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
@ -7216,6 +7226,7 @@ package Einfo is
pragma Inline (Is_Primitive_Wrapper);
pragma Inline (Is_Private_Composite);
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Primitive);
pragma Inline (Is_Private_Type);
pragma Inline (Is_Protected_Interface);
pragma Inline (Is_Protected_Type);
@ -7609,6 +7620,7 @@ package Einfo is
pragma Inline (Set_Is_Primitive_Wrapper);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Private_Primitive);
pragma Inline (Set_Is_Protected_Interface);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);

1050
gcc/ada/exp_ch9.adb
View file

File diff suppressed because it is too large Load diff

12
gcc/ada/exp_ch9.ads
View file

@ -153,6 +153,18 @@ package Exp_Ch9 is
-- aggregate. It replaces the call to Init (Args) done by
-- Build_Task_Allocate_Block.
function Build_Wrapper_Spec
(Loc : Source_Ptr;
Subp_Id : Entity_Id;
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id;
-- Ada 2005 (AI-345): Build the specification of a primitive operation
-- associated with a protected or task type. This is required to implement
-- dispatching calls through interfaces. Subp_Id is the primitive to be
-- wrapped, Obj_Typ is the type of the newly added formal parameter to
-- handle object notation, Formals are the original entry formals that
-- will be explicitly replicated.
function Concurrent_Ref (N : Node_Id) return Node_Id;
-- Given the name of a concurrent object (task or protected object), or
-- the name of an access to a concurrent object, this function returns an

129
gcc/ada/sem_ch3.adb
View file

@ -31,6 +31,7 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Tss; use Exp_Tss;
@ -15811,48 +15812,117 @@ package body Sem_Ch3 is
-- If the private view was tagged, copy the new primitive operations
-- from the private view to the full view.
-- Note: Subprograms covering interface primitives were previously
-- propagated to the full view by Derive_Progenitor_Primitives
if Is_Tagged_Type (Full_T)
and then not Is_Concurrent_Type (Full_T)
then
if Is_Tagged_Type (Full_T) then
declare
Priv_List : Elist_Id;
Full_List : constant Elist_Id := Primitive_Operations (Full_T);
P1, P2 : Elmt_Id;
Disp_Typ : Entity_Id;
Full_List : Elist_Id;
Prim : Entity_Id;
D_Type : Entity_Id;
Prim_Elmt : Elmt_Id;
Priv_List : Elist_Id;
function Contains
(E : Entity_Id;
L : Elist_Id) return Boolean;
-- Determine whether list L contains element E
--------------
-- Contains --
--------------
function Contains
(E : Entity_Id;
L : Elist_Id) return Boolean
is
List_Elmt : Elmt_Id;
begin
List_Elmt := First_Elmt (L);
while Present (List_Elmt) loop
if Node (List_Elmt) = E then
return True;
end if;
Next_Elmt (List_Elmt);
end loop;
return False;
end Contains;
-- Start of processing
begin
if Is_Tagged_Type (Priv_T) then
Priv_List := Primitive_Operations (Priv_T);
Prim_Elmt := First_Elmt (Priv_List);
P1 := First_Elmt (Priv_List);
while Present (P1) loop
Prim := Node (P1);
-- In the case of a concurrent type completing a private tagged
-- type, primivies may have been declared in between the two
-- views. These subprograms need to be wrapped the same way
-- entries and protected procedures are handled because they
-- cannot be directly shared by the two views.
-- Transfer explicit primitives, not those inherited from
-- parent of partial view, which will be re-inherited on
-- the full view.
if Is_Concurrent_Type (Full_T) then
declare
Conc_Typ : constant Entity_Id :=
Corresponding_Record_Type (Full_T);
Loc : constant Source_Ptr := Sloc (Conc_Typ);
Curr_Nod : Node_Id := Parent (Conc_Typ);
Wrap_Spec : Node_Id;
if Comes_From_Source (Prim) then
P2 := First_Elmt (Full_List);
while Present (P2) and then Node (P2) /= Prim loop
Next_Elmt (P2);
begin
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if Comes_From_Source (Prim)
and then not Is_Abstract_Subprogram (Prim)
then
Wrap_Spec :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Wrapper_Spec (Loc,
Subp_Id => Prim,
Obj_Typ => Conc_Typ,
Formals =>
Parameter_Specifications (
Parent (Prim))));
Insert_After (Curr_Nod, Wrap_Spec);
Curr_Nod := Wrap_Spec;
Analyze (Wrap_Spec);
end if;
Next_Elmt (Prim_Elmt);
end loop;
-- If not found, that is a new one
return;
end;
if No (P2) then
-- For non-concurrent types, transfer explicit primitives, but
-- omit those inherited from the parent of the private view
-- since they will be re-inherited later on.
else
Full_List := Primitive_Operations (Full_T);
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if Comes_From_Source (Prim)
and then not Contains (Prim, Full_List)
then
Append_Elmt (Prim, Full_List);
end if;
end if;
Next_Elmt (P1);
end loop;
Next_Elmt (Prim_Elmt);
end loop;
end if;
-- Untagged private view
else
Full_List := Primitive_Operations (Full_T);
-- In this case the partial view is untagged, so here we locate
-- all of the earlier primitives that need to be treated as
-- dispatching (those that appear between the two views). Note
@ -15871,10 +15941,9 @@ package body Sem_Ch3 is
or else
Ekind (Prim) = E_Function
then
Disp_Typ := Find_Dispatching_Type (Prim);
D_Type := Find_Dispatching_Type (Prim);
if D_Type = Full_T
if Disp_Typ = Full_T
and then (Chars (Prim) /= Name_Op_Ne
or else Comes_From_Source (Prim))
then
@ -15887,13 +15956,13 @@ package body Sem_Ch3 is
end if;
elsif Is_Dispatching_Operation (Prim)
and then D_Type /= Full_T
and then Disp_Typ /= Full_T
then
-- Verify that it is not otherwise controlled by a
-- formal or a return value of type T.
Check_Controlling_Formals (D_Type, Prim);
Check_Controlling_Formals (Disp_Typ, Prim);
end if;
end if;

215
gcc/ada/sem_ch6.adb
View file

@ -1306,6 +1306,17 @@ package body Sem_Ch6 is
-- If pragma does not appear after the body, check whether there is
-- an inline pragma before any local declarations.
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
-- mechanism is used to find the corresponding spec of the primitive
-- body.
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
-- type that implements an interface and has a private view.
procedure Set_Trivial_Subprogram (N : Node_Id);
-- Sets the Is_Trivial_Subprogram flag in both spec and body of the
-- subprogram whose body is being analyzed. N is the statement node
@ -1457,6 +1468,128 @@ package body Sem_Ch6 is
end if;
end Check_Inline_Pragma;
-----------------------
-- Disambiguate_Spec --
-----------------------
function Disambiguate_Spec return Entity_Id is
Priv_Spec : Entity_Id;
Spec_N : Entity_Id;
procedure Replace_Types (To_Corresponding : Boolean);
-- Depending on the flag, replace the type of formal parameters of
-- Body_Id if it is a concurrent type implementing interfaces with
-- the corresponding record type or the other way around.
procedure Replace_Types (To_Corresponding : Boolean) is
Formal : Entity_Id;
Formal_Typ : Entity_Id;
begin
Formal := First_Formal (Body_Id);
while Present (Formal) loop
Formal_Typ := Etype (Formal);
-- From concurrent type to corresponding record
if To_Corresponding then
if Is_Concurrent_Type (Formal_Typ)
and then Present (Corresponding_Record_Type (Formal_Typ))
and then Present (Interfaces (
Corresponding_Record_Type (Formal_Typ)))
then
Set_Etype (Formal,
Corresponding_Record_Type (Formal_Typ));
end if;
-- From corresponding record to concurrent type
else
if Is_Concurrent_Record_Type (Formal_Typ)
and then Present (Interfaces (Formal_Typ))
then
Set_Etype (Formal,
Corresponding_Concurrent_Type (Formal_Typ));
end if;
end if;
Next_Formal (Formal);
end loop;
end Replace_Types;
-- Start of processing for Disambiguate_Spec
begin
-- Try to retrieve the specification of the body as is. All error
-- messages are suppressed because the body may not have a spec in
-- its current state.
Spec_N := Find_Corresponding_Spec (N, False);
-- It is possible that this is the body of a primitive declared
-- between a private and a full view of a concurrent type. The
-- controlling parameter of the spec carries the concurrent type,
-- not the corresponding record type as transformed by Analyze_
-- Subprogram_Specification. In such cases, we undo the change
-- made by the analysis of the specification and try to find the
-- spec again.
if No (Spec_N) then
-- Restore all references of corresponding record types to the
-- original concurrent types.
Replace_Types (To_Corresponding => False);
Priv_Spec := Find_Corresponding_Spec (N, False);
-- The current body truly belongs to a primitive declared between
-- a private and a full view. We leave the modified body as is,
-- and return the true spec.
if Present (Priv_Spec)
and then Is_Private_Primitive (Priv_Spec)
then
return Priv_Spec;
end if;
-- In case that this is some sort of error, restore the original
-- state of the body.
Replace_Types (To_Corresponding => True);
end if;
return Spec_N;
end Disambiguate_Spec;
-------------------------------------
-- Is_Private_Concurrent_Primitive --
-------------------------------------
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean
is
Formal_Typ : Entity_Id;
begin
if Present (First_Formal (Subp_Id)) then
Formal_Typ := Etype (First_Formal (Subp_Id));
if Is_Concurrent_Record_Type (Formal_Typ) then
Formal_Typ := Corresponding_Concurrent_Type (Formal_Typ);
end if;
-- The type of the first formal is a concurrent tagged type with
-- a private view.
return
Is_Concurrent_Type (Formal_Typ)
and then Is_Tagged_Type (Formal_Typ)
and then Has_Private_Declaration (Formal_Typ);
end if;
return False;
end Is_Private_Concurrent_Primitive;
----------------------------
-- Set_Trivial_Subprogram --
----------------------------
@ -1581,7 +1714,11 @@ package body Sem_Ch6 is
if Nkind (N) = N_Subprogram_Body_Stub
or else No (Corresponding_Spec (N))
then
Spec_Id := Find_Corresponding_Spec (N);
if Is_Private_Concurrent_Primitive (Body_Id) then
Spec_Id := Disambiguate_Spec;
else
Spec_Id := Find_Corresponding_Spec (N);
end if;
-- If this is a duplicate body, no point in analyzing it
@ -2322,6 +2459,22 @@ package body Sem_Ch6 is
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 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 Is_Private_Type (Formal_Typ)
and then not Is_Generic_Actual_Type (Formal_Typ));
end;
end if;
-- Ada 2005 (AI-251): Abstract interface primitives must be abstract
-- or null.
@ -2435,8 +2588,6 @@ package body Sem_Ch6 is
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
Designator : constant Entity_Id := Defining_Entity (N);
Formals : constant List_Id := Parameter_Specifications (N);
Formal : Entity_Id;
Formal_Typ : Entity_Id;
-- Start of processing for Analyze_Subprogram_Specification
@ -2466,21 +2617,29 @@ package body Sem_Ch6 is
-- record, to match the proper signature of an overriding operation.
if Ada_Version >= Ada_05 then
Formal := First_Formal (Designator);
while Present (Formal) loop
Formal_Typ := Etype (Formal);
declare
Formal : Entity_Id;
Formal_Typ : Entity_Id;
Rec_Typ : Entity_Id;
if Is_Concurrent_Type (Formal_Typ)
and then Present (Corresponding_Record_Type (Formal_Typ))
and then Present (Interfaces
(Corresponding_Record_Type (Formal_Typ)))
then
Set_Etype (Formal,
Corresponding_Record_Type (Formal_Typ));
end if;
begin
Formal := First_Formal (Designator);
while Present (Formal) loop
Formal_Typ := Etype (Formal);
Formal := Next_Formal (Formal);
end loop;
if Is_Concurrent_Type (Formal_Typ)
and then Present (Corresponding_Record_Type (Formal_Typ))
then
Rec_Typ := Corresponding_Record_Type (Formal_Typ);
if Present (Interfaces (Rec_Typ)) then
Set_Etype (Formal, Rec_Typ);
end if;
end if;
Next_Formal (Formal);
end loop;
end;
end if;
End_Scope;
@ -5161,7 +5320,10 @@ package body Sem_Ch6 is
-- Find_Corresponding_Spec --
-----------------------------
function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is
function Find_Corresponding_Spec
(N : Node_Id;
Post_Error : Boolean := True) return Entity_Id
is
Spec : constant Node_Id := Specification (N);
Designator : constant Entity_Id := Defining_Entity (Spec);
@ -5205,7 +5367,6 @@ package body Sem_Ch6 is
end if;
if not Has_Completion (E) then
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Corresponding_Spec (N, E);
end if;
@ -5250,14 +5411,15 @@ package body Sem_Ch6 is
return Empty;
end if;
-- If body already exists, this is an error unless the
-- previous declaration is the implicit declaration of
-- a derived subprogram, or this is a spurious overloading
-- in an instance.
-- If the body already exists, then this is an error unless
-- the previous declaration is the implicit declaration of a
-- derived subprogram, or this is a spurious overloading in an
-- instance.
elsif No (Alias (E))
and then not Is_Intrinsic_Subprogram (E)
and then not In_Instance
and then Post_Error
then
Error_Msg_Sloc := Sloc (E);
if Is_Imported (E) then
@ -5269,16 +5431,17 @@ package body Sem_Ch6 is
end if;
end if;
-- Child units cannot be overloaded, so a conformance mismatch
-- between body and a previous spec is an error.
elsif Is_Child_Unit (E)
and then
Nkind (Unit_Declaration_Node (Designator)) = N_Subprogram_Body
and then
Nkind (Parent (Unit_Declaration_Node (Designator))) =
N_Compilation_Unit
N_Compilation_Unit
and then Post_Error
then
-- Child units cannot be overloaded, so a conformance mismatch
-- between body and a previous spec is an error.
Error_Msg_N
("body of child unit does not match previous declaration", N);
end if;

8
gcc/ada/sem_ch6.ads
View file

@ -136,8 +136,8 @@ package Sem_Ch6 is
Get_Inst : Boolean := False) return Boolean;
-- Check that the types of two formal parameters are conforming. In most
-- cases this is just a name comparison, but within an instance it involves
-- generic actual types, and in the presence of anonymous access types
-- it must examine the designated types.
-- generic actual types, and in the presence of anonymous access types it
-- must examine the designated types.
procedure Create_Extra_Formals (E : Entity_Id);
-- For each parameter of a subprogram or entry that requires an additional
@ -147,7 +147,9 @@ package Sem_Ch6 is
-- the end of Subp's parameter list (with each subsequent extra formal
-- being attached to the preceding extra formal).
function Find_Corresponding_Spec (N : Node_Id) return Entity_Id;
function Find_Corresponding_Spec
(N : Node_Id;
Post_Error : Boolean := True) return Entity_Id;
-- Use the subprogram specification in the body to retrieve the previous
-- subprogram declaration, if any.