-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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 Freeze; use Freeze;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
-- trouble with cascaded errors.
-- The following array is the list of attributes defined in the Ada 83 RM
+ -- 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_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_Priority |
+ Attribute_Stream_Size |
+ Attribute_Wide_Wide_Width => True,
+ others => False);
+
+ -- The following array contains all attributes that cause a modification
+ -- of their prefixes. In a certain sense, the prefix may be considered as
+ -- an lvalue.
+
+ Attribute_Name_Modifies_Prefix : constant Attribute_Class_Array :=
+ Attribute_Class_Array'(
+ Attribute_Access |
+ Attribute_Address |
+ Attribute_Input |
+ Attribute_Read |
+ Attribute_Unchecked_Access => True,
+ others => False);
+
+ -- The following list contains all attributes that require simple names
+ -- rather than values as their prefixes.
+
+ Attribute_Requires_Simple_Name_Prefix : constant Attribute_Class_Array :=
+ Attribute_Class_Array'(
+ Attribute_Asm_Input |
+ Attribute_Asm_Output |
+ Attribute_Size => True,
+ others => False);
+
-----------------------
-- Local_Subprograms --
-----------------------
-- no arguments is used when the caller has already generated the
-- required error messages.
+ procedure Error_Attr_P (Msg : String);
+ pragma No_Return (Error_Attr);
+ -- Like Error_Attr, but error is posted at the start of the prefix
+
procedure Standard_Attribute (Val : Int);
-- Used to process attributes whose prefix is package Standard which
-- yield values of type Universal_Integer. The attribute reference
function OK_Self_Reference return Boolean;
-- An access reference whose prefix is a type can legally appear
-- within an aggregate, where it is obtained by expansion of
- -- a defaulted aggregate;
+ -- a defaulted aggregate. The enclosing aggregate that contains
+ -- the self-referenced is flagged so that the self-reference can
+ -- be expanded into a reference to the target object (see exp_aggr).
------------------------------
-- Build_Access_Object_Type --
Index : Interp_Index;
It : Interp;
+ procedure Check_Local_Access (E : Entity_Id);
+ -- Deal with possible access to local subprogram. If we have such
+ -- an access, we set a flag to kill all tracked values on any call
+ -- because this access value may be passed around, and any called
+ -- code might use it to access a local procedure which clobbers a
+ -- tracked value.
+
function Get_Kind (E : Entity_Id) return Entity_Kind;
-- Distinguish between access to regular/protected subprograms
+ ------------------------
+ -- Check_Local_Access --
+ ------------------------
+
+ procedure Check_Local_Access (E : Entity_Id) is
+ begin
+ if not Is_Library_Level_Entity (E) then
+ Set_Suppress_Value_Tracking_On_Call (Current_Scope);
+ end if;
+ end Check_Local_Access;
+
--------------
-- Get_Kind --
--------------
Set_Etype (N, Any_Type);
if not Is_Overloaded (P) then
+ Check_Local_Access (Entity (P));
+
if not Is_Intrinsic_Subprogram (Entity (P)) then
Acc_Type :=
New_Internal_Entity
else
Get_First_Interp (P, Index, It);
while Present (It.Nam) loop
+ Check_Local_Access (It.Nam);
+
if not Is_Intrinsic_Subprogram (It.Nam) then
Acc_Type :=
New_Internal_Entity
end loop;
end if;
+ -- Cannot be applied to intrinsic. Looking at the tests above,
+ -- the only way Etype (N) can still be set to Any_Type is if
+ -- Is_Intrinsic_Subprogram was True for some referenced entity.
+
if Etype (N) = Any_Type then
- Error_Attr ("prefix of % attribute cannot be intrinsic", P);
+ Error_Attr_P ("prefix of % attribute cannot be intrinsic");
end if;
end Build_Access_Subprogram_Type;
begin
Par := Parent (N);
while Present (Par)
- and then Nkind (Par) in N_Subexpr
+ and then
+ (Nkind (Par) = N_Component_Association
+ or else Nkind (Par) in N_Subexpr)
loop
- exit when Nkind (Par) = N_Aggregate
- or else Nkind (Par) = N_Extension_Aggregate;
+ if Nkind (Par) = N_Aggregate
+ or else Nkind (Par) = N_Extension_Aggregate
+ then
+ if Etype (Par) = Typ then
+ Set_Has_Self_Reference (Par);
+ return True;
+ end if;
+ end if;
+
Par := Parent (Par);
end loop;
- if Present (Par)
- and then
- (Nkind (Par) = N_Aggregate
- or else Nkind (Par) = N_Extension_Aggregate)
- and then Etype (Par) = Typ
- then
- Set_Has_Self_Reference (Par);
- return True;
- else
- return False;
- end if;
+ -- No enclosing aggregate, or not a self-reference
+
+ return False;
end OK_Self_Reference;
-- Start of processing for Analyze_Access_Attribute
Check_E0;
if Nkind (P) = N_Character_Literal then
- Error_Attr
- ("prefix of % attribute cannot be enumeration literal", P);
+ Error_Attr_P
+ ("prefix of % attribute cannot be enumeration literal");
end if;
-- Case of access to subprogram
end if;
if Is_Always_Inlined (Entity (P)) then
- Error_Attr
- ("prefix of % attribute cannot be Inline_Always subprogram",
- P);
+ Error_Attr_P
+ ("prefix of % attribute cannot be Inline_Always subprogram");
end if;
if Aname = Name_Unchecked_Access then
and then Is_Overloadable (Entity (Selector_Name (P)))
then
if Ekind (Entity (Selector_Name (P))) = E_Entry then
- Error_Attr ("prefix of % attribute must be subprogram", P);
+ Error_Attr_P ("prefix of % attribute must be subprogram");
end if;
Build_Access_Subprogram_Type (Selector_Name (P));
end;
if Nkind (P) = N_Expanded_Name then
- Error_Msg_N
+ Error_Msg_F
("current instance prefix must be a direct name", P);
end if;
-- OK if self-reference in an aggregate in Ada 2005, and
-- the reference comes from a copied default expression.
+ -- Note that we check legality of self-reference even if the
+ -- expression comes from source, e.g. when a single component
+ -- association in an aggregate has a box association.
+
elsif Ada_Version >= Ada_05
- and then not Comes_From_Source (N)
and then OK_Self_Reference
then
null;
end;
end if;
- -- If we have an access to an object, and the attribute comes
- -- from source, then set the object as potentially source modified.
- -- We do this because the resulting access pointer can be used to
- -- modify the variable, and we might not detect this, leading to
- -- some junk warnings.
+ -- Special cases when prefix is entity name
if Is_Entity_Name (P) then
+
+ -- If we have an access to an object, and the attribute comes from
+ -- source, then set the object as potentially source modified. We
+ -- do this because the resulting access pointer can be used to
+ -- modify the variable, and we might not detect this, leading to
+ -- some junk warnings.
+
Set_Never_Set_In_Source (Entity (P), False);
+
+ -- Mark entity as address taken, and kill current values
+
+ Set_Address_Taken (Entity (P));
+ Kill_Current_Values (Entity (P));
end if;
- -- Check for aliased view unless unrestricted case. We allow
- -- a nonaliased prefix when within an instance because the
- -- prefix may have been a tagged formal object, which is
- -- defined to be aliased even when the actual might not be
- -- (other instance cases will have been caught in the generic).
- -- Similarly, within an inlined body we know that the attribute
- -- is legal in the original subprogram, and therefore legal in
- -- the expansion.
+ -- Check for aliased view unless unrestricted case. We allow a
+ -- nonaliased prefix when within an instance because the prefix may
+ -- have been a tagged formal object, which is defined to be aliased
+ -- even when the actual might not be (other instance cases will have
+ -- been caught in the generic). Similarly, within an inlined body we
+ -- know that the attribute is legal in the original subprogram, and
+ -- therefore legal in the expansion.
if Aname /= Name_Unrestricted_Access
and then not Is_Aliased_View (P)
and then not In_Instance
and then not In_Inlined_Body
then
- Error_Attr ("prefix of % attribute must be aliased", P);
+ Error_Attr_P ("prefix of % attribute must be aliased");
end if;
end Analyze_Access_Attribute;
-- recovery behavior.
Error_Msg_Name_1 := Aname;
- Error_Msg_N
+ Error_Msg_F
("prefix for % attribute must be constrained array", P);
end if;
else
if Is_Private_Type (P_Type) then
- Error_Attr
- ("prefix for % attribute may not be private type", P);
+ Error_Attr_P ("prefix for % attribute may not be private type");
elsif Is_Access_Type (P_Type)
and then Is_Array_Type (Designated_Type (P_Type))
and then Is_Entity_Name (P)
and then Is_Type (Entity (P))
then
- Error_Attr ("prefix of % attribute cannot be access type", P);
+ Error_Attr_P ("prefix of % attribute cannot be access type");
elsif Attr_Id = Attribute_First
or else
Error_Attr ("invalid prefix for % attribute", P);
else
- Error_Attr ("prefix for % attribute must be array", P);
+ Error_Attr_P ("prefix for % attribute must be array");
end if;
end if;
and then
Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
then
- Error_Attr
- ("prefix for % attribute must be selected component", P);
+ Error_Attr_P ("prefix for % attribute must be selected component");
end if;
end Check_Component;
Check_Type;
if not Is_Decimal_Fixed_Point_Type (P_Type) then
- Error_Attr
- ("prefix of % attribute must be decimal type", P);
+ Error_Attr_P ("prefix of % attribute must be decimal type");
end if;
end Check_Decimal_Fixed_Point_Type;
Check_Type;
if not Is_Discrete_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be discrete type", P);
+ Error_Attr_P ("prefix of % attribute must be discrete type");
end if;
end Check_Discrete_Type;
Check_Type;
if not Is_Fixed_Point_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be fixed point type", P);
+ Error_Attr_P ("prefix of % attribute must be fixed point type");
end if;
end Check_Fixed_Point_Type;
Check_Type;
if not Is_Floating_Point_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be float type", P);
+ Error_Attr_P ("prefix of % attribute must be float type");
end if;
end Check_Floating_Point_Type;
Check_Type;
if not Is_Integer_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be integer type", P);
+ Error_Attr_P ("prefix of % attribute must be integer type");
end if;
end Check_Integer_Type;
procedure Check_Library_Unit is
begin
if not Is_Compilation_Unit (Entity (P)) then
- Error_Attr ("prefix of % attribute must be library unit", P);
+ Error_Attr_P ("prefix of % attribute must be library unit");
end if;
end Check_Library_Unit;
Check_Type;
if not Is_Modular_Integer_Type (P_Type) then
- Error_Attr
- ("prefix of % attribute must be modular integer type", P);
+ Error_Attr_P
+ ("prefix of % attribute must be modular integer type");
end if;
end Check_Modular_Integer_Type;
end loop;
if From_With_Type (Etype (E)) then
- Error_Attr
- ("prefix of % attribute cannot be an incomplete type", P);
+ Error_Attr_P
+ ("prefix of % attribute cannot be an incomplete type");
else
if Is_Access_Type (Etype (E)) then
if Ekind (Typ) = E_Incomplete_Type
and then No (Full_View (Typ))
then
- Error_Attr
- ("prefix of % attribute cannot be an incomplete type", P);
+ Error_Attr_P
+ ("prefix of % attribute cannot be an incomplete type");
end if;
end if;
end if;
-- Otherwise we must have an object reference
elsif not Is_Object_Reference (P) then
- Error_Attr ("prefix of % attribute must be object", P);
+ Error_Attr_P ("prefix of % attribute must be object");
end if;
end Check_Object_Reference;
end;
end if;
- Error_Attr ("prefix of % attribute must be program unit", P);
+ Error_Attr_P ("prefix of % attribute must be program unit");
end Check_Program_Unit;
---------------------
Check_Type;
if not Is_Real_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be real type", P);
+ Error_Attr_P ("prefix of % attribute must be real type");
end if;
end Check_Real_Type;
Check_Type;
if not Is_Scalar_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be scalar type", P);
+ Error_Attr_P ("prefix of % attribute must be scalar type");
end if;
end Check_Scalar_Type;
else
if Ada_Version >= Ada_05 then
- Error_Attr ("prefix of % attribute must be a task or a task "
- & "interface class-wide object", P);
+ Error_Attr_P
+ ("prefix of % attribute must be a task or a task " &
+ "interface class-wide object");
else
- Error_Attr ("prefix of % attribute must be a task", P);
+ Error_Attr_P ("prefix of % attribute must be a task");
end if;
end if;
end Check_Task_Prefix;
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
then
- Error_Attr ("prefix of % attribute must be a type", P);
+ Error_Attr_P ("prefix of % attribute must be a type");
elsif Ekind (Entity (P)) = E_Incomplete_Type
and then Present (Full_View (Entity (P)))
Error_Attr;
end Error_Attr;
+ ------------------
+ -- Error_Attr_P --
+ ------------------
+
+ procedure Error_Attr_P (Msg : String) is
+ begin
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_F (Msg, P);
+ Error_Attr;
+ end Error_Attr_P;
+
----------------------------
-- Legal_Formal_Attribute --
----------------------------
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
then
- Error_Attr ("prefix of % attribute must be generic type", N);
+ Error_Attr_P ("prefix of % attribute must be generic type");
elsif Is_Generic_Actual_Type (Entity (P))
or else In_Instance
elsif Is_Generic_Type (Entity (P)) then
if not Is_Indefinite_Subtype (Entity (P)) then
- Error_Attr
- ("prefix of % attribute must be indefinite generic type", N);
+ Error_Attr_P
+ ("prefix of % attribute must be indefinite generic type");
end if;
else
- Error_Attr
- ("prefix of % attribute must be indefinite generic type", N);
+ Error_Attr_P
+ ("prefix of % attribute must be indefinite generic type");
end if;
Set_Etype (N, Standard_Boolean);
raise Bad_Attribute;
end if;
- -- Deal with Ada 83 and Features issues
+ -- Deal with Ada 83 issues
if Comes_From_Source (N) then
if not Attribute_83 (Attr_Id) then
end if;
end if;
+ -- Deal with Ada 2005 issues
+
+ if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then
+ Check_Restriction (No_Implementation_Attributes, N);
+ end if;
+
-- Remote access to subprogram type access attribute reference needs
-- unanalyzed copy for tree transformation. The analyzed copy is used
-- for its semantic information (whether prefix is a remote subprogram
begin
if Is_Subprogram (Ent) then
- if not Is_Library_Level_Entity (Ent)
-
- -- Do not take into account nodes generated by the
- -- expander for the elaboration of the dispatch tables;
- -- otherwise we erroneously generate warnings indicating
- -- violation of restriction No_Implicit_Dynamic_Code
- -- with those nodes.
-
- and then not (Is_Dispatching_Operation (Ent)
- and then Nkind (Parent (N)) = N_Assignment_Statement
- and then Nkind (Name (Parent (N))) = N_Indexed_Component
- and then Nkind (Prefix (Name (Parent (N)))) =
- N_Selected_Component
- and then Nkind (Selector_Name
- (Prefix (Name (Parent (N))))) =
- N_Identifier
- and then Present (Entity (Selector_Name
- (Prefix (Name (Parent (N))))))
- and then Entity (Selector_Name
- (Prefix (Name (Parent (N))))) =
- RTE_Record_Component (RE_Prims_Ptr))
- then
+ if not Is_Library_Level_Entity (Ent) then
Check_Restriction (No_Implicit_Dynamic_Code, P);
end if;
Set_Address_Taken (Ent);
+ Kill_Current_Values (Ent);
- -- An Address attribute is accepted when generated by
- -- the compiler for dispatching operation, and an error
- -- is issued once the subprogram is frozen (to avoid
- -- confusing errors about implicit uses of Address in
- -- the dispatch table initialization).
+ -- An Address attribute is accepted when generated by the
+ -- compiler for dispatching operation, and an error is
+ -- issued once the subprogram is frozen (to avoid confusing
+ -- errors about implicit uses of Address in the dispatch
+ -- table initialization).
if Is_Always_Inlined (Entity (P))
and then Comes_From_Source (P)
then
- Error_Attr
+ Error_Attr_P
("prefix of % attribute cannot be Inline_Always" &
- " subprogram", P);
+ " subprogram");
end if;
elsif Is_Object (Ent)
procedure Bad_AST_Entry is
begin
- Error_Attr ("prefix for % attribute must be task entry", P);
+ Error_Attr_P ("prefix for % attribute must be task entry");
end Bad_AST_Entry;
function OK_Entry (E : Entity_Id) return Boolean is
if Result then
if not Is_AST_Entry (E) then
Error_Msg_Name_2 := Aname;
- Error_Attr
- ("% attribute requires previous % pragma", P);
+ Error_Attr ("% attribute requires previous % pragma", P);
end if;
end if;
and then not Is_Scalar_Type (Typ)
and then not Is_Generic_Type (Typ)
then
- Error_Msg_N ("prefix of Base attribute must be scalar type", N);
+ Error_Attr_P ("prefix of Base attribute must be scalar type");
elsif Sloc (Typ) = Standard_Location
and then Base_Type (Typ) = Typ
and then Warn_On_Redundant_Constructs
then
- Error_Msg_NE
- ("?redudant attribute, & is its own base type", N, Typ);
+ Error_Msg_NE
+ ("?redudant attribute, & is its own base type", N, Typ);
end if;
Set_Etype (N, Base_Type (Entity (P)));
Check_E0;
if not Is_Object_Reference (P) then
- Error_Attr ("prefix for % attribute must be object", P);
+ Error_Attr_P ("prefix for % attribute must be object");
-- What about the access object cases ???
Check_Type;
if not Is_Record_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be record type", P);
+ Error_Attr_P ("prefix of % attribute must be record type");
end if;
if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
or else Is_Interface (Etype (E1))
then
Analyze_And_Resolve (N, Etype (P));
+
+ -- However, the attribute is a name that occurs in a context
+ -- that imposes its own type. Leave the result unanalyzed,
+ -- so that type checking with the context type take place.
+ -- on the new conversion node, otherwise Resolve is a noop.
+
+ Set_Analyzed (N, False);
+
else
Analyze (N);
end if;
else
Find_Type (N);
end if;
-
end Class;
------------------
-- Fall through if bad prefix
- Error_Attr
- ("prefix of % attribute must be object of discriminated type", P);
+ Error_Attr_P
+ ("prefix of % attribute must be object of discriminated type");
---------------
-- Copy_Sign --
if not Is_Floating_Point_Type (P_Type)
and then not Is_Decimal_Fixed_Point_Type (P_Type)
then
- Error_Attr
- ("prefix of % attribute must be float or decimal type", P);
+ Error_Attr_P
+ ("prefix of % attribute must be float or decimal type");
end if;
Set_Etype (N, Universal_Integer);
and then
Ekind (Entity (P)) /= E_Enumeration_Literal)
then
- Error_Attr
+ Error_Attr_P
("prefix of %attribute must be " &
- "discrete type/object or enum literal", P);
+ "discrete type/object or enum literal");
end if;
end if;
Set_Etype (N, Standard_String);
if not Is_Tagged_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be tagged", P);
+ Error_Attr_P ("prefix of % attribute must be tagged");
end if;
-----------
else
if Ada_Version >= Ada_05 then
- Error_Attr ("prefix of % attribute must be an exception, a "
- & "task or a task interface class-wide object", P);
+ Error_Attr_P
+ ("prefix of % attribute must be an exception, a " &
+ "task or a task interface class-wide object");
else
- Error_Attr ("prefix of % attribute must be a task or an "
- & "exception", P);
+ Error_Attr_P
+ ("prefix of % attribute must be a task or an exception");
end if;
end if;
if not Is_Scalar_Type (P_Type)
or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
then
- Error_Attr
- ("prefix of % attribute must be scalar object name", N);
+ Error_Attr_P
+ ("prefix of % attribute must be scalar object name");
end if;
Check_Enum_Image;
if not Is_Entity_Name (P)
or else not Is_Subprogram (Entity (P))
then
- Error_Attr ("prefix of % attribute must be subprogram", P);
+ Error_Attr_P ("prefix of % attribute must be subprogram");
end if;
Check_Either_E0_Or_E1;
if P_Type /= Any_Type then
if not Is_Library_Level_Entity (Entity (P)) then
- Error_Attr
- ("prefix of % attribute must be library-level entity", P);
+ Error_Attr_P
+ ("prefix of % attribute must be library-level entity");
-- The defining entity of prefix should not be declared inside
-- a Pure unit. RM E.1(8).
elsif Is_Entity_Name (P)
and then Is_Pure (Entity (P))
then
- Error_Attr
- ("prefix of % attribute must not be declared pure", P);
+ Error_Attr_P
+ ("prefix of % attribute must not be declared pure");
end if;
end if;
then
Resolve (P, Etype (P));
else
- Error_Attr ("prefix of % attribute must be a protected object", P);
+ Error_Attr_P ("prefix of % attribute must be a protected object");
end if;
Set_Etype (N, Standard_Integer);
null;
else
- Error_Attr ("invalid prefix for % attribute", P);
+ Error_Attr_P ("invalid prefix for % attribute");
end if;
Check_Not_Incomplete_Type;
Check_E0;
if Ekind (P_Type) = E_Access_Subprogram_Type then
- Error_Attr
- ("cannot use % attribute for access-to-subprogram type", P);
+ Error_Attr_P
+ ("cannot use % attribute for access-to-subprogram type");
end if;
-- Set appropriate entity
Validate_Remote_Access_To_Class_Wide_Type (N);
else
- Error_Attr ("prefix of % attribute must be access type", P);
+ Error_Attr_P ("prefix of % attribute must be access type");
end if;
------------------
elsif Is_Access_Type (P_Type) then
if Ekind (P_Type) = E_Access_Subprogram_Type then
- Error_Attr
- ("cannot use % attribute for access-to-subprogram type", P);
+ Error_Attr_P
+ ("cannot use % attribute for access-to-subprogram type");
end if;
if Is_Entity_Name (P)
end if;
else
- Error_Attr
- ("prefix of % attribute must be access or task type", P);
+ Error_Attr_P ("prefix of % attribute must be access or task type");
end if;
------------------
then
Set_Etype (N, Universal_Integer);
else
- Error_Attr ("invalid prefix for % attribute", P);
+ Error_Attr_P ("invalid prefix for % attribute");
end if;
---------------
Rewrite (N,
New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc));
else
- Error_Attr
- ("prefix of% attribute must be remote access to classwide", P);
+ Error_Attr_P
+ ("prefix of% attribute must be remote access to classwide");
end if;
----------
Check_Dereference;
if not Is_Tagged_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be tagged", P);
+ Error_Attr_P ("prefix of % attribute must be tagged");
-- Next test does not apply to generated code
-- why not, and what does the illegal reference mean???
and then not Is_Class_Wide_Type (P_Type)
and then Comes_From_Source (N)
then
- Error_Attr
- ("% attribute can only be applied to objects of class-wide type",
- P);
+ Error_Attr_P
+ ("% attribute can only be applied to objects " &
+ "of class - wide type");
end if;
+ -- The prefix cannot be an incomplete type. However, references
+ -- to 'Tag can be generated when expanding interface conversions,
+ -- and this is legal.
+
+ if Comes_From_Source (N) then
+ Check_Not_Incomplete_Type;
+ end if;
Set_Etype (N, RTE (RE_Tag));
-----------------
if Nkind (P) /= N_Identifier
or else Chars (P) /= Name_System
then
- Error_Attr ("prefix of %attribute must be System", P);
+ Error_Attr_P ("prefix of %attribute must be System");
end if;
Generate_Reference (RTE (RE_Address), P);
if not Is_Entity_Name (P)
or else Ekind (Entity (P)) not in Named_Kind
then
- Error_Attr ("prefix for % attribute must be named number", P);
+ Error_Attr_P ("prefix for % attribute must be named number");
else
declare
end if;
if not Is_Scalar_Type (P_Type) then
- Error_Attr ("object for % attribute must be of scalar type", P);
+ Error_Attr_P ("object for % attribute must be of scalar type");
end if;
Set_Etype (N, Standard_Boolean);
and then Associated_Node_For_Itype (Anon) = Parent (Typ);
end Is_Anonymous_Tagged_Base;
+ --------------------------
+ -- Name_Modifies_Prefix --
+ --------------------------
+
+ function Name_Modifies_Prefix (Nam : Name_Id) return Boolean is
+ pragma Assert (Is_Attribute_Name (Nam));
+ begin
+ return Attribute_Name_Modifies_Prefix (Get_Attribute_Id (Nam));
+ end Name_Modifies_Prefix;
+
+ ---------------------------------
+ -- Requires_Simple_Name_Prefix --
+ ---------------------------------
+
+ function Requires_Simple_Name_Prefix (Nam : Name_Id) return Boolean is
+ pragma Assert (Is_Attribute_Name (Nam));
+ begin
+ return Attribute_Requires_Simple_Name_Prefix (Get_Attribute_Id (Nam));
+ end Requires_Simple_Name_Prefix;
+
-----------------------
-- Resolve_Attribute --
-----------------------
-- know will fail, so generate an appropriate warning.
if In_Instance_Body then
- Error_Msg_N
+ Error_Msg_F
("?non-local pointer cannot point to local object", P);
- Error_Msg_N
+ Error_Msg_F
("\?Program_Error will be raised at run time", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
return;
else
- Error_Msg_N
+ Error_Msg_F
("non-local pointer cannot point to local object", P);
-- Check for case where we have a missing access definition
if Present (Indic) then
Error_Msg_NE
("\use an access definition for" &
- " the access discriminant of&", N,
- Entity (Subtype_Mark (Indic)));
+ " the access discriminant of&",
+ N, Entity (Subtype_Mark (Indic)));
end if;
end if;
end if;
elsif Is_Overloadable (Entity (P))
and then Is_Abstract_Subprogram (Entity (P))
then
- Error_Msg_N ("prefix of % attribute cannot be abstract", P);
+ Error_Msg_F ("prefix of % attribute cannot be abstract", P);
Set_Etype (N, Any_Type);
elsif Convention (Entity (P)) = Convention_Intrinsic then
if Ekind (Entity (P)) = E_Enumeration_Literal then
- Error_Msg_N
+ Error_Msg_F
("prefix of % attribute cannot be enumeration literal",
- P);
+ P);
else
- Error_Msg_N
+ Error_Msg_F
("prefix of % attribute cannot be intrinsic", P);
end if;
Set_Etype (N, Any_Type);
-
- elsif Is_Thread_Body (Entity (P)) then
- Error_Msg_N
- ("prefix of % attribute cannot be a thread body", P);
end if;
-- Assignments, return statements, components of aggregates,
or else
Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
then
+ -- Deal with convention mismatch
+
if Convention (Btyp) /= Convention (Entity (P)) then
- Error_Msg_N
- ("subprogram has invalid convention for context", P);
+ Error_Msg_FE
+ ("subprogram & has wrong convention", P, Entity (P));
+
+ Error_Msg_FE
+ ("\does not match convention of access type &",
+ P, Btyp);
+
+ if not Has_Convention_Pragma (Btyp) then
+ Error_Msg_FE
+ ("\probable missing pragma Convention for &",
+ P, Btyp);
+ end if;
else
Check_Subtype_Conformant
if Attr_Id = Attribute_Unchecked_Access then
Error_Msg_Name_1 := Aname;
- Error_Msg_N
+ Error_Msg_F
("attribute% cannot be applied to a subprogram", P);
elsif Aname = Name_Unrestricted_Access then
and then Ekind (Btyp) /=
E_Anonymous_Access_Protected_Subprogram_Type
then
- Error_Msg_N
+ Error_Msg_F
("subprogram must not be deeper than access type", P);
-- Check the restriction of 3.10.2(32) that disallows the
-- want the check to apply when the access attribute is in
-- the spec and there's some other generic body enclosing
-- generic). Finally, there's no point applying the check
- -- when within an instance, because any violations will
- -- have been caught by the compilation of the generic unit.
+ -- when within an instance, because any violations will have
+ -- been caught by the compilation of the generic unit.
elsif Attr_Id = Attribute_Access
and then not In_Instance
if Attr_Id = Attribute_Unchecked_Access then
Error_Msg_Name_1 := Aname;
- Error_Msg_N
+ Error_Msg_F
("attribute% cannot be applied to protected operation", P);
end if;
Resolve (P);
end if;
- -- X'Access is illegal if X denotes a constant and the access
- -- type is access-to-variable. Same for 'Unchecked_Access.
- -- The rule does not apply to 'Unrestricted_Access.
- -- If the reference is a default-initialized aggregate component
- -- for a self-referential type the reference is legal.
+ -- X'Access is illegal if X denotes a constant and the access type
+ -- is access-to-variable. Same for 'Unchecked_Access. The rule
+ -- does not apply to 'Unrestricted_Access. If the reference is a
+ -- default-initialized aggregate component for a self-referential
+ -- type the reference is legal.
if not (Ekind (Btyp) = E_Access_Subprogram_Type
or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
- or else (Is_Record_Type (Btyp) and then
- Present (Corresponding_Remote_Type (Btyp)))
+ or else (Is_Record_Type (Btyp)
+ and then
+ Present (Corresponding_Remote_Type (Btyp)))
or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
or else Ekind (Btyp)
= E_Anonymous_Access_Protected_Subprogram_Type
null;
elsif Comes_From_Source (N) then
- Error_Msg_N ("access-to-variable designates constant", P);
+ Error_Msg_F ("access-to-variable designates constant", P);
end if;
end if;
or else Ekind (Btyp) = E_Anonymous_Access_Type)
then
-- Ada 2005 (AI-230): Check the accessibility of anonymous
- -- access types in record and array components. For a
- -- component definition the level is the same of the
- -- enclosing composite type.
+ -- access types for stand-alone objects, record and array
+ -- components, and return objects. For a component definition
+ -- the level is the same of the enclosing composite type.
if Ada_Version >= Ada_05
- and then
- (Is_Local_Anonymous_Access (Btyp)
- or else Ekind (Scope (Btyp)) = E_Return_Statement)
+ and then Is_Local_Anonymous_Access (Btyp)
and then Object_Access_Level (P) > Type_Access_Level (Btyp)
and then Attr_Id = Attribute_Access
then
-- know will fail, so generate an appropriate warning.
if In_Instance_Body then
- Error_Msg_N
+ Error_Msg_F
("?non-local pointer cannot point to local object", P);
- Error_Msg_N
+ Error_Msg_F
("\?Program_Error will be raised at run time", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Typ);
+
else
- Error_Msg_N
+ Error_Msg_F
("non-local pointer cannot point to local object", P);
end if;
end if;
if Is_Dependent_Component_Of_Mutable_Object (P) then
- Error_Msg_N
+ Error_Msg_F
("illegal attribute for discriminant-dependent component",
P);
end if;
Nom_Subt := Etype (P);
if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
- Nom_Subt := Etype (Nom_Subt);
+ Nom_Subt := Base_Type (Nom_Subt);
end if;
Des_Btyp := Designated_Type (Btyp);
null;
else
- Error_Msg_NE
+ Error_Msg_FE
("type of prefix: & not compatible",
P, Nom_Subt);
- Error_Msg_NE
+ Error_Msg_FE
("\with &, the expected designated type",
P, Designated_Type (Typ));
end if;
(not Is_Class_Wide_Type (Designated_Type (Typ))
and then Is_Class_Wide_Type (Nom_Subt))
then
- Error_Msg_NE
+ Error_Msg_FE
("type of prefix: & is not covered", P, Nom_Subt);
- Error_Msg_NE
+ Error_Msg_FE
("\by &, the expected designated type" &
" ('R'M 3.10.2 (27))", P, Designated_Type (Typ));
end if;
not Has_Constrained_Partial_View
(Designated_Type (Base_Type (Typ)))))
then
- Error_Msg_N
+ Error_Msg_F
("object subtype must statically match "
& "designated subtype", P);
if Is_Entity_Name (P)
and then not Is_Protected_Type (Scope (Entity (P)))
then
- Error_Msg_N ("context requires a protected subprogram", P);
+ Error_Msg_F ("context requires a protected subprogram", P);
-- Check accessibility of protected object against that
-- of the access type, but only on user code, because
-- the expander creates access references for handlers.
-- If the context is an anonymous_access_to_protected,
-- there are no accessibility checks either.
+ -- Omit check altogether for GNAT Unrestricted_Access.
elsif Object_Access_Level (P) > 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
then
Accessibility_Message;
return;
Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type)
and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
then
- Error_Msg_N ("context requires a non-protected subprogram", P);
+ Error_Msg_F ("context requires a non-protected subprogram", P);
end if;
-- The context cannot be a pool-specific type, but this is a
Wrong_Type (N, Typ);
end if;
- Set_Etype (N, Typ);
+ -- The context may be a constrained access type (however ill-
+ -- advised such subtypes might be) so in order to generate a
+ -- constraint check when needed set the type of the attribute
+ -- reference to the base type of the context.
+
+ Set_Etype (N, Btyp);
-- Check for incorrect atomic/volatile reference (RM C.6(12))
if Is_Atomic_Object (P)
and then not Is_Atomic (Designated_Type (Typ))
then
- Error_Msg_N
+ Error_Msg_F
("access to atomic object cannot yield access-to-" &
"non-atomic type", P);
elsif Is_Volatile_Object (P)
and then not Is_Volatile (Designated_Type (Typ))
then
- Error_Msg_N
+ Error_Msg_F
("access to volatile object cannot yield access-to-" &
"non-volatile type", P);
end if;
if Present (It.Nam) then
Error_Msg_Name_1 := Aname;
- Error_Msg_N
+ Error_Msg_F
("prefix of % attribute cannot be overloaded", P);
- return;
end if;
end if;
end case;
-- Normally the Freezing is done by Resolve but sometimes the Prefix
- -- is not resolved, in which case the freezing must be done now.
+ -- is not resolved, in which case the freezing must be done now. The
+ -- exception to this general rule is the use of 'Address with
+ -- subprograms (this is required by the backend to support the static
+ -- allocation of the dispatch tables).
+
+ if Static_Dispatch_Tables
+ and then Nkind (P) in N_Has_Entity
+ and then not Is_Frozen (Entity (P))
+ and then Attr_Id = Attribute_Address
+ and then Is_Subprogram (Entity (P))
+ and then Is_Dispatching_Operation (Entity (P))
+ then
+ Set_Has_Delayed_Freeze (Entity (P));
- Freeze_Expression (P);
+ else
+ Freeze_Expression (P);
+ end if;
-- Finally perform static evaluation on the attribute reference
OSDN Git Service
