2005-03-08 Javier Miranda <miranda@adacore.com>

	    Robert Dewar  <dewar@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>
	    Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* atree.ads, atree.adb: Add support for Elist24 field

	* atree.h: Fix wrong definition of Field27
	Add support for Elist16 field
	Add support for Elist24 field

	* einfo.ads, einfo.adb (Abstract_Interfaces,
	Set_Abstract_Interfaces): New subprograms.
	(Abstract_Interface_Alias, Set_Abstract_Interface_Alias): New
	subprograms.
	(Access_Disp_Table, Set_Access_Disp_Table): Modified to handle a list of
	entities rather than a single node.
	(Is_Interface, Set_Is_Interface): New subprogram
	(First_Tag_Component): New syntesized attribute
	(Next_Tag_Component): New synthesized attribute
	(Write_Entity_Flags): Upgraded to write Is_Interface
	(Write_Field24_Name): Upgraded to write Abstract_Interfaces
	(Write_Field25_Name): Upgraded to write Abstract_Interface_Alias
	(Task_Body_Procedure): New subprogram to read this attribute.
	(Set_Task_Body_Procedure): New subprogram to set this attribute.
	(Has_Controlled_Component): Now applies to all entities.
	This is only a documentation change, since it always worked to apply
	this to other than composite types (yielding false), but now this is
	official.
	Update documentation on Must_Be_Byte_Aligned for new spec

	* tbuild.adb, exp_dist.adb, exp_disp.adb, exp_ch3.ads, exp_ch3.adb,
	exp_attr.adb, exp_aggr.adb, exp_ch4.adb, exp_ch5.adb: Upgrade all the
	uses of the Access_Disp_Table attribute to reference the first dispatch
	table associated with a tagged type. As
	part of the implementation of abstract interface types,
	Access_Disp_Table has been redefined to contain a list of dispatch
	tables (rather than a single dispatch table).
	Similarly, upgrade all the references to Tag_Component by the
	new attribute First_Tag_Component.
	(Find_Inherited_TSS): Moved to exp_tss.
	Clean up test in Expand_N_Object_Declaration for cases
	where we need to do a separate assignment of the initial value.
	(Expand_N_Object_Declaration): If the expression in the
	declaration of a tagged type is an aggregate, no need to generate an
	additional tag assignment.
	(Freeze_Type): Now a function that returns True if the N_Freeze_Entity
	is to be deleted.
	Bit packed array ops are only called if operands are known to be
	aligned.
	(Component_Equality): When returning an N_Raise_Program_Error statement,
	ensure that its Etype is set to Empty to avoid confusing GIGI (which
	expects that only expressions have a bona fide type).
	(Make_Tag_Ctrl_Assignment): Use Build_Actual_Subtype to correctly
	determine the amount of data to be copied.

	* par.adb (P_Interface_Type_Definition): New subprogram that parses the
	new syntax rule of Ada 2005 interfaces (for AI-251 and AI-345):
	    INTERFACE_TYPE_DEFINITION ::=
	      [limited | task | protected | synchronized] interface
	        [AND interface_list]

	* par-ch3.adb (P_Type_Declaration): Modified to give support to
	interfaces.
	(P_Derived_Type_Def_Or_Private_Ext_Decl): Modified to give support to
	interfaces.
	(P_Interface_Type_Definition): New subprogram that parses the new
	syntax rule of Ada 2005 interfaces
	(P_Identifier_Declarations): fix two occurrences of 'RENAMES' in error
	messages by the correct RENAMES (quotes removed).

	* sem_prag.adb: Upgrade all the references to Tag_Component by the new
	attribute First_Tag_Component.

	* sinfo.ads, sinfo.adb: Remove OK_For_Stream flag, not used, not needed
	(Interface_List, Set_Interface_List): New subprograms.
	(Interface_Present, Set_Interface_Present): New subprograms.
	(Limited_Present, Set_Limited_Present): Available also in derived
	type definition nodes.
	(Protected_Present, Set_Protected_Present): Available also in
	record type definition and
	derived type definition nodes.
	(Synchronized_Present, Set_Synchronized_Present): New subprograms.
	(Task_Present, Set_Task_Present): New subprogram.
	(Task_Body_Procedure): Removed.
	(Set_Task_Body_Procedure): Removed.
	These subprogram have been removed because the attribute
	Task_Body_Procedure has been moved to the corresponding task type
	or task subtype entity to leave a field free to store the list
	of interfaces implemented by a task (for AI-345)
	Add Expression field to N_Raise_Statement node for Ada 2005 AI-361
	(Null_Exclusion_Present): Change to Flag11, to avoid conflict with
	expression flag Do_Range_Check
	(Exception_Junk): Change to Flag7 to accomodate above change
	(Box_Present, Default_Name, Specification, Set_Box_Present,
	Set_Default_Name, Set_Specification): Expand the expression
	"X in N_Formal_Subprogram_Declaration" into the corresponding
	two comparisons. Required to use the csinfo tool.

	* exp_ch11.adb (Expand_N_Raise_Statement): Deal with case where
	"with string" given.

        * sem_ch11.adb (Analyze_Raise_Statement): Handle case where string
        expression given.

	* par-ch11.adb (P_Raise_Statement): Recognize with string expression
	in 2005 mode

	* exp_ch9.adb (Build_Task_Proc_Specification): Modified to use entity
	attribute Task_Body_Procedure rather than the old semantic field that
	was available in the task_type_declaration node.

	* par-ch12.adb (P_Formal_Type_Definition): Modified to handle formal
	interface type definitions.
	(P_Formal_Derived_Type_Definition): Modified to handle the list of
	interfaces.

	* par-ch9.adb (P_Task): Modified to handle the list of interfaces in a
	task type declaration.
	(P_Protected): Modified to handle the list of interfaces in a
	protected type declaration.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@96489 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 123 insertions, 13 deletions

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 8606bf0958a..900b69a7e2b 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -129,7 +129,7 @@ package body Einfo is
    --    String_Literal_Low_Bound        Node15
    --    Shared_Var_Read_Proc            Node15
 
