Aspect_Initial_Condition, -- GNAT
Aspect_Initializes, -- GNAT
Aspect_Input,
+ Aspect_Integer_Literal,
Aspect_Interrupt_Priority,
Aspect_Invariant, -- GNAT
Aspect_Iterator_Element,
Aspect_Priority,
Aspect_Put_Image,
Aspect_Read,
+ Aspect_Real_Literal,
Aspect_Refined_Depends, -- GNAT
Aspect_Refined_Global, -- GNAT
Aspect_Refined_Post, -- GNAT
Aspect_Storage_Pool,
Aspect_Storage_Size,
Aspect_Stream_Size,
+ Aspect_String_Literal,
Aspect_Suppress,
Aspect_Synchronization,
Aspect_Test_Case, -- GNAT
Aspect_Initial_Condition => Expression,
Aspect_Initializes => Expression,
Aspect_Input => Name,
+ Aspect_Integer_Literal => Name,
Aspect_Interrupt_Priority => Expression,
Aspect_Invariant => Expression,
Aspect_Iterable => Expression,
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,
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,
Aspect_Initial_Condition => False,
Aspect_Initializes => False,
Aspect_Input => False,
+ Aspect_Integer_Literal => False,
Aspect_Interrupt_Priority => False,
Aspect_Invariant => False,
Aspect_Iterable => False,
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,
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,
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,
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,
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,
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,
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,
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,
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???
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;
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);
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.
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.
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;
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 =>
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 --
-----------------------------------
-- 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
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;
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;
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
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;
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.
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 --
---------------
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
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
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
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Alloc;
with Debug; use Debug;
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
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 --
--------------------------------------
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.
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 + $;
projects / gcc.git / commitdiff