2015-10-26 Hristian Kirtchev <kirtchev@adacore.com>

	* exp_ch4.adb (Is_OK_Object_Reference): New routine.
	(Substitute_Valid_Check): Perform the 'Valid subsitution but do
	not suggest the use of the attribute if the left hand operand
	does not denote an object as it leads to illegal code.

2015-10-26  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_unst.adb: Minor reformatting.

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

	* sem_ch6.adb: Improve error msg.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@229341 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 106 insertions, 45 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4c3620f9ced..244014f20c8 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2015-10-26  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch4.adb (Is_OK_Object_Reference): New routine.
+	(Substitute_Valid_Check): Perform the 'Valid subsitution but do
+	not suggest the use of the attribute if the left hand operand
+	does not denote an object as it leads to illegal code.
+
+2015-10-26  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_unst.adb: Minor reformatting.
+
+2015-10-26  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch6.adb: Improve error msg.
+
 2015-10-26  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_disp.adb (Check_Controlling_Type): Handle properly the
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 6714894f637..0b1fe7920a0 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -5493,9 +5493,6 @@ package body Exp_Ch4 is
       Rop    : constant Node_Id    := Right_Opnd (N);
       Static : constant Boolean    := Is_OK_Static_Expression (N);
 
-      Ltyp  : Entity_Id;
-      Rtyp  : Entity_Id;
-
       procedure Substitute_Valid_Check;
       --  Replaces node N by Lop'Valid. This is done when we have an explicit
       --  test for the left operand being in range of its subtype.
@@ -5505,6 +5502,49 @@ package body Exp_Ch4 is
       ----------------------------
 
       procedure Substitute_Valid_Check is
+         function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
+         --  Determine whether arbitrary node Nod denotes a source object that
+         --  may safely act as prefix of attribute 'Valid.
+
+         ----------------------------
+         -- Is_OK_Object_Reference --
+         ----------------------------
+
+         function Is_OK_Object_Reference (Nod : Node_Id) return Boolean is
+            Obj_Ref : Node_Id;
+
+         begin
+            --  Inspect the original operand
+
+            Obj_Ref := Original_Node (Nod);
+
+            --  The object reference must be a source construct, otherwise the
+            --  codefix suggestion may refer to nonexistent code from a user
+            --  perspective.
+
+            if Comes_From_Source (Obj_Ref) then
+
+               --  Recover the actual object reference. There may be more cases
+               --  to consider???
+
+               loop
+                  if Nkind_In (Obj_Ref, N_Type_Conversion,
+                                        N_Unchecked_Type_Conversion)
+                  then
+                     Obj_Ref := Expression (Obj_Ref);
+                  else
+                     exit;
+                  end if;
+               end loop;
+
+               return Is_Object_Reference (Obj_Ref);
+            end if;
+
+            return False;
+         end Is_OK_Object_Reference;
+
+      --  Start of processing for Substitute_Valid_Check
+
       begin
          Rewrite (N,
            Make_Attribute_Reference (Loc,
@@ -5513,20 +5553,27 @@ package body Exp_Ch4 is
 
          Analyze_And_Resolve (N, Restyp);
 
-         --  Give warning unless overflow checking is MINIMIZED or ELIMINATED,
-         --  in which case, this usage makes sense, and in any case, we have
-         --  actually eliminated the danger of optimization above.
+         --  Emit a warning when the left-hand operand of the membership test
+         --  is a source object, otherwise the use of attribute 'Valid would be
+         --  illegal. The warning is not given when overflow checking is either
+         --  MINIMIZED or ELIMINATED, as the danger of optimization has been
+         --  eliminated above.
 
-         if Overflow_Check_Mode not in Minimized_Or_Eliminated then
+         if Is_OK_Object_Reference (Lop)
+           and then Overflow_Check_Mode not in Minimized_Or_Eliminated
+         then
             Error_Msg_N
               ("??explicit membership test may be optimized away", N);
             Error_Msg_N -- CODEFIX
               ("\??use ''Valid attribute instead", N);
          end if;
-
-         return;
       end Substitute_Valid_Check;
 
+      --  Local variables
+
+      Ltyp : Entity_Id;
+      Rtyp : Entity_Id;
+
    --  Start of processing for Expand_N_In
 
    begin
@@ -9767,7 +9814,7 @@ package body Exp_Ch4 is
             if not Is_Discrete_Type (Etype (N)) then
                null;
 
-            --  Don't do this on the left hand of an assignment statement.
+            --  Don't do this on the left-hand side of an assignment statement.
             --  Normally one would think that references like this would not
             --  occur, but they do in generated code, and mean that we really
             --  do want to assign the discriminant.
@@ -10212,7 +10259,7 @@ package body Exp_Ch4 is
             Cons := No_List;
 
             --  If type is unconstrained we have to add a constraint, copied
-            --  from the actual value of the left hand side.
+            --  from the actual value of the left-hand side.
 
             if not Is_Constrained (Target_Type) then
                if Has_Discriminants (Operand_Type) then
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 0b738d1b450..5db40e52a8d 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -316,12 +316,12 @@ package body Exp_Unst is
             Callee : Entity_Id;
 
             procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean);
-               --  Given a type T, checks if it is a static type defined as a
-               --  type with no dynamic bounds in sight. If so, the only action
-               --  is to set Is_Static_Type True for T. If T is not a static
-               --  type, then all types with dynamic bounds associated with
-               --  T are detected, and their bounds are marked as uplevel
-               --  referenced if not at the library level, and DT is set True.
+            --  Given a type T, checks if it is a static type defined as a type
+            --  with no dynamic bounds in sight. If so, the only action is to
+            --  set Is_Static_Type True for T. If T is not a static type, then
+            --  all types with dynamic bounds associated with T are detected,
+            --  and their bounds are marked as uplevel referenced if not at the
+            --  library level, and DT is set True.
 
             procedure Note_Uplevel_Ref
               (E      : Entity_Id;
@@ -407,7 +407,7 @@ package body Exp_Unst is
                      end if;
                   end;
 
-                  --  For record type, check all components
+               --  For record type, check all components
 
                elsif Is_Record_Type (T) then
                   declare
@@ -420,7 +420,7 @@ package body Exp_Unst is
                      end loop;
                   end;
 
-                  --  For array type, check index types and component type
+               --  For array type, check index types and component type
 
                elsif Is_Array_Type (T) then
                   declare
@@ -467,9 +467,9 @@ package body Exp_Unst is
                if Caller = Callee then
                   return;
 
-               --  Callee may be a function that returns an array, and
-               --  that has been rewritten as a procedure. If caller is
-               --  that procedure, nothing to do either.
+               --  Callee may be a function that returns an array, and that has
+               --  been rewritten as a procedure. If caller is that procedure,
+               --  nothing to do either.
 
                elsif Ekind (Callee) = E_Function
                  and then Rewritten_For_C (Callee)
@@ -1183,8 +1183,9 @@ package body Exp_Unst is
 
                      --  Now we can insert the AREC declarations into the body
 
-                     --  type ARECnT is record .. end record;
-                     --  pragma Suppress_Initialization (ARECnT);
+                     --    type ARECnT is record .. end record;
+                     --    pragma Suppress_Initialization (ARECnT);
+
                      --  Note that we need to set the Suppress_Initialization
                      --  flag after Decl_ARECnT has been analyzed.
 
@@ -1438,8 +1439,8 @@ package body Exp_Unst is
                --  probably happens as a result of not properly treating
                --  instance bodies. To be examined ???
 
-               --  If this test is omitted, then the compilation of
-               --  freeze.adb and inline.adb fail in unnesting mode.
+               --  If this test is omitted, then the compilation of freeze.adb
+               --  and inline.adb fail in unnesting mode.
 
                if No (STJR.ARECnF) then
                   goto Continue;
@@ -1451,12 +1452,11 @@ package body Exp_Unst is
 
                Push_Scope (STJR.Ent);
 
-               --  Now we need to rewrite the reference. We have a
-               --  reference is from level STJR.Lev to level STJE.Lev.
-               --  The general form of the rewritten reference for
-               --  entity X is:
+               --  Now we need to rewrite the reference. We have a reference
+               --  from level STJR.Lev to level STJE.Lev. The general form of
+               --  the rewritten reference for entity X is:
 
-               --   Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X)
+               --    Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X)
 
                --  where a,b,c,d .. m =
                --    STJR.Lev - 1,  STJR.Lev - 2, .. STJE.Lev
