[Ada] Missing warning for unreferenced formals in expression functions

[Pierre-Marie de Rodat <derodat at adacore dot com>]

This patch fixes an issue whereby the compiler failed to properly warn against
unreferenced formal parameters when analyzing expression functions.

Tested on x86_64-pc-linux-gnu, committed on trunk

2018-05-22  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* sem_ch6.adb (Analyze_Expression_Function): Propagate flags from the
	original function spec into the generated function spec due to
	expansion of expression functions during analysis.
	(Analyze_Subprogram_Body_Helper): Modify check on formal parameter
	references from the body to the subprogram spec in the case of
	expression functions because of inconsistances related to having a
	generated body.
	* libgnarl/s-osinte__android.ads: Flag parameters as unused.
	* libgnarl/s-osinte__lynxos178e.ads: Likewise.
	* libgnarl/s-osinte__qnx.adb: Likewise.
	* libgnarl/s-osinte__qnx.ads: Likewise.

gcc/testsuite/

	* gnat.dg/warn14.adb: New testcase.

--- gcc/ada/libgnarl/s-osinte__android.ads
+++ gcc/ada/libgnarl/s-osinte__android.ads
@@ -313,7 +313,7 @@ package System.OS_Interface is
    Stack_Base_Available : constant Boolean := False;
    --  Indicates whether the stack base is available on this target
 
-   function Get_Stack_Base (thread : pthread_t)
+   function Get_Stack_Base (ignored_thread : pthread_t)
      return Address is (Null_Address);
    --  This is a dummy procedure to share some GNULLI files
 
@@ -425,12 +425,12 @@ package System.OS_Interface is
    PTHREAD_PRIO_INHERIT : constant := 1;
 
    function pthread_mutexattr_setprotocol
-     (attr     : access pthread_mutexattr_t;
-      protocol : int) return int is (0);
+     (ignored_attr     : access pthread_mutexattr_t;
+      ignored_protocol : int) return int is (0);
 
    function pthread_mutexattr_setprioceiling
-     (attr        : access pthread_mutexattr_t;
-      prioceiling : int) return int is (0);
+     (ignored_attr        : access pthread_mutexattr_t;
+      ignored_prioceiling : int) return int is (0);
 
    type struct_sched_param is record
       sched_priority : int;  --  scheduling priority

--- gcc/ada/libgnarl/s-osinte__lynxos178e.ads
+++ gcc/ada/libgnarl/s-osinte__lynxos178e.ads
@@ -453,8 +453,8 @@ package System.OS_Interface is
    pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
 
    function pthread_attr_setscope
-     (attr            : access pthread_attr_t;
-      contentionscope : int) return int is (0);
+     (Unused_attr            : access pthread_attr_t;
+      Unused_contentionscope : int) return int is (0);
    --  pthread_attr_setscope is not implemented in production mode
 
    function pthread_attr_setinheritsched

--- gcc/ada/libgnarl/s-osinte__qnx.adb
+++ gcc/ada/libgnarl/s-osinte__qnx.adb
@@ -42,13 +42,25 @@ pragma Polling (Off);
 with Interfaces.C; use Interfaces.C;
 package body System.OS_Interface is
 
+   -----------------
+   -- sigaltstack --
+   -----------------
+
+   function sigaltstack
+     (ss  : not null access stack_t;
+      oss : access stack_t) return int
+   is
+      pragma Unreferenced (ss, oss);
+   begin
+      return 0;
+   end sigaltstack;
+
    --------------------
    -- Get_Stack_Base --
    --------------------
 
    function Get_Stack_Base (thread : pthread_t) return Address is
-      pragma Warnings (Off, thread);
-
+      pragma Unreferenced (thread);
    begin
       return Null_Address;
    end Get_Stack_Base;

--- gcc/ada/libgnarl/s-osinte__qnx.ads
+++ gcc/ada/libgnarl/s-osinte__qnx.ads
@@ -301,7 +301,7 @@ package System.OS_Interface is
    function sigaltstack
      (ss  : not null access stack_t;
       oss : access stack_t) return int
-   is (0);
+     with Inline;
    --  Not supported on QNX
 
    Alternate_Stack : aliased System.Address;
@@ -315,7 +315,7 @@ package System.OS_Interface is
    --  Indicates whether the stack base is available on this target
 
    function Get_Stack_Base (thread : pthread_t) return System.Address
-     with Inline_Always;
+     with Inline;
    --  This is a dummy procedure to share some GNULLI files
 
    function Get_Page_Size return int;

--- gcc/ada/sem_ch6.adb
+++ gcc/ada/sem_ch6.adb
@@ -490,8 +490,8 @@ package body Sem_Ch6 is
       Orig_N   : Node_Id;
       Ret      : Node_Id;
 
