-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Freeze; use Freeze;
+with Gnatvsn; use Gnatvsn;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Rtsfind; use Rtsfind;
with Sdefault; use Sdefault;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch10; use Sem_Ch10;
with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
procedure Check_Dereference;
-- If the prefix of attribute is an object of an access type, then
- -- introduce an explicit deference, and adjust P_Type accordingly.
+ -- introduce an explicit dereference, and adjust P_Type accordingly.
procedure Check_Discrete_Type;
-- Verify that prefix of attribute N is a discrete type
-- corresponding possible defined attribute function (e.g. for the
-- Read attribute, Nam will be TSS_Stream_Read).
+ procedure Check_PolyORB_Attribute;
+ -- Validity checking for PolyORB/DSA attribute
+
procedure Check_Task_Prefix;
-- Verify that prefix of attribute N is a task or task type
-- 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.
+ -- tracked value. If the scope is a loop or block, indicate that
+ -- value tracking is disabled for the enclosing subprogram.
function Get_Kind (E : Entity_Id) return Entity_Kind;
-- Distinguish between access to regular/protected subprograms
begin
if not Is_Library_Level_Entity (E) then
Set_Suppress_Value_Tracking_On_Call (Current_Scope);
+ Set_Suppress_Value_Tracking_On_Call
+ (Nearest_Dynamic_Scope (Current_Scope));
end if;
end Check_Local_Access;
Error_Attr ("attribute% cannot be applied to a subprogram", P);
end if;
+ -- Issue an error if the prefix denotes an eliminated subprogram
+
+ Check_For_Eliminated_Subprogram (P, Entity (P));
+
-- Build the appropriate subprogram type
Build_Access_Subprogram_Type (P);
end loop;
if Present (Q) then
- Set_Has_Per_Object_Constraint (
- Defining_Identifier (Q), True);
+ Set_Has_Per_Object_Constraint
+ (Defining_Identifier (Q), True);
end if;
end;
then
null;
+ -- OK if reference to current instance of a protected object
+
+ elsif Is_Protected_Self_Reference (P) then
+ null;
+
-- Otherwise we have an error case
else
-- 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));
+ -- As done elsewhere, freezing must not happen when pre-analyzing
+ -- a pre- or postcondition or a default value for an object or
+ -- for a formal parameter.
+
+ if not In_Spec_Expression then
+ Freeze_Before (N, Designated_Type (P_Type));
+ end if;
Rewrite (P,
Make_Explicit_Dereference (Sloc (P),
E := Prefix (E);
end loop;
- if From_With_Type (Etype (E)) then
+ Typ := Etype (E);
+
+ if From_With_Type (Typ) 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);
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ -- A legal use of a shadow entity occurs only when the unit
+ -- where the non-limited view resides is imported via a regular
+ -- with clause in the current body. Such references to shadow
+ -- entities may occur in subprogram formals.
+
+ if Is_Incomplete_Type (Typ)
+ and then From_With_Type (Typ)
+ and then Present (Non_Limited_View (Typ))
+ and then Is_Legal_Shadow_Entity_In_Body (Typ)
+ then
+ Typ := Non_Limited_View (Typ);
end if;
if Ekind (Typ) = E_Incomplete_Type
end if;
end Check_Object_Reference;
+ ----------------------------
+ -- Check_PolyORB_Attribute --
+ ----------------------------
+
+ procedure Check_PolyORB_Attribute is
+ begin
+ Validate_Non_Static_Attribute_Function_Call;
+
+ Check_Type;
+ Check_Not_CPP_Type;
+
+ if Get_PCS_Name /= Name_PolyORB_DSA then
+ Error_Attr
+ ("attribute% requires the 'Poly'O'R'B 'P'C'S", N);
+ end if;
+ end Check_PolyORB_Attribute;
+
------------------------
-- Check_Program_Unit --
------------------------
end if;
end if;
- -- Check for violation of restriction No_Stream_Attributes
+ -- Check restriction violations
+
+ -- First check the No_Streams restriction, which prohibits the use
+ -- of explicit stream attributes in the source program. We do not
+ -- prevent the occurrence of stream attributes in generated code,
+ -- for instance those generated implicitly for dispatching purposes.
+
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Streams, P);
+ end if;
+
+ -- Check special case of Exception_Id and Exception_Occurrence which
+ -- are not allowed for restriction No_Exception_Regstriation.
if Is_RTE (P_Type, RE_Exception_Id)
or else
then
Error_Attr_P ("prefix of % attribute must be a type");
+ elsif Is_Protected_Self_Reference (P) then
+ Error_Attr_P
+ ("prefix of % attribute denotes current instance "
+ & "(RM 9.4(21/2))");
+
elsif Ekind (Entity (P)) = E_Incomplete_Type
and then Present (Full_View (Entity (P)))
then
and then Aname /= Name_Address
and then Aname /= Name_Code_Address
and then Aname /= Name_Count
+ and then Aname /= Name_Result
and then Aname /= Name_Unchecked_Access
then
Error_Attr ("ambiguous prefix for % attribute", P);
-- entry wrappers, the attributes Count, Caller and AST_Entry require
-- a context check
- if Aname = Name_Count
- or else Aname = Name_Caller
- or else Aname = Name_AST_Entry
+ if Ada_Version >= Ada_05
+ and then (Aname = Name_Count
+ or else Aname = Name_Caller
+ or else Aname = Name_AST_Entry)
then
declare
Count : Natural := 0;
-- 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_Protected_Self_Reference (P) then
+
+ -- Address attribute on a protected object self reference is legal
+
+ null;
+
+ elsif Is_Entity_Name (P) then
declare
Ent : constant Entity_Id := Entity (P);
Error_Attr_P
("prefix of % attribute cannot be Inline_Always" &
" subprogram");
+
+ -- It is illegal to apply 'Address to an intrinsic
+ -- subprogram. This is now formalized in AI05-0095.
+ -- In an instance, an attempt to obtain 'Address of an
+ -- intrinsic subprogram (e.g the renaming of a predefined
+ -- operator that is an actual) raises Program_Error.
+
+ elsif Convention (Ent) = Convention_Intrinsic then
+ if In_Instance then
+ Rewrite (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Address_Of_Intrinsic));
+
+ else
+ Error_Msg_N
+ ("cannot take Address of intrinsic subprogram", N);
+ end if;
+
+ -- Issue an error if prefix denotes an eliminated subprogram
+
+ else
+ Check_For_Eliminated_Subprogram (P, Ent);
end if;
elsif Is_Object (Ent)
then
Error_Attr ("invalid prefix for % attribute", P);
Set_Address_Taken (Entity (P));
+
+ -- Issue an error if the prefix denotes an eliminated subprogram
+
+ else
+ Check_For_Eliminated_Subprogram (P, Entity (P));
end if;
Set_Etype (N, RTE (RE_Address));
+ ----------------------
+ -- Compiler_Version --
+ ----------------------
+
+ when Attribute_Compiler_Version =>
+ Check_E0;
+ Check_Standard_Prefix;
+ Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
+ Analyze_And_Resolve (N, Standard_String);
+
--------------------
-- Component_Size --
--------------------
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
+ --------------
+ -- From_Any --
+ --------------
+
+ when Attribute_From_Any =>
+ Check_E1;
+ Check_PolyORB_Attribute;
+ Set_Etype (N, P_Base_Type);
+
-----------------------
-- Has_Access_Values --
-----------------------
------------
when Attribute_Result => Result : declare
- CS : constant Entity_Id := Current_Scope;
- PS : constant Entity_Id := Scope (CS);
+ CS : Entity_Id := Current_Scope;
+ PS : Entity_Id := Scope (CS);
begin
+ -- If the enclosing subprogram is always inlined, the enclosing
+ -- postcondition will not be propagated to the expanded call.
+
+ if Has_Pragma_Inline_Always (PS)
+ and then Warn_On_Redundant_Constructs
+ then
+ Error_Msg_N
+ ("postconditions on inlined functions not enforced?", N);
+ end if;
+
-- If we are in the scope of a function and in Spec_Expression mode,
-- this is likely the prescan of the postcondition pragma, and we
-- just set the proper type. If there is an error it will be caught
end if;
-- Body case, where we must be inside a generated _Postcondition
- -- procedure, or the attribute use is definitely misplaced.
+ -- procedure, and the prefix must be on the scope stack, or else
+ -- the attribute use is definitely misplaced. The condition itself
+ -- may have generated transient scopes, and is not necessarily the
+ -- current one.
- elsif Chars (CS) = Name_uPostconditions
- and then Ekind (PS) = E_Function
- then
- -- Check OK prefix
+ else
+ while Present (CS)
+ and then CS /= Standard_Standard
+ loop
+ if Chars (CS) = Name_uPostconditions then
+ exit;
+ else
+ CS := Scope (CS);
+ end if;
+ end loop;
- if Nkind (P) /= N_Identifier
- or else Chars (P) /= Chars (PS)
+ PS := Scope (CS);
+
+ if Chars (CS) = Name_uPostconditions
+ and then Ekind (PS) = E_Function
then
- Error_Msg_NE
- ("incorrect prefix for % attribute, expected &", P, PS);
- Error_Attr;
- end if;
+ -- Check OK prefix
- Rewrite (N,
- Make_Identifier (Sloc (N),
- Chars => Name_uResult));
- Analyze_And_Resolve (N, Etype (PS));
+ if Nkind_In (P, N_Identifier, N_Operator_Symbol)
+ and then Chars (P) = Chars (PS)
+ then
+ null;
- else
- Error_Attr
- ("% attribute can only appear in function Postcondition pragma",
- P);
+ -- Within an instance, the prefix designates the local renaming
+ -- of the original generic.
+
+ elsif Is_Entity_Name (P)
+ and then Ekind (Entity (P)) = E_Function
+ and then Present (Alias (Entity (P)))
+ and then Chars (Alias (Entity (P))) = Chars (PS)
+ then
+ null;
+
+ else
+ Error_Msg_NE
+ ("incorrect prefix for % attribute, expected &", P, PS);
+ Error_Attr;
+ end if;
+
+ Rewrite (N,
+ Make_Identifier (Sloc (N),
+ Chars => Name_uResult));
+ Analyze_And_Resolve (N, Etype (PS));
+
+ else
+ Error_Attr
+ ("% attribute can only appear" &
+ " in function Postcondition pragma", P);
+ end if;
end if;
end Result;
Analyze_And_Resolve (E1, Any_Integer);
Set_Etype (N, RTE (RE_Address));
+ ------------
+ -- To_Any --
+ ------------
+
+ when Attribute_To_Any =>
+ Check_E1;
+ Check_PolyORB_Attribute;
+ Set_Etype (N, RTE (RE_Any));
+
----------------
-- Truncation --
----------------
Check_Not_Incomplete_Type;
Set_Etype (N, RTE (RE_Type_Class));
+ --------------
+ -- TypeCode --
+ --------------
+
+ when Attribute_TypeCode =>
+ Check_E0;
+ Check_PolyORB_Attribute;
+ Set_Etype (N, RTE (RE_TypeCode));
+
-----------------
-- UET_Address --
-----------------
-- Check that result is in bounds of the type if it is static
- if Is_In_Range (N, T) then
+ if Is_In_Range (N, T, Assume_Valid => False) then
null;
elsif Is_Out_Of_Range (N, T) then
if Present (AS) and then Is_Constrained (AS) then
P_Entity := AS;
- -- If we have an unconstrained type, cannot fold
+ -- If we have an unconstrained type we cannot fold
else
Check_Expressions;
-- Again we compute the variable Static for easy reference later
-- (note that no array attributes are static in Ada 83).
+ -- We also need to set Static properly for subsequent legality checks
+ -- which might otherwise accept non-static constants in contexts
+ -- where they are not legal.
+
Static := Ada_Version >= Ada_95
and then Statically_Denotes_Entity (P);
begin
N := First_Index (P_Type);
+
+ -- The expression is static if the array type is constrained
+ -- by given bounds, and not by an initial expression. Constant
+ -- strings are static in any case.
+
+ if Root_Type (P_Type) /= Standard_String then
+ Static :=
+ Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
+ end if;
+
while Present (N) loop
Static := Static and then Is_Static_Subtype (Etype (N));
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.
+ -- In the case of a generic index type, the bounds may appear static
+ -- but the computation is not meaningful in this case, and may
+ -- generate a spurious warning.
Ind := First_Index (P_Type);
-
while Present (Ind) loop
if Is_Generic_Type (Etype (Ind)) then
return;
Set_Bounds;
+ -- For two compile time values, we can compute length
+
if Compile_Time_Known_Value (Lo_Bound)
and then Compile_Time_Known_Value (Hi_Bound)
then
UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
True);
end if;
+
+ -- One more case is where Hi_Bound and Lo_Bound are compile-time
+ -- comparable, and we can figure out the difference between them.
+
+ declare
+ Diff : aliased Uint;
+
+ begin
+ case
+ Compile_Time_Compare
+ (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
+ is
+ when EQ =>
+ Fold_Uint (N, Uint_1, False);
+
+ when GT =>
+ Fold_Uint (N, Uint_0, False);
+
+ when LT =>
+ if Diff /= No_Uint then
+ Fold_Uint (N, Diff + 1, False);
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end;
end Length;
-------------
when Attribute_Range_Length =>
Set_Bounds;
+ -- Can fold if both bounds are compile time known
+
if Compile_Time_Known_Value (Hi_Bound)
and then Compile_Time_Known_Value (Lo_Bound)
then
Static);
end if;
+ -- One more case is where Hi_Bound and Lo_Bound are compile-time
+ -- comparable, and we can figure out the difference between them.
+
+ declare
+ Diff : aliased Uint;
+
+ begin
+ case
+ Compile_Time_Compare
+ (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
+ is
+ when EQ =>
+ Fold_Uint (N, Uint_1, False);
+
+ when GT =>
+ Fold_Uint (N, Uint_0, False);
+
+ when LT =>
+ if Diff /= No_Uint then
+ Fold_Uint (N, Diff + 1, False);
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end;
+
---------------
-- Remainder --
---------------
end if;
end Width;
+ -- The following attributes denote function that cannot be folded
+
+ when Attribute_From_Any |
+ Attribute_To_Any |
+ Attribute_TypeCode =>
+ null;
+
-- The following attributes can never be folded, and furthermore we
-- should not even have entered the case statement for any of these.
-- Note that in some cases, the values have already been folded as
Attribute_Caller |
Attribute_Class |
Attribute_Code_Address |
+ Attribute_Compiler_Version |
Attribute_Count |
Attribute_Default_Bit_Order |
Attribute_Elaborated |
Note_Possible_Modification (P, Sure => False);
end if;
+ -- The following comes from a query by Adam Beneschan, concerning
+ -- improper use of universal_access in equality tests involving
+ -- anonymous access types. Another good reason for 'Ref, but
+ -- for now disable the test, which breaks several filed tests.
+
+ if Ekind (Typ) = E_Anonymous_Access_Type
+ and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
+ and then False
+ then
+ Error_Msg_N ("need unique type to resolve 'Access", N);
+ Error_Msg_N ("\qualify attribute with some access type", N);
+ end if;
+
if Is_Entity_Name (P) then
if Is_Overloaded (P) then
Get_First_Interp (P, Index, It);
-- 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).
+ -- access-to-subprogram types in access parameters.
elsif Attr_Id = Attribute_Access
and then not In_Instance_Body
+ and then
+ (Ekind (Btyp) = E_Access_Subprogram_Type
+ or else Is_Local_Anonymous_Access (Btyp))
+
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_F
("subprogram must not be deeper than access type", P);
OSDN Git Service
