atree.adb (Flag231..Flag247): New functions

2007-12-06  Robert Dewar  <dewar@adacore.com>

	* atree.adb (Flag231..Flag247): New functions
	(Set_Flag231..Set_Flag247): New procedures
	(Basic_Set_Convention): Rename Set_Convention to be
	Basic_Set_Convention
	(Nkind_In): New functions
	Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List

	* exp_ch6.adb (Expand_Call): Use new flag Has_Pragma_Inline_Always
	instead
	 of obsolete function Is_Always_Inlined
	(Register_Predefined_DT_Entry): Initialize slots of the second
	secondary dispatch table.
	Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List
	(Expand_N_Function_Call): Remove special provision for stack checking.

	* exp_util.ads, exp_util.adb (Is_Predefined_Dispatching_Operation):
	Include _Disp_Requeue in the list of predefined operations.
	(Find_Interface_ADT): Modified to fulfill the new specification.
	Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List

	* par-ch4.adb, nlists.ads, nlists.adb: 
	Remove Atree.Delete_Tree/Delete_Node and Nlist.Delete_List

	* sinfo.ads, sinfo.adb: (Nkind_In): New functions
	Fix location of flag for unrecognized pragma message

	* sem_ch7.adb: Use Nkind_In

From-SVN: r130820

gcc/ada/exp_util.adb

@@ -1327,7 +1327,7 @@ package body Exp_Util is
 
    function Find_Interface_ADT
      (T     : Entity_Id;
-      Iface : Entity_Id) return Entity_Id
+      Iface : Entity_Id) return Elmt_Id
    is
       ADT   : Elmt_Id;
       Found : Boolean   := False;
@@ -1385,6 +1385,7 @@ package body Exp_Util is
                end if;
 
                Next_Elmt (ADT);
+               Next_Elmt (ADT);
                Next_Elmt (AI_Elmt);
             end loop;
          end if;
@@ -1423,7 +1424,7 @@ package body Exp_Util is
       pragma Assert (Present (Node (ADT)));
       Find_Secondary_Table (Typ);
       pragma Assert (Found);
-      return Node (ADT);
+      return ADT;
    end Find_Interface_ADT;
 
    ------------------------
@@ -2336,14 +2337,31 @@ package body Exp_Util is
 
             when N_And_Then | N_Or_Else =>
                if N = Right_Opnd (P) then
+
+                  --  We are now going to either append the actions to the
+                  --  actions field of the short-circuit operation. We will
+                  --  also analyze the actions now.
+
+                  --  This analysis is really too early, the proper thing would
+                  --  be to just park them there now, and only analyze them if
+                  --  we find we really need them, and to it at the proper
+                  --  final insertion point. However attempting to this proved
+                  --  tricky, so for now we just kill current values before and
+                  --  after the analyze call to make sure we avoid peculiar
+                  --  optimizations from this out of order insertion.
+
+                  Kill_Current_Values;
+
                   if Present (Actions (P)) then
                      Insert_List_After_And_Analyze
-                      (Last (Actions (P)), Ins_Actions);
+                       (Last (Actions (P)), Ins_Actions);
                   else
                      Set_Actions (P, Ins_Actions);
                      Analyze_List (Actions (P));
                   end if;
 
+                  Kill_Current_Values;
+
                   return;
                end if;
 
@@ -2985,11 +3003,12 @@ package body Exp_Util is
            or else TSS_Name  = TSS_Deep_Adjust
            or else TSS_Name  = TSS_Deep_Finalize
            or else (Ada_Version >= Ada_05
-             and then (Chars (E) = Name_uDisp_Asynchronous_Select
-               or else Chars (E) = Name_uDisp_Conditional_Select
-               or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
-               or else Chars (E) = Name_uDisp_Get_Task_Id
-               or else Chars (E) = Name_uDisp_Timed_Select))
+                      and then (Chars (E) = Name_uDisp_Asynchronous_Select
+                        or else Chars (E) = Name_uDisp_Conditional_Select
+                        or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
+                        or else Chars (E) = Name_uDisp_Get_Task_Id
+                        or else Chars (E) = Name_uDisp_Requeue
+                        or else Chars (E) = Name_uDisp_Timed_Select))
          then
             return True;
          end if;
@@ -3459,8 +3478,6 @@ package body Exp_Util is
          elsif Nkind (N) in N_Generic_Instantiation then
             Remove_Dead_Instance (N);
          end if;
-
-         Delete_Tree (N);
       end if;
    end Kill_Dead_Code;
 
@@ -3472,11 +3489,11 @@ package body Exp_Util is
    begin
       W := Warn;
       if Is_Non_Empty_List (L) then
-         loop
-            N := Remove_Head (L);
-            exit when No (N);
+         N := First (L);
+         while Present (N) loop
             Kill_Dead_Code (N, W);
             W := False;
+            Next (N);
          end loop;
       end if;
    end Kill_Dead_Code;

gcc/ada/exp_util.ads

