https://gcc.gnu.org/g:7bc5bf6585864ab2185f17e5924ce1036b05fc43
commit r16-4685-g7bc5bf6585864ab2185f17e5924ce1036b05fc43 Author: Javier Miranda <[email protected]> Date: Mon Sep 15 16:34:47 2025 +0000 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: --- 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 c9eaea1b7f94..aecbbe270730 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 b7c54a000662..ffe4adc790e1 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 290ae331d37a..b0acb25b40bc 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 b5d9c1cde666..b9548a78f845 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 f8ae9970c88e..338be465513a 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 22fea0d02907..4bff79d16a99 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 9ca77089d1a3..aa15166fa860 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 59c1976dbe97..8d430516c04a 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; ----------------