-      Def_Id   : Entity_Id := Empty;
-      Prev     : Entity_Id;
+      Def_Id : Entity_Id := Empty;
+      Prev   : Entity_Id;
       --  If the expression is a completion, Prev is the entity whose
       --  declaration is completed. Def_Id is needed to analyze the spec.
 
@@ -783,11 +783,44 @@ package body Sem_Ch6 is
             Related_Nod => Original_Node (N));
       end if;
 
-      --  If the return expression is a static constant, we suppress warning
-      --  messages on unused formals, which in most cases will be noise.
+      --  We must enforce checks for unreferenced formals in our newly
+      --  generated function, so we propagate the referenced flag from the
+      --  original spec to the new spec as well as setting Comes_From_Source.
+
+      if Present (Parameter_Specifications (New_Spec)) then
+         declare
+            Form_New_Def  : Entity_Id;
+            Form_New_Spec : Entity_Id;
+            Form_Old_Def  : Entity_Id;
+            Form_Old_Spec : Entity_Id;
+         begin
+
+            Form_New_Spec := First (Parameter_Specifications (New_Spec));
+            Form_Old_Spec := First (Parameter_Specifications (Spec));
+
+            while Present (Form_New_Spec) and then Present (Form_Old_Spec) loop
+               Form_New_Def := Defining_Identifier (Form_New_Spec);
+               Form_Old_Def := Defining_Identifier (Form_Old_Spec);
+
+               Set_Comes_From_Source (Form_New_Def, True);
+
+               --  Because of the usefulness of unreferenced controlling
+               --  formals we exempt them from unreferenced warnings by marking
+               --  them as always referenced.
+
+               Set_Referenced
+                 (Form_Old_Def,
+                  (Is_Formal (Form_Old_Def)
+                     and then Is_Controlling_Formal (Form_Old_Def))
+                   or else Referenced (Form_Old_Def));
+                   --  or else Is_Dispatching_Operation
+                   --          (Corresponding_Spec (New_Body)));
 
-      Set_Is_Trivial_Subprogram
-        (Defining_Entity (New_Body), Is_OK_Static_Expression (Expr));
+               Next (Form_New_Spec);
+               Next (Form_Old_Spec);
+            end loop;
+         end;
+      end if;
    end Analyze_Expression_Function;
 
    ----------------------------------------
@@ -3906,7 +3939,13 @@ package body Sem_Ch6 is
             end if;
          end if;
 
-         if Spec_Id /= Body_Id then
+         --  In the case we are dealing with an expression function we check
+         --  the formals attached to the spec instead of the body - so we don't
+         --  reference body formals.
+
+         if Spec_Id /= Body_Id
+           and then not Is_Expression_Function (Spec_Id)
+         then
             Reference_Body_Formals (Spec_Id, Body_Id);
          end if;
 
@@ -4617,9 +4656,17 @@ package body Sem_Ch6 is
             end loop;
          end if;
 
-         --  Check references in body
+         --  Check references of the subprogram spec when we are dealing with
+         --  an expression function due to it having a generated body.
+         --  Otherwise, we simply check the formals of the subprogram body.
 
-         Check_References (Body_Id);
+         if Present (Spec_Id)
+           and then Is_Expression_Function (Spec_Id)
+         then
+            Check_References (Spec_Id);
+         else
+            Check_References (Body_Id);
+         end if;
       end;
 
       --  Check for nested subprogram, and mark outer level subprogram if so

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/warn14.adb
@@ -0,0 +1,33 @@
+--  { dg-do compile }
+--  { dg-options "-gnatwa" }
+
+procedure Warn14 is
+
+  type E is record
+    P : Boolean;
+  end record;
+
+  EE : Boolean := True; --  { dg-warning "variable \"EE\" is not referenced" }
+
+  function F1 (I : Natural) return Natural is --  { dg-warning "function \"F1\" is not referenced" }
+  begin
+    return I;
+  end;
+
+  function F2 (I : Natural) return Natural is (I); --  { dg-warning "function \"F2\" is not referenced" }
+
+  function F3 (I : Natural) return Natural is (1); --  { dg-warning "function \"F3\" is not referenced|formal parameter \"I\" is not referenced" }
+
+  function F7 (EE : E) return Boolean is (EE.P); --  { dg-warning "function \"F7\" is not referenced" }
+
+  package YY is
+    type XX is tagged null record;
+
+    function F4 (Y : XX; U : Boolean) return Natural is (1); --  { dg-warning "formal parameter \"U\" is not referenced" }
+  end YY;
+
+  XXX : YY.XX;
+  B : Natural := XXX.F4 (True); --  { dg-warning "variable \"B\" is not referenced" }
+begin
+  null;
+end;