[Ada] remove "with type"

Arnaud Charlet charlet@adacore.com
Mon Jun 11 16:02:00 GMT 2007


Tested on i686-linux, committed on trunk

When an object declaration has an unconstrained nominal subtype, the initial
expression is used to build an actual constrained subtype for it. If the type
is limited there can be no initial expression in Ada95, and therefore limited
types with unknown discriminants do not receive an actual subtype. In Ada2005
it is possible to initialize such an object with a function call. If the
underlying type is unconstrained, we must extend this mechanism to limited
types, in order to build a constrained subtype that is usable by the back-end.

gnat.dg/test_tables.adb must now compile quietly.

If an object O is a packed component that is not directly addressable, then
a renaming of it is handled like a macro by the front-end, and replaced at
every point of use by the expression that denotes it. Such a renaming cannot
be considered free of side effects, because the value of the object may be
changed through the renaming. If the object O is itself the prefix of another
renaming, the object denoted of this later renaming can be affected accidentally
by an assignment to O.

gnat.dg/tfren.adb must execute quietly.

When a with_clause mentions a child unit, we must determine whether the parent
unit is a renaming, in order to create the proper file name for the child, using
the renamed unit as the proper parent name. The code that examines the parent
unit did not account for the case where the parent itself is a child unit, and
failed to recognize that the parent was a renaming, As a result, the file name
for the requested unit was incorrect, and the file for it was not found by the
load procedure.

The following must compile quietly:

package GNOT is
   pragma Pure;
end GNOT;

with Not_System.GNOT.Mumble;
package GNOT.Mumble renames Not_System.GNOT.Mumble;

package Not_System is
   X : Integer;
end Not_System;

package Not_System.GNOT is
   Y : Integer;
end Not_System.GNOT;

package Not_System.GNOT.Mumble is
   Z : Integer;
end Not_System.GNOT.Mumble;

package Not_System.GNOT.Mumble.Dumble is end;

with GNOT.Mumble; use GNOT.Mumble;
with GNOT.Mumble.Dumble; use GNOT.Mumble.Dumble;  --  This is legal!
procedure Main is
begin
   null;
end Main;

Finally, "with type" is a GNAT extension introduced 8 years ago, to handle
mutually recursive types declared in different compilation units. This feature
has been made obsolete by the Limited_With clause of Ada 2005, and With_Type
context clauses are now rejected by the compiler.

2007-06-06  Ed Schonberg  <schonberg@adacore.com>

	* exp_util.ads, exp_util.adb (Expand_Subtype_From_Expr): In Ada2005, an
	object of a limited type can be initialized with a call to a function
	that returns in place. If the limited type has unknown discriminants,
	and the underlying type is a constrained composite type, build an actual
	subtype from the function call, as is done for private types.
	(Side_Effect_Free): An expression that is the renaming of an object or
	whose prefix is the renaming of a object, is not side-effect free
	because it may be assigned through the renaming and its value must be
	captured in a temporary.
	(Has_Controlled_Coextensions): New routine.
	(Expand_Subtype_From_Expr): Do nothing if type is a limited interface,
	as is done for other limited types.
	(Non_Limited_Designated_Type): new predicate.
	(Make_CW_Equivalent_Type): Modified to handle class-wide interface
	objects.
	Remove all handling of with_type clauses.

        * par-ch10.adb: Remove all handling of with_type clauses.

	* lib-load.ads, lib-load.adb (Load_Main_Source): Do not get the
	checksum if the main source could not be parsed.
	(Loat_Unit): When processing a child unit, determine properly whether
	the parent unit is a renaming when the parent is itself a child unit.
	Remove handling of with_type clauses.

	* sinfo.ads, sinfo.adb (Is_Static_Coextension): New function.
	(Set_Is_Static_Coextension): New procedure.
	(Has_Local_Raise): New function
	(Set_Has_Local_Raise): New procedure
	(Renaming_Exception): New field
	(Has_Init_Expression): New flag
	(Delay_Finalize_Attach): Remove because flag is obsolete.
	(Set_Delay_Finalize_Attach): Remove because flag is obsolete.
	Remove all handling of with_type clauses.
	(Exception_Junk): Can now be set in N_Block_Statement

-------------- next part --------------
Index: exp_util.ads
===================================================================
--- exp_util.ads	(revision 124068)
+++ exp_util.ads	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -27,6 +27,7 @@
 --  Package containing utility procedures used throughout the expander
 
 with Exp_Tss; use Exp_Tss;
+with Namet;   use Namet;
 with Rtsfind; use Rtsfind;
 with Sinfo;   use Sinfo;
 with Types;   use Types;
@@ -393,7 +394,7 @@ package Exp_Util is
    --  or not known at all. In the first two cases, Get_Current_Condition will
    --  return with Op set to the appropriate conditional operator (inverted if
    --  the condition is known false), and Val set to the constant value. If the
-   --  condition is not known, then Cond and Val are set for the empty case
+   --  condition is not known, then Op and Val are set for the empty case
    --  (N_Empty and Empty).
    --
    --  The check for whether the condition is true/false unknown depends
@@ -411,6 +412,10 @@ package Exp_Util is
    --  N_Op_Eq), or to determine the result of some other test in other cases
    --  (e.g. no access check required if N_Op_Ne Null).
 
+   function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean;
+   --  Determine whether a record type has anonymous access discriminants with
+   --  a controlled designated type.
+
    function Homonym_Number (Subp : Entity_Id) return Nat;
    --  Here subp is the entity for a subprogram. This routine returns the
    --  homonym number used to disambiguate overloaded subprograms in the same
@@ -520,6 +525,11 @@ package Exp_Util is
    --  caller has to check whether stack checking is actually enabled in order
    --  to guide the expansion (typically of a function call).
 
+   function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id;
+   --  An anonymous access type may designate a limited view. Check whether
+   --  non-limited view is available during expansion, to examine components
+   --  or other characteristics of the full type.
+
    function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean;
    --  This function is used when testing whether or not to replace a reference
    --  to entity E by a known constant value. Such replacement must be done
@@ -532,6 +542,14 @@ package Exp_Util is
    --  address might be captured in a way we do not detect. A value of True is
    --  returned only if the replacement is safe.
 
+   function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean;
+   --  This function is used in processing the assignment of a record or
+   --  indexed component. The argument N is either the left hand or right
+   --  hand side of an assignment, and this function determines if there
+   --  is a record component reference where the record may be bit aligned
+   --  in a manner that causes trouble for the back end (see description
+   --  of Exp_Util.Component_May_Be_Bit_Aligned for further details).
+
    procedure Remove_Side_Effects
      (Exp          : Node_Id;
       Name_Req     : Boolean := False;
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 124068)
+++ exp_util.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -32,11 +32,9 @@ with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Aggr; use Exp_Aggr;
 with Exp_Ch7;  use Exp_Ch7;
-with Hostparm; use Hostparm;
 with Inline;   use Inline;
 with Itypes;   use Itypes;
 with Lib;      use Lib;
