-- --
-- B o d y --
-- --
--- $Revision: 1.7 $
--- --
--- Copyright (C) 1992-2001, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Atree; use Atree;
+with Casing; use Casing;
with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
with Eval_Fat;
-with Exp_Tss; use Exp_Tss;
+with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
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;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
+with Sdefault; use Sdefault;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
-with Snames; use Snames;
-with Stand;
with Stringt; use Stringt;
+with Style;
+with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Ttypef; use Ttypef;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
-with Widechar; use Widechar;
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 : Attribute_Class_Array := Attribute_Class_Array'(
+ Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Address |
Attribute_Aft |
Attribute_Alignment |
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 imply a modification
+ -- of their prefixes or result in an access value. Such prefixes can be
+ -- considered as lvalues.
+
+ Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
+ Attribute_Class_Array'(
+ Attribute_Access |
+ Attribute_Address |
+ Attribute_Input |
+ Attribute_Read |
+ Attribute_Unchecked_Access |
+ Attribute_Unrestricted_Access => True,
+ others => False);
+
-----------------------
-- Local_Subprograms --
-----------------------
P_Base_Type : Entity_Id;
-- Base type of prefix after analysis
- P_Root_Type : Entity_Id;
- -- Root type of prefix after analysis
-
- Unanalyzed : Node_Id;
-
-----------------------
-- Local Subprograms --
-----------------------
- procedure Access_Attribute;
+ procedure Analyze_Access_Attribute;
-- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
-- Internally, Id distinguishes which of the three cases is involved.
-- as referenced, since the image function could possibly end up
-- referencing any of the literals indirectly.
- procedure Check_Enumeration_Type;
- -- Verify that prefix of attribute N is an enumeration type
-
procedure Check_Fixed_Point_Type;
-- Verify that prefix of attribute N is a fixed type
-- two attribute expressions are present
procedure Legal_Formal_Attribute;
- -- Common processing for attributes Definite, and Has_Discriminants
+ -- Common processing for attributes Definite, Has_Access_Values,
+ -- and Has_Discriminants
procedure Check_Integer_Type;
-- Verify that prefix of attribute N is an integer type
procedure Check_Library_Unit;
-- Verify that prefix of attribute N is a library unit
+ procedure Check_Modular_Integer_Type;
+ -- Verify that prefix of attribute N is a modular integer type
+
procedure Check_Not_Incomplete_Type;
-- Check that P (the prefix of the attribute) is not an incomplete
-- type or a private type for which no full view has been given.
procedure Check_Standard_Prefix;
-- Verify that prefix of attribute N is package Standard
- procedure Check_Stream_Attribute (Nam : Name_Id);
- -- Validity checking for stream attribute. Nam is the name of the
+ procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
+ -- Validity checking for stream attribute. Nam is the TSS name of the
-- corresponding possible defined attribute function (e.g. for the
- -- Read attribute, Nam will be Name_uRead).
+ -- Read attribute, Nam will be TSS_Stream_Read).
procedure Check_Task_Prefix;
-- Verify that prefix of attribute N is a task or task type
procedure Error_Attr (Msg : String; Error_Node : Node_Id);
pragma No_Return (Error_Attr);
+ procedure Error_Attr;
+ pragma No_Return (Error_Attr);
-- Posts error using Error_Msg_N at given node, sets type of attribute
-- node to Any_Type, and then raises Bad_Attribute to avoid any further
-- semantic processing. The message typically contains a % insertion
- -- character which is replaced by the attribute name.
+ -- character which is replaced by the attribute name. The call with
+ -- 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
-- non-scalar arguments or returns a non-scalar result. Verifies that
-- such a call does not appear in a preelaborable context.
- ----------------------
- -- Access_Attribute --
- ----------------------
+ ------------------------------
+ -- Analyze_Access_Attribute --
+ ------------------------------
- procedure Access_Attribute is
+ procedure Analyze_Access_Attribute is
Acc_Type : Entity_Id;
Scop : Entity_Id;
-- the type of the prefix. If prefix is overloaded, so it the
-- node itself. The result is stored in Acc_Type.
+ 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. 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 --
------------------------------
function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
- Typ : Entity_Id;
-
+ Typ : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
begin
- if Aname = Name_Unrestricted_Access then
- Typ :=
- New_Internal_Entity
- (E_Allocator_Type, Current_Scope, Loc, 'A');
- else
- Typ :=
- New_Internal_Entity
- (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
- end if;
-
Set_Etype (Typ, Typ);
Init_Size_Align (Typ);
Set_Is_Itype (Typ);
----------------------------------
procedure Build_Access_Subprogram_Type (P : Node_Id) is
- Index : Interp_Index;
- It : Interp;
+ 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 and protected
- -- subprograms.
+ -- 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 --
+ --------------
function Get_Kind (E : Entity_Id) return Entity_Kind is
begin
-- Start of processing for Build_Access_Subprogram_Type
begin
+ -- In the case of an access to subprogram, use the name of the
+ -- subprogram itself as the designated type. Type-checking in
+ -- this case compares the signatures of the designated types.
+
+ Set_Etype (N, Any_Type);
+
if not Is_Overloaded (P) then
- Acc_Type :=
- New_Internal_Entity
- (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
- Set_Etype (Acc_Type, Acc_Type);
- Set_Directly_Designated_Type (Acc_Type, Entity (P));
- Set_Etype (N, Acc_Type);
+ Check_Local_Access (Entity (P));
+
+ if not Is_Intrinsic_Subprogram (Entity (P)) then
+ Acc_Type :=
+ New_Internal_Entity
+ (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
+ Set_Etype (Acc_Type, Acc_Type);
+ Set_Directly_Designated_Type (Acc_Type, Entity (P));
+ Set_Etype (N, Acc_Type);
+ end if;
else
Get_First_Interp (P, Index, It);
- Set_Etype (N, Any_Type);
-
while Present (It.Nam) loop
+ Check_Local_Access (It.Nam);
if not Is_Intrinsic_Subprogram (It.Nam) then
Acc_Type :=
Get_Next_Interp (Index, It);
end loop;
+ end if;
- if Etype (N) = Any_Type then
- Error_Attr ("prefix of % attribute cannot be intrinsic", P);
- 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_P ("prefix of % attribute cannot be intrinsic");
end if;
end Build_Access_Subprogram_Type;
- -- Start of processing for Access_Attribute
+ ----------------------
+ -- OK_Self_Reference --
+ ----------------------
+
+ function OK_Self_Reference return Boolean is
+ Par : Node_Id;
+
+ begin
+ Par := Parent (N);
+ while Present (Par)
+ and then
+ (Nkind (Par) = N_Component_Association
+ or else Nkind (Par) in N_Subexpr)
+ loop
+ 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;
+
+ -- No enclosing aggregate, or not a self-reference
+
+ return False;
+ end OK_Self_Reference;
+
+ -- Start of processing for Analyze_Access_Attribute
begin
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;
- -- In the case of an access to subprogram, use the name of the
- -- subprogram itself as the designated type. Type-checking in
- -- this case compares the signatures of the designated types.
+ -- Case of access to subprogram
- elsif Is_Entity_Name (P)
+ if Is_Entity_Name (P)
and then Is_Overloadable (Entity (P))
then
+ -- Not allowed for nested subprograms if No_Implicit_Dynamic_Code
+ -- restriction set (since in general a trampoline is required).
+
+ if not Is_Library_Level_Entity (Entity (P)) then
+ Check_Restriction (No_Implicit_Dynamic_Code, P);
+ end if;
+
+ if Is_Always_Inlined (Entity (P)) then
+ Error_Attr_P
+ ("prefix of % attribute cannot be Inline_Always subprogram");
+ end if;
+
+ if Aname = Name_Unchecked_Access then
+ Error_Attr ("attribute% cannot be applied to a subprogram", P);
+ end if;
+
+ -- Build the appropriate subprogram 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
+ Kill_Current_Values;
+ end if;
+
return;
- -- Component is an operation of a protected type.
+ -- Component is an operation of a protected type
- elsif (Nkind (P) = N_Selected_Component
- and then Is_Overloadable (Entity (Selector_Name (P))))
+ elsif Nkind (P) = N_Selected_Component
+ 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;
-- Deal with incorrect reference to a type, but note that some
- -- accesses are allowed (references to the current type instance).
+ -- accesses are allowed: references to the current type instance,
+ -- or in Ada 2005 self-referential pointer in a default-initialized
+ -- aggregate.
if Is_Entity_Name (P) then
- Scop := Current_Scope;
Typ := Entity (P);
+ -- The reference may appear in an aggregate that has been expanded
+ -- into a loop. Locate scope of type definition, if any.
+
+ Scop := Current_Scope;
+ while Ekind (Scop) = E_Loop loop
+ Scop := Scope (Scop);
+ end loop;
+
if Is_Type (Typ) then
-- OK if we are within the scope of a limited type
loop
Q := Parent (Q);
end loop;
+
if Present (Q) then
Set_Has_Per_Object_Constraint (
Defining_Identifier (Q), True);
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;
-- is rewritten as a reference to the current object.
elsif Ekind (Scop) = E_Procedure
- and then Chars (Scop) = Name_uInit_Proc
+ and then Is_Init_Proc (Scop)
and then Etype (First_Formal (Scop)) = Typ
then
Rewrite (N,
elsif Is_Task_Type (Typ) then
null;
+ -- 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 OK_Self_Reference
+ then
+ null;
+
-- Otherwise we have an error case
else
declare
Index : Interp_Index;
It : Interp;
-
begin
Set_Etype (N, Any_Type);
Get_First_Interp (P, Index, It);
-
while Present (It.Typ) loop
Acc_Type := Build_Access_Object_Type (It.Typ);
Add_One_Interp (N, Acc_Type, Acc_Type);
end;
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).
+ -- Special cases when we can find a prefix that is an entity name
+
+ declare
+ PP : Node_Id;
+ Ent : Entity_Id;
+
+ begin
+ PP := P;
+ loop
+ if Is_Entity_Name (PP) then
+ Ent := Entity (PP);
+
+ -- 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 (Ent, False);
+
+ -- Mark entity as address taken, and kill current values
+
+ Set_Address_Taken (Ent);
+ Kill_Current_Values (Ent);
+ exit;
+
+ elsif Nkind (PP) = N_Selected_Component
+ or else Nkind (PP) = N_Indexed_Component
+ then
+ PP := Prefix (PP);
+
+ else
+ exit;
+ end if;
+ end loop;
+ end;
+
+ -- 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 Access_Attribute;
+ end Analyze_Access_Attribute;
--------------------------------
-- Check_Array_Or_Scalar_Type --
Index : Entity_Id;
D : Int;
- -- Dimension number for array attributes.
+ -- Dimension number for array attributes
begin
-- Case of string literal or string literal subtype. These cases
-- object, and that the expression, if present, is static
-- and within the range of the dimensions of the type.
- if Is_Array_Type (P_Type) then
- Index := First_Index (P_Base_Type);
-
- else pragma Assert (Is_Access_Type (P_Type));
- Index := First_Index (Base_Type (Designated_Type (P_Type)));
- end if;
+ pragma Assert (Is_Array_Type (P_Type));
+ Index := First_Index (P_Base_Type);
if No (E1) then
procedure Check_Array_Type is
D : Int;
- -- Dimension number for array attributes.
+ -- Dimension number for array attributes
begin
-- If the type is a string literal type, then this must be generated
-- Normal case of array type or subtype
Check_Either_E0_Or_E1;
+ Check_Dereference;
if Is_Array_Type (P_Type) then
if not Is_Constrained (P_Type)
-- recovery behavior.
Error_Msg_Name_1 := Aname;
- Error_Msg_N
+ Error_Msg_F
("prefix for % attribute must be constrained array", P);
end if;
D := Number_Dimensions (P_Type);
- elsif Is_Access_Type (P_Type)
- and then Is_Array_Type (Designated_Type (P_Type))
- then
- if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
- Error_Attr ("prefix of % attribute cannot be access type", P);
- end if;
-
- D := Number_Dimensions (Designated_Type (P_Type));
-
- -- If there is an implicit dereference, then we must freeze
- -- the designated type of the access type, since the type of
- -- the referenced array is this type (see AI95-00106).
-
- Freeze_Before (N, Designated_Type (P_Type));
-
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_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;
if not Is_Static_Expression (E1)
or else Raises_Constraint_Error (E1)
then
- Error_Attr ("expression for dimension must be static", E1);
+ Flag_Non_Static_Expr
+ ("expression for dimension must be static!", E1);
+ Error_Attr;
elsif UI_To_Int (Expr_Value (E1)) > D
or else UI_To_Int (Expr_Value (E1)) < 1
Error_Attr ("invalid dimension number for array type", E1);
end if;
end if;
+
+ if (Style_Check and Style_Check_Array_Attribute_Index)
+ and then Comes_From_Source (N)
+ then
+ Style.Check_Array_Attribute_Index (N, E1, D);
+ end if;
end Check_Array_Type;
-------------------------
return;
elsif not Is_OK_Static_Expression (E1) then
- Error_Attr
- ("constraint argument must be static string expression", E1);
+ Flag_Non_Static_Expr
+ ("constraint argument must be static string expression!", E1);
+ Error_Attr;
end if;
-- Check second argument is right type
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;
procedure Check_Dereference is
begin
- if Is_Object_Reference (P)
- and then Is_Access_Type (P_Type)
+
+ -- Case of a subtype mark
+
+ if Is_Entity_Name (P)
+ and then Is_Type (Entity (P))
then
+ return;
+ end if;
+
+ -- Case of an expression
+
+ Resolve (P);
+
+ if Is_Access_Type (P_Type) then
+
+ -- If there is an implicit dereference, then we must freeze
+ -- the designated type of the access type, since the type of
+ -- the referenced array is this type (see AI95-00106).
+
+ Freeze_Before (N, Designated_Type (P_Type));
+
Rewrite (P,
Make_Explicit_Dereference (Sloc (P),
Prefix => Relocate_Node (P)));
end if;
P_Base_Type := Base_Type (P_Type);
- P_Root_Type := Root_Type (P_Base_Type);
end if;
end Check_Dereference;
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;
procedure Check_Enum_Image is
Lit : Entity_Id;
-
begin
if Is_Enumeration_Type (P_Base_Type) then
Lit := First_Literal (P_Base_Type);
end Check_Enum_Image;
----------------------------
- -- Check_Enumeration_Type --
- ----------------------------
-
- procedure Check_Enumeration_Type is
- begin
- Check_Type;
-
- if not Is_Enumeration_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be enumeration type", P);
- end if;
- end Check_Enumeration_Type;
-
- ----------------------------
-- Check_Fixed_Point_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_Modular_Integer_Type --
+ --------------------------------
+
+ procedure Check_Modular_Integer_Type is
+ begin
+ Check_Type;
+
+ if not Is_Modular_Integer_Type (P_Type) then
+ Error_Attr_P
+ ("prefix of % attribute must be modular integer type");
+ end if;
+ end Check_Modular_Integer_Type;
+
-------------------------------
-- Check_Not_Incomplete_Type --
-------------------------------
procedure Check_Not_Incomplete_Type is
+ E : Entity_Id;
+ Typ : Entity_Id;
+
begin
+ -- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
+ -- dereference we have to check wrong uses of incomplete types
+ -- (other wrong uses are checked at their freezing point).
+
+ -- Example 1: Limited-with
+
+ -- limited with Pkg;
+ -- package P is
+ -- type Acc is access Pkg.T;
+ -- X : Acc;
+ -- S : Integer := X.all'Size; -- ERROR
+ -- end P;
+
+ -- Example 2: Tagged incomplete
+
+ -- type T is tagged;
+ -- type Acc is access all T;
+ -- X : Acc;
+ -- S : constant Integer := X.all'Size; -- ERROR
+ -- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
+
+ if Ada_Version >= Ada_05
+ and then Nkind (P) = N_Explicit_Dereference
+ then
+ E := P;
+ while Nkind (E) = N_Explicit_Dereference loop
+ E := Prefix (E);
+ end loop;
+
+ if From_With_Type (Etype (E)) then
+ Error_Attr_P
+ ("prefix of % attribute cannot be an incomplete type");
+
+ else
+ if Is_Access_Type (Etype (E)) then
+ Typ := Directly_Designated_Type (Etype (E));
+ else
+ Typ := Etype (E);
+ end if;
+
+ if Ekind (Typ) = E_Incomplete_Type
+ and then No (Full_View (Typ))
+ then
+ Error_Attr_P
+ ("prefix of % attribute cannot be an incomplete type");
+ end if;
+ end if;
+ end if;
+
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
or else In_Default_Expression
then
return;
-
else
Check_Fully_Declared (P_Type, P);
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;
-- Check_Stream_Attribute --
----------------------------
- procedure Check_Stream_Attribute (Nam : Name_Id) is
+ procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
Etyp : Entity_Id;
Btyp : Entity_Id;
-- for this here, before they are rewritten, to give a more precise
-- diagnostic.
- if Nam = Name_uInput then
+ if Nam = TSS_Stream_Input then
null;
elsif Is_List_Member (N)
else
Error_Attr
- ("invalid context for attribute %, which is a procedure", N);
+ ("invalid context for attribute%, which is a procedure", N);
end if;
Check_Type;
Btyp := Implementation_Base_Type (P_Type);
-- Stream attributes not allowed on limited types unless the
- -- special OK_For_Stream flag is set.
-
- if Is_Limited_Type (P_Type)
- and then Comes_From_Source (N)
- and then not Present (TSS (Btyp, Nam))
- and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert))
+ -- attribute reference was generated by the expander (in which
+ -- case the underlying type will be used, as described in Sinfo),
+ -- or the attribute was specified explicitly for the type itself
+ -- or one of its ancestors (taking visibility rules into account if
+ -- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
+ -- (with no visibility restriction).
+
+ if Comes_From_Source (N)
+ and then not Stream_Attribute_Available (P_Type, Nam)
+ and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
then
- -- Special case the message if we are compiling the stub version
- -- of a remote operation. One error on the type is sufficient.
+ Error_Msg_Name_1 := Aname;
- if (Is_Remote_Types (Current_Scope)
- or else Is_Remote_Call_Interface (Current_Scope))
- and then not Error_Posted (Btyp)
- then
- Error_Msg_Node_2 := Current_Scope;
+ if Is_Limited_Type (P_Type) then
Error_Msg_NE
- ("limited type& used in& has no stream attributes", P, Btyp);
- Set_Error_Posted (Btyp);
-
- elsif not Error_Posted (Btyp) then
+ ("limited type& has no% attribute", P, P_Type);
+ Explain_Limited_Type (P_Type, P);
+ else
Error_Msg_NE
- ("limited type& has no stream attributes", P, Btyp);
+ ("attribute% for type& is not available", P, P_Type);
end if;
end if;
+ -- Check for violation of restriction No_Stream_Attributes
+
+ if Is_RTE (P_Type, RE_Exception_Id)
+ or else
+ Is_RTE (P_Type, RE_Exception_Occurrence)
+ then
+ Check_Restriction (No_Exception_Registration, P);
+ end if;
+
-- Here we must check that the first argument is an access type
-- that is compatible with Ada.Streams.Root_Stream_Type'Class.
-- Note: the double call to Root_Type here is needed because the
-- root type of a class-wide type is the corresponding type (e.g.
- -- X for X'Class, and we really want to go to the root.
+ -- X for X'Class, and we really want to go to the root.)
if not Is_Access_Type (Etyp)
or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
if Present (E2) then
Analyze (E2);
- if Nam = Name_uRead
+ if Nam = TSS_Stream_Read
and then not Is_OK_Variable_For_Out_Formal (E2)
then
Error_Attr
begin
Analyze (P);
+ -- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
+ -- task interface class-wide types.
+
if Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
- and then Is_Task_Type (Designated_Type (Etype (P))))
+ and then Is_Task_Type (Designated_Type (Etype (P))))
+ or else (Ada_Version >= Ada_05
+ and then Ekind (Etype (P)) = E_Class_Wide_Type
+ and then Is_Interface (Etype (P))
+ and then Is_Task_Interface (Etype (P)))
then
- Resolve (P, Etype (P));
+ Resolve (P);
+
else
- Error_Attr ("prefix of % attribute must be a task", P);
+ if Ada_Version >= Ada_05 then
+ Error_Attr_P
+ ("prefix of % attribute must be a task or a task " &
+ "interface class-wide object");
+
+ else
+ 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 --
----------------
- procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
+ procedure Error_Attr is
begin
- Error_Msg_Name_1 := Aname;
- Error_Msg_N (Msg, Error_Node);
Set_Etype (N, Any_Type);
Set_Entity (N, Any_Type);
raise Bad_Attribute;
end Error_Attr;
+ procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
+ begin
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N (Msg, Error_Node);
+ 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 In_Instance
+ or else In_Instance
+ or else In_Inlined_Body
then
null;
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);
procedure Standard_Attribute (Val : Int) is
begin
Check_Standard_Prefix;
- Rewrite (N,
- Make_Integer_Literal (Loc, Val));
+ Rewrite (N, Make_Integer_Literal (Loc, Val));
Analyze (N);
end Standard_Attribute;
if In_Preelaborated_Unit
and then not In_Subprogram_Or_Concurrent_Unit
then
- Error_Msg_N ("non-static function call in preelaborated unit", N);
+ Flag_Non_Static_Expr
+ ("non-static function call in preelaborated unit!", N);
end if;
end Validate_Non_Static_Attribute_Function_Call;
raise Bad_Attribute;
end if;
- -- Deal with Ada 83 and Features issues
+ -- Deal with Ada 83 issues
- if not Attribute_83 (Attr_Id) then
- if Ada_83 and then Comes_From_Source (N) then
- Error_Msg_Name_1 := Aname;
- Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
- end if;
+ if Comes_From_Source (N) then
+ if not Attribute_83 (Attr_Id) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
+ end if;
- if Attribute_Impl_Def (Attr_Id) then
- Check_Restriction (No_Implementation_Attributes, N);
+ if Attribute_Impl_Def (Attr_Id) then
+ Check_Restriction (No_Implementation_Attributes, N);
+ end if;
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
-- name), the unanalyzed copy is used to construct new subtree rooted
- -- with N_aggregate which represents a fat pointer aggregate.
+ -- with N_Aggregate which represents a fat pointer aggregate.
if Aname = Name_Access then
- Unanalyzed := Copy_Separate_Tree (N);
+ Discard_Node (Copy_Separate_Tree (N));
end if;
-- Analyze prefix and exit if error in analysis. If the prefix is an
- -- incomplete type, use full view if available. A special case is
- -- that we never analyze the prefix of an Elab_Body or Elab_Spec
- -- or UET_Address attribute.
+ -- 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.
if Aname /= Name_Elab_Body
and then
Aname /= Name_Elab_Spec
and then
Aname /= Name_UET_Address
+ and then
+ Aname /= Name_Enabled
then
Analyze (P);
P_Type := Etype (P);
if Is_Entity_Name (P)
and then Present (Entity (P))
and then Is_Type (Entity (P))
- and then Ekind (Entity (P)) = E_Incomplete_Type
then
- P_Type := Get_Full_View (P_Type);
- Set_Entity (P, P_Type);
- Set_Etype (P, P_Type);
+ if Ekind (Entity (P)) = E_Incomplete_Type then
+ P_Type := Get_Full_View (P_Type);
+ Set_Entity (P, P_Type);
+ Set_Etype (P, P_Type);
+
+ elsif Entity (P) = Current_Scope
+ and then Is_Record_Type (Entity (P))
+ then
+ -- Use of current instance within the type. Verify that if the
+ -- attribute appears within a constraint, it yields an access
+ -- type, other uses are illegal.
+
+ declare
+ Par : Node_Id;
+
+ begin
+ Par := Parent (N);
+ while Present (Par)
+ and then Nkind (Parent (Par)) /= N_Component_Definition
+ loop
+ Par := Parent (Par);
+ end loop;
+
+ if Present (Par)
+ and then Nkind (Par) = N_Subtype_Indication
+ then
+ if Attr_Id /= Attribute_Access
+ and then Attr_Id /= Attribute_Unchecked_Access
+ and then Attr_Id /= Attribute_Unrestricted_Access
+ then
+ Error_Msg_N
+ ("in a constraint the current instance can only"
+ & " be used with an access attribute", N);
+ end if;
+ end if;
+ end;
+ end if;
end if;
if P_Type = Any_Type then
end if;
P_Base_Type := Base_Type (P_Type);
- P_Root_Type := Root_Type (P_Base_Type);
end if;
-- Analyze expressions that may be present, exiting if an error occurs
E1 := First (Exprs);
Analyze (E1);
- -- Check for missing or bad expression (result of previous error)
+ -- Check for missing/bad expression (result of previous error)
if No (E1) or else Etype (E1) = Any_Type then
raise Bad_Attribute;
end if;
end if;
- if Is_Overloaded (P)
+ -- Ada 2005 (AI-345): Ensure that the compiler gives exactly the current
+ -- output compiling in Ada 95 mode for the case of ambiguous prefixes.
+
+ if Ada_Version < Ada_05
+ and then Is_Overloaded (P)
and then Aname /= Name_Access
and then Aname /= Name_Address
and then Aname /= Name_Code_Address
and then Aname /= Name_Unchecked_Access
then
Error_Attr ("ambiguous prefix for % attribute", P);
- end if;
- -- Remaining processing depends on attribute
+ elsif Ada_Version >= Ada_05
+ and then Is_Overloaded (P)
+ and then Aname /= Name_Access
+ and then Aname /= Name_Address
+ and then Aname /= Name_Code_Address
+ and then Aname /= Name_Unchecked_Access
+ then
+ -- Ada 2005 (AI-345): Since protected and task types have primitive
+ -- entry wrappers, the attributes Count, Caller and AST_Entry require
+ -- a context check
- case Attr_Id is
+ if Aname = Name_Count
+ or else Aname = Name_Caller
+ or else Aname = Name_AST_Entry
+ then
+ declare
+ Count : Natural := 0;
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (P, I, It);
+ while Present (It.Nam) loop
+ if Comes_From_Source (It.Nam) then
+ Count := Count + 1;
+ else
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Count > 1 then
+ Error_Attr ("ambiguous prefix for % attribute", P);
+ else
+ Set_Is_Overloaded (P, False);
+ end if;
+ end;
+
+ else
+ Error_Attr ("ambiguous prefix for % attribute", P);
+ end if;
+ end if;
+
+ -- Remaining processing depends on attribute
+
+ case Attr_Id is
------------------
-- Abort_Signal --
------------
when Attribute_Access =>
- Access_Attribute;
+ Analyze_Access_Attribute;
-------------
-- Address --
-- An Address attribute created by expansion is legal even when it
-- applies to other entity-denoting expressions.
- if (Is_Entity_Name (P)) then
- if Is_Subprogram (Entity (P))
- or else Is_Object (Entity (P))
- or else Ekind (Entity (P)) = E_Label
- then
- Set_Address_Taken (Entity (P));
+ if Is_Entity_Name (P) then
+ declare
+ Ent : constant Entity_Id := Entity (P);
- elsif (Is_Concurrent_Type (Etype (Entity (P)))
- and then Etype (Entity (P)) = Base_Type (Entity (P)))
- or else Ekind (Entity (P)) = E_Package
- or else Is_Generic_Unit (Entity (P))
- then
- Rewrite (N,
- New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
+ begin
+ if Is_Subprogram (Ent) then
+ if not Is_Library_Level_Entity (Ent) then
+ Check_Restriction (No_Implicit_Dynamic_Code, P);
+ end if;
- else
- Error_Attr ("invalid prefix for % attribute", 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).
+
+ if Is_Always_Inlined (Entity (P))
+ and then Comes_From_Source (P)
+ then
+ Error_Attr_P
+ ("prefix of % attribute cannot be Inline_Always" &
+ " subprogram");
+ end if;
+
+ elsif Is_Object (Ent)
+ or else Ekind (Ent) = E_Label
+ 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.
+
+ Set_Never_Set_In_Source (Ent, False);
+
+ elsif (Is_Concurrent_Type (Etype (Ent))
+ and then Etype (Ent) = Base_Type (Ent))
+ or else Ekind (Ent) = E_Package
+ or else Is_Generic_Unit (Ent)
+ then
+ Rewrite (N,
+ New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
+
+ else
+ Error_Attr ("invalid prefix for % attribute", P);
+ end if;
+ end;
elsif Nkind (P) = N_Attribute_Reference
- and then Attribute_Name (P) = Name_AST_Entry
+ and then Attribute_Name (P) = Name_AST_Entry
then
Rewrite (N,
New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
then
null;
+ -- What exactly are we allowing here ??? and is this properly
+ -- documented in the sinfo documentation for this node ???
+
elsif not Comes_From_Source (N) then
null;
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;
-- If the prefix is a selected component whose prefix is of an
-- access type, then introduce an explicit dereference.
+ -- ??? Could we reuse Check_Dereference here?
if Nkind (Pref) = N_Selected_Component
and then Is_Access_Type (Ptyp)
-- Base --
----------
+ -- Note: when the base attribute appears in the context of a subtype
+ -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
+ -- the following circuit.
+
when Attribute_Base => Base : declare
Typ : Entity_Id;
begin
- Check_Either_E0_Or_E1;
+ Check_E0;
Find_Type (P);
Typ := Entity (P);
- if Sloc (Typ) = Standard_Location
+ if Ada_Version >= Ada_95
+ and then not Is_Scalar_Type (Typ)
+ and then not Is_Generic_Type (Typ)
+ then
+ 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)));
-
- -- If we have an expression present, then really this is a conversion
- -- and the tree must be reformed. Note that this is one of the cases
- -- in which we do a replace rather than a rewrite, because the
- -- original tree is junk.
-
- if Present (E1) then
- Replace (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix => Prefix (N),
- Attribute_Name => Name_Base),
- Expression => Relocate_Node (E1)));
-
- -- E1 may be overloaded, and its interpretations preserved.
-
- Save_Interps (E1, Expression (N));
- Analyze (N);
-
- -- For other cases, set the proper type as the entity of the
- -- attribute reference, and then rewrite the node to be an
- -- occurrence of the referenced base type. This way, no one
- -- else in the compiler has to worry about the base attribute.
-
- else
- Set_Entity (N, Base_Type (Entity (P)));
- Rewrite (N,
- New_Reference_To (Entity (N), Loc));
- Analyze (N);
- end if;
+ Set_Entity (N, Base_Type (Entity (P)));
+ Rewrite (N, New_Reference_To (Entity (N), Loc));
+ Analyze (N);
end Base;
---------
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
end if;
Set_Etype (N, RTE (RE_Bit_Order));
- Resolve (N, Etype (N));
+ Resolve (N);
-- Reset incorrect indication of staticness
-- immediately and sets an appropriate type.
when Attribute_Bit_Position =>
-
if Comes_From_Source (N) then
Check_Component;
end if;
end if;
end loop;
- Set_Etype (N, RTE (RO_AT_Task_ID));
+ Set_Etype (N, RTE (RO_AT_Task_Id));
end Caller;
-------------
-- Class --
-----------
- when Attribute_Class => Class : declare
- begin
+ when Attribute_Class =>
Check_Restriction (No_Dispatch, N);
- Check_Either_E0_Or_E1;
-
- -- If we have an expression present, then really this is a conversion
- -- and the tree must be reformed into a proper conversion. This is a
- -- Replace rather than a Rewrite, because the original tree is junk.
- -- If expression is overloaded, propagate interpretations to new one.
-
- if Present (E1) then
- Replace (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix => Prefix (N),
- Attribute_Name => Name_Class),
- Expression => Relocate_Node (E1)));
-
- Save_Interps (E1, Expression (N));
- Analyze (N);
-
- -- Otherwise we just need to find the proper type
-
- else
- Find_Type (N);
- end if;
-
- end Class;
+ Check_E0;
+ Find_Type (N);
------------------
-- Code_Address --
-- Case from RM J.4(2) of constrained applied to private type
if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
+ Check_Restriction (No_Obsolescent_Features, N);
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("constrained for private type is an " &
+ "obsolescent feature (RM J.4)?", N);
+ end if;
-- If we are within an instance, the attribute must be legal
- -- because it was valid in the generic unit.
+ -- because it was valid in the generic unit. Ditto if this is
+ -- an inlining of a function declared in an instance.
- if In_Instance then
+ if In_Instance
+ or else In_Inlined_Body
+ then
return;
-- For sure OK if we have a real private type itself, but must
-- be completed, cannot apply Constrained to incomplete type.
elsif Is_Private_Type (Entity (P)) then
+
+ -- Note: this is one of the Annex J features that does not
+ -- generate a warning from -gnatwj, since in fact it seems
+ -- very useful, and is used in the GNAT runtime.
+
Check_Not_Incomplete_Type;
return;
end if;
+ -- Normal (non-obsolescent case) of application to object of
+ -- a discriminated type.
+
else
Check_Object_Reference (P);
end if;
-- Must have discriminants or be an access type designating
- -- a type with discriminants. If it is a classwide type is
+ -- a type with discriminants. If it is a classwide type is ???
-- has unknown discriminants.
if Has_Discriminants (P_Type)
-- 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 --
end if;
elsif Nkind (P) = N_Indexed_Component then
- Ent := Entity (Prefix (P));
+ if not Is_Entity_Name (Prefix (P))
+ or else No (Entity (Prefix (P)))
+ or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
+ then
+ if Nkind (Prefix (P)) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Prefix (P))))
+ and then Ekind (Entity (Selector_Name (Prefix (P)))) =
+ E_Entry_Family
+ then
+ Error_Attr
+ ("attribute % must apply to entry of current task", P);
- if Ekind (Ent) /= E_Entry_Family then
- Error_Attr ("invalid entry family name", P);
+ else
+ Error_Attr ("invalid entry family name", P);
+ end if;
return;
+
+ else
+ Ent := Entity (Prefix (P));
end if;
+ elsif Nkind (P) = N_Selected_Component
+ and then Present (Entity (Selector_Name (P)))
+ and then Ekind (Entity (Selector_Name (P))) = E_Entry
+ then
+ Error_Attr
+ ("attribute % must apply to entry of current task", P);
+
else
Error_Attr ("invalid entry name", N);
return;
then
null;
else
- Error_Msg_N
- ("Count must apply to entry of current task", N);
+ Error_Attr
+ ("Attribute % must apply to entry of current task", N);
end if;
end if;
and then Ekind (S) /= E_Entry
and then Ekind (S) /= E_Entry_Family
then
- Error_Attr ("Count cannot appear in inner unit", N);
+ Error_Attr ("Attribute % cannot appear in inner unit", N);
elsif Ekind (Scope (Ent)) = E_Protected_Type
and then not Has_Completion (Scope (Ent))
if It.Nam = Ent then
null;
- elsif Scope (It.Nam) = Scope (Ent) then
- Error_Attr ("ambiguous entry name", N);
+ -- Ada 2005 (AI-345): Do not consider primitive entry
+ -- wrappers generated for task or protected types.
- else
- -- For now make this into a warning. Will become an
- -- error after the 3.15 release.
+ elsif Ada_Version >= Ada_05
+ and then not Comes_From_Source (It.Nam)
+ then
+ null;
- Error_Msg_N
- ("ambiguous name, resolved to entry?", N);
- Error_Msg_N
- ("\(this will become an error in a later release)?", N);
+ else
+ Error_Attr ("ambiguous entry name", N);
end if;
Get_Next_Interp (Index, It);
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);
Check_Floating_Point_Type_0;
Set_Etype (N, Universal_Integer);
+ -------------
+ -- Enabled --
+ -------------
+
+ when Attribute_Enabled =>
+ Check_Either_E0_Or_E1;
+
+ if Present (E1) then
+ if not Is_Entity_Name (E1) or else No (Entity (E1)) then
+ Error_Msg_N ("entity name expected for Enabled attribute", E1);
+ E1 := Empty;
+ end if;
+ end if;
+
+ if Nkind (P) /= N_Identifier then
+ Error_Msg_N ("identifier expected (check name)", P);
+
+ elsif Get_Check_Id (Chars (P)) = No_Check_Id then
+ Error_Msg_N ("& is not a recognized check name", P);
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
--------------
-- Enum_Rep --
--------------
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;
-----------
Resolve (E1, P_Base_Type);
-----------------------
+ -- Has_Access_Values --
+ -----------------------
+
+ when Attribute_Has_Access_Values =>
+ Check_Type;
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+
+ -----------------------
-- Has_Discriminants --
-----------------------
if Etype (P) = Standard_Exception_Type then
Set_Etype (N, RTE (RE_Exception_Id));
+ -- Ada 2005 (AI-345): Attribute 'Identity may be applied to
+ -- task interface class-wide types.
+
elsif Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
- and then Is_Task_Type (Designated_Type (Etype (P))))
+ and then Is_Task_Type (Designated_Type (Etype (P))))
+ or else (Ada_Version >= Ada_05
+ and then Ekind (Etype (P)) = E_Class_Wide_Type
+ and then Is_Interface (Etype (P))
+ and then Is_Task_Interface (Etype (P)))
then
- Resolve (P, Etype (P));
- Set_Etype (N, RTE (RO_AT_Task_ID));
+ Resolve (P);
+ Set_Etype (N, RTE (RO_AT_Task_Id));
else
- Error_Attr ("prefix of % attribute must be a task or an "
- & "exception", P);
+ if Ada_Version >= Ada_05 then
+ Error_Attr_P
+ ("prefix of % attribute must be an exception, a " &
+ "task or a task interface class-wide object");
+ else
+ Error_Attr_P
+ ("prefix of % attribute must be a task or an exception");
+ end if;
end if;
-----------
Check_Scalar_Type;
if Is_Real_Type (P_Type) then
- if Ada_83 and then Comes_From_Source (N) then
+ if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
Error_Msg_N
("(Ada 83) % attribute not allowed for real types", N);
when Attribute_Img => Img :
begin
+ Check_E0;
Set_Etype (N, Standard_String);
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;
when Attribute_Input =>
Check_E1;
- Check_Stream_Attribute (Name_uInput);
- Disallow_In_No_Run_Time_Mode (N);
+ Check_Stream_Attribute (TSS_Stream_Input);
Set_Etype (N, P_Base_Type);
-------------------
Check_E0;
Set_Etype (N, Universal_Integer);
+ ----------------------
+ -- Machine_Rounding --
+ ----------------------
+
+ when Attribute_Machine_Rounding =>
+ Check_Floating_Point_Type_1;
+ Set_Etype (N, P_Base_Type);
+ Resolve (E1, P_Base_Type);
+
--------------------
-- Machine_Rounds --
--------------------
Resolve (E2, P_Base_Type);
Set_Etype (N, P_Base_Type);
- ----------------------------
- -- Max_Interrupt_Priority --
- ----------------------------
-
- when Attribute_Max_Interrupt_Priority =>
- Standard_Attribute
- (UI_To_Int
- (Expr_Value
- (Expression
- (Parent (RTE (RE_Max_Interrupt_Priority))))));
-
- ------------------
- -- Max_Priority --
- ------------------
-
- when Attribute_Max_Priority =>
- Standard_Attribute
- (UI_To_Int
- (Expr_Value
- (Expression
- (Parent (RTE (RE_Max_Priority))))));
-
----------------------------------
-- Max_Size_In_Storage_Elements --
----------------------------------
--------------------
when Attribute_Mechanism_Code =>
-
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;
Set_Etype (E1, Standard_Integer);
if not Is_Static_Expression (E1) then
- Error_Attr
- ("expression for parameter number must be static", E1);
+ Flag_Non_Static_Expr
+ ("expression for parameter number must be static!", E1);
+ Error_Attr;
elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
or else UI_To_Int (Intval (E1)) < 0
Resolve (E2, P_Base_Type);
Set_Etype (N, P_Base_Type);
+ ---------
+ -- Mod --
+ ---------
+
+ when Attribute_Mod =>
+
+ -- Note: this attribute is only allowed in Ada 2005 mode, but
+ -- we do not need to test that here, since Mod is only recognized
+ -- as an attribute name in Ada 2005 mode during the parse.
+
+ Check_E1;
+ Check_Modular_Integer_Type;
+ Resolve (E1, Any_Integer);
+ Set_Etype (N, P_Base_Type);
+
-----------
-- Model --
-----------
when Attribute_Modulus =>
Check_E0;
- Check_Type;
-
- if not Is_Modular_Integer_Type (P_Type) then
- Error_Attr ("prefix of % attribute must be modular type", P);
- end if;
-
+ Check_Modular_Integer_Type;
Set_Etype (N, Universal_Integer);
--------------------
when Attribute_Output =>
Check_E2;
- Check_Stream_Attribute (Name_uInput);
+ Check_Stream_Attribute (TSS_Stream_Output);
Set_Etype (N, Standard_Void_Type);
- Disallow_In_No_Run_Time_Mode (N);
Resolve (N, Standard_Void_Type);
------------------
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;
Check_Type;
Set_Etype (N, Standard_Boolean);
+ ------------------
+ -- Pool_Address --
+ ------------------
+
+ when Attribute_Pool_Address =>
+ Check_E0;
+ Set_Etype (N, RTE (RE_Address));
+
---------
-- Pos --
---------
end if;
end if;
+ --------------
+ -- Priority --
+ --------------
+
+ -- Ada 2005 (AI-327): Dynamic ceiling priorities
+
+ when Attribute_Priority =>
+ if Ada_Version < Ada_05 then
+ Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
+ end if;
+
+ Check_E0;
+
+ -- The prefix must be a protected object (AARM D.5.2 (2/2))
+
+ Analyze (P);
+
+ if Is_Protected_Type (Etype (P))
+ or else (Is_Access_Type (Etype (P))
+ and then Is_Protected_Type (Designated_Type (Etype (P))))
+ then
+ Resolve (P, Etype (P));
+ else
+ Error_Attr_P ("prefix of % attribute must be a protected object");
+ end if;
+
+ Set_Etype (N, Standard_Integer);
+
+ -- Must be called from within a protected procedure or entry of the
+ -- protected object.
+
+ declare
+ S : Entity_Id;
+
+ begin
+ S := Current_Scope;
+ while S /= Etype (P)
+ and then S /= Standard_Standard
+ loop
+ S := Scope (S);
+ end loop;
+
+ if S = Standard_Standard then
+ Error_Attr ("the attribute % is only allowed inside protected "
+ & "operations", P);
+ end if;
+ end;
+
+ Validate_Non_Static_Attribute_Function_Call;
+
-----------
-- Range --
-----------
when Attribute_Range =>
Check_Array_Or_Scalar_Type;
- if Ada_83
+ if Ada_Version = Ada_83
and then Is_Scalar_Type (P_Type)
and then Comes_From_Source (N)
then
when Attribute_Read =>
Check_E2;
- Check_Stream_Attribute (Name_uRead);
+ Check_Stream_Attribute (TSS_Stream_Read);
Set_Etype (N, Standard_Void_Type);
Resolve (N, Standard_Void_Type);
- Disallow_In_No_Run_Time_Mode (N);
Note_Possible_Modification (E2);
---------------
when Attribute_Size | Attribute_VADS_Size =>
Check_E0;
- if Is_Object_Reference (P)
- or else (Is_Entity_Name (P)
- and then Ekind (Entity (P)) = E_Function)
+ -- If prefix is parameterless function call, rewrite and resolve
+ -- as such.
+
+ if Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Function
+ then
+ Resolve (P);
+
+ -- Similar processing for a protected function call
+
+ elsif Nkind (P) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (P))) = E_Function
then
+ Resolve (P);
+ end if;
+
+ if Is_Object_Reference (P) then
Check_Object_Reference (P);
elsif Is_Entity_Name (P)
- and then Is_Type (Entity (P))
+ and then (Is_Type (Entity (P))
+ or else Ekind (Entity (P)) = E_Enumeration_Literal)
then
null;
null;
else
- Error_Attr ("invalid prefix for % attribute", P);
+ Error_Attr_P ("invalid prefix for % attribute");
end if;
Check_Not_Incomplete_Type;
if Is_Access_Type (P_Type) then
Check_E0;
+ if Ekind (P_Type) = E_Access_Subprogram_Type then
+ Error_Attr_P
+ ("cannot use % attribute for access-to-subprogram type");
+ end if;
+
-- Set appropriate entity
if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
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;
------------------
------------------
when Attribute_Storage_Size =>
-
if Is_Task_Type (P_Type) then
Check_E0;
Set_Etype (N, Universal_Integer);
elsif Is_Access_Type (P_Type) then
+ if Ekind (P_Type) = E_Access_Subprogram_Type then
+ Error_Attr_P
+ ("cannot use % attribute for access-to-subprogram type");
+ end if;
+
if Is_Entity_Name (P)
and then Is_Type (Entity (P))
then
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;
------------------
when Attribute_Storage_Unit =>
Standard_Attribute (Ttypes.System_Storage_Unit);
+ -----------------
+ -- Stream_Size --
+ -----------------
+
+ when Attribute_Stream_Size =>
+ Check_E0;
+ Check_Type;
+
+ if Is_Entity_Name (P)
+ and then Is_Elementary_Type (Entity (P))
+ then
+ Set_Etype (N, Universal_Integer);
+ else
+ Error_Attr_P ("invalid prefix for % attribute");
+ end if;
+
+ ---------------
+ -- Stub_Type --
+ ---------------
+
+ when Attribute_Stub_Type =>
+ 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));
+ else
+ Error_Attr_P
+ ("prefix of% attribute must be remote access to classwide");
+ end if;
+
----------
-- Succ --
----------
if Is_Real_Type (P_Type) then
null;
- -- If not modular type, test for overflow check required.
+ -- If not modular type, test for overflow check required
else
if not Is_Modular_Integer_Type (P_Type)
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));
- ----------------
- -- Terminated --
- ----------------
+ -----------------
+ -- Target_Name --
+ -----------------
- when Attribute_Terminated =>
+ when Attribute_Target_Name => Target_Name : declare
+ TN : constant String := Sdefault.Target_Name.all;
+ TL : Natural;
+
+ begin
+ Check_Standard_Prefix;
Check_E0;
- Set_Etype (N, Standard_Boolean);
- Check_Task_Prefix;
- ----------
- -- Tick --
- ----------
+ TL := TN'Last;
+
+ if TN (TL) = '/' or else TN (TL) = '\' then
+ TL := TL - 1;
+ end if;
- when Attribute_Tick =>
- Check_Standard_Prefix;
Rewrite (N,
- Make_Real_Literal (Loc,
- UR_From_Components (
- Num => UI_From_Int (Ttypes.System_Tick_Nanoseconds),
- Den => UI_From_Int (9),
- Rbase => 10)));
- Analyze (N);
+ Make_String_Literal (Loc,
+ Strval => TN (TN'First .. TL)));
+ Analyze_And_Resolve (N, Standard_String);
+ end Target_Name;
+
+ ----------------
+ -- Terminated --
+ ----------------
+
+ when Attribute_Terminated =>
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+ Check_Task_Prefix;
----------------
-- To_Address --
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);
Check_Restriction (No_Unchecked_Access, N);
end if;
- Access_Attribute;
+ Analyze_Access_Attribute;
+
+ -------------------------
+ -- Unconstrained_Array --
+ -------------------------
+
+ when Attribute_Unconstrained_Array =>
+ Check_E0;
+ Check_Type;
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, Standard_Boolean);
------------------------------
-- Universal_Literal_String --
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
Set_Address_Taken (Entity (P));
end if;
- Access_Attribute;
+ Analyze_Access_Attribute;
---------
-- Val --
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);
Check_E1;
Check_Scalar_Type;
+ -- Case of enumeration type
+
if Is_Enumeration_Type (P_Type) then
Check_Restriction (No_Enumeration_Maps, N);
+
+ -- Mark all enumeration literals as referenced, since the use of
+ -- the Value attribute can implicitly reference any of the
+ -- literals of the enumeration base type.
+
+ declare
+ Ent : Entity_Id := First_Literal (P_Base_Type);
+ begin
+ while Present (Ent) loop
+ Set_Referenced (Ent);
+ Next_Literal (Ent);
+ end loop;
+ end;
end if;
- -- Set Etype before resolving expression because expansion
- -- of expression may require enclosing type.
+ -- Set Etype before resolving expression because expansion of
+ -- expression may require enclosing type. Note that the type
+ -- returned by 'Value is the base type of the prefix type.
- Set_Etype (N, P_Type);
+ Set_Etype (N, P_Base_Type);
Validate_Non_Static_Attribute_Function_Call;
end Value;
Validate_Non_Static_Attribute_Function_Call;
end Wide_Image;
+ ---------------------
+ -- Wide_Wide_Image --
+ ---------------------
+
+ when Attribute_Wide_Wide_Image => Wide_Wide_Image :
+ begin
+ Check_Scalar_Type;
+ Set_Etype (N, Standard_Wide_Wide_String);
+ Check_E1;
+ Resolve (E1, P_Base_Type);
+ Validate_Non_Static_Attribute_Function_Call;
+ end Wide_Wide_Image;
+
----------------
-- Wide_Value --
----------------
Validate_Non_Static_Attribute_Function_Call;
end Wide_Value;
+ ---------------------
+ -- Wide_Wide_Value --
+ ---------------------
+
+ when Attribute_Wide_Wide_Value => Wide_Wide_Value :
+ begin
+ Check_E1;
+ Check_Scalar_Type;
+
+ -- Set Etype before resolving expression because expansion
+ -- of expression may require enclosing type.
+
+ Set_Etype (N, P_Type);
+ Validate_Non_Static_Attribute_Function_Call;
+ end Wide_Wide_Value;
+
+ ---------------------
+ -- Wide_Wide_Width --
+ ---------------------
+
+ when Attribute_Wide_Wide_Width =>
+ Check_E0;
+ Check_Scalar_Type;
+ Set_Etype (N, Universal_Integer);
+
----------------
-- Wide_Width --
----------------
when Attribute_Write =>
Check_E2;
- Check_Stream_Attribute (Name_uWrite);
+ Check_Stream_Attribute (TSS_Stream_Write);
Set_Etype (N, Standard_Void_Type);
- Disallow_In_No_Run_Time_Mode (N);
Resolve (N, Standard_Void_Type);
end case;
-- one attribute expression, and the check succeeds, we want to be able
-- to proceed securely assuming that an expression is in fact present.
+ -- Note: we set the attribute analyzed in this case to prevent any
+ -- attempt at reanalysis which could generate spurious error msgs.
+
exception
when Bad_Attribute =>
+ Set_Analyzed (N);
Set_Etype (N, Any_Type);
return;
-
end Analyze_Attribute;
--------------------
P : constant Node_Id := Prefix (N);
C_Type : constant Entity_Id := Etype (N);
- -- The type imposed by the context.
+ -- The type imposed by the context
E1 : Node_Id;
-- First expression, or Empty if none
-- The root type of the prefix type
Static : Boolean;
- -- True if prefix type is static
+ -- True if the result is Static. This is set by the general processing
+ -- to true if the prefix is static, and all expressions are static. It
+ -- can be reset as processing continues for particular attributes
Lo_Bound, Hi_Bound : Node_Id;
-- Expressions for low and high bounds of type or array index referenced
-- any, of the attribute, are in a non-static context. This procedure
-- performs the required additional checks.
+ function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
+ -- Determines if the given type has compile time known bounds. Note
+ -- that we enter the case statement even in cases where the prefix
+ -- type does NOT have known bounds, so it is important to guard any
+ -- attempt to evaluate both bounds with a call to this function.
+
procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
-- This procedure is called when the attribute N has a non-static
-- but compile time known value given by Val. It includes the
IEEEX_Val : Int;
VAXFF_Val : Int;
VAXDF_Val : Int;
- VAXGF_Val : Int);
+ VAXGF_Val : Int;
+ AAMPS_Val : Int;
+ AAMPL_Val : Int);
-- This procedure evaluates a float attribute with no arguments that
-- returns a universal integer result. The parameters give the values
-- for the possible floating-point root types. See ttypef for details.
IEEEX_Val : String;
VAXFF_Val : String;
VAXDF_Val : String;
- VAXGF_Val : String);
+ VAXGF_Val : String;
+ AAMPS_Val : String;
+ AAMPL_Val : String);
-- This procedure evaluates a float attribute with no arguments that
-- returns a universal real result. The parameters give the values
-- required for the possible floating-point root types in string
procedure Set_Bounds;
-- Used for First, Last and Length attributes applied to an array or
- -- array subtype. Sets the variables Index_Lo and Index_Hi to the low
+ -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
-- and high bound expressions for the index referenced by the attribute
-- designator (i.e. the first index if no expression is present, and
-- the N'th index if the value N is present as an expression). Also
- -- used for First and Last of scalar types.
+ -- used for First and Last of scalar types. Static is reset to False
+ -- if the type or index type is not statically constrained.
+
+ function Statically_Denotes_Entity (N : Node_Id) return Boolean;
+ -- Verify that the prefix of a potentially static array attribute
+ -- satisfies the conditions of 4.9 (14).
---------------
-- Aft_Value --
begin
Result := 1;
Delta_Val := Delta_Value (P_Type);
-
while Delta_Val < Ureal_Tenth loop
Delta_Val := Delta_Val * Ureal_10;
Result := Result + 1;
-----------------------
procedure Check_Expressions is
- E : Node_Id := E1;
-
+ E : Node_Id;
begin
+ E := E1;
while Present (E) loop
Check_Non_Static_Context (E);
Next (E);
T : constant Entity_Id := Etype (N);
begin
- Fold_Uint (N, Val);
- Set_Is_Static_Expression (N, False);
+ Fold_Uint (N, Val, False);
-- Check that result is in bounds of the type if it is static
elsif Is_Out_Of_Range (N, T) then
Apply_Compile_Time_Constraint_Error
- (N, "value not in range of}?");
+ (N, "value not in range of}?", CE_Range_Check_Failed);
elsif not Range_Checks_Suppressed (T) then
Enable_Range_Check (N);
end if;
end Compile_Time_Known_Attribute;
+ -------------------------------
+ -- Compile_Time_Known_Bounds --
+ -------------------------------
+
+ function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
+ begin
+ return
+ Compile_Time_Known_Value (Type_Low_Bound (Typ))
+ and then
+ Compile_Time_Known_Value (Type_High_Bound (Typ));
+ end Compile_Time_Known_Bounds;
+
---------------------------------------
-- Float_Attribute_Universal_Integer --
---------------------------------------
IEEEX_Val : Int;
VAXFF_Val : Int;
VAXDF_Val : Int;
- VAXGF_Val : Int)
+ VAXGF_Val : Int;
+ AAMPS_Val : Int;
+ AAMPL_Val : Int)
is
Val : Int;
Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
begin
- if not Vax_Float (P_Base_Type) then
- if Digs = IEEES_Digits then
- Val := IEEES_Val;
- elsif Digs = IEEEL_Digits then
- Val := IEEEL_Val;
- else pragma Assert (Digs = IEEEX_Digits);
- Val := IEEEX_Val;
- end if;
-
- else
+ if Vax_Float (P_Base_Type) then
if Digs = VAXFF_Digits then
Val := VAXFF_Val;
elsif Digs = VAXDF_Digits then
else pragma Assert (Digs = VAXGF_Digits);
Val := VAXGF_Val;
end if;
+
+ elsif Is_AAMP_Float (P_Base_Type) then
+ if Digs = AAMPS_Digits then
+ Val := AAMPS_Val;
+ else pragma Assert (Digs = AAMPL_Digits);
+ Val := AAMPL_Val;
+ end if;
+
+ else
+ if Digs = IEEES_Digits then
+ Val := IEEES_Val;
+ elsif Digs = IEEEL_Digits then
+ Val := IEEEL_Val;
+ else pragma Assert (Digs = IEEEX_Digits);
+ Val := IEEEX_Val;
+ end if;
end if;
- Fold_Uint (N, UI_From_Int (Val));
+ Fold_Uint (N, UI_From_Int (Val), True);
end Float_Attribute_Universal_Integer;
------------------------------------
IEEEX_Val : String;
VAXFF_Val : String;
VAXDF_Val : String;
- VAXGF_Val : String)
+ VAXGF_Val : String;
+ AAMPS_Val : String;
+ AAMPL_Val : String)
is
Val : Node_Id;
Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
begin
- if not Vax_Float (P_Base_Type) then
- if Digs = IEEES_Digits then
- Val := Real_Convert (IEEES_Val);
- elsif Digs = IEEEL_Digits then
- Val := Real_Convert (IEEEL_Val);
- else pragma Assert (Digs = IEEEX_Digits);
- Val := Real_Convert (IEEEX_Val);
- end if;
-
- else
+ if Vax_Float (P_Base_Type) then
if Digs = VAXFF_Digits then
Val := Real_Convert (VAXFF_Val);
elsif Digs = VAXDF_Digits then
else pragma Assert (Digs = VAXGF_Digits);
Val := Real_Convert (VAXGF_Val);
end if;
+
+ elsif Is_AAMP_Float (P_Base_Type) then
+ if Digs = AAMPS_Digits then
+ Val := Real_Convert (AAMPS_Val);
+ else pragma Assert (Digs = AAMPL_Digits);
+ Val := Real_Convert (AAMPL_Val);
+ end if;
+
+ else
+ if Digs = IEEES_Digits then
+ Val := Real_Convert (IEEES_Val);
+ elsif Digs = IEEEL_Digits then
+ Val := Real_Convert (IEEEL_Val);
+ else pragma Assert (Digs = IEEEX_Digits);
+ Val := Real_Convert (IEEEX_Val);
+ end if;
end if;
Set_Sloc (Val, Loc);
Rewrite (N, Val);
+ Set_Is_Static_Expression (N, Static);
Analyze_And_Resolve (N, C_Type);
end Float_Attribute_Universal_Real;
-- low bound.
if Ekind (P_Type) = E_String_Literal_Subtype then
- Lo_Bound :=
- Type_Low_Bound (Etype (First_Index (Base_Type (P_Type))));
+ Ityp := Etype (First_Index (Base_Type (P_Type)));
+ Lo_Bound := Type_Low_Bound (Ityp);
Hi_Bound :=
Make_Integer_Literal (Sloc (P),
elsif Is_Scalar_Type (P_Type) then
Ityp := P_Type;
+ -- For a fixed-point type, we must freeze to get the attributes
+ -- of the fixed-point type set now so we can reference them.
+
if Is_Fixed_Point_Type (P_Type)
and then not Is_Frozen (Base_Type (P_Type))
and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
Lo_Bound := Type_Low_Bound (Ityp);
Hi_Bound := Type_High_Bound (Ityp);
+ if not Is_Static_Subtype (Ityp) then
+ Static := False;
+ end if;
end Set_Bounds;
+ -------------------------------
+ -- Statically_Denotes_Entity --
+ -------------------------------
+
+ function Statically_Denotes_Entity (N : Node_Id) return Boolean is
+ E : Entity_Id;
+
+ begin
+ if not Is_Entity_Name (N) then
+ return False;
+ else
+ E := Entity (N);
+ end if;
+
+ return
+ Nkind (Parent (E)) /= N_Object_Renaming_Declaration
+ or else Statically_Denotes_Entity (Renamed_Object (E));
+ end Statically_Denotes_Entity;
+
-- Start of processing for Eval_Attribute
begin
E2 := Empty;
end if;
- -- Special processing for cases where the prefix is an object
+ -- Special processing for Enabled attribute. This attribute has a very
+ -- special prefix, and the easiest way to avoid lots of special checks
+ -- to protect this special prefix from causing trouble is to deal with
+ -- this attribute immediately and be done with it.
+
+ if Id = Attribute_Enabled then
+
+ -- Evaluate the Enabled attribute
+
+ -- We skip evaluation if the expander is not active. This is not just
+ -- an optimization. It is of key importance that we not rewrite the
+ -- attribute in a generic template, since we want to pick up the
+ -- setting of the check in the instance, and testing expander active
+ -- is as easy way of doing this as any.
+
+ if Expander_Active then
+ declare
+ C : constant Check_Id := Get_Check_Id (Chars (P));
+ R : Boolean;
+
+ begin
+ if No (E1) then
+ if C in Predefined_Check_Id then
+ R := Scope_Suppress (C);
+ else
+ R := Is_Check_Suppressed (Empty, C);
+ end if;
+
+ else
+ R := Is_Check_Suppressed (Entity (E1), C);
+ end if;
+
+ if R then
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ else
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ end if;
+ end;
+ end if;
+
+ return;
+ end if;
+
+ -- Special processing for cases where the prefix is an object. For
+ -- this purpose, a string literal counts as an object (attributes
+ -- of string literals can only appear in generated code).
- if Is_Object_Reference (P) then
+ if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
-- For Component_Size, the prefix is an array object, and we apply
-- the attribute to the type of the object. This is allowed for
AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
begin
- if Present (AS) then
+ if Present (AS) and then Is_Constrained (AS) then
P_Entity := AS;
- -- If no actual subtype, cannot fold
+ -- If we have an unconstrained type, cannot fold
else
Check_Expressions;
-- cannot fold Size.
elsif Id = Attribute_Size then
-
if Is_Entity_Name (P)
and then Known_Esize (Entity (P))
then
-- cannot fold Alignment.
elsif Id = Attribute_Alignment then
-
if Is_Entity_Name (P)
and then Known_Alignment (Entity (P))
then
- Fold_Uint (N, Alignment (Entity (P)));
- Set_Is_Static_Expression (N, False);
+ Fold_Uint (N, Alignment (Entity (P)), False);
return;
else
then
P_Type := Etype (P_Entity);
- -- If the entity is an array constant with an unconstrained
- -- nominal subtype then get the type from the initial value.
- -- If the value has been expanded into assignments, the expression
- -- is not present and the attribute reference remains dynamic.
+ -- If the entity is an array constant with an unconstrained nominal
+ -- subtype then get the type from the initial value. If the value has
+ -- been expanded into assignments, there is no expression and the
+ -- attribute reference remains dynamic.
-- We could do better here and retrieve the type ???
if Ekind (P_Entity) = E_Constant
-- Definite must be folded if the prefix is not a generic type,
-- that is to say if we are within an instantiation. Same processing
- -- applies to the GNAT attributes Has_Discriminants and Type_Class
+ -- applies to the GNAT attributes Has_Discriminants, Type_Class,
+ -- and Unconstrained_Array.
elsif (Id = Attribute_Definite
or else
+ Id = Attribute_Has_Access_Values
+ or else
Id = Attribute_Has_Discriminants
or else
- Id = Attribute_Type_Class)
+ Id = Attribute_Type_Class
+ or else
+ Id = Attribute_Unconstrained_Array)
and then not Is_Generic_Type (P_Entity)
then
P_Type := P_Entity;
Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
return;
+ -- We can fold 'Alignment applied to a type if the alignment is known
+ -- (as happens for an alignment from an attribute definition clause).
+ -- At this stage, this can happen only for types (e.g. record
+ -- types) for which the size is always non-static. We exclude
+ -- generic types from consideration (since they have bogus
+ -- sizes set within templates).
+
+ elsif Id = Attribute_Alignment
+ and then Is_Type (P_Entity)
+ and then (not Is_Generic_Type (P_Entity))
+ and then Known_Alignment (P_Entity)
+ then
+ Compile_Time_Known_Attribute (N, Alignment (P_Entity));
+ return;
+
+ -- If this is an access attribute that is known to fail accessibility
+ -- check, rewrite accordingly.
+
+ elsif Attribute_Name (N) = Name_Access
+ and then Raises_Constraint_Error (N)
+ then
+ Rewrite (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, C_Type);
+ return;
+
-- No other cases are foldable (they certainly aren't static, and at
- -- the moment we don't try to fold any cases other than the two above)
+ -- the moment we don't try to fold any cases other than these three).
else
Check_Expressions;
-- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
-- since we can't do anything with unconstrained arrays. In addition,
-- only the First, Last and Length attributes are possibly static.
- -- In addition Component_Size is possibly foldable, even though it
- -- can never be static.
- -- Definite, Has_Discriminants and Type_Class are again exceptions,
- -- because they apply as well to unconstrained types.
+ -- Definite, Has_Access_Values, Has_Discriminants, Type_Class, and
+ -- Unconstrained_Array are again exceptions, because they apply as
+ -- well to unconstrained types.
+
+ -- In addition Component_Size is an exception since it is possibly
+ -- foldable, even though it is never static, and it does apply to
+ -- unconstrained arrays. Furthermore, it is essential to fold this
+ -- in the packed case, since otherwise the value will be incorrect.
elsif Id = Attribute_Definite
or else
+ Id = Attribute_Has_Access_Values
+ or else
Id = Attribute_Has_Discriminants
or else
Id = Attribute_Type_Class
+ or else
+ Id = Attribute_Unconstrained_Array
+ or else
+ Id = Attribute_Component_Size
then
Static := False;
else
if not Is_Constrained (P_Type)
- or else (Id /= Attribute_Component_Size and then
- Id /= Attribute_First and then
- Id /= Attribute_Last and then
+ or else (Id /= Attribute_First and then
+ Id /= Attribute_Last and then
Id /= Attribute_Length)
then
Check_Expressions;
-- cases which we can fold at compile time even though they are not
-- static (e.g. 'Length applied to a static index, even though other
-- non-static indexes make the array type non-static). This is only
- -- ab optimization, but it falls out essentially free, so why not.
+ -- an optimization, but it falls out essentially free, so why not.
-- Again we compute the variable Static for easy reference later
-- (note that no array attributes are static in Ada 83).
- Static := Ada_95;
+ Static := Ada_Version >= Ada_95
+ and then Statically_Denotes_Entity (P);
declare
N : Node_Id;
begin
N := First_Index (P_Type);
while Present (N) loop
- Static := Static and Is_Static_Subtype (Etype (N));
+ Static := Static and then Is_Static_Subtype (Etype (N));
+
+ -- If however the index type is generic, attributes cannot
+ -- be folded.
+
+ if Is_Generic_Type (Etype (N))
+ and then Id /= Attribute_Component_Size
+ then
+ return;
+ end if;
+
Next_Index (N);
end loop;
end;
while Present (E) loop
-- If expression is not static, then the attribute reference
- -- certainly is neither foldable nor static, so we can quit
- -- after calling Apply_Range_Check for 'Pos attributes.
+ -- result certainly cannot be static.
+
+ if not Is_Static_Expression (E) then
+ Static := False;
+ end if;
- -- We can also quit if the expression is not of a scalar type
- -- as noted above.
+ -- If the result is not known at compile time, or is not of
+ -- a scalar type, then the result is definitely not static,
+ -- so we can quit now.
- if not Is_Static_Expression (E)
+ if not Compile_Time_Known_Value (E)
or else not Is_Scalar_Type (Etype (E))
then
+ -- An odd special case, if this is a Pos attribute, this
+ -- is where we need to apply a range check since it does
+ -- not get done anywhere else.
+
if Id = Attribute_Pos then
if Is_Integer_Type (Etype (E)) then
Apply_Range_Check (E, Etype (N));
if Raises_Constraint_Error (N) then
CE_Node :=
- Make_Raise_Constraint_Error (Sloc (N));
+ Make_Raise_Constraint_Error (Sloc (N),
+ Reason => CE_Range_Check_Failed);
Set_Etype (CE_Node, Etype (N));
Set_Raises_Constraint_Error (CE_Node);
Check_Expressions;
-- be foldable, and the individual attribute processing routines
-- 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.
+
case Id is
--------------
--------------
when Attribute_Adjacent =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Adjacent
- (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Adjacent
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
---------
-- Aft --
---------
when Attribute_Aft =>
- Fold_Uint (N, UI_From_Int (Aft_Value));
+ Fold_Uint (N, UI_From_Int (Aft_Value), True);
---------------
-- Alignment --
-- Fold if alignment is set and not otherwise
if Known_Alignment (P_TypeA) then
- Fold_Uint (N, Alignment (P_TypeA));
+ Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA));
end if;
end Alignment_Block;
-------------
when Attribute_Ceiling =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static);
--------------------
-- Component_Size --
--------------------
when Attribute_Component_Size =>
- if Component_Size (P_Type) /= 0 then
- Fold_Uint (N, Component_Size (P_Type));
+ if Known_Static_Component_Size (P_Type) then
+ Fold_Uint (N, Component_Size (P_Type), False);
end if;
-------------
-------------
when Attribute_Compose =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Compose
- (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Compose
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)),
+ Static);
-----------------
-- Constrained --
---------------
when Attribute_Copy_Sign =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Copy_Sign
- (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Copy_Sign
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
-----------
-- Delta --
-----------
when Attribute_Delta =>
- Fold_Ureal (N, Delta_Value (P_Type));
+ Fold_Ureal (N, Delta_Value (P_Type), True);
--------------
-- Definite --
--------------
when Attribute_Definite =>
- declare
- Result : Node_Id;
-
- begin
- if Is_Indefinite_Subtype (P_Entity) then
- Result := New_Occurrence_Of (Standard_False, Loc);
- else
- Result := New_Occurrence_Of (Standard_True, Loc);
- end if;
-
- Rewrite (N, Result);
- Analyze_And_Resolve (N, Standard_Boolean);
- end;
+ Rewrite (N, New_Occurrence_Of (
+ Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
+ Analyze_And_Resolve (N, Standard_Boolean);
------------
-- Denorm --
when Attribute_Denorm =>
Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)));
+ (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True);
------------
-- Digits --
------------
when Attribute_Digits =>
- Fold_Uint (N, Digits_Value (P_Type));
+ Fold_Uint (N, Digits_Value (P_Type), True);
----------
-- Emax --
-- T'Emax = 4 * T'Mantissa
- Fold_Uint (N, 4 * Mantissa);
+ Fold_Uint (N, 4 * Mantissa, True);
--------------
-- Enum_Rep --
--------------
when Attribute_Enum_Rep =>
- if Static then
- -- For an enumeration type with a non-standard representation
- -- use the Enumeration_Rep field of the proper constant. Note
- -- that this would not work for types Character/Wide_Character,
- -- since no real entities are created for the enumeration
- -- literals, but that does not matter since these two types
- -- do not have non-standard representations anyway.
+ -- For an enumeration type with a non-standard representation use
+ -- the Enumeration_Rep field of the proper constant. Note that this
+ -- will not work for types Character/Wide_[Wide-]Character, since no
+ -- real entities are created for the enumeration literals, but that
+ -- does not matter since these two types do not have non-standard
+ -- representations anyway.
- if Is_Enumeration_Type (P_Type)
- and then Has_Non_Standard_Rep (P_Type)
- then
- Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)));
+ if Is_Enumeration_Type (P_Type)
+ and then Has_Non_Standard_Rep (P_Type)
+ then
+ Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
- -- For enumeration types with standard representations and all
- -- other cases (i.e. all integer and modular types), Enum_Rep
- -- is equivalent to Pos.
+ -- For enumeration types with standard representations and all
+ -- other cases (i.e. all integer and modular types), Enum_Rep
+ -- is equivalent to Pos.
- else
- Fold_Uint (N, Expr_Value (E1));
- end if;
+ else
+ Fold_Uint (N, Expr_Value (E1), Static);
end if;
-------------
-- T'Epsilon = 2.0**(1 - T'Mantissa)
- Fold_Ureal (N, Ureal_2 ** (1 - Mantissa));
+ Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
--------------
-- Exponent --
--------------
when Attribute_Exponent =>
- if Static then
- Fold_Uint (N,
- Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Uint (N,
+ Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static);
-----------
-- First --
if Compile_Time_Known_Value (Lo_Bound) then
if Is_Real_Type (P_Type) then
- Fold_Ureal (N, Expr_Value_R (Lo_Bound));
+ Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
else
- Fold_Uint (N, Expr_Value (Lo_Bound));
+ Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
end if;
end First_Attr;
-----------
when Attribute_Floor =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static);
----------
-- Fore --
----------
when Attribute_Fore =>
- if Static then
- Fold_Uint (N, UI_From_Int (Fore_Value));
+ if Compile_Time_Known_Bounds (P_Type) then
+ Fold_Uint (N, UI_From_Int (Fore_Value), Static);
end if;
--------------
--------------
when Attribute_Fraction =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static);
-----------------------
- -- Has_Discriminants --
+ -- Has_Access_Values --
-----------------------
- when Attribute_Has_Discriminants =>
- declare
- Result : Node_Id;
+ when Attribute_Has_Access_Values =>
+ Rewrite (N, New_Occurrence_Of
+ (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
+ Analyze_And_Resolve (N, Standard_Boolean);
- begin
- if Has_Discriminants (P_Entity) then
- Result := New_Occurrence_Of (Standard_True, Loc);
- else
- Result := New_Occurrence_Of (Standard_False, Loc);
- end if;
+ -----------------------
+ -- Has_Discriminants --
+ -----------------------
- Rewrite (N, Result);
- Analyze_And_Resolve (N, Standard_Boolean);
- end;
+ when Attribute_Has_Discriminants =>
+ Rewrite (N, New_Occurrence_Of (
+ Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
+ Analyze_And_Resolve (N, Standard_Boolean);
--------------
-- Identity --
-- Image is a scalar attribute, but is never static, because it is
-- not a static function (having a non-scalar argument (RM 4.9(22))
+ -- However, we can constant-fold the image of an enumeration literal
+ -- if names are available.
when Attribute_Image =>
- null;
+ if Is_Entity_Name (E1)
+ and then Ekind (Entity (E1)) = E_Enumeration_Literal
+ and then not Discard_Names (First_Subtype (Etype (E1)))
+ and then not Global_Discard_Names
+ then
+ declare
+ Lit : constant Entity_Id := Entity (E1);
+ Str : String_Id;
+ begin
+ Start_String;
+ Get_Unqualified_Decoded_Name_String (Chars (Lit));
+ Set_Casing (All_Upper_Case);
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ Str := End_String;
+ Rewrite (N, Make_String_Literal (Loc, Strval => Str));
+ Analyze_And_Resolve (N, Standard_String);
+ Set_Is_Static_Expression (N, False);
+ end;
+ end if;
---------
-- Img --
-- T'Emax = 4 * T'Mantissa
Fold_Ureal (N,
- Ureal_2 ** (4 * Mantissa) *
- (Ureal_1 - Ureal_2 ** (-Mantissa)));
+ Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
+ True);
end if;
----------
if Compile_Time_Known_Value (Hi_Bound) then
if Is_Real_Type (P_Type) then
- Fold_Ureal (N, Expr_Value_R (Hi_Bound));
+ Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
else
- Fold_Uint (N, Expr_Value (Hi_Bound));
+ Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
end if;
end Last;
------------------
when Attribute_Leading_Part =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Leading_Part
- (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Leading_Part
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
------------
-- Length --
------------
- when Attribute_Length => Length :
+ when Attribute_Length => Length : declare
+ Ind : Node_Id;
+
begin
+ -- In the case of a generic index type, the bounds may
+ -- appear static but the computation is not meaningful,
+ -- and may generate a spurious warning.
+
+ Ind := First_Index (P_Type);
+
+ while Present (Ind) loop
+ if Is_Generic_Type (Etype (Ind)) then
+ return;
+ end if;
+
+ Next_Index (Ind);
+ end loop;
+
Set_Bounds;
if Compile_Time_Known_Value (Lo_Bound)
and then Compile_Time_Known_Value (Hi_Bound)
then
Fold_Uint (N,
- UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))));
+ UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
+ True);
end if;
end Length;
-------------
when Attribute_Machine =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Machine (P_Root_Type, Expr_Value_R (E1),
- Eval_Fat.Round));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Machine
+ (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
+ Static);
------------------
-- Machine_Emax --
IEEEX_Machine_Emax,
VAXFF_Machine_Emax,
VAXDF_Machine_Emax,
- VAXGF_Machine_Emax);
+ VAXGF_Machine_Emax,
+ AAMPS_Machine_Emax,
+ AAMPL_Machine_Emax);
------------------
-- Machine_Emin --
IEEEX_Machine_Emin,
VAXFF_Machine_Emin,
VAXDF_Machine_Emin,
- VAXGF_Machine_Emin);
+ VAXGF_Machine_Emin,
+ AAMPS_Machine_Emin,
+ AAMPL_Machine_Emin);
----------------------
-- Machine_Mantissa --
IEEEX_Machine_Mantissa,
VAXFF_Machine_Mantissa,
VAXDF_Machine_Mantissa,
- VAXGF_Machine_Mantissa);
+ VAXGF_Machine_Mantissa,
+ AAMPS_Machine_Mantissa,
+ AAMPL_Machine_Mantissa);
-----------------------
-- Machine_Overflows --
-- Always true for fixed-point
if Is_Fixed_Point_Type (P_Type) then
- Fold_Uint (N, True_Value);
+ Fold_Uint (N, True_Value, True);
-- Floating point case
else
- Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)));
+ Fold_Uint (N,
+ UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
+ True);
end if;
-------------------
if Is_Decimal_Fixed_Point_Type (P_Type)
and then Machine_Radix_10 (P_Type)
then
- Fold_Uint (N, Uint_10);
+ Fold_Uint (N, Uint_10, True);
else
- Fold_Uint (N, Uint_2);
+ Fold_Uint (N, Uint_2, True);
end if;
-- All floating-point type always have radix 2
else
- Fold_Uint (N, Uint_2);
+ Fold_Uint (N, Uint_2, True);
end if;
+ ----------------------
+ -- Machine_Rounding --
+ ----------------------
+
+ -- Note: for the folding case, it is fine to treat Machine_Rounding
+ -- exactly the same way as Rounding, since this is one of the allowed
+ -- behaviors, and performance is not an issue here. It might be a bit
+ -- better to give the same result as it would give at run-time, even
+ -- though the non-determinism is certainly permitted.
+
+ when Attribute_Machine_Rounding =>
+ Fold_Ureal (N,
+ Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
+
--------------------
-- Machine_Rounds --
--------------------
-- Always False for fixed-point
if Is_Fixed_Point_Type (P_Type) then
- Fold_Uint (N, False_Value);
+ Fold_Uint (N, False_Value, True);
-- Else yield proper floating-point result
else
Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)));
+ (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True);
end if;
------------------
begin
if Known_Esize (P_TypeA) then
- Fold_Uint (N, Esize (P_TypeA));
+ Fold_Uint (N, Esize (P_TypeA), True);
end if;
end Machine_Size;
Siz := Siz + 1;
end loop;
- Fold_Uint (N, Siz);
+ Fold_Uint (N, Siz, True);
end;
else
-- Floating-point Mantissa
else
- Fold_Uint (N, Mantissa);
+ Fold_Uint (N, Mantissa, True);
end if;
---------
when Attribute_Max => Max :
begin
if Is_Real_Type (P_Type) then
- Fold_Ureal (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)));
+ Fold_Ureal
+ (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
else
- Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)));
+ Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
end if;
end Max;
if Known_Esize (P_Type) then
Fold_Uint (N,
(Esize (P_Type) + System_Storage_Unit - 1) /
- System_Storage_Unit);
+ System_Storage_Unit,
+ Static);
end if;
--------------------
end if;
if Mech < 0 then
- Fold_Uint (N, UI_From_Int (Int (-Mech)));
+ Fold_Uint (N, UI_From_Int (Int (-Mech)), True);
end if;
end;
when Attribute_Min => Min :
begin
if Is_Real_Type (P_Type) then
- Fold_Ureal (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)));
+ Fold_Ureal
+ (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
else
- Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)));
+ Fold_Uint
+ (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
end if;
end Min;
- -----------
- -- Model --
- -----------
-
+ ---------
+ -- Mod --
+ ---------
+
+ when Attribute_Mod =>
+ Fold_Uint
+ (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
+
+ -----------
+ -- Model --
+ -----------
+
when Attribute_Model =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static);
----------------
-- Model_Emin --
IEEEX_Model_Emin,
VAXFF_Model_Emin,
VAXDF_Model_Emin,
- VAXGF_Model_Emin);
+ VAXGF_Model_Emin,
+ AAMPS_Model_Emin,
+ AAMPL_Model_Emin);
-------------------
-- Model_Epsilon --
IEEEX_Model_Epsilon'Universal_Literal_String,
VAXFF_Model_Epsilon'Universal_Literal_String,
VAXDF_Model_Epsilon'Universal_Literal_String,
- VAXGF_Model_Epsilon'Universal_Literal_String);
+ VAXGF_Model_Epsilon'Universal_Literal_String,
+ AAMPS_Model_Epsilon'Universal_Literal_String,
+ AAMPL_Model_Epsilon'Universal_Literal_String);
--------------------
-- Model_Mantissa --
IEEEX_Model_Mantissa,
VAXFF_Model_Mantissa,
VAXDF_Model_Mantissa,
- VAXGF_Model_Mantissa);
+ VAXGF_Model_Mantissa,
+ AAMPS_Model_Mantissa,
+ AAMPL_Model_Mantissa);
-----------------
-- Model_Small --
IEEEX_Model_Small'Universal_Literal_String,
VAXFF_Model_Small'Universal_Literal_String,
VAXDF_Model_Small'Universal_Literal_String,
- VAXGF_Model_Small'Universal_Literal_String);
+ VAXGF_Model_Small'Universal_Literal_String,
+ AAMPS_Model_Small'Universal_Literal_String,
+ AAMPL_Model_Small'Universal_Literal_String);
-------------
-- Modulus --
-------------
when Attribute_Modulus =>
- Fold_Uint (N, Modulus (P_Type));
+ Fold_Uint (N, Modulus (P_Type), True);
--------------------
-- Null_Parameter --
begin
if Known_Esize (P_TypeA) then
- Fold_Uint (N, Esize (P_TypeA));
+ Fold_Uint (N, Esize (P_TypeA), True);
end if;
end Object_Size;
-- Scalar types are never passed by reference
when Attribute_Passed_By_Reference =>
- Fold_Uint (N, False_Value);
+ Fold_Uint (N, False_Value, True);
---------
-- Pos --
---------
when Attribute_Pos =>
- Fold_Uint (N, Expr_Value (E1));
+ Fold_Uint (N, Expr_Value (E1), True);
----------
-- Pred --
when Attribute_Pred => Pred :
begin
- if Static then
+ -- Floating-point case
- -- Floating-point case. For now, do not fold this, since we
- -- don't know how to do it right (see fixed bug 3512-001 ???)
-
- if Is_Floating_Point_Type (P_Type) then
- Fold_Ureal (N,
- Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)));
+ if Is_Floating_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static);
- -- Fixed-point case
+ -- Fixed-point case
- elsif Is_Fixed_Point_Type (P_Type) then
- Fold_Ureal (N,
- Expr_Value_R (E1) - Small_Value (P_Type));
+ elsif Is_Fixed_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Expr_Value_R (E1) - Small_Value (P_Type), True);
- -- Modular integer case (wraps)
+ -- Modular integer case (wraps)
- elsif Is_Modular_Integer_Type (P_Type) then
- Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type));
+ elsif Is_Modular_Integer_Type (P_Type) then
+ Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
- -- Other scalar cases
+ -- Other scalar cases
- else
- pragma Assert (Is_Scalar_Type (P_Type));
+ else
+ pragma Assert (Is_Scalar_Type (P_Type));
- if Is_Enumeration_Type (P_Type)
- and then Expr_Value (E1) =
- Expr_Value (Type_Low_Bound (P_Base_Type))
- then
- Apply_Compile_Time_Constraint_Error
- (N, "Pred of type''First");
- Check_Expressions;
- return;
- end if;
+ if Is_Enumeration_Type (P_Type)
+ and then Expr_Value (E1) =
+ Expr_Value (Type_Low_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Pred of `&''First`",
+ CE_Overflow_Check_Failed,
+ Ent => P_Base_Type,
+ Warn => not Static);
- Fold_Uint (N, Expr_Value (E1) - 1);
+ Check_Expressions;
+ return;
end if;
+
+ Fold_Uint (N, Expr_Value (E1) - 1, Static);
end if;
end Pred;
then
Fold_Uint (N,
UI_Max
- (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1));
+ (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
+ Static);
end if;
---------------
-- Remainder --
---------------
- when Attribute_Remainder =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Remainder
- (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
+ when Attribute_Remainder => Remainder : declare
+ X : constant Ureal := Expr_Value_R (E1);
+ Y : constant Ureal := Expr_Value_R (E2);
+
+ begin
+ if UR_Is_Zero (Y) then
+ Apply_Compile_Time_Constraint_Error
+ (N, "division by zero in Remainder",
+ CE_Overflow_Check_Failed,
+ Warn => not Static);
+
+ Check_Expressions;
+ return;
end if;
+ Fold_Ureal (N, Eval_Fat.Remainder (P_Root_Type, X, Y), Static);
+ end Remainder;
+
-----------
-- Round --
-----------
Si : Uint;
begin
- if Static then
- -- First we get the (exact result) in units of small
+ -- First we get the (exact result) in units of small
- Sr := Expr_Value_R (E1) / Small_Value (C_Type);
+ Sr := Expr_Value_R (E1) / Small_Value (C_Type);
- -- Now round that exactly to an integer
+ -- Now round that exactly to an integer
- Si := UR_To_Uint (Sr);
+ Si := UR_To_Uint (Sr);
- -- Finally the result is obtained by converting back to real
+ -- Finally the result is obtained by converting back to real
- Fold_Ureal (N, Si * Small_Value (C_Type));
- end if;
+ Fold_Ureal (N, Si * Small_Value (C_Type), Static);
end Round;
--------------
--------------
when Attribute_Rounding =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
---------------
-- Safe_Emax --
IEEEX_Safe_Emax,
VAXFF_Safe_Emax,
VAXDF_Safe_Emax,
- VAXGF_Safe_Emax);
+ VAXGF_Safe_Emax,
+ AAMPS_Safe_Emax,
+ AAMPL_Safe_Emax);
----------------
-- Safe_First --
IEEEX_Safe_First'Universal_Literal_String,
VAXFF_Safe_First'Universal_Literal_String,
VAXDF_Safe_First'Universal_Literal_String,
- VAXGF_Safe_First'Universal_Literal_String);
+ VAXGF_Safe_First'Universal_Literal_String,
+ AAMPS_Safe_First'Universal_Literal_String,
+ AAMPL_Safe_First'Universal_Literal_String);
----------------
-- Safe_Large --
when Attribute_Safe_Large =>
if Is_Fixed_Point_Type (P_Type) then
- Fold_Ureal (N, Expr_Value_R (Type_High_Bound (P_Base_Type)));
+ Fold_Ureal
+ (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
else
Float_Attribute_Universal_Real (
IEEES_Safe_Large'Universal_Literal_String,
IEEEX_Safe_Large'Universal_Literal_String,
VAXFF_Safe_Large'Universal_Literal_String,
VAXDF_Safe_Large'Universal_Literal_String,
- VAXGF_Safe_Large'Universal_Literal_String);
+ VAXGF_Safe_Large'Universal_Literal_String,
+ AAMPS_Safe_Large'Universal_Literal_String,
+ AAMPL_Safe_Large'Universal_Literal_String);
end if;
---------------
IEEEX_Safe_Last'Universal_Literal_String,
VAXFF_Safe_Last'Universal_Literal_String,
VAXDF_Safe_Last'Universal_Literal_String,
- VAXGF_Safe_Last'Universal_Literal_String);
+ VAXGF_Safe_Last'Universal_Literal_String,
+ AAMPS_Safe_Last'Universal_Literal_String,
+ AAMPL_Safe_Last'Universal_Literal_String);
----------------
-- Safe_Small --
-- it for backwards compatibility.
if Is_Fixed_Point_Type (P_Type) then
- Fold_Ureal (N, Small_Value (P_Type));
+ Fold_Ureal (N, Small_Value (P_Type), Static);
-- Ada 83 Safe_Small for floating-point cases
IEEEX_Safe_Small'Universal_Literal_String,
VAXFF_Safe_Small'Universal_Literal_String,
VAXDF_Safe_Small'Universal_Literal_String,
- VAXGF_Safe_Small'Universal_Literal_String);
+ VAXGF_Safe_Small'Universal_Literal_String,
+ AAMPS_Safe_Small'Universal_Literal_String,
+ AAMPL_Safe_Small'Universal_Literal_String);
end if;
-----------
-----------
when Attribute_Scale =>
- Fold_Uint (N, Scale_Value (P_Type));
+ Fold_Uint (N, Scale_Value (P_Type), True);
-------------
-- Scaling --
-------------
when Attribute_Scaling =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Scaling
- (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Scaling
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
------------------
-- Signed_Zeros --
when Attribute_Signed_Zeros =>
Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)));
+ (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static);
----------
-- Size --
-- VADS_Size case
- if (Id = Attribute_VADS_Size or else Use_VADS_Size) then
-
+ if Id = Attribute_VADS_Size or else Use_VADS_Size then
declare
S : constant Node_Id := Size_Clause (P_TypeA);
if Present (S)
and then Is_OK_Static_Expression (Expression (S))
then
- Fold_Uint (N, Expr_Value (Expression (S)));
+ Fold_Uint (N, Expr_Value (Expression (S)), True);
-- If no size is specified, then we simply use the object
-- size in the VADS_Size case (e.g. Natural'Size is equal
-- to Integer'Size, not one less).
else
- Fold_Uint (N, Esize (P_TypeA));
+ Fold_Uint (N, Esize (P_TypeA), True);
end if;
end;
-- Normal case (Size) in which case we want the RM_Size
else
- Fold_Uint (N, RM_Size (P_TypeA));
+ Fold_Uint (N,
+ RM_Size (P_TypeA),
+ Static and then Is_Discrete_Type (P_TypeA));
end if;
end if;
end Size;
when Attribute_Small =>
- -- The floating-point case is present only for Ada 83 compatibility.
+ -- The floating-point case is present only for Ada 83 compatability.
-- Note that strictly this is an illegal addition, since we are
-- extending an Ada 95 defined attribute, but we anticipate an
-- ARG ruling that will permit this.
-- T'Emax = 4 * T'Mantissa
- Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1));
+ Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
-- Normal Ada 95 fixed-point case
else
- Fold_Ureal (N, Small_Value (P_Type));
+ Fold_Ureal (N, Small_Value (P_Type), True);
end if;
+ -----------------
+ -- Stream_Size --
+ -----------------
+
+ when Attribute_Stream_Size =>
+ null;
+
----------
-- Succ --
----------
when Attribute_Succ => Succ :
begin
- if Static then
+ -- Floating-point case
- -- Floating-point case. For now, do not fold this, since we
- -- don't know how to do it right (see fixed bug 3512-001 ???)
+ if Is_Floating_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static);
- if Is_Floating_Point_Type (P_Type) then
- Fold_Ureal (N,
- Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)));
+ -- Fixed-point case
- -- Fixed-point case
+ elsif Is_Fixed_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Expr_Value_R (E1) + Small_Value (P_Type), Static);
- elsif Is_Fixed_Point_Type (P_Type) then
- Fold_Ureal (N,
- Expr_Value_R (E1) + Small_Value (P_Type));
+ -- Modular integer case (wraps)
- -- Modular integer case (wraps)
+ elsif Is_Modular_Integer_Type (P_Type) then
+ Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
- elsif Is_Modular_Integer_Type (P_Type) then
- Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type));
+ -- Other scalar cases
- -- Other scalar cases
+ else
+ pragma Assert (Is_Scalar_Type (P_Type));
- else
- pragma Assert (Is_Scalar_Type (P_Type));
+ if Is_Enumeration_Type (P_Type)
+ and then Expr_Value (E1) =
+ Expr_Value (Type_High_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Succ of `&''Last`",
+ CE_Overflow_Check_Failed,
+ Ent => P_Base_Type,
+ Warn => not Static);
- if Is_Enumeration_Type (P_Type)
- and then Expr_Value (E1) =
- Expr_Value (Type_High_Bound (P_Base_Type))
- then
- Apply_Compile_Time_Constraint_Error
- (N, "Succ of type''Last");
- Check_Expressions;
- return;
- else
- Fold_Uint (N, Expr_Value (E1) + 1);
- end if;
+ Check_Expressions;
+ return;
+ else
+ Fold_Uint (N, Expr_Value (E1) + 1, Static);
end if;
end if;
end Succ;
----------------
when Attribute_Truncation =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static);
----------------
-- Type_Class --
Id : RE_Id;
begin
- if Is_RTE (P_Root_Type, RE_Address) then
+ if Is_Descendent_Of_Address (Typ) then
Id := RE_Type_Class_Address;
elsif Is_Enumeration_Type (Typ) then
end if;
Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
-
end Type_Class;
-----------------------
-----------------------
when Attribute_Unbiased_Rounding =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)),
+ Static);
+
+ -------------------------
+ -- Unconstrained_Array --
+ -------------------------
+
+ when Attribute_Unconstrained_Array => Unconstrained_Array : declare
+ Typ : constant Entity_Id := Underlying_Type (P_Type);
+
+ begin
+ Rewrite (N, New_Occurrence_Of (
+ Boolean_Literals (
+ Is_Array_Type (P_Type)
+ and then not Is_Constrained (Typ)), Loc));
+
+ -- Analyze and resolve as boolean, note that this attribute is
+ -- a static attribute in GNAT.
+
+ Analyze_And_Resolve (N, Standard_Boolean);
+ Static := True;
+ end Unconstrained_Array;
---------------
-- VADS_Size --
when Attribute_Val => Val :
begin
- if Static then
- if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
- or else
- Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
- then
- Apply_Compile_Time_Constraint_Error
- (N, "Val expression out of range");
- Check_Expressions;
- return;
- else
- Fold_Uint (N, Expr_Value (E1));
- end if;
+ if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
+ or else
+ Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Val expression out of range",
+ CE_Range_Check_Failed,
+ Warn => not Static);
+
+ Check_Expressions;
+ return;
+
+ else
+ Fold_Uint (N, Expr_Value (E1), Static);
end if;
end Val;
when Attribute_Value_Size => Value_Size : declare
P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
-
begin
if RM_Size (P_TypeA) /= Uint_0 then
- Fold_Uint (N, RM_Size (P_TypeA));
+ Fold_Uint (N, RM_Size (P_TypeA), True);
end if;
-
end Value_Size;
-------------
when Attribute_Wide_Image =>
null;
+ ---------------------
+ -- Wide_Wide_Image --
+ ---------------------
+
+ -- Wide_Wide_Image is a scalar attribute but is never static, because it
+ -- is not a static function (having a non-scalar argument (RM 4.9(22)).
+
+ when Attribute_Wide_Wide_Image =>
+ null;
+
+ ---------------------
+ -- Wide_Wide_Width --
+ ---------------------
+
+ -- Processing for Wide_Wide_Width is combined with Width
+
----------------
-- Wide_Width --
----------------
-- Width --
-----------
- -- This processing also handles the case of Wide_Width
+ -- This processing also handles the case of Wide_[Wide_]Width
- when Attribute_Width | Attribute_Wide_Width => Width :
+ when Attribute_Width |
+ Attribute_Wide_Width |
+ Attribute_Wide_Wide_Width => Width :
begin
- if Static then
+ if Compile_Time_Known_Bounds (P_Type) then
-- Floating-point types
if Expr_Value_R (Type_High_Bound (P_Type)) <
Expr_Value_R (Type_Low_Bound (P_Type))
then
- Fold_Uint (N, Uint_0);
+ Fold_Uint (N, Uint_0, True);
else
-- For floating-point, we have +N.dddE+nnn where length
-- nnn is set to 2 for Short_Float and Float (32 bit
-- floats), and 3 for Long_Float and Long_Long_Float.
- -- This is not quite right, but is good enough.
+ -- For machines where Long_Long_Float is the IEEE
+ -- extended precision type, the exponent takes 4 digits.
declare
Len : Int :=
begin
if Esize (P_Type) <= 32 then
Len := Len + 6;
- else
+ elsif Esize (P_Type) = 64 then
Len := Len + 7;
+ else
+ Len := Len + 8;
end if;
- Fold_Uint (N, UI_From_Int (Len));
+ Fold_Uint (N, UI_From_Int (Len), True);
end;
end if;
if Expr_Value (Type_High_Bound (P_Type)) <
Expr_Value (Type_Low_Bound (P_Type))
then
- Fold_Uint (N, Uint_0);
+ Fold_Uint (N, Uint_0, True);
-- The non-null case depends on the specific real type
else
-- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
- Fold_Uint (N, UI_From_Int (Fore_Value + 1 + Aft_Value));
+ Fold_Uint
+ (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True);
end if;
-- Discrete types
W := 0;
-- Width for types derived from Standard.Character
- -- and Standard.Wide_Character.
+ -- and Standard.Wide_[Wide_]Character.
elsif R = Standard_Character
- or else R = Standard_Wide_Character
+ or else R = Standard_Wide_Character
+ or else R = Standard_Wide_Wide_Character
then
W := 0;
for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
- -- Assume all wide-character escape sequences are
- -- same length, so we can quit when we reach one.
+ -- All wide characters look like Hex_hhhhhhhh
if J > 255 then
- if Id = Attribute_Wide_Width then
- W := Int'Max (W, 3);
- exit;
- else
- W := Int'Max (W, Length_Wide);
- exit;
- end if;
+ W := 12;
else
C := Character'Val (J);
No_Break_Space .. LC_Y_Diaeresis
=> Wt := 3;
-
end case;
W := Int'Max (W, Wt);
Get_Decoded_Name_String (Chars (L));
Wt := Nat (Name_Len);
- -- For Wide_Width, use encoded name, and then
- -- adjust for the encoding.
+ -- For Wide_[Wide_]Width, use encoded name, and
+ -- then adjust for the encoding.
else
Get_Name_String (Chars (L));
end loop;
end if;
- Fold_Uint (N, UI_From_Int (W));
+ Fold_Uint (N, UI_From_Int (W), True);
end;
end if;
end if;
Attribute_Elaborated |
Attribute_Elab_Body |
Attribute_Elab_Spec |
+ Attribute_Enabled |
Attribute_External_Tag |
Attribute_First_Bit |
Attribute_Input |
Attribute_Last_Bit |
- Attribute_Max_Interrupt_Priority |
- Attribute_Max_Priority |
Attribute_Maximum_Alignment |
Attribute_Output |
Attribute_Partition_ID |
+ Attribute_Pool_Address |
Attribute_Position |
+ Attribute_Priority |
Attribute_Read |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |
+ Attribute_Stub_Type |
Attribute_Tag |
+ Attribute_Target_Name |
Attribute_Terminated |
- Attribute_Tick |
Attribute_To_Address |
Attribute_UET_Address |
Attribute_Unchecked_Access |
Attribute_Value |
Attribute_Wchar_T_Size |
Attribute_Wide_Value |
+ Attribute_Wide_Wide_Value |
Attribute_Word_Size |
Attribute_Write =>
raise Program_Error;
-
end case;
-- At the end of the case, one more check. If we did a static evaluation
-- in the constant only if the prefix type is a static subtype. For
-- non-static subtypes, the folding is still OK, but not static.
+ -- An exception is the GNAT attribute Constrained_Array which is
+ -- defined to be a static attribute in all cases.
+
if Nkind (N) = N_Integer_Literal
or else Nkind (N) = N_Real_Literal
or else Nkind (N) = N_Character_Literal
else
null;
end if;
-
end Eval_Attribute;
------------------------------
and then Associated_Node_For_Itype (Anon) = Parent (Typ);
end Is_Anonymous_Tagged_Base;
+ --------------------------------
+ -- Name_Implies_Lvalue_Prefix --
+ --------------------------------
+
+ function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is
+ pragma Assert (Is_Attribute_Name (Nam));
+ begin
+ return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam));
+ end Name_Implies_Lvalue_Prefix;
+
-----------------------
-- Resolve_Attribute --
-----------------------
P : constant Node_Id := Prefix (N);
Aname : constant Name_Id := Attribute_Name (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+ Btyp : constant Entity_Id := Base_Type (Typ);
+ Des_Btyp : Entity_Id;
Index : Interp_Index;
It : Interp;
- Btyp : Entity_Id := Base_Type (Typ);
Nom_Subt : Entity_Id;
+ procedure Accessibility_Message;
+ -- Error, or warning within an instance, if the static accessibility
+ -- rules of 3.10.2 are violated.
+
+ ---------------------------
+ -- Accessibility_Message --
+ ---------------------------
+
+ procedure Accessibility_Message is
+ Indic : Node_Id := Parent (Parent (N));
+
+ begin
+ -- In an instance, this is a runtime check, but one we
+ -- know will fail, so generate an appropriate warning.
+
+ if In_Instance_Body then
+ Error_Msg_F
+ ("?non-local pointer cannot point to local object", P);
+ 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);
+ return;
+
+ else
+ Error_Msg_F
+ ("non-local pointer cannot point to local object", P);
+
+ -- Check for case where we have a missing access definition
+
+ if Is_Record_Type (Current_Scope)
+ and then
+ (Nkind (Parent (N)) = N_Discriminant_Association
+ or else
+ Nkind (Parent (N)) = N_Index_Or_Discriminant_Constraint)
+ then
+ Indic := Parent (Parent (N));
+ while Present (Indic)
+ and then Nkind (Indic) /= N_Subtype_Indication
+ loop
+ Indic := Parent (Indic);
+ end loop;
+
+ if Present (Indic) then
+ Error_Msg_NE
+ ("\use an access definition for" &
+ " the access discriminant of&",
+ N, Entity (Subtype_Mark (Indic)));
+ end if;
+ end if;
+ end if;
+ end Accessibility_Message;
+
+ -- Start of processing for Resolve_Attribute
+
begin
-- If error during analysis, no point in continuing, except for
-- array types, where we get better recovery by using unconstrained
| Attribute_Unchecked_Access
| Attribute_Unrestricted_Access =>
+ Access_Attribute : begin
if Is_Variable (P) then
Note_Possible_Modification (P);
end if;
if Is_Entity_Name (P) then
-
if Is_Overloaded (P) then
Get_First_Interp (P, Index, It);
-
while Present (It.Nam) loop
-
if Type_Conformant (Designated_Type (Typ), It.Nam) then
Set_Entity (P, It.Nam);
- -- The prefix is definitely NOT overloaded anymore
- -- at this point, so we reset the Is_Overloaded
- -- flag to avoid any confusion when reanalyzing
- -- the node.
+ -- The prefix is definitely NOT overloaded anymore at
+ -- this point, so we reset the Is_Overloaded flag to
+ -- avoid any confusion when reanalyzing the node.
Set_Is_Overloaded (P, False);
+ Set_Is_Overloaded (N, False);
Generate_Reference (Entity (P), P);
exit;
end if;
Get_Next_Interp (Index, It);
end loop;
- -- If it is a subprogram name or a type, there is nothing
- -- to resolve.
+ -- If Prefix is a subprogram name, it is frozen by this
+ -- reference:
- elsif not Is_Overloadable (Entity (P))
- and then not Is_Type (Entity (P))
- then
- Resolve (P, Etype (P));
+ -- If it is a type, there is nothing to resolve.
+ -- If it is an object, complete its resolution.
+
+ elsif Is_Overloadable (Entity (P)) then
+ if not In_Default_Expression then
+ Insert_Actions (N, Freeze_Entity (Entity (P), Loc));
+ end if;
+
+ elsif Is_Type (Entity (P)) then
+ null;
+ else
+ Resolve (P);
end if;
+ Error_Msg_Name_1 := Aname;
+
if not Is_Entity_Name (P) then
null;
- elsif Is_Abstract (Entity (P))
- and then Is_Overloadable (Entity (P))
+ elsif Is_Overloadable (Entity (P))
+ and then Is_Abstract_Subprogram (Entity (P))
then
- Error_Msg_Name_1 := Aname;
- 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
- Error_Msg_Name_1 := Aname;
-
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;
-- also be accessibility checks on those, this is where the
-- checks can eventually be centralized ???
- if Ekind (Btyp) = E_Access_Subprogram_Type then
+ if Ekind (Btyp) = E_Access_Subprogram_Type
+ or else
+ Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
+ 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
null; -- Nothing to check
- -- Check the static accessibility rule of 3.10.2(32)
+ -- Check the static accessibility rule of 3.10.2(32).
+ -- This rule also applies within the private part of an
+ -- instantiation. This rule does not apply to anonymous
+ -- access-to-subprogram types (Ada 2005).
elsif Attr_Id = Attribute_Access
- and then Subprogram_Access_Level (Entity (P))
- > Type_Access_Level (Btyp)
+ and then not In_Instance_Body
+ and then Subprogram_Access_Level (Entity (P)) >
+ Type_Access_Level (Btyp)
+ and then Ekind (Btyp) /=
+ E_Anonymous_Access_Subprogram_Type
+ and then Ekind (Btyp) /=
+ E_Anonymous_Access_Protected_Subprogram_Type
then
- if not In_Instance_Body then
- Error_Msg_N
- ("subprogram must not be deeper than access type",
- P);
- else
- Warn_On_Instance := True;
- Error_Msg_N
- ("subprogram must not be deeper than access type?",
- P);
- Error_Msg_N
- ("Constraint_Error will be raised ?", P);
- Set_Raises_Constraint_Error (N);
- Warn_On_Instance := False;
- end if;
+ Error_Msg_F
+ ("subprogram must not be deeper than access type", P);
+
+ -- Check the restriction of 3.10.2(32) that disallows the
+ -- access attribute within a generic body when the ultimate
+ -- ancestor of the type of the attribute is declared outside
+ -- of the generic unit and the subprogram is declared within
+ -- that generic unit. This includes any such attribute that
+ -- occurs within the body of a generic unit that is a child
+ -- of the generic unit where the subprogram is declared.
+ -- The rule also prohibits applying the attibute when the
+ -- access type is a generic formal access type (since the
+ -- level of the actual type is not known). This restriction
+ -- does not apply when the attribute type is an anonymous
+ -- access-to-subprogram type. Note that this check was
+ -- revised by AI-229, because the originally Ada 95 rule
+ -- was too lax. The original rule only applied when the
+ -- subprogram was declared within the body of the generic,
+ -- which allowed the possibility of dangling references).
+ -- The rule was also too strict in some case, in that it
+ -- didn't permit the access to be declared in the generic
+ -- spec, whereas the revised rule does (as long as it's not
+ -- a formal type).
+
+ -- There are a couple of subtleties of the test for applying
+ -- the check that are worth noting. First, we only apply it
+ -- when the levels of the subprogram and access type are the
+ -- same (the case where the subprogram is statically deeper
+ -- was applied above, and the case where the type is deeper
+ -- is always safe). Second, we want the check to apply
+ -- within nested generic bodies and generic child unit
+ -- bodies, but not to apply to an attribute that appears in
+ -- the generic unit's specification. This is done by testing
+ -- that the attribute's innermost enclosing generic body is
+ -- not the same as the innermost generic body enclosing the
+ -- generic unit where the subprogram is declared (we don't
+ -- 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.
- -- Check the restriction of 3.10.2(32) that disallows
- -- the type of the access attribute to be declared
- -- outside a generic body when the attribute occurs
- -- within that generic body.
-
- elsif Enclosing_Generic_Body (Entity (P))
- /= Enclosing_Generic_Body (Btyp)
+ elsif Attr_Id = Attribute_Access
+ and then not In_Instance
+ and then Present (Enclosing_Generic_Unit (Entity (P)))
+ and then Present (Enclosing_Generic_Body (N))
+ and then Enclosing_Generic_Body (N) /=
+ Enclosing_Generic_Body
+ (Enclosing_Generic_Unit (Entity (P)))
+ and then Subprogram_Access_Level (Entity (P)) =
+ Type_Access_Level (Btyp)
+ and then Ekind (Btyp) /=
+ E_Anonymous_Access_Subprogram_Type
+ and then Ekind (Btyp) /=
+ E_Anonymous_Access_Protected_Subprogram_Type
then
- Error_Msg_N
- ("access type must not be outside generic body", P);
+ -- The attribute type's ultimate ancestor must be
+ -- declared within the same generic unit as the
+ -- subprogram is declared. The error message is
+ -- specialized to say "ancestor" for the case where
+ -- the access type is not its own ancestor, since
+ -- saying simply "access type" would be very confusing.
+
+ if Enclosing_Generic_Unit (Entity (P)) /=
+ Enclosing_Generic_Unit (Root_Type (Btyp))
+ then
+ Error_Msg_N
+ ("''Access attribute not allowed in generic body",
+ N);
+
+ if Root_Type (Btyp) = Btyp then
+ Error_Msg_NE
+ ("\because " &
+ "access type & is declared outside " &
+ "generic unit (RM 3.10.2(32))", N, Btyp);
+ else
+ Error_Msg_NE
+ ("\because ancestor of " &
+ "access type & is declared outside " &
+ "generic unit (RM 3.10.2(32))", N, Btyp);
+ end if;
+
+ Error_Msg_NE
+ ("\move ''Access to private part, or " &
+ "(Ada 2005) use anonymous access type instead of &",
+ N, Btyp);
+
+ -- If the ultimate ancestor of the attribute's type is
+ -- a formal type, then the attribute is illegal because
+ -- the actual type might be declared at a higher level.
+ -- The error message is specialized to say "ancestor"
+ -- for the case where the access type is not its own
+ -- ancestor, since saying simply "access type" would be
+ -- very confusing.
+
+ elsif Is_Generic_Type (Root_Type (Btyp)) then
+ if Root_Type (Btyp) = Btyp then
+ Error_Msg_N
+ ("access type must not be a generic formal type",
+ N);
+ else
+ Error_Msg_N
+ ("ancestor access type must not be a generic " &
+ "formal type", N);
+ end if;
+ end if;
end if;
end if;
- -- if this is a renaming, an inherited operation, or a
- -- subprogram instance, use the original entity.
+ -- If this is a renaming, an inherited operation, or a
+ -- subprogram instance, use the original entity. This may make
+ -- the node type-inconsistent, so this transformation can only
+ -- be done if the node will not be reanalyzed. In particular,
+ -- if it is within a default expression, the transformation
+ -- must be delayed until the default subprogram is created for
+ -- it, when the enclosing subprogram is frozen.
if Is_Entity_Name (P)
and then Is_Overloadable (Entity (P))
and then Present (Alias (Entity (P)))
+ and then Expander_Active
then
Rewrite (P,
New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
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 (Prefix (P), Etype (Prefix (P)));
+ Resolve (Prefix (P));
+ Generate_Reference (Entity (Selector_Name (P)), P);
elsif Is_Overloaded (P) then
- -- Use the designated type of the context to disambiguate.
+ -- Use the designated type of the context to disambiguate
+ -- Note that this was not strictly conformant to Ada 95,
+ -- but was the implementation adopted by most Ada 95 compilers.
+ -- The use of the context type to resolve an Access attribute
+ -- reference is now mandated in AI-235 for Ada 2005.
+
declare
Index : Interp_Index;
It : Interp;
+
begin
Get_First_Interp (P, Index, It);
-
while Present (It.Typ) loop
if Covers (Designated_Type (Typ), It.Typ) then
Resolve (P, It.Typ);
end loop;
end;
else
- Resolve (P, Etype (P));
+ 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.
+ -- 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 (Is_Record_Type (Btyp) and then
- Present (Corresponding_Remote_Type (Btyp)))
+ or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
+ 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
or else Is_Access_Constant (Btyp)
or else Is_Variable (P)
or else Attr_Id = Attribute_Unrestricted_Access)
then
- if Comes_From_Source (N) then
- Error_Msg_N ("access-to-variable designates constant", P);
+ if Is_Entity_Name (P)
+ and then Is_Type (Entity (P))
+ then
+ -- Legality of a self-reference through an access
+ -- attribute has been verified in Analyze_Access_Attribute.
+
+ null;
+
+ elsif Comes_From_Source (N) then
+ Error_Msg_F ("access-to-variable designates constant", P);
end if;
end if;
or else
Attr_Id = Attribute_Unchecked_Access)
and then (Ekind (Btyp) = E_General_Access_Type
- or else Ekind (Btyp) = E_Anonymous_Access_Type)
+ or else Ekind (Btyp) = E_Anonymous_Access_Type)
then
+ -- Ada 2005 (AI-230): Check the accessibility of anonymous
+ -- 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)
+ and then Object_Access_Level (P) > Type_Access_Level (Btyp)
+ and then Attr_Id = Attribute_Access
+ then
+ -- In an instance, this is a runtime check, but one we
+ -- know will fail, so generate an appropriate warning.
+
+ if In_Instance_Body then
+ Error_Msg_F
+ ("?non-local pointer cannot point to local object", P);
+ 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_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;
- -- Check the static matching rule of 3.10.2(27). The
- -- nominal subtype of the prefix must statically
- -- match the designated type.
+ -- Check static matching rule of 3.10.2(27). Nominal subtype
+ -- of the prefix must statically match the designated type.
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);
+
+ if Ekind (Des_Btyp) = E_Incomplete_Subtype then
+
+ -- Ada 2005 (AI-412): Subtypes of incomplete types visible
+ -- through a limited with clause or regular incomplete
+ -- subtypes.
+
+ if From_With_Type (Des_Btyp)
+ and then Present (Non_Limited_View (Des_Btyp))
+ then
+ Des_Btyp := Non_Limited_View (Des_Btyp);
+ else
+ Des_Btyp := Etype (Des_Btyp);
+ end if;
end if;
if Is_Tagged_Type (Designated_Type (Typ)) then
-- If the attribute is in the context of an access
- -- parameter, then the prefix is allowed to be of
- -- the class-wide type (by AI-127).
+ -- parameter, then the prefix is allowed to be of the
+ -- class-wide type (by AI-127).
if Ekind (Typ) = E_Anonymous_Access_Type then
if not Covers (Designated_Type (Typ), Nom_Subt)
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));
+ " (RM 3.10.2 (27))", P, Designated_Type (Typ));
end if;
if Is_Class_Wide_Type (Designated_Type (Typ))
(N, Etype (Designated_Type (Typ)));
end if;
- elsif not Subtypes_Statically_Match
- (Designated_Type (Typ), Nom_Subt)
+ -- Ada 2005 (AI-363): Require static matching when designated
+ -- type has discriminants and a constrained partial view, since
+ -- in general objects of such types are mutable, so we can't
+ -- allow the access value to designate a constrained object
+ -- (because access values must be assumed to designate mutable
+ -- objects when designated type does not impose a constraint).
+
+ elsif not Subtypes_Statically_Match (Des_Btyp, Nom_Subt)
and then
not (Has_Discriminants (Designated_Type (Typ))
- and then not Is_Constrained (Designated_Type (Typ)))
+ and then not Is_Constrained (Des_Btyp)
+ and then
+ (Ada_Version < Ada_05
+ or else
+ 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 Is_Array_Type (Designated_Type (Typ))
then
-
declare
D : constant Node_Id := Declaration_Node (Entity (P));
and then Object_Access_Level (P) > Type_Access_Level (Btyp)
and then Ekind (Btyp) = E_General_Access_Type
then
- -- In an instance, this is a runtime check, but one we
- -- know will fail, so generate an appropriate warning.
-
- if In_Instance_Body then
- Error_Msg_N
- ("?non-local pointer cannot point to local object", P);
- Error_Msg_N
- ("?Program_Error will be raised at run time", P);
- Rewrite (N, Make_Raise_Program_Error (Loc));
- Set_Etype (N, Typ);
- return;
-
- else
- Error_Msg_N
- ("non-local pointer cannot point to local object", P);
-
- if Is_Record_Type (Current_Scope)
- and then (Nkind (Parent (N)) =
- N_Discriminant_Association
- or else
- Nkind (Parent (N)) =
- N_Index_Or_Discriminant_Constraint)
- then
- declare
- Indic : Node_Id := Parent (Parent (N));
-
- begin
- while Present (Indic)
- and then Nkind (Indic) /= N_Subtype_Indication
- loop
- Indic := Parent (Indic);
- end loop;
-
- if Present (Indic) then
- Error_Msg_NE
- ("\use an access definition for" &
- " the access discriminant of&", N,
- Entity (Subtype_Mark (Indic)));
- end if;
- end;
- end if;
- end if;
+ Accessibility_Message;
+ return;
end if;
end if;
if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
- and then Is_Entity_Name (P)
- and then not Is_Protected_Type (Scope (Entity (P)))
+ or else
+ Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
then
- Error_Msg_N ("context requires a protected subprogram", P);
+ if Is_Entity_Name (P)
+ and then not Is_Protected_Type (Scope (Entity (P)))
+ then
+ 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 entirely for 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;
+ end if;
- elsif Ekind (Btyp) = E_Access_Subprogram_Type
+ elsif (Ekind (Btyp) = E_Access_Subprogram_Type
+ or else
+ 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;
end if;
+ if Is_Entity_Name (P) then
+ Set_Address_Taken (Entity (P));
+ end if;
+ end Access_Attribute;
+
-------------
-- Address --
-------------
-- is not permitted here, since there is no context to resolve it.
when Attribute_Address | Attribute_Code_Address =>
+ Address_Attribute : begin
-- To be safe, assume that if the address of a variable is taken,
-- it may be modified via this address, so note modification.
Note_Possible_Modification (P);
end if;
- if Nkind (P) in N_Subexpr
+ if Nkind (P) in N_Subexpr
and then Is_Overloaded (P)
then
Get_First_Interp (P, Index, It);
if Present (It.Nam) then
Error_Msg_Name_1 := Aname;
- Error_Msg_N
- ("prefix of % attribute cannot be overloaded", N);
- return;
+ Error_Msg_F
+ ("prefix of % attribute cannot be overloaded", P);
end if;
end if;
if not Is_Entity_Name (P)
- or else not Is_Overloadable (Entity (P))
+ or else not Is_Overloadable (Entity (P))
then
if not Is_Task_Type (Etype (P))
or else Nkind (P) = N_Explicit_Dereference
then
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
end if;
New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
end if;
+ if Is_Entity_Name (P) then
+ Set_Address_Taken (Entity (P));
+ end if;
+ end Address_Attribute;
+
---------------
-- AST_Entry --
---------------
-- Count --
-----------
- -- Prefix of the Count attribute is an entry name which must not
- -- be resolved, since this is definitely not an entry call.
+ -- If the prefix of the Count attribute is an entry name it must not
+ -- be resolved, since this is definitely not an entry call. However,
+ -- if it is an element of an entry family, the index itself may
+ -- have to be resolved because it can be a general expression.
when Attribute_Count =>
- null;
+ if Nkind (P) = N_Indexed_Component
+ and then Is_Entity_Name (Prefix (P))
+ then
+ declare
+ Indx : constant Node_Id := First (Expressions (P));
+ Fam : constant Entity_Id := Entity (Prefix (P));
+ begin
+ Resolve (Indx, Entry_Index_Type (Fam));
+ Apply_Range_Check (Indx, Entry_Index_Type (Fam));
+ end;
+ end if;
----------------
-- Elaborated --
when Attribute_Elaborated =>
null;
+ -------------
+ -- Enabled --
+ -------------
+
+ -- Prefix of Enabled attribute is a check name, which must be treated
+ -- specially and not touched by Resolve.
+
+ when Attribute_Enabled =>
+ null;
+
--------------------
-- Mechanism_Code --
--------------------
Process_Partition_Id (N);
return;
+ ------------------
+ -- Pool_Address --
+ ------------------
+
+ when Attribute_Pool_Address =>
+ Resolve (P);
+
-----------
-- Range --
-----------
-- explicit. This solves some complex visibility problems
-- related to the use of privals.
+ --------------------------------
+ -- Check_Discriminated_Prival --
+ --------------------------------
+
function Check_Discriminated_Prival
(N : Node_Id)
return Node_Id
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
then
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
-- Check whether prefix is (renaming of) private component
Ekind (Scope (Scope (Entity (P)))) =
E_Protected_Type)
then
- LB := Check_Discriminated_Prival (
- Type_Low_Bound (Etype (First_Index (Etype (P)))));
+ LB :=
+ Check_Discriminated_Prival
+ (Type_Low_Bound (Etype (First_Index (Etype (P)))));
- HB := Check_Discriminated_Prival (
- Type_High_Bound (Etype (First_Index (Etype (P)))));
+ HB :=
+ Check_Discriminated_Prival
+ (Type_High_Bound (Etype (First_Index (Etype (P)))));
else
HB :=
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
then
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
-- If the attribute reference itself is a type name ('Base,
when Attribute_Wide_Value =>
Resolve (First (Expressions (N)), Standard_Wide_String);
+ when Attribute_Wide_Wide_Value =>
+ Resolve (First (Expressions (N)), Standard_Wide_Wide_String);
+
when others => null;
end case;
+
+ -- If the prefix of the attribute is a class-wide type then it
+ -- will be expanded into a dispatching call to a predefined
+ -- primitive. Therefore we must check for potential violation
+ -- of such restriction.
+
+ if Is_Class_Wide_Type (Etype (P)) then
+ Check_Restriction (No_Dispatching_Calls, N);
+ end if;
end case;
-- Normally the Freezing is done by Resolve but sometimes the Prefix
-- Finally perform static evaluation on the attribute reference
Eval_Attribute (N);
-
end Resolve_Attribute;
+ --------------------------------
+ -- Stream_Attribute_Available --
+ --------------------------------
+
+ function Stream_Attribute_Available
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type;
+ Partial_View : Node_Id := Empty) return Boolean
+ is
+ Etyp : Entity_Id := Typ;
+
+ -- Start of processing for Stream_Attribute_Available
+
+ begin
+ -- We need some comments in this body ???
+
+ if Has_Stream_Attribute_Definition (Typ, Nam) then
+ return True;
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ return not Is_Limited_Type (Typ)
+ or else Stream_Attribute_Available (Etype (Typ), Nam);
+ end if;
+
+ if Nam = TSS_Stream_Input
+ and then Is_Abstract_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ then
+ return False;
+ end if;
+
+ if not (Is_Limited_Type (Typ)
+ or else (Present (Partial_View)
+ and then Is_Limited_Type (Partial_View)))
+ then
+ return True;
+ end if;
+
+ -- In Ada 2005, Input can invoke Read, and Output can invoke Write
+
+ if Nam = TSS_Stream_Input
+ and then Ada_Version >= Ada_05
+ and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
+ then
+ return True;
+
+ elsif Nam = TSS_Stream_Output
+ and then Ada_Version >= Ada_05
+ and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
+ then
+ return True;
+ end if;
+
+ -- Case of Read and Write: check for attribute definition clause that
+ -- applies to an ancestor type.
+
+ while Etype (Etyp) /= Etyp loop
+ Etyp := Etype (Etyp);
+
+ if Has_Stream_Attribute_Definition (Etyp, Nam) then
+ return True;
+ end if;
+ end loop;
+
+ if Ada_Version < Ada_05 then
+
+ -- In Ada 95 mode, also consider a non-visible definition
+
+ declare
+ Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
+ begin
+ return Btyp /= Typ
+ and then Stream_Attribute_Available
+ (Btyp, Nam, Partial_View => Typ);
+ end;
+ end if;
+
+ return False;
+ end Stream_Attribute_Available;
+
end Sem_Attr;
OSDN Git Service