-   --    Access_Disp_Table               Node16
+   --    Access_Disp_Table               Elist16
    --    Cloned_Subtype                  Node16
    --    DTC_Entity                      Node16
    --    Entry_Formal                    Node16
@@ -210,9 +210,13 @@ package body Einfo is
    --    Protected_Operation             Node23
 
    --    Obsolescent_Warning             Node24
+   --    Task_Body_Procedure             Node24
+   --    Abstract_Interfaces             Node24
+
+   --    Abstract_Interface_Alias        Node25
 
-   --    (unused)                        Node25
    --    (unused)                        Node26
+
    --    (unused)                        Node27
 
    ---------------------------------------------
@@ -428,8 +432,8 @@ package body Einfo is
    --    Must_Be_On_Byte_Boundary       Flag183
    --    Has_Stream_Size_Clause         Flag184
    --    Is_Ada_2005                    Flag185
+   --    Is_Interface                   Flag186
 
-   --    (unused)                       Flag186
    --    (unused)                       Flag187
    --    (unused)                       Flag188
    --    (unused)                       Flag189
@@ -494,15 +498,31 @@ package body Einfo is
    -- Attribute Access Functions --
    --------------------------------
 
+   function Abstract_Interfaces (Id : E) return L is
+   begin
+      pragma Assert (Ekind (Id) = E_Record_Type
+                       or else Ekind (Id) = E_Record_Subtype
+                       or else Ekind (Id) = E_Record_Type_With_Private
+                       or else Ekind (Id) = E_Record_Subtype_With_Private);
+      return Elist24 (Id);
+   end Abstract_Interfaces;
+
+   function Abstract_Interface_Alias (Id : E) return E is
+   begin
+      pragma Assert
+        (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
+      return Node25 (Id);
+   end Abstract_Interface_Alias;
+
    function Accept_Address (Id : E) return L is
    begin
       return Elist21 (Id);
    end Accept_Address;
 
-   function Access_Disp_Table (Id : E) return E is
+   function Access_Disp_Table (Id : E) return L is
    begin
       pragma Assert (Is_Tagged_Type (Id));
-      return Node16 (Implementation_Base_Type (Id));
+      return Elist16 (Implementation_Base_Type (Id));
    end Access_Disp_Table;
 
    function Actual_Subtype (Id : E) return E is
@@ -1551,6 +1571,16 @@ package body Einfo is
       return Flag11 (Id);
    end Is_Inlined;
 
+   function Is_Interface (Id : E) return B is
+   begin
+      pragma Assert (Ekind (Id) = E_Record_Type
+                       or else Ekind (Id) = E_Record_Subtype
+                       or else Ekind (Id) = E_Record_Type_With_Private
+                       or else Ekind (Id) = E_Record_Subtype_With_Private
+                       or else Ekind (Id) = E_Class_Wide_Type);
+      return Flag186 (Id);
+   end Is_Interface;
+
    function Is_Instantiated (Id : E) return B is
    begin
       return Flag126 (Id);
@@ -2207,6 +2237,13 @@ package body Einfo is
       return Flag165 (Id);
    end Suppress_Style_Checks;
 
+   function Task_Body_Procedure (Id : E) return N is
+   begin
+      pragma Assert (Ekind (Id) = E_Task_Type
+                      or else Ekind (Id) = E_Task_Subtype);
+      return Node24 (Id);
+   end Task_Body_Procedure;
+
    function Treat_As_Volatile (Id : E) return B is
    begin
       return Flag41 (Id);
@@ -2434,15 +2471,31 @@ package body Einfo is
    -- Attribute Set Procedures --
    ------------------------------
 
+   procedure Set_Abstract_Interfaces (Id : E; V : L) is
+   begin
+      pragma Assert (Ekind (Id) = E_Record_Type
+                       or else Ekind (Id) = E_Record_Subtype
+                       or else Ekind (Id) = E_Record_Type_With_Private
+                       or else Ekind (Id) = E_Record_Subtype_With_Private);
+      Set_Elist24 (Id, V);
+   end Set_Abstract_Interfaces;
+
+   procedure Set_Abstract_Interface_Alias (Id : E; V : E) is
+   begin
+      pragma Assert
+        (Ekind (Id) = E_Procedure or Ekind (Id) = E_Function);
+      Set_Node25 (Id, V);
+   end Set_Abstract_Interface_Alias;
+
    procedure Set_Accept_Address (Id : E; V : L) is
    begin
       Set_Elist21 (Id, V);
    end Set_Accept_Address;
 
-   procedure Set_Access_Disp_Table (Id : E; V : E) is
+   procedure Set_Access_Disp_Table (Id : E; V : L) is
    begin
       pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
-      Set_Node16 (Id, V);
+      Set_Elist16 (Id, V);
    end Set_Access_Disp_Table;
 
    procedure Set_Associated_Final_Chain (Id : E; V : E) is
@@ -3527,6 +3580,15 @@ package body Einfo is
       Set_Flag11 (Id, V);
    end Set_Is_Inlined;
 
+   procedure Set_Is_Interface (Id : E; V : B := True) is
+   begin
+      pragma Assert (Ekind (Id) = E_Record_Type
+                       or else Ekind (Id) = E_Record_Subtype
+                       or else Ekind (Id) = E_Record_Type_With_Private
+                       or else Ekind (Id) = E_Record_Subtype_With_Private);
+      Set_Flag186 (Id, V);
+   end Set_Is_Interface;
+
    procedure Set_Is_Instantiated (Id : E; V : B := True) is
    begin
       Set_Flag126 (Id, V);
@@ -4194,6 +4256,13 @@ package body Einfo is
       Set_Flag165 (Id, V);
    end Set_Suppress_Style_Checks;
 
+   procedure Set_Task_Body_Procedure (Id : E; V : N) is
+   begin
+      pragma Assert (Ekind (Id) = E_Task_Type
+                      or else Ekind (Id) = E_Task_Subtype);
+      Set_Node24 (Id, V);
+   end Set_Task_Body_Procedure;
+
    procedure Set_Treat_As_Volatile (Id : E; V : B := True) is
    begin
       Set_Flag41 (Id, V);
@@ -6039,11 +6108,11 @@ package body Einfo is
       return Kind;
    end Subtype_Kind;
 
-   -------------------
-   -- Tag_Component --
-   -------------------
+   -------------------------
+   -- First_Tag_Component --
+   -------------------------
 
-   function Tag_Component (Id : E) return E is
+   function First_Tag_Component (Id : E) return E is
       Comp : Entity_Id;
       Typ  : Entity_Id := Id;
 
@@ -6070,7 +6139,34 @@ package body Einfo is
       --  No tag component found
 
       return Empty;
-   end Tag_Component;
+   end First_Tag_Component;
+
+   ------------------------
+   -- Next_Tag_Component --
+   ------------------------
+
+   function Next_Tag_Component (Id : E) return E is
+      Comp : Entity_Id;
+      Typ  : constant Entity_Id := Scope (Id);
+
+   begin
+      pragma Assert (Ekind (Id) = E_Component
+                       and then Is_Tagged_Type (Typ));
+
+      Comp := Next_Entity (Id);
+      while Present (Comp) loop
+         if Is_Tag (Comp) then
+            pragma Assert (Chars (Comp) /= Name_uTag);
+            return Comp;
+         end if;
+
+         Comp := Next_Entity (Comp);
+      end loop;
+
+      --  No tag component found
+
+      return Empty;
+   end Next_Tag_Component;
 
    ---------------------
    -- Type_High_Bound --
@@ -6311,6 +6407,7 @@ package body Einfo is
       W ("Is_Imported",                   Flag24  (Id));
       W ("Is_Inlined",                    Flag11  (Id));
       W ("Is_Instantiated",               Flag126 (Id));
+      W ("Is_Interface",                  Flag186 (Id));
       W ("Is_Internal",                   Flag17  (Id));
       W ("Is_Interrupt_Handler",          Flag89  (Id));
       W ("Is_Intrinsic_Subprogram",       Flag64  (Id));
@@ -6939,7 +7036,7 @@ package body Einfo is
               E_Procedure                                =>
             Write_Str ("Alias");
 
-         when E_Record_Type                =>
+         when E_Record_Type                              =>
             Write_Str ("Corresponding_Concurrent_Type");
 
          when E_Entry_Index_Parameter                    =>
@@ -7255,9 +7352,18 @@ package body Einfo is
    procedure Write_Field24_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
+         when E_Record_Type                              |
+              E_Record_Subtype                           |
+              E_Record_Type_With_Private                 |
+              E_Record_Subtype_With_Private              =>
+            Write_Str ("Abstract_Interfaces");
+
          when Subprogram_Kind                            =>
             Write_Str ("Obsolescent_Warning");
 
+         when Task_Kind                                  =>
+            Write_Str ("Task_Body_Procedure");
+
          when others                                     =>
             Write_Str ("Field24??");
       end case;
@@ -7270,6 +7376,10 @@ package body Einfo is
    procedure Write_Field25_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
+         when E_Procedure                                |
+              E_Function                                 =>
+            Write_Str ("Abstract_Interface_Alias");
+
          when others                                     =>
             Write_Str ("Field25??");
       end case;