checks.adb (Build_Discriminant_Checks): If the expression being checks is an aggregate retrieve the values of its...

2006-02-13  Ed Schonberg  <schonberg@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* checks.adb (Build_Discriminant_Checks): If the expression being
	checks is an aggregate retrieve the values of its discriminants to
	generate the check, rather than creating a temporary and a reference
	to it.
	(Apply_Access_Check): Rewritten to handle new Is_Known_Null flag
	(Install_Null_Excluding_Check): Ditto
	(Selected_Length_Checks): Build actual subtype for the original Ck_Node,
	not for the renamed object, so that the actual itype is attached in the
	proper context.

From-SVN: r111052

1 files changed, 115 insertions, 77 deletions

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index d53dcc0..6a58415 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -382,60 +382,22 @@ package body Checks is
       P : constant Node_Id := Prefix (N);
 
    begin
-      if Inside_A_Generic then
-         return;
-      end if;
-
-      if Is_Entity_Name (P) then
-         Check_Unset_Reference (P);
-      end if;
-
-      --  We do not need access checks if prefix is known to be non-null
-
-      if Known_Non_Null (P) then
-         return;
-
-      --  We do not need access checks if they are suppressed on the type
-
-      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).
 
-      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
+      if not Expander_Active then
          return;
       end if;
 
-      --  Case where P is an entity name
-
-      if Is_Entity_Name (P) then
-         declare
-            Ent : constant Entity_Id := Entity (P);
-
-         begin
-            if Access_Checks_Suppressed (Ent) then
-               return;
-            end if;
-
-            --  Otherwise we are going to generate an access check, and
-            --  are we have done it, the entity will now be known non null
-            --  But we have to check for safe sequential semantics here!
+      --  No check if short circuiting makes check unnecessary
 
-            if Safe_To_Capture_Value (N, Ent) then
-               Set_Is_Known_Non_Null (Ent);
-            end if;
-         end;
+      if not Check_Needed (P, Access_Check) then
+         return;
       end if;
 
-      --  Access check is required
+      --  Otherwise go ahead and install the check
 
       Install_Null_Excluding_Check (P);
    end Apply_Access_Check;
@@ -472,9 +434,8 @@ package body Checks is
          Type_Level :=
            Make_Integer_Literal (Loc, Type_Access_Level (Typ));
 
-         --  Raise Program_Error if the accessibility level of the
-         --  the access parameter is deeper than the level of the
-         --  target access type.
+         --  Raise Program_Error if the accessibility level of the the access
+         --  parameter is deeper than the level of the target access type.
 
          Insert_Action (N,
            Make_Raise_Program_Error (Loc,
@@ -2387,7 +2348,40 @@ package body Checks is
       Dref     : Node_Id;
       Dval     : Node_Id;
 
+      function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
+
+      ----------------------------------
+      -- Aggregate_Discriminant_Value --
+      ----------------------------------
+
+      function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
+         Assoc : Node_Id;
+
+      begin
+         --  The aggregate has been normalized with named associations. We
+         --  use the Chars field to locate the discriminant to take into
+         --  account discriminants in derived types, which carry the same
+         --  name as those in the parent.
+
+         Assoc := First (Component_Associations (N));
+         while Present (Assoc) loop
+            if Chars (First (Choices (Assoc))) = Chars (Disc) then
+               return Expression (Assoc);
+            else
+               Next (Assoc);
+            end if;
+         end loop;
+
+         --  Discriminant must have been found in the loop above
+
+         raise Program_Error;
+      end Aggregate_Discriminant_Val;
+
+   --  Start of processing for Build_Discriminant_Checks
+
    begin
+      --  Loop through discriminants evolving the condition
+
       Cond := Empty;
       Disc := First_Elmt (Discriminant_Constraint (T_Typ));
 
@@ -2422,6 +2416,11 @@ package body Checks is
                 T_Typ,
                 Stored_Constraint (T_Typ)));
 
