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.adb

@@ -36,7 +36,6 @@ with Elists;   use Elists;
 with Eval_Fat; use Eval_Fat;
 with Freeze;   use Freeze;
 with Lib;      use Lib;
-with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
@@ -220,7 +219,7 @@ package body Checks is
    --  routine. The Do_Static flag indicates that only a static check is
    --  to be done.
 
-   type Check_Type is (Access_Check, Division_Check);
+   type Check_Type is new Check_Id range Access_Check .. Division_Check;
    function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
    --  This function is used to see if an access or division by zero check is
    --  needed. The check is to be applied to a single variable appearing in the
@@ -543,12 +542,12 @@ package body Checks is
               ("?specified address for& may be inconsistent with alignment ",
                Aexp, E);
             Error_Msg_FE
-              ("\?program execution may be erroneous ('R'M 13.3(27))",
+              ("\?program execution may be erroneous (RM 13.3(27))",
                Aexp, E);
          end if;
       end Compile_Time_Bad_Alignment;
 
-   --  Start of processing for Apply_Address_Check
+   --  Start of processing for Apply_Address_Clause_Check
 
    begin
       --  First obtain expression from address clause
@@ -637,7 +636,7 @@ package body Checks is
       --  maximum alignment is one, since the check will always succeed.
 
       --  Note: we do not check for checks suppressed here, since that check
-      --  was done in Sem_Ch13 when the address clause was proceeds. We are
+      --  was done in Sem_Ch13 when the address clause was processed. We are
       --  only called if checks were not suppressed. The reason for this is
       --  that we have to delay the call to Apply_Alignment_Check till freeze
       --  time (so that all types etc are elaborated), but we have to check
@@ -953,7 +952,7 @@ package body Checks is
 
          --  No checks necessary if expression statically null
 
-         if Nkind (N) = N_Null then
+         if Known_Null (N) then
             if Can_Never_Be_Null (Typ) then
                Install_Null_Excluding_Check (N);
             end if;
@@ -1007,7 +1006,7 @@ package body Checks is
       --  unconstrained subtype (through instantiation). If this is a
       --  discriminated component assigned in the expansion of an aggregate
       --  in an initialization, the check must be suppressed. This unusual
-      --  situation requires a predicate of its own (see 7503-008).
+      --  situation requires a predicate of its own.
 
       ----------------------------------------
       -- Is_Aliased_Unconstrained_Component --
@@ -1064,7 +1063,7 @@ package body Checks is
       --  incomplete, then the access value must be null and we suppress the
       --  check.
 
-      if Nkind (N) = N_Null then
+      if Known_Null (N) then
          return;
 
       elsif Is_Access_Type (S_Typ) then
@@ -1388,28 +1387,38 @@ package body Checks is
    --  to perform a range check in the floating-point domain instead, however:
 
    --      (1)  The bounds may not be known at compile time
-   --      (2)  The check must take into account possible rounding.
+   --      (2)  The check must take into account rounding or truncation.
    --      (3)  The range of type I may not be exactly representable in F.
-   --      (4)  The end-points I'First - 0.5 and I'Last + 0.5 may or may
-   --           not be in range, depending on the sign of  I'First and I'Last.
+   --      (4)  For the rounding case, The end-points I'First - 0.5 and
+   --           I'Last + 0.5 may or may not be in range, depending on the
+   --           sign of  I'First and I'Last.
    --      (5)  X may be a NaN, which will fail any comparison
 
-   --  The following steps take care of these issues converting X:
+   --  The following steps correctly convert X with rounding:
 
    --      (1) If either I'First or I'Last is not known at compile time, use
    --          I'Base instead of I in the next three steps and perform a
    --          regular range check against I'Range after conversion.
    --      (2) If I'First - 0.5 is representable in F then let Lo be that
    --          value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
-   --          F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
-   --          take one of the closest floating-point numbers to T, and see if
-   --          it is in range or not.
+   --          F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
+   --          In other words, take one of the closest floating-point numbers
+   --          (which is an integer value) to I'First, and see if it is in
+   --          range or not.
    --      (3) If I'Last + 0.5 is representable in F then let Hi be that value
    --          and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
-   --          F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
+   --          F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
    --      (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
    --                     or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
 
+   --  For the truncating case, replace steps (2) and (3) as follows:
+   --      (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
+   --          be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
+   --          Lo_OK be True.
+   --      (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
+   --          be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
+   --          Hi_OK be False
+
    procedure Apply_Float_Conversion_Check
      (Ck_Node    : Node_Id;
       Target_Typ : Entity_Id)
@@ -1421,9 +1430,16 @@ package body Checks is
       Target_Base : constant Entity_Id  :=
                       Implementation_Base_Type (Target_Typ);
 
-      Max_Bound   : constant Uint := UI_Expon
-                                       (Machine_Radix (Expr_Type),
-                                        Machine_Mantissa (Expr_Type) - 1) - 1;
+      Par : constant Node_Id := Parent (Ck_Node);
+      pragma Assert (Nkind (Par) = N_Type_Conversion);
+      --  Parent of check node, must be a type conversion
+
+      Truncate  : constant Boolean := Float_Truncate (Par);
+      Max_Bound : constant Uint :=
+                    UI_Expon
+                      (Machine_Radix (Expr_Type),
+                       Machine_Mantissa (Expr_Type) - 1) - 1;
+
       --  Largest bound, so bound plus or minus half is a machine number of F
 
       Ifirst, Ilast : Uint;
@@ -1449,10 +1465,7 @@ package body Checks is
             --  to prevent overflow during conversion and then perform a
             --  regular range check against the (dynamic) bounds.
 
-            Par : constant Node_Id := Parent (Ck_Node);
-
             pragma Assert (Target_Base /= Target_Typ);
-            pragma Assert (Nkind (Par) = N_Type_Conversion);
 
             Temp : constant Entity_Id :=
                     Make_Defining_Identifier (Loc,
@@ -1489,9 +1502,18 @@ package body Checks is
 
       --  Check against lower bound
 
-      if abs (Ifirst) < Max_Bound then
+      if Truncate and then Ifirst > 0 then
+         Lo := Pred (Expr_Type, UR_From_Uint (Ifirst));
+         Lo_OK := False;
+
+      elsif Truncate then
+         Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1));
+         Lo_OK := True;
+
+      elsif abs (Ifirst) < Max_Bound then
          Lo := UR_From_Uint (Ifirst) - Ureal_Half;
          Lo_OK := (Ifirst > 0);
+
       else
          Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
          Lo_OK := (Lo >= UR_From_Uint (Ifirst));
@@ -1515,7 +1537,15 @@ package body Checks is
 
       --  Check against higher bound
 
-      if abs (Ilast) < Max_Bound then
+      if Truncate and then Ilast < 0 then
+         Hi := Succ (Expr_Type, UR_From_Uint (Ilast));
+         Lo_OK := False;
+
+      elsif Truncate then
+         Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1));
+         Hi_OK := True;
+
+      elsif abs (Ilast) < Max_Bound then
          Hi := UR_From_Uint (Ilast) + Ureal_Half;
          Hi_OK := (Ilast < 0);
       else
@@ -1636,17 +1666,25 @@ package body Checks is
    --  Start of processing for Apply_Scalar_Range_Check
 
    begin
-      if Inside_A_Generic then
-         return;
+      --  Return if check obviously not needed
 
-      --  Return if check obviously not needed. Note that we do not check for
-      --  the expander being inactive, since this routine does not insert any
-      --  code, but it does generate useful warnings sometimes, which we would
-      --  like even if we are in semantics only mode.
+      if
+         --  Not needed inside generic
 
-      elsif Target_Typ = Any_Type
-        or else not Is_Scalar_Type (Target_Typ)
-        or else Raises_Constraint_Error (Expr)
+         Inside_A_Generic
+
+         --  Not needed if previous error
+
+         or else Target_Typ = Any_Type
+         or else Nkind (Expr) = N_Error
+
+         --  Not needed for non-scalar type
+
+         or else not Is_Scalar_Type (Target_Typ)
+
+         --  Not needed if we know node raises CE already
+
+         or else Raises_Constraint_Error (Expr)
       then
          return;
       end if;
@@ -2498,11 +2536,11 @@ package body Checks is
          return True;
       end if;
 
-      --  Right operand of test mus be key value (zero or null)
+      --  Right operand of test must be key value (zero or null)
 
       case Check is
          when Access_Check =>
-            if Nkind (R) /= N_Null then
+            if not Known_Null (R) then
                return True;
             end if;
 
@@ -2512,6 +2550,9 @@ package body Checks is
             then
                return True;
             end if;
+
+         when others =>
+            raise Program_Error;
       end case;
 
       --  Here we have the optimizable case, warn if not short-circuited
@@ -2526,6 +2567,9 @@ package body Checks is
                Error_Msg_N
                  ("Constraint_Error may be raised (zero divide)?",
                   Parent (Nod));
+
+            when others =>
+               raise Program_Error;
          end case;
 
          if K = N_Op_And then
@@ -2682,29 +2726,27 @@ package body Checks is
       if K /= N_Function_Specification then
          Expr := Expression (N);
 
-         if Present (Expr)
-           and then Nkind (Expr) = N_Null
-         then
+         if Present (Expr) and then Known_Null (Expr) then
             case K is
                when N_Component_Declaration      |
                     N_Discriminant_Specification =>
                   Apply_Compile_Time_Constraint_Error
                     (N      => Expr,
-                     Msg    => "(Ada 2005) NULL not allowed " &
+                     Msg    => "(Ada 2005) null not allowed " &
                                "in null-excluding components?",
                      Reason => CE_Null_Not_Allowed);
 
                when N_Object_Declaration =>
                   Apply_Compile_Time_Constraint_Error
                     (N      => Expr,
-                     Msg    => "(Ada 2005) NULL not allowed " &
+                     Msg    => "(Ada 2005) null not allowed " &
                                "in null-excluding objects?",
                      Reason => CE_Null_Not_Allowed);
 
                when N_Parameter_Specification =>
                   Apply_Compile_Time_Constraint_Error
                     (N      => Expr,
-                     Msg    => "(Ada 2005) NULL not allowed " &
+                     Msg    => "(Ada 2005) null not allowed " &
                                "in null-excluding formals?",
                      Reason => CE_Null_Not_Allowed);
 
@@ -4459,6 +4501,12 @@ package body Checks is
                 Reason => Reason)));
 
             Rewrite (N, New_Occurrence_Of (Tnn, Loc));
