ada: Unsigned_Base_Range aspect (part 5)

Enable this language extension using -gnat.u, and extend the
current support to handle derivations of types that have
Unsigned_Base_Range aspect.

gcc/ada/ChangeLog:

	* aspects.adb (Get_Aspect_Id): Enable aspect Unsigned_Base_Range
	using -gnatd.u
	* debug.adb (Debug_Flag_Dot_U): Document this switch.
	* einfo-utils.adb (Is_Modular_Integer_Type): Return True if
	the entity is a modular integer type and its base type does
	not have the attribute has_unsigned_base_range_aspect.
	(Is_Signed_Integer_Type): Return True if the entity is a signed
	integer type, or it is a modular integer type and its base type
	has the attribute has_unsigned_base_range_aspect.
	* einfo.ads (E_Modular_Integer_Type): Add documentation of
	Has_Unsigned_Base_Range_Aspect.
	* par-ch4.adb (Scan_Apostrophe): Enable attribute Unsigned_Base_Range
	using -gnatd.u
	* sem_ch13.adb (Analyze_One_Aspect): Check general language
	restrictions on aspect Unsigned_Base_Range. For Unsigned_Base_Range
	aspect, do not delay the generation of the pragma becase we need
	to process it before any type or subtype derivation is analyzed.
	* sem_ch3.adb (Build_Scalar_Bound): Disable code analyzing the
	bound with the base type of the parent type because, for unsigned
	base range types, their base type is a modular type but their
	type is a signed integer type.
	* sem_prag.adb (Analyze_Pragma): Enable pragma Unsigned_Base_Range
	using -gnatd.u. Check more errors on Unsigned_Base_Range pragma,
	and create the new base type only when required.

diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index c9eaea1b7f94b67cf1c51d446016bbaad9748b11..aecbbe2707307be54431923f0e97ddccc9c95ff1 100644 (file)
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -24,6 +24,7 @@
 ------------------------------------------------------------------------------
 
 with Atree;          use Atree;
+with Debug;          use Debug;
 with Einfo;          use Einfo;
 with Einfo.Entities; use Einfo.Entities;
 with Einfo.Utils;    use Einfo.Utils;
@@ -282,7 +283,9 @@ package body Aspects is
    begin
       --  Aspect Unsigned_Base_Range temporarily disabled
 
-      if Name = Name_Unsigned_Base_Range then
+      if Name = Name_Unsigned_Base_Range
+        and then not Debug_Flag_Dot_U
+      then
          return No_Aspect;
       end if;
 

diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index b7c54a00066227dc1dfc6db54a23063edc8f233e..ffe4adc790e12b4685107093689847d8470caf04 100644 (file)
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -105,7 +105,7 @@ package body Debug is
    --  d.r  Disable reordering of components in record types
    --  d.s  Strict secondary stack management
    --  d.t  Disable static allocation of library level dispatch tables
-   --  d.u
+   --  d.u  Enable Unsigned_Base_Range aspect language extension
    --  d.v  Enforce SPARK elaboration rules in SPARK code
    --  d.w  Do not check for infinite loops
    --  d.x  No exception handlers
@@ -800,7 +800,8 @@ package body Debug is
    --       previous dynamic construction of tables. It is there as a possible
    --       work around if we run into trouble with the new implementation.
 
-   --  d.u
+   --  d.u  Enable the support for Unsigned_Base_Range aspect, attribute, and
+   --       pragma.
 
    --  d.v  This flag enforces the elaboration rules defined in the SPARK
    --       Reference Manual, chapter 7.7, to all SPARK code within a unit. As

diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 290ae331d37ad15357b5853c8bdec1cbc2ebb1ef..b0acb25b40bc88250084bc875fade126e700b73c 100644 (file)
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -333,7 +333,8 @@ package body Einfo.Utils is
 
    function Is_Modular_Integer_Type             (Id : E) return B is
    begin
-      return Ekind (Id) in Modular_Integer_Kind;
+      return Ekind (Id) in Modular_Integer_Kind
+        and then not Has_Unsigned_Base_Range_Aspect (Base_Type (Id));
    end Is_Modular_Integer_Type;
 
    function Is_Named_Access_Type                (Id : E) return B is
@@ -393,7 +394,10 @@ package body Einfo.Utils is
 
    function Is_Signed_Integer_Type              (Id : E) return B is
    begin
-      return Ekind (Id) in Signed_Integer_Kind;
+      return Ekind (Id) in Signed_Integer_Kind
+        or else
+          (Ekind (Id) in Modular_Integer_Kind
+             and then Has_Unsigned_Base_Range_Aspect (Base_Type (Id)));
    end Is_Signed_Integer_Type;
 
    function Is_Subprogram                       (Id : E) return B is

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index b5d9c1cde66659193dac66c711ea0eca0d682a02..b9548a78f8455942baa0f90ef4d89cef587de068 100644 (file)
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -5757,6 +5757,7 @@ package Einfo is
    --    Non_Binary_Modulus                   (base type only)
    --    Has_Biased_Representation
    --    Has_Shift_Operator                   (base type only)
+   --    Has_Unsigned_Base_Range_Aspect       (base type only)
    --    No_Predicate_On_Actual
    --    No_Dynamic_Predicate_On_Actual
    --    Type_Low_Bound                       (synth)

diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index f8ae9970c88e0667867be11fb7f7f033e7107a58..338be465513ad6a3b358c9a154b1b607461fce1a 100644 (file)
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -485,7 +485,8 @@ package body Ch4 is
             --  Attribute Unsigned_Base_Range temporarily disabled
 
             if not Is_Attribute_Name (Attr_Name)
-              or else Attr_Name = Name_Unsigned_Base_Range
+              or else (Attr_Name = Name_Unsigned_Base_Range
+                         and then not Debug_Flag_Dot_U)
             then
                if Apostrophe_Should_Be_Semicolon then
                   Expr_Form := EF_Name;

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 22fea0d02907abe9c2df7a9ea997f02fd1630f88..4bff79d16a99359ee7ce401e2cf5acac27c7daac 100644 (file)
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -3590,6 +3590,7 @@ package body Sem_Ch13 is
                             | Aspect_Effective_Reads
                             | Aspect_Effective_Writes
                             | Aspect_Preelaborable_Initialization
+                            | Aspect_Unsigned_Base_Range
             then
                Error_Msg_Name_1 := Nam;
 
@@ -3703,6 +3704,13 @@ package body Sem_Ch13 is
                   then
                      Delay_Required := False;
 
+                  --  For Unsigned_Base_Range aspect, do not delay becase we
+                  --  need to process it before any type or subtype derivation
+                  --  is analyzed.
+
+                  elsif A_Id in Aspect_Unsigned_Base_Range then
+                     Delay_Required := False;
+
                   --  All other cases are delayed
 
                   else

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 9ca77089d1a366af74522e845cd1322d844629c8..aa15166fa8601c3263b4507550116ed05e2f8eed 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -11287,7 +11287,13 @@ package body Sem_Ch3 is
       --  not. It is OK for the new bound we are creating, but not for
       --  the old one??? Still if it never happens, no problem.
 
-      Analyze_And_Resolve (Bound, Base_Type (Par_T));
+      --  This must be disabled on unsigned base range types because their
+      --  base type is a modular type, and their type is a signed integer
+      --  type.
+
+      if not Has_Unsigned_Base_Range_Aspect (Base_Type (Par_T)) then
+         Analyze_And_Resolve (Bound, Base_Type (Par_T));
+      end if;
 
       if Nkind (Bound) in N_Integer_Literal | N_Real_Literal then
          New_Bound := New_Copy (Bound);

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 59c1976dbe97fb735a9e830f37abd26bfc1d2fd5..8d430516c04a743165661f7fd1d7e198b1f4ed2e 100644 (file)
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -12690,7 +12690,8 @@ package body Sem_Prag is
       --  Pragma Unsigned_Base_Range temporarily disabled
 
       if not Is_Pragma_Name (Pname)
-        or else Pname = Name_Unsigned_Base_Range
+        or else (Pname = Name_Unsigned_Base_Range
+                  and then not Debug_Flag_Dot_U)
       then
          declare
             Msg_Issued : Boolean := False;
@@ -28154,12 +28155,23 @@ package body Sem_Prag is
             then
                Error_Pragma_Arg
                  ("cannot apply pragma %",
-                  "\& is not a signed integer type",
-                  Arg1);
+                  "\& is not a signed integer type", Arg1);
 
             elsif Is_Derived_Type (E) then
                Error_Pragma_Arg
                  ("pragma % cannot apply to derived type", Arg1);
+
+            elsif Is_Generic_Type (E) then
+               Error_Pragma_Arg
+                 ("pragma % cannot apply to formal type", Arg1);
+
+            elsif Present (Expr)
+              and then Is_False (Expr_Value (Expr))
+              and then Ekind (Base_Type (E)) = E_Modular_Integer_Type
+              and then Has_Unsigned_Base_Range_Aspect (Base_Type (E))
+            then
+               Error_Pragma_Arg
+                 ("pragma % can only confirm previous True value", Arg1);
             end if;
 
             Check_First_Subtype (Arg1);
@@ -28167,17 +28179,19 @@ package body Sem_Prag is
             --  Create the new unsigned integer base type entity, and apply
             --  the constraint to create the first subtype of E.
 
-            Unsigned_Base_Range_Type_Declaration (E,
-              Def => Type_Definition (Parent (E)));
+            if No (Expr) or else Is_True (Expr_Value (Expr)) then
+               Unsigned_Base_Range_Type_Declaration (E,
+                 Def => Type_Definition (Parent (E)));
 
-            Set_Direct_Primitive_Operations (Base_Type (E), New_Elmt_List);
-            Set_Direct_Primitive_Operations (E,
-              Direct_Primitive_Operations (Base_Type (E)));
-            Ensure_Freeze_Node (Base_Type (E));
-            Set_First_Subtype_Link (Freeze_Node (Base_Type (E)), E);
-            Set_Has_Delayed_Freeze (E);
+               Set_Direct_Primitive_Operations (Base_Type (E), New_Elmt_List);
+               Set_Direct_Primitive_Operations (E,
+                 Direct_Primitive_Operations (Base_Type (E)));
+               Ensure_Freeze_Node (Base_Type (E));
+               Set_First_Subtype_Link (Freeze_Node (Base_Type (E)), E);
+               Set_Has_Delayed_Freeze (E);
 
-            Set_Has_Unsigned_Base_Range_Aspect (Base_Type (E));
+               Set_Has_Unsigned_Base_Range_Aspect (Base_Type (E));
+            end if;
          end Unsigned_Base_Range;
 
          ----------------