exp_util.ads, [...] (Expand_Subtype_From_Expr): In Ada2005...

2007-04-20  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

From-SVN: r125410

gcc/ada/exp_util.ads

@@ -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;

gcc/ada/lib-load.adb

@@ -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;
 

gcc/ada/lib-load.ads

@@ -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;

gcc/ada/par-ch10.adb

@@ -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

gcc/ada/sinfo.adb

@@ -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;