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

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.

From-SVN: r96489

1 files changed, 194 insertions, 18 deletions

diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb
index 5da4a3e10e1..d28f1a9a07d 100644
--- a/gcc/ada/par-ch3.adb
+++ b/gcc/ada/par-ch3.adb
@@ -241,12 +241,16 @@ package body Ch3 is
    --    ENUMERATION_TYPE_DEFINITION  | INTEGER_TYPE_DEFINITION
    --  | REAL_TYPE_DEFINITION         | ARRAY_TYPE_DEFINITION
    --  | RECORD_TYPE_DEFINITION       | ACCESS_TYPE_DEFINITION
-   --  | DERIVED_TYPE_DEFINITION
+   --  | DERIVED_TYPE_DEFINITION      | INTERFACE_TYPE_DEFINITION
 
    --  INTEGER_TYPE_DEFINITION ::=
    --    SIGNED_INTEGER_TYPE_DEFINITION
    --    MODULAR_TYPE_DEFINITION
 
+   --  INTERFACE_TYPE_DEFINITION ::=
+   --    [limited | task | protected | synchronized ] interface
+   --      [AND interface_list]
+
    --  Error recovery: can raise Error_Resync
 
    --  Note: The processing for full type declaration, incomplete type
@@ -256,18 +260,19 @@ package body Ch3 is
    --  function handles only declarations starting with TYPE).
 
    function P_Type_Declaration return Node_Id is
-      Type_Loc         : Source_Ptr;
-      Type_Start_Col   : Column_Number;
-      Ident_Node       : Node_Id;
+      Abstract_Present : Boolean;
+      Abstract_Loc     : Source_Ptr;
       Decl_Node        : Node_Id;
       Discr_List       : List_Id;
-      Unknown_Dis      : Boolean;
       Discr_Sloc       : Source_Ptr;
-      Abstract_Present : Boolean;
-      Abstract_Loc     : Source_Ptr;
       End_Labl         : Node_Id;
+      Type_Loc         : Source_Ptr;
+      Type_Start_Col   : Column_Number;
+      Ident_Node       : Node_Id;
+      Is_Derived_Iface : Boolean := False;
+      Unknown_Dis      : Boolean;
 
-      Typedef_Node : Node_Id;
+      Typedef_Node     : Node_Id;
       --  Normally holds type definition, except in the case of a private
       --  extension declaration, in which case it holds the declaration itself
 
@@ -551,12 +556,6 @@ package body Ch3 is
                TF_Semicolon;
                exit;
 
-            when Tok_Private =>
-               Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
-               Scan; -- past PRIVATE
-               TF_Semicolon;
-               exit;
-
             when Tok_Limited =>
                Scan; -- past LIMITED
 
@@ -585,6 +584,18 @@ package body Ch3 is
                   Typedef_Node := P_Record_Definition;
                   Set_Limited_Present (Typedef_Node, True);
 
+               --  Ada 2005 (AI-251): LIMITED INTERFACE
+
+               elsif Token = Tok_Interface then
+                  Typedef_Node := P_Interface_Type_Definition
+                                    (Is_Synchronized => False);
+                  Abstract_Present := True;
+                  Set_Limited_Present (Typedef_Node);
+
+                  if Nkind (Typedef_Node) = N_Derived_Type_Definition then
+                     Is_Derived_Iface := True;
+                  end if;
+
                --  LIMITED PRIVATE is the only remaining possibility here
 
                else
@@ -634,6 +645,55 @@ package body Ch3 is
 
                exit;
 
+            --  Ada 2005 (AI-251): INTERFACE
+
+            when Tok_Interface =>
+               Typedef_Node := P_Interface_Type_Definition
+                                (Is_Synchronized => False);
+               Abstract_Present := True;
+               TF_Semicolon;
+               exit;
+
+            when Tok_Private =>
+               Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
+               Scan; -- past PRIVATE
+               TF_Semicolon;
+               exit;
+
+            --  Ada 2005 (AI-345)
+
+            when Tok_Protected    |
+                 Tok_Synchronized |
+                 Tok_Task         =>
+
+               declare
+                  Saved_Token : constant Token_Type := Token;
+
+               begin
+                  Scan; -- past TASK, PROTECTED or SYNCHRONIZED
+
+                  Typedef_Node := P_Interface_Type_Definition
+                                   (Is_Synchronized => True);
+
+                  case Saved_Token is
+                     when Tok_Task =>
+                        Set_Task_Present         (Typedef_Node);
+
+                     when Tok_Protected =>
+                        Set_Protected_Present    (Typedef_Node);
+
+                     when Tok_Synchronized =>
+                        Set_Synchronized_Present (Typedef_Node);
+
+                     when others =>
+                        pragma Assert (False);
+                        null;
+                  end case;
+               end;
+
+               TF_Semicolon;
+               exit;
+
             --  Anything else is an error
 
             when others =>
@@ -693,6 +753,7 @@ package body Ch3 is
          if Nkind (Typedef_Node) = N_Record_Definition
            or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
                       and then Present (Record_Extension_Part (Typedef_Node)))
+           or else Is_Derived_Iface
          then
             Set_Abstract_Present (Typedef_Node, Abstract_Present);
 
