[multiple changes]

2009-06-25  Vincent Celier  <celier@adacore.com>

	* vms_data.ads: Minor comment change

2009-06-25  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch5.adb (Expand_N_Extended_Return_Statement): Don't build an
	assignment statement to targeting a caller-provided object when the
	result type is an interface type.

	* exp_ch6.adb (Expand_Call): Remove redundant test of
	Is_Limited_Interface (Is_Inherently_Limited is sufficient).
	(Is_Build_In_Place_Function): Remove test for Is_Limited_Interface.

	* sem_aggr.adb (Check_Expr_OK_In_Limited_Aggregate): Add type in call
	to OK_For_Limited_Init.

	* sem_aux.adb (Is_Inherently_Limited_Type): Revise limited type
	condition so that True is returned for all limited interfaces, not
	just synchronized ones. Ignore components of an interface type when
	checking for limited components (such a component can be a parent
	component).

	* sem_ch3.ads (OK_For_Limited_Init_In_05): Add type parameter.
	(OK_For_Limited_Init): Add type parameter.

	* sem_ch3.adb (Check_Initialization): Add type in call to
	OK_For_Limited_Init.
	(OK_For_Limited_Init): Add new type param in call to
	OK_For_Limited_Init_In_05.
	(OK_For_Limited_Init_In_05): Permit arbitrary expressions of a
	nonlimited type when the context type is a limited interface. Add type
	on recursive calls.

	* sem_ch4.adb (Analyze_Allocator): Add type in call to
	OK_For_Limited_Init.

	* sem_ch6.adb (Check_Limited_Return): Add type in call to
	OK_For_Limited_Init.

	* sem_ch12.adb (Analyze_Formal_Object_Declaration): Add type in call to
	OK_For_Limited_Init.
	(Instantiate_Object): Add type in call to OK_For_Limited_Init.

	* sem_type.adb (Interface_Present_In_Ancestor): In the case of a
	class-wide interface, get the base type before applying Etype, in order
	to account for class-wide subtypes.

From-SVN: r148938

12 files changed, 157 insertions, 44 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 5e92642..e8918c4 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,51 @@
+2009-06-25  Vincent Celier  <celier@adacore.com>
+
+	* vms_data.ads: Minor comment change
+
+2009-06-25  Gary Dismukes  <dismukes@adacore.com>
+
+	* exp_ch5.adb (Expand_N_Extended_Return_Statement): Don't build an
+	assignment statement to targeting a caller-provided object when the
+	result type is an interface type.
+
+	* exp_ch6.adb (Expand_Call): Remove redundant test of
+	Is_Limited_Interface (Is_Inherently_Limited is sufficient).
+	(Is_Build_In_Place_Function): Remove test for Is_Limited_Interface.
+
+	* sem_aggr.adb (Check_Expr_OK_In_Limited_Aggregate): Add type in call
+	to OK_For_Limited_Init.
+
+	* sem_aux.adb (Is_Inherently_Limited_Type): Revise limited type
+	condition so that True is returned for all limited interfaces, not
+	just synchronized ones. Ignore components of an interface type when
+	checking for limited components (such a component can be a parent
+	component).
+
+	* sem_ch3.ads (OK_For_Limited_Init_In_05): Add type parameter.
+	(OK_For_Limited_Init): Add type parameter.
+
+	* sem_ch3.adb (Check_Initialization): Add type in call to
+	OK_For_Limited_Init.
+	(OK_For_Limited_Init): Add new type param in call to
+	OK_For_Limited_Init_In_05.
+	(OK_For_Limited_Init_In_05): Permit arbitrary expressions of a
+	nonlimited type when the context type is a limited interface. Add type
+	on recursive calls.
+
+	* sem_ch4.adb (Analyze_Allocator): Add type in call to
+	OK_For_Limited_Init.
+
+	* sem_ch6.adb (Check_Limited_Return): Add type in call to
+	OK_For_Limited_Init.
+
+	* sem_ch12.adb (Analyze_Formal_Object_Declaration): Add type in call to
+	OK_For_Limited_Init.
+	(Instantiate_Object): Add type in call to OK_For_Limited_Init.
+
+	* sem_type.adb (Interface_Present_In_Ancestor): In the case of a
+	class-wide interface, get the base type before applying Etype, in order
+	to account for class-wide subtypes.
+
 2009-06-25  Emmanuel Briot  <briot@adacore.com>
 
 	* gnatcmd.adb, prj-proc.adb, make.adb, prj.adb, prj.ads, prj-nmsc.adb,
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 4cc6630..0659c7e 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -2694,10 +2694,21 @@ package body Exp_Ch5 is
                --  and the declaration isn't marked as No_Initialization, then
                --  we need to generate an assignment to the object and insert
                --  it after the declaration before rewriting it as a renaming
