itypes.ads, itypes.adb (Create_Null_Excluding_Itype): New subprogram that given…

itypes.ads, itypes.adb (Create_Null_Excluding_Itype): New subprogram that given an entity T creates and returns an Itype that...

2005-09-01  Javier Miranda  <miranda@adacore.com>

	* itypes.ads, itypes.adb (Create_Null_Excluding_Itype): New subprogram
	that given an entity T creates and returns an Itype that duplicates the
	contents of T. The returned Itype has the null-exclusion
	attribute set to True, and its Etype attribute references T
	to keep the association between the two entities.
	Update copyright notice

	* sem_aggr.adb (Check_Can_Never_Be_Null,
	Aggregate_Constraint_Checks, Resolve_Aggregate,
	Resolve_Array_Aggregate, Resolve_Record_Aggregate): Code cleanup.

	* sem_ch5.adb (Analyze_Assignment): Code cleanup.

From-SVN: r103868

gcc/ada/itypes.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2003 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005 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- --
@@ -25,10 +25,8 @@
 ------------------------------------------------------------------------------
 
 with Atree;    use Atree;
-with Einfo;    use Einfo;
 with Opt;      use Opt;
 with Sem;      use Sem;
-with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Stand;    use Stand;
 
@@ -74,4 +72,40 @@ package body Itypes is
       return Typ;
    end Create_Itype;
 
+   ---------------------------------
+   -- Create_Null_Excluding_Itype --
+   ---------------------------------
+
+   function Create_Null_Excluding_Itype
+      (T           : Entity_Id;
+       Related_Nod : Node_Id;
+       Scope_Id    : Entity_Id := Current_Scope) return Entity_Id
+   is
+      I_Typ        : Entity_Id;
+
+   begin
+      pragma Assert (Is_Access_Type (T));
+
+      I_Typ := Create_Itype (Ekind       => E_Access_Subtype,
+                             Related_Nod => Related_Nod,
+                             Scope_Id    => Scope_Id);
+
+      Set_Directly_Designated_Type (I_Typ,
+         Directly_Designated_Type (T));
+      Set_Etype              (I_Typ, T);
+      Init_Size_Align        (I_Typ);
+      Set_Depends_On_Private (I_Typ, Depends_On_Private (T));
+      Set_Is_Public          (I_Typ, Is_Public (T));
+      Set_From_With_Type     (I_Typ, From_With_Type (T));
+      Set_Is_Access_Constant (I_Typ, Is_Access_Constant (T));
+      Set_Is_Generic_Type    (I_Typ, Is_Generic_Type (T));
+      Set_Is_Volatile        (I_Typ, Is_Volatile (T));
+      Set_Treat_As_Volatile  (I_Typ, Treat_As_Volatile (T));
+      Set_Is_Atomic          (I_Typ, Is_Atomic (T));
+      Set_Is_Ada_2005        (I_Typ, Is_Ada_2005 (T));
+      Set_Can_Never_Be_Null  (I_Typ);
+
+      return I_Typ;
+   end Create_Null_Excluding_Itype;
+
 end Itypes;

gcc/ada/itypes.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2003 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2005 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- --
@@ -110,4 +110,32 @@ package Itypes is
    --  The Scope_Id parameter specifies the scope of the created type, and
    --  is normally the Current_Scope as shown, but can be set otherwise.
 
+   ---------------------------------
+   -- Create_Null_Excluding_Itype --
+   ---------------------------------
+
+   function Create_Null_Excluding_Itype
+      (T           : Entity_Id;
+       Related_Nod : Node_Id;
+       Scope_Id    : Entity_Id := Current_Scope) return Entity_Id;
+   --  Ada 2005 (AI-231): T is an access type and this subprogram creates and
+   --  returns an internal access-subtype declaration of T that has the null
+   --  exclusion attribute set to True.
+   --
+   --  Usage of null-excluding itypes
+   --  ------------------------------
+   --
+   --      type T1 is access ...
+   --      type T2 is not null T1;
+   --
+   --      type Rec is record
+   --         Comp : not null T1;
+   --      end record;
+   --
+   --      type Arr is array (...) of not null T1;
+   --
+   --  Instead of associating the not-null attribute with the defining ids of
+   --  these declarations, we generate an internal subtype declaration of T1
+   --  that has the null exclusion attribute set to true.
+
 end Itypes;

gcc/ada/sem_aggr.adb