+
+            --  Set the type of N, because the declaration for Tnn might not
+            --  be analyzed yet, as is the case if N appears within a record
+            --  declaration, as a discriminant constraint or expression.
+
+            Set_Etype (N, Target_Base_Type);
          end;
 
       --  At this stage, we know that we have two scalar types, which are
@@ -4626,6 +4674,32 @@ package body Checks is
       end if;
    end Generate_Range_Check;
 
+   ------------------
+   -- Get_Check_Id --
+   ------------------
+
+   function Get_Check_Id (N : Name_Id) return Check_Id is
+   begin
+      --  For standard check name, we can do a direct computation
+
+      if N in First_Check_Name .. Last_Check_Name then
+         return Check_Id (N - (First_Check_Name - 1));
+
+      --  For non-standard names added by pragma Check_Name, search table
+
+      else
+         for J in All_Checks + 1 .. Check_Names.Last loop
+            if Check_Names.Table (J) = N then
+               return J;
+            end if;
+         end loop;
+      end if;
+
+      --  No matching name found
+
+      return No_Check_Id;
+   end Get_Check_Id;
+
    ---------------------
    -- Get_Discriminal --
    ---------------------
@@ -4636,20 +4710,6 @@ package body Checks is
       Sc  : Entity_Id;
 
    begin
