checks.adb (Check_Needed): New procedure...

2005-09-01  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Check_Needed): New procedure, deals with removing checks
	based on analysis of short-circuited forms. Also generates warnings for
	improper use of non-short-circuited forms.
	Code clean ups.

From-SVN: r103857

1 files changed, 228 insertions, 190 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 68eb16e..8bb9171 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -218,6 +218,30 @@ 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);
+   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;
@@ -254,10 +278,6 @@ package body Checks is
    --  that the access value is non-null, since the checks do not
    --  not apply to null access values.
 
-   procedure Install_Null_Excluding_Check (N : Node_Id);
-   --  Determines whether an access node requires a runtime access check and
-   --  if so inserts the appropriate run-time check
-
    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.
@@ -380,13 +400,18 @@ package body Checks is
       elsif Access_Checks_Suppressed (Etype (P)) then
          return;
 
-         --  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).
+      --  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).
 
       elsif not Expander_Active then
          return;
+
+      --  We do not need checks if not needed because of short circuiting
+
+      elsif not Check_Needed (P, Access_Check) then
+         return;
       end if;
 
       --  Case where P is an entity name
@@ -1360,7 +1385,8 @@ package body Checks is
 
    begin
       if Expander_Active
-        and not Backend_Divide_Checks_On_Target
+        and then not Backend_Divide_Checks_On_Target
+        and then Check_Needed (Right, Division_Check)
       then
          Determine_Range (Right, ROK, Rlo, Rhi);
 
@@ -1382,7 +1408,6 @@ package body Checks is
          --  Test for extremely annoying case of xxx'First divided by -1
 
          if Do_Overflow_Check (N) then
-
             if Nkind (N) = N_Op_Divide
               and then Is_Signed_Integer_Type (Typ)
             then
@@ -2420,6 +2445,121 @@ package body Checks is
       return Cond;
    end Build_Discriminant_Checks;
 
+   ------------------
+   -- Check_Needed --
+   ------------------
+
+   function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
+      N : Node_Id;
+      P : Node_Id;
+      K : Node_Kind;
+      L : Node_Id;
+      R : Node_Id;
+
+   begin
+      --  Always check if not simple entity
+
+      if Nkind (Nod) not in N_Has_Entity
+        or else not Comes_From_Source (Nod)
+      then
+         return True;
+      end if;
+
+      --  Look up tree for short circuit
+
+      N := Nod;
+      loop
+         P := Parent (N);
+         K := Nkind (P);
+
+         if K not in N_Subexpr then
+            return True;
+
+         --  Or/Or Else case, left operand must be equality test
+
+         elsif K = N_Op_Or or else K = N_Or_Else then
+            exit when N = Right_Opnd (P)
+              and then Nkind (Left_Opnd (P)) = N_Op_Eq;
+
+         --  And/And then case, left operand must be inequality test. Note that
+         --  at this stage, the expander will have changed a/=b to not (a=b).
+
+         elsif K = N_Op_And or else K = N_And_Then then
+            exit when N = Right_Opnd (P)
+              and then Nkind (Left_Opnd (P)) = N_Op_Not
+              and then Nkind (Right_Opnd (Left_Opnd (P))) = N_Op_Eq;
+         end if;
+
+         N := P;
+      end loop;
+
+      --  If we fall through the loop, then we have a conditional with an
+      --  appropriate test as its left operand. So test further.
+
+      L := Left_Opnd (P);
+
+      if Nkind (L) = N_Op_Not then
+         L := Right_Opnd (L);
+      end if;
+
+      R := Right_Opnd (L);
+      L := Left_Opnd (L);
+
+      --  Left operand of test must match original variable
+
+      if Nkind (L) not in N_Has_Entity
+        or else Entity (L) /= Entity (Nod)
+      then
+         return True;
+      end if;
+
+      --  Right operand of test mus be key value (zero or null)
+
+      case Check is
+         when Access_Check =>
+            if Nkind (R) /= N_Null then
+               return True;
+            end if;
+
+         when Division_Check =>
+            if not Compile_Time_Known_Value (R)
+              or else Expr_Value (R) /= Uint_0
+            then
+               return True;
+            end if;
+      end case;
+
+      --  Here we have the optimizable case, warn if not short-circuited
+
+      if K = N_Op_And or else K = N_Op_Or then
+         case Check is
+            when Access_Check =>
+               Error_Msg_N
+                 ("Constraint_Error may be raised (access check)?",
+                  Parent (Nod));
+            when Division_Check =>
+               Error_Msg_N
+                 ("Constraint_Error may be raised (zero divide)?",
+                  Parent (Nod));
+         end case;
+
+         if K = N_Op_And then
+            Error_Msg_N ("use `AND THEN` instead of AND?", P);
+         else
+            Error_Msg_N ("use `OR ELSE` instead of OR?", P);
+         end if;
+
+         --  If not short-circuited, we need the ckeck
+
+         return True;
+
+      --  If short-circuited, we can omit the check
+
+      else
+         return False;
+      end if;
+   end Check_Needed;
+
    -----------------------------------
    -- Check_Valid_Lvalue_Subscripts --
    -----------------------------------
