2007-10-15 Robert Dewar <dewar@adacore.com>

	* s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, 
	s-taprop-vxworks.adb, s-taprop-posix.adb, a-calend-vms.adb,
	a-calend.adb, a-nuflra.adb, a-tigeau.adb, a-wtgeau.adb, 
	checks.adb, bindgen.adb, eval_fat.adb, exp_fixd.adb, fmap.adb, 
	freeze.adb, g-awk.adb, g-calend.adb, g-diopit.adb, g-expect.adb, 
	gnatchop.adb, gnatlink.adb, g-spipat.adb, g-thread.adb, make.adb, 
	mdll.adb, mlib.adb, mlib-prj.adb, osint.adb, par-ch3.adb, prj.adb, 
	prj-makr.adb, sem_prag.adb, sem_type.adb, s-fatgen.adb, s-fileio.adb, 
	sinfo.ads, sinput-d.adb, s-taasde.adb, s-tasdeb.ads, s-tasren.adb, 
	s-tassta.adb, s-tpobop.adb, s-tposen.adb, stylesw.adb, types.ads,
	uintp.adb, validsw.adb, makegpr.adb, a-rbtgso.adb, a-crbtgo.adb, 
	a-coorse.adb, a-convec.adb, a-coinve.adb, a-cohama.adb, a-ciorse.adb, 
	a-cihama.adb, a-cidlli.adb, a-chtgop.adb, a-cdlili.adb, a-cdlili.adb, 
	a-coormu.adb, a-ciormu.adb, a-cihase.adb, a-cohase.adb, a-ciorma.adb, 
	a-coorma.adb, a-ztgeau.adb, symbols-vms.adb, a-crdlli.adb, 
	a-calari.adb, a-calfor.adb, s-os_lib.adb, s-regpat.adb, a-ngrear.adb:
	Minor reformatting.
	Add Unreferenced and Warnings (Off) pragmas for cases of
	variables modified calls where they are IN OUT or OUT parameters and
	the resulting values are not subsequently referenced. In a few cases,
	we also remove redundant code found by the new warnings.

	* ug_words, vms_data.ads, usage.adb, sem_util.adb, sem_util.ads, 
	sem_warn.adb, sem_warn.ads, sem_res.adb, sem_ch7.adb, sem_ch8.adb,
	sem_ch5.adb, opt.ads, lib-xref.adb, lib-xref.ads, exp_smem.adb,
	sem_ch11.adb, exp_ch6.adb, einfo.ads, einfo.adb: implement a new
	warning controlled by -gnatw.o that warns on cases of out parameter
	values being ignored.



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

1 files changed, 88 insertions, 20 deletions

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 718fb242e08..258064aa20d 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -116,6 +116,10 @@ package body Sem_Res is
    --  initialization of individual components within the init proc itself.
    --  Could be optimized away perhaps?
 
+   function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
+   --  Determine whether E is an access type declared by an access
+   --  declaration, and not an (anonymous) allocator type.
+
    function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
    --  Utility to check whether the name in the call is a predefined
    --  operator, in which case the call is made into an operator node.
@@ -989,6 +993,18 @@ package body Sem_Res is
       end if;
    end Check_Parameterless_Call;
 
+   -----------------------------
+   -- Is_Definite_Access_Type --
+   -----------------------------
+
+   function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
+      Btyp : constant Entity_Id := Base_Type (E);
+   begin
+      return Ekind (Btyp) = E_Access_Type
+        or else (Ekind (Btyp) = E_Access_Subprogram_Type
+                  and then Comes_From_Source (Btyp));
+   end Is_Definite_Access_Type;
+
    ----------------------
    -- Is_Predefined_Op --
    ----------------------
@@ -1024,10 +1040,6 @@ package body Sem_Res is
 
       type Kind_Test is access function (E : Entity_Id) return Boolean;
 
-      function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
-      --  Determine whether E is an access type declared by an access decla-
-      --  ration, and  not an (anonymous) allocator type.
-
       function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
       --  If the operand is not universal, and the operator is given by a
       --  expanded name,  verify that the operand has an interpretation with
