[multiple changes]

2015-10-26  Jerome Lambourg  <lambourg@adacore.com>

	* sysdep.c (__gnat_get_task_options): Workaround a VxWorks
	bug where VX_DEALLOC_TCB task option is forbidden when calling
	taskCreate but allowed in VX_USR_TASK_OPTIONS.

2015-10-26  Javier Miranda  <miranda@adacore.com>

	* exp_unst.ads, exp_unst.adb (Is_Uplevel_Referenced): New subprogram.

2015-10-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Constant_Indexing_OK): New predicate, subsidiary
	of Try_Container_Indexing, that implements the name resolution
	rules given in RM 4.1.6 (13-15).

From-SVN: r229355

5 files changed, 195 insertions, 22 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4ce0053..6b12af2 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,19 @@
+2015-10-26  Jerome Lambourg  <lambourg@adacore.com>
+
+	* sysdep.c (__gnat_get_task_options): Workaround a VxWorks
+	bug where VX_DEALLOC_TCB task option is forbidden when calling
+	taskCreate but allowed in VX_USR_TASK_OPTIONS.
+
+2015-10-26  Javier Miranda  <miranda@adacore.com>
+
+	* exp_unst.ads, exp_unst.adb (Is_Uplevel_Referenced): New subprogram.
+
+2015-10-26  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch4.adb (Constant_Indexing_OK): New predicate, subsidiary
+	of Try_Container_Indexing, that implements the name resolution
+	rules given in RM 4.1.6 (13-15).
+
 2015-10-26  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_ch3.adb, sem_util.adb: Minor reformatting.
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 5221472..b555fe7 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -119,6 +119,21 @@ package body Exp_Unst is
      Table_Increment      => 200,
      Table_Name           => "Unnest_Urefs");
 
+   ---------------------------
+   -- Is_Uplevel_Referenced --
+   ---------------------------
+
+   function Is_Uplevel_Referenced (E : Entity_Id) return Boolean is
+   begin
+      for J in Urefs.First .. Urefs.Last loop
+         if Urefs.Table (J).Ent = E then
+            return True;
+         end if;
+      end loop;
+
+      return False;
+   end Is_Uplevel_Referenced;
+
    -----------------------
    -- Unnest_Subprogram --
    -----------------------
diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads
index 084e904..1458853 100644
--- a/gcc/ada/exp_unst.ads
+++ b/gcc/ada/exp_unst.ads
@@ -686,4 +686,7 @@ package Exp_Unst is
    --  adds the ARECP parameter to all nested subprograms which need it, and
    --  modifies all uplevel references appropriately.
 
+   function Is_Uplevel_Referenced (E : Entity_Id) return Boolean;
+   --  Determines if E has some uplevel reference from a nested subprogram
+
 end Exp_Unst;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 3b55ea3..c354de8 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -7161,18 +7161,147 @@ package body Sem_Ch4 is
       Prefix : Node_Id;
       Exprs  : List_Id) return Boolean
    is
