From 5042f726c5a4e41d6e52c7dcb21e31259342d311 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 9 Sep 2010 12:07:52 +0200 Subject: [PATCH] [multiple changes] 2010-09-09 Javier Miranda * 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 * exp_ch8.adb: Minor reformatting. 2010-09-09 Ed Schonberg * exp_ch9.adb, einfo.adb, einfo.ads: New attribute Corresponding_Protected_Entry. From-SVN: r164065 --- gcc/ada/ChangeLog | 15 +++++++++++++++ gcc/ada/einfo.adb | 14 ++++++++++++++ gcc/ada/einfo.ads | 8 ++++++++ gcc/ada/exp_ch8.adb | 25 +++++++++++++------------ gcc/ada/exp_ch9.adb | 4 ++++ gcc/ada/sem_ch3.adb | 30 ------------------------------ gcc/ada/sem_type.adb | 12 ++++++++++++ gcc/ada/sem_type.ads | 10 +++++++++- 8 files changed, 75 insertions(+), 43 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fe15868..97aa882 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2010-09-09 Javier Miranda + + * 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 + + * exp_ch8.adb: Minor reformatting. + +2010-09-09 Ed Schonberg + + * exp_ch9.adb, einfo.adb, einfo.ads: New attribute + Corresponding_Protected_Entry. + 2010-09-09 Ed Schonberg * exp_ch3.adb (Build_Untagged_Equality): Do not set alias of implicit diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 15bf858..95dc331 100644 --- a/gcc/ada/einfo.adb +++ b/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"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3c12bba..db19b39 100644 --- a/gcc/ada/einfo.ads +++ b/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); diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index b81fb42..39c0fc6 100644 --- a/gcc/ada/exp_ch8.adb +++ b/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, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 1e9edfe..7d6b0f9 100644 --- a/gcc/ada/exp_ch9.adb +++ b/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. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 3e801ad..7708b8b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/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 -- ------------------------------ diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 0ae2825..3f253fa 100644 --- a/gcc/ada/sem_type.adb +++ b/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 -- ------------------- diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 307674f..83d4bb9 100644 --- a/gcc/ada/sem_type.ads +++ b/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??? -- 2.7.4