From 158b52c9616a3bc0b1c2622e3627a544318fd329 Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Fri, 3 Apr 2020 17:34:38 -0700 Subject: [PATCH] [Ada] Implement AI12-0249, AI12-0295 (user-defined numeric & string literals) 2020-06-16 Steve Baird gcc/ada/ * snames.ads-tmpl: Define names of the three new aspects. * aspects.ads: Define the three new aspects. * sem_util.ads, sem_util.adb, sem_dim.adb: Move the function String_From_Numeric_Literal from being declared in the body of package Sem_Dim to being declared in the visible part of package Sem_Util. * sem_ch13.ads, sem_ch13.adb: Declare new visible procedure Validate_Literal_Aspect. This is where most of the legality checking occurs for an aspect specification for one of the three new aspects, as well as resolution of the subprogram named in the aspect specification. Follow example of other aspects (e.g., Validate_Literal_Aspect is called in much the same way as Validate_Iterable_Aspect in Analyze_Aspects_At_Freeze_Point; a small amount of legality checking is performed in Analyze_One_Aspect in much the same way as for Default_Value or Default_Component_Value aspects). Most of the work is done in Validate_Literal_Aspect. * contracts.adb (Add_Contract_Item): Call Validate_Literal_Aspect in much the same way that Validate_Iterable_Aspect was already being called. * sem_res.adb (Resolve): Rewrite a literal as a call if it is a user-defined literal. This is where the dynamic semantics of the 3 new aspects are implemented. * sem_ch6.adb (Fully_Conformant_Expressions): Two numeric literals that have different text but the same value (e.g., 12345 and 12_345) do not conform if they are user-defined literals. Introduce a new function User_Defined_Numeric_Literal_Mismatch to avoid duplication in making this check. * sem_type.adb (Has_Compatible_Type): A numeric literal can be compatible with a non-numeric type (and a string literal can be compatible with a non-string type) if it can be interpreted as a user-defined literal. --- gcc/ada/aspects.ads | 15 ++++ gcc/ada/contracts.adb | 22 +++++- gcc/ada/sem_ch13.adb | 155 +++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_ch13.ads | 4 ++ gcc/ada/sem_ch6.adb | 28 +++++++- gcc/ada/sem_dim.adb | 62 ---------------- gcc/ada/sem_res.adb | 81 +++++++++++++++++++++ gcc/ada/sem_type.adb | 15 +++- gcc/ada/sem_util.adb | 57 +++++++++++++++ gcc/ada/sem_util.ads | 4 ++ gcc/ada/snames.ads-tmpl | 3 + 11 files changed, 377 insertions(+), 69 deletions(-) diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 1c7d3c49871..cf292ae579b 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -109,6 +109,7 @@ package Aspects is Aspect_Initial_Condition, -- GNAT Aspect_Initializes, -- GNAT Aspect_Input, + Aspect_Integer_Literal, Aspect_Interrupt_Priority, Aspect_Invariant, -- GNAT Aspect_Iterator_Element, @@ -133,6 +134,7 @@ package Aspects is Aspect_Priority, Aspect_Put_Image, Aspect_Read, + Aspect_Real_Literal, Aspect_Refined_Depends, -- GNAT Aspect_Refined_Global, -- GNAT Aspect_Refined_Post, -- GNAT @@ -149,6 +151,7 @@ package Aspects is Aspect_Storage_Pool, Aspect_Storage_Size, Aspect_Stream_Size, + Aspect_String_Literal, Aspect_Suppress, Aspect_Synchronization, Aspect_Test_Case, -- GNAT @@ -373,6 +376,7 @@ package Aspects is Aspect_Initial_Condition => Expression, Aspect_Initializes => Expression, Aspect_Input => Name, + Aspect_Integer_Literal => Name, Aspect_Interrupt_Priority => Expression, Aspect_Invariant => Expression, Aspect_Iterable => Expression, @@ -397,6 +401,7 @@ package Aspects is Aspect_Priority => Expression, Aspect_Put_Image => Name, Aspect_Read => Name, + Aspect_Real_Literal => Name, Aspect_Refined_Depends => Expression, Aspect_Refined_Global => Expression, Aspect_Refined_Post => Expression, @@ -413,6 +418,7 @@ package Aspects is Aspect_Storage_Pool => Name, Aspect_Storage_Size => Expression, Aspect_Stream_Size => Expression, + Aspect_String_Literal => Name, Aspect_Suppress => Name, Aspect_Synchronization => Name, Aspect_Test_Case => Expression, @@ -467,6 +473,7 @@ package Aspects is Aspect_Initial_Condition => False, Aspect_Initializes => False, Aspect_Input => False, + Aspect_Integer_Literal => False, Aspect_Interrupt_Priority => False, Aspect_Invariant => False, Aspect_Iterable => False, @@ -491,6 +498,7 @@ package Aspects is Aspect_Priority => False, Aspect_Put_Image => False, Aspect_Read => False, + Aspect_Real_Literal => False, Aspect_Refined_Depends => False, Aspect_Refined_Global => False, Aspect_Refined_Post => False, @@ -507,6 +515,7 @@ package Aspects is Aspect_Storage_Pool => True, Aspect_Storage_Size => True, Aspect_Stream_Size => True, + Aspect_String_Literal => False, Aspect_Suppress => False, Aspect_Synchronization => False, Aspect_Test_Case => False, @@ -614,6 +623,7 @@ package Aspects is Aspect_Initial_Condition => Name_Initial_Condition, Aspect_Initializes => Name_Initializes, Aspect_Input => Name_Input, + Aspect_Integer_Literal => Name_Integer_Literal, Aspect_Interrupt_Handler => Name_Interrupt_Handler, Aspect_Interrupt_Priority => Name_Interrupt_Priority, Aspect_Invariant => Name_Invariant, @@ -650,6 +660,7 @@ package Aspects is Aspect_Pure_Function => Name_Pure_Function, Aspect_Put_Image => Name_Put_Image, Aspect_Read => Name_Read, + Aspect_Real_Literal => Name_Real_Literal, Aspect_Refined_Depends => Name_Refined_Depends, Aspect_Refined_Global => Name_Refined_Global, Aspect_Refined_Post => Name_Refined_Post, @@ -672,6 +683,7 @@ package Aspects is Aspect_Storage_Pool => Name_Storage_Pool, Aspect_Storage_Size => Name_Storage_Size, Aspect_Stream_Size => Name_Stream_Size, + Aspect_String_Literal => Name_String_Literal, Aspect_Suppress => Name_Suppress, Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info, Aspect_Suppress_Initialization => Name_Suppress_Initialization, @@ -832,6 +844,7 @@ package Aspects is Aspect_Inline => Always_Delay, Aspect_Inline_Always => Always_Delay, Aspect_Input => Always_Delay, + Aspect_Integer_Literal => Always_Delay, Aspect_Interrupt_Handler => Always_Delay, Aspect_Interrupt_Priority => Always_Delay, Aspect_Invariant => Always_Delay, @@ -857,6 +870,7 @@ package Aspects is Aspect_Pure_Function => Always_Delay, Aspect_Put_Image => Always_Delay, Aspect_Read => Always_Delay, + Aspect_Real_Literal => Always_Delay, Aspect_Relative_Deadline => Always_Delay, Aspect_Remote_Access_Type => Always_Delay, Aspect_Remote_Call_Interface => Always_Delay, @@ -869,6 +883,7 @@ package Aspects is Aspect_Static_Predicate => Always_Delay, Aspect_Storage_Pool => Always_Delay, Aspect_Stream_Size => Always_Delay, + Aspect_String_Literal => Always_Delay, Aspect_Suppress => Always_Delay, Aspect_Suppress_Debug_Info => Always_Delay, Aspect_Suppress_Initialization => Always_Delay, diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index ae85d2cdc4d..337e4b60b54 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -425,7 +425,7 @@ package body Contracts is Analyze_Task_Contract (Defining_Entity (Decl)); -- For type declarations, we need to do the preanalysis of Iterable - -- aspect specifications. + -- and the 3 Xxx_Literal aspect specifications. -- Other type aspects need to be resolved here??? @@ -433,13 +433,29 @@ package body Contracts is and then Present (Aspect_Specifications (Decl)) then declare - E : constant Entity_Id := Defining_Identifier (Decl); - It : constant Node_Id := Find_Aspect (E, Aspect_Iterable); + E : constant Entity_Id := Defining_Identifier (Decl); + It : constant Node_Id := Find_Aspect (E, Aspect_Iterable); + I_Lit : constant Node_Id := + Find_Aspect (E, Aspect_Integer_Literal); + R_Lit : constant Node_Id := + Find_Aspect (E, Aspect_Real_Literal); + S_Lit : constant Node_Id := + Find_Aspect (E, Aspect_String_Literal); begin if Present (It) then Validate_Iterable_Aspect (E, It); end if; + + if Present (I_Lit) then + Validate_Literal_Aspect (E, I_Lit); + end if; + if Present (R_Lit) then + Validate_Literal_Aspect (E, R_Lit); + end if; + if Present (S_Lit) then + Validate_Literal_Aspect (E, S_Lit); + end if; end; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d7d5a47fded..583bb98185f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1461,6 +1461,12 @@ package body Sem_Ch13 is ASN, E); end if; + when Aspect_Integer_Literal + | Aspect_Real_Literal + | Aspect_String_Literal + => + Validate_Literal_Aspect (E, ASN); + when Aspect_Iterable => Validate_Iterable_Aspect (E, ASN); @@ -3750,6 +3756,24 @@ package body Sem_Ch13 is Aitem := Empty; + when Aspect_Integer_Literal + | Aspect_Real_Literal + | Aspect_String_Literal + => + + if not Is_First_Subtype (E) then + Error_Msg_N + ("may only be specified for a first subtype", Aspect); + goto Continue; + end if; + + if Ada_Version < Ada_2020 then + Check_Restriction + (No_Implementation_Aspect_Specifications, N); + end if; + + Aitem := Empty; + -- Case 3b: The aspects listed below don't correspond to -- pragmas/attributes and don't need delayed analysis. @@ -9868,7 +9892,10 @@ package body Sem_Ch13 is elsif A_Id = Aspect_Variable_Indexing or else A_Id = Aspect_Constant_Indexing or else A_Id = Aspect_Default_Iterator or else - A_Id = Aspect_Iterator_Element + A_Id = Aspect_Iterator_Element or else + A_Id = Aspect_Integer_Literal or else + A_Id = Aspect_Real_Literal or else + A_Id = Aspect_String_Literal then -- Make type unfrozen before analysis, to prevent spurious errors -- about late attributes. @@ -9989,6 +10016,9 @@ package body Sem_Ch13 is Ident : constant Node_Id := Identifier (ASN); -- Identifier (use Entity field to save expression) + Expr : constant Node_Id := Expression (ASN); + -- For cases where using Entity (Identifier) doesn't work + A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); T : Entity_Id := Empty; @@ -10137,6 +10167,20 @@ package body Sem_Ch13 is Analyze (Expression (ASN)); return; + -- Same for Literal aspects, where the expression is a function + -- name. Legality rules are checked separately. Use Expr to avoid + -- losing track of the previous resolution of Expression. + + when Aspect_Integer_Literal + | Aspect_Real_Literal + | Aspect_String_Literal + => + Set_Entity (Expression (ASN), Entity (Expr)); + Set_Etype (Expression (ASN), Etype (Expr)); + Set_Is_Overloaded (Expression (ASN), False); + Analyze (Expression (ASN)); + return; + -- Ditto for Iterable, legality checks in Validate_Iterable_Aspect. when Aspect_Iterable => @@ -15122,6 +15166,115 @@ package body Sem_Ch13 is end if; end Validate_Iterable_Aspect; + ------------------------------ + -- Validate_Literal_Aspect -- + ------------------------------ + + procedure Validate_Literal_Aspect (Typ : Entity_Id; ASN : Node_Id) is + A_Id : constant Aspect_Id := Get_Aspect_Id (ASN); + pragma Assert ((A_Id = Aspect_Integer_Literal) or + (A_Id = Aspect_Real_Literal) or + (A_Id = Aspect_String_Literal)); + Func_Name : constant Node_Id := Expression (ASN); + Overloaded : Boolean := Is_Overloaded (Func_Name); + + I : Interp_Index; + It : Interp; + Param_Type : Entity_Id; + Match_Found : Boolean := False; + Is_Match : Boolean; + Match : Interp; + begin + if not Is_Type (Typ) then + Error_Msg_N ("aspect can only be specified for a type", ASN); + return; + elsif not Is_First_Subtype (Typ) then + Error_Msg_N ("aspect cannot be specified for a subtype", ASN); + return; + end if; + + if A_Id = Aspect_String_Literal then + if Is_String_Type (Typ) then + Error_Msg_N ("aspect cannot be specified for a string type", ASN); + return; + end if; + Param_Type := Standard_Wide_Wide_String; + else + if Is_Numeric_Type (Typ) then + Error_Msg_N ("aspect cannot be specified for a numeric type", ASN); + return; + end if; + Param_Type := Standard_String; + end if; + + if not Overloaded and then not Present (Entity (Func_Name)) then + Analyze (Func_Name); + Overloaded := Is_Overloaded (Func_Name); + end if; + + if Overloaded then + Get_First_Interp (Func_Name, I => I, It => It); + else + -- only one possible interpretation + It.Nam := Entity (Func_Name); + pragma Assert (Present (It.Nam)); + end if; + + while It.Nam /= Empty loop + Is_Match := False; + + if Ekind (It.Nam) = E_Function + and then Base_Type (Etype (It.Nam)) = Typ + then + declare + Params : constant List_Id := + Parameter_Specifications (Parent (It.Nam)); + Param_Spec : Node_Id; + Param_Id : Entity_Id; + begin + if List_Length (Params) = 1 then + Param_Spec := First (Params); + if not More_Ids (Param_Spec) then + Param_Id := Defining_Identifier (Param_Spec); + if Base_Type (Etype (Param_Id)) = Param_Type + and then Ekind (Param_Id) = E_In_Parameter + then + Is_Match := True; + end if; + end if; + end if; + end; + end if; + + if Is_Match then + if Match_Found then + Error_Msg_N ("aspect specification is ambiguous", ASN); + return; + end if; + Match_Found := True; + Match := It; + end if; + + exit when not Overloaded; + + if not Is_Match then + Remove_Interp (I => I); + end if; + + Get_Next_Interp (I => I, It => It); + end loop; + + if not Match_Found then + Error_Msg_N + ("function name in aspect specification cannot be resolved", ASN); + return; + end if; + + Set_Entity (Func_Name, Match.Nam); + Set_Etype (Func_Name, Etype (Match.Nam)); + Set_Is_Overloaded (Func_Name, False); + end Validate_Literal_Aspect; + ----------------------------------- -- Validate_Unchecked_Conversion -- ----------------------------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 4c26473edc7..85063a621b8 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -345,6 +345,10 @@ package Sem_Ch13 is -- for First, Next, and Has_Element. Optionally an Element primitive may -- also be defined. + procedure Validate_Literal_Aspect (Typ : Entity_Id; ASN : Node_Id); + -- Check legality of Integer_Literal, Real_Literal, and String_Literal + -- aspect specifications. + procedure Install_Discriminants (E : Entity_Id); -- Make visible the discriminants of type entity E diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 55f0c6bb102..1b3cba8de11 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9401,6 +9401,28 @@ package body Sem_Ch6 is end if; end FCO; + function User_Defined_Numeric_Literal_Mismatch return Boolean; + -- Usually literals with the same value like 12345 and 12_345 + -- or 123.0 and 123.00 conform, but not if they are + -- user-defined literals. + + ------------------------------------------- + -- User_Defined_Numeric_Literal_Mismatch -- + ------------------------------------------- + + function User_Defined_Numeric_Literal_Mismatch return Boolean is + E1_Is_User_Defined : constant Boolean := + not Nkind_In (Given_E1, N_Integer_Literal, N_Real_Literal); + E2_Is_User_Defined : constant Boolean := + not Nkind_In (Given_E2, N_Integer_Literal, N_Real_Literal); + begin + pragma Assert (E1_Is_User_Defined = E2_Is_User_Defined); + + return E1_Is_User_Defined and then + not String_Equal (String_From_Numeric_Literal (E1), + String_From_Numeric_Literal (E2)); + end User_Defined_Numeric_Literal_Mismatch; + -- Local variables Result : Boolean; @@ -9662,7 +9684,8 @@ package body Sem_Ch6 is FCL (Expressions (E1), Expressions (E2)); when N_Integer_Literal => - return (Intval (E1) = Intval (E2)); + return (Intval (E1) = Intval (E2)) + and then not User_Defined_Numeric_Literal_Mismatch; when N_Null => return True; @@ -9748,7 +9771,8 @@ package body Sem_Ch6 is FCE (High_Bound (E1), High_Bound (E2)); when N_Real_Literal => - return (Realval (E1) = Realval (E2)); + return (Realval (E1) = Realval (E2)) + and then not User_Defined_Numeric_Literal_Mismatch; when N_Selected_Component => return diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 378f4492d5d..d22e5d26beb 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -40,7 +40,6 @@ with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; -with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -377,10 +376,6 @@ package body Sem_Dim is procedure Set_Symbol (E : Entity_Id; Val : String_Id); -- Associate a symbol representation of a dimension vector with a subtype - function String_From_Numeric_Literal (N : Node_Id) return String_Id; - -- Return the string that corresponds to the numeric litteral N as it - -- appears in the source. - function Symbol_Of (E : Entity_Id) return String_Id; -- E denotes a subtype with a dimension. Return the symbol representation -- of the dimension vector. @@ -3740,63 +3735,6 @@ package body Sem_Dim is Symbol_Table.Set (E, Val); end Set_Symbol; - --------------------------------- - -- String_From_Numeric_Literal -- - --------------------------------- - - function String_From_Numeric_Literal (N : Node_Id) return String_Id is - Loc : constant Source_Ptr := Sloc (N); - Sbuffer : constant Source_Buffer_Ptr := - Source_Text (Get_Source_File_Index (Loc)); - Src_Ptr : Source_Ptr := Loc; - - C : Character := Sbuffer (Src_Ptr); - -- Current source program character - - function Belong_To_Numeric_Literal (C : Character) return Boolean; - -- Return True if C belongs to a numeric literal - - ------------------------------- - -- Belong_To_Numeric_Literal -- - ------------------------------- - - function Belong_To_Numeric_Literal (C : Character) return Boolean is - begin - case C is - when '0' .. '9' - | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' - => - return True; - - -- Make sure '+' or '-' is part of an exponent. - - when '+' | '-' => - declare - Prev_C : constant Character := Sbuffer (Src_Ptr - 1); - begin - return Prev_C = 'e' or else Prev_C = 'E'; - end; - - -- All other character doesn't belong to a numeric literal - - when others => - return False; - end case; - end Belong_To_Numeric_Literal; - - -- Start of processing for String_From_Numeric_Literal - - begin - Start_String; - while Belong_To_Numeric_Literal (C) loop - Store_String_Char (C); - Src_Ptr := Src_Ptr + 1; - C := Sbuffer (Src_Ptr); - end loop; - - return End_String; - end String_From_Numeric_Literal; - --------------- -- Symbol_Of -- --------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 13d925c7f18..bdd954fb8b6 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -2142,6 +2143,12 @@ package body Sem_Res is return; end Resolution_Failed; + Literal_Aspect_Map : + constant array (N_Numeric_Or_String_Literal) of Aspect_Id := + (N_Integer_Literal => Aspect_Integer_Literal, + N_Real_Literal => Aspect_Real_Literal, + N_String_Literal => Aspect_String_Literal); + -- Start of processing for Resolve begin @@ -2845,6 +2852,80 @@ package body Sem_Res is end; end if; + -- Rewrite Literal as a call if the corresponding literal aspect + -- is set. + + if Nkind (N) in N_Numeric_Or_String_Literal + and then Present + (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))) + then + declare + function Literal_Text (N : Node_Id) return String_Id; + -- Returns the text of a literal node + + ------------------- + -- Literal_Text -- + ------------------- + + function Literal_Text (N : Node_Id) return String_Id is + begin + pragma Assert (Nkind (N) in N_Numeric_Or_String_Literal); + + if Nkind (N) = N_String_Literal then + return Strval (N); + else + return String_From_Numeric_Literal (N); + end if; + end Literal_Text; + + Lit_Aspect : constant Aspect_Id := + Literal_Aspect_Map (Nkind (N)); + + Callee : constant Entity_Id := + Entity (Expression (Find_Aspect (Typ, Lit_Aspect))); + + Loc : constant Source_Ptr := Sloc (N); + + Name : constant Node_Id := + Make_Identifier (Loc, Chars (Callee)); + + Param : constant Node_Id := + Make_String_Literal (Loc, Literal_Text (N)); + + Params : constant List_Id := New_List (Param); + + Call : Node_Id := + Make_Function_Call + (Sloc => Loc, + Name => Name, + Parameter_Associations => Params); + begin + Set_Entity (Name, Callee); + Set_Is_Overloaded (Name, False); + if Lit_Aspect = Aspect_String_Literal then + Set_Etype (Param, Standard_Wide_Wide_String); + else + Set_Etype (Param, Standard_String); + end if; + Set_Etype (Call, Etype (Callee)); + + -- Conversion needed in case of an inherited aspect + -- of a derived type. + -- + -- ??? Need to do something different here for downward + -- tagged conversion case (which is only possible in the + -- case of a null extension); the current call to + -- Convert_To results in an error message about an illegal + -- downward conversion. + + Call := Convert_To (Typ, Call); + + Rewrite (N, Call); + end; + Analyze_And_Resolve (N, Typ); + return; + end if; + -- Looks like we have a type error, but check for special case -- of Address wanted, integer found, with the configuration pragma -- Allow_Integer_Address active. If we have this case, introduce diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index af0687cf436..a2244185cee 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Alloc; with Debug; use Debug; @@ -2427,7 +2428,19 @@ package body Sem_Type is or else (not Is_Tagged_Type (Typ) and then Ekind (Typ) /= E_Anonymous_Access_Type - and then Covers (Etype (N), Typ)); + and then Covers (Etype (N), Typ)) + + or else + (Nkind (N) = N_Integer_Literal + and then Present (Find_Aspect (Typ, Aspect_Integer_Literal))) + + or else + (Nkind (N) = N_Real_Literal + and then Present (Find_Aspect (Typ, Aspect_Real_Literal))) + + or else + (Nkind (N) = N_String_Literal + and then Present (Find_Aspect (Typ, Aspect_String_Literal))); -- Overloaded case diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 366eaff3746..43bffc96f4e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -26720,6 +26720,63 @@ package body Sem_Util is return Statically_Names_Object (Prefix (N)); end Statically_Names_Object; + --------------------------------- + -- String_From_Numeric_Literal -- + --------------------------------- + + function String_From_Numeric_Literal (N : Node_Id) return String_Id is + Loc : constant Source_Ptr := Sloc (N); + Sbuffer : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Loc)); + Src_Ptr : Source_Ptr := Loc; + + C : Character := Sbuffer (Src_Ptr); + -- Current source program character + + function Belongs_To_Numeric_Literal (C : Character) return Boolean; + -- Return True if C belongs to the numeric literal + + -------------------------------- + -- Belongs_To_Numeric_Literal -- + -------------------------------- + + function Belongs_To_Numeric_Literal (C : Character) return Boolean is + begin + case C is + when '0' .. '9' + | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F' + => + return True; + + -- Make sure '+' or '-' is part of an exponent + + when '+' | '-' => + declare + Prev_C : constant Character := Sbuffer (Src_Ptr - 1); + begin + return Prev_C = 'e' or else Prev_C = 'E'; + end; + + -- Other characters cannot belong to a numeric literal + + when others => + return False; + end case; + end Belongs_To_Numeric_Literal; + + -- Start of processing for String_From_Numeric_Literal + + begin + Start_String; + while Belongs_To_Numeric_Literal (C) loop + Store_String_Char (C); + Src_Ptr := Src_Ptr + 1; + C := Sbuffer (Src_Ptr); + end loop; + + return End_String; + end String_From_Numeric_Literal; + -------------------------------------- -- Subject_To_Loop_Entry_Attributes -- -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a7ca0f7a092..6cd626e1542 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2929,6 +2929,10 @@ package Sem_Util is function Statically_Names_Object (N : Node_Id) return Boolean; -- Return True iff N is a name that "statically names" an object. + function String_From_Numeric_Literal (N : Node_Id) return String_Id; + -- Return the string that corresponds to the numeric literal N as it + -- appears in the source. + function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean; -- Determine whether node N is a loop statement subject to at least one -- 'Loop_Entry attribute. diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 8d6ba414da3..0e807b057c9 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -148,8 +148,11 @@ package Snames is Name_Dimension_System : constant Name_Id := N + $; Name_Disable_Controlled : constant Name_Id := N + $; Name_Dynamic_Predicate : constant Name_Id := N + $; + Name_Integer_Literal : constant Name_Id := N + $; + Name_Real_Literal : constant Name_Id := N + $; Name_Relaxed_Initialization : constant Name_Id := N + $; Name_Static_Predicate : constant Name_Id := N + $; + Name_String_Literal : constant Name_Id := N + $; Name_Synchronization : constant Name_Id := N + $; Name_Unimplemented : constant Name_Id := N + $; -- 2.30.2