+      function Constant_Indexing_OK return Boolean;
+      --  Constant_Indexing is legal if there is no Variable_Indexing defined
+      --  for the type, or else node not a target of assignment, or an actual
+      --  for an IN OUT or OUT formal (RM 4.1.6 (11)).
+
+      --------------------------
+      -- Constant_Indexing_OK --
+      --------------------------
+
+      function Constant_Indexing_OK return Boolean is
+         Par : Node_Id;
+
+      begin
+         if No (Find_Value_Of_Aspect
+                 (Etype (Prefix), Aspect_Variable_Indexing))
+         then
+            return True;
+
+         elsif not Is_Variable (Prefix) then
+            return True;
+         end if;
+
+         Par := N;
+         while Present (Par) loop
+            if Nkind (Parent (Par)) = N_Assignment_Statement
+              and then Par = Name (Parent (Par))
+            then
+               return False;
+
+            --  The call may be overloaded, in which case we assume that its
+            --  resolution does not depend on the type of the parameter that
+            --  includes the indexing operation.
+
+            elsif Nkind_In (Parent (Par), N_Function_Call,
+                                          N_Procedure_Call_Statement)
+              and then Is_Entity_Name (Name (Parent (Par)))
+            then
+               declare
+                  Actual : Node_Id;
+                  Formal : Entity_Id;
+                  Proc   : Entity_Id;
+
+               begin
+                  --  We should look for an interpretation with the proper
+                  --  number of formals, and determine whether it is an
+                  --  In_Parameter, but for now assume that in the overloaded
+                  --  case constant indexing is legal. To be improved ???
+
+                  if Is_Overloaded (Name (Parent (Par))) then
+                     return True;
+
+                  else
+                     Proc := Entity (Name (Parent (Par)));
+
+                     --  If this is an indirect call, get formals from
+                     --  designated type.
+
+                     if Is_Access_Subprogram_Type (Etype (Proc)) then
+                        Proc := Designated_Type (Etype (Proc));
+                     end if;
+                  end if;
+
+                  Formal := First_Formal (Proc);
+                  Actual := First_Actual (Parent (Par));
+
+                  --  Find corresponding actual
+
+                  while Present (Actual) loop
+                     exit when Actual = Par;
+                     Next_Actual (Actual);
+
+                     if Present (Formal) then
+                        Next_Formal (Formal);
+
+                     --  Otherwise this is a parameter mismatch, the error is
+                     --  reported elsewhere.
+
+                     else
+                        return False;
+                     end if;
+                  end loop;
+
+                  return Ekind (Formal) = E_In_Parameter;
+               end;
+
+            elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
+               return False;
+
+            --  If the indexed component is a prefix it may be the first actual
+            --  of a prefixed call. Retrieve the called entity, if any, and
+            --  check its first formal.
+
+            elsif Nkind (Parent (Par)) = N_Selected_Component then
+               declare
+                  Sel : constant Node_Id   := Selector_Name (Parent (Par));
+                  Nam : constant Entity_Id := Current_Entity (Sel);
+
+               begin
+                  if Present (Nam)
+                    and then Is_Overloadable (Nam)
+                    and then Present (First_Formal (Nam))
+                  then
+                     return Ekind (First_Formal (Nam)) = E_In_Parameter;
+                  end if;
+               end;
+
+            elsif Nkind ((Par)) in N_Op then
+               return True;
+            end if;
+
+            Par := Parent (Par);
+         end loop;
+
+         --  In all other cases, constant indexing is legal
+
+         return True;
+      end Constant_Indexing_OK;
+
+      --  Local variables
+
       Loc       : constant Source_Ptr := Sloc (N);
-      C_Type    : Entity_Id;
       Assoc     : List_Id;
+      C_Type    : Entity_Id;
       Func      : Entity_Id;
       Func_Name : Node_Id;
       Indexing  : Node_Id;
 
+   --  Start of processing for Try_Container_Indexing
+
    begin
+      --  Node may have been analyzed already when testing for a prefixed
+      --  call, in which case do not redo analysis.
+
+      if Present (Generalized_Indexing (N)) then
+         return True;
+      end if;
+
       C_Type := Etype (Prefix);
 
-      --  If indexing a class-wide container, obtain indexing primitive
-      --  from specific type.
+      --  If indexing a class-wide container, obtain indexing primitive from
+      --  specific type.
 
       if Is_Class_Wide_Type (C_Type) then
          C_Type := Etype (Base_Type (C_Type));
@@ -7182,14 +7311,14 @@ package body Sem_Ch4 is
 
       Func_Name := Empty;
 
-      if Is_Variable (Prefix) then
+      if Constant_Indexing_OK then
          Func_Name :=
-           Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing);
+           Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing);
       end if;
 
       if No (Func_Name) then
          Func_Name :=