+         elsif Nkind (N) = N_Aggregate then
+            Dref :=
+               Duplicate_Subexpr_No_Checks
+                 (Aggregate_Discriminant_Val (Disc_Ent));
+
          else
             Dref :=
               Make_Selected_Component (Loc,
@@ -2664,7 +2663,7 @@ package body Checks is
       --  Check that null-excluding objects are always initialized
 
       if K = N_Object_Declaration
-        and then not Present (Expression (N))
+        and then No (Expression (N))
       then
          --  Add a an expression that assignates null. This node is needed
          --  by Apply_Compile_Time_Constraint_Error, that will replace this
@@ -4802,42 +4801,81 @@ package body Checks is
    ----------------------------------
 
    procedure Install_Null_Excluding_Check (N : Node_Id) is
-      Loc  : constant Source_Ptr := Sloc (N);
-      Etyp : constant Entity_Id  := Etype (N);
+      Loc : constant Source_Ptr := Sloc (N);
+      Typ : constant Entity_Id  := Etype (N);
+
+      procedure Mark_Non_Null;
+      --  After installation of check, marks node as non-null if entity
+
+      -------------------
+      -- Mark_Non_Null --
+      -------------------
+
+      procedure Mark_Non_Null is
+      begin
+         if Is_Entity_Name (N) then
+            Set_Is_Known_Null (Entity (N), False);
+
+            if Safe_To_Capture_Value (N, Entity (N)) then
+               Set_Is_Known_Non_Null (Entity (N), True);
+            end if;
+         end if;
+      end Mark_Non_Null;
+
+   --  Start of processing for Install_Null_Excluding_Check
 
    begin
-      pragma Assert (Is_Access_Type (Etyp));
+      pragma Assert (Is_Access_Type (Typ));
 
-      --  Don't need access check if:
-      --   1) we are analyzing a generic
-      --   2) it is known to be non-null
-      --   3) the check was suppressed on the type
-      --   4) This is an attribute reference that returns an access type.
+      --  No check inside a generic (why not???)
 
-      if Inside_A_Generic
-        or else Access_Checks_Suppressed (Etyp)
-      then
+      if Inside_A_Generic then
          return;
-      elsif Nkind (N) = N_Attribute_Reference
-        and then
-         (Attribute_Name (N) = Name_Access
-            or else
-          Attribute_Name (N) = Name_Unchecked_Access
-            or else
-          Attribute_Name (N) = Name_Unrestricted_Access)
-      then
+      end if;
+
+      --  No check needed if known to be non-null
+
+      if Known_Non_Null (N) then
          return;
-         --  Otherwise install access check
+      end if;
 
-      else
-         Insert_Action (N,
-           Make_Raise_Constraint_Error (Loc,
-             Condition =>
-               Make_Op_Eq (Loc,
-                 Left_Opnd  => Duplicate_Subexpr_Move_Checks (N),
-                 Right_Opnd => Make_Null (Loc)),
-             Reason    => CE_Access_Check_Failed));
+      --  If known to be null, here is where we generate a compile time check
+
+      if Known_Null (N) then
+         Apply_Compile_Time_Constraint_Error
+           (N,
+            "null value not allowed here?",
+            CE_Access_Check_Failed);
+         Mark_Non_Null;
+         return;
       end if;
+
+      --  If entity is never assigned, for sure a warning is appropriate
+
+      if Is_Entity_Name (N) then
+         Check_Unset_Reference (N);
+      end if;
+
+      --  No check needed if checks are suppressed on the range. Note that we
+      --  don't set Is_Known_Non_Null in this case (we could legitimately do
+      --  so, since the program is erroneous, but we don't like to casually
+      --  propagate such conclusions from erroneosity).
+
+      if Access_Checks_Suppressed (Typ) then
+         return;
+      end if;
+
+      --  Otherwise install access check
+
+      Insert_Action (N,
+        Make_Raise_Constraint_Error (Loc,
+          Condition =>
+            Make_Op_Eq (Loc,
+              Left_Opnd  => Duplicate_Subexpr_Move_Checks (N),
+              Right_Opnd => Make_Null (Loc)),
+          Reason => CE_Access_Check_Failed));
+
+      Mark_Non_Null;
    end Install_Null_Excluding_Check;
 
    --------------------------
@@ -5375,7 +5413,7 @@ package body Checks is
             Freeze_Before (Ck_Node, T_Typ);
 
             Expr_Actual := Get_Referenced_Object (Ck_Node);
-            Exptyp      := Get_Actual_Subtype (Expr_Actual);
+            Exptyp      := Get_Actual_Subtype (Ck_Node);
 
             if Is_Access_Type (Exptyp) then
                Exptyp := Designated_Type (Exptyp);