Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                               C H E C K S                                --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2011, 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- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Atree;    use Atree;

with Debug;    use Debug;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Exp_Ch2;  use Exp_Ch2;

with Exp_Ch4;  use Exp_Ch4;

with Exp_Ch11; use Exp_Ch11;

with Exp_Pakd; use Exp_Pakd;

with Exp_Util; use Exp_Util;

with Elists;   use Elists;

with Eval_Fat; use Eval_Fat;

with Freeze;   use Freeze;

with Lib;      use Lib;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Output;   use Output;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Eval; use Sem_Eval;

with Sem_Ch3;  use Sem_Ch3;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Res;  use Sem_Res;

with Sem_Util; use Sem_Util;

with Sem_Warn; use Sem_Warn;

with Sinfo;    use Sinfo;

with Sinput;   use Sinput;

with Snames;   use Snames;

with Sprint;   use Sprint;

with Stand;    use Stand;

with Targparm; use Targparm;

with Tbuild;   use Tbuild;

with Ttypes;   use Ttypes;

with Urealp;   use Urealp;

with Validsw;  use Validsw;

package body Checks is

   --  General note: many of these routines are concerned with generating

   --  checking code to make sure that constraint error is raised at runtime.

   --  Clearly this code is only needed if the expander is active, since

   --  otherwise we will not be generating code or going into the runtime

   --  execution anyway.

   --  We therefore disconnect most of these checks if the expander is

   --  inactive. This has the additional benefit that we do not need to

   --  worry about the tree being messed up by previous errors (since errors

   --  turn off expansion anyway).

   --  There are a few exceptions to the above rule. For instance routines

   --  such as Apply_Scalar_Range_Check that do not insert any code can be

   --  safely called even when the Expander is inactive (but Errors_Detected

   --  is 0). The benefit of executing this code when expansion is off, is

   --  the ability to emit constraint error warning for static expressions

   --  even when we are not generating code.

   -------------------------------------

   -- Suppression of Redundant Checks --

   -------------------------------------

   --  This unit implements a limited circuit for removal of redundant

   --  checks. The processing is based on a tracing of simple sequential

   --  flow. For any sequence of statements, we save expressions that are

   --  marked to be checked, and then if the same expression appears later

   --  with the same check, then under certain circumstances, the second

   --  check can be suppressed.

   --  Basically, we can suppress the check if we know for certain that

   --  the previous expression has been elaborated (together with its

   --  check), and we know that the exception frame is the same, and that

   --  nothing has happened to change the result of the exception.

   --  Let us examine each of these three conditions in turn to describe

   --  how we ensure that this condition is met.

   --  First, we need to know for certain that the previous expression has

   --  been executed. This is done principally by the mechanism of calling

   --  Conditional_Statements_Begin at the start of any statement sequence

   --  and Conditional_Statements_End at the end. The End call causes all

   --  checks remembered since the Begin call to be discarded. This does

   --  miss a few cases, notably the case of a nested BEGIN-END block with

   --  no exception handlers. But the important thing is to be conservative.

   --  The other protection is that all checks are discarded if a label

   --  is encountered, since then the assumption of sequential execution

   --  is violated, and we don't know enough about the flow.

   --  Second, we need to know that the exception frame is the same. We

   --  do this by killing all remembered checks when we enter a new frame.

   --  Again, that's over-conservative, but generally the cases we can help

   --  with are pretty local anyway (like the body of a loop for example).

   --  Third, we must be sure to forget any checks which are no longer valid.

   --  This is done by two mechanisms, first the Kill_Checks_Variable call is

   --  used to note any changes to local variables. We only attempt to deal

   --  with checks involving local variables, so we do not need to worry

   --  about global variables. Second, a call to any non-global procedure

   --  causes us to abandon all stored checks, since such a all may affect

   --  the values of any local variables.

   --  The following define the data structures used to deal with remembering

   --  checks so that redundant checks can be eliminated as described above.

   --  Right now, the only expressions that we deal with are of the form of

   --  simple local objects (either declared locally, or IN parameters) or

   --  such objects plus/minus a compile time known constant. We can do

   --  more later on if it seems worthwhile, but this catches many simple

   --  cases in practice.

   --  The following record type reflects a single saved check. An entry

   --  is made in the stack of saved checks if and only if the expression

   --  has been elaborated with the indicated checks.

   type Saved_Check is record

      Killed : Boolean;

      --  Set True if entry is killed by Kill_Checks

      Entity : Entity_Id;

      --  The entity involved in the expression that is checked

      Offset : Uint;

      --  A compile time value indicating the result of adding or

      --  subtracting a compile time value. This value is to be

      --  added to the value of the Entity. A value of zero is

      --  used for the case of a simple entity reference.

      Check_Type : Character;

      --  This is set to 'R' for a range check (in which case Target_Type

      --  is set to the target type for the range check) or to 'O' for an

      --  overflow check (in which case Target_Type is set to Empty).

      Target_Type : Entity_Id;

      --  Used only if Do_Range_Check is set. Records the target type for

      --  the check. We need this, because a check is a duplicate only if

      --  it has the same target type (or more accurately one with a

      --  range that is smaller or equal to the stored target type of a

      --  saved check).

   end record;

   --  The following table keeps track of saved checks. Rather than use an

   --  extensible table. We just use a table of fixed size, and we discard

   --  any saved checks that do not fit. That's very unlikely to happen and

   --  this is only an optimization in any case.

   Saved_Checks : array (Int range 1 .. 200) of Saved_Check;

   --  Array of saved checks

   Num_Saved_Checks : Nat := 0;

   --  Number of saved checks

   --  The following stack keeps track of statement ranges. It is treated

   --  as a stack. When Conditional_Statements_Begin is called, an entry

   --  is pushed onto this stack containing the value of Num_Saved_Checks

   --  at the time of the call. Then when Conditional_Statements_End is

   --  called, this value is popped off and used to reset Num_Saved_Checks.

   --  Note: again, this is a fixed length stack with a size that should

   --  always be fine. If the value of the stack pointer goes above the

   --  limit, then we just forget all saved checks.

   Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;

   Saved_Checks_TOS : Nat := 0;

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Apply_Float_Conversion_Check

     (Ck_Node    : Node_Id;

      Target_Typ : Entity_Id);

   --  The checks on a conversion from a floating-point type to an integer

   --  type are delicate. They have to be performed before conversion, they

   --  have to raise an exception when the operand is a NaN, and rounding must

   --  be taken into account to determine the safe bounds of the operand.

   procedure Apply_Selected_Length_Checks

     (Ck_Node    : Node_Id;

      Target_Typ : Entity_Id;

      Source_Typ : Entity_Id;

      Do_Static  : Boolean);

   --  This is the subprogram that does all the work for Apply_Length_Check

   --  and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as

   --  described for the above routines. The Do_Static flag indicates that

   --  only a static check is to be done.

   procedure Apply_Selected_Range_Checks

     (Ck_Node    : Node_Id;

      Target_Typ : Entity_Id;

      Source_Typ : Entity_Id;

      Do_Static  : Boolean);

   --  This is the subprogram that does all the work for Apply_Range_Check.

   --  Expr, Target_Typ and Source_Typ are as described for the above

   --  routine. The Do_Static flag indicates that only a static check is

   --  to be done.

   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

   --  source, and N is the node for the reference. If N is not of this form,

   --  True is returned with no further processing. If N is of the right form,

   --  then further processing determines if the given Check is needed.

   --

   --  The particular circuit is to see if we have the case of a check that is

   --  not needed because it appears in the right operand of a short circuited

   --  conditional where the left operand guards the check. For example:

   --

   --    if Var = 0 or else Q / Var > 12 then

   --       ...

   --    end if;

   --

   --  In this example, the division check is not required. At the same time

   --  we can issue warnings for suspicious use of non-short-circuited forms,

   --  such as:

   --

   --    if Var = 0 or Q / Var > 12 then

   --       ...

   --    end if;

   procedure Find_Check

     (Expr        : Node_Id;

      Check_Type  : Character;

      Target_Type : Entity_Id;

      Entry_OK    : out Boolean;

      Check_Num   : out Nat;

      Ent         : out Entity_Id;

      Ofs         : out Uint);

   --  This routine is used by Enable_Range_Check and Enable_Overflow_Check

   --  to see if a check is of the form for optimization, and if so, to see

   --  if it has already been performed. Expr is the expression to check,

   --  and Check_Type is 'R' for a range check, 'O' for an overflow check.

   --  Target_Type is the target type for a range check, and Empty for an

   --  overflow check. If the entry is not of the form for optimization,

   --  then Entry_OK is set to False, and the remaining out parameters

   --  are undefined. If the entry is OK, then Ent/Ofs are set to the

   --  entity and offset from the expression. Check_Num is the number of

   --  a matching saved entry in Saved_Checks, or zero if no such entry

   --  is located.

   function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;

   --  If a discriminal is used in constraining a prival, Return reference

   --  to the discriminal of the protected body (which renames the parameter

   --  of the enclosing protected operation). This clumsy transformation is

   --  needed because privals are created too late and their actual subtypes

   --  are not available when analysing the bodies of the protected operations.

   --  This function is called whenever the bound is an entity and the scope

   --  indicates a protected operation. If the bound is an in-parameter of

   --  a protected operation that is not a prival, the function returns the

   --  bound itself.

   --  To be cleaned up???

   function Guard_Access

     (Cond    : Node_Id;

      Loc     : Source_Ptr;

      Ck_Node : Node_Id) return Node_Id;

   --  In the access type case, guard the test with a test to ensure

   --  that the access value is non-null, since the checks do not

   --  not apply to null access values.

   procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);

   --  Called by Apply_{Length,Range}_Checks to rewrite the tree with the

   --  Constraint_Error node.

   function Range_Or_Validity_Checks_Suppressed

     (Expr : Node_Id) return Boolean;

   --  Returns True if either range or validity checks or both are suppressed

   --  for the type of the given expression, or, if the expression is the name

   --  of an entity, if these checks are suppressed for the entity.

   function Selected_Length_Checks

     (Ck_Node    : Node_Id;

      Target_Typ : Entity_Id;

      Source_Typ : Entity_Id;

      Warn_Node  : Node_Id) return Check_Result;

   --  Like Apply_Selected_Length_Checks, except it doesn't modify

   --  anything, just returns a list of nodes as described in the spec of

   --  this package for the Range_Check function.

   function Selected_Range_Checks

     (Ck_Node    : Node_Id;

      Target_Typ : Entity_Id;

      Source_Typ : Entity_Id;

      Warn_Node  : Node_Id) return Check_Result;

   --  Like Apply_Selected_Range_Checks, except it doesn't modify anything,

   --  just returns a list of nodes as described in the spec of this package

   --  for the Range_Check function.

   ------------------------------

   -- Access_Checks_Suppressed --

   ------------------------------

   function Access_Checks_Suppressed (E : Entity_Id) return Boolean is

   begin

      if Present (E) and then Checks_May_Be_Suppressed (E) then

         return Is_Check_Suppressed (E, Access_Check);

      else

         return Scope_Suppress (Access_Check);

      end if;

   end Access_Checks_Suppressed;

   -------------------------------------

   -- Accessibility_Checks_Suppressed --

   -------------------------------------

   function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is

   begin

      if Present (E) and then Checks_May_Be_Suppressed (E) then

         return Is_Check_Suppressed (E, Accessibility_Check);

      else

         return Scope_Suppress (Accessibility_Check);

      end if;

   end Accessibility_Checks_Suppressed;

   -----------------------------

   -- Activate_Division_Check --

   -----------------------------

   procedure Activate_Division_Check (N : Node_Id) is

   begin

      Set_Do_Division_Check (N, True);

      Possible_Local_Raise (N, Standard_Constraint_Error);

   end Activate_Division_Check;

   -----------------------------

   -- Activate_Overflow_Check --

   -----------------------------

   procedure Activate_Overflow_Check (N : Node_Id) is

   begin

      Set_Do_Overflow_Check (N, True);

      Possible_Local_Raise (N, Standard_Constraint_Error);

   end Activate_Overflow_Check;

   --------------------------

   -- Activate_Range_Check --

   --------------------------

   procedure Activate_Range_Check (N : Node_Id) is

   begin

      Set_Do_Range_Check (N, True);

      Possible_Local_Raise (N, Standard_Constraint_Error);

   end Activate_Range_Check;

   ---------------------------------

   -- Alignment_Checks_Suppressed --

   ---------------------------------

   function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is

   begin

      if Present (E) and then Checks_May_Be_Suppressed (E) then

         return Is_Check_Suppressed (E, Alignment_Check);

      else

         return Scope_Suppress (Alignment_Check);

      end if;

   end Alignment_Checks_Suppressed;

   -------------------------

   -- Append_Range_Checks --

   -------------------------

   procedure Append_Range_Checks

     (Checks       : Check_Result;

      Stmts        : List_Id;

      Suppress_Typ : Entity_Id;

      Static_Sloc  : Source_Ptr;

      Flag_Node    : Node_Id)

   is

      Internal_Flag_Node   : constant Node_Id    := Flag_Node;

      Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;

      Checks_On : constant Boolean :=

                    (not Index_Checks_Suppressed (Suppress_Typ))

                       or else

                    (not Range_Checks_Suppressed (Suppress_Typ));

   begin

      --  For now we just return if Checks_On is false, however this should

      --  be enhanced to check for an always True value in the condition

      --  and to generate a compilation warning???

      if not Checks_On then

         return;

      end if;

      for J in 1 .. 2 loop

         exit when No (Checks (J));

         if Nkind (Checks (J)) = N_Raise_Constraint_Error

           and then Present (Condition (Checks (J)))

         then

            if not Has_Dynamic_Range_Check (Internal_Flag_Node) then

               Append_To (Stmts, Checks (J));

               Set_Has_Dynamic_Range_Check (Internal_Flag_Node);

            end if;

         else

            Append_To

              (Stmts,

                Make_Raise_Constraint_Error (Internal_Static_Sloc,

                  Reason => CE_Range_Check_Failed));

         end if;

      end loop;

   end Append_Range_Checks;

   ------------------------

   -- Apply_Access_Check --

   ------------------------

   procedure Apply_Access_Check (N : Node_Id) is

      P : constant Node_Id := Prefix (N);

   begin

      --  We do not need checks if we are not generating code (i.e. the

      --  expander is not active). This is not just an optimization, there

      --  are cases (e.g. with pragma Debug) where generating the checks

      --  can cause real trouble).

      if not Full_Expander_Active then

         return;

      end if;

      --  No check if short circuiting makes check unnecessary

      if not Check_Needed (P, Access_Check) then

         return;

      end if;

      --  No check if accessing the Offset_To_Top component of a dispatch

      --  table. They are safe by construction.

      if Tagged_Type_Expansion

        and then Present (Etype (P))

        and then RTU_Loaded (Ada_Tags)

        and then RTE_Available (RE_Offset_To_Top_Ptr)

        and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)

      then

         return;

      end if;

      --  Otherwise go ahead and install the check

      Install_Null_Excluding_Check (P);

   end Apply_Access_Check;

   -------------------------------

   -- Apply_Accessibility_Check --

   -------------------------------

   procedure Apply_Accessibility_Check

     (N           : Node_Id;

      Typ         : Entity_Id;

      Insert_Node : Node_Id)

   is

      Loc         : constant Source_Ptr := Sloc (N);

      Param_Ent   : Entity_Id           := Param_Entity (N);

      Param_Level : Node_Id;

      Type_Level  : Node_Id;

   begin

      if Ada_Version >= Ada_2012

         and then not Present (Param_Ent)

         and then Is_Entity_Name (N)

         and then Ekind_In (Entity (N), E_Constant, E_Variable)

         and then Present (Effective_Extra_Accessibility (Entity (N)))

      then

         Param_Ent := Entity (N);

         while Present (Renamed_Object (Param_Ent)) loop

            --  Renamed_Object must return an Entity_Name here

            --  because of preceding "Present (E_E_A (...))" test.

            Param_Ent := Entity (Renamed_Object (Param_Ent));

         end loop;

      end if;

      if Inside_A_Generic then

         return;

      --  Only apply the run-time check if the access parameter has an

      --  associated extra access level parameter and when the level of the

      --  type is less deep than the level of the access parameter, and

      --  accessibility checks are not suppressed.

      elsif Present (Param_Ent)

         and then Present (Extra_Accessibility (Param_Ent))

         and then UI_Gt (Object_Access_Level (N),

                         Deepest_Type_Access_Level (Typ))

         and then not Accessibility_Checks_Suppressed (Param_Ent)

         and then not Accessibility_Checks_Suppressed (Typ)

      then

         Param_Level :=

           New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);

         Type_Level :=

           Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));

         --  Raise Program_Error if the accessibility level of the access

         --  parameter is deeper than the level of the target access type.

         Insert_Action (Insert_Node,

           Make_Raise_Program_Error (Loc,

             Condition =>

               Make_Op_Gt (Loc,

                 Left_Opnd  => Param_Level,

                 Right_Opnd => Type_Level),

             Reason => PE_Accessibility_Check_Failed));

         Analyze_And_Resolve (N);

      end if;

   end Apply_Accessibility_Check;

   --------------------------------

   -- Apply_Address_Clause_Check --

   --------------------------------

   procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is

      AC   : constant Node_Id    := Address_Clause (E);

      Loc  : constant Source_Ptr := Sloc (AC);

      Typ  : constant Entity_Id  := Etype (E);

      Aexp : constant Node_Id    := Expression (AC);

      Expr : Node_Id;

      --  Address expression (not necessarily the same as Aexp, for example

      --  when Aexp is a reference to a constant, in which case Expr gets

      --  reset to reference the value expression of the constant.

      procedure Compile_Time_Bad_Alignment;

      --  Post error warnings when alignment is known to be incompatible. Note

      --  that we do not go as far as inserting a raise of Program_Error since

      --  this is an erroneous case, and it may happen that we are lucky and an

      --  underaligned address turns out to be OK after all.

      --------------------------------

      -- Compile_Time_Bad_Alignment --

      --------------------------------

      procedure Compile_Time_Bad_Alignment is

      begin

         if Address_Clause_Overlay_Warnings then

            Error_Msg_FE

              ("?specified address for& may be inconsistent with alignment ",

               Aexp, E);

            Error_Msg_FE

              ("\?program execution may be erroneous (RM 13.3(27))",

               Aexp, E);

            Set_Address_Warning_Posted (AC);

         end if;

      end Compile_Time_Bad_Alignment;

   --  Start of processing for Apply_Address_Clause_Check

   begin

      --  See if alignment check needed. Note that we never need a check if the

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

      --  the status of check suppressing at the point of the address clause.

      if No (AC)

        or else not Check_Address_Alignment (AC)

        or else Maximum_Alignment = 1

      then

         return;

      end if;

      --  Obtain expression from address clause

      Expr := Expression (AC);

      --  The following loop digs for the real expression to use in the check

      loop

         --  For constant, get constant expression

         if Is_Entity_Name (Expr)

           and then Ekind (Entity (Expr)) = E_Constant

         then

            Expr := Constant_Value (Entity (Expr));

         --  For unchecked conversion, get result to convert

         elsif Nkind (Expr) = N_Unchecked_Type_Conversion then

            Expr := Expression (Expr);

         --  For (common case) of To_Address call, get argument

         elsif Nkind (Expr) = N_Function_Call

           and then Is_Entity_Name (Name (Expr))

           and then Is_RTE (Entity (Name (Expr)), RE_To_Address)

         then

            Expr := First (Parameter_Associations (Expr));

            if Nkind (Expr) = N_Parameter_Association then

               Expr := Explicit_Actual_Parameter (Expr);

            end if;

         --  We finally have the real expression

         else

            exit;

         end if;

      end loop;

      --  See if we know that Expr has a bad alignment at compile time

      if Compile_Time_Known_Value (Expr)

        and then (Known_Alignment (E) or else Known_Alignment (Typ))

      then

         declare

            AL : Uint := Alignment (Typ);

         begin

            --  The object alignment might be more restrictive than the

            --  type alignment.

            if Known_Alignment (E) then

               AL := Alignment (E);

            end if;

            if Expr_Value (Expr) mod AL /= 0 then

               Compile_Time_Bad_Alignment;

            else

               return;

            end if;

         end;

      --  If the expression has the form X'Address, then we can find out if

      --  the object X has an alignment that is compatible with the object E.

      --  If it hasn't or we don't know, we defer issuing the warning until

      --  the end of the compilation to take into account back end annotations.

      elsif Nkind (Expr) = N_Attribute_Reference

        and then Attribute_Name (Expr) = Name_Address

        and then Has_Compatible_Alignment (E, Prefix (Expr)) = Known_Compatible

      then

         return;

      end if;

      --  Here we do not know if the value is acceptable. Strictly we don't

      --  have to do anything, since if the alignment is bad, we have an

      --  erroneous program. However we are allowed to check for erroneous

      --  conditions and we decide to do this by default if the check is not

      --  suppressed.

      --  However, don't do the check if elaboration code is unwanted

      if Restriction_Active (No_Elaboration_Code) then

         return;

      --  Generate a check to raise PE if alignment may be inappropriate

      else

         --  If the original expression is a non-static constant, use the

         --  name of the constant itself rather than duplicating its

         --  defining expression, which was extracted above.

         --  Note: Expr is empty if the address-clause is applied to in-mode

         --  actuals (allowed by 13.1(22)).

         if not Present (Expr)

           or else

             (Is_Entity_Name (Expression (AC))

               and then Ekind (Entity (Expression (AC))) = E_Constant

               and then Nkind (Parent (Entity (Expression (AC))))

                                 = N_Object_Declaration)

         then

            Expr := New_Copy_Tree (Expression (AC));

         else

            Remove_Side_Effects (Expr);

         end if;

         Insert_After_And_Analyze (N,

           Make_Raise_Program_Error (Loc,

             Condition =>

               Make_Op_Ne (Loc,

                 Left_Opnd =>

                   Make_Op_Mod (Loc,

                     Left_Opnd =>

                       Unchecked_Convert_To

                         (RTE (RE_Integer_Address), Expr),

                     Right_Opnd =>

                       Make_Attribute_Reference (Loc,

                         Prefix => New_Occurrence_Of (E, Loc),

                         Attribute_Name => Name_Alignment)),

                 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),

             Reason => PE_Misaligned_Address_Value),

           Suppress => All_Checks);

         return;

      end if;

   exception

      --  If we have some missing run time component in configurable run time

      --  mode then just skip the check (it is not required in any case).

      when RE_Not_Available =>

         return;

   end Apply_Address_Clause_Check;

   -------------------------------------

   -- Apply_Arithmetic_Overflow_Check --

   -------------------------------------

   --  This routine is called only if the type is an integer type, and a

   --  software arithmetic overflow check may be needed for op (add, subtract,

   --  or multiply). This check is performed only if Software_Overflow_Checking

   --  is enabled and Do_Overflow_Check is set. In this case we expand the

   --  operation into a more complex sequence of tests that ensures that

   --  overflow is properly caught.

   procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is

      Loc   : constant Source_Ptr := Sloc (N);

      Typ   : constant Entity_Id  := Etype (N);

      Rtyp  : constant Entity_Id  := Root_Type (Typ);

   begin

      --  An interesting special case. If the arithmetic operation appears as

      --  the operand of a type conversion:

      --    type1 (x op y)

      --  and all the following conditions apply:

      --    arithmetic operation is for a signed integer type

      --    target type type1 is a static integer subtype

      --    range of x and y are both included in the range of type1

      --    range of x op y is included in the range of type1

      --    size of type1 is at least twice the result size of op

      --  then we don't do an overflow check in any case, instead we transform

      --  the operation so that we end up with:

      --    type1 (type1 (x) op type1 (y))

      --  This avoids intermediate overflow before the conversion. It is

      --  explicitly permitted by RM 3.5.4(24):

      --    For the execution of a predefined operation of a signed integer

      --    type, the implementation need not raise Constraint_Error if the

      --    result is outside the base range of the type, so long as the

      --    correct result is produced.

      --  It's hard to imagine that any programmer counts on the exception

      --  being raised in this case, and in any case it's wrong coding to

      --  have this expectation, given the RM permission. Furthermore, other

      --  Ada compilers do allow such out of range results.

      --  Note that we do this transformation even if overflow checking is

      --  off, since this is precisely about giving the "right" result and

      --  avoiding the need for an overflow check.

      --  Note: this circuit is partially redundant with respect to the similar

      --  processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals

      --  with cases that do not come through here. We still need the following

      --  processing even with the Exp_Ch4 code in place, since we want to be

      --  sure not to generate the arithmetic overflow check in these cases

      --  (Exp_Ch4 would have a hard time removing them once generated).

      if Is_Signed_Integer_Type (Typ)

        and then Nkind (Parent (N)) = N_Type_Conversion