-- --
-- 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
and then not In_Instance
and then not In_Inlined_Body
then
- if Restriction_Check_Required (No_Implicit_Aliasing) then
- Error_Attr_P
- ("prefix of % attribute must be explicitly aliased");
- else
- Error_Attr_P
- ("prefix of % attribute must be aliased");
- end if;
+ 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
case Attr_Id is
- -- Attributes related to Ada2012 iterators. Attribute specifications
+ -- Attributes related to Ada 2012 iterators. Attribute specifications
-- exist for these, but they cannot be queried.
when Attribute_Constant_Indexing |
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;
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 --
------------
-- 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");
-- 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 Is_Object (Entity (P)) then
+ 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;
-- 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).
case Id is
- -- Attributes related to Ada2012 iterators (placeholder ???)
+ -- Attributes related to Ada 2012 iterators (placeholder ???)
when Attribute_Constant_Indexing => null;
when Attribute_Default_Iterator => null;
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;
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
Attribute_Priority |
Attribute_Read |
Attribute_Result |
+ Attribute_Simple_Storage_Pool |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |
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
-- Finally perform static evaluation on the attribute reference
+ Analyze_Dimension (N);
Eval_Attribute (N);
end Resolve_Attribute;
OSDN Git Service