-with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
@@ -653,7 +651,7 @@ package body Exp_Util is
          Expr := Make_Function_Call (Loc,
            Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
 
-         if not In_Init_Proc then
+         if not In_Init_Proc and then VM_Target = No_VM then
             Set_Uses_Sec_Stack (Defining_Entity (Fun));
          end if;
       end if;
@@ -1289,11 +1287,35 @@ package body Exp_Util is
       then
          null;
 
-      --  Nothing to be done if the type of the expression is limited, because
-      --  in this case the expression cannot be copied, and its use can only
-      --  be by reference and there is no need for the actual subtype.
+      --  In Ada95, Nothing to be done if the type of the expression is
+      --  limited, because in this case the expression cannot be copied,
+      --  and its use can only be by reference.
+
+      --  In Ada2005, the context can be an object declaration whose expression
+      --  is a function that returns in place. If the nominal subtype has
+      --  unknown discriminants, the call still provides constraints on the
+      --  object, and we have to create an actual subtype from it.
 
-      elsif Is_Limited_Type (Exp_Typ) then
+      --  If the type is class-wide, the expression is dynamically tagged and
+      --  we do not create an actual subtype either. Ditto for an interface.
+
+      elsif Is_Limited_Type (Exp_Typ)
+        and then
+         (Is_Class_Wide_Type (Exp_Typ)
+           or else Is_Interface (Exp_Typ)
+           or else not Has_Unknown_Discriminants (Exp_Typ)
+           or else not Is_Composite_Type (Unc_Type))
+      then
+         null;
+
+      --  For limited interfaces, nothing to be done
+
+      --  This branch may be redundant once the limited interface issue is
+      --  sorted out???
+
+      elsif Is_Interface (Exp_Typ)
+        and then Is_Limited_Interface (Exp_Typ)
+      then
          null;
 
       else
@@ -2106,6 +2128,44 @@ package body Exp_Util is
       end;
    end Get_Current_Value_Condition;
 
+   ---------------------------------
+   -- Has_Controlled_Coextensions --
+   ---------------------------------
+
+   function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is
+      D_Typ : Entity_Id;
+      Discr : Entity_Id;
+
+   begin
+      --  Only consider record types
+
+      if Ekind (Typ) /= E_Record_Type
+        and then Ekind (Typ) /= E_Record_Subtype
+      then
+         return False;
+      end if;
+
+      if Has_Discriminants (Typ) then
+         Discr := First_Discriminant (Typ);
+         while Present (Discr) loop
+            D_Typ := Etype (Discr);
+
+            if Ekind (D_Typ) = E_Anonymous_Access_Type
+              and then
+                (Is_Controlled (Directly_Designated_Type (D_Typ))
+                   or else
+                 Is_Concurrent_Type (Directly_Designated_Type (D_Typ)))
+            then
+               return True;
+            end if;
+
+            Next_Discriminant (Discr);
+         end loop;
+      end if;
+
+      return False;
+   end Has_Controlled_Coextensions;
+
    --------------------
    -- Homonym_Number --
    --------------------
@@ -2725,8 +2785,7 @@ package body Exp_Util is
                N_Variant                                |
                N_Variant_Part                           |
                N_Validate_Unchecked_Conversion          |
-               N_With_Clause                            |
-               N_With_Type_Clause
+               N_With_Clause
             =>
                null;
 
@@ -2755,13 +2814,14 @@ package body Exp_Util is
             P := Parent (N);
          end if;
       end loop;
-
    end Insert_Actions;
 
    --  Version with check(s) suppressed
 
    procedure Insert_Actions
-     (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
+     (Assoc_Node  : Node_Id;
+      Ins_Actions : List_Id;
+      Suppress    : Check_Id)
    is
    begin
       if Suppress = All_Checks then
@@ -2810,7 +2870,8 @@ package body Exp_Util is
       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
 
    begin
-      New_Scope (Cunit_Entity (Main_Unit));
+      Push_Scope (Cunit_Entity (Main_Unit));
+      --  ??? should this be Current_Sem_Unit instead of Main_Unit?
 
       if No (Actions (Aux)) then
          Set_Actions (Aux, New_List (N));
@@ -2831,7 +2892,8 @@ package body Exp_Util is
 
    begin
       if Is_Non_Empty_List (L) then
-         New_Scope (Cunit_Entity (Main_Unit));
+         Push_Scope (Cunit_Entity (Main_Unit));
+         --  ??? should this be Current_Sem_Unit instead of Main_Unit?
 
          if No (Actions (Aux)) then
             Set_Actions (Aux, L);
@@ -3078,14 +3140,7 @@ package body Exp_Util is
 
    function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
    begin
-      --  ??? GCC3 will eventually handle strings with arbitrary alignments,
-      --  but for now the following check must be disabled.
-
-      --  if get_gcc_version >= 3 then
-      --     return False;
-      --  end if;
-
-      --  For renaming case, go to renamed object
+      --  Go to renamed object
 
       if Is_Entity_Name (N)
         and then Is_Object (Entity (N))
@@ -3589,6 +3644,7 @@ package body Exp_Util is
       Loc         : constant Source_Ptr := Sloc (E);
       Root_Typ    : constant Entity_Id  := Root_Type (T);
       List_Def    : constant List_Id    := Empty_List;
+      Comp_List   : constant List_Id    := New_List;
       Equiv_Type  : Entity_Id;
       Range_Type  : Entity_Id;
       Str_Type    : Entity_Id;
@@ -3611,22 +3667,35 @@ package body Exp_Util is
                  Make_Subtype_From_Expr (E, Root_Typ)));
       end if;
 
-      --  subtype rg__xx is Storage_Offset range
-      --                           (Expr'size - typ'size) / Storage_Unit
+      --  Generate the range subtype declaration
 
       Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
 
-      Sizexpr :=
-        Make_Op_Subtract (Loc,
-          Left_Opnd =>
-            Make_Attribute_Reference (Loc,
-              Prefix =>
-                OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
-              Attribute_Name => Name_Size),
-          Right_Opnd =>
-            Make_Attribute_Reference (Loc,
-              Prefix => New_Reference_To (Constr_Root, Loc),
-              Attribute_Name => Name_Object_Size));
+      if not Is_Interface (Root_Typ) then
+         --  subtype rg__xx is
+         --    Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
+
+         Sizexpr :=
+           Make_Op_Subtract (Loc,
+             Left_Opnd =>
+               Make_Attribute_Reference (Loc,
+                 Prefix =>
+                   OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+                 Attribute_Name => Name_Size),
+             Right_Opnd =>
+               Make_Attribute_Reference (Loc,
+                 Prefix => New_Reference_To (Constr_Root, Loc),
+                 Attribute_Name => Name_Object_Size));
+      else
+         --  subtype rg__xx is
+         --    Storage_Offset range 1 .. Expr'size / Storage_Unit
+
+         Sizexpr :=
+           Make_Attribute_Reference (Loc,
+             Prefix =>
+               OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+             Attribute_Name => Name_Size);
+      end if;
 
       Set_Paren_Count (Sizexpr, 1);
 
@@ -3661,7 +3730,7 @@ package body Exp_Util is
                     New_List (New_Reference_To (Range_Type, Loc))))));
 
       --  type Equiv_T is record
-      --    _parent : Tnn;
+      --    [ _parent : Tnn; ]
       --    E : Str_Type;
       --  end Equiv_T;
 
@@ -3682,36 +3751,41 @@ package body Exp_Util is
       Set_Ekind (Equiv_Type, E_Record_Type);
       Set_Parent_Subtype (Equiv_Type, Constr_Root);
 
+      if not Is_Interface (Root_Typ) then
+         Append_To (Comp_List,
+           Make_Component_Declaration (Loc,
+             Defining_Identifier =>
+               Make_Defining_Identifier (Loc, Name_uParent),
+             Component_Definition =>
+               Make_Component_Definition (Loc,
+                 Aliased_Present    => False,
+                 Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
+      end if;
+
+      Append_To (Comp_List,
+        Make_Component_Declaration (Loc,
+          Defining_Identifier =>
+            Make_Defining_Identifier (Loc,
+              Chars => New_Internal_Name ('C')),
+          Component_Definition =>
+            Make_Component_Definition (Loc,
+              Aliased_Present    => False,
+              Subtype_Indication => New_Reference_To (Str_Type, Loc))));
+
       Append_To (List_Def,
         Make_Full_Type_Declaration (Loc,
           Defining_Identifier => Equiv_Type,
-
           Type_Definition =>
             Make_Record_Definition (Loc,
-              Component_List => Make_Component_List (Loc,
-                Component_Items => New_List (
-                  Make_Component_Declaration (Loc,
-                    Defining_Identifier =>
-                      Make_Defining_Identifier (Loc, Name_uParent),
-                    Component_Definition =>
-                      Make_Component_Definition (Loc,
-                        Aliased_Present    => False,
-                        Subtype_Indication =>
-                          New_Reference_To (Constr_Root, Loc))),
-
-                  Make_Component_Declaration (Loc,
-                    Defining_Identifier =>
-                      Make_Defining_Identifier (Loc,
-                        Chars => New_Internal_Name ('C')),
-                    Component_Definition =>
-                      Make_Component_Definition (Loc,
-                        Aliased_Present    => False,
-                        Subtype_Indication =>
-                          New_Reference_To (Str_Type, Loc)))),
+              Component_List =>
+                Make_Component_List (Loc,
+                  Component_Items => Comp_List,
+                  Variant_Part    => Empty))));
 
-                Variant_Part => Empty))));
+      --  Suppress all checks during the analysis of the expanded code
+      --  to avoid the generation of spurious warnings under ZFP run-time.
 
-      Insert_Actions (E, List_Def);
+      Insert_Actions (E, List_Def, Suppress => All_Checks);
       return Equiv_Type;
    end Make_CW_Equivalent_Type;
 
@@ -3839,12 +3913,12 @@ package body Exp_Util is
             EQ_Typ     : Entity_Id := Empty;
 
          begin
-            --  A class-wide equivalent type is not needed when Java_VM
-            --  because the JVM back end handles the class-wide object
+            --  A class-wide equivalent type is not needed when VM_Target
+            --  because the VM back-ends handle the class-wide object
             --  initialization itself (and doesn't need or want the
             --  additional intermediate type to handle the assignment).
 
-            if Expander_Active and then not Java_VM then
+            if Expander_Active and then VM_Target = No_VM then
                EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
             end if;
 
@@ -3952,6 +4026,22 @@ package body Exp_Util is
       return (Res);
    end New_Class_Wide_Subtype;
 
+   --------------------------------
+   -- Non_Limited_Designated_Type --
+   ---------------------------------
+
+   function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
+      Desig : constant Entity_Id := Designated_Type (T);
+   begin
+      if Ekind (Desig) = E_Incomplete_Type
+        and then Present (Non_Limited_View (Desig))
+      then
+         return Non_Limited_View (Desig);
+      else
+         return Desig;
+      end if;
+   end Non_Limited_Designated_Type;
+
    -----------------------------------
    -- OK_To_Do_Constant_Replacement --
    -----------------------------------
@@ -4019,6 +4109,69 @@ package body Exp_Util is
       end if;
    end OK_To_Do_Constant_Replacement;
 
+   ------------------------------------
+   -- Possible_Bit_Aligned_Component --
+   ------------------------------------
+
+   function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
+   begin
+      case Nkind (N) is
+
+         --  Case of indexed component
+
+         when N_Indexed_Component =>
+            declare
+               P    : constant Node_Id   := Prefix (N);
+               Ptyp : constant Entity_Id := Etype (P);
+
+            begin
+               --  If we know the component size and it is less than 64, then
+               --  we are definitely OK. The back end always does assignment
+               --  of misaligned small objects correctly.
+
+               if Known_Static_Component_Size (Ptyp)
+                 and then Component_Size (Ptyp) <= 64
+               then
+                  return False;
+
+               --  Otherwise, we need to test the prefix, to see if we are
+               --  indexing from a possibly unaligned component.
+
+               else
+                  return Possible_Bit_Aligned_Component (P);
+               end if;
+            end;
+
+         --  Case of selected component
+
+         when N_Selected_Component =>
+            declare
+               P    : constant Node_Id   := Prefix (N);
+               Comp : constant Entity_Id := Entity (Selector_Name (N));
+
+            begin
+               --  If there is no component clause, then we are in the clear
+               --  since the back end will never misalign a large component
+               --  unless it is forced to do so. In the clear means we need
+               --  only the recursive test on the prefix.
+
+               if Component_May_Be_Bit_Aligned (Comp) then
+                  return True;
+               else
+                  return Possible_Bit_Aligned_Component (P);
+               end if;
+            end;
+
+         --  If we have neither a record nor array component, it means that we
+         --  have fallen off the top testing prefixes recursively, and we now
+         --  have a stand alone object, where we don't have a problem.
+
+         when others =>
+            return False;
+
+      end case;
+   end Possible_Bit_Aligned_Component;
+
    -------------------------
    -- Remove_Side_Effects --
    -------------------------
@@ -4171,6 +4324,17 @@ package body Exp_Util is
 
          elsif Compile_Time_Known_Value (N) then
             return True;
+
+         --  A variable renaming is not side-effet free, because the
+         --  renaming will function like a macro in the front-end in
+         --  some cases, and an assignment can modify the the component
+         --  designated by N, so we need to create a temporary for it.
+
+         elsif Is_Entity_Name (Original_Node (N))
+           and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
+           and then Ekind (Entity (Original_Node (N))) /= E_Constant
+         then
+            return False;
          end if;
 
          --  For other than entity names and compile time known values,
Index: par-ch10.adb
===================================================================
--- par-ch10.adb	(revision 124068)
+++ par-ch10.adb	(working copy)
@@ -869,22 +869,17 @@ package body Ch10 is
 
             if Token = Tok_Type then
 
-               --  WITH TYPE is an GNAT specific extension
+               --  WITH TYPE is an obsolete GNAT specific extension
 