-      --  The entity E is the type of a private component of the protected
-      --  type, or the type of a renaming of that component within a protected
-      --  operation of that type.
-
-      Sc := Scope (E);
-
-      if Ekind (Sc) /= E_Protected_Type then
-         Sc := Scope (Sc);
-
-         if Ekind (Sc) /= E_Protected_Type then
-            return Bound;
-         end if;
-      end if;
-
       --  The bound can be a bona fide parameter of a protected operation,
       --  rather than a prival encoded as an in-parameter.
 
@@ -4657,17 +4717,48 @@ package body Checks is
          return Bound;
       end if;
 
+      --  Climb the scope stack looking for an enclosing protected type. If
+      --  we run out of scopes, return the bound itself.
+
+      Sc := Scope (E);
+      while Present (Sc) loop
+         if Sc = Standard_Standard then
+            return Bound;
+
+         elsif Ekind (Sc) = E_Protected_Type then
+            exit;
+         end if;
+
+         Sc := Scope (Sc);
+      end loop;
+
       D := First_Discriminant (Sc);
+      while Present (D) loop
+         if Chars (D) = Chars (Bound) then
+            return New_Occurrence_Of (Discriminal (D), Loc);
+         end if;
 
-      while Present (D)
-        and then Chars (D) /= Chars (Bound)
-      loop
          Next_Discriminant (D);
       end loop;
 