-               --  (otherwise we'll lose the initialization).
+               --  (otherwise we'll lose the initialization). The case where
+               --  the result type is an interface (or class-wide interface)
+               --  is also excluded because the context of the function call
+               --  must be unconstrained, so the initialization will always
+               --  be done as part of an allocator evaluation (storage pool
+               --  or secondary stack), never to a constrained target object
+               --  passed in by the caller. Besides the assignment being
+               --  unneeded in this case, it avoids problems with trying to
+               --  generate a dispatching assignment when the return expression
+               --  is a nonlimited descendant of a limited interface (the
+               --  interface has no assignment operation).
 
                if Present (Return_Obj_Expr)
                  and then not No_Initialization (Return_Object_Decl)
+                 and then not Is_Interface (Return_Obj_Typ)
                then
                   Init_Assignment :=
                     Make_Assignment_Statement (Loc,
@@ -2822,12 +2833,21 @@ package body Exp_Ch5 is
                      if Present (Return_Obj_Expr)
                        and then not No_Initialization (Return_Object_Decl)
                      then
+                        --  Always use the type of the expression for the
+                        --  qualified expression, rather than the result type.
+                        --  In general we cannot always use the result type
+                        --  for the allocator, because the expression might be
+                        --  of a specific type, such as in the case of an
+                        --  aggregate or even a nonlimited object when the
+                        --  result type is a limited class-wide interface type.
+
                         Heap_Allocator :=
                           Make_Allocator (Loc,
                             Expression =>
                               Make_Qualified_Expression (Loc,
                                 Subtype_Mark =>
-                                  New_Reference_To (Return_Obj_Typ, Loc),
+                                  New_Reference_To
+                                    (Etype (Return_Obj_Expr), Loc),
                                 Expression =>
                                   New_Copy_Tree (Return_Obj_Expr)));
 
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index d1a5630..991783f 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3065,7 +3065,6 @@ package body Exp_Ch6 is
 
       if Needs_Finalization (Etype (Subp))
         and then not Is_Inherently_Limited_Type (Etype (Subp))
-        and then not Is_Limited_Interface (Etype (Subp))
       then
          Expand_Ctrl_Function_Call (N);
       end if;
@@ -4653,12 +4652,10 @@ package body Exp_Ch6 is
          then
             return False;
 
-         --  If the return type is a limited interface it has to be treated
-         --  as a return in place, even if the actual object is some non-
-         --  limited descendant.
-
-         elsif Is_Limited_Interface (Etype (E)) then
-            return True;
+         --  In Ada 2005 all functions with an inherently limited return type
+         --  must be handled using a build-in-place profile, including the case
+         --  of a function with a limited interface result, where the function
+         --  may return objects of nonlimited descendants.
 
          else
             return Is_Inherently_Limited_Type (Etype (E))
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 66653f6..43ed7c0 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -776,7 +776,7 @@ package body Sem_Aggr is
          and then Comes_From_Source (Expr)
          and then not In_Instance_Body
       then
-         if not OK_For_Limited_Init (Expr) then
+         if not OK_For_Limited_Init (Etype (Expr), Expr) then
             Error_Msg_N ("initialization not allowed for limited types", Expr);
             Explain_Limited_Type (Etype (Expr), Expr);
          end if;
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index f2f55ce..6513e73 100755
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, 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- --
@@ -594,11 +594,16 @@ package body Sem_Aux is
          return True;
 
       elsif Is_Record_Type (Btype) then
+
+         --  Note that we return True for all limited interfaces, even though
+         --  (unsynchronized) limited interfaces can have descendants that are
+         --  nonlimited, because this is a predicate on the type itself, and
+         --  things like functions with limited interface results need to be
+         --  handled as build in place even though they might return objects
+         --  of a type that is not inherently limited.
+
          if Is_Limited_Record (Btype) then
-            return not Is_Interface (Btype)
-              or else Is_Protected_Interface (Btype)
-              or else Is_Synchronized_Interface (Btype)
-              or else Is_Task_Interface (Btype);
+            return True;
 
          elsif Is_Class_Wide_Type (Btype) then
             return Is_Inherently_Limited_Type (Root_Type (Btype));
@@ -610,7 +615,16 @@ package body Sem_Aux is
             begin
                C := First_Component (Btype);
                while Present (C) loop
-                  if Is_Inherently_Limited_Type (Etype (C)) then
+
+                  --  Don't consider components with interface types (which can
+                  --  only occur in the case of a _parent component anyway).
+                  --  They don't have any components, plus it would cause this
+                  --  function to return true for nonlimited types derived from
+                  --  limited intefaces.
+
+                  if not Is_Interface (Etype (C))
+                    and then Is_Inherently_Limited_Type (Etype (C))
+                  then
                      return True;
                   end if;
 
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index f7d5a1a..9afdb0a 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -1884,7 +1884,7 @@ package body Sem_Ch12 is
          if Present (E) then
             Preanalyze_Spec_Expression (E, T);
 
-            if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then
+            if Is_Limited_Type (T) and then not OK_For_Limited_Init (T, E) then
                Error_Msg_N
                  ("initialization not allowed for limited types", E);
                Explain_Limited_Type (T, E);
@@ -8434,7 +8434,7 @@ package body Sem_Ch12 is
                end if;
 
                if Is_Limited_Type (Typ)
-                 and then not OK_For_Limited_Init (Actual)
+                 and then not OK_For_Limited_Init (Typ, Actual)
                then
                   Error_Msg_N
                     ("initialization not allowed for limited types", Actual);
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index ff702a6..488b300 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -8780,7 +8780,7 @@ package body Sem_Ch3 is
         and then not In_Instance
         and then not In_Inlined_Body
       then
-         if not OK_For_Limited_Init (Exp) then
+         if not OK_For_Limited_Init (T, Exp) then
 
             --  In GNAT mode, this is just a warning, to allow it to be evilly
             --  turned off. Otherwise it is a real error.
@@ -15316,20 +15316,36 @@ package body Sem_Ch3 is
    --  ???Check all calls of this, and compare the conditions under which it's
    --  called.
 
-   function OK_For_Limited_Init (Exp : Node_Id) return Boolean is
+   function OK_For_Limited_Init
+     (Typ : Entity_Id;
+      Exp : Node_Id) return Boolean
+   is
    begin
       return Is_CPP_Constructor_Call (Exp)
         or else (Ada_Version >= Ada_05
                   and then not Debug_Flag_Dot_L
-                  and then OK_For_Limited_Init_In_05 (Exp));
+                  and then OK_For_Limited_Init_In_05 (Typ, Exp));
    end OK_For_Limited_Init;
 
    -------------------------------
    -- OK_For_Limited_Init_In_05 --
    -------------------------------
 
-   function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean is
+   function OK_For_Limited_Init_In_05
+     (Typ : Entity_Id;
+      Exp : Node_Id) return Boolean
+   is
    begin
+      --  An object of a limited interface type can be initialized with any
+      --  expression of a nonlimited descendant type.
+
+      if Is_Class_Wide_Type (Typ)
+        and then Is_Limited_Interface (Typ)
+        and then not Is_Limited_Type (Etype (Exp))
+      then
+         return True;
+      end if;
+
       --  Ada 2005 (AI-287, AI-318): Relax the strictness of the front end in
       --  case of limited aggregates (including extension aggregates), and
       --  function calls. The function call may have been give in prefixed
@@ -15341,7 +15357,8 @@ package body Sem_Ch3 is
 
          when N_Qualified_Expression =>
             return
-              OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp)));
+              OK_For_Limited_Init_In_05
+                (Typ, Expression (Original_Node (Exp)));
 
          --  Ada 2005 (AI-251): If a class-wide interface object is initialized
          --  with a function call, the expander has rewritten the call into an