@@ -77,7 +77,7 @@ package body Sem_Aggr is
    --  statement of variant part will usually be small and probably in near
    --  sorted order.
 
-   procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id);
+   procedure Check_Can_Never_Be_Null (Typ : Node_Id; Expr : Node_Id);
    --  Ada 2005 (AI-231): Check bad usage of the null-exclusion issue
 
    ------------------------------------------------------
@@ -495,14 +495,14 @@ package body Sem_Aggr is
       return Entity_Id
    is
       Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
-      --  Number of aggregate index dimensions.
+      --  Number of aggregate index dimensions
 
       Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
-      --  Constrained N_Range of each index dimension in our aggregate itype.
+      --  Constrained N_Range of each index dimension in our aggregate itype
 
       Aggr_Low   : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
       Aggr_High  : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
-      --  Low and High bounds for each index dimension in our aggregate itype.
+      --  Low and High bounds for each index dimension in our aggregate itype
 
       Is_Fully_Positional : Boolean := True;
 
@@ -511,6 +511,7 @@ package body Sem_Aggr is
       --  (sub-)aggregate N. This procedure collects the constrained N_Range
       --  nodes corresponding to each index dimension of our aggregate itype.
       --  These N_Range nodes are collected in Aggr_Range above.
+      --
       --  Likewise collect in Aggr_Low & Aggr_High above the low and high
       --  bounds of each index dimension. If, when collecting, two bounds
       --  corresponding to the same dimension are static and found to differ,
@@ -522,11 +523,11 @@ package body Sem_Aggr is
 
       procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos) is
          This_Range : constant Node_Id := Aggregate_Bounds (N);
-         --  The aggregate range node of this specific sub-aggregate.
+         --  The aggregate range node of this specific sub-aggregate
 
          This_Low  : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
          This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N));
-         --  The aggregate bounds of this specific sub-aggregate.
+         --  The aggregate bounds of this specific sub-aggregate
 
          Assoc : Node_Id;
          Expr  : Node_Id;
@@ -601,7 +602,7 @@ package body Sem_Aggr is
       --  the final itype of the overall aggregate
 
       Index_Constraints : constant List_Id := New_List;
-      --  The list of index constraints of the aggregate itype.
+      --  The list of index constraints of the aggregate itype
 
    --  Start of processing for Array_Aggr_Subtype
 
@@ -612,7 +613,7 @@ package body Sem_Aggr is
       Set_Parent (Index_Constraints, N);
       Collect_Aggr_Bounds (N, 1);
 
-      --  Build the list of constrained indices of our aggregate itype.
+      --  Build the list of constrained indices of our aggregate itype
 
       for J in 1 .. Aggr_Dimension loop
          Create_Index : declare
@@ -816,7 +817,7 @@ package body Sem_Aggr is
          Next_Component (Comp);
       end loop;
 
-      --  On exit, all components have statically known sizes.
+      --  On exit, all components have statically known sizes
 
       Set_Size_Known_At_Compile_Time (T);
    end Check_Static_Discriminated_Subtype;
@@ -987,13 +988,6 @@ package body Sem_Aggr is
 
             Set_Etype (N, Aggr_Typ);  --  may be overridden later on
 
-            --  Ada 2005 (AI-231): Propagate the null_exclusion attribute to
-            --  the components of the array aggregate
-
-            if Ada_Version >= Ada_05 then
-               Set_Can_Never_Be_Null (Aggr_Typ, Can_Never_Be_Null (Typ));
-            end if;
-
             if Is_Constrained (Typ) and then
               (Pkind = N_Assignment_Statement      or else
                Pkind = N_Parameter_Association     or else
@@ -1106,7 +1100,7 @@ package body Sem_Aggr is
       --  warning if not and sets the Raises_Constraint_Error Flag in N.
 
       function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean;
-      --  Returns True if range L .. H is dynamic or null.
+      --  Returns True if range L .. H is dynamic or null
 
       procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean);
       --  Given expression node From, this routine sets OK to False if it
@@ -1368,10 +1362,10 @@ package body Sem_Aggr is
       is
          Nxt_Ind        : constant Node_Id := Next_Index (Index);
          Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr);
-         --  Index is the current index corresponding to the expresion.
+         --  Index is the current index corresponding to the expresion
 
          Resolution_OK : Boolean := True;
-         --  Set to False if resolution of the expression failed.
+         --  Set to False if resolution of the expression failed
 
       begin
          --  If the array type against which we are resolving the aggregate