@@ -2467,222 +2607,120 @@ package body Checks is
       Related_Nod        : Node_Id;
       Has_Null_Exclusion : Boolean := False;
 
-      type Msg_Kind is (Components, Formals, Objects);
-      Msg_K : Msg_Kind := Objects;
-      --  Used by local subprograms to generate precise error messages
+   begin
+      pragma Assert (K = N_Parameter_Specification
+                       or else K = N_Object_Declaration
+                       or else K = N_Discriminant_Specification
+                       or else K = N_Component_Declaration);
 
-      procedure Check_Must_Be_Access
-        (Typ                : Entity_Id;
-         Has_Null_Exclusion : Boolean);
-      --  ??? local subprograms must have comment on spec
+      Typ := Etype (Defining_Identifier (N));
 
-      procedure Check_Already_Null_Excluding_Type
-        (Typ                : Entity_Id;
-         Has_Null_Exclusion : Boolean;
-         Related_Nod        : Node_Id);
-      --  ??? local subprograms must have comment on spec
+      pragma Assert (Is_Access_Type (Typ)
+        or else (K = N_Object_Declaration and then Is_Array_Type (Typ)));
 
-      procedure Check_Must_Be_Initialized
-        (N           : Node_Id;
-         Related_Nod : Node_Id);
-      --  ??? local subprograms must have comment on spec
+      case K is
+         when N_Parameter_Specification =>
+            Related_Nod        := Parameter_Type (N);
+            Has_Null_Exclusion := Null_Exclusion_Present (N);
 
-      procedure Check_Null_Not_Allowed (N : Node_Id);
-      --  ??? local subprograms must have comment on spec
+         when N_Object_Declaration =>
+            Related_Nod        := Object_Definition (N);
+            Has_Null_Exclusion := Null_Exclusion_Present (N);
 
-      --  ??? following bodies lack comments
+         when N_Discriminant_Specification =>
+            Related_Nod        := Discriminant_Type (N);
+            Has_Null_Exclusion := Null_Exclusion_Present (N);
 
-      --------------------------
-      -- Check_Must_Be_Access --
-      --------------------------
+         when N_Component_Declaration =>
+            if Present (Access_Definition (Component_Definition (N))) then
+               Related_Nod := Component_Definition (N);
+               Has_Null_Exclusion :=
+                 Null_Exclusion_Present
+                   (Access_Definition (Component_Definition (N)));
+            else
+               Related_Nod :=
+                 Subtype_Indication (Component_Definition (N));
+               Has_Null_Exclusion :=
+                 Null_Exclusion_Present (Component_Definition (N));
+            end if;
 
-      procedure Check_Must_Be_Access
-        (Typ                : Entity_Id;
-         Has_Null_Exclusion : Boolean)
-      is
-      begin
-         if Has_Null_Exclusion
-           and then not Is_Access_Type (Typ)
-         then
-            Error_Msg_N ("(Ada 2005) must be an access type", Related_Nod);
-         end if;
-      end Check_Must_Be_Access;
+         when others =>
+            raise Program_Error;
+      end case;
 