-               if not Extensions_Allowed then
-                  Error_Msg_SP ("`WITH TYPE` is a 'G'N'A'T extension");
-                  Error_Msg_SP ("\unit must be compiled with -gnatX switch");
-               end if;
+               Error_Msg_SP
+                 ("`WITH TYPE` is an obsolete 'G'N'A'T extension");
+               Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead");
 
                Scan;  -- past TYPE
-               With_Node := New_Node (N_With_Type_Clause, Token_Ptr);
-               Append (With_Node, Item_List);
-               Set_Name (With_Node, P_Qualified_Simple_Name);
 
                T_Is;
 
                if Token = Tok_Tagged then
-                  Set_Tagged_Present (With_Node);
                   Scan;
 
                elsif Token = Tok_Access then
Index: lib-load.ads
===================================================================
--- lib-load.ads	(revision 124068)
+++ lib-load.ads	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -153,6 +153,15 @@ package Lib.Load is
    --  limited-with clause, or some unit in the context of X. It is used to
    --  avoid the check on circular dependency (Ada 2005, AI-50217)
 
+   procedure Change_Main_Unit_To_Spec;
+   --  This procedure is called if the main unit file contains a No_Body pragma
+   --  and no other tokens. The effect is, if possible, to change the main unit
+   --  from the body it references now, to the corresponding spec. This has the
+   --  effect of ignoring the body, which is what we want. If it is impossible
+   --  to successfully make the change, then the call has no effect, and the
+   --  file is unchanged (this will lead to an error complaining about the
+   --  inappropriate No_Body spec).
+
    function Create_Dummy_Package_Unit
      (With_Node : Node_Id;
       Spec_Name : Unit_Name_Type) return Unit_Number_Type;
Index: lib-load.adb
===================================================================
--- lib-load.adb	(revision 124068)
+++ lib-load.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -30,7 +30,6 @@ with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Fname;    use Fname;
 with Fname.UF; use Fname.UF;
-with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
@@ -71,6 +70,69 @@ package body Lib.Load is
    --  This procedure is used to generate error message info lines that
    --  trace the current dependency chain when a load error occurs.
 
+   ------------------------------
+   -- Change_Main_Unit_To_Spec --
+   ------------------------------
+
+   procedure Change_Main_Unit_To_Spec is
+      U : Unit_Record renames Units.Table (Main_Unit);
+      N : File_Name_Type;
+      X : Source_File_Index;
+
+   begin
+      --  Get name of unit body
+
+      Get_Name_String (U.Unit_File_Name);
+
+      --  Note: for the following we should really generalize and consult the
+      --  file name pattern data, but for now we just deal with the common
+      --  naming cases, which is probably good enough in practice ???
+
+      --  Change .adb to .ads
+
+      if Name_Len >= 5
+        and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb"
+      then
+         Name_Buffer (Name_Len) := 's';
+
+      --  Change .2.ada to .1.ada (Rational convention)
+
+      elsif Name_Len >= 7
+        and then Name_Buffer (Name_Len - 5 .. Name_Len) = ".2.ada"
+      then
+         Name_Buffer (Name_Len - 4) := '1';
+
+      --  Change .ada to _.ada (DEC convention)
+
+      elsif Name_Len >= 5
+        and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ada"
+      then
+         Name_Buffer (Name_Len - 3 .. Name_Len + 1) := "_.ada";
+         Name_Len := Name_Len + 1;
+
+      --  No match, don't make the change
+
+      else
+         return;
+      end if;
+
+      --  Try loading the spec
+
+      N := Name_Find;
+      X := Load_Source_File (N);
+
+      --  No change if we did not find the spec
+
+      if X = No_Source_File then
+         return;
+      end if;
+
+      --  Otherwise modify Main_Unit entry to point to spec
+
+      U.Unit_File_Name := N;
+      U.Source_Index := X;
+   end Change_Main_Unit_To_Spec;
+
    -------------------------------
    -- Create_Dummy_Package_Unit --
    -------------------------------
@@ -218,7 +280,8 @@ package body Lib.Load is
    ----------------------
 
    procedure Load_Main_Source is
-      Fname : File_Name_Type;
+      Fname   : File_Name_Type;
+      Version : Word := 0;
 
    begin
       Load_Stack.Increment_Last;
@@ -239,13 +302,17 @@ package body Lib.Load is
          Main_Source_File := Load_Source_File (Fname);
          Current_Error_Source_File := Main_Source_File;
 
+         if Main_Source_File /= No_Source_File then
+            Version := Source_Checksum (Main_Source_File);
+         end if;
+
          Units.Table (Main_Unit) := (
            Cunit           => Empty,
            Cunit_Entity    => Empty,
            Dependency_Num  => 0,
            Dynamic_Elab    => False,
            Error_Location  => No_Location,
-           Expected_Unit   => No_Name,
+           Expected_Unit   => No_Unit_Name,
            Fatal_Error     => False,
            Generate_Code   => False,
            Has_RACW        => False,
@@ -256,8 +323,8 @@ package body Lib.Load is
            Serial_Number   => 0,
            Source_Index    => Main_Source_File,
            Unit_File_Name  => Fname,
-           Unit_Name       => No_Name,
-           Version         => Source_Checksum (Main_Source_File));
+           Unit_Name       => No_Unit_Name,
+           Version         => Version);
       end if;
    end Load_Main_Source;
 
@@ -303,13 +370,10 @@ package body Lib.Load is
          --  If parent is a renaming, then we use the renamed package as
          --  the actual parent for the subsequent load operation.
 
-         if Nkind (Parent (Cunit_Entity (Unump))) =
-           N_Package_Renaming_Declaration
-         then
+         if Nkind (Unit (Cunit (Unump))) = N_Package_Renaming_Declaration then
             Uname_Actual :=
               New_Child
-                (Load_Name,
-                 Get_Unit_Name (Name (Parent (Cunit_Entity (Unump)))));
+                (Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump)))));
 
             --  Save the renaming entity, to establish its visibility when
             --  installing the context. The implicit with is on this entity,
@@ -382,7 +446,7 @@ package body Lib.Load is
       --  Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
 
       if Present (Error_Node)
-        and then Unit_Name (Main_Unit) /= No_Name
+        and then Unit_Name (Main_Unit) /= No_Unit_Name
       then
          --  It seems like In_Extended_Main_Source_Unit (Error_Node) would
          --  do the trick here, but that's wrong, it is much too early to
@@ -408,9 +472,6 @@ package body Lib.Load is
             --  If the load is called from a with_type clause, the error
             --  node is correct.
 
-            elsif Nkind (Parent (Error_Node)) = N_With_Type_Clause then
-               Load_Msg_Sloc := Sloc (Error_Node);
-
             --  Otherwise, check for the subunit case, and if so, consider
             --  we have a match if one name is a prefix of the other name.
 
@@ -474,14 +535,13 @@ package body Lib.Load is
 
                if Present (Error_Node) then
                   if Is_Predefined_File_Name (Fname) then
-                     Error_Msg_Name_1 := Uname_Actual;
+                     Error_Msg_Unit_1 := Uname_Actual;
                      Error_Msg
-                       ("% is not a language defined unit", Load_Msg_Sloc);
+                       ("$$ is not a language defined unit", Load_Msg_Sloc);
                   else
