inline.adb, [...]: Suppress unmodified in-out parameter warning in some cases…

inline.adb, [...]: Suppress unmodified in-out parameter warning in some cases This patch is a also...

2007-08-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* inline.adb, types.ads, inline.ads, frontend.adb, alloc.ads: 
	Suppress unmodified in-out parameter warning in some cases
	This patch is a also fairly significant change to the way suppressible
	checks are handled.

	* checks.ads, checks.adb (Install_Null_Excluding_Check): No check
	needed for access to concurrent record types generated by the expander.
	(Generate_Range_Check): When generating a temporary to capture the
	value of a conversion that requires a range check, set the type of the
	temporary before rewriting the node, so that the type is always
	properly placed for back-end use.
	(Apply_Float_Conversion_Check): Handle case where the conversion is
	truncating.
	(Get_Discriminal): Code reformatting. Climb the scope stack looking
	for a protected type in order to examine its discriminants.

From-SVN: r127410

gcc/ada/alloc.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, 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- --
@@ -63,15 +63,15 @@ package Alloc is
    Elmts_Initial                    : constant := 1_200;   -- Elists
    Elmts_Increment                  : constant := 100;
 
-   Entity_Suppress_Initial          : constant := 100;     -- Sem
-   Entity_Suppress_Increment        : constant := 200;
-
    Inlined_Bodies_Initial           : constant := 50;      -- Inline
    Inlined_Bodies_Increment         : constant := 200;
 
    Inlined_Initial                  : constant := 100;     -- Inline
    Inlined_Increment                : constant := 100;
 
+   In_Out_Warnings_Initial          : constant := 100;     -- Sem_Warn
+   In_Out_Warnings_Increment        : constant := 100;
+
    Interp_Map_Initial               : constant := 200;     -- Sem_Type
    Interp_Map_Increment             : constant := 100;
 

gcc/ada/checks.ads

@@ -36,8 +36,10 @@
 --  This always occurs whether checks are suppressed or not.  Dynamic range
 --  checks are, of course, not inserted if checks are suppressed.
 
-with Types; use Types;
-with Uintp; use Uintp;
+with Namet;  use Namet;
+with Table;
+with Types;  use Types;
+with Uintp;  use Uintp;
 
 package Checks is
 
@@ -383,16 +385,28 @@ package Checks is
    --  values (i.e. the underlying integer value is used).
 
    type Check_Result is private;
-   --  Type used to return result of Range_Check call, for later use in
+   --  Type used to return result of Get_Range_Checks call, for later use in
    --  call to Insert_Range_Checks procedure.
 
+   function Get_Range_Checks
+     (Ck_Node    : Node_Id;
+      Target_Typ : Entity_Id;
+      Source_Typ : Entity_Id := Empty;
+      Warn_Node  : Node_Id   := Empty) return Check_Result;
+   --  Like Apply_Range_Check, except it does not modify anything. Instead
+   --  it returns an encapsulated result of the check operations for later
+   --  use in a call to Insert_Range_Checks. If Warn_Node is non-empty, its
+   --  Sloc is used, in the static case, for the generated warning or error.
+   --  Additionally, it is used rather than Expr (or Low/High_Bound of Expr)
+   --  in constructing the check.
+
    procedure Append_Range_Checks
      (Checks       : Check_Result;
       Stmts        : List_Id;
       Suppress_Typ : Entity_Id;
       Static_Sloc  : Source_Ptr;
       Flag_Node    : Node_Id);
-   --  Called to append range checks as returned by a call to Range_Check.
+   --  Called to append range checks as returned by a call to Get_Range_Checks.
    --  Stmts is a list to which either the dynamic check is appended or the
    --  raise Constraint_Error statement is appended (for static checks).
    --  Static_Sloc is the Sloc at which the raise CE node points, Flag_Node is
@@ -406,7 +420,7 @@ package Checks is
       Static_Sloc  : Source_Ptr := No_Location;
       Flag_Node    : Node_Id    := Empty;
       Do_Before    : Boolean    := False);
-   --  Called to insert range checks as returned by a call to Range_Check.
+   --  Called to insert range checks as returned by a call to Get_Range_Checks.
    --  Node is the node after which either the dynamic check is inserted or
    --  the raise Constraint_Error statement is inserted (for static checks).
    --  Suppress_Typ is the type to check to determine if checks are suppressed.