@@ -1407,7 +1468,7 @@ package body Ch3 is
                Acc_Node := P_Access_Definition (Not_Null_Present);
 
                if Token /= Tok_Renames then
-                  Error_Msg_SC ("'RENAMES' expected");
+                  Error_Msg_SC ("RENAMES expected");
                   raise Error_Resync;
                end if;
 
@@ -1463,7 +1524,7 @@ package body Ch3 is
             Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
 
             if Token /= Tok_Renames then
-               Error_Msg_SC ("'RENAMES' expected");
+               Error_Msg_SC ("RENAMES expected");
                raise Error_Resync;
             end if;
 
@@ -1583,11 +1644,12 @@ package body Ch3 is
 
    --  DERIVED_TYPE_DEFINITION ::=
    --    [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
-   --    [RECORD_EXTENSION_PART]
+   --    [[AND interface_list] RECORD_EXTENSION_PART]
 
    --  PRIVATE_EXTENSION_DECLARATION ::=
    --     type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
-   --       [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;
+   --       [abstract] new ancestor_SUBTYPE_INDICATION
+   --       [AND interface_list] with PRIVATE;
 
    --  RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
 
@@ -1605,6 +1667,7 @@ package body Ch3 is
       Typedef_Node     : Node_Id;
       Typedecl_Node    : Node_Id;
       Not_Null_Present : Boolean := False;
+
    begin
       Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
       T_New;
@@ -1619,6 +1682,31 @@ package body Ch3 is
       Set_Subtype_Indication (Typedef_Node,
          P_Subtype_Indication (Not_Null_Present));
 
+      --  Ada 2005 (AI-251): Deal with interfaces
+
+      if Token = Tok_And then
+         Scan; -- past AND
+
+         if Ada_Version < Ada_05 then
+            Error_Msg_SP
+              ("abstract interface is an Ada 2005 extension");
+            Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+         end if;
+
+         Set_Interface_List (Typedef_Node, New_List);
+
+         loop
+            Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
+            exit when Token /= Tok_And;
+            Scan; -- past AND
+         end loop;
+
+         if Token /= Tok_With then
+            Error_Msg_SC ("WITH expected");
+            raise Error_Resync;
+         end if;
+      end if;
+
       --  Deal with record extension, note that we assume that a WITH is
       --  missing in the case of "type X is new Y record ..." or in the
       --  case of "type X is new Y null record".
@@ -3279,6 +3367,94 @@ package body Ch3 is
 
    --  Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
 
+   --------------------------------------
+   -- 3.9.4  Interface Type Definition --
+   --------------------------------------
+
+   --  INTERFACE_TYPE_DEFINITION ::=
+   --    [limited | task | protected | synchronized] interface
+   --      [AND interface_list]
+
+   --  Error recovery: cannot raise Error_Resync
+
+   function P_Interface_Type_Definition
+      (Is_Synchronized : Boolean) return Node_Id
+   is
+      Typedef_Node : Node_Id;
+
+   begin
+      if Ada_Version < Ada_05 then
+         Error_Msg_SP ("abstract interface is an Ada 2005 extension");
+         Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
+      end if;
+
+      Scan; -- past INTERFACE
+
+      --  Ada 2005 (AI-345): In case of synchronized interfaces and
+      --  interfaces with a null list of interfaces we build a
+      --  record_definition node.
+
+      if Is_Synchronized
+        or else Token = Tok_Semicolon
+      then
+         Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
+
+         Set_Abstract_Present  (Typedef_Node);
+         Set_Tagged_Present    (Typedef_Node);
+         Set_Null_Present      (Typedef_Node);
+         Set_Interface_Present (Typedef_Node);
+
+         if Is_Synchronized
+           and then Token = Tok_And
+         then
+            Scan; -- past AND
+            Set_Interface_List (Typedef_Node, New_List);
+
+            loop
+               Append (P_Qualified_Simple_Name,
+                       Interface_List (Typedef_Node));
+               exit when Token /= Tok_And;
+               Scan; -- past AND
+            end loop;
+         end if;
+
+      --  Ada 2005 (AI-251): In case of not-synchronized interfaces that have
+      --  a list of interfaces we build a derived_type_definition node. This
+      --  simplifies the semantic analysis (and hence further mainteinance)
+
+      else
+         if Token /= Tok_And then
+            Error_Msg_AP ("AND expected");
+         else
+            Scan; -- past AND
+         end if;
+
+         Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
+
+         Set_Abstract_Present   (Typedef_Node);
+         Set_Interface_Present  (Typedef_Node);
+         Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
+
+         Set_Record_Extension_Part (Typedef_Node,
+           New_Node (N_Record_Definition, Token_Ptr));
+         Set_Null_Present (Record_Extension_Part (Typedef_Node));
+
+         if Token = Tok_And then
+            Set_Interface_List (Typedef_Node, New_List);
+            Scan; -- past AND
+
+            loop
+               Append (P_Qualified_Simple_Name,
+                       Interface_List (Typedef_Node));
+               exit when Token /= Tok_And;
+               Scan; -- past AND
+            end loop;
+         end if;
+      end if;
+
+      return Typedef_Node;
+   end P_Interface_Type_Definition;
+
    ----------------------------------
    -- 3.10  Access Type Definition --
    ----------------------------------