-      ---------------------------------------
-      -- Check_Already_Null_Excluding_Type --
-      ---------------------------------------
+      --  Enforce legality rule 3.10 (14/1): A null_exclusion is only allowed
+      --  of the access subtype does not exclude null.
 
-      procedure Check_Already_Null_Excluding_Type
-        (Typ                : Entity_Id;
-         Has_Null_Exclusion : Boolean;
-         Related_Nod        : Node_Id)
-      is
-      begin
-         if Has_Null_Exclusion
-           and then Can_Never_Be_Null (Typ)
-         then
-            Error_Msg_N
-              ("(Ada 2005) already a null-excluding type", Related_Nod);
-         end if;
-      end Check_Already_Null_Excluding_Type;
+      if Has_Null_Exclusion
+        and then Can_Never_Be_Null (Typ)
 
-      -------------------------------
-      -- Check_Must_Be_Initialized --
-      -------------------------------
+         --  No need to check itypes that have the null-excluding attribute
+         --  because they were checked at their point of creation
 
-      procedure Check_Must_Be_Initialized
-        (N           : Node_Id;
-         Related_Nod : Node_Id)
-      is
-         Expr        : constant Node_Id := Expression (N);
+        and then not Is_Itype (Typ)
+      then
+         Error_Msg_N
+           ("(Ada 2005) already a null-excluding type", Related_Nod);
+      end if;
 
-      begin
-         pragma Assert (Nkind (N) = N_Component_Declaration
-                          or else Nkind (N) = N_Object_Declaration);
-
-         if not Present (Expr) then
-            case Msg_K is
-               when Components =>
-                  Error_Msg_N
-                    ("(Ada 2005) null-excluding components must be " &
-                     "initialized", Related_Nod);
-
-               when Formals =>
-                  Error_Msg_N
-                    ("(Ada 2005) null-excluding formals must be initialized",
-                     Related_Nod);
-
-               when Objects =>
-                  Error_Msg_N
-                    ("(Ada 2005) null-excluding objects must be initialized",
-                     Related_Nod);
-            end case;
-         end if;
-      end Check_Must_Be_Initialized;
+      --  Check that null-excluding objects are always initialized
+
+      if K = N_Object_Declaration
+        and then not Present (Expression (N))
+      then
+         --  Add a an expression that assignates null. This node is needed
+         --  by Apply_Compile_Time_Constraint_Error, that will replace this
+         --  node by a Constraint_Error node.
+
+         Set_Expression (N, Make_Null (Sloc (N)));
+         Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
 
-      ----------------------------
-      -- Check_Null_Not_Allowed --
-      ----------------------------
+         Apply_Compile_Time_Constraint_Error
+           (N      => Expression (N),
+            Msg    => "(Ada 2005) null-excluding objects must be initialized?",
+            Reason => CE_Null_Not_Allowed);
+      end if;
 
-      procedure Check_Null_Not_Allowed (N : Node_Id) is
+      --  Check that the null value is not used as a single expression to
+      --  assignate a value to a null-excluding component, formal or object;
+      --  otherwise generate a warning message at the sloc of Related_Nod and
+      --  replace Expression (N) by an N_Contraint_Error node.
+
+      declare
          Expr : constant Node_Id := Expression (N);
 
       begin
          if Present (Expr)
            and then Nkind (Expr) = N_Null
          then
-            case Msg_K is
-               when Components =>
+            case K is
+               when N_Discriminant_Specification  |
+                    N_Component_Declaration      =>
                   Apply_Compile_Time_Constraint_Error
                      (N      => Expr,
                       Msg    => "(Ada 2005) NULL not allowed in"
                                   & " null-excluding components?",
-                      Reason => CE_Null_Not_Allowed,
-                      Rep    => False);
+                      Reason => CE_Null_Not_Allowed);
 
-               when Formals =>
+               when N_Parameter_Specification =>
                   Apply_Compile_Time_Constraint_Error
                      (N      => Expr,
                       Msg    => "(Ada 2005) NULL not allowed in"
                                   & " null-excluding formals?",
-                      Reason => CE_Null_Not_Allowed,
-                      Rep    => False);
+                      Reason => CE_Null_Not_Allowed);
 