@@ -417,19 +431,6 @@ package Checks is
    --  inserted after, if Do_Before is True, the check is inserted before
    --  Node.
 
-   function Range_Check
-     (Ck_Node    : Node_Id;
-      Target_Typ : Entity_Id;
-      Source_Typ : Entity_Id := Empty;
-      Warn_Node  : Node_Id   := Empty)
-      return       Check_Result;
-   --  Like Apply_Range_Check, except it does not modify anything. Instead
-   --  it returns an encapsulated result of the check operations for later
-   --  use in a call to Insert_Range_Checks. If Warn_Node is non-empty, its
-   --  Sloc is used, in the static case, for the generated warning or error.
-   --  Additionally, it is used rather than Expr (or Low/High_Bound of Expr)
-   --  in constructing the check.
-
    -----------------------
    -- Expander Routines --
    -----------------------
@@ -659,6 +660,29 @@ package Checks is
    --  If N is an N_Range node, then Ensure_Valid is called on its bounds,
    --  if validity checking of operands is enabled.
 
+   -----------------------------
+   -- Handling of Check Names --
+   -----------------------------
+
+   --  The following table contains Name_Id's for recognized checks. The first
+   --  entries (corresponding to the values of the subtype Predefined_Check_Id)
+   --  contain the Name_Id values for the checks that are predefined, including
+   --  All_Checks (see Types). Remaining entries are those that are introduced
+   --  by pragma Check_Names.
+
+   package Check_Names is new Table.Table (
+     Table_Component_Type => Name_Id,
+     Table_Index_Type     => Check_Id,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 30,
+     Table_Increment      => 200,
+     Table_Name           => "Name_Check_Names");
+
+   function Get_Check_Id (N : Name_Id) return Check_Id;
+   --  Function to search above table for matching name. If found returns the
+   --  corresponding Check_Id value in the range 1 .. Check_Name.Last. If not
+   --  found returns No_Check_Id.
+
 private
 
    type Check_Result is array (Positive range 1 .. 2) of Node_Id;

gcc/ada/frontend.adb

@@ -322,9 +322,10 @@ begin
             Lib.List;
          end if;
 
-         --  Output any messages for unreferenced entities
+         --  Output waiting warning messages
 
-         Output_Unreferenced_Messages;
+         Sem_Warn.Output_Non_Modifed_In_Out_Warnings;
+         Sem_Warn.Output_Unreferenced_Messages;
          Sem_Warn.Check_Unused_Withs;
       end if;
    end if;

gcc/ada/inline.adb

@@ -957,7 +957,6 @@ package body Inline is
          --  set (that's why we can't simply use a FOR loop here).
 
          J := 0;
-
          while J <= Pending_Instantiations.Last
            and then Serious_Errors_Detected = 0
          loop

gcc/ada/inline.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2007, 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- --
@@ -37,8 +37,9 @@
 --  Frontend, and thus are not mutually recursive.
 
 with Alloc;
+with Sem;   use Sem;
 with Table;
-with Types;  use Types;
+with Types; use Types;
 
 package Inline is
 
@@ -51,7 +52,7 @@ package Inline is
    --  global data structure, and the bodies constructed by means of a separate
    --  analysis and expansion step.
 
-   --  See full description in body of Sem_Ch12 for details
+   --  See full description in body of Sem_Ch12 for more details
 
    type Pending_Body_Info is record
       Inst_Node : Node_Id;
@@ -68,6 +69,22 @@ package Inline is
       --  The semantic unit within which the instantiation is found. Must
       --  be restored when compiling the body, to insure that internal enti-
       --  ties use the same counter and are unique over spec and body.
+
+      Scope_Suppress           : Suppress_Array;
+      Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;
+      --  Save suppress information at the point of instantiation. Used to
+      --  properly inherit check status active at this point (see RM 11.5
+      --  (7.2/2), AI95-00224-01):
+      --
+      --    "If a checking pragma applies to a generic instantiation, then the
+      --    checking pragma also applies to the instance. If a checking pragma
+      --    applies to a call to a subprogram that has a pragma Inline applied
+      --    to it, then the checking pragma also applies to the inlined
+      --    subprogram body".
+      --
+      --  This means we have to capture this information from the current scope
+      --  at the point of instantiation.
+
    end record;
 
    package Pending_Instantiations is new Table.Table (