sinfo.ads, sinfo.adb (Coextensions): New element list for allocators...

2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* sinfo.ads, sinfo.adb (Coextensions): New element list for allocators,
	to chain nested components that are allocators for access discriminants
	of the enclosing object.
	Add N_Push and N_Pop nodes
	New field Exception_Label added
	(Local_Raise_Statements): New field in N_Exception_Handler_Node
	(Local_Raise_Not_OK): New flag in N_Exception_Handler_Node
	(Is_Coextension): New flag for allocators, to mark allocators that
	correspond to access discriminants of dynamically allocated objects.
	(N_Block_Statement): Document the fact that the corresponding entity
	can be an E_Return_Statement.
	(Is_Coextension): New flag for allocators.
	Remove all code for DSP option

	* sprint.ads, sprint.adb: Display basic information for class_wide
	subtypes. Add handling of N_Push and N_Pop nodes

From-SVN: r123600

gcc/ada/sinfo.adb

@@ -380,6 +380,14 @@ package body Sinfo is
       return List1 (N);
    end Choices;
 
+   function Coextensions
+      (N : Node_Id) return Elist_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator);
+      return Elist4 (N);
+   end Coextensions;
+
    function Comes_From_Extended_Return_Statement
      (N : Node_Id) return Boolean is
    begin
@@ -1100,6 +1108,17 @@ package body Sinfo is
       return Flag7 (N);
    end Exception_Junk;
 
+   function Exception_Label
+     (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler
+        or else NT (N).Nkind = N_Push_Constraint_Error_Label
+        or else NT (N).Nkind = N_Push_Program_Error_Label
+        or else NT (N).Nkind = N_Push_Storage_Error_Label);
+      return Node5 (N);
+   end Exception_Label;
+
    function Expansion_Delayed
      (N : Node_Id) return Boolean is
    begin
@@ -1522,6 +1541,14 @@ package body Sinfo is
       return Flag7 (N);
    end Is_Asynchronous_Call_Block;
 
+   function Is_Coextension
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator);
+      return Flag18 (N);
+   end Is_Coextension;
+
    function Is_Component_Left_Opnd
       (N : Node_Id) return Boolean is
    begin
@@ -1740,6 +1767,22 @@ package body Sinfo is
       return List1 (N);
    end Literals;
 
+   function Local_Raise_Not_OK
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      return Flag7 (N);
+   end Local_Raise_Not_OK;
+
+   function Local_Raise_Statements
+      (N : Node_Id) return Elist_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      return Elist1 (N);
+   end Local_Raise_Statements;
+
    function Loop_Actions
       (N : Node_Id) return List_Id is
    begin
@@ -3022,6 +3065,14 @@ package body Sinfo is
       Set_List1_With_Parent (N, Val);
    end Set_Choices;
 
+   procedure Set_Coextensions
+      (N : Node_Id; Val : Elist_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator);
+      Set_Elist4 (N, Val);
+   end Set_Coextensions;
+
    procedure Set_Comes_From_Extended_Return_Statement
      (N : Node_Id; Val : Boolean := True) is
    begin
@@ -3733,6 +3784,17 @@ package body Sinfo is
       Set_Flag7 (N, Val);
    end Set_Exception_Junk;
 
+   procedure Set_Exception_Label
+     (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler
+        or else NT (N).Nkind = N_Push_Constraint_Error_Label
+        or else NT (N).Nkind = N_Push_Program_Error_Label
+        or else NT (N).Nkind = N_Push_Storage_Error_Label);
+      Set_Node5 (N, Val); -- semantic field, no parent set
+   end Set_Exception_Label;
+
    procedure Set_Expansion_Delayed
      (N : Node_Id; Val : Boolean := True) is
    begin
@@ -4155,6 +4217,14 @@ package body Sinfo is
       Set_Flag7 (N, Val);
    end Set_Is_Asynchronous_Call_Block;
 
+   procedure Set_Is_Coextension
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator);
+      Set_Flag18 (N, Val);
+   end Set_Is_Coextension;
+
    procedure Set_Is_Component_Left_Opnd
       (N : Node_Id; Val : Boolean := True) is
    begin
@@ -4373,6 +4443,22 @@ package body Sinfo is
       Set_List1_With_Parent (N, Val);
    end Set_Literals;
 
+   procedure Set_Local_Raise_Not_OK
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      Set_Flag7 (N, Val);
+   end Set_Local_Raise_Not_OK;
+
+   procedure Set_Local_Raise_Statements
+      (N : Node_Id; Val : Elist_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      Set_Elist1 (N, Val);
+   end Set_Local_Raise_Statements;
+
    procedure Set_Loop_Actions
       (N : Node_Id; Val : List_Id) is
    begin

gcc/ada/sprint.adb

@@ -2218,6 +2218,42 @@ package body Sprint is
                Write_Str (", ");
             end if;
 
+         when N_Pop_Constraint_Error_Label =>
+            Write_Indent_Str ("%pop_constraint_error_label");
+
+         when N_Pop_Program_Error_Label =>
+            Write_Indent_Str ("%pop_program_error_label");
+
+         when N_Pop_Storage_Error_Label =>
+            Write_Indent_Str ("%pop_storage_error_label");
+
+         when N_Push_Constraint_Error_Label =>
+            Write_Indent_Str ("%push_constraint_error_label (");
+
+            if Present (Exception_Label (Node)) then
+               Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
+            end if;
+
+            Write_Str (")");
+
+         when N_Push_Program_Error_Label =>
+            Write_Indent_Str ("%push_program_error_label (");
+
+            if Present (Exception_Label (Node)) then
+               Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
+            end if;
+
+            Write_Str (")");
+
+         when N_Push_Storage_Error_Label =>
+            Write_Indent_Str ("%push_storage_error_label (");
+
+            if Present (Exception_Label (Node)) then
+               Write_Name_With_Col_Check (Chars (Exception_Label (Node)));
+            end if;
+
+            Write_Str (")");
+
          when N_Pragma =>
             Write_Indent_Str_Sloc ("pragma ");
             Write_Name_With_Col_Check (Chars (Node));
@@ -3698,7 +3734,8 @@ package body Sprint is
 
                   --  Class-Wide types
 
-                  when E_Class_Wide_Type =>
+                  when E_Class_Wide_Type    |
+                       E_Class_Wide_Subtype =>
                      Write_Header;
                      Write_Name_With_Col_Check (Chars (Etype (Typ)));
                      Write_Str ("'Class");

gcc/ada/sprint.ads

@@ -67,6 +67,8 @@ package Sprint is
    --    Multiply wi Treat_Fixed_As_Integer  x #* y
    --    Multiply wi Rounded_Result          x @* y
    --    Others choice for cleanup           when all others
+   --    Pop exception label                 %pop_xxx_exception_label
+   --    Push exception label                %push_xxx_exception_label (label)
    --    Raise xxx error                     [xxx_error [when cond]]
    --    Raise xxx error with msg            [xxx_error [when cond], "msg"]
    --    Rational literal                    See UR_Write for details