Skip to content

R
riscv-gcc-1
Commit 822033eb by Hristian Kirtchev Committed by Arnaud Charlet
Options

exp_ch2.adb: Remove "with" and "use" clauses for Namet and Snames. 

2007-04-20  Hristian Kirtchev  <kirtchev@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* exp_ch2.adb: Remove "with" and "use" clauses for Namet and Snames.
	Add "with" and "use" clauses for Sem_Attr.
	(Expand_Current_Value): Do not replace occurences of attribute
	references where the prefix must be a simple name.

	* sem_attr.ads, sem_attr.adb: Remove "with" and "use" clauses for
	Namet. Add new arrays Attribute_Name_Modifies_Prefix and
	Attribute_Requires_Simple_Name_Prefix.
	(Name_Modifies_Prefix): Body of new function.
	(Requires_Simple_Name_Prefix): Body of new function.
	(Resolve_Attribute, case Access): Improve error message for case of
	mismatched conventions.
	(Analyze_Attribute, case 'Tag): The prefix the attribute cannot be of an
	incomplete type.
	(Analyze_Attribute, case 'Access): If the type of the prefix is a
	constrained subtype for a nominal unconstrained type, use its base type
	to check for conformance with the context.
	(Resolve_Attribute): Remove test of the access type being associated
	with a return statement from condition for performing accessibility
	checks on access attributes, since this case is now captured by
	Is_Local_Anonymous_Access.
	(Analyze_Access_Attribute): Set Address_Taken on entity
	(Analyze_Attribute, case Address): Set Address_Taken on entity
	(OK_Self_Reference): Traverse tree to locate enclosing aggregate when
	validating an access attribute whose prefix is a current instance.
	(Resolve_Attribute): In case of attributes 'Code_Address and 'Address
	applied to dispatching operations, if freezing is required then we set
	the attribute Has_Delayed_Freeze in the prefix's entity.
	(Check_Local_Access): Set flag Suppress_Value_Tracking_On_Call in
	current scope if access of local subprogram taken
	(Analyze_Access_Attribute): Check legality of self-reference even if the
	expression comes from source, as when a single component association in
	an aggregate has a box association.
	(Resolve_Attribute, case 'Access): Do not apply accessibility checks to
	the prefix if it is a protected operation and the attribute is
	Unrestricted_Access.
	(Resolve_Attribute, case 'Access): Set the Etype of the attribute
	reference to the base type of the context, to force a constraint check
	when the context is an access subtype with an explicit constraint.
	(Analyze_Attribute, case 'Class): If the prefix is an interface and the
	node is rewritten as an interface conversion. leave unanalyzed after
	resolution, to ensure that type checking against the context will take
	place.

From-SVN: r125395
parent 33160237
Showing with 355 additions and 210 deletions
gcc/ada/exp_ch2.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -35,12 +35,12 @@ with Exp_VFpt; use Exp_VFpt;
with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Attr; use Sem_Attr;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
......@@ -156,13 +156,12 @@ package body Exp_Ch2 is
and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
-- Same for Asm_Input and Asm_Output attribute references
-- Same for attribute references that require a simple name prefix
and then not (Nkind (Parent (N)) = N_Attribute_Reference
and then
(Attribute_Name (Parent (N)) = Name_Asm_Input
or else
Attribute_Name (Parent (N)) = Name_Asm_Output))
and then Requires_Simple_Name_Prefix (
Attribute_Name (Parent (N))))
then
-- Case of Current_Value is a compile time known value
......
gcc/ada/sem_attr.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -37,7 +37,6 @@ with Expander; use Expander;
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;
......@@ -79,6 +78,7 @@ package body Sem_Attr is
-- 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 |
......@@ -125,6 +125,40 @@ package body Sem_Attr is
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 --
-----------------------
......@@ -311,6 +345,10 @@ package body Sem_Attr is
-- 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
......@@ -348,7 +386,9 @@ package body Sem_Attr is
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 --
......@@ -375,9 +415,27 @@ package body Sem_Attr is
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 --
--------------
......@@ -401,6 +459,8 @@ package body Sem_Attr is
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
......@@ -413,6 +473,8 @@ package body Sem_Attr is
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
......@@ -426,8 +488,12 @@ package body Sem_Attr is
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;
......@@ -441,24 +507,25 @@ package body Sem_Attr is
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
......@@ -467,8 +534,8 @@ package body Sem_Attr is
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
......@@ -484,9 +551,8 @@ package body Sem_Attr is
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
......@@ -513,7 +579,7 @@ package body Sem_Attr is
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));
......@@ -565,7 +631,7 @@ package body Sem_Attr is
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;
......@@ -608,8 +674,11 @@ package body Sem_Attr is
-- 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;
......@@ -647,31 +716,38 @@ package body Sem_Attr is
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;
......@@ -788,7 +864,7 @@ package body Sem_Attr is
-- recovery behavior.
Error_Msg_Name_1 := Aname;
Error_Msg_N
Error_Msg_F
("prefix for % attribute must be constrained array", P);
end if;
......@@ -796,15 +872,14 @@ package body Sem_Attr is
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
......@@ -813,7 +888,7 @@ package body Sem_Attr is
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;
......@@ -888,8 +963,7 @@ package body Sem_Attr is
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;
......@@ -902,8 +976,7 @@ package body Sem_Attr is
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;
......@@ -958,7 +1031,7 @@ package body Sem_Attr is
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;
......@@ -1054,7 +1127,7 @@ package body Sem_Attr is
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;
......@@ -1077,7 +1150,7 @@ package body Sem_Attr is
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;
......@@ -1120,7 +1193,7 @@ package body Sem_Attr is
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;
......@@ -1131,7 +1204,7 @@ package body Sem_Attr is
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;
......@@ -1144,8 +1217,8 @@ package body Sem_Attr is
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;
......@@ -1188,8 +1261,8 @@ package body Sem_Attr is
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
......@@ -1201,8 +1274,8 @@ package body Sem_Attr is
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;
......@@ -1242,7 +1315,7 @@ package body Sem_Attr is
-- 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;
......@@ -1274,7 +1347,7 @@ package body Sem_Attr is
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;
---------------------
......@@ -1286,7 +1359,7 @@ package body Sem_Attr is
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;
......@@ -1299,7 +1372,7 @@ package body Sem_Attr is
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;
......@@ -1443,11 +1516,12 @@ package body Sem_Attr is
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;
......@@ -1465,7 +1539,7 @@ package body Sem_Attr is
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)))
......@@ -1513,6 +1587,17 @@ package body Sem_Attr is
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 --
----------------------------
......@@ -1524,7 +1609,7 @@ package body Sem_Attr is
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
......@@ -1534,13 +1619,13 @@ package body Sem_Attr is
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);
......@@ -1674,7 +1759,7 @@ package body Sem_Attr is
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
......@@ -1689,6 +1774,12 @@ package body Sem_Attr is
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
......@@ -1899,45 +1990,25 @@ package body Sem_Attr is
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)
......@@ -2083,7 +2154,7 @@ package body Sem_Attr is
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
......@@ -2099,8 +2170,7 @@ package body Sem_Attr 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;
......@@ -2195,14 +2265,14 @@ package body Sem_Attr is
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)));
......@@ -2248,7 +2318,7 @@ package body Sem_Attr is
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 ???
......@@ -2269,7 +2339,7 @@ package body Sem_Attr is
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
......@@ -2408,6 +2478,14 @@ package body Sem_Attr is
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;
......@@ -2417,7 +2495,6 @@ package body Sem_Attr is
else
Find_Type (N);
end if;
end Class;
------------------
......@@ -2552,8 +2629,8 @@ package body Sem_Attr is
-- 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 --
......@@ -2749,8 +2826,8 @@ package body Sem_Attr is
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);
......@@ -2812,9 +2889,9 @@ package body Sem_Attr is
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;
......@@ -2849,7 +2926,7 @@ package body Sem_Attr is
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;
-----------
......@@ -2946,11 +3023,12 @@ package body Sem_Attr is
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;
......@@ -2992,8 +3070,8 @@ package body Sem_Attr is
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;
......@@ -3184,7 +3262,7 @@ package body Sem_Attr is
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;
......@@ -3405,8 +3483,8 @@ package body Sem_Attr is
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).
......@@ -3415,8 +3493,8 @@ package body Sem_Attr is
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;
......@@ -3505,7 +3583,7 @@ package body Sem_Attr is
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);
......@@ -3718,7 +3796,7 @@ package body Sem_Attr is
null;
else
Error_Attr ("invalid prefix for % attribute", P);
Error_Attr_P ("invalid prefix for % attribute");
end if;
Check_Not_Incomplete_Type;
......@@ -3742,8 +3820,8 @@ package body Sem_Attr is
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
......@@ -3763,7 +3841,7 @@ package body Sem_Attr is
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;
------------------
......@@ -3777,8 +3855,8 @@ package body Sem_Attr is
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)
......@@ -3804,8 +3882,7 @@ package body Sem_Attr is
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;
------------------
......@@ -3828,7 +3905,7 @@ package body Sem_Attr is
then
Set_Etype (N, Universal_Integer);
else
Error_Attr ("invalid prefix for % attribute", P);
Error_Attr_P ("invalid prefix for % attribute");
end if;
---------------
......@@ -3843,8 +3920,8 @@ package body Sem_Attr is
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;
----------
......@@ -3881,7 +3958,7 @@ package body Sem_Attr is
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???
......@@ -3890,11 +3967,18 @@ package body Sem_Attr is
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));
-----------------
......@@ -3941,7 +4025,7 @@ package body Sem_Attr is
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);
......@@ -4024,7 +4108,7 @@ package body Sem_Attr is
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
......@@ -4125,7 +4209,7 @@ package body Sem_Attr is
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);
......@@ -6946,6 +7030,26 @@ package body Sem_Attr is
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 --
-----------------------
......@@ -6977,9 +7081,9 @@ package body Sem_Attr is
-- 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,
......@@ -6988,7 +7092,7 @@ package body Sem_Attr is
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
......@@ -7009,8 +7113,8 @@ package body Sem_Attr is
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;
......@@ -7106,24 +7210,20 @@ package body Sem_Attr is
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,
......@@ -7138,9 +7238,21 @@ package body Sem_Attr is
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
......@@ -7151,7 +7263,7 @@ package body Sem_Attr is
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
......@@ -7171,7 +7283,7 @@ package body Sem_Attr is
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
......@@ -7210,8 +7322,8 @@ package body Sem_Attr is
-- 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
......@@ -7306,7 +7418,7 @@ package body Sem_Attr is
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;
......@@ -7340,16 +7452,17 @@ package body Sem_Attr is
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
......@@ -7366,7 +7479,7 @@ package body Sem_Attr is
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;
......@@ -7377,14 +7490,12 @@ package body Sem_Attr is
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
......@@ -7392,22 +7503,23 @@ package body Sem_Attr is
-- 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;
......@@ -7419,7 +7531,7 @@ package body Sem_Attr is
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);
......@@ -7463,10 +7575,10 @@ package body Sem_Attr is
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;
......@@ -7478,9 +7590,9 @@ package body Sem_Attr is
(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;
......@@ -7511,7 +7623,7 @@ package body Sem_Attr is
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);
......@@ -7552,17 +7664,19 @@ package body Sem_Attr is
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;
......@@ -7573,7 +7687,7 @@ package body Sem_Attr is
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
......@@ -7586,7 +7700,12 @@ package body Sem_Attr is
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))
......@@ -7594,14 +7713,14 @@ package body Sem_Attr is
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;
......@@ -7631,9 +7750,8 @@ package body Sem_Attr is
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;
......@@ -7994,9 +8112,23 @@ package body Sem_Attr is
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
......
gcc/ada/sem_attr.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- 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- --
......@@ -32,6 +32,7 @@
-- This spec also documents all GNAT implementation defined pragmas
with Exp_Tss; use Exp_Tss;
with Namet; use Namet;
with Snames; use Snames;
with Types; use Types;
......@@ -541,6 +542,19 @@ package Sem_Attr is
-- in appropriate contexts (i.e. in subtype marks, or as prefixes for
-- other attributes).
function Name_Modifies_Prefix (Nam : Name_Id) return Boolean;
-- Determine whether the name of an attribute reference modifies the
-- contents of its prefix. "Read" is such an attribute.
function Requires_Simple_Name_Prefix (Nam : Name_Id) return Boolean;
-- Determine whether the name of an attribute reference requires a simple
-- name rather than a value as its prefix. Such prefixes do not need to be
-- optimized. For instance in the following example:
-- I : constant Integer := 5;
-- S : constant Integer := I'Size;
-- "Size" requires a simple name prefix since "5'Size" does not make
-- sense.
procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id);
-- Performs type resolution of attribute. If the attribute yields a
-- universal value, mark its type as that of the context. On the other
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment