Commit 5042f726 by Arnaud Charlet

[multiple changes]

2010-09-09  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Is_Progenitor): Relocated to sem_type.
	(Replace_Type): Code cleanup.
	* sem_type.ads, sem_type.adb (Is_Progenitor): Relocated from sem_ch3

2010-09-09  Thomas Quinot  <quinot@adacore.com>

	* exp_ch8.adb: Minor reformatting.

2010-09-09  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch9.adb, einfo.adb, einfo.ads: New attribute
	Corresponding_Protected_Entry.

From-SVN: r164065
parent 3a89c57d
2010-09-09 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Is_Progenitor): Relocated to sem_type.
(Replace_Type): Code cleanup.
* sem_type.ads, sem_type.adb (Is_Progenitor): Relocated from sem_ch3
2010-09-09 Thomas Quinot <quinot@adacore.com>
* exp_ch8.adb: Minor reformatting.
2010-09-09 Ed Schonberg <schonberg@adacore.com>
* exp_ch9.adb, einfo.adb, einfo.ads: New attribute
Corresponding_Protected_Entry.
2010-09-09 Ed Schonberg <schonberg@adacore.com> 2010-09-09 Ed Schonberg <schonberg@adacore.com>
* exp_ch3.adb (Build_Untagged_Equality): Do not set alias of implicit * exp_ch3.adb (Build_Untagged_Equality): Do not set alias of implicit
......
...@@ -149,6 +149,7 @@ package body Einfo is ...@@ -149,6 +149,7 @@ package body Einfo is
-- Alias Node18 -- Alias Node18
-- Corresponding_Concurrent_Type Node18 -- Corresponding_Concurrent_Type Node18
-- Corresponding_Protected_Entry Node18
-- Corresponding_Record_Type Node18 -- Corresponding_Record_Type Node18
-- Delta_Value Ureal18 -- Delta_Value Ureal18
-- Enclosing_Scope Node18 -- Enclosing_Scope Node18
...@@ -723,6 +724,11 @@ package body Einfo is ...@@ -723,6 +724,11 @@ package body Einfo is
return Node13 (Id); return Node13 (Id);
end Corresponding_Equality; end Corresponding_Equality;
function Corresponding_Protected_Entry (Id : E) return E is
begin
return Node18 (Id);
end Corresponding_Protected_Entry;
function Corresponding_Record_Type (Id : E) return E is function Corresponding_Record_Type (Id : E) return E is
begin begin
pragma Assert (Is_Concurrent_Type (Id)); pragma Assert (Is_Concurrent_Type (Id));
...@@ -3109,6 +3115,11 @@ package body Einfo is ...@@ -3109,6 +3115,11 @@ package body Einfo is
Set_Node13 (Id, V); Set_Node13 (Id, V);
end Set_Corresponding_Equality; end Set_Corresponding_Equality;
procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is
begin
Set_Node18 (Id, V);
end Set_Corresponding_Protected_Entry;
procedure Set_Corresponding_Record_Type (Id : E; V : E) is procedure Set_Corresponding_Record_Type (Id : E; V : E) is
begin begin
pragma Assert (Is_Concurrent_Type (Id)); pragma Assert (Is_Concurrent_Type (Id));
...@@ -7648,6 +7659,9 @@ package body Einfo is ...@@ -7648,6 +7659,9 @@ package body Einfo is
when E_Record_Type => when E_Record_Type =>
Write_Str ("Corresponding_Concurrent_Type"); Write_Str ("Corresponding_Concurrent_Type");
when E_Subprogram_Body =>
Write_Str ("Corresponding_Protected_Entry");
when E_Entry_Index_Parameter => when E_Entry_Index_Parameter =>
Write_Str ("Entry_Index_Constant"); Write_Str ("Entry_Index_Constant");
......
...@@ -631,6 +631,10 @@ package Einfo is ...@@ -631,6 +631,10 @@ package Einfo is
-- other function entities, only in implicit inequality routines, -- other function entities, only in implicit inequality routines,
-- where Comes_From_Source is always False. -- where Comes_From_Source is always False.
-- Corresponding_Protected_Entry (Node18)
-- Present in subrogram bodies that implement entries of protected
-- types.
-- Corresponding_Record_Type (Node18) -- Corresponding_Record_Type (Node18)
-- Present in protected and task types and subtypes. References the -- Present in protected and task types and subtypes. References the
-- entity for the corresponding record type constructed by the expander -- entity for the corresponding record type constructed by the expander
...@@ -5765,6 +5769,7 @@ package Einfo is ...@@ -5765,6 +5769,7 @@ package Einfo is
function Corresponding_Concurrent_Type (Id : E) return E; function Corresponding_Concurrent_Type (Id : E) return E;
function Corresponding_Discriminant (Id : E) return E; function Corresponding_Discriminant (Id : E) return E;
function Corresponding_Equality (Id : E) return E; function Corresponding_Equality (Id : E) return E;
function Corresponding_Protected_Entry (Id : E) return E;
function Corresponding_Record_Type (Id : E) return E; function Corresponding_Record_Type (Id : E) return E;
function Corresponding_Remote_Type (Id : E) return E; function Corresponding_Remote_Type (Id : E) return E;
function Current_Use_Clause (Id : E) return E; function Current_Use_Clause (Id : E) return E;
...@@ -6326,6 +6331,7 @@ package Einfo is ...@@ -6326,6 +6331,7 @@ package Einfo is
procedure Set_Corresponding_Concurrent_Type (Id : E; V : E); procedure Set_Corresponding_Concurrent_Type (Id : E; V : E);
procedure Set_Corresponding_Discriminant (Id : E; V : E); procedure Set_Corresponding_Discriminant (Id : E; V : E);
procedure Set_Corresponding_Equality (Id : E; V : E); procedure Set_Corresponding_Equality (Id : E; V : E);
procedure Set_Corresponding_Protected_Entry (Id : E; V : E);
procedure Set_Corresponding_Record_Type (Id : E; V : E); procedure Set_Corresponding_Record_Type (Id : E; V : E);
procedure Set_Corresponding_Remote_Type (Id : E; V : E); procedure Set_Corresponding_Remote_Type (Id : E; V : E);
procedure Set_Current_Use_Clause (Id : E; V : E); procedure Set_Current_Use_Clause (Id : E; V : E);
...@@ -6982,6 +6988,7 @@ package Einfo is ...@@ -6982,6 +6988,7 @@ package Einfo is
pragma Inline (Corresponding_Concurrent_Type); pragma Inline (Corresponding_Concurrent_Type);
pragma Inline (Corresponding_Discriminant); pragma Inline (Corresponding_Discriminant);
pragma Inline (Corresponding_Equality); pragma Inline (Corresponding_Equality);
pragma Inline (Corresponding_Protected_Entry);
pragma Inline (Corresponding_Record_Type); pragma Inline (Corresponding_Record_Type);
pragma Inline (Corresponding_Remote_Type); pragma Inline (Corresponding_Remote_Type);
pragma Inline (Current_Use_Clause); pragma Inline (Current_Use_Clause);
...@@ -7413,6 +7420,7 @@ package Einfo is ...@@ -7413,6 +7420,7 @@ package Einfo is
pragma Inline (Set_Corresponding_Concurrent_Type); pragma Inline (Set_Corresponding_Concurrent_Type);
pragma Inline (Set_Corresponding_Discriminant); pragma Inline (Set_Corresponding_Discriminant);
pragma Inline (Set_Corresponding_Equality); pragma Inline (Set_Corresponding_Equality);
pragma Inline (Set_Corresponding_Protected_Entry);
pragma Inline (Set_Corresponding_Record_Type); pragma Inline (Set_Corresponding_Record_Type);
pragma Inline (Set_Corresponding_Remote_Type); pragma Inline (Set_Corresponding_Remote_Type);
pragma Inline (Set_Current_Use_Clause); pragma Inline (Set_Current_Use_Clause);
......
...@@ -371,8 +371,8 @@ package body Exp_Ch8 is ...@@ -371,8 +371,8 @@ package body Exp_Ch8 is
Typ : constant Entity_Id := Etype (First_Formal (Id)); Typ : constant Entity_Id := Etype (First_Formal (Id));
Decl : Node_Id; Decl : Node_Id;
Body_Id : constant Entity_Id Body_Id : constant Entity_Id :=
:= Make_Defining_Identifier (Sloc (N), Chars (Id)); Make_Defining_Identifier (Sloc (N), Chars (Id));
begin begin
if Is_Record_Type (Typ) if Is_Record_Type (Typ)
...@@ -397,7 +397,8 @@ package body Exp_Ch8 is ...@@ -397,7 +397,8 @@ package body Exp_Ch8 is
Specification => Specification =>
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => Body_Id, Defining_Unit_Name => Body_Id,
Parameter_Specifications => Copy_Parameter_List (Id), Parameter_Specifications =>
Copy_Parameter_List (Id),
Result_Definition => Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)), New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => Empty_List, Declarations => Empty_List,
......
...@@ -2720,6 +2720,10 @@ package body Exp_Ch9 is ...@@ -2720,6 +2720,10 @@ package body Exp_Ch9 is
raise Program_Error; raise Program_Error;
end case; end case;
-- Establish link between subprogram body entity and source entry.
Set_Corresponding_Protected_Entry (Edef, Ent);
-- Create body of entry procedure. The renaming declarations are -- Create body of entry procedure. The renaming declarations are
-- placed ahead of the block that contains the actual entry body. -- placed ahead of the block that contains the actual entry body.
......
...@@ -574,14 +574,6 @@ package body Sem_Ch3 is ...@@ -574,14 +574,6 @@ package body Sem_Ch3 is
-- copying the record declaration for the derived base. In the tagged case -- copying the record declaration for the derived base. In the tagged case
-- the value returned is irrelevant. -- the value returned is irrelevant.
function Is_Progenitor
(Iface : Entity_Id;
Typ : Entity_Id) return Boolean;
-- Determine whether the interface Iface is implemented by Typ. It requires
-- traversing the list of abstract interfaces of the type, as well as that
-- of the ancestor types. The predicate is used to determine when a formal
-- in the signature of an inherited operation must carry the derived type.
function Is_Valid_Constraint_Kind function Is_Valid_Constraint_Kind
(T_Kind : Type_Kind; (T_Kind : Type_Kind;
Constraint_Kind : Node_Kind) return Boolean; Constraint_Kind : Node_Kind) return Boolean;
...@@ -12263,15 +12255,6 @@ package body Sem_Ch3 is ...@@ -12263,15 +12255,6 @@ package body Sem_Ch3 is
Set_Etype (New_Id, Base_Type (Derived_Type)); Set_Etype (New_Id, Base_Type (Derived_Type));
end if; end if;
-- Ada 2005 (AI-251): Handle derivations of abstract interface
-- primitives.
elsif Is_Interface (Etype (Id))
and then not Is_Class_Wide_Type (Etype (Id))
and then Is_Progenitor (Etype (Id), Derived_Type)
then
Set_Etype (New_Id, Derived_Type);
else else
Set_Etype (New_Id, Etype (Id)); Set_Etype (New_Id, Etype (Id));
end if; end if;
...@@ -14951,19 +14934,6 @@ package body Sem_Ch3 is ...@@ -14951,19 +14934,6 @@ package body Sem_Ch3 is
end if; end if;
end Is_Null_Extension; end Is_Null_Extension;
--------------------
-- Is_Progenitor --
--------------------
function Is_Progenitor
(Iface : Entity_Id;
Typ : Entity_Id) return Boolean
is
begin
return Implements_Interface (Typ, Iface,
Exclude_Parents => True);
end Is_Progenitor;
------------------------------ ------------------------------
-- Is_Valid_Constraint_Kind -- -- Is_Valid_Constraint_Kind --
------------------------------ ------------------------------
......
...@@ -2669,6 +2669,18 @@ package body Sem_Type is ...@@ -2669,6 +2669,18 @@ package body Sem_Type is
end if; end if;
end Is_Invisible_Operator; end Is_Invisible_Operator;
--------------------
-- Is_Progenitor --
--------------------
function Is_Progenitor
(Iface : Entity_Id;
Typ : Entity_Id) return Boolean
is
begin
return Implements_Interface (Typ, Iface, Exclude_Parents => True);
end Is_Progenitor;
------------------- -------------------
-- Is_Subtype_Of -- -- Is_Subtype_Of --
------------------- -------------------
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2009, 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -221,6 +221,14 @@ package Sem_Type is ...@@ -221,6 +221,14 @@ package Sem_Type is
-- T1 is a tagged type (not class-wide). Verify that it is one of the -- T1 is a tagged type (not class-wide). Verify that it is one of the
-- ancestors of type T2 (which may or not be class-wide). -- ancestors of type T2 (which may or not be class-wide).
function Is_Progenitor
(Iface : Entity_Id;
Typ : Entity_Id) return Boolean;
-- Determine whether the interface Iface is implemented by Typ. It requires
-- traversing the list of abstract interfaces of the type, as well as that
-- of the ancestor types. The predicate is used to determine when a formal
-- in the signature of an inherited operation must carry the derived type.
function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
-- Checks whether T1 is any subtype of T2 directly or indirectly. Applies -- Checks whether T1 is any subtype of T2 directly or indirectly. Applies
-- only to scalar subtypes??? -- only to scalar subtypes???
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment