Skip to content

R
riscv-gcc-1
Commit 5042f726 by Arnaud Charlet
Options

[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
Showing with 75 additions and 43 deletions
gcc/ada/ChangeLog
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>
* exp_ch3.adb (Build_Untagged_Equality): Do not set alias of implicit
......
gcc/ada/einfo.adb
......@@ -149,6 +149,7 @@ package body Einfo is
-- Alias Node18
-- Corresponding_Concurrent_Type Node18
-- Corresponding_Protected_Entry Node18
-- Corresponding_Record_Type Node18
-- Delta_Value Ureal18
-- Enclosing_Scope Node18
......@@ -723,6 +724,11 @@ package body Einfo is
return Node13 (Id);
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
begin
pragma Assert (Is_Concurrent_Type (Id));
......@@ -3109,6 +3115,11 @@ package body Einfo is
Set_Node13 (Id, V);
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
begin
pragma Assert (Is_Concurrent_Type (Id));
......@@ -7648,6 +7659,9 @@ package body Einfo is
when E_Record_Type =>
Write_Str ("Corresponding_Concurrent_Type");
when E_Subprogram_Body =>
Write_Str ("Corresponding_Protected_Entry");
when E_Entry_Index_Parameter =>
Write_Str ("Entry_Index_Constant");
......
gcc/ada/einfo.ads
......@@ -631,6 +631,10 @@ package Einfo is
-- other function entities, only in implicit inequality routines,
-- 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)
-- Present in protected and task types and subtypes. References the
-- entity for the corresponding record type constructed by the expander
......@@ -5765,6 +5769,7 @@ package Einfo is
function Corresponding_Concurrent_Type (Id : E) return E;
function Corresponding_Discriminant (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_Remote_Type (Id : E) return E;
function Current_Use_Clause (Id : E) return E;
......@@ -6326,6 +6331,7 @@ package Einfo is
procedure Set_Corresponding_Concurrent_Type (Id : E; V : E);
procedure Set_Corresponding_Discriminant (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_Remote_Type (Id : E; V : E);
procedure Set_Current_Use_Clause (Id : E; V : E);
......@@ -6982,6 +6988,7 @@ package Einfo is
pragma Inline (Corresponding_Concurrent_Type);
pragma Inline (Corresponding_Discriminant);
pragma Inline (Corresponding_Equality);
pragma Inline (Corresponding_Protected_Entry);
pragma Inline (Corresponding_Record_Type);
pragma Inline (Corresponding_Remote_Type);
pragma Inline (Current_Use_Clause);
......@@ -7413,6 +7420,7 @@ package Einfo is
pragma Inline (Set_Corresponding_Concurrent_Type);
pragma Inline (Set_Corresponding_Discriminant);
pragma Inline (Set_Corresponding_Equality);
pragma Inline (Set_Corresponding_Protected_Entry);
pragma Inline (Set_Corresponding_Record_Type);
pragma Inline (Set_Corresponding_Remote_Type);
pragma Inline (Set_Current_Use_Clause);
......
gcc/ada/exp_ch8.adb
......@@ -358,7 +358,7 @@ package body Exp_Ch8 is
end if;
-- Check whether this is a renaming of a predefined equality on an
-- untagged record type (AI05-0123).
-- untagged record type (AI05-0123).
if Is_Entity_Name (Nam)
and then Chars (Entity (Nam)) = Name_Op_Eq
......@@ -370,9 +370,9 @@ package body Exp_Ch8 is
Id : constant Entity_Id := Defining_Entity (N);
Typ : constant Entity_Id := Etype (First_Formal (Id));
Decl : Node_Id;
Body_Id : constant Entity_Id
:= Make_Defining_Identifier (Sloc (N), Chars (Id));
Decl : Node_Id;
Body_Id : constant Entity_Id :=
Make_Defining_Identifier (Sloc (N), Chars (Id));
begin
if Is_Record_Type (Typ)
......@@ -394,14 +394,15 @@ package body Exp_Ch8 is
Set_Has_Delayed_Freeze (Id);
Decl := Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Body_Id,
Parameter_Specifications => Copy_Parameter_List (Id),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence => Empty);
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Body_Id,
Parameter_Specifications =>
Copy_Parameter_List (Id),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence => Empty);
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
......
gcc/ada/exp_ch9.adb
......@@ -2720,6 +2720,10 @@ package body Exp_Ch9 is
raise Program_Error;
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
-- placed ahead of the block that contains the actual entry body.
......
gcc/ada/sem_ch3.adb
......@@ -574,14 +574,6 @@ package body Sem_Ch3 is
-- copying the record declaration for the derived base. In the tagged case
-- 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
(T_Kind : Type_Kind;
Constraint_Kind : Node_Kind) return Boolean;
......@@ -12263,15 +12255,6 @@ package body Sem_Ch3 is
Set_Etype (New_Id, Base_Type (Derived_Type));
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
Set_Etype (New_Id, Etype (Id));
end if;
......@@ -14951,19 +14934,6 @@ package body Sem_Ch3 is
end if;
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 --
------------------------------
......
gcc/ada/sem_type.adb
......@@ -2669,6 +2669,18 @@ package body Sem_Type is
end if;
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 --
-------------------
......
gcc/ada/sem_type.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -221,6 +221,14 @@ package Sem_Type is
-- 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).
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;
-- Checks whether T1 is any subtype of T2 directly or indirectly. Applies
-- 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