@@ -338,9 +338,10 @@ package Exp_Util is
 
    function Find_Interface_ADT
      (T     : Entity_Id;
-      Iface : Entity_Id) return Entity_Id;
+      Iface : Entity_Id) return Elmt_Id;
    --  Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-   --  return the Access_Disp_Table value of the interface.
+   --  return the element of Access_Disp_Table containing the tag of the
+   --  interface.
 
    function Find_Interface_Tag
      (T     : Entity_Id;
@@ -483,16 +484,16 @@ package Exp_Util is
    --  or is a private type whose completion is such a type.
 
    procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False);
-   --  N represents a node for a section of code that is known to be dead. The
-   --  node is deleted, and any exception handler references and warning
-   --  messages relating to this code are removed. If Warn is True, a warning
-   --  will be output at the start of N indicating the deletion of the code.
+   --  N represents a node for a section of code that is known to be dead. Any
+   --  exception handler references and warning messages relating to this code
+   --  are removed. If Warn is True, a warning will be output at the start of N
+   --  indicating the deletion of the code. Note that the tree for the deleted
+   --  code is left intact so that e.g. cross-reference data is still valid.
 
    procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False);
    --  Like the above procedure, but applies to every element in the given
-   --  list. Each of the entries is removed from the list before killing it.
-   --  If Warn is True, a warning will be output at the start of N indicating
-   --  the deletion of the code.
+   --  list. If Warn is True, a warning will be output at the start of N
+   --  indicating the deletion of the code.
 
    function Known_Non_Negative (Opnd : Node_Id) return Boolean;
    --  Given a node for a subexpression, determines if it represents a value

gcc/ada/nlists.adb

@@ -279,22 +279,6 @@ package body Nlists is
       Append (Node, To);
    end Append_To;
 
-   -----------------
-   -- Delete_List --
-   -----------------
-
-   procedure Delete_List (L : List_Id) is
-      N : Node_Id;
-
-   begin
-      while Is_Non_Empty_List (L) loop
-         N := Remove_Head (L);
-         Delete_Tree (N);
-      end loop;
-
-      --  Should recycle list header???
-   end Delete_List;
-
    -----------
    -- First --
    -----------
@@ -315,7 +299,6 @@ package body Nlists is
 
    function First_Non_Pragma (List : List_Id) return Node_Id is
       N : constant Node_Id := First (List);
-
    begin
       if Nkind (N) /= N_Pragma
            and then
@@ -649,7 +632,6 @@ package body Nlists is
 
    function Last_Non_Pragma (List : List_Id) return Node_Id is
       N : constant Node_Id := Last (List);
-
    begin
       if Nkind (N) /= N_Pragma then
          return N;

gcc/ada/nlists.ads

@@ -333,9 +333,6 @@ package Nlists is
    --  These functions return the addresses of the Next_Node and Prev_Node
    --  tables (used in Back_End for Gigi).
 
-   procedure Delete_List (L : List_Id);
-   --  Removes all elements of the given list, and calls Delete_Tree on each
-
    function p (U : Union_Id) return Node_Id;
    --  This function is intended for use from the debugger, it determines
    --  whether U is a Node_Id or List_Id, and calls the appropriate Parent

gcc/ada/par-ch4.adb

@@ -463,8 +463,6 @@ package body Ch4 is
                   Style.Check_Attribute_Name (False);
                end if;
 
-               Delete_Node (Token_Node);
-
             --  Here for case of attribute designator is not an identifier
 
             else

gcc/ada/sem_ch7.adb

@@ -592,9 +592,9 @@ package body Sem_Ch7 is
                   --  the flag for outer level entities that are not
                   --  imported/exported, and which have no interface name.
 
-                  elsif K = N_Object_Declaration
-                    or else K = N_Exception_Declaration
-                    or else K = N_Subprogram_Declaration
+                  elsif Nkind_In (K, N_Object_Declaration,
+                                     N_Exception_Declaration,
+                                     N_Subprogram_Declaration)
                   then
                      E := Defining_Entity (D);
 
@@ -844,8 +844,8 @@ package body Sem_Ch7 is
          then
             Generate_Reference (Id, Scope (Id), 'k', False);
 
-         elsif Nkind (Unit (Cunit (Main_Unit))) /= N_Subprogram_Body
-           and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
+         elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body,
+                                                       N_Subunit)
          then
             --  If current unit is an ancestor of main unit, generate
             --  a reference to its own parent.
@@ -909,16 +909,16 @@ package body Sem_Ch7 is
             --  with a known_discriminant_part whose full view is an
             --  Unchecked_Union.
 
-            if (Nkind (Decl) = N_Incomplete_Type_Declaration
-                  or else
-                Nkind (Decl) = N_Private_Type_Declaration)
+            if Nkind_In (Decl, N_Incomplete_Type_Declaration,
+                               N_Private_Type_Declaration)
               and then Has_Discriminants (Defining_Identifier (Decl))
               and then Present (Full_View (Defining_Identifier (Decl)))