@@ -15354,7 +15371,8 @@ package body Sem_Ch3 is
          when N_Type_Conversion | N_Unchecked_Type_Conversion =>
             return not Comes_From_Source (Exp)
               and then
-                OK_For_Limited_Init_In_05 (Expression (Original_Node (Exp)));
+                OK_For_Limited_Init_In_05
+                  (Typ, Expression (Original_Node (Exp)));
 
          when N_Indexed_Component | N_Selected_Component  =>
             return Nkind (Exp) = N_Function_Call;
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index 93750701..c8fc885 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, 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- --
@@ -182,18 +182,24 @@ package Sem_Ch3 is
    --  wide type is created at the same time, and therefore there is a private
    --  and a full declaration for the class-wide type as well.
 
-   function OK_For_Limited_Init_In_05 (Exp : Node_Id) return Boolean;
-   --  Presuming Exp is an expression of an inherently limited type, returns
-   --  True if the expression is allowed in an initialization context by the
-   --  rules of Ada 2005. We use the rule in RM-7.5(2.1/2), "...it is an
-   --  aggregate, a function_call, or a parenthesized expression or
-   --  qualified_expression whose operand is permitted...". Note that in Ada
-   --  95 mode, we sometimes wish to give warnings based on whether the
-   --  program _would_ be legal in Ada 2005. Note that Exp must already have
-   --  been resolved, so we can know whether it's a function call (as opposed
-   --  to an indexed component, for example).
-
-   function OK_For_Limited_Init (Exp : Node_Id) return Boolean;
+   function OK_For_Limited_Init_In_05
+     (Typ : Entity_Id;
+      Exp : Node_Id) return Boolean;
+   --  Presuming Exp is an expression of an inherently limited type Typ,
+   --  returns True if the expression is allowed in an initialization context
+   --  by the rules of Ada 2005. We use the rule in RM-7.5(2.1/2), "...it is an
+   --  aggregate, a function_call, or a parenthesized expression or qualified
+   --  expression whose operand is permitted...". Note that in Ada 95 mode,
+   --  we sometimes wish to give warnings based on whether the program _would_
+   --  be legal in Ada 2005. Note that Exp must already have been resolved,
+   --  so we can know whether it's a function call (as opposed to an indexed
+   --  component, for example). In the case where Typ is a limited interface's
+   --  class-wide type, then the expression is allowed to be of any kind if its
+   --  type is a nonlimited descendant of the interface.
+
+   function OK_For_Limited_Init
+     (Typ : Entity_Id;
+      Exp : Node_Id) return Boolean;
    --  Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in
    --  Ada 2005 mode.
 
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index e94a331..06d0752 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -387,7 +387,7 @@ package body Sem_Ch4 is
            and then Comes_From_Source (N)
            and then not In_Instance_Body
          then