@@ -1037,18 +1049,6 @@ package body Sem_Res is
       --  Find a type of the given class in the package Pack that contains
       --  the operator.
 
-      -----------------------------
-      -- Is_Definite_Access_Type --
-      -----------------------------
-
-      function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
-         Btyp : constant Entity_Id := Base_Type (E);
-      begin
-         return Ekind (Btyp) = E_Access_Type
-           or else (Ekind (Btyp) = E_Access_Subprogram_Type
-                     and then Comes_From_Source (Btyp));
-      end Is_Definite_Access_Type;
-
       ---------------------------
       -- Operand_Type_In_Scope --
       ---------------------------
@@ -2568,6 +2568,7 @@ package body Sem_Res is
       A_Typ  : Entity_Id;
       F_Typ  : Entity_Id;
       Prev   : Node_Id := Empty;
+      Orig_A : Node_Id;
 
       procedure Check_Prefixed_Call;
       --  If the original node is an overloaded call in prefix notation,
@@ -3042,10 +3043,44 @@ package body Sem_Res is
                end if;
             end if;
 
-            if Ekind (F) /= E_In_Parameter
-              and then not Is_OK_Variable_For_Out_Formal (A)
-            then
-               Error_Msg_NE ("actual for& must be a variable", A, F);
+            --  For IN parameter, this is where we generate a reference after
+            --  resolution is complete.
+
+            if Ekind (F) = E_In_Parameter then
+               Orig_A := Original_Node (A);
+
+               if Is_Entity_Name (Orig_A)
+                 and then Present (Entity (Orig_A))
+               then
+                  Generate_Reference (Entity (Orig_A), Orig_A);
+               end if;
+
+            --  Case of OUT or IN OUT parameter
+
+            else
+               --  Validate the form of the actual. Note that the call to
+               --  Is_OK_Variable_For_Out_Formal generates the required
+               --  reference in this case.
+
+               if not Is_OK_Variable_For_Out_Formal (A) then
+                  Error_Msg_NE ("actual for& must be a variable", A, F);
+               end if;
+
+               --  For an Out parameter, check for useless assignment. Note
+               --  that we can't set Last_Assignment this early, because we
+               --  may kill current values in Resolve_Call, and that call
+               --  would clobber the Last_Assignment field.
+
+               if Ekind (F) = E_Out_Parameter then
+                  if Warn_On_Out_Parameter_Unread
+                    and then Is_Entity_Name (A)
+                    and then Present (Entity (A))
+                  then
+                     Warn_On_Useless_Assignment (Entity (A), Sloc (A));
+                  end if;
+               end if;
+
+               --  What's the following about???
 
                if Is_Entity_Name (A) then
                   Kill_Checks (Entity (A));
@@ -4774,6 +4809,37 @@ package body Sem_Res is
          Kill_Current_Values;
       end if;
 
+      --  If we are warning about unread out parameters, this is the place to
+      --  set Last_Assignment for out parameters. We have to do this after the
+      --  above call to Kill_Current_Values (since that call clears the
+      --  Last_Assignment field of all local variables).
+
+      if Warn_On_Out_Parameter_Unread
+        and then Comes_From_Source (N)
+        and then In_Extended_Main_Source_Unit (N)
+      then
+         declare
+            F : Entity_Id;
+            A : Node_Id;
+
+         begin
+            F := First_Formal (Nam);
+            A := First_Actual (N);
+            while Present (F) and then Present (A) loop
+               if Ekind (F) = E_Out_Parameter
+                 and then Is_Entity_Name (A)
+                 and then Present (Entity (A))
+                 and then Safe_To_Capture_Value (N, Entity (A))
+               then
+                  Set_Last_Assignment (Entity (A), A);
+               end if;
+
+               Next_Formal (F);
+               Next_Actual (A);
+            end loop;
+         end;
+      end if;
+
       --  If the subprogram is a primitive operation, check whether or not
       --  it is a correct dispatching call.
 
@@ -4804,6 +4870,8 @@ package body Sem_Res is
          Check_Intrinsic_Call (N);
       end if;
 
+      --  All done, evaluate call and deal with elaboration issues
+
       Eval_Call (N);
       Check_Elab_Call (N);
    end Resolve_Call;