@@ -1584,7 +1578,7 @@ package body Sem_Aggr is
             --  in the current association.
 
          begin
-            --  STEP 2 (A): Check discrete choices validity.
+            --  STEP 2 (A): Check discrete choices validity
 
             Assoc := First (Component_Associations (N));
             while Present (Assoc) loop
@@ -1637,7 +1631,7 @@ package body Sem_Aggr is
                   if Etype (Choice) = Any_Type then
                      return Failure;
 
-                  --  If the discrete choice raises CE get its original bounds.
+                  --  If the discrete choice raises CE get its original bounds
 
                   elsif Nkind (Choice) = N_Raise_Constraint_Error then
                      Set_Raises_Constraint_Error (N);
@@ -1681,7 +1675,9 @@ package body Sem_Aggr is
 
                --  Ada 2005 (AI-231)
 
-               if Ada_Version >= Ada_05 then
+               if Ada_Version >= Ada_05
+                 and then Nkind (Expression (Assoc)) = N_Null
+               then
                   Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
                end if;
 
@@ -1811,7 +1807,9 @@ package body Sem_Aggr is
 
             --  Ada 2005 (AI-231)
 
-            if Ada_Version >= Ada_05 then
+            if Ada_Version >= Ada_05
+              and then Nkind (Expr) = N_Null
+            then
                Check_Can_Never_Be_Null (Etype (N), Expr);
             end if;
 
@@ -1827,7 +1825,9 @@ package body Sem_Aggr is
 
             --  Ada 2005 (AI-231)
 
-            if Ada_Version >= Ada_05 then
+            if Ada_Version >= Ada_05
+              and then Nkind (Expression (Assoc)) = N_Null
+            then
                Check_Can_Never_Be_Null
                  (Etype (N), Expression (Assoc));
             end if;
@@ -2231,18 +2231,19 @@ package body Sem_Aggr is
             return True;
          end if;
 
-         --  Now look to see if Discr was specified in the ancestor part.
-
-         Orig_Discr := Original_Record_Component (Discr);
-         D          := First_Discriminant (Ancestor_Typ);
+         --  Now look to see if Discr was specified in the ancestor part
 
          if Ancestor_Is_Subtyp then
             D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
          end if;
 
+         Orig_Discr := Original_Record_Component (Discr);
+
+         D := First_Discriminant (Ancestor_Typ);
          while Present (D) loop
-            --  If Ancestor has already specified Disc value than
-            --  insert its value in the final aggregate.
+
+            --  If Ancestor has already specified Disc value than insert its
+            --  value in the final aggregate.
 
             if Original_Record_Component (D) = Orig_Discr then
                if Ancestor_Is_Subtyp then
@@ -2506,14 +2507,14 @@ package body Sem_Aggr is
 
             --  For each range in an array type where a discriminant has been
             --  replaced with the constraint, check that this range is within
-            --  the range of the base type. This checks is done in the
-            --  init proc for regular objects, but has to be done here for
+            --  the range of the base type. This checks is done in the init
+            --  proc for regular objects, but has to be done here for
             --  aggregates since no init proc is called for them.
 
             if Is_Array_Type (Expr_Type) then
                declare
                   Index : Node_Id := First_Index (Expr_Type);
-                  --  Range of the current constrained index in the array.
+                  --  Range of the current constrained index in the array
 
                   Orig_Index : Node_Id := First_Index (Etype (Component));
                   --  Range corresponding to the range Index above in the
@@ -2697,7 +2698,9 @@ package body Sem_Aggr is
 
                --  Ada 2005 (AI-231)
 
-               if Ada_Version >= Ada_05 then
+               if Ada_Version >= Ada_05
+                 and then Nkind (Positional_Expr) = N_Null
+               then
                   Check_Can_Never_Be_Null (Discrim, Positional_Expr);
                end if;
 
@@ -2790,7 +2793,7 @@ package body Sem_Aggr is
                 Subtype_Indication  => Indic);
             Set_Parent (Subtyp_Decl, Parent (N));
 
-            --  Itypes must be analyzed with checks off (see itypes.ads).
+            --  Itypes must be analyzed with checks off (see itypes.ads)
 
             Analyze (Subtyp_Decl, Suppress => All_Checks);
 
@@ -2884,7 +2887,7 @@ package body Sem_Aggr is
                end if;
             end loop;
 