-                     Error_Msg_Name_1 := Fname;
+                     Error_Msg_File_1 := Fname;
                      Error_Msg_Unit_1 := Uname_Actual;
-                     Error_Msg
-                       ("File{ does not contain unit$", Load_Msg_Sloc);
+                     Error_Msg ("File{ does not contain unit$", Load_Msg_Sloc);
                   end if;
 
                   Write_Dependency_Chain;
@@ -604,11 +664,10 @@ package body Lib.Load is
             if Corr_Body /= No_Unit
               and then Spec_Is_Irrelevant (Unum, Corr_Body)
             then
-               Error_Msg_Name_1 := Unit_File_Name (Corr_Body);
+               Error_Msg_File_1 := Unit_File_Name (Corr_Body);
                Error_Msg
-                 ("cannot compile subprogram in file {!",
-                  Load_Msg_Sloc);
-               Error_Msg_Name_1 := Unit_File_Name (Unum);
+                 ("cannot compile subprogram in file {!", Load_Msg_Sloc);
+               Error_Msg_File_1 := Unit_File_Name (Unum);
                Error_Msg
                  ("\incorrect spec in file { must be removed first!",
                   Load_Msg_Sloc);
@@ -655,12 +714,12 @@ package body Lib.Load is
 
                   Check_Restricted_Unit (Load_Name, Error_Node);
 
-                  Error_Msg_Name_1 := Uname_Actual;
+                  Error_Msg_Unit_1 := Uname_Actual;
                   Error_Msg
-                    ("% is not a predefined library unit", Load_Msg_Sloc);
+                    ("$$ is not a predefined library unit", Load_Msg_Sloc);
 
                else
-                  Error_Msg_Name_1 := Fname;
+                  Error_Msg_File_1 := Fname;
                   Error_Msg ("file{ not found", Load_Msg_Sloc);
                end if;
 
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 124068)
+++ sinfo.ads	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -48,6 +48,7 @@
 --  WARNING: Several files are automatically generated from this package.
 --  See below for details.
 
+with Namet;  use Namet;
 with Types;  use Types;
 with Uintp;  use Uintp;
 with Urealp; use Urealp;
@@ -462,10 +463,6 @@ package Sinfo is
    --    already been analyzed, both for efficiency and functional correctness
    --    reasons.
 
-   --  Coextensions (Elist4-Sem)
-   --    Present in allocators nodes. Points to list of allocators for the
-   --    access discriminants of the allocated object,
-
    --  Comes_From_Source (Flag2)
    --    This flag is on for any nodes built by the scanner or parser from the
    --    source program, and off for any nodes built by the analyzer or
@@ -485,7 +482,9 @@ package Sinfo is
    --    points to a list of raise nodes, which are calls to a routine to raise
    --    an exception. These are raise nodes which can be optimized into gotos
    --    if the handler turns out to meet the conditions which permit this
-   --    transformation.
+   --    transformation. Note that this does NOT include instances of the
+   --    N_Raise_xxx_Error nodes since the transformation of these nodes is
+   --    handled by the back end (using the N_Push/N_Pop mechanism).
 
    --  Has_Dynamic_Length_Check (Flag10-Sem)
    --    This flag is present on all nodes. It is set to indicate that one of
@@ -499,6 +498,13 @@ package Sinfo is
    --    has been inserted at the flagged node. This is used to avoid the
    --    generation of duplicate checks.
 
+   --  Has_Local_Raise (Flag8-Sem)
+   --    Present in exception handler nodes. Set if the handler can be entered
+   --    via a local raise that gets transformed to a goto statement. This will
+   --    always be set if Local_Raise_Statements is non-empty, but can also be
+   --    set as a result of generation of N_Raise_xxx nodes, or flags set in
+   --    nodes requiring generation of back end checks.
+
    ------------------------------------
    -- Description of Semantic Fields --
    ------------------------------------
@@ -660,6 +666,10 @@ package Sinfo is
    --    attribute definition clause is given, rather than testing this at the
    --    freeze point.
 
+   --  Coextensions (Elist4-Sem)
+   --    Present in allocators nodes. Points to list of allocators for the
+   --    access discriminants of the allocated object.
+
    --  Comes_From_Extended_Return_Statement (Flag18-Sem)
    --    Present in N_Return_Statement nodes. True if this node was
    --    constructed as part of the expansion of an
@@ -767,14 +777,6 @@ package Sinfo is
    --    for the default expression). Default_Expression is used for
    --    conformance checking.
 
-   --  Delay_Finalize_Attach (Flag14-Sem)
-   --    This flag is present in an N_Object_Declaration node. If it is set,
-   --    then in the case of a controlled type being declared and initialized,
-   --    the normal code for attaching the result to the appropriate local
-   --    finalization list is suppressed. This is used for functions that
-   --    return controlled types without using the secondary stack, where it is
-   --    the caller who must do the attachment.
-
    --  Discr_Check_Funcs_Built (Flag11-Sem)
    --    This flag is present in N_Full_Type_Declaration nodes. It is set when
    --    discriminant checking functions are constructed. The purpose is to
@@ -950,7 +952,7 @@ package Sinfo is
    --    points to an essentially arbitrary choice from the possible set of
    --    types.
 
-   --  Exception_Junk (Flag7-Sem)
+   --  Exception_Junk (Flag8-Sem)
    --    This flag is set in a various nodes appearing in a statement sequence
    --    to indicate that the corresponding node is an artifact of the
    --    generated code for exception handling, and should be ignored when
@@ -1211,6 +1213,10 @@ package Sinfo is
    --    handler to make sure that the associated protected object is unlocked
    --    when the subprogram completes.
 
+   --  Is_Static_Coextension (Flag14-Sem)
+   --    Present in N_Allocator nodes. Set if the allocator is a coextension
+   --    of an object allocated on the stack rather than the heap.
+
    --  Is_Static_Expression (Flag6-Sem)
    --    Indicates that an expression is a static expression (RM 4.9). See spec
    --    of package Sem_Eval for full details on the use of this flag.
@@ -1482,6 +1488,14 @@ package Sinfo is
    --    to indicate that a use is redundant (and therefore need not be undone
    --    on scope exit).
 
+   --  Renaming_Exception (Node2-Sem)
+   --    Present in N_Exception_Declaration node. Used to point back to the
+   --    exception renaming for an exception declared within a subprogram.
+   --    What happens is that an exception declared in a subprogram is moved
+   --    to the library level with a unique name, and the original exception
+   --    becomes a renaming. This link from the library level exception to the
+   --    renaming declaration allows registering of the proper exception name.
+
    --  Return_Statement_Entity (Node5-Sem)
    --    Present in N_Return_Statement and N_Extended_Return_Statement.
    --    Points to an E_Return_Statement representing the return statement.
@@ -1967,7 +1981,7 @@ package Sinfo is
       --  Null_Exclusion_Present (Flag11)
       --  Subtype_Indication (Node5)
       --  Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