@@ -1562,11 +1562,10 @@ package body Exp_Unst is
          begin
             if Present (STT.ARECnF) then
 
-               --  CTJ.N is a call to a subprogram which may require
-               --  a pointer to an activation record. The subprogram
-               --  containing the call is CTJ.From and the subprogram being
-               --  called is CTJ.To, so we have a call from level STF.Lev to
-               --  level STT.Lev.
+               --  CTJ.N is a call to a subprogram which may require a pointer
+               --  to an activation record. The subprogram containing the call
+               --  is CTJ.From and the subprogram being called is CTJ.To, so we
+               --  have a call from level STF.Lev to level STT.Lev.
 
                --  There are three possibilities:
 
@@ -1576,10 +1575,10 @@ package body Exp_Unst is
                if STF.Lev = STT.Lev then
                   Extra := New_Occurrence_Of (STF.ARECnF, Loc);
 
-               --  For a call that goes down a level, we pass a pointer
-               --  to the activation record constructed within the caller
-               --  (which may be the outer level subprogram, but also may
-               --  be a more deeply nested caller).
+               --  For a call that goes down a level, we pass a pointer to the
+               --  activation record constructed within the caller (which may
+               --  be the outer-level subprogram, but also may be a more deeply
+               --  nested caller).
 
                elsif STT.Lev = STF.Lev + 1 then
                   Extra := New_Occurrence_Of (STF.ARECnP, Loc);
@@ -1601,9 +1600,9 @@ package body Exp_Unst is
                   pragma Assert (STT.Lev < STF.Lev);
 
                   Extra := New_Occurrence_Of (STF.ARECnF, Loc);
-                  SubX := Subp_Index (CTJ.Caller);
+                  SubX  := Subp_Index (CTJ.Caller);
                   for K in reverse STT.Lev .. STF.Lev - 1 loop
-                     SubX := Enclosing_Subp (SubX);
+                     SubX  := Enclosing_Subp (SubX);
                      Extra :=
                        Make_Selected_Component (Loc,
                          Prefix        => Extra,
@@ -1628,8 +1627,8 @@ package body Exp_Unst is
 
                Append (ExtraP, Parameter_Associations (CTJ.N));
 
-               --  We need to deal with the actual parameter chain as well.
-               --  The newly added parameter is always the last actual.
+               --  We need to deal with the actual parameter chain as well. The
+               --  newly added parameter is always the last actual.
 
                Act := First_Named_Actual (CTJ.N);
 
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index ec92bf45813..d36cf850b4b 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -674,7 +674,7 @@ package body Sem_Ch6 is
                              Scope_Depth (Scope (Scope_Id))
                      then
                         Error_Msg_N
-                          ("access discriminant in return aggregate will be "
+                          ("access discriminant in return aggregate would be "
                            & "a dangling reference", Obj);
                      end if;
                   end if;