-            --  Now collect components from all other ancestors.
+            --  Now collect components from all other ancestors
 
             Parent_Elmt := First_Elmt (Parent_Typ_List);
             while Present (Parent_Elmt) loop
@@ -2934,7 +2937,9 @@ package body Sem_Aggr is
 
          --  Ada 2005 (AI-231)
 
-         if Ada_Version >= Ada_05 then
+         if Ada_Version >= Ada_05
+           and then Nkind (Positional_Expr) = N_Null
+         then
             Check_Can_Never_Be_Null (Component, Positional_Expr);
          end if;
 
@@ -3087,19 +3092,38 @@ package body Sem_Aggr is
    -- Check_Can_Never_Be_Null --
    -----------------------------
 
-   procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id) is
+   procedure Check_Can_Never_Be_Null (Typ : Node_Id; Expr : Node_Id) is
+      Comp_Typ : Entity_Id;
+
    begin
-      pragma Assert (Ada_Version >= Ada_05);
+      pragma Assert (Ada_Version >= Ada_05
+        and then Present (Expr)
+        and then Nkind (Expr) = N_Null);
 
-      if Nkind (Expr) = N_Null
-        and then Can_Never_Be_Null (N)
+      case Ekind (Typ) is
+         when E_Array_Type  =>
+            Comp_Typ := Component_Type (Typ);
+
+         when E_Component    |
+              E_Discriminant =>
+            Comp_Typ := Etype (Typ);
+
+         when others =>
+            return;
+      end case;
+
+      if Present (Expr)
+        and then Can_Never_Be_Null (Comp_Typ)
       then
-         Apply_Compile_Time_Constraint_Error
-           (N      => Expr,
-            Msg    => "(Ada 2005) NULL not allowed in"
-                       & " null-excluding components?",
-            Reason => CE_Null_Not_Allowed,
-            Rep    => False);
+         Error_Msg_N
+           ("(Ada 2005) NULL not allowed in null-excluding components?", Expr);
+         Error_Msg_NEL
+           ("\& will be raised at run time!?",
+            Expr, Standard_Constraint_Error, Sloc (Expr));
+
+         Set_Etype                    (Expr, Comp_Typ);
+         Set_Analyzed                 (Expr);
+         Install_Null_Excluding_Check (Expr);
       end if;
    end Check_Can_Never_Be_Null;
 

gcc/ada/sem_ch5.adb

@@ -375,9 +375,7 @@ package body Sem_Ch5 is
 
       T2 := Etype (Rhs);
 
-      if Covers (T1, T2) then
-         null;
-      else
+      if not Covers (T1, T2) then
          Wrong_Type (Rhs, Etype (Lhs));
          return;
       end if;
@@ -448,17 +446,21 @@ package body Sem_Ch5 is
       --  Ada 2005 (AI-231)
 
       if Ada_Version >= Ada_05
-        and then Nkind (Rhs) = N_Null
-        and then Is_Access_Type (T1)
+        and then Can_Never_Be_Null (T1)
         and then not Assignment_OK (Lhs)
-        and then ((Is_Entity_Name (Lhs)
-                     and then Can_Never_Be_Null (Entity (Lhs)))
-                   or else Can_Never_Be_Null (Etype (Lhs)))
       then
+         if Nkind (Rhs) = N_Null then
             Apply_Compile_Time_Constraint_Error
-           (N      => Lhs,
+              (N   => Rhs,
                Msg => "(Ada 2005) NULL not allowed in null-excluding objects?",
                Reason => CE_Null_Not_Allowed);
+            return;
+
+         elsif not Can_Never_Be_Null (T2) then
+            Rewrite (Rhs,
+              Convert_To (T1, Relocate_Node (Rhs)));
+            Analyze_And_Resolve (Rhs, T1);
+         end if;
       end if;
 
       if Is_Scalar_Type (T1) then
@@ -550,7 +552,7 @@ package body Sem_Ch5 is
 
       Ent := Entity (Lhs);
 
-      --  Capture value if save to do so
+      --  Capture value if safe to do so
 
       if Safe_To_Capture_Value (N, Ent) then
          Set_Current_Value (Ent, Rhs);
@@ -1274,7 +1276,7 @@ package body Sem_Ch5 is
       --  Start of processing for Process_Bounds
 
       begin
-         --  Determine expected type of range by analyzing separate copy.
+         --  Determine expected type of range by analyzing separate copy
 
          Set_Parent (R_Copy, Parent (R));
          Pre_Analyze_And_Resolve (R_Copy);