-      --  Exception_Junk (Flag7-Sem)
+      --  Exception_Junk (Flag8-Sem)
 
       -------------------------------
       -- 3.2.2  Subtype Indication --
@@ -2055,6 +2069,13 @@ package Sinfo is
       --  Prev_Ids flags to preserve the original source form as described
       --  in the section on "Handling of Defining Identifier Lists".
 
+      --  The flag Has_Init_Expression is set if an initializing expression
+      --  is present. Normally it is set if and only if Expression contains
+      --  a non-empty value, but there is an exception to this. When the
+      --  initializing expression is an aggregate which requires explicit
+      --  assignments, the Expression field gets set to Empty, but this flag
+      --  is still set, so we don't forget we had an initializing expression.
+
       --  Note: if a range check is required for the initialization
       --  expression then the Do_Range_Check flag is set in the Expression,
       --  with the check being done against the type given by the object
@@ -2091,9 +2112,9 @@ package Sinfo is
       --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
       --  No_Initialization (Flag13-Sem)
       --  Assignment_OK (Flag15-Sem)
-      --  Exception_Junk (Flag7-Sem)
-      --  Delay_Finalize_Attach (Flag14-Sem)
+      --  Exception_Junk (Flag8-Sem)
       --  Is_Subprogram_Descriptor (Flag16-Sem)
+      --  Has_Init_Expression (Flag14)
 
       -------------------------------------
       -- 3.3.1  Defining Identifier List --
@@ -3643,6 +3664,7 @@ package Sinfo is
       --  Procedure_To_Call (Node2-Sem)
       --  Coextensions (Elist4-Sem)
       --  No_Initialization (Flag13-Sem)
+      --  Is_Static_Coextension (Flag14-Sem)
       --  Do_Storage_Check (Flag17-Sem)
       --  Is_Coextension (Flag18-Sem)
       --  plus fields for expression
@@ -3718,7 +3740,7 @@ package Sinfo is
       --  N_Label
       --  Sloc points to <<
       --  Identifier (Node1) direct name of statement identifier
-      --  Exception_Junk (Flag7-Sem)
+      --  Exception_Junk (Flag8-Sem)
 
       -------------------------------
       -- 5.1  Statement Identifier --
@@ -3921,9 +3943,12 @@ package Sinfo is
       --  True. Blocks constructed by the expander usually have no identifier,
       --  and no corresponding entity.
 
-      --  Note well: the block statement created for an extended return
-      --  statement has an entity, and this entity is an E_Return_Statement,
-      --  rather than the usual E_Block.
+      --  Note: the block statement created for an extended return statement
+      --  has an entity, and this entity is an E_Return_Statement, rather than
+      --  the usual E_Block.
+
+      --  Note: Exception_Junk is set for the wrapping blocks created during
+      --  local raise optimization (Exp_Ch11.Expand_Local_Exception_Handlers).
 
       --  N_Block_Statement
       --  Sloc points to DECLARE or BEGIN
@@ -3935,6 +3960,7 @@ package Sinfo is
       --  Has_Created_Identifier (Flag15)
       --  Is_Task_Allocation_Block (Flag6)
       --  Is_Asynchronous_Call_Block (Flag7)
+      --  Exception_Junk (Flag8-Sem)
 
       -------------------------
       -- 5.7  Exit Statement --
@@ -3960,7 +3986,7 @@ package Sinfo is
       --  N_Goto_Statement
       --  Sloc points to GOTO
       --  Name (Node2)
-      --  Exception_Junk (Flag7-Sem)
+      --  Exception_Junk (Flag8-Sem)
 
       ---------------------------------
       -- 6.1  Subprogram Declaration --
@@ -5374,14 +5400,8 @@ package Sinfo is
 
       --  This is a GNAT extension, used to implement mutually recursive
       --  types declared in different packages.
-
-      --  WITH_TYPE_CLAUSE ::=
-      --    with type type_NAME is access | with type type_NAME is tagged
-
-      --  N_With_Type_Clause
-      --  Sloc points to first token of type name
-      --  Name (Node2)
-      --  Tagged_Present (Flag15)
+      --  Note: this is now obsolete. The functionality of this construct
+      --  is now implemented by the Ada 2005 Limited_with_Clause.
 
       ---------------------
       -- 10.2  Body stub --
@@ -5475,6 +5495,7 @@ package Sinfo is
       --  Sloc points to EXCEPTION
       --  Defining_Identifier (Node1)
       --  Expression (Node3-Sem)
+      --  Renaming_Exception (Node2-Sem)
       --  More_Ids (Flag5) (set to False if no more identifiers in list)
       --  Prev_Ids (Flag6) (set to False if no previous identifiers in list)
 
@@ -5565,6 +5586,7 @@ package Sinfo is
       --  Zero_Cost_Handling (Flag5-Sem)
       --  Local_Raise_Statements (Elist1-Sem) (set to No_Elist if not present)
       --  Local_Raise_Not_OK (Flag7-Sem)
+      --  Has_Local_Raise (Flag8-Sem)
 
       ------------------------------------------
       -- 11.2  Choice parameter specification --
@@ -7093,13 +7115,13 @@ package Sinfo is
       N_Formal_Abstract_Subprogram_Declaration,
       N_Formal_Concrete_Subprogram_Declaration,
 
-      --  N_Push_xxx_Label
+      --  N_Push_xxx_Label, N_Push_Pop_xxx_Label
 
       N_Push_Constraint_Error_Label,
       N_Push_Program_Error_Label,
       N_Push_Storage_Error_Label,
 
-      --  N_Pop_xxx_Label
+      --  N_Pop_xxx_Label, N_Push_Pop_xxx_Label
 
       N_Pop_Constraint_Error_Label,
       N_Pop_Program_Error_Label,
@@ -7168,7 +7190,6 @@ package Sinfo is
       N_Variant,
       N_Variant_Part,
       N_With_Clause,
-      N_With_Type_Clause,
       N_Unused_At_End);
 
    for Node_Kind'Size use 8;
@@ -7296,6 +7317,10 @@ package Sinfo is
      N_Pop_Constraint_Error_Label ..
      N_Pop_Storage_Error_Label;
 
+   subtype N_Push_Pop_xxx_Label is Node_Kind range
+     N_Push_Constraint_Error_Label ..
+     N_Pop_Storage_Error_Label;
+
    subtype N_Raise_xxx_Error is Node_Kind range
      N_Raise_Constraint_Error ..
      N_Raise_Storage_Error;
@@ -7561,9 +7586,6 @@ package Sinfo is
    function Delay_Alternative
      (N : Node_Id) return Node_Id;    -- Node4
 
-   function Delay_Finalize_Attach
-     (N : Node_Id) return Boolean;    -- Flag14
-
    function Delay_Statement
      (N : Node_Id) return Node_Id;    -- Node2
 
@@ -7685,7 +7707,7 @@ package Sinfo is
      (N : Node_Id) return List_Id;    -- List5
 
    function Exception_Junk
-     (N : Node_Id) return Boolean;    -- Flag7
+     (N : Node_Id) return Boolean;    -- Flag8
 
    function Exception_Label
      (N : Node_Id) return Node_Id;    -- Node5