-               when Objects =>
+               when N_Object_Declaration =>
                   Apply_Compile_Time_Constraint_Error
                      (N      => Expr,
                       Msg    => "(Ada 2005) NULL not allowed in"
                                   & " null-excluding objects?",
-                      Reason => CE_Null_Not_Allowed,
-                      Rep    => False);
+                      Reason => CE_Null_Not_Allowed);
+
+               when others =>
+                  null;
             end case;
          end if;
-      end Check_Null_Not_Allowed;
-
-   --  Start of processing for Null_Exclusion_Static_Checks
-
-   begin
-      pragma Assert (K = N_Component_Declaration
-                       or else K = N_Parameter_Specification
-                       or else K = N_Object_Declaration
-                       or else K = N_Discriminant_Specification
-                       or else K = N_Allocator);
-
-      case K is
-         when N_Component_Declaration =>
-            Msg_K := Components;
-
-            if not Present (Access_Definition (Component_Definition (N))) then
-               Has_Null_Exclusion  := Null_Exclusion_Present
-                                        (Component_Definition (N));
-               Typ := Etype (Subtype_Indication (Component_Definition (N)));
-               Related_Nod := Subtype_Indication (Component_Definition (N));
-               Check_Must_Be_Access (Typ, Has_Null_Exclusion);
-               Check_Already_Null_Excluding_Type
-                 (Typ, Has_Null_Exclusion, Related_Nod);
-               Check_Must_Be_Initialized (N, Related_Nod);
-            end if;
-
-            Check_Null_Not_Allowed (N);
-
-         when N_Parameter_Specification =>
-            Msg_K := Formals;
-            Has_Null_Exclusion := Null_Exclusion_Present (N);
-            Typ := Entity (Parameter_Type (N));
-            Related_Nod := Parameter_Type (N);
-            Check_Must_Be_Access (Typ, Has_Null_Exclusion);
-            Check_Already_Null_Excluding_Type
-              (Typ, Has_Null_Exclusion, Related_Nod);
-            Check_Null_Not_Allowed (N);
-
-         when N_Object_Declaration =>
-            Msg_K := Objects;
-
-            if Nkind (Object_Definition (N)) /= N_Access_Definition then
-               Has_Null_Exclusion := Null_Exclusion_Present (N);
-               Typ := Entity (Object_Definition (N));
-               Related_Nod := Object_Definition (N);
-               Check_Must_Be_Access (Typ, Has_Null_Exclusion);
-               Check_Already_Null_Excluding_Type
-                 (Typ, Has_Null_Exclusion, Related_Nod);
-               Check_Must_Be_Initialized (N, Related_Nod);
-            end if;
-
-            Check_Null_Not_Allowed (N);
-
-         when N_Discriminant_Specification =>
-            Msg_K := Components;
-
-            if Nkind (Discriminant_Type (N)) /= N_Access_Definition then
-               Has_Null_Exclusion := Null_Exclusion_Present (N);
-               Typ := Etype (Defining_Identifier (N));
-               Related_Nod := Discriminant_Type (N);
-               Check_Must_Be_Access (Typ, Has_Null_Exclusion);
-               Check_Already_Null_Excluding_Type
-                 (Typ, Has_Null_Exclusion, Related_Nod);
-            end if;
-
-            Check_Null_Not_Allowed (N);
-
-         when N_Allocator =>
-            Msg_K := Objects;
-            Has_Null_Exclusion := Null_Exclusion_Present (N);
-            Typ := Etype (Expression (N));
-
-            if Nkind (Expression (N)) = N_Qualified_Expression then
-               Related_Nod := Subtype_Mark (Expression (N));
-            else
-               Related_Nod := Expression (N);
-            end if;
-
-            Check_Must_Be_Access (Typ, Has_Null_Exclusion);
-            Check_Already_Null_Excluding_Type
-              (Typ, Has_Null_Exclusion, Related_Nod);
-            Check_Null_Not_Allowed (N);
-
-         when others =>
-            raise Program_Error;
-      end case;
+      end;
    end Null_Exclusion_Static_Checks;
 
    ----------------------------------