From: Javier Miranda <[email protected]>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.adb | 5 ++++-
gcc/ada/debug.adb | 5 +++--
gcc/ada/einfo-utils.adb | 8 ++++++--
gcc/ada/einfo.ads | 1 +
gcc/ada/par-ch4.adb | 3 ++-
gcc/ada/sem_ch13.adb | 8 ++++++++
gcc/ada/sem_ch3.adb | 8 +++++++-
gcc/ada/sem_prag.adb | 38 ++++++++++++++++++++++++++------------
8 files changed, 57 insertions(+), 19 deletions(-)
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index c9eaea1b7f9..aecbbe27073 100644
--- 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 b7c54a00066..ffe4adc790e 100644
--- 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 290ae331d37..b0acb25b40b 100644
--- 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 b5d9c1cde66..b9548a78f84 100644
--- 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 f8ae9970c88..338be465513 100644
--- 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 22fea0d0290..4bff79d16a9 100644
--- 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 9ca77089d1a..aa15166fa86 100644
--- 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 59c1976dbe9..8d430516c04 100644
--- 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;
----------------
--
2.51.0