@@ -7765,6 +7787,12 @@ package Sinfo is
    function Has_Dynamic_Range_Check
      (N : Node_Id) return Boolean;    -- Flag12
 
+   function Has_Init_Expression
+     (N : Node_Id) return Boolean;    -- Flag14
+
+   function Has_Local_Raise
+     (N : Node_Id) return Boolean;    -- Flag8
+
    function Has_No_Elaboration_Code
      (N : Node_Id) return Boolean;    -- Flag17
 
@@ -7855,6 +7883,9 @@ package Sinfo is
    function Is_Protected_Subprogram_Body
      (N : Node_Id) return Boolean;    -- Flag7
 
+   function Is_Static_Coextension
+     (N : Node_Id) return Boolean;    -- Flag14
+
    function Is_Static_Expression
      (N : Node_Id) return Boolean;    -- Flag6
 
@@ -8071,6 +8102,9 @@ package Sinfo is
    function Redundant_Use
      (N : Node_Id) return Boolean;    -- Flag13
 
+   function Renaming_Exception
+     (N : Node_Id) return Node_Id;    -- Node2
+
    function Result_Definition
      (N : Node_Id) return Node_Id;    -- Node4
 
@@ -8410,9 +8444,6 @@ package Sinfo is
    procedure Set_Delay_Alternative
      (N : Node_Id; Val : Node_Id);            -- Node4
 
-   procedure Set_Delay_Finalize_Attach
-     (N : Node_Id; Val : Boolean := True);    -- Flag14
-
    procedure Set_Delay_Statement
      (N : Node_Id; Val : Node_Id);            -- Node2
 
@@ -8531,7 +8562,7 @@ package Sinfo is
      (N : Node_Id; Val : List_Id);            -- List5
 
    procedure Set_Exception_Junk
-     (N : Node_Id; Val : Boolean := True);    -- Flag7
+     (N : Node_Id; Val : Boolean := True);    -- Flag8
 
    procedure Set_Exception_Label
      (N : Node_Id; Val : Node_Id);            -- Node5
@@ -8611,6 +8642,12 @@ package Sinfo is
    procedure Set_Has_Dynamic_Range_Check
      (N : Node_Id; Val : Boolean := True);    -- Flag12
 
+   procedure Set_Has_Init_Expression
+     (N : Node_Id; Val : Boolean := True);    -- Flag14
+
+   procedure Set_Has_Local_Raise
+     (N : Node_Id; Val : Boolean := True);    -- Flag8
+
    procedure Set_Has_No_Elaboration_Code
      (N : Node_Id; Val : Boolean := True);    -- Flag17
 
@@ -8701,6 +8738,9 @@ package Sinfo is
    procedure Set_Is_Protected_Subprogram_Body
      (N : Node_Id; Val : Boolean := True);    -- Flag7
 
+   procedure Set_Is_Static_Coextension
+     (N : Node_Id; Val : Boolean := True);    -- Flag14
+
    procedure Set_Is_Static_Expression
      (N : Node_Id; Val : Boolean := True);    -- Flag6
 
@@ -8917,6 +8957,9 @@ package Sinfo is
    procedure Set_Redundant_Use
      (N : Node_Id; Val : Boolean := True);    -- Flag13
 
+   procedure Set_Renaming_Exception
+     (N : Node_Id; Val : Node_Id);            -- Node2
+
    procedure Set_Result_Definition
      (N : Node_Id; Val : Node_Id);            -- Node4
 
@@ -10142,13 +10185,6 @@ package Sinfo is
         4 => False,   --  Library_Unit (Node4-Sem)
         5 => False),  --  Corresponding_Spec (Node5-Sem)
 
-     N_With_Type_Clause =>
-       (1 => False,   --  unused
-        2 => True,    --  Name (Node2)
-        3 => False,   --  unused
-        4 => False,   --  unused
-        5 => False),  --  unused
-
      N_Subprogram_Body_Stub =>
        (1 => True,    --  Specification (Node1)
         2 => False,   --  unused
@@ -10683,7 +10719,6 @@ package Sinfo is
    pragma Inline (Defining_Identifier);
    pragma Inline (Defining_Unit_Name);
    pragma Inline (Delay_Alternative);
-   pragma Inline (Delay_Finalize_Attach);
    pragma Inline (Delay_Statement);
    pragma Inline (Delta_Expression);
    pragma Inline (Digits_Expression);
@@ -10751,6 +10786,8 @@ package Sinfo is
    pragma Inline (Has_Created_Identifier);
    pragma Inline (Has_Dynamic_Length_Check);
    pragma Inline (Has_Dynamic_Range_Check);
+   pragma Inline (Has_Init_Expression);
+   pragma Inline (Has_Local_Raise);
    pragma Inline (Has_Self_Reference);
    pragma Inline (Has_No_Elaboration_Code);
    pragma Inline (Has_Priority_Pragma);
@@ -10781,6 +10818,7 @@ package Sinfo is
    pragma Inline (Is_Overloaded);
    pragma Inline (Is_Power_Of_2_For_Shift);
    pragma Inline (Is_Protected_Subprogram_Body);
+   pragma Inline (Is_Static_Coextension);
    pragma Inline (Is_Static_Expression);
    pragma Inline (Is_Subprogram_Descriptor);
    pragma Inline (Is_Task_Allocation_Block);
@@ -10853,6 +10891,7 @@ package Sinfo is
    pragma Inline (Reason);
    pragma Inline (Record_Extension_Part);
    pragma Inline (Redundant_Use);
+   pragma Inline (Renaming_Exception);
    pragma Inline (Result_Definition);
    pragma Inline (Return_Object_Declarations);
    pragma Inline (Return_Statement_Entity);
@@ -10963,7 +11002,6 @@ package Sinfo is
    pragma Inline (Set_Defining_Identifier);
    pragma Inline (Set_Defining_Unit_Name);
    pragma Inline (Set_Delay_Alternative);
-   pragma Inline (Set_Delay_Finalize_Attach);
    pragma Inline (Set_Delay_Statement);
    pragma Inline (Set_Delta_Expression);
    pragma Inline (Set_Digits_Expression);
@@ -11029,6 +11067,8 @@ package Sinfo is
    pragma Inline (Set_Handler_List_Entry);
    pragma Inline (Set_Has_Created_Identifier);
    pragma Inline (Set_Has_Dynamic_Length_Check);
+   pragma Inline (Set_Has_Init_Expression);
+   pragma Inline (Set_Has_Local_Raise);
    pragma Inline (Set_Has_Dynamic_Range_Check);
    pragma Inline (Set_Has_No_Elaboration_Code);
    pragma Inline (Set_Has_Priority_Pragma);
@@ -11060,6 +11100,7 @@ package Sinfo is
    pragma Inline (Set_Is_Power_Of_2_For_Shift);
    pragma Inline (Set_Is_Protected_Subprogram_Body);
    pragma Inline (Set_Has_Self_Reference);
+   pragma Inline (Set_Is_Static_Coextension);
    pragma Inline (Set_Is_Static_Expression);
    pragma Inline (Set_Is_Subprogram_Descriptor);
    pragma Inline (Set_Is_Task_Allocation_Block);
@@ -11131,6 +11172,7 @@ package Sinfo is
    pragma Inline (Set_Reason);
    pragma Inline (Set_Record_Extension_Part);
    pragma Inline (Set_Redundant_Use);
+   pragma Inline (Set_Renaming_Exception);
    pragma Inline (Set_Result_Definition);
    pragma Inline (Set_Return_Object_Declarations);
    pragma Inline (Set_Reverse_Present);
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 124068)
+++ sinfo.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -727,14 +727,6 @@ package body Sinfo is
       return Node4 (N);
    end Delay_Alternative;
 