-      return New_Occurrence_Of (Discriminal (D), Loc);
+      return Bound;
    end Get_Discriminal;
 
+   ----------------------
+   -- Get_Range_Checks --
+   ----------------------
+
+   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
+   is
+   begin
+      return Selected_Range_Checks
+        (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
+   end Get_Range_Checks;
+
    ------------------
    -- Guard_Access --
    ------------------
@@ -4717,6 +4808,12 @@ package body Checks is
       for J in Determine_Range_Cache_N'Range loop
          Determine_Range_Cache_N (J) := Empty;
       end loop;
+
+      Check_Names.Init;
+
+      for J in Int range 1 .. All_Checks loop
+         Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1));
+      end loop;
    end Initialize;
 
    -------------------------
@@ -4952,6 +5049,18 @@ package body Checks is
          return;
       end if;
 
+      --  No check needed for access to concurrent record types generated by
+      --  the expander. This is not just an optimization (though it does indeed
+      --  remove junk checks). It also avoids generation of junk warnings.
+
+      if Nkind (N) in N_Has_Chars
+        and then Chars (N) = Name_uObject
+        and then Is_Concurrent_Record_Type
+                   (Directly_Designated_Type (Etype (N)))
+      then
+         return;
+      end if;
+
       --  Otherwise install access check
 
       Insert_Action (N,
@@ -5050,22 +5159,6 @@ package body Checks is
          return Scope_Suppress (Overflow_Check);
       end if;
    end Overflow_Checks_Suppressed;
-
-   -----------------
-   -- Range_Check --
-   -----------------
-
-   function Range_Check
-     (Ck_Node    : Node_Id;
-      Target_Typ : Entity_Id;
-      Source_Typ : Entity_Id := Empty;
-      Warn_Node  : Node_Id   := Empty) return Check_Result
-   is
-   begin
-      return Selected_Range_Checks
-        (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
-   end Range_Check;
-
    -----------------------------
    -- Range_Checks_Suppressed --
    -----------------------------
@@ -5357,7 +5450,7 @@ package body Checks is
                   Next_Index (Indx_Type);
                end loop;
 
-               Get_Index_Bounds  (Indx_Type, Lo, Hi);
+               Get_Index_Bounds (Indx_Type, Lo, Hi);
 
                if Nkind (Lo) = N_Identifier
                  and then Ekind (Entity (Lo)) = E_In_Parameter
@@ -5542,9 +5635,9 @@ package body Checks is
          T_Typ := Designated_Type (T_Typ);
          Do_Access := True;
 
-         --  A simple optimization
+         --  A simple optimization for the null case
 
-         if Nkind (Ck_Node) = N_Null then
+         if Known_Null (Ck_Node) then
             return Ret_Result;
          end if;
       end if;
@@ -6193,9 +6286,9 @@ package body Checks is
          T_Typ := Designated_Type (T_Typ);
          Do_Access := True;
 
-         --  A simple optimization
+         --  A simple optimization for the null case
 
-         if Nkind (Ck_Node) = N_Null then
+         if Known_Null (Ck_Node) then
             return Ret_Result;
          end if;
       end if;

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 (

gcc/ada/types.ads

@@ -31,13 +31,13 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
---  This package contains host independent type definitions which are used
---  in more than one unit in the compiler. They are gathered here for easy
+--  This package contains host independent type definitions which are used in
+--  more than one unit in the compiler. They are gathered here for easy
 --  reference, though in some cases the full description is found in the
---  relevant module which implements the definition. The main reason that
---  they are not in their "natural" specs is that this would cause a lot
---  of inter-spec dependencies, and in particular some awkward circular
---  dependencies would have to be dealt with.
+--  relevant module which implements the definition. The main reason that they
+--  are not in their "natural" specs is that this would cause a lot of inter-
+--  spec dependencies, and in particular some awkward circular dependencies
+--  would have to be dealt with.
 
 --  WARNING: There is a C version of this package. Any changes to this source
 --  file must be properly reflected in the C header file types.h declarations.
@@ -108,9 +108,9 @@ package Types is
    --  Line terminator characters (LF, VT, FF, CR)
    --
    --  This definition is dubious now that we have two more wide character
-   --  sequences that constitute a line terminator. Every reference to
-   --  this subtype needs checking to make sure the wide character case
-   --  is handled appropriately. ???
+   --  sequences that constitute a line terminator. Every reference to this
+   --  subtype needs checking to make sure the wide character case is handled
+   --  appropriately. ???
 
    subtype Upper_Half_Character is
      Character range Character'Val (16#80#) .. Character'Val (16#FF#);
@@ -134,9 +134,9 @@ package Types is
    -- Types Used for Text Buffer Handling --
    -----------------------------------------
 
-   --  We can't use type String for text buffers, since we must use the
-   --  standard 32-bit integer as an index value, since we count on all
-   --  index values being the same size.
+   --  We can not use type String for text buffers, since we must use the
+   --  standard 32-bit integer as an index value, since we count on all index
+   --  values being the same size.
 
    type Text_Ptr is new Int;
    --  Type used for subscripts in text buffer
@@ -167,9 +167,9 @@ package Types is
 
    type Physical_Line_Number is range 1 .. Int'Last;
    for Physical_Line_Number'Size use 32;
-   --  Line number type, used for storing physical line numbers (i.e.
-   --  line numbers in the physical file being compiled, unaffected by
-   --  the presence of source reference pragmas.
+   --  Line number type, used for storing physical line numbers (i.e. line
+   --  numbers in the physical file being compiled, unaffected by the presence
+   --  of source reference pragmas.
 
    type Column_Number is range 0 .. 32767;
    for Column_Number'Size use 16;
@@ -183,20 +183,20 @@ package Types is
    subtype Source_Buffer is Text_Buffer;
    --  Type used to store text of a source file . The buffer for the main
    --  source (the source specified on the command line) has a lower bound
-   --  starting at zero. Subsequent subsidiary sources have lower bounds
-   --  which are one greater than the previous upper bound.
+   --  starting at zero. Subsequent subsidiary sources have lower bounds which
+   --  are one greater than the previous upper bound.
 
    subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last);
    --  This is a virtual type used as the designated type of the access
    --  type Source_Buffer_Ptr, see Osint.Read_Source_File for details.
 
    type Source_Buffer_Ptr is access all Big_Source_Buffer;
-   --  Pointer to source buffer. We use virtual origin addressing for
-   --  source buffers, with thin pointers. The pointer points to a virtual
-   --  instance of type Big_Source_Buffer, where the actual type is in fact
-   --  of type Source_Buffer. The address is adjusted so that the virtual
-   --  origin addressing works correctly. See Osint.Read_Source_Buffer for
-   --  further details.
+   --  Pointer to source buffer. We use virtual origin addressing for source
+   --  buffers, with thin pointers. The pointer points to a virtual instance
+   --  of type Big_Source_Buffer, where the actual type is in fact of type
+   --  Source_Buffer. The address is adjusted so that the virtual origin
+   --  addressing works correctly. See Osint.Read_Source_Buffer for further
+   --  details.
 
    subtype Source_Ptr is Text_Ptr;
    --  Type used to represent a source location, which is a subscript of a
@@ -215,10 +215,10 @@ package Types is
    --  mode and the corresponding source line in -gnatD mode).
 
    Standard_Location : constant Source_Ptr := -2;
-   --  Used for all nodes in the representation of package Standard other
-   --  than nodes representing the contents of Standard.ASCII. Note that
-   --  testing for <= Standard_Location tests for both Standard_Location
-   --  and for Standard_ASCII_Location.
+   --  Used for all nodes in the representation of package Standard other than
+   --  nodes representing the contents of Standard.ASCII. Note that testing for
+   --  a value being <= Standard_Location tests for both Standard_Location and
+   --  for Standard_ASCII_Location.
 
    Standard_ASCII_Location : constant Source_Ptr := -3;
    --  Used for all nodes in the presentation of package Standard.ASCII
@@ -266,13 +266,13 @@ package Types is
    --  List_Id and Node_Id values (see further description below).
 
    List_High_Bound : constant := 0;
-   --  Maximum List_Id subscript value. This allows up to 100 million list
-   --  Id values, which is in practice infinite, and there is no need to
-   --  check the range. The range overlaps the node range by one element
-   --  (with value zero), which is used both for the Empty node, and for
-   --  indicating no list. The fact that the same value is used is convenient
-   --  because it means that the default value of Empty applies to both nodes
-   --  and lists, and also is more efficient to test for.
+   --  Maximum List_Id subscript value. This allows up to 100 million list Id
+   --  values, which is in practice infinite, and there is no need to check the
+   --  range. The range overlaps the node range by one element (with value
+   --  zero), which is used both for the Empty node, and for indicating no
+   --  list. The fact that the same value is used is convenient because it
+   --  means that the default value of Empty applies to both nodes and lists,
+   --  and also is more efficient to test for.
 
    Node_Low_Bound : constant := 0;
    --  The tree Id values start at zero, because we use zero for Empty (to
@@ -413,10 +413,10 @@ package Types is
    ------------------------------
 
    --  List_Id values are used to identify node lists in the tree. They are
-   --  subscripts into the Lists table declared in package Tree. Note that
-   --  the special value Error_List is a subscript in this table, but the
-   --  value No_List is *not* a valid subscript, and any attempt to apply
-   --  list operations to No_List will cause a (detected) error.
+   --  subscripts into the Lists table declared in package Tree. Note that the
+   --  special value Error_List is a subscript in this table, but the value
+   --  No_List is *not* a valid subscript, and any attempt to apply list
+   --  operations to No_List will cause a (detected) error.
 
    type List_Id is range List_Low_Bound .. List_High_Bound;
    --  Type used to identify a node list
@@ -439,10 +439,10 @@ package Types is
    -- Types for Elists Package --
    ------------------------------
 
-   --  Element list Id values are used to identify element lists stored in
-   --  the tree (see package Tree for further details). They are formed by
-   --  adding a bias (Element_List_Bias) to subscript values in the same
-   --  array that is used for node list headers.
+   --  Element list Id values are used to identify element lists stored in the
+   --  tree (see package Tree for further details). They are formed by adding a
+   --  bias (Element_List_Bias) to subscript values in the same array that is
+   --  used for node list headers.
 
    type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound;
    --  Type used to identify an element list (Elist header table subscript)
@@ -471,8 +471,8 @@ package Types is
    -- Types for Stringt Package --
    -------------------------------
 
-   --  String_Id values are used to identify entries in the strings table.
-   --  They are subscripts into the strings table defined in package Strings.
+   --  String_Id values are used to identify entries in the strings table. They
+   --  are subscripts into the strings table defined in package Strings.
 
    --  Note that with only a few exceptions, which are clearly documented, the
    --  type String_Id should be regarded as a private type. In particular it is
@@ -492,15 +492,15 @@ package Types is
    -- Character Code Type --
    -------------------------
 
-   --  The type Char is used for character data internally in the compiler,
-   --  but character codes in the source are represented by the Char_Code
-   --  type. Each character literal in the source is interpreted as being one
-   --  of the 16#8000_0000 possible Wide_Wide_Character codes, and a unique
-   --  Integer Value is assigned, corresponding to the UTF_32 value, which
-   --  also correspondds to the POS value in the Wide_Wide_Character type,
-   --  and also corresponds to the POS value in the Wide_Character and
-   --  Character types for values that are in appropriate range. String
-   --  literals are similarly interpreted as a sequence of such codes.
+   --  The type Char is used for character data internally in the compiler, but
+   --  character codes in the source are represented by the Char_Code type.
+   --  Each character literal in the source is interpreted as being one of the
+   --  16#8000_0000 possible Wide_Wide_Character codes, and a unique Integer
+   --  Value is assigned, corresponding to the UTF_32 value, which also
+   --  correspondds to the POS value in the Wide_Wide_Character type, and also
+   --  corresponds to the POS value in the Wide_Character and Character types
+   --  for values that are in appropriate range. String literals are similarly
+   --  interpreted as a sequence of such codes.
 
    type Char_Code_Base is mod 2 ** 32;
    for Char_Code_Base'Size use 32;
@@ -530,7 +530,7 @@ package Types is
    pragma Inline (Get_Character);
    --  For a character C that is in Character range (see above function), this
    --  function returns the corresponding Character value. It is an error to
-   --  call Get_Character if C is not in C haracter range
+   --  call Get_Character if C is not in Character range.
 
    function Get_Wide_Character (C : Char_Code) return Wide_Character;
    --  For a character C that is in Wide_Character range (see above function),
@@ -596,11 +596,10 @@ package Types is
    --  Type used to represent time stamp
 
    Empty_Time_Stamp : constant Time_Stamp_Type := (others => ' ');
-   --  Type used to represent an empty or missing time stamp. Looks less
-   --  than any real time stamp if two time stamps are compared. Note that
-   --  although this is not a private type, clients should not rely on the
-   --  exact way in which this string is represented, and instead should
-   --  use the subprograms below.
+   --  Value representing an empty or missing time stamp. Looks less than any
+   --  real time stamp if two time stamps are compared. Note that although this
+   --  is not private, clients should not rely on the exact way in which this
+   --  string is represented, and instead should use the subprograms below.
 
    Dummy_Time_Stamp : constant Time_Stamp_Type := (others => '0');
    --  This is used for dummy time stamp values used in the D lines for
@@ -611,14 +610,15 @@ package Types is
    function ">=" (Left, Right : Time_Stamp_Type) return Boolean;
    function "<"  (Left, Right : Time_Stamp_Type) return Boolean;
    function ">"  (Left, Right : Time_Stamp_Type) return Boolean;
-   --  Comparison functions on time stamps. Note that two time stamps
-   --  are defined as being equal if they have the same day/month/year
-   --  and the hour/minutes/seconds values are within 2 seconds of one
-   --  another. This deals with rounding effects in library file time
-   --  stamps caused by copying operations during installation. We have
-   --  particularly noticed that WinNT seems susceptible to such changes.
-   --  Note: the Empty_Time_Stamp value looks equal to itself, and less
-   --  than any non-empty time stamp value.
+   --  Comparison functions on time stamps. Note that two time stamps are
+   --  defined as being equal if they have the same day/month/year and the
+   --  hour/minutes/seconds values are within 2 seconds of one another. This
+   --  deals with rounding effects in library file time stamps caused by
+   --  copying operations during installation. We have particularly noticed
+   --  that WinNT seems susceptible to such changes.
+   --
+   --  Note : the Empty_Time_Stamp value looks equal to itself, and less than
+   --  any non-empty time stamp value.
 
    procedure Split_Time_Stamp
      (TS      : Time_Stamp_Type;
@@ -644,21 +644,32 @@ package Types is
    -- Types used for Pragma Suppress Management --
    -----------------------------------------------
 
-   type Check_Id is
-     (Access_Check,
-      Accessibility_Check,
-      Alignment_Check,
-      Discriminant_Check,
-      Division_Check,
-      Elaboration_Check,
-      Index_Check,
-      Length_Check,
-      Overflow_Check,
-      Range_Check,
-      Storage_Check,
-      Tag_Check,
-      Validity_Check,
-      All_Checks);
+   type Check_Id is new Nat;
+   --  Type used to represent a check id
+
+   No_Check_Id         : constant := 0;
+   --  Check_Id value used to indicate no check
+
+   Access_Check        : constant :=  1;
+   Accessibility_Check : constant :=  2;
+   Alignment_Check     : constant :=  3;
+   Discriminant_Check  : constant :=  4;
+   Division_Check      : constant :=  5;
+   Elaboration_Check   : constant :=  6;
+   Index_Check         : constant :=  7;
+   Length_Check        : constant :=  8;
+   Overflow_Check      : constant :=  9;
+   Range_Check         : constant := 10;
+   Storage_Check       : constant := 11;
+   Tag_Check           : constant := 12;
+   Validity_Check      : constant := 13;
+   --  Values used to represent individual predefined checks
+
+   All_Checks          : constant := 14;
+   --  Value used to represent All_Checks value
+
+   subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks;
+   --  Subtype for predefined checks, including All_Checks
 
    --  The following array contains an entry for each recognized check name
    --  for pragma Suppress. It is used to represent current settings of scope
@@ -672,7 +683,7 @@ package Types is
    --  We recognize only an explicit suppress of Elaboration_Check as a signal
    --  that the static elaboration checking should skip a compile time check.
 
-   type Suppress_Array is array (Check_Id) of Boolean;
+   type Suppress_Array is array (Predefined_Check_Id) of Boolean;
    pragma Pack (Suppress_Array);
 
    --  To add a new check type to GNAT, the following steps are required:
@@ -691,19 +702,19 @@ package Types is
    --  throughout the compiler or in other GNAT tools.
 
    Unrecoverable_Error : exception;
-   --  This exception is raised to immediately terminate the compilation
-   --  of the current source program. Used in situations where things are
-   --  bad enough that it doesn't seem worth continuing (e.g. max errors
-   --  reached, or a required file is not found). Also raised when the
-   --  compiler finds itself in trouble after an error (see Comperr).
+   --  This exception is raised to immediately terminate the compilation of the
+   --  current source program. Used in situations where things are bad enough
+   --  that it doesn't seem worth continuing (e.g. max errors reached, or a
+   --  required file is not found). Also raised when the compiler finds itself
+   --  in trouble after an error (see Comperr).
 
    Terminate_Program : exception;
    --  This exception is raised to immediately terminate the tool being
-   --  executed. Each tool where this exception may be raised must have
-   --  a single exception handler that contains only a null statement and
-   --  that is the last statement of the program. If needed, procedure
-   --  Set_Exit_Status is called with the appropriate exit status before
-   --  raising Terminate_Program.
+   --  executed. Each tool where this exception may be raised must have a
+   --  single exception handler that contains only a null statement and that is
+   --  the last statement of the program. If needed, procedure Set_Exit_Status
+   --  is called with the appropriate exit status before raising
+   --  Terminate_Program.
 
    ---------------------------------
    -- Parameter Mechanism Control --
@@ -722,10 +733,10 @@ package Types is
    -- Run-Time Exception Codes --
    ------------------------------
 
-   --  When the code generator generates a run-time exception, it provides
-   --  a reason code which is one of the following. This reason code is used
-   --  to select the appropriate run-time routine to be called, determining
-   --  both the exception to be raised, and the message text to be added.
+   --  When the code generator generates a run-time exception, it provides a
+   --  reason code which is one of the following. This reason code is used to
+   --  select the appropriate run-time routine to be called, determining both
+   --  the exception to be raised, and the message text to be added.
 
    --  The prefix CE/PE/SE indicates the exception to be raised
    --    CE = Constraint_Error