-            if not OK_For_Limited_Init (Expression (E)) then
+            if not OK_For_Limited_Init (Type_Id, Expression (E)) then
                Error_Msg_N ("initialization not allowed for limited types", N);
                Explain_Limited_Type (Type_Id, N);
             end if;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index dfd0cd4..2fa6cf8 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -464,7 +464,7 @@ package body Sem_Ch6 is
          if Is_Limited_Type (R_Type)
            and then Comes_From_Source (N)
            and then not In_Instance_Body
-           and then not OK_For_Limited_Init_In_05 (Expr)
+           and then not OK_For_Limited_Init_In_05 (R_Type, Expr)
          then
             --  Error in Ada 2005
 
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 0cbce21..5883e3f 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -2367,8 +2367,10 @@ package body Sem_Type is
    --  Start of processing for Interface_Present_In_Ancestor
 
    begin
+      --  Iface might be a class-wide subtype, so we have to apply Base_Type
+
       if Is_Class_Wide_Type (Iface) then
-         Iface_Typ := Etype (Iface);
+         Iface_Typ := Etype (Base_Type (Iface));
       else
          Iface_Typ := Iface;
       end if;
diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads
index 07047c7..a8565c3 100644
--- a/gcc/ada/vms_data.ads
+++ b/gcc/ada/vms_data.ads
@@ -820,12 +820,19 @@ package VMS_Data is
    --
    --   Work quietly, only output warnings and errors.
 
-   S_Check_Time  : aliased constant S := "/TIME "                        &
-                                            "-t";
+   S_Check_Time     : aliased constant S := "/TIME "                       &
+                                               "-t";
    --        /NOTIME (D)
-   --        /QUIET
+   --        /TIME
+   --
+   --   Print out execution time
+
+   S_Check_Log      : aliased constant S := "/LOG "                        &
+                                               "-log";
+   --        /NOLOG (D)
+   --        /LOG
    --
-   --   Print  out execution time
+   --   Duplicate all the output sent to Stderr into a log file.
 
    S_Check_Sections : aliased constant S := "/SECTIONS="                   &
                                             "DEFAULT "                     &
@@ -901,6 +908,7 @@ package VMS_Data is
                        S_Check_Project  'Access,
                        S_Check_Quiet    'Access,
                        S_Check_Time     'Access,
+                       S_Check_Log      'Access,
                        S_Check_Sections 'Access,
                        S_Check_Short    'Access,
                        S_Check_Subdirs  'Access,