-   function Delay_Finalize_Attach
-      (N : Node_Id) return Boolean is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Object_Declaration);
-      return Flag14 (N);
-   end Delay_Finalize_Attach;
-
    function Delay_Statement
       (N : Node_Id) return Node_Id is
    begin
@@ -1101,11 +1093,12 @@ package body Sinfo is
      (N : Node_Id) return Boolean is
    begin
       pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement
         or else NT (N).Nkind = N_Goto_Statement
         or else NT (N).Nkind = N_Label
         or else NT (N).Nkind = N_Object_Declaration
         or else NT (N).Nkind = N_Subtype_Declaration);
-      return Flag7 (N);
+      return Flag8 (N);
    end Exception_Junk;
 
    function Exception_Label
@@ -1360,6 +1353,22 @@ package body Sinfo is
       return Flag12 (N);
    end Has_Dynamic_Range_Check;
 
+   function Has_Init_Expression
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      return Flag14 (N);
+   end Has_Init_Expression;
+
+   function Has_Local_Raise
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      return Flag8 (N);
+   end Has_Local_Raise;
+
    function Has_No_Elaboration_Code
       (N : Node_Id) return Boolean is
    begin
@@ -1629,6 +1638,14 @@ package body Sinfo is
       return Flag7 (N);
    end Is_Protected_Subprogram_Body;
 
+   function Is_Static_Coextension
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator);
+      return Flag14 (N);
+   end Is_Static_Coextension;
+
    function Is_Static_Expression
       (N : Node_Id) return Boolean is
    begin
@@ -1900,8 +1917,7 @@ package body Sinfo is
         or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
         or else NT (N).Nkind = N_Subunit
         or else NT (N).Nkind = N_Variant_Part
-        or else NT (N).Nkind = N_With_Clause
-        or else NT (N).Nkind = N_With_Type_Clause);
+        or else NT (N).Nkind = N_With_Clause);
       return Node2 (N);
    end Name;
 
@@ -2348,6 +2364,14 @@ package body Sinfo is
       return Flag13 (N);
    end Redundant_Use;
 
+   function Renaming_Exception
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Declaration);
+      return Node2 (N);
+   end Renaming_Exception;
+
    function Result_Definition
      (N : Node_Id) return Node_Id is
    begin
@@ -2576,8 +2600,7 @@ package body Sinfo is
         or else NT (N).Nkind = N_Formal_Private_Type_Definition
         or else NT (N).Nkind = N_Incomplete_Type_Declaration
         or else NT (N).Nkind = N_Private_Type_Declaration
-        or else NT (N).Nkind = N_Record_Definition
-        or else NT (N).Nkind = N_With_Type_Clause);
+        or else NT (N).Nkind = N_Record_Definition);
       return Flag15 (N);
    end Tagged_Present;
 
@@ -3412,14 +3435,6 @@ package body Sinfo is
       Set_Node4_With_Parent (N, Val);
    end Set_Delay_Alternative;
 
-   procedure Set_Delay_Finalize_Attach
-      (N : Node_Id; Val : Boolean := True) is
-   begin
-      pragma Assert (False
-        or else NT (N).Nkind = N_Object_Declaration);
-      Set_Flag14 (N, Val);
-   end Set_Delay_Finalize_Attach;
-
    procedure Set_Delay_Statement
       (N : Node_Id; Val : Node_Id) is
    begin
@@ -3777,11 +3792,12 @@ package body Sinfo is
      (N : Node_Id; Val : Boolean := True) is
    begin
       pragma Assert (False
+        or else NT (N).Nkind = N_Block_Statement
         or else NT (N).Nkind = N_Goto_Statement
         or else NT (N).Nkind = N_Label
         or else NT (N).Nkind = N_Object_Declaration
         or else NT (N).Nkind = N_Subtype_Declaration);
-      Set_Flag7 (N, Val);
+      Set_Flag8 (N, Val);
    end Set_Exception_Junk;
 
    procedure Set_Exception_Label
@@ -4036,6 +4052,22 @@ package body Sinfo is
       Set_Flag12 (N, Val);
    end Set_Has_Dynamic_Range_Check;
 
+   procedure Set_Has_Init_Expression
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Object_Declaration);
+      Set_Flag14 (N, Val);
+   end Set_Has_Init_Expression;
+
+   procedure Set_Has_Local_Raise
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Handler);
+      Set_Flag8 (N, Val);
+   end Set_Has_Local_Raise;
+
    procedure Set_Has_No_Elaboration_Code
       (N : Node_Id; Val : Boolean := True) is
    begin
@@ -4305,6 +4337,14 @@ package body Sinfo is
       Set_Flag7 (N, Val);
    end Set_Is_Protected_Subprogram_Body;
 
+   procedure Set_Is_Static_Coextension
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator);
+      Set_Flag14 (N, Val);
+   end Set_Is_Static_Coextension;
+
    procedure Set_Is_Static_Expression
       (N : Node_Id; Val : Boolean := True) is
    begin
@@ -4576,8 +4616,7 @@ package body Sinfo is
         or else NT (N).Nkind = N_Subprogram_Renaming_Declaration
         or else NT (N).Nkind = N_Subunit
         or else NT (N).Nkind = N_Variant_Part
-        or else NT (N).Nkind = N_With_Clause
-        or else NT (N).Nkind = N_With_Type_Clause);
+        or else NT (N).Nkind = N_With_Clause);
       Set_Node2_With_Parent (N, Val);
    end Set_Name;
 
@@ -5024,6 +5063,14 @@ package body Sinfo is
       Set_Flag13 (N, Val);
    end Set_Redundant_Use;
 
+   procedure Set_Renaming_Exception
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exception_Declaration);
+      Set_Node2 (N, Val);
+   end Set_Renaming_Exception;
+
    procedure Set_Result_Definition
      (N : Node_Id; Val : Node_Id) is
    begin
@@ -5252,8 +5299,7 @@ package body Sinfo is
         or else NT (N).Nkind = N_Formal_Private_Type_Definition
         or else NT (N).Nkind = N_Incomplete_Type_Declaration
         or else NT (N).Nkind = N_Private_Type_Declaration
-        or else NT (N).Nkind = N_Record_Definition
-        or else NT (N).Nkind = N_With_Type_Clause);
+        or else NT (N).Nkind = N_Record_Definition);
       Set_Flag15 (N, Val);
    end Set_Tagged_Present;
 


More information about the Gcc-patches mailing list