-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
+with Sem_Dim; use Sem_Dim;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
-- that are not included in Ada 95, but still get recognized in GNAT.
Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
- Attribute_Address |
- Attribute_Aft |
- Attribute_Alignment |
- Attribute_Base |
- Attribute_Callable |
- Attribute_Constrained |
- Attribute_Count |
- Attribute_Delta |
- Attribute_Digits |
- Attribute_Emax |
- Attribute_Epsilon |
- Attribute_First |
- Attribute_First_Bit |
- Attribute_Fore |
- Attribute_Image |
- Attribute_Large |
- Attribute_Last |
- Attribute_Last_Bit |
- Attribute_Leading_Part |
- Attribute_Length |
- Attribute_Machine_Emax |
- Attribute_Machine_Emin |
- Attribute_Machine_Mantissa |
- Attribute_Machine_Overflows |
- Attribute_Machine_Radix |
- Attribute_Machine_Rounds |
- Attribute_Mantissa |
- Attribute_Pos |
- Attribute_Position |
- Attribute_Pred |
- Attribute_Range |
- Attribute_Safe_Emax |
- Attribute_Safe_Large |
- Attribute_Safe_Small |
- Attribute_Size |
- Attribute_Small |
- Attribute_Storage_Size |
- Attribute_Succ |
- Attribute_Terminated |
- Attribute_Val |
- Attribute_Value |
- Attribute_Width => True,
- others => False);
+ Attribute_Address |
+ Attribute_Aft |
+ Attribute_Alignment |
+ Attribute_Base |
+ Attribute_Callable |
+ Attribute_Constrained |
+ Attribute_Count |
+ Attribute_Delta |
+ Attribute_Digits |
+ Attribute_Emax |
+ Attribute_Epsilon |
+ Attribute_First |
+ Attribute_First_Bit |
+ Attribute_Fore |
+ Attribute_Image |
+ Attribute_Large |
+ Attribute_Last |
+ Attribute_Last_Bit |
+ Attribute_Leading_Part |
+ Attribute_Length |
+ Attribute_Machine_Emax |
+ Attribute_Machine_Emin |
+ Attribute_Machine_Mantissa |
+ Attribute_Machine_Overflows |
+ Attribute_Machine_Radix |
+ Attribute_Machine_Rounds |
+ Attribute_Mantissa |
+ Attribute_Pos |
+ Attribute_Position |
+ Attribute_Pred |
+ Attribute_Range |
+ Attribute_Safe_Emax |
+ Attribute_Safe_Large |
+ Attribute_Safe_Small |
+ Attribute_Size |
+ Attribute_Small |
+ Attribute_Storage_Size |
+ Attribute_Succ |
+ Attribute_Terminated |
+ Attribute_Val |
+ Attribute_Value |
+ Attribute_Width => True,
+ others => False);
-- The following array is the list of attributes defined in the Ada 2005
-- RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
-- but in Ada 95 they are considered to be implementation defined.
Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
- Attribute_Machine_Rounding |
- Attribute_Mod |
- Attribute_Priority |
- Attribute_Stream_Size |
- Attribute_Wide_Wide_Width => True,
- others => False);
+ Attribute_Machine_Rounding |
+ Attribute_Mod |
+ Attribute_Priority |
+ Attribute_Stream_Size |
+ Attribute_Wide_Wide_Width => True,
+ others => False);
-- The following array contains all attributes that imply a modification
-- of their prefixes or result in an access value. Such prefixes can be
Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
Attribute_Class_Array'(
- Attribute_Access |
- Attribute_Address |
- Attribute_Input |
- Attribute_Read |
- Attribute_Unchecked_Access |
- Attribute_Unrestricted_Access => True,
- others => False);
+ Attribute_Access |
+ Attribute_Address |
+ Attribute_Input |
+ Attribute_Read |
+ Attribute_Unchecked_Access |
+ Attribute_Unrestricted_Access => True,
+ others => False);
-----------------------
-- Local_Subprograms --
-- actual, then the message is a warning, and we generate code to raise
-- program error with an appropriate reason. No error message is given
-- for internally generated uses of the attributes.
+ -- The legality rule only applies to scalar types, even though the
+ -- current AI mentions all subtypes.
procedure Check_Array_Or_Scalar_Type;
-- Common procedure used by First, Last, Range attribute to check
-- If the prefix type is an enumeration type, set all its literals
-- as referenced, since the image function could possibly end up
-- referencing any of the literals indirectly. Same for Enum_Val.
+ -- Set the flag only if the reference is in the main code unit. Same
+ -- restriction when resolving 'Value; otherwise an improperly set
+ -- reference when analyzing an inlined body will lose a proper warning
+ -- on a useless with_clause.
procedure Check_Fixed_Point_Type;
-- Verify that prefix of attribute N is a fixed type
-- Common processing for attributes Definite and Has_Discriminants.
-- Checks that prefix is generic indefinite formal type.
+ procedure Check_SPARK_Restriction_On_Attribute;
+ -- Issue an error in formal mode because attribute N is allowed
+
procedure Check_Integer_Type;
-- Verify that prefix of attribute N is an integer type
- procedure Check_Library_Unit;
- -- Verify that prefix of attribute N is a library unit
-
procedure Check_Modular_Integer_Type;
-- Verify that prefix of attribute N is a modular integer type
-- itself of the form of a library unit name. Note that this is
-- quite different from Check_Program_Unit, since it only checks
-- the syntactic form of the name, not the semantic identity. This
- -- is because it is used with attributes (Elab_Body, Elab_Spec, and
- -- UET_Address) which can refer to non-visible unit.
+ -- is because it is used with attributes (Elab_Body, Elab_Spec,
+ -- UET_Address and Elaborated) which can refer to non-visible unit.
procedure Error_Attr (Msg : String; Error_Node : Node_Id);
pragma No_Return (Error_Attr);
-- Start of processing for Analyze_Access_Attribute
begin
- -- Access attribute is not allowed in SPARK or ALFA
-
- if Formal_Verification_Mode and then Comes_From_Source (N) then
- Error_Attr_P ("|~~% attribute is not allowed");
- end if;
-
- -- Proceed with analysis
-
+ Check_SPARK_Restriction_On_Attribute;
Check_E0;
if Nkind (P) = N_Character_Literal then
Build_Access_Subprogram_Type (P);
- -- For unrestricted access, kill current values, since this
- -- attribute allows a reference to a local subprogram that
- -- could modify local variables to be passed out of scope
-
- if Aname = Name_Unrestricted_Access then
-
- -- Do not kill values on nodes initializing dispatch tables
- -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
- -- is currently generated by the expander only for this
- -- purpose. Done to keep the quality of warnings currently
- -- generated by the compiler (otherwise any declaration of
- -- a tagged type cleans constant indications from its scope).
-
- if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
- and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
- or else
- Etype (Parent (N)) = RTE (RE_Size_Ptr))
- and then Is_Dispatching_Operation
- (Directly_Designated_Type (Etype (N)))
- then
- null;
- else
- Kill_Current_Values;
- end if;
+ -- For P'Access or P'Unrestricted_Access, where P is a nested
+ -- subprogram, we might be passing P to another subprogram (but we
+ -- don't check that here), which might call P. P could modify
+ -- local variables, so we need to kill current values. It is
+ -- important not to do this for library-level subprograms, because
+ -- Kill_Current_Values is very inefficient in the case of library
+ -- level packages with lots of tagged types.
+
+ if Is_Library_Level_Entity (Entity (Prefix (N))) then
+ null;
+
+ -- Do not kill values on nodes initializing dispatch tables
+ -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
+ -- is currently generated by the expander only for this
+ -- purpose. Done to keep the quality of warnings currently
+ -- generated by the compiler (otherwise any declaration of
+ -- a tagged type cleans constant indications from its scope).
+
+ elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
+ and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
+ or else
+ Etype (Parent (N)) = RTE (RE_Size_Ptr))
+ and then Is_Dispatching_Operation
+ (Directly_Designated_Type (Etype (N)))
+ then
+ null;
+
+ else
+ Kill_Current_Values;
end if;
return;
and then not In_Inlined_Body
then
Error_Attr_P ("prefix of % attribute must be aliased");
+ Check_No_Implicit_Aliasing (P);
end if;
end Analyze_Access_Attribute;
procedure Bad_Attribute_For_Predicate is
begin
- if Comes_From_Source (N) then
+ if Is_Scalar_Type (P_Type)
+ and then Comes_From_Source (N)
+ then
Error_Msg_Name_1 := Aname;
Bad_Predicated_Subtype_Use
("type& has predicates, attribute % not allowed", N, P_Type);
procedure Check_Enum_Image is
Lit : Entity_Id;
+
begin
- if Is_Enumeration_Type (P_Base_Type) then
+ -- When an enumeration type appears in an attribute reference, all
+ -- literals of the type are marked as referenced. This must only be
+ -- done if the attribute reference appears in the current source.
+ -- Otherwise the information on references may differ between a
+ -- normal compilation and one that performs inlining.
+
+ if Is_Enumeration_Type (P_Base_Type)
+ and then In_Extended_Main_Code_Unit (N)
+ then
Lit := First_Literal (P_Base_Type);
while Present (Lit) loop
Set_Referenced (Lit);
end if;
end Check_Integer_Type;
- ------------------------
- -- Check_Library_Unit --
- ------------------------
-
- procedure Check_Library_Unit is
- begin
- if not Is_Compilation_Unit (Entity (P)) then
- Error_Attr_P ("prefix of % attribute must be library unit");
- end if;
- end Check_Library_Unit;
-
--------------------------------
-- Check_Modular_Integer_Type --
--------------------------------
end if;
end Check_Scalar_Type;
+ ------------------------------------------
+ -- Check_SPARK_Restriction_On_Attribute --
+ ------------------------------------------
+
+ procedure Check_SPARK_Restriction_On_Attribute is
+ begin
+ Error_Msg_Name_1 := Aname;
+ Check_SPARK_Restriction ("attribute % is not allowed", P);
+ end Check_SPARK_Restriction_On_Attribute;
+
---------------------------
-- Check_Standard_Prefix --
---------------------------
Check_Restriction (No_Streams, P);
end if;
+ -- AI05-0057: if restriction No_Default_Stream_Attributes is active,
+ -- it is illegal to use a predefined elementary type stream attribute
+ -- either by itself, or more importantly as part of the attribute
+ -- subprogram for a composite type.
+
+ if Restriction_Active (No_Default_Stream_Attributes) then
+ declare
+ T : Entity_Id;
+
+ begin
+ if Nam = TSS_Stream_Input
+ or else
+ Nam = TSS_Stream_Read
+ then
+ T :=
+ Type_Without_Stream_Operation (P_Type, TSS_Stream_Read);
+ else
+ T :=
+ Type_Without_Stream_Operation (P_Type, TSS_Stream_Write);
+ end if;
+
+ if Present (T) then
+ Check_Restriction (No_Default_Stream_Attributes, N);
+
+ Error_Msg_NE
+ ("missing user-defined Stream Read or Write for type&",
+ N, T);
+ if not Is_Elementary_Type (P_Type) then
+ Error_Msg_NE
+ ("\which is a component of type&", N, P_Type);
+ end if;
+ end if;
+ end;
+ end if;
+
-- Check special case of Exception_Id and Exception_Occurrence which
-- are not allowed for restriction No_Exception_Registration.
- if Is_RTE (P_Type, RE_Exception_Id)
- or else
- Is_RTE (P_Type, RE_Exception_Occurrence)
+ if Restriction_Check_Required (No_Exception_Registration)
+ and then (Is_RTE (P_Type, RE_Exception_Id)
+ or else
+ Is_RTE (P_Type, RE_Exception_Occurrence))
then
Check_Restriction (No_Exception_Registration, P);
end if;
if Nkind (Nod) = N_Identifier then
return;
- elsif Nkind (Nod) = N_Selected_Component then
+ elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then
Check_Unit_Name (Prefix (Nod));
if Nkind (Selector_Name (Nod)) = N_Identifier then
end if;
end Validate_Non_Static_Attribute_Function_Call;
- -----------------------------------------------
- -- Start of Processing for Analyze_Attribute --
- -----------------------------------------------
+ -- Start of processing for Analyze_Attribute
begin
-- Immediate return if unrecognized attribute (already diagnosed
end if;
end if;
- -- Deal with Ada 2005 issues
+ -- Deal with Ada 2005 attributes that are
- if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then
+ if Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005 then
Check_Restriction (No_Implementation_Attributes, N);
end if;
-- Analyze prefix and exit if error in analysis. If the prefix is an
-- incomplete type, use full view if available. Note that there are
-- some attributes for which we do not analyze the prefix, since the
- -- prefix is not a normal name.
+ -- prefix is not a normal name, or else needs special handling.
if Aname /= Name_Elab_Body
and then
Aname /= Name_Elab_Spec
and then
+ Aname /= Name_Elab_Subp_Body
+ and then
Aname /= Name_UET_Address
and then
Aname /= Name_Enabled
+ and then
+ Aname /= Name_Old
then
Analyze (P);
P_Type := Etype (P);
end if;
end if;
- -- In SPARK or ALFA, attributes of private types are only allowed if
- -- the full type declaration is visible.
+ -- In SPARK, attributes of private types are only allowed if the full
+ -- type declaration is visible.
- if Formal_Verification_Mode
- and then Comes_From_Source (Original_Node (N))
- and then Is_Entity_Name (P)
+ if Is_Entity_Name (P)
+ and then Present (Entity (P)) -- needed in some cases
and then Is_Type (Entity (P))
and then Is_Private_Type (P_Type)
and then not In_Open_Scopes (Scope (P_Type))
and then not In_Spec_Expression
then
- Error_Msg_FE
- ("|~~invisible attribute of}", N, First_Subtype (P_Type));
+ Check_SPARK_Restriction ("invisible attribute of type", N);
end if;
-- Remaining processing depends on attribute
case Attr_Id is
+ -- Attributes related to Ada 2012 iterators. Attribute specifications
+ -- exist for these, but they cannot be queried.
+
+ when Attribute_Constant_Indexing |
+ Attribute_Default_Iterator |
+ Attribute_Implicit_Dereference |
+ Attribute_Iterator_Element |
+ Attribute_Variable_Indexing =>
+ Error_Msg_N ("illegal attribute", N);
+
------------------
-- Abort_Signal --
------------------
then
Set_Address_Taken (Ent);
- -- If we have an address of an object, and the attribute
- -- comes from source, then set the object as potentially
- -- source modified. We do this because the resulting address
- -- can potentially be used to modify the variable and we
- -- might not detect this, leading to some junk warnings.
+ -- Deal with No_Implicit_Aliasing restriction
+
+ if Restriction_Check_Required (No_Implicit_Aliasing) then
+ if not Is_Aliased_View (P) then
+ Check_Restriction (No_Implicit_Aliasing, P);
+ else
+ Check_No_Implicit_Aliasing (P);
+ end if;
+ end if;
+
+ -- If we have an address of an object, and the attribute
+ -- comes from source, then set the object as potentially
+ -- source modified. We do this because the resulting address
+ -- can potentially be used to modify the variable and we
+ -- might not detect this, leading to some junk warnings.
Set_Never_Set_In_Source (Ent, False);
("?redundant attribute, & is its own base type", N, Typ);
end if;
+ if Nkind (Parent (N)) /= N_Attribute_Reference then
+ Error_Msg_Name_1 := Aname;
+ Check_SPARK_Restriction
+ ("attribute% is only allowed as prefix of another attribute", P);
+ end if;
+
Set_Etype (N, Base_Type (Entity (P)));
Set_Entity (N, Base_Type (Entity (P)));
Rewrite (N, New_Reference_To (Entity (N), Loc));
Check_Floating_Point_Type_0;
Set_Etype (N, Standard_Boolean);
+ ---------------------
+ -- Descriptor_Size --
+ ---------------------
+
+ when Attribute_Descriptor_Size =>
+ Check_E0;
+
+ if not Is_Entity_Name (P)
+ or else not Is_Type (Entity (P))
+ then
+ Error_Attr_P ("prefix of attribute % must denote a type");
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+
------------
-- Digits --
------------
-- Elab_Body --
---------------
- -- Also handles processing for Elab_Spec
+ -- Also handles processing for Elab_Spec and Elab_Subp_Body
+
+ when Attribute_Elab_Body |
+ Attribute_Elab_Spec |
+ Attribute_Elab_Subp_Body =>
- when Attribute_Elab_Body | Attribute_Elab_Spec =>
Check_E0;
Check_Unit_Name (P);
Set_Etype (N, Standard_Void_Type);
when Attribute_Elaborated =>
Check_E0;
- Check_Library_Unit;
+ Check_Unit_Name (P);
Set_Etype (N, Standard_Boolean);
----------
when Attribute_Image => Image :
begin
- Set_Etype (N, Standard_String);
+ Check_SPARK_Restriction_On_Attribute;
Check_Scalar_Type;
+ Set_Etype (N, Standard_String);
if Is_Real_Type (P_Type) then
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
end if;
Check_E0;
+
+ -- Prefix has not been analyzed yet, and its full analysis will take
+ -- place during expansion (see below).
+
+ Preanalyze_And_Resolve (P);
+ P_Type := Etype (P);
Set_Etype (N, P_Type);
if No (Current_Subprogram) then
end if;
end Check_Local;
+ -- The attribute appears within a pre/postcondition, but refers to
+ -- an entity in the enclosing subprogram. If it is a component of a
+ -- formal its expansion might generate actual subtypes that may be
+ -- referenced in an inner context, and which must be elaborated
+ -- within the subprogram itself. As a result we create a declaration
+ -- for it and insert it at the start of the enclosing subprogram
+ -- This is properly an expansion activity but it has to be performed
+ -- now to prevent out-of-order issues.
+
+ if Nkind (P) = N_Selected_Component
+ and then Has_Discriminants (Etype (Prefix (P)))
+ then
+ P_Type := Base_Type (P_Type);
+ Set_Etype (N, P_Type);
+ Set_Etype (P, P_Type);
+ Expand (N);
+ end if;
+
+ ----------------------
+ -- Overlaps_Storage --
+ ----------------------
+
+ when Attribute_Overlaps_Storage =>
+ if Ada_Version < Ada_2012 then
+ Error_Msg_N
+ ("attribute Overlaps_Storage is an Ada 2012 feature", N);
+ Error_Msg_N
+ ("\unit must be compiled with -gnat2012 switch", N);
+ end if;
+ Check_E1;
+
+ -- Both arguments must be objects of any type
+
+ Analyze_And_Resolve (P);
+ Analyze_And_Resolve (E1);
+ Check_Object_Reference (P);
+ Check_Object_Reference (E1);
+ Set_Etype (N, Standard_Boolean);
+
------------
-- Output --
------------
when Attribute_Pos =>
Check_Discrete_Type;
Check_E1;
+
+ if Is_Boolean_Type (P_Type) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_Name_2 := Chars (P_Type);
+ Check_SPARK_Restriction
+ ("attribute% is not allowed for type%", P);
+ end if;
+
Resolve (E1, P_Base_Type);
Set_Etype (N, Universal_Integer);
when Attribute_Pred =>
Check_Scalar_Type;
Check_E1;
+
+ if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_Name_2 := Chars (P_Type);
+ Check_SPARK_Restriction
+ ("attribute% is not allowed for type%", P);
+ end if;
+
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
-- source subprogram to which the postcondition applies. During
-- pre-analysis, CS is the scope of the subprogram declaration.
+ Prag : Node_Id;
+ -- During pre-analysis, Prag is the enclosing pragma node if any
+
begin
-- Find enclosing scopes, excluding loops
-- Check OK prefix
if Chars (CS) /= Chars (P) then
+ Error_Msg_Name_1 := Name_Result;
+
Error_Msg_NE
("incorrect prefix for % attribute, expected &", P, CS);
Error_Attr;
end if;
+ -- Check in postcondition of function
+
+ Prag := N;
+ while not Nkind_In (Prag, N_Pragma,
+ N_Function_Specification,
+ N_Subprogram_Body)
+ loop
+ Prag := Parent (Prag);
+ end loop;
+
+ if Nkind (Prag) /= N_Pragma then
+ Error_Attr
+ ("% attribute can only appear in postcondition of function",
+ P);
+
+ elsif Get_Pragma_Id (Prag) = Pragma_Test_Case then
+ declare
+ Arg_Ens : constant Node_Id :=
+ Get_Ensures_From_Test_Case_Pragma (Prag);
+ Arg : Node_Id;
+
+ begin
+ Arg := N;
+ while Arg /= Prag and Arg /= Arg_Ens loop
+ Arg := Parent (Arg);
+ end loop;
+
+ if Arg /= Arg_Ens then
+ Error_Attr ("% attribute misplaced inside Test_Case", P);
+ end if;
+ end;
+
+ elsif Get_Pragma_Id (Prag) /= Pragma_Postcondition then
+ Error_Attr
+ ("% attribute can only appear in postcondition of function",
+ P);
+ end if;
+
+ -- The attribute reference is a primary. If expressions follow,
+ -- the attribute reference is really an indexable object, so
+ -- rewrite and analyze as an indexed component.
+
+ if Present (E1) then
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Prefix (N)),
+ Attribute_Name => Name_Result),
+ Expressions => Expressions (N)));
+ Analyze (N);
+ return;
+ end if;
+
Set_Etype (N, Etype (CS));
-- If several functions with that name are visible,
else
Error_Attr
- ("% attribute can only appear" &
- " in function Postcondition pragma", P);
+ ("% attribute can only appear in postcondition of function",
+ P);
end if;
end if;
end Result;
Check_Real_Type;
Set_Etype (N, Universal_Real);
+ ------------------
+ -- Same_Storage --
+ ------------------
+
+ when Attribute_Same_Storage =>
+ if Ada_Version < Ada_2012 then
+ Error_Msg_N
+ ("attribute Same_Storage is an Ada 2012 feature", N);
+ Error_Msg_N
+ ("\unit must be compiled with -gnat2012 switch", N);
+ end if;
+
+ Check_E1;
+
+ -- The arguments must be objects of any type
+
+ Analyze_And_Resolve (P);
+ Analyze_And_Resolve (E1);
+ Check_Object_Reference (P);
+ Check_Object_Reference (E1);
+ Set_Etype (N, Standard_Boolean);
+
-----------
-- Scale --
-----------
-- Storage_Pool --
------------------
- when Attribute_Storage_Pool => Storage_Pool :
+ when Attribute_Storage_Pool |
+ Attribute_Simple_Storage_Pool => Storage_Pool :
begin
Check_E0;
Set_Entity (N, RTE (RE_Global_Pool_Object));
end if;
- Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+ if Attr_Id = Attribute_Storage_Pool then
+ if Present (Get_Rep_Pragma (Etype (Entity (N)),
+ Name_Simple_Storage_Pool_Type))
+ then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N ("cannot use % attribute for type with simple " &
+ "storage pool?", N);
+ Error_Msg_N
+ ("\Program_Error will be raised at run time?", N);
+
+ Rewrite
+ (N, Make_Raise_Program_Error
+ (Sloc (N), Reason => PE_Explicit_Raise));
+ end if;
+
+ Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+ -- In the Simple_Storage_Pool case, verify that the pool entity is
+ -- actually of a simple storage pool type, and set the attribute's
+ -- type to the pool object's type.
+
+ else
+ if not Present (Get_Rep_Pragma (Etype (Entity (N)),
+ Name_Simple_Storage_Pool_Type))
+ then
+ Error_Attr_P
+ ("cannot use % attribute for type without simple " &
+ "storage pool");
+ end if;
+
+ Set_Etype (N, Etype (Entity (N)));
+ end if;
-- Validate_Remote_Access_To_Class_Wide_Type for attribute
-- Storage_Pool since this attribute is not defined for such
Check_Type;
Check_E0;
- if Is_Remote_Access_To_Class_Wide_Type (P_Type) then
- Rewrite (N,
- New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc));
+ if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then
+
+ -- For a real RACW [sub]type, use corresponding stub type
+
+ if not Is_Generic_Type (P_Type) then
+ Rewrite (N,
+ New_Occurrence_Of
+ (Corresponding_Stub_Type (Base_Type (P_Type)), Loc));
+
+ -- For a generic type (that has been marked as an RACW using the
+ -- Remote_Access_Type aspect or pragma), use a generic RACW stub
+ -- type. Note that if the actual is not a remote access type, the
+ -- instantiation will fail.
+
+ else
+ -- Note: we go to the underlying type here because the view
+ -- returned by RTE (RE_RACW_Stub_Type) might be incomplete.
+
+ Rewrite (N,
+ New_Occurrence_Of
+ (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc));
+ end if;
+
else
Error_Attr_P
("prefix of% attribute must be remote access to classwide");
when Attribute_Succ =>
Check_Scalar_Type;
Check_E1;
+
+ if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_Name_2 := Chars (P_Type);
+ Check_SPARK_Restriction
+ ("attribute% is not allowed for type%", P);
+ end if;
+
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
end if;
end if;
+ --------------------------------
+ -- System_Allocator_Alignment --
+ --------------------------------
+
+ when Attribute_System_Allocator_Alignment =>
+ Standard_Attribute (Ttypes.System_Allocator_Alignment);
+
---------
-- Tag --
---------
-- all scope checks and checks for aliased views are omitted.
when Attribute_Unrestricted_Access =>
+
+ -- If from source, deal with relevant restrictions
+
if Comes_From_Source (N) then
Check_Restriction (No_Unchecked_Access, N);
+
+ if Nkind (P) in N_Has_Entity
+ and then Present (Entity (P))
+ and then Is_Object (Entity (P))
+ then
+ Check_Restriction (No_Implicit_Aliasing, N);
+ end if;
end if;
if Is_Entity_Name (P) then
begin
Check_E1;
Check_Discrete_Type;
+
+ if Is_Boolean_Type (P_Type) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_Name_2 := Chars (P_Type);
+ Check_SPARK_Restriction
+ ("attribute% is not allowed for type%", P);
+ end if;
+
Resolve (E1, Any_Integer);
Set_Etype (N, P_Base_Type);
when Attribute_Value => Value :
begin
+ Check_SPARK_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
-- Case of enumeration type
- if Is_Enumeration_Type (P_Type) then
+ -- When an enumeration type appears in an attribute reference, all
+ -- literals of the type are marked as referenced. This must only be
+ -- done if the attribute reference appears in the current source.
+ -- Otherwise the information on references may differ between a
+ -- normal compilation and one that performs inlining.
+
+ if Is_Enumeration_Type (P_Type)
+ and then In_Extended_Main_Code_Unit (N)
+ then
Check_Restriction (No_Enumeration_Maps, N);
-- Mark all enumeration literals as referenced, since the use of
when Attribute_Wide_Image => Wide_Image :
begin
+ Check_SPARK_Restriction_On_Attribute;
Check_Scalar_Type;
Set_Etype (N, Standard_Wide_String);
Check_E1;
when Attribute_Wide_Value => Wide_Value :
begin
+ Check_SPARK_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
----------------
when Attribute_Wide_Width =>
+ Check_SPARK_Restriction_On_Attribute;
Check_E0;
Check_Scalar_Type;
Set_Etype (N, Universal_Integer);
-----------
when Attribute_Width =>
+ Check_SPARK_Restriction_On_Attribute;
Check_E0;
Check_Scalar_Type;
Set_Etype (N, Universal_Integer);
-- Computes the Fore value for the current attribute prefix, which is
-- known to be a static fixed-point type. Used by Fore and Width.
+ function Is_VAX_Float (Typ : Entity_Id) return Boolean;
+ -- Determine whether Typ denotes a VAX floating point type
+
function Mantissa return Uint;
-- Returns the Mantissa value for the prefix type
return R;
end Fore_Value;
+ ------------------
+ -- Is_VAX_Float --
+ ------------------
+
+ function Is_VAX_Float (Typ : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Floating_Point_Type (Typ)
+ and then
+ (Float_Format = 'V'
+ or else Float_Rep (Typ) = VAX_Native);
+ end Is_VAX_Float;
+
--------------
-- Mantissa --
--------------
-- Start of processing for Eval_Attribute
begin
- -- No folding in spec expression that comes from source where the prefix
- -- is an unfrozen entity. This avoids premature folding in cases like:
-
- -- procedure DefExprAnal is
- -- type R is new Integer;
- -- procedure P (Arg : Integer := R'Size);
- -- for R'Size use 64;
- -- procedure P (Arg : Integer := R'Size) is
- -- begin
- -- Put_Line (Arg'Img);
- -- end P;
- -- begin
- -- P;
- -- end;
-
- -- which should print 64 rather than 32. The exclusion of non-source
- -- constructs from this test comes from some internal usage in packed
- -- arrays, which otherwise fails, could use more analysis perhaps???
-
- -- We do however go ahead with generic actual types, otherwise we get
- -- some regressions, probably these types should be frozen anyway???
-
- if In_Spec_Expression
- and then Comes_From_Source (N)
- and then not (Is_Entity_Name (P)
- and then
- (Is_Frozen (Entity (P))
- or else (Is_Type (Entity (P))
- and then
- Is_Generic_Actual_Type (Entity (P)))))
- then
- return;
- end if;
-
-- Acquire first two expressions (at the moment, no attributes take more
-- than two expressions in any case).
-- test Static as required in cases where it makes a difference.
-- In the case where Static is not set, we do know that all the
- -- expressions present are at least known at compile time (we
- -- assumed above that if this was not the case, then there was
- -- no hope of static evaluation). However, we did not require
- -- that the bounds of the prefix type be compile time known,
- -- let alone static). That's because there are many attributes
- -- that can be computed at compile time on non-static subtypes,
- -- even though such references are not static expressions.
+ -- expressions present are at least known at compile time (we assumed
+ -- above that if this was not the case, then there was no hope of static
+ -- evaluation). However, we did not require that the bounds of the
+ -- prefix type be compile time known, let alone static). That's because
+ -- there are many attributes that can be computed at compile time on
+ -- non-static subtypes, even though such references are not static
+ -- expressions.
case Id is
+ -- Attributes related to Ada 2012 iterators (placeholder ???)
+
+ when Attribute_Constant_Indexing => null;
+ when Attribute_Default_Iterator => null;
+ when Attribute_Implicit_Dereference => null;
+ when Attribute_Iterator_Element => null;
+ when Attribute_Variable_Indexing => null;
+
--------------
-- Adjacent --
--------------
Eval_Fat.Copy_Sign
(P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
- -----------
- -- Delta --
- -----------
-
- when Attribute_Delta =>
- Fold_Ureal (N, Delta_Value (P_Type), True);
-
--------------
-- Definite --
--------------
Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
+ -----------
+ -- Delta --
+ -----------
+
+ when Attribute_Delta =>
+ Fold_Ureal (N, Delta_Value (P_Type), True);
+
------------
-- Denorm --
------------
Fold_Uint
(N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True);
+ ---------------------
+ -- Descriptor_Size --
+ ---------------------
+
+ when Attribute_Descriptor_Size =>
+ null;
+
------------
-- Digits --
------------
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
+ -- Replace VAX Float_Type'First with a reference to the temporary
+ -- which represents the low bound of the type. This transformation
+ -- is needed since the back end cannot evaluate 'First on VAX.
+
+ elsif Is_VAX_Float (P_Type)
+ and then Nkind (Lo_Bound) = N_Identifier
+ then
+ Rewrite (N, New_Reference_To (Entity (Lo_Bound), Sloc (N)));
+ Analyze (N);
+
else
Check_Concurrent_Discriminant (Lo_Bound);
end if;
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
+ -- Replace VAX Float_Type'Last with a reference to the temporary
+ -- which represents the high bound of the type. This transformation
+ -- is needed since the back end cannot evaluate 'Last on VAX.
+
+ elsif Is_VAX_Float (P_Type)
+ and then Nkind (Hi_Bound) = N_Identifier
+ then
+ Rewrite (N, New_Reference_To (Entity (Hi_Bound), Sloc (N)));
+ Analyze (N);
+
else
Check_Concurrent_Discriminant (Hi_Bound);
end if;
end if;
end Object_Size;
+ ----------------------
+ -- Overlaps_Storage --
+ ----------------------
+
+ when Attribute_Overlaps_Storage =>
+ null;
+
-------------------------
-- Passed_By_Reference --
-------------------------
Fold_Ureal (N, Model_Small_Value (P_Type), Static);
end if;
+ ------------------
+ -- Same_Storage --
+ ------------------
+
+ when Attribute_Same_Storage =>
+ null;
+
-----------
-- Scale --
-----------
T := T / 10;
end loop;
+ -- User declared enum type with discard names
+
+ elsif Discard_Names (R) then
+
+ -- If range is null, result is zero, that has already
+ -- been dealt with, so what we need is the power of ten
+ -- that accomodates the Pos of the largest value, which
+ -- is the high bound of the range + one for the space.
+
+ W := 1;
+ T := Hi;
+ while T /= 0 loop
+ T := T / 10;
+ W := W + 1;
+ end loop;
+
-- Only remaining possibility is user declared enum type
+ -- with normal case of Discard_Names not active.
else
pragma Assert (Is_Enumeration_Type (P_Type));
W := 0;
L := First_Literal (P_Type);
-
while Present (L) loop
-- Only pay attention to in range characters
-- Note that in some cases, the values have already been folded as
-- a result of the processing in Analyze_Attribute.
- when Attribute_Abort_Signal |
- Attribute_Access |
- Attribute_Address |
- Attribute_Address_Size |
- Attribute_Asm_Input |
- Attribute_Asm_Output |
- Attribute_Base |
- Attribute_Bit_Order |
- Attribute_Bit_Position |
- Attribute_Callable |
- Attribute_Caller |
- Attribute_Class |
- Attribute_Code_Address |
- Attribute_Compiler_Version |
- Attribute_Count |
- Attribute_Default_Bit_Order |
- Attribute_Elaborated |
- Attribute_Elab_Body |
- Attribute_Elab_Spec |
- Attribute_Enabled |
- Attribute_External_Tag |
- Attribute_Fast_Math |
- Attribute_First_Bit |
- Attribute_Input |
- Attribute_Last_Bit |
- Attribute_Maximum_Alignment |
- Attribute_Old |
- Attribute_Output |
- Attribute_Partition_ID |
- Attribute_Pool_Address |
- Attribute_Position |
- Attribute_Priority |
- Attribute_Read |
- Attribute_Result |
- Attribute_Storage_Pool |
- Attribute_Storage_Size |
- Attribute_Storage_Unit |
- Attribute_Stub_Type |
- Attribute_Tag |
- Attribute_Target_Name |
- Attribute_Terminated |
- Attribute_To_Address |
- Attribute_Type_Key |
- Attribute_UET_Address |
- Attribute_Unchecked_Access |
- Attribute_Universal_Literal_String |
- Attribute_Unrestricted_Access |
- Attribute_Valid |
- Attribute_Value |
- Attribute_Wchar_T_Size |
- Attribute_Wide_Value |
- Attribute_Wide_Wide_Value |
- Attribute_Word_Size |
- Attribute_Write =>
+ when Attribute_Abort_Signal |
+ Attribute_Access |
+ Attribute_Address |
+ Attribute_Address_Size |
+ Attribute_Asm_Input |
+ Attribute_Asm_Output |
+ Attribute_Base |
+ Attribute_Bit_Order |
+ Attribute_Bit_Position |
+ Attribute_Callable |
+ Attribute_Caller |
+ Attribute_Class |
+ Attribute_Code_Address |
+ Attribute_Compiler_Version |
+ Attribute_Count |
+ Attribute_Default_Bit_Order |
+ Attribute_Elaborated |
+ Attribute_Elab_Body |
+ Attribute_Elab_Spec |
+ Attribute_Elab_Subp_Body |
+ Attribute_Enabled |
+ Attribute_External_Tag |
+ Attribute_Fast_Math |
+ Attribute_First_Bit |
+ Attribute_Input |
+ Attribute_Last_Bit |
+ Attribute_Maximum_Alignment |
+ Attribute_Old |
+ Attribute_Output |
+ Attribute_Partition_ID |
+ Attribute_Pool_Address |
+ Attribute_Position |
+ Attribute_Priority |
+ Attribute_Read |
+ Attribute_Result |
+ Attribute_Simple_Storage_Pool |
+ Attribute_Storage_Pool |
+ Attribute_Storage_Size |
+ Attribute_Storage_Unit |
+ Attribute_Stub_Type |
+ Attribute_System_Allocator_Alignment |
+ Attribute_Tag |
+ Attribute_Target_Name |
+ Attribute_Terminated |
+ Attribute_To_Address |
+ Attribute_Type_Key |
+ Attribute_UET_Address |
+ Attribute_Unchecked_Access |
+ Attribute_Universal_Literal_String |
+ Attribute_Unrestricted_Access |
+ Attribute_Valid |
+ Attribute_Value |
+ Attribute_Wchar_T_Size |
+ Attribute_Wide_Value |
+ Attribute_Wide_Wide_Value |
+ Attribute_Word_Size |
+ Attribute_Write =>
raise Program_Error;
end case;
-- the level is the same of the enclosing composite type.
if Ada_Version >= Ada_2005
- and then Is_Local_Anonymous_Access (Btyp)
- and then Object_Access_Level (P) > Type_Access_Level (Btyp)
+ and then (Is_Local_Anonymous_Access (Btyp)
+
+ -- Handle cases where Btyp is the
+ -- anonymous access type of an Ada 2012
+ -- stand-alone object.
+
+ or else Nkind (Associated_Node_For_Itype (Btyp)) =
+ N_Object_Declaration)
+ and then Object_Access_Level (P)
+ > Deepest_Type_Access_Level (Btyp)
and then Attr_Id = Attribute_Access
then
-- In an instance, this is a runtime check, but one we
and then
(Ada_Version < Ada_2005
or else
- not Has_Constrained_Partial_View
- (Designated_Type (Base_Type (Typ))))
+ not Effectively_Has_Constrained_Partial_View
+ (Typ => Designated_Type (Base_Type (Typ)),
+ Scop => Current_Scope))
then
null;
then
declare
D : constant Node_Id := Declaration_Node (Entity (P));
-
begin
Error_Msg_N ("aliased object has explicit bounds?",
D);
end if;
end if;
- -- Check the static accessibility rule of 3.10.2(28).
- -- Note that this check is not performed for the
- -- case of an anonymous access type, since the access
- -- attribute is always legal in such a context.
+ -- Check the static accessibility rule of 3.10.2(28). Note that
+ -- this check is not performed for the case of an anonymous
+ -- access type, since the access attribute is always legal
+ -- in such a context.
if Attr_Id /= Attribute_Unchecked_Access
- and then Object_Access_Level (P) > Type_Access_Level (Btyp)
+ and then
+ Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
and then Ekind (Btyp) = E_General_Access_Type
then
Accessibility_Message;
-- anonymous_access_to_protected, there are no accessibility
-- checks either. Omit check entirely for Unrestricted_Access.
- elsif Object_Access_Level (P) > Type_Access_Level (Btyp)
+ elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
and then Comes_From_Source (N)
and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
and then Attr_Id /= Attribute_Unrestricted_Access
declare
LB : Node_Id;
HB : Node_Id;
+ Dims : List_Id;
begin
if not Is_Entity_Name (P)
Resolve (P);
end if;
+ Dims := Expressions (N);
+
HB :=
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr (P, Name_Req => True),
Attribute_Name => Name_Last,
- Expressions => Expressions (N));
+ Expressions => Dims);
LB :=
Make_Attribute_Reference (Loc,
- Prefix => P,
- Attribute_Name => Name_First,
- Expressions => Expressions (N));
+ Prefix => P,
+ Attribute_Name => Name_First,
+ Expressions => (Dims));
+
+ -- Do not share the dimension indicator, if present. Even
+ -- though it is a static constant, its source location
+ -- may be modified when printing expanded code and node
+ -- sharing will lead to chaos in Sprint.
+
+ if Present (Dims) then
+ Set_Expressions (LB,
+ New_List (New_Copy_Tree (First (Dims))));
+ end if;
-- If the original was marked as Must_Not_Freeze (see code
-- in Sem_Ch3.Make_Index), then make sure the rewriting
-- Finally perform static evaluation on the attribute reference
+ Analyze_Dimension (N);
Eval_Attribute (N);
end Resolve_Attribute;