-              and then Is_Unchecked_Union
-                (Full_View (Defining_Identifier (Decl)))
+              and then
+                Is_Unchecked_Union (Full_View (Defining_Identifier (Decl)))
             then
-               Error_Msg_N ("completion of discriminated partial view" &
-                 " cannot be an Unchecked_Union",
+               Error_Msg_N
+                 ("completion of discriminated partial view "
+                  & "cannot be an Unchecked_Union",
                  Full_View (Defining_Identifier (Decl)));
             end if;
 
@@ -942,8 +942,8 @@ package body Sem_Ch7 is
          while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
             Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
 
-            if (Nkind (Inst_Node) = N_Package_Instantiation
-                  or else Nkind (Inst_Node) = N_Formal_Package_Declaration)
+            if Nkind_In (Inst_Node, N_Package_Instantiation,
+                                    N_Formal_Package_Declaration)
               and then Nkind (Name (Inst_Node)) = N_Expanded_Name
             then
                Inst_Par := Entity (Prefix (Name (Inst_Node)));

gcc/ada/sinfo.adb

@@ -2192,6 +2192,14 @@ package body Sinfo is
       return List2 (N);
    end Pragma_Argument_Associations;
 
+   function Pragma_Identifier
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      return Node4 (N);
+   end Pragma_Identifier;
+
    function Pragmas_After
       (N : Node_Id) return List_Id is
    begin
@@ -4915,6 +4923,14 @@ package body Sinfo is
       Set_List2_With_Parent (N, Val);
    end Set_Pragma_Argument_Associations;
 
+   procedure Set_Pragma_Identifier
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Pragma);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Pragma_Identifier;
+
    procedure Set_Pragmas_After
       (N : Node_Id; Val : List_Id) is
    begin
@@ -5558,4 +5574,120 @@ package body Sinfo is
         UI_From_Int (Int (S) - Int (Sloc (N))));
    end Set_End_Location;
 
+   --------------------------------
+   -- Node_Kind Membership Tests --
+   --------------------------------
+
+   function Nkind_In
+     (T  : Node_Kind;
+      V1 : Node_Kind;
+      V2 : Node_Kind) return Boolean
+   is
+   begin
+      return T = V1 or else
+             T = V2;
+   end Nkind_In;
+
+   function Nkind_In
+     (T  : Node_Kind;
+      V1 : Node_Kind;
+      V2 : Node_Kind;
+      V3 : Node_Kind) return Boolean
+   is
+   begin
+      return T = V1 or else
+             T = V2 or else
+             T = V3;
+   end Nkind_In;
+
+   function Nkind_In
+     (T  : Node_Kind;
+      V1 : Node_Kind;
+      V2 : Node_Kind;
+      V3 : Node_Kind;
+      V4 : Node_Kind) return Boolean
+   is
+   begin
+      return T = V1 or else
+             T = V2 or else
+             T = V3 or else
+             T = V4;
+   end Nkind_In;
+
+   function Nkind_In
+     (T  : Node_Kind;
+      V1 : Node_Kind;
+      V2 : Node_Kind;
+      V3 : Node_Kind;
+      V4 : Node_Kind;
+      V5 : Node_Kind) return Boolean
+   is
+   begin
+      return T = V1 or else
+             T = V2 or else
+             T = V3 or else
+             T = V4 or else
+             T = V5;
+   end Nkind_In;
+
+   function Nkind_In
+     (T  : Node_Kind;
+      V1 : Node_Kind;
+      V2 : Node_Kind;
+      V3 : Node_Kind;
+      V4 : Node_Kind;
+      V5 : Node_Kind;
+      V6 : Node_Kind) return Boolean
+   is
+   begin
+      return T = V1 or else
+             T = V2 or else
+             T = V3 or else
+             T = V4 or else
+             T = V5 or else
+             T = V6;
+   end Nkind_In;
+
+   function Nkind_In
+     (T  : Node_Kind;
+      V1 : Node_Kind;
+      V2 : Node_Kind;
+      V3 : Node_Kind;
+      V4 : Node_Kind;
+      V5 : Node_Kind;
+      V6 : Node_Kind;
+      V7 : Node_Kind) return Boolean
+   is
+   begin
+      return T = V1 or else
+             T = V2 or else
+             T = V3 or else
+             T = V4 or else
+             T = V5 or else
+             T = V6 or else
+             T = V7;
+   end Nkind_In;
+
+   function Nkind_In
+     (T  : Node_Kind;
+      V1 : Node_Kind;
+      V2 : Node_Kind;
+      V3 : Node_Kind;
+      V4 : Node_Kind;
+      V5 : Node_Kind;
+      V6 : Node_Kind;
+      V7 : Node_Kind;
+      V8 : Node_Kind) return Boolean
+   is
+   begin
+      return T = V1 or else
+             T = V2 or else
+             T = V3 or else
+             T = V4 or else
+             T = V5 or else
+             T = V6 or else
+             T = V7 or else
+             T = V8;
+   end Nkind_In;
+
 end Sinfo;