-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, 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;
-- 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
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 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 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
-- 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);
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);
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);
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 --
------------
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");
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
-- 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
-- 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 --
--------------
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;
OSDN Git Service