-           Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing);
+           Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing);
       end if;
 
       --  If aspect does not exist the expression is illegal. Error is
@@ -7197,8 +7326,8 @@ package body Sem_Ch4 is
 
       if No (Func_Name) then
 
-         --  The prefix itself may be an indexing of a container: rewrite
-         --  as such and re-analyze.
+         --  The prefix itself may be an indexing of a container: rewrite as
+         --  such and re-analyze.
 
          if Has_Implicit_Dereference (Etype (Prefix)) then
             Build_Explicit_Dereference
@@ -7213,14 +7342,14 @@ package body Sem_Ch4 is
       --  value of the inherited aspect is the Reference operation declared
       --  for the parent type.
 
-      --  However, Reference is also a primitive operation of the type, and
-      --  the inherited operation has a different signature. We retrieve the
-      --  right ones (the function may be overloaded) from the list of
-      --  primitive operations of the derived type.
+      --  However, Reference is also a primitive operation of the type, and the
+      --  inherited operation has a different signature. We retrieve the right
+      --  ones (the function may be overloaded) from the list of primitive
+      --  operations of the derived type.
 
-      --  Note that predefined containers are typically all derived from one
-      --  of the Controlled types. The code below is motivated by containers
-      --  that are derived from other types with a Reference aspect.
+      --  Note that predefined containers are typically all derived from one of
+      --  the Controlled types. The code below is motivated by containers that
+      --  are derived from other types with a Reference aspect.
 
       elsif Is_Derived_Type (C_Type)
         and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix)
@@ -7238,8 +7367,8 @@ package body Sem_Ch4 is
 
       --  The generalized indexing node is the one on which analysis and
       --  resolution take place. Before expansion the original node is replaced
-      --  with the generalized indexing node, which is a call, possibly with
-      --  a dereference operation.
+      --  with the generalized indexing node, which is a call, possibly with a
+      --  dereference operation.
 
       if Comes_From_Source (N) then
          Check_Compiler_Unit ("generalized indexing", N);
@@ -7279,7 +7408,8 @@ package body Sem_Ch4 is
       else
          Indexing :=
            Make_Function_Call (Loc,
-             Name => Make_Identifier (Loc, Chars (Func_Name)),
+             Name                   =>
+               Make_Identifier (Loc, Chars (Func_Name)),
              Parameter_Associations => Assoc);
 
          Set_Parent (Indexing, Parent (N));
@@ -7297,7 +7427,7 @@ package body Sem_Ch4 is
                Analyze_One_Call (Indexing, It.Nam, False, Success);
 
                if Success then
-                  Set_Etype (Name (Indexing), It.Typ);
+                  Set_Etype  (Name (Indexing), It.Typ);
                   Set_Entity (Name (Indexing), It.Nam);
                   Set_Etype (N, Etype (Indexing));
 
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index 01dae2b..21cd37c 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -865,10 +865,19 @@ __gnat_get_task_options (void)
 
   /* Mask those bits that are not under user control */
 #ifdef VX_USR_TASK_OPTIONS
-  return options & VX_USR_TASK_OPTIONS;
-#else
-  return options;
+  /* O810-007, TSR 00043679:
+     Workaround a bug in Vx-7 where VX_DEALLOC_TCB == VX_PRIVATE_UMASK and:
+     - VX_DEALLOC_TCB is an internal option not to be used by users
+     - VX_PRIVATE_UMASK as a user-definable option
+     This leads to VX_USR_TASK_OPTIONS allowing 0x8000 as VX_PRIVATE_UMASK but
+     taskCreate refusing this option (VX_DEALLOC_TCB is not allowed)
+  */
+# if defined (VX_PRIVATE_UMASK) && (VX_DEALLOC_TCB == VX_PRIVATE_UMASK)
+  options &= ~VX_DEALLOC_TCB;
+# endif
+  options &= VX_USR_TASK_OPTIONS;
 #endif
+  return options;
 }
 
 #endif