home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / checks.adb < prev    next >
Text File  |  1996-09-28  |  28KB  |  815 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                               C H E C K S                                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.5 $                              --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Atree;    use Atree;
  26. with Einfo;    use Einfo;
  27. with Exp_Util; use Exp_Util;
  28. with Nlists;   use Nlists;
  29. with Nmake;    use Nmake;
  30. with Rtsfind;  use Rtsfind;
  31. with Sem;      use Sem;
  32. with Sem_Eval; use Sem_Eval;
  33. with Sem_Res;  use Sem_Res;
  34. with Sem_Util; use Sem_Util;
  35. with Sinfo;    use Sinfo;
  36. with Snames;   use Snames;
  37. with Stand;    use Stand;
  38. with Tbuild;   use Tbuild;
  39. with Ttypes;   use Ttypes;
  40. with Uintp;    use Uintp;
  41. with Urealp;   use Urealp;
  42.  
  43. package body Checks is
  44.  
  45.    ------------------------------
  46.    -- Access_Checks_Suppressed --
  47.    ------------------------------
  48.  
  49.    function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
  50.    begin
  51.       return Scope_Suppress.Access_Checks
  52.         or else (Present (E) and then Suppress_Access_Checks (E));
  53.    end Access_Checks_Suppressed;
  54.  
  55.    -------------------------------------
  56.    -- Accessibility_Checks_Suppressed --
  57.    -------------------------------------
  58.  
  59.    function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
  60.    begin
  61.       return Scope_Suppress.Accessibility_Checks
  62.         or else (Present (E) and then Suppress_Accessibility_Checks (E));
  63.    end Accessibility_Checks_Suppressed;
  64.  
  65.    ------------------------
  66.    -- Apply_Access_Check --
  67.    ------------------------
  68.  
  69.    procedure Apply_Access_Check (N : Node_Id; Typ : Entity_Id) is
  70.    begin
  71.       if not Access_Checks_Suppressed (Typ) then
  72.          Set_Do_Access_Check (N, True);
  73.       end if;
  74.    end Apply_Access_Check;
  75.  
  76.    -------------------------------------
  77.    -- Apply_Arithmetic_Overflow_Check --
  78.    -------------------------------------
  79.  
  80.    --  This routine is called only if the type is an integer type, and
  81.    --  a software arithmetic overflow check must be performed for op
  82.    --  (add, subtract, divide, multiply):
  83.  
  84.    --    x op y
  85.  
  86.    --  is expanded into
  87.  
  88.    --    Typ (Checktyp (x) op Checktyp (y));
  89.  
  90.    --  where Typ is the type of the original expression, and Checktyp is an
  91.    --  integer type of sufficient length to hold the largest possible result.
  92.  
  93.    --  In the case where the check type exceeds the size of Long_Long_Integer,
  94.    --  we use a different approach, expanding to:
  95.  
  96.    --    typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
  97.  
  98.    --  where xxx is Add, Divide, Multiply or Subtract as appropriate
  99.  
  100.    procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
  101.       Loc   : constant Source_Ptr := Sloc (N);
  102.       Typ   : constant Entity_Id  := Etype (N);
  103.       Rtyp  : constant Entity_Id  := Root_Type (Typ);
  104.       Siz   : constant Int        := UI_To_Int (Esize (Rtyp));
  105.       Dsiz  : constant Int        := Siz * 2;
  106.       Opnod : constant Node_Id    := Relocate_Node (N);
  107.       Ctyp  : Entity_Id;
  108.       Opnd  : Node_Id;
  109.       Cent  : RE_Id;
  110.  
  111.    begin
  112.       --  Find check type if one exists
  113.  
  114.       if Dsiz <= Standard_Integer_Size then
  115.          Ctyp := Standard_Integer;
  116.  
  117.       elsif Dsiz <= Standard_Long_Long_Integer_Size then
  118.          Ctyp := Standard_Long_Long_Integer;
  119.  
  120.       --  No check type exists, use runtime call
  121.  
  122.       else
  123.          if Nkind (N) = N_Op_Add then
  124.             Cent := RE_Add_With_Ovflo_Check;
  125.          elsif Nkind (N) = N_Op_Divide then
  126.             Cent := RE_Divide_With_Ovflo_Check;
  127.          elsif Nkind (N) = N_Op_Multiply then
  128.             Cent := RE_Multiply_With_Ovflo_Check;
  129.          elsif Nkind (N) = N_Op_Subtract then
  130.             Cent := RE_Subtract_With_Ovflo_Check;
  131.          else
  132.             pragma Assert (False); null;
  133.          end if;
  134.  
  135.          Rewrite_Substitute_Tree (N,
  136.            Make_Type_Conversion (Loc,
  137.              Subtype_Mark => New_Reference_To (Typ, Loc),
  138.              Expression =>
  139.                Make_Function_Call (Loc,
  140.                  Name => New_Reference_To (RTE (Cent), Loc),
  141.                  Parameter_Associations => New_List (
  142.                    Make_Type_Conversion (Loc,
  143.                      Subtype_Mark =>
  144.                        New_Reference_To (RTE (RE_Integer_64), Loc),
  145.                      Expression => Left_Opnd (Opnod)),
  146.                    Make_Type_Conversion (Loc,
  147.                      Subtype_Mark =>
  148.                        New_Reference_To (RTE (RE_Integer_64), Loc),
  149.                      Expression => Right_Opnd (Opnod))))));
  150.  
  151.          Analyze (N);
  152.          Resolve (N, Typ);
  153.          return;
  154.       end if;
  155.  
  156.       --  If we fall through, we have the case where we do the arithmetic in
  157.       --  the next higher type and get the check by conversion. In these cases
  158.       --  Ctyp is set to the type to be used as the check type.
  159.  
  160.       Opnd :=
  161.         Make_Type_Conversion (Loc,
  162.           Subtype_Mark => New_Reference_To (Ctyp, Loc),
  163.             Expression => Left_Opnd (Opnod));
  164.  
  165.       Analyze (Opnd);
  166.       Set_Etype (Opnd, Ctyp);
  167.       Set_Analyzed (Opnd, True);
  168.       Set_Left_Opnd (Opnod, Opnd);
  169.  
  170.       Opnd :=
  171.         Make_Type_Conversion (Loc,
  172.           Subtype_Mark => New_Reference_To (Ctyp, Loc),
  173.           Expression => Right_Opnd (Opnod));
  174.  
  175.       Analyze (Opnd);
  176.       Set_Etype (Opnd, Ctyp);
  177.       Set_Analyzed (Opnd, True);
  178.       Set_Right_Opnd (Opnod, Opnd);
  179.  
  180.       --  The type of the operation changes to the base type of the check
  181.       --  type, and we reset the overflow check indication, since clearly
  182.       --  no overflow is possible now that we are using a double length
  183.       --  type. We also set the Analyzed flag to avoid a recursive attempt
  184.       --  to expand the node.
  185.  
  186.       Set_Etype             (Opnod, Base_Type (Ctyp));
  187.       Set_Do_Overflow_Check (Opnod, False);
  188.       Set_Analyzed          (Opnod, True);
  189.  
  190.       --  Now build the outer conversion
  191.  
  192.       Opnd :=
  193.         Make_Type_Conversion (Loc,
  194.           Subtype_Mark => New_Reference_To (Typ, Loc),
  195.           Expression => Opnod);
  196.  
  197.       Analyze (Opnd);
  198.       Set_Etype (Opnd, Typ);
  199.       Set_Analyzed (Opnd, True);
  200.       Set_Do_Overflow_Check (Opnd, True);
  201.  
  202.       Rewrite_Substitute_Tree (N, Opnd);
  203.    end Apply_Arithmetic_Overflow_Check;
  204.  
  205.    ------------------------------
  206.    -- Apply_Discriminant_Check --
  207.    ------------------------------
  208.  
  209.    procedure Apply_Discriminant_Check (N : Node_Id; Typ : Entity_Id) is
  210.    begin
  211.       if not Discriminant_Checks_Suppressed (Typ) then
  212.          Set_Do_Discriminant_Check (N, True);
  213.       end if;
  214.    end Apply_Discriminant_Check;
  215.  
  216.    ------------------------
  217.    -- Apply_Length_Check --
  218.    ------------------------
  219.  
  220.    procedure Apply_Length_Check
  221.      (Expr : Node_Id;
  222.       Typ  : Entity_Id)
  223.    is
  224.       Loc         : constant Source_Ptr := Sloc (Expr);
  225.       Expr_Actual : constant Node_Id    := Get_Referenced_Object (Expr);
  226.       Exptyp      : constant Entity_Id  := Get_Actual_Subtype (Expr_Actual);
  227.       Ndims       : constant Nat        := Number_Dimensions (Typ);
  228.       Cond        : Node_Id;
  229.  
  230.       function Get_Length
  231.         (E    : Entity_Id;
  232.          Indx : Nat)
  233.          return Node_Id;
  234.       --  Returns expression for Indx'th length of array type E
  235.  
  236.       function Get_Length
  237.         (E    : Entity_Id;
  238.          Indx : Nat)
  239.          return Node_Id
  240.       is
  241.          N : Node_Id;
  242.  
  243.       begin
  244.          if Ekind (E) = E_String_Literal_Subtype then
  245.             return
  246.               Make_Integer_Literal (Loc,
  247.                 Intval => String_Literal_Length (E));
  248.  
  249.          else
  250.             N :=
  251.               Make_Attribute_Reference (Loc,
  252.                 Attribute_Name => Name_Length,
  253.                 Prefix => New_Occurrence_Of (E, Loc));
  254.  
  255.             if Indx > 1 then
  256.                Set_Expressions (N, New_List (
  257.                  Make_Integer_Literal (Loc, UI_From_Int (Indx))));
  258.             end if;
  259.  
  260.             return N;
  261.          end if;
  262.       end Get_Length;
  263.  
  264.    --  Start processing for Length_Check
  265.  
  266.    begin
  267.       --  String_Literal case. This needs to be handled specially because
  268.       --  no index types are available for string literals. The condition
  269.       --  is simply:
  270.  
  271.       --    Typ'Length = string-literal-length
  272.  
  273.       if Nkind (Expr_Actual) = N_String_Literal then
  274.          Cond :=
  275.            Make_Op_Ne (Loc,
  276.              Left_Opnd  => Get_Length (Typ, 1),
  277.              Right_Opnd =>
  278.                Make_Integer_Literal (Loc,
  279.                  Intval => String_Literal_Length (Etype (Expr_Actual))));
  280.  
  281.       --  Handle cases where we do not get a usable actual subtype that is
  282.       --  constrained. This happens for example in the function call and
  283.       --  explicit dereference cases. In these cases, we have to get the
  284.       --  length from the expression itself, making sure we do not evaluate
  285.       --  it more than once.
  286.  
  287.       --     Typ'Length     /= Expr'Length (1) or else
  288.       --     Typ'Length (2) /= Expr'Length (2) or else
  289.       --     Typ'Length (3) /= Expr'Length (3) or else
  290.       --     ...
  291.  
  292.       --  Here Expr is the original expression, or more properly the result
  293.       --  of applying Duplicate_Expr to the original tree, forcing the result
  294.       --  to be a name.
  295.  
  296.       elsif not Is_Constrained (Exptyp) then
  297.          declare
  298.             Cond1   : Node_Id;
  299.  
  300.          begin
  301.             --  Build the condition for the explicit dereference case
  302.  
  303.             Cond := Empty;
  304.             for Indx in 1 .. Ndims loop
  305.  
  306.                --  Build check for one index position
  307.  
  308.                Cond1 :=
  309.                  Make_Op_Ne (Loc,
  310.                    Left_Opnd  => Get_Length (Typ, Indx),
  311.                    Right_Opnd =>
  312.                      Make_Attribute_Reference (Loc,
  313.                        Attribute_Name => Name_Length,
  314.                        Prefix =>
  315.                          Duplicate_Subexpr (Expr, Name_Req => True),
  316.                        Expressions    => New_List (
  317.                          Make_Integer_Literal (Loc, UI_From_Int (Indx)))));
  318.  
  319.                --  Add new check to evolving condition
  320.  
  321.                if No (Cond) then
  322.                   Cond := Cond1;
  323.                else
  324.                   Cond :=
  325.                     Make_Or_Else (Loc,
  326.                       Left_Opnd  => Cond,
  327.                       Right_Opnd => Cond1);
  328.                end if;
  329.             end loop;
  330.          end;
  331.  
  332.       --  General array case. Here we have a usable actual subtype for the
  333.       --  expression, and the condition is built from the two types:
  334.  
  335.       --     Typ'Length     /= Exptyp'Length     or else
  336.       --     Typ'Length (2) /= Exptyp'Length (2) or else
  337.       --     Typ'Length (3) /= Exptyp'Length (3) or else
  338.       --     ...
  339.  
  340.       --  The comparison for an individual index subtype is omitted if the
  341.       --  corresponding index subtypes statically match, since the result
  342.       --  is known to be true. Note that this test is worth while even though
  343.       --  we do static evaluation, because it is possible for non-static
  344.       --  subtypes to statically match.
  345.  
  346.       else
  347.          declare
  348.             L_Index : Node_Id;
  349.             R_Index : Node_Id;
  350.             Cond1   : Node_Id;
  351.  
  352.          begin
  353.             L_Index := First_Index (Typ);
  354.             R_Index := First_Index (Exptyp);
  355.             Cond    := Empty;
  356.  
  357.             for Indx in 1 .. Ndims loop
  358.                if not
  359.                  Subtypes_Statically_Match (Etype (L_Index), Etype (R_Index))
  360.                then
  361.                   Cond1 :=
  362.                     Make_Op_Ne (Loc,
  363.                       Left_Opnd  => Get_Length (Typ, Indx),
  364.                       Right_Opnd => Get_Length (Exptyp, Indx));
  365.  
  366.                   --  Add new check to evolving condition
  367.  
  368.                   if No (Cond) then
  369.                      Cond := Cond1;
  370.                   else
  371.                      Cond :=
  372.                        Make_Or_Else (Loc,
  373.                          Left_Opnd  => Cond,
  374.                          Right_Opnd => Cond1);
  375.                   end if;
  376.                end if;
  377.  
  378.                L_Index := Next (L_Index);
  379.                R_Index := Next (R_Index);
  380.             end loop;
  381.          end;
  382.       end if;
  383.  
  384.       --  Construct the test and insert into the tree
  385.  
  386.       if Present (Cond) then
  387.  
  388.          Insert_Action (Expr,
  389.            Make_If_Statement (Loc,
  390.              Condition => Cond,
  391.              Then_Statements => New_List (
  392.                Make_Raise_Statement (Loc,
  393.                  Name =>
  394.                    New_Reference_To
  395.                      (Standard_Constraint_Error, Loc)))));
  396.  
  397.          if Is_Entity_Name (Cond)
  398.            and then Entity (Cond) = Standard_True
  399.          then
  400.             Compile_Time_Constraint_Error (Expr, "wrong length for array?");
  401.          end if;
  402.       end if;
  403.    end Apply_Length_Check;
  404.  
  405.    -----------------------
  406.    -- Apply_Range_Check --
  407.    -----------------------
  408.  
  409.    --  A range constraint may be applied in any of the following contexts:
  410.    --  object declaration, subtype declaration, derived declaration
  411.    --  assignment, function/procedure/entry call, type conversion
  412.  
  413.    --  Shouldn't this be part of the expander ???
  414.  
  415.    procedure Apply_Range_Check
  416.      (N           : Node_Id;
  417.       Source_Type : Entity_Id;
  418.       Target_Type : Entity_Id)
  419.    is
  420.       Checks_On : constant Boolean :=
  421.                     not Index_Checks_Suppressed (Target_Type)
  422.                       and not Range_Checks_Suppressed (Target_Type);
  423.  
  424.    begin
  425.       --  Don't worry about range checks if we have a previous error or if
  426.       --  the expression is already signalled as raising a constraint error
  427.       --  which means that a warning message has already been posted.
  428.  
  429.       if Source_Type = Any_Type
  430.         or else Target_Type = Any_Type
  431.         or else Raises_Constraint_Error (N)
  432.       then
  433.          return;
  434.  
  435.       --  Confine the range checks currently to only scalar types
  436.  
  437.       elsif not Is_Scalar_Type (Source_Type) then
  438.          return;
  439.  
  440.       --  For now unconditionally do check if kinds of base types are
  441.       --  different, as happens in a conversion. We can still carry out
  442.       --  many of the optimizations, but they are more complex.
  443.  
  444.       elsif
  445.         Ekind (Base_Type (Source_Type)) /= Ekind (Base_Type (Target_Type))
  446.       then
  447.          Set_Do_Range_Check (N, Checks_On);
  448.  
  449.       --  For literals, we can tell if the constraint error will be raised
  450.       --  at compile time, so we never need a dynamic check, but if the
  451.       --  exception will be raised, then post the usual warning, and replace
  452.       --  the literal with a raise constraint error expression.
  453.  
  454.       elsif Is_OK_Static_Expression (N) then
  455.          declare
  456.             LB            : constant Node_Id := Type_Low_Bound (Target_Type);
  457.             UB            : constant Node_Id := Type_High_Bound (Target_Type);
  458.             Out_Of_Range  : Boolean;
  459.             Static_Bounds : constant Boolean :=
  460.                               Is_OK_Static_Expression (LB)
  461.                                 and Is_OK_Static_Expression (UB);
  462.  
  463.          begin
  464.             --  If literal is outside a static bound, raise the warning
  465.  
  466.             --  Following range tests should use sem_eval routine ???
  467.  
  468.             if Static_Bounds then
  469.                if Is_Floating_Point_Type (Source_Type) then
  470.                   Out_Of_Range := (Expr_Value_R (N) < Expr_Value_R (LB))
  471.                                      or else
  472.                                   (Expr_Value_R (N) > Expr_Value_R (UB));
  473.  
  474.                else -- fixed or discrete type
  475.                   Out_Of_Range :=
  476.                     Expr_Value (N) < Expr_Value (LB)
  477.                       or else
  478.                     Expr_Value (N) > Expr_Value (UB);
  479.                end if;
  480.  
  481.                --  Bounds of the type are static and the literal is not
  482.                --  out of range so there is nothing to do.
  483.  
  484.                if Out_Of_Range then
  485.                   Compile_Time_Constraint_Error
  486.                     (N, "static value out of range?");
  487.                end if;
  488.  
  489.             --  Otherwise the check is needed
  490.  
  491.             else
  492.                Set_Do_Range_Check (N, Checks_On);
  493.             end if;
  494.          end;
  495.  
  496.       --  Here for the case of a non-static expression, we need a runtime
  497.       --  check unless the source type range is guaranteed to be in the
  498.       --  range of the target type.
  499.  
  500.       else
  501.          if not In_Subrange_Of (Source_Type, Target_Type) then
  502.             Set_Do_Range_Check (N, Checks_On);
  503.          end if;
  504.       end if;
  505.    end Apply_Range_Check;
  506.  
  507.    -----------------------------
  508.    -- Apply_Slice_Range_Check --
  509.    -----------------------------
  510.  
  511.    procedure Apply_Slice_Range_Check
  512.      (N           : Node_Id;
  513.       Source_Type : Entity_Id;
  514.       Target_Type : Entity_Id)
  515.    is
  516.       Checks_On : constant Boolean :=
  517.                     not Index_Checks_Suppressed (Target_Type)
  518.                       and not Range_Checks_Suppressed (Target_Type);
  519.  
  520.       LB : Node_Id := Low_Bound (N);
  521.       HB : Node_Id := High_Bound (N);
  522.       Null_Range : Boolean;
  523.  
  524.    begin
  525.       --  Don't worry about range checks if we have a previous error or if
  526.       --  the expression is already signalled as raising a constraint error
  527.       --  which means that a warning message has already been posted.
  528.  
  529.       if Source_Type = Any_Type
  530.         or else Target_Type = Any_Type
  531.         or else Raises_Constraint_Error (N)
  532.       then
  533.          return;
  534.  
  535.       --  Confine the range checks currently to only scalar types
  536.  
  537.       elsif not Is_Scalar_Type (Source_Type) then
  538.          return;
  539.  
  540.       elsif Is_OK_Static_Expression (LB)
  541.               and then Is_OK_Static_Expression (HB) then
  542.  
  543.          if Is_Floating_Point_Type (Source_Type) then
  544.             Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
  545.          else -- fixed or discrete type
  546.             Null_Range := Expr_Value (HB) < Expr_Value (LB);
  547.          end if;
  548.  
  549.          if Null_Range then
  550.             return;
  551.          else
  552.             Apply_Range_Check (LB, Source_Type, Target_Type);
  553.             Apply_Range_Check (HB, Source_Type, Target_Type);
  554.  
  555.             if Do_Range_Check (LB) then
  556.                Set_Do_Range_Check (N, Checks_On);
  557.             end if;
  558.          end if;
  559.  
  560.       else
  561.          if not In_Subrange_Of (Source_Type, Target_Type) then
  562.             Set_Do_Range_Check (N, Checks_On);
  563.          end if;
  564.       end if;
  565.    end Apply_Slice_Range_Check;
  566.  
  567.    -------------------------------
  568.    -- Apply_Static_Length_Check --
  569.    -------------------------------
  570.  
  571.    procedure Apply_Static_Length_Check
  572.      (N           : Node_Id;
  573.       Source_Type : Entity_Id;
  574.       Target_Type : Entity_Id)
  575.    is
  576.       Source_Index : Node_Id;
  577.       Target_Index : Node_Id;
  578.  
  579.       S_Low  : Node_Id;
  580.       S_High : Node_Id;
  581.       T_Low  : Node_Id;
  582.       T_High : Node_Id;
  583.  
  584.       S_Length : Uint;
  585.       T_Length : Uint;
  586.  
  587.    begin
  588.       if not Is_Array_Type (Source_Type)
  589.         or else not Is_Array_Type (Target_Type)
  590.       then
  591.          return;
  592.       end if;
  593.  
  594.       --  If the target two array type is unconstrained it will take
  595.       --  the bounds from the Source_Type, so the length check succeds
  596.       --  by definition. Incidentally we check also for unconstrained
  597.       --  Source_Type in the event the caller mixed them up.
  598.  
  599.       if not Is_Constrained (Target_Type)
  600.         or else not Is_Constrained (Source_Type)
  601.       then
  602.          return;
  603.       end if;
  604.  
  605.       Source_Index := First_Index (Source_Type);
  606.       Target_Index := First_Index (Target_Type);
  607.  
  608.       while Present (Source_Index) and then Present (Target_Index) loop
  609.          if Nkind (Source_Index) = N_Raise_Constraint_Error
  610.            or else Nkind (Target_Index) = N_Raise_Constraint_Error
  611.          then
  612.             return;
  613.          end if;
  614.  
  615.          Get_Index_Bounds (Source_Index, S_Low, S_High);
  616.          Get_Index_Bounds (Target_Index, T_Low, T_High);
  617.  
  618.          if Nkind (S_Low) = N_Raise_Constraint_Error
  619.            or else Nkind (S_High) = N_Raise_Constraint_Error
  620.            or else Nkind (T_Low) = N_Raise_Constraint_Error
  621.            or else Nkind (T_High) = N_Raise_Constraint_Error
  622.          then
  623.             return;
  624.          end if;
  625.  
  626.          if Is_Static_Expression (S_Low)
  627.            and then Is_Static_Expression (S_High)
  628.            and then Is_Static_Expression (T_Low)
  629.            and then Is_Static_Expression (T_High)
  630.          then
  631.             if Expr_Value (S_High) >= Expr_Value (S_Low) then
  632.                S_Length := Expr_Value (S_High) - Expr_Value (S_Low) + 1;
  633.             else
  634.                S_Length := UI_From_Int (0);
  635.             end if;
  636.  
  637.             if Expr_Value (T_High) >= Expr_Value (T_Low) then
  638.                T_Length := Expr_Value (T_High) - Expr_Value (T_Low) + 1;
  639.             else
  640.                T_Length := UI_From_Int (0);
  641.             end if;
  642.  
  643.             if S_Length < T_Length then
  644.                Compile_Time_Constraint_Error (N, "too few elements?");
  645.                return;
  646.             elsif  S_Length > T_Length then
  647.                Compile_Time_Constraint_Error (N, "too many elements?");
  648.                return;
  649.             end if;
  650.          end if;
  651.  
  652.          Source_Index := Next_Index (Source_Index);
  653.          Target_Index := Next_Index (Target_Index);
  654.       end loop;
  655.    end Apply_Static_Length_Check;
  656.  
  657.    ---------------------------------------
  658.    -- Apply_Subscript_Conversion_Checks --
  659.    ---------------------------------------
  660.  
  661.    procedure Apply_Subscript_Conversion_Checks (N : Node_Id) is
  662.       Prefix_Type : Entity_Id := Etype (Prefix (N));
  663.       Index       : Entity_Id;
  664.       Expr        : Node_Id;
  665.  
  666.    begin
  667.       --  If all index checks are suppressed globally do not do unnecessary
  668.       --  tree constructions used only for subscript checking.
  669.  
  670.       if Index_Checks_Suppressed (Empty) then
  671.          return;
  672.       end if;
  673.  
  674.       if Is_Access_Type (Prefix_Type) then
  675.          Prefix_Type := Designated_Type (Prefix_Type);
  676.       end if;
  677.  
  678.       --  Conversion checks need to be added only in the case of unconstrained
  679.       --  arrays or packed arrays since otherwise the appropriate array bounds
  680.       --  exist to make the index checks in appropriate calls to
  681.       --  Apply_Range_Check when resolving the indexed component.
  682.  
  683.       if not (Is_Array_Type (Prefix_Type)
  684.         and then not Is_Constrained (Prefix_Type)
  685.         and then Ekind (Prefix_Type) /= E_Enum_Table_Type)
  686.         and then not Is_Packed (Prefix_Type)
  687.       then
  688.          return;
  689.       end if;
  690.  
  691.       --  Transform indexed components of access types to a canonical form
  692.       --  using explicit .all notation so that getting the actual subtype
  693.       --  of the unconstrained type is made easier.
  694.  
  695.       if Is_Access_Type (Etype (Prefix (N))) then
  696.          Rewrite_Substitute_Tree (N,
  697.            Make_Indexed_Component (Sloc (N),
  698.              Prefix => Make_Explicit_Dereference (Sloc (N),
  699.                Relocate_Node (Prefix (N))),
  700.              Expressions => Expressions (N)));
  701.          Analyze (N);
  702.          Resolve (N, Etype (Original_Node (N)));
  703.          return;
  704.       end if;
  705.  
  706.       Index := First_Index (Get_Actual_Subtype (Prefix (N)));
  707.       Expr  := First (Expressions (N));
  708.  
  709.       --  For each subscript generate a type conversion to the corresponding
  710.       --  actual subtype for the index.
  711.  
  712.       while Present (Index) loop
  713.          if not Index_Checks_Suppressed (Etype (Index)) then
  714.             Rewrite_Substitute_Tree (Expr, Convert_To (Etype (Index), Expr));
  715.             Analyze (Expr);
  716.             Resolve (Expr, Etype (Index));
  717.          end if;
  718.  
  719.          Index := Next_Index (Index);
  720.          Expr  := Next (Expr);
  721.       end loop;
  722.    end Apply_Subscript_Conversion_Checks;
  723.  
  724.    ------------------------------------
  725.    -- Discriminant_Checks_Suppressed --
  726.    ------------------------------------
  727.  
  728.    function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
  729.    begin
  730.       return Scope_Suppress.Discriminant_Checks
  731.         or else (Present (E) and then Suppress_Discriminant_Checks (E));
  732.    end Discriminant_Checks_Suppressed;
  733.  
  734.    --------------------------------
  735.    -- Division_Checks_Suppressed --
  736.    --------------------------------
  737.  
  738.    function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
  739.    begin
  740.       return Scope_Suppress.Division_Checks
  741.         or else (Present (E) and then Suppress_Division_Checks (E));
  742.    end Division_Checks_Suppressed;
  743.  
  744.    -----------------------------------
  745.    -- Elaboration_Checks_Suppressed --
  746.    -----------------------------------
  747.  
  748.    function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
  749.    begin
  750.       return Scope_Suppress.Elaboration_Checks
  751.         or else (Present (E) and then Suppress_Elaboration_Checks (E));
  752.    end Elaboration_Checks_Suppressed;
  753.  
  754.    -----------------------------
  755.    -- Index_Checks_Suppressed --
  756.    -----------------------------
  757.  
  758.    function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
  759.    begin
  760.       return Scope_Suppress.Index_Checks
  761.         or else (Present (E) and then Suppress_Index_Checks (E));
  762.    end Index_Checks_Suppressed;
  763.  
  764.    ------------------------------
  765.    -- Length_Checks_Suppressed --
  766.    ------------------------------
  767.  
  768.    function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
  769.    begin
  770.       return Scope_Suppress.Length_Checks
  771.         or else (Present (E) and then Suppress_Length_Checks (E));
  772.    end Length_Checks_Suppressed;
  773.  
  774.    --------------------------------
  775.    -- Overflow_Checks_Suppressed --
  776.    --------------------------------
  777.  
  778.    function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
  779.    begin
  780.       return Scope_Suppress.Overflow_Checks
  781.         or else (Present (E) and then Suppress_Overflow_Checks (E));
  782.    end Overflow_Checks_Suppressed;
  783.  
  784.    -----------------------------
  785.    -- Range_Checks_Suppressed --
  786.    -----------------------------
  787.  
  788.    function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
  789.    begin
  790.       return Scope_Suppress.Range_Checks
  791.         or else (Present (E) and then Suppress_Range_Checks (E));
  792.    end Range_Checks_Suppressed;
  793.  
  794.    -------------------------------
  795.    -- Storage_Checks_Suppressed --
  796.    -------------------------------
  797.  
  798.    function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
  799.    begin
  800.       return Scope_Suppress.Storage_Checks
  801.         or else (Present (E) and then Suppress_Storage_Checks (E));
  802.    end Storage_Checks_Suppressed;
  803.  
  804.    ---------------------------
  805.    -- Tag_Checks_Suppressed --
  806.    ---------------------------
  807.  
  808.    function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
  809.    begin
  810.       return Scope_Suppress.Tag_Checks
  811.         or else (Present (E) and then Suppress_Tag_Checks (E));
  812.    end Tag_Checks_Suppressed;
  813.  
  814. end Checks;
  815.