-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 Nlists; use Nlists;
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;
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;
Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Machine_Rounding |
+ Attribute_Mod |
Attribute_Priority |
Attribute_Stream_Size |
Attribute_Wide_Wide_Width => True,
-- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
-- Internally, Id distinguishes which of the three cases is involved.
+ procedure Bad_Attribute_For_Predicate;
+ -- Output error message for use of a predicate (First, Last, Range) not
+ -- allowed with a type that has predicates. If the type is a generic
+ -- actual, then the message is a warning, and we generate code to raise
+ -- program error with an appropriate reason. No error message is given
+ -- for internally generated uses of the attributes.
+
procedure Check_Array_Or_Scalar_Type;
-- Common procedure used by First, Last, Range attribute to check
-- that the prefix is a constrained array or scalar type, or a name
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
procedure Check_Enum_Image;
-- If the prefix type is an enumeration type, set all its literals
-- as referenced, since the image function could possibly end up
- -- referencing any of the literals indirectly.
+ -- referencing any of the literals indirectly. Same for Enum_Val.
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, Has_Access_Values,
- -- and Has_Discriminants
+ -- Common processing for attributes Definite and Has_Discriminants.
+ -- Checks that prefix is generic indefinite formal type.
procedure Check_Integer_Type;
-- Verify that prefix of attribute N is an integer type
procedure Check_Modular_Integer_Type;
-- Verify that prefix of attribute N is a modular integer type
+ procedure Check_Not_CPP_Type;
+ -- Check that P (the prefix of the attribute) is not an CPP type
+ -- for which no Ada predefined primitive is available.
+
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.
-- 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
-- type that is constructed is returned as the result.
procedure Build_Access_Subprogram_Type (P : Node_Id);
- -- Build an access to subprogram whose designated type is
- -- the type of the prefix. If prefix is overloaded, so it the
- -- node itself. The result is stored in Acc_Type.
+ -- Build an access to subprogram whose designated type is the type of
+ -- the prefix. If prefix is overloaded, so is 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
(E_Access_Attribute_Type, Current_Scope, Loc, 'A');
begin
Set_Etype (Typ, Typ);
- Init_Size_Align (Typ);
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, N);
Set_Directly_Designated_Type (Typ, DT);
-- 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;
-- subprogram itself as the designated type. Type-checking in
-- this case compares the signatures of the designated types.
+ -- Note: This fragment of the tree is temporarily malformed
+ -- because the correct tree requires an E_Subprogram_Type entity
+ -- as the designated type. In most cases this designated type is
+ -- later overridden by the semantics with the type imposed by the
+ -- context during the resolution phase. In the specific case of
+ -- the expression Address!(Prim'Unrestricted_Access), used to
+ -- initialize slots of dispatch tables, this work will be done by
+ -- the expander (see Exp_Aggr).
+
+ -- The reason to temporarily add this kind of node to the tree
+ -- instead of a proper E_Subprogram_Type itype, is the following:
+ -- in case of errors found in the source file we report better
+ -- error messages. For example, instead of generating the
+ -- following error:
+
+ -- "expected access to subprogram with profile
+ -- defined at line X"
+
+ -- we currently generate:
+
+ -- "expected access to function Z defined at line X"
+
Set_Etype (N, Any_Type);
if not Is_Overloaded (P) then
Check_Local_Access (Entity (P));
if not Is_Intrinsic_Subprogram (Entity (P)) then
- Acc_Type :=
- New_Internal_Entity
- (Get_Kind (Entity (P)), Current_Scope, Loc, 'A');
+ Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);
+ Set_Is_Public (Acc_Type, False);
Set_Etype (Acc_Type, Acc_Type);
+ Set_Convention (Acc_Type, Convention (Entity (P)));
Set_Directly_Designated_Type (Acc_Type, Entity (P));
Set_Etype (N, Acc_Type);
+ Freeze_Before (N, Acc_Type);
end if;
else
Check_Local_Access (It.Nam);
if not Is_Intrinsic_Subprogram (It.Nam) then
- Acc_Type :=
- New_Internal_Entity
- (Get_Kind (It.Nam), Current_Scope, Loc, 'A');
+ Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
+ Set_Is_Public (Acc_Type, False);
Set_Etype (Acc_Type, Acc_Type);
+ Set_Convention (Acc_Type, Convention (It.Nam));
Set_Directly_Designated_Type (Acc_Type, It.Nam);
Add_One_Interp (N, Acc_Type, Acc_Type);
+ Freeze_Before (N, Acc_Type);
end if;
Get_Next_Interp (Index, It);
(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 Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then
if Etype (Par) = Typ then
Set_Has_Self_Reference (Par);
return True;
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
+ if Has_Pragma_Inline_Always (Entity (P)) then
Error_Attr_P
("prefix of % attribute cannot be Inline_Always subprogram");
end if;
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));
+
+ -- Check for obsolescent subprogram reference
+
+ Check_Obsolescent_2005_Entity (Entity (P), P);
+
-- Build the appropriate subprogram type
Build_Access_Subprogram_Type (P);
-- could modify local variables to be passed out of scope
if Aname = Name_Unrestricted_Access then
- Kill_Current_Values;
+
+ -- Do not kill values on nodes initializing dispatch tables
+ -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
+ -- is currently generated by the expander only for this
+ -- purpose. Done to keep the quality of warnings currently
+ -- generated by the compiler (otherwise any declaration of
+ -- a tagged type cleans constant indications from its scope).
+
+ if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
+ and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
+ or else
+ Etype (Parent (N)) = RTE (RE_Size_Ptr))
+ and then Is_Dispatching_Operation
+ (Directly_Designated_Type (Etype (N)))
+ then
+ null;
+ else
+ Kill_Current_Values;
+ end if;
end if;
return;
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;
("current instance prefix must be a direct name", P);
end if;
- -- If a current instance attribute appears within a
- -- a component constraint it must appear alone; other
- -- contexts (default expressions, within a task body)
- -- are not subject to this restriction.
+ -- If a current instance attribute appears in a component
+ -- constraint it must appear alone; other contexts (spec-
+ -- expressions, within a task body) are not subject to this
+ -- restriction.
- if not In_Default_Expression
+ if not In_Spec_Expression
and then not Has_Completion (Scop)
- and then
- Nkind (Parent (N)) /= N_Discriminant_Association
- and then
- Nkind (Parent (N)) /= N_Index_Or_Discriminant_Constraint
+ and then not
+ Nkind_In (Parent (N), N_Discriminant_Association,
+ N_Index_Or_Discriminant_Constraint)
then
Error_Msg_N
("current instance attribute must appear alone", N);
end if;
+ if Is_CPP_Class (Root_Type (Typ)) then
+ Error_Msg_N
+ ("?current instance unsupported for derivations of "
+ & "'C'P'P types", N);
+ end if;
+
-- OK if we are in initialization procedure for the type
-- in question, in which case the reference to the type
-- is rewritten as a reference to the current object.
-- expression comes from source, e.g. when a single component
-- association in an aggregate has a box association.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then OK_Self_Reference
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
end;
end if;
- -- Special cases when prefix is entity name
+ -- Special cases when we can find a prefix that is an entity name
- if Is_Entity_Name (P) then
+ declare
+ PP : Node_Id;
+ Ent : Entity_Id;
- -- 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.
+ begin
+ PP := P;
+ loop
+ if Is_Entity_Name (PP) then
+ Ent := Entity (PP);
- Set_Never_Set_In_Source (Entity (P), False);
+ -- 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.
- -- Mark entity as address taken, and kill current values
+ Set_Never_Set_In_Source (Ent, False);
- Set_Address_Taken (Entity (P));
- Kill_Current_Values (Entity (P));
- end if;
+ -- Mark entity as address taken, and kill current values
+
+ Set_Address_Taken (Ent);
+ Kill_Current_Values (Ent);
+ exit;
+
+ elsif Nkind_In (PP, N_Selected_Component,
+ 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
end if;
end Analyze_Access_Attribute;
+ ---------------------------------
+ -- Bad_Attribute_For_Predicate --
+ ---------------------------------
+
+ procedure Bad_Attribute_For_Predicate is
+ begin
+ if Comes_From_Source (N) then
+ Error_Msg_Name_1 := Aname;
+ Bad_Predicated_Subtype_Use
+ ("type& has predicates, attribute % not allowed", N, P_Type);
+ end if;
+ end Bad_Attribute_For_Predicate;
+
--------------------------------
-- Check_Array_Or_Scalar_Type --
--------------------------------
-- 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),
end if;
end Check_Modular_Integer_Type;
+ ------------------------
+ -- Check_Not_CPP_Type --
+ ------------------------
+
+ procedure Check_Not_CPP_Type is
+ begin
+ if Is_Tagged_Type (Etype (P))
+ and then Convention (Etype (P)) = Convention_CPP
+ and then Is_CPP_Class (Root_Type (Etype (P)))
+ then
+ Error_Attr_P
+ ("invalid use of % attribute with 'C'P'P tagged type");
+ end if;
+ end Check_Not_CPP_Type;
+
-------------------------------
-- Check_Not_Incomplete_Type --
-------------------------------
-- S : constant Integer := X.all'Size; -- ERROR
-- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Nkind (P) = N_Explicit_Dereference
then
E := 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
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
- or else In_Default_Expression
+ or else In_Spec_Expression
then
return;
else
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 --
------------------------
then
Error_Attr ("only allowed prefix for % attribute is Standard", P);
end if;
-
end Check_Standard_Prefix;
----------------------------
Etyp : Entity_Id;
Btyp : Entity_Id;
+ In_Shared_Var_Procs : Boolean;
+ -- True when compiling the body of System.Shared_Storage.
+ -- Shared_Var_Procs. For this runtime package (always compiled in
+ -- GNAT mode), we allow stream attributes references for limited
+ -- types for the case where shared passive objects are implemented
+ -- using stream attributes, which is the default in GNAT's persistent
+ -- storage implementation.
+
begin
Validate_Non_Static_Attribute_Function_Call;
null;
elsif Is_List_Member (N)
- and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
- and then Nkind (Parent (N)) /= N_Aggregate
+ and then not Nkind_In (Parent (N), N_Procedure_Call_Statement,
+ N_Aggregate)
then
null;
-- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
-- (with no visibility restriction).
- if Comes_From_Source (N)
+ declare
+ Gen_Body : constant Node_Id := Enclosing_Generic_Body (N);
+ begin
+ if Present (Gen_Body) then
+ In_Shared_Var_Procs :=
+ Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs);
+ else
+ In_Shared_Var_Procs := False;
+ end if;
+ end;
+
+ if (Comes_From_Source (N)
+ and then not (In_Shared_Var_Procs or In_Instance))
and then not Stream_Attribute_Available (P_Type, Nam)
and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
then
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
Resolve (E2, P_Type);
end if;
+
+ Check_Not_CPP_Type;
end Check_Stream_Attribute;
-----------------------
if Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
- or else (Ada_Version >= Ada_05
+ or else (Ada_Version >= Ada_2005
and then Ekind (Etype (P)) = E_Class_Wide_Type
and then Is_Interface (Etype (P))
and then Is_Task_Interface (Etype (P)))
Resolve (P);
else
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Error_Attr_P
("prefix of % attribute must be a task or a task " &
"interface class-wide object");
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
-- 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
+ if Ada_Version < Ada_2005
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_Count
+ and then Aname /= Name_Result
and then Aname /= Name_Unchecked_Access
then
Error_Attr ("ambiguous prefix for % attribute", P);
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
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_Result
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
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then (Aname = Name_Count
or else Aname = Name_Caller
or else Aname = Name_AST_Entry)
-- 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);
begin
if Is_Subprogram (Ent) then
- if not Is_Library_Level_Entity (Ent) then
- Check_Restriction (No_Implicit_Dynamic_Code, P);
- end if;
-
Set_Address_Taken (Ent);
Kill_Current_Values (Ent);
-- errors about implicit uses of Address in the dispatch
-- table initialization).
- if Is_Always_Inlined (Entity (P))
+ if Has_Pragma_Inline_Always (Entity (P))
and then Comes_From_Source (P)
then
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)
Check_E0;
Check_Not_Incomplete_Type;
+ Check_Not_CPP_Type;
Set_Etype (N, Universal_Integer);
---------------
end if;
end if;
- Note_Possible_Modification (E2);
+ Note_Possible_Modification (E2, Sure => True);
Set_Etype (N, RTE (RE_Asm_Output_Operand));
---------------
-- is set True for the entry family case). In the True case,
-- makes sure that Is_AST_Entry is set on the entry.
+ -------------------
+ -- Bad_AST_Entry --
+ -------------------
+
procedure Bad_AST_Entry is
begin
Error_Attr_P ("prefix for % attribute must be task entry");
end Bad_AST_Entry;
+ --------------
+ -- OK_Entry --
+ --------------
+
function OK_Entry (E : Entity_Id) return Boolean is
Result : Boolean;
-- or of a variable of the enclosing task type.
else
- if Nkind (Pref) = N_Identifier
- or else Nkind (Pref) = N_Expanded_Name
- then
+ if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then
Ent := Entity (Pref);
if not OK_Entry (Ent)
Typ : Entity_Id;
begin
- Check_Either_E0_Or_E1;
+ Check_E0;
Find_Type (P);
Typ := Entity (P);
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 -- CODEFIX
+ ("?redundant 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;
---------
begin
Check_E0;
- if Nkind (P) = N_Identifier
- or else Nkind (P) = N_Expanded_Name
- then
+ if Nkind_In (P, N_Identifier, N_Expanded_Name) then
Ent := Entity (P);
if not Is_Entry (Ent) then
-- Class --
-----------
- when Attribute_Class => Class : declare
- P : constant Entity_Id := Prefix (N);
-
- 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 => P,
- Attribute_Name => Name_Class),
- Expression => Relocate_Node (E1)));
-
- Save_Interps (E1, Expression (N));
-
- -- Ada 2005 (AI-251): In case of abstract interfaces we have to
- -- analyze and resolve the type conversion to generate the code
- -- that displaces the reference to the base of the object.
-
- if Is_Interface (Etype (P))
- or else Is_Interface (Etype (E1))
- then
- Analyze_And_Resolve (N, Etype (P));
-
- -- However, the attribute is a name that occurs in a context
- -- that imposes its own type. Leave the result unanalyzed,
- -- so that type checking with the context type take place.
- -- on the new conversion node, otherwise Resolve is a noop.
-
- Set_Analyzed (N, False);
-
- else
- Analyze (N);
- end if;
+ Check_E0;
+ Find_Type (N);
- -- Otherwise we just need to find the proper type
+ -- Applying Class to untagged incomplete type is obsolescent in Ada
+ -- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since
+ -- this flag gets set by Find_Type in this situation.
- else
- Find_Type (N);
+ if Restriction_Check_Required (No_Obsolescent_Features)
+ and then Ada_Version >= Ada_2005
+ and then Ekind (P_Type) = E_Incomplete_Type
+ then
+ declare
+ DN : constant Node_Id := Declaration_Node (P_Type);
+ begin
+ if Nkind (DN) = N_Incomplete_Type_Declaration
+ and then not Tagged_Present (DN)
+ then
+ Check_Restriction (No_Obsolescent_Features, P);
+ end if;
+ end;
end if;
- end Class;
------------------
-- Code_Address --
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 --
--------------------
-- 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);
+ Check_Restriction (No_Obsolescent_Features, P);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
begin
Check_E0;
- if Nkind (P) = N_Identifier
- or else Nkind (P) = N_Expanded_Name
- then
+ if Nkind_In (P, N_Identifier, N_Expanded_Name) then
Ent := Entity (P);
if Ekind (Ent) /= E_Entry then
exit;
elsif Ekind (Scope (Ent)) in Task_Kind
- and then Ekind (S) /= E_Loop
- and then Ekind (S) /= E_Block
- and then Ekind (S) /= E_Entry
- and then Ekind (S) /= E_Entry_Family
+ and then
+ not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family)
then
Error_Attr ("Attribute % cannot appear in inner unit", N);
-- Ada 2005 (AI-345): Do not consider primitive entry
-- wrappers generated for task or protected types.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then not Comes_From_Source (It.Nam)
then
null;
when Attribute_Default_Bit_Order => Default_Bit_Order :
begin
Check_Standard_Prefix;
- Check_E0;
if Bytes_Big_Endian then
Rewrite (N,
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;
Ekind (Entity (P)) /= E_Enumeration_Literal)
then
Error_Attr_P
- ("prefix of %attribute must be " &
+ ("prefix of % attribute must be " &
"discrete type/object or enum literal");
end if;
end if;
Set_Etype (N, Universal_Integer);
end Enum_Rep;
+ --------------
+ -- Enum_Val --
+ --------------
+
+ when Attribute_Enum_Val => Enum_Val : begin
+ Check_E1;
+ Check_Type;
+
+ if not Is_Enumeration_Type (P_Type) then
+ Error_Attr_P ("prefix of % attribute must be enumeration type");
+ end if;
+
+ -- If the enumeration type has a standard representation, the effect
+ -- is the same as 'Val, so rewrite the attribute as a 'Val.
+
+ if not Has_Non_Standard_Rep (P_Base_Type) then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Prefix (N)),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (Relocate_Node (E1))));
+ Analyze_And_Resolve (N, P_Base_Type);
+
+ -- Non-standard representation case (enumeration with holes)
+
+ else
+ Check_Enum_Image;
+ Resolve (E1, Any_Integer);
+ Set_Etype (N, P_Base_Type);
+ end if;
+ end Enum_Val;
+
-------------
-- Epsilon --
-------------
Error_Attr_P ("prefix of % attribute must be tagged");
end if;
+ ---------------
+ -- Fast_Math --
+ ---------------
+
+ when Attribute_Fast_Math =>
+ Check_Standard_Prefix;
+
+ if Opt.Fast_Math then
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ else
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ end if;
+
-----------
-- First --
-----------
when Attribute_First =>
Check_Array_Or_Scalar_Type;
+ Bad_Attribute_For_Predicate;
---------------
-- First_Bit --
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 --
-----------------------
Set_Etype (N, Standard_Boolean);
-----------------------
+ -- Has_Tagged_Values --
+ -----------------------
+
+ when Attribute_Has_Tagged_Values =>
+ Check_Type;
+ Check_E0;
+ Set_Etype (N, Standard_Boolean);
+
+ -----------------------
-- Has_Discriminants --
-----------------------
elsif Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
- or else (Ada_Version >= Ada_05
+ or else (Ada_Version >= Ada_2005
and then Ekind (Etype (P)) = E_Class_Wide_Type
and then Is_Interface (Etype (P))
and then Is_Task_Interface (Etype (P)))
Set_Etype (N, RTE (RO_AT_Task_Id));
else
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Error_Attr_P
("prefix of % attribute must be an exception, a " &
"task or a task interface class-wide object");
when Attribute_Img => Img :
begin
+ Check_E0;
Set_Etype (N, Standard_String);
if not Is_Scalar_Type (P_Type)
Check_E1;
Check_Integer_Type;
Resolve (E1, Any_Fixed);
+
+ -- Signal an error if argument type is not a specific fixed-point
+ -- subtype. An error has been signalled already if the argument
+ -- was not of a fixed-point type.
+
+ if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then
+ Error_Attr ("argument of % must be of a fixed-point type", E1);
+ end if;
+
Set_Etype (N, P_Base_Type);
+ -------------------
+ -- Invalid_Value --
+ -------------------
+
+ when Attribute_Invalid_Value =>
+ Check_E0;
+ Check_Scalar_Type;
+ Set_Etype (N, P_Base_Type);
+ Invalid_Value_Used := True;
+
-----------
-- Large --
-----------
when Attribute_Last =>
Check_Array_Or_Scalar_Type;
+ Bad_Attribute_For_Predicate;
--------------
-- Last_Bit --
Set_Etype (N, P_Base_Type);
----------------------------------
+ -- Max_Alignment_For_Allocation --
-- Max_Size_In_Storage_Elements --
----------------------------------
- when Attribute_Max_Size_In_Storage_Elements =>
+ when Attribute_Max_Alignment_For_Allocation |
+ Attribute_Max_Size_In_Storage_Elements =>
Check_E0;
Check_Type;
Check_Not_Incomplete_Type;
elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
or else UI_To_Int (Intval (E1)) < 0
then
- Error_Attr ("invalid parameter number for %attribute", E1);
+ Error_Attr ("invalid parameter number for % attribute", E1);
end if;
end if;
----------------------
procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
- Pent : Entity_Id := Proc_Ent;
+ Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent);
begin
- while Present (Alias (Pent)) loop
- Pent := Alias (Pent);
- end loop;
-
-- Ignore check if procedure not frozen yet (we will get
-- another chance when the default parameter is reanalyzed)
-- Case of attribute used as actual for subprogram (positional)
- elsif (Nkind (Parnt) = N_Procedure_Call_Statement
- or else
- Nkind (Parnt) = N_Function_Call)
+ elsif Nkind_In (Parnt, N_Procedure_Call_Statement,
+ N_Function_Call)
and then Is_Entity_Name (Name (Parnt))
then
Must_Be_Imported (Entity (Name (Parnt)));
-- Case of attribute used as actual for subprogram (named)
elsif Nkind (Parnt) = N_Parameter_Association
- and then (Nkind (GParnt) = N_Procedure_Call_Statement
- or else
- Nkind (GParnt) = N_Function_Call)
+ and then Nkind_In (GParnt, N_Procedure_Call_Statement,
+ N_Function_Call)
and then Is_Entity_Name (Name (GParnt))
then
Must_Be_Imported (Entity (Name (GParnt)));
Bad_Null_Parameter
("Null_Parameter must be actual or default parameter");
end if;
-
end Null_Parameter;
-----------------
Check_Not_Incomplete_Type;
Set_Etype (N, Universal_Integer);
+ ---------
+ -- Old --
+ ---------
+
+ when Attribute_Old =>
+
+ -- The attribute reference is a primary. If expressions follow, the
+ -- attribute reference is an indexable object, so rewrite the node
+ -- accordingly.
+
+ if Present (E1) then
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Prefix (N)),
+ Attribute_Name => Name_Old),
+ Expressions => Expressions (N)));
+
+ Analyze (N);
+ return;
+ end if;
+
+ Check_E0;
+ Set_Etype (N, P_Type);
+
+ if No (Current_Subprogram) then
+ Error_Attr ("attribute % can only appear within subprogram", N);
+ end if;
+
+ if Is_Limited_Type (P_Type) then
+ Error_Attr ("attribute % cannot apply to limited objects", P);
+ end if;
+
+ if Is_Entity_Name (P)
+ and then Is_Constant_Object (Entity (P))
+ then
+ Error_Msg_N
+ ("?attribute Old applied to constant has no effect", P);
+ end if;
+
+ -- Check that the expression does not refer to local entities
+
+ Check_Local : declare
+ Subp : Entity_Id := Current_Subprogram;
+
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Check that N does not contain references to local variables or
+ -- other local entities of Subp.
+
+ -------------
+ -- Process --
+ -------------
+
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then not Is_Formal (Entity (N))
+ and then Enclosing_Subprogram (Entity (N)) = Subp
+ then
+ Error_Msg_Node_1 := Entity (N);
+ Error_Attr
+ ("attribute % cannot refer to local variable&", N);
+ end if;
+
+ return OK;
+ end Process;
+
+ procedure Check_No_Local is new Traverse_Proc;
+
+ -- Start of processing for Check_Local
+
+ begin
+ Check_No_Local (P);
+
+ if In_Parameter_Specification (P) then
+
+ -- We have additional restrictions on using 'Old in parameter
+ -- specifications.
+
+ if Present (Enclosing_Subprogram (Current_Subprogram)) then
+
+ -- Check that there is no reference to the enclosing
+ -- subprogram local variables. Otherwise, we might end up
+ -- being called from the enclosing subprogram and thus using
+ -- 'Old on a local variable which is not defined at entry
+ -- time.
+
+ Subp := Enclosing_Subprogram (Current_Subprogram);
+ Check_No_Local (P);
+
+ else
+ -- We must prevent default expression of library-level
+ -- subprogram from using 'Old, as the subprogram may be
+ -- used in elaboration code for which there is no enclosing
+ -- subprogram.
+
+ Error_Attr
+ ("attribute % can only appear within subprogram", N);
+ end if;
+ end if;
+ end Check_Local;
+
------------
-- Output --
------------
-- Partition_ID --
------------------
- when Attribute_Partition_ID =>
+ when Attribute_Partition_ID => Partition_Id :
+ begin
Check_E0;
if P_Type /= Any_Type then
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).
- -- The Is_Pure flag has been set during declaration.
+ -- The defining entity of prefix should not be declared inside a
+ -- Pure unit. RM E.1(8). Is_Pure was set during declaration.
elsif Is_Entity_Name (P)
and then Is_Pure (Entity (P))
then
- Error_Attr_P
- ("prefix of % attribute must not be declared pure");
+ Error_Attr_P ("prefix of% attribute must not be declared pure");
end if;
end if;
Set_Etype (N, Universal_Integer);
+ end Partition_Id;
-------------------------
-- Passed_By_Reference --
-- Ada 2005 (AI-327): Dynamic ceiling priorities
when Attribute_Priority =>
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
end if;
when Attribute_Range =>
Check_Array_Or_Scalar_Type;
+ Bad_Attribute_For_Predicate;
if Ada_Version = Ada_83
and then Is_Scalar_Type (P_Type)
("(Ada 83) % attribute not allowed for scalar type", P);
end if;
+ ------------
+ -- Result --
+ ------------
+
+ when Attribute_Result => Result : declare
+ 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
+ -- when the real Analyze call is done.
+
+ if Ekind (CS) = E_Function
+ and then In_Spec_Expression
+ then
+ -- Check OK prefix
+
+ if Chars (CS) /= Chars (P) then
+ Error_Msg_NE
+ ("incorrect prefix for % attribute, expected &", P, CS);
+ Error_Attr;
+ end if;
+
+ Set_Etype (N, Etype (CS));
+
+ -- If several functions with that name are visible,
+ -- the intended one is the current scope.
+
+ if Is_Overloaded (P) then
+ Set_Entity (P, CS);
+ Set_Is_Overloaded (P, False);
+ end if;
+
+ -- Body case, where we must be inside a generated _Postcondition
+ -- 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.
+
+ 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;
+
+ PS := Scope (CS);
+
+ if Chars (CS) = Name_uPostconditions
+ and then Ekind (PS) = E_Function
+ then
+ -- Check OK prefix
+
+ if Nkind_In (P, N_Identifier, N_Operator_Symbol)
+ and then Chars (P) = Chars (PS)
+ then
+ null;
+
+ -- 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), 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;
+
------------------
-- Range_Length --
------------------
when Attribute_Range_Length =>
+ Check_E0;
Check_Discrete_Type;
Set_Etype (N, Universal_Integer);
Check_Stream_Attribute (TSS_Stream_Read);
Set_Etype (N, Standard_Void_Type);
Resolve (N, Standard_Void_Type);
- Note_Possible_Modification (E2);
+ Note_Possible_Modification (E2, Sure => True);
+
+ ---------
+ -- Ref --
+ ---------
+
+ when Attribute_Ref =>
+ Check_E1;
+ Analyze (P);
+
+ if Nkind (P) /= N_Expanded_Name
+ or else not Is_RTE (P_Type, RE_Address)
+ then
+ Error_Attr_P ("prefix of % attribute must be System.Address");
+ end if;
+
+ Analyze_And_Resolve (E1, Any_Integer);
+ Set_Etype (N, RTE (RE_Address));
---------------
-- Remainder --
-- Size --
----------
- when Attribute_Size | Attribute_VADS_Size =>
+ when Attribute_Size | Attribute_VADS_Size => Size :
+ begin
Check_E0;
-- If prefix is parameterless function call, rewrite and resolve
end if;
Check_Not_Incomplete_Type;
+ Check_Not_CPP_Type;
Set_Etype (N, Universal_Integer);
+ end Size;
-----------
-- Small --
-- Storage_Pool --
------------------
- when Attribute_Storage_Pool =>
- if Is_Access_Type (P_Type) then
- Check_E0;
+ when Attribute_Storage_Pool => Storage_Pool :
+ begin
+ Check_E0;
+ if 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");
else
Error_Attr_P ("prefix of % attribute must be access type");
end if;
+ end Storage_Pool;
------------------
-- Storage_Size --
------------------
- when Attribute_Storage_Size =>
+ when Attribute_Storage_Size => Storage_Size :
+ begin
+ Check_E0;
+
if Is_Task_Type (P_Type) then
- Check_E0;
Set_Etype (N, Universal_Integer);
+ -- Use with tasks is an obsolescent feature
+
+ Check_Restriction (No_Obsolescent_Features, P);
+
elsif Is_Access_Type (P_Type) then
if Ekind (P_Type) = E_Access_Subprogram_Type then
Error_Attr_P
if Is_Entity_Name (P)
and then Is_Type (Entity (P))
then
- Check_E0;
Check_Type;
Set_Etype (N, Universal_Integer);
-- of an access value designating a task.
else
- Check_E0;
Check_Task_Prefix;
Set_Etype (N, Universal_Integer);
end if;
else
Error_Attr_P ("prefix of % attribute must be access or task type");
end if;
+ end Storage_Size;
------------------
-- Storage_Unit --
-- Tag --
---------
- when Attribute_Tag =>
+ when Attribute_Tag => Tag :
+ begin
Check_E0;
Check_Dereference;
if Comes_From_Source (N) then
Check_Not_Incomplete_Type;
end if;
+
+ -- Set appropriate type
+
Set_Etype (N, RTE (RE_Tag));
+ end Tag;
-----------------
-- Target_Name --
begin
Check_Standard_Prefix;
- Check_E0;
TL := TN'Last;
if Nkind (P) /= N_Identifier
or else Chars (P) /= Name_System
then
- Error_Attr_P ("prefix of %attribute must be System");
+ Error_Attr_P ("prefix of % attribute must be System");
end if;
- Generate_Reference (RTE (RE_Address), P);
- Analyze_And_Resolve (E1, Any_Integer);
- Set_Etype (N, RTE (RE_Address));
+ Generate_Reference (RTE (RE_Address), P);
+ 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 --
+ ----------------
+
+ when Attribute_Truncation =>
+ Check_Floating_Point_Type_1;
+ Resolve (E1, P_Base_Type);
+ Set_Etype (N, P_Base_Type);
+
+ ----------------
+ -- Type_Class --
+ ----------------
+
+ when Attribute_Type_Class =>
+ Check_E0;
+ Check_Type;
+ 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));
+
+ --------------
+ -- Type_Key --
+ --------------
+
+ when Attribute_Type_Key =>
+ Check_E0;
+ Check_Type;
+
+ -- This processing belongs in Eval_Attribute ???
+
+ declare
+ function Type_Key return String_Id;
+ -- A very preliminary implementation. For now, a signature
+ -- consists of only the type name. This is clearly incomplete
+ -- (e.g., adding a new field to a record type should change the
+ -- type's Type_Key attribute).
+
+ --------------
+ -- Type_Key --
+ --------------
+
+ function Type_Key return String_Id is
+ Full_Name : constant String_Id :=
+ Fully_Qualified_Name_String (Entity (P));
+
+ begin
+ -- Copy all characters in Full_Name but the trailing NUL
- ----------------
- -- Truncation --
- ----------------
+ Start_String;
+ for J in 1 .. String_Length (Full_Name) - 1 loop
+ Store_String_Char (Get_String_Char (Full_Name, Int (J)));
+ end loop;
- when Attribute_Truncation =>
- Check_Floating_Point_Type_1;
- Resolve (E1, P_Base_Type);
- Set_Etype (N, P_Base_Type);
+ Store_String_Chars ("'Type_Key");
+ return End_String;
+ end Type_Key;
- ----------------
- -- Type_Class --
- ----------------
+ begin
+ Rewrite (N, Make_String_Literal (Loc, Type_Key));
+ end;
- when Attribute_Type_Class =>
- Check_E0;
- Check_Type;
- Check_Not_Incomplete_Type;
- Set_Etype (N, RTE (RE_Type_Class));
+ Analyze_And_Resolve (N, Standard_String);
-----------------
-- UET_Address --
Negative := False;
end if;
- if Nkind (Expr) /= N_Integer_Literal
- and then Nkind (Expr) /= N_Real_Literal
- then
+ if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
Error_Attr
("named number for % attribute must be simple literal", N);
end if;
-- processing, since otherwise gigi might see an attribute which it is
-- unprepared to deal with.
- function Aft_Value return Nat;
- -- Computes Aft value for current attribute prefix (used by Aft itself
- -- and also by Width for computing the Width of a fixed point type).
+ procedure Check_Concurrent_Discriminant (Bound : Node_Id);
+ -- If Bound is a reference to a discriminant of a task or protected type
+ -- occurring within the object's body, rewrite attribute reference into
+ -- a reference to the corresponding discriminal. Use for the expansion
+ -- of checks against bounds of entry family index subtypes.
procedure Check_Expressions;
-- In case where the attribute is not foldable, the expressions, if
-- but compile time known value given by Val. It includes the
-- necessary checks for out of range values.
- procedure Float_Attribute_Universal_Integer
- (IEEES_Val : Int;
- IEEEL_Val : Int;
- IEEEX_Val : Int;
- VAXFF_Val : Int;
- VAXDF_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.
- -- The prefix type is a float type (and is thus not a generic type).
-
- procedure Float_Attribute_Universal_Real
- (IEEES_Val : String;
- IEEEL_Val : String;
- IEEEX_Val : String;
- VAXFF_Val : String;
- VAXDF_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
- -- format as real literals with a possible leading minus sign.
- -- The prefix type is a float type (and is thus not a generic type).
-
function Fore_Value return Nat;
-- Computes the Fore value for the current attribute prefix, which is
-- known to be a static fixed-point type. Used by Fore and Width.
-- Verify that the prefix of a potentially static array attribute
-- satisfies the conditions of 4.9 (14).
- ---------------
- -- Aft_Value --
- ---------------
+ -----------------------------------
+ -- Check_Concurrent_Discriminant --
+ -----------------------------------
- function Aft_Value return Nat is
- Result : Nat;
- Delta_Val : Ureal;
+ procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
+ Tsk : Entity_Id;
+ -- The concurrent (task or protected) type
begin
- Result := 1;
- Delta_Val := Delta_Value (P_Type);
- while Delta_Val < Ureal_Tenth loop
- Delta_Val := Delta_Val * Ureal_10;
- Result := Result + 1;
- end loop;
+ if Nkind (Bound) = N_Identifier
+ and then Ekind (Entity (Bound)) = E_Discriminant
+ and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
+ then
+ Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
+
+ if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then
- return Result;
- end Aft_Value;
+ -- Find discriminant of original concurrent type, and use
+ -- its current discriminal, which is the renaming within
+ -- the task/protected body.
+
+ Rewrite (N,
+ New_Occurrence_Of
+ (Find_Body_Discriminal (Entity (Bound)), Loc));
+ end if;
+ end if;
+ end Check_Concurrent_Discriminant;
-----------------------
-- Check_Expressions --
-- 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
Compile_Time_Known_Value (Type_High_Bound (Typ));
end Compile_Time_Known_Bounds;
- ---------------------------------------
- -- Float_Attribute_Universal_Integer --
- ---------------------------------------
-
- procedure Float_Attribute_Universal_Integer
- (IEEES_Val : Int;
- IEEEL_Val : Int;
- IEEEX_Val : Int;
- VAXFF_Val : Int;
- VAXDF_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 Vax_Float (P_Base_Type) then
- if Digs = VAXFF_Digits then
- Val := VAXFF_Val;
- elsif Digs = VAXDF_Digits then
- Val := VAXDF_Val;
- 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), True);
- end Float_Attribute_Universal_Integer;
-
- ------------------------------------
- -- Float_Attribute_Universal_Real --
- ------------------------------------
-
- procedure Float_Attribute_Universal_Real
- (IEEES_Val : String;
- IEEEL_Val : String;
- IEEEX_Val : String;
- VAXFF_Val : String;
- VAXDF_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 Vax_Float (P_Base_Type) then
- if Digs = VAXFF_Digits then
- Val := Real_Convert (VAXFF_Val);
- elsif Digs = VAXDF_Digits then
- Val := Real_Convert (VAXDF_Val);
- 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;
-
----------------
-- Fore_Value --
----------------
-- Start of processing for Eval_Attribute
begin
- -- Acquire first two expressions (at the moment, no attributes
- -- take more than two expressions in any case).
+ -- No folding in spec expression that comes from source where the prefix
+ -- is an unfrozen entity. This avoids premature folding in cases like:
+
+ -- procedure DefExprAnal is
+ -- type R is new Integer;
+ -- procedure P (Arg : Integer := R'Size);
+ -- for R'Size use 64;
+ -- procedure P (Arg : Integer := R'Size) is
+ -- begin
+ -- Put_Line (Arg'Img);
+ -- end P;
+ -- begin
+ -- P;
+ -- end;
+
+ -- which should print 64 rather than 32. The exclusion of non-source
+ -- constructs from this test comes from some internal usage in packed
+ -- arrays, which otherwise fails, could use more analysis perhaps???
+
+ -- We do however go ahead with generic actual types, otherwise we get
+ -- some regressions, probably these types should be frozen anyway???
+
+ if In_Spec_Expression
+ and then Comes_From_Source (N)
+ and then not (Is_Entity_Name (P)
+ and then
+ (Is_Frozen (Entity (P))
+ or else (Is_Type (Entity (P))
+ and then
+ Is_Generic_Actual_Type (Entity (P)))))
+ then
+ return;
+ end if;
+
+ -- Acquire first two expressions (at the moment, no attributes take more
+ -- than two expressions in any case).
if Present (Expressions (N)) then
E1 := First (Expressions (N));
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
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;
-- 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, Type_Class,
- -- and Unconstrained_Array.
+ -- Has_Tagged_Value, and Unconstrained_Array.
elsif (Id = Attribute_Definite
or else
or else
Id = Attribute_Has_Discriminants
or else
+ Id = Attribute_Has_Tagged_Values
+ or else
Id = Attribute_Type_Class
or else
- Id = Attribute_Unconstrained_Array)
+ Id = Attribute_Unconstrained_Array
+ or else
+ Id = Attribute_Max_Alignment_For_Allocation)
and then not Is_Generic_Type (P_Entity)
then
P_Type := P_Entity;
- -- We can fold 'Size applied to a type if the size is known
- -- (as happens for a size 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).
+ -- We can fold 'Size applied to a type if the size is known (as happens
+ -- for a size 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_Size
and then Is_Type (P_Entity)
-- since we can't do anything with unconstrained arrays. In addition,
-- only the First, Last and Length attributes are possibly static.
- -- Definite, Has_Access_Values, Has_Discriminants, Type_Class, and
- -- Unconstrained_Array are again exceptions, because they apply as
- -- well to unconstrained types.
+ -- Definite, Has_Access_Values, Has_Discriminants, Has_Tagged_Values,
+ -- 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
or else
Id = Attribute_Has_Discriminants
or else
+ Id = Attribute_Has_Tagged_Values
+ or else
Id = Attribute_Type_Class
or else
Id = Attribute_Unconstrained_Array
then
Static := False;
- else
+ elsif Id /= Attribute_Max_Alignment_For_Allocation then
if not Is_Constrained (P_Type)
or else (Id /= Attribute_First and then
Id /= Attribute_Last and then
-- 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));
- -- If however the index type is generic, attributes cannot
- -- be folded.
+ -- If however the index type is generic, or derived from
+ -- one, attributes cannot be folded.
- if Is_Generic_Type (Etype (N))
+ if Is_Generic_Type (Root_Type (Etype (N)))
and then Id /= Attribute_Component_Size
then
return;
---------
when Attribute_Aft =>
- Fold_Uint (N, UI_From_Int (Aft_Value), True);
+ Fold_Uint (N, Aft_Value (P_Type), True);
---------------
-- Alignment --
-----------------
-- Constrained is never folded for now, there may be cases that
- -- could be handled at compile time. to be looked at later.
+ -- could be handled at compile time. To be looked at later.
when Attribute_Constrained =>
null;
Fold_Uint (N, Expr_Value (E1), Static);
end if;
+ --------------
+ -- Enum_Val --
+ --------------
+
+ when Attribute_Enum_Val => Enum_Val : declare
+ Lit : Node_Id;
+
+ begin
+ -- We have something like Enum_Type'Enum_Val (23), so search for a
+ -- corresponding value in the list of Enum_Rep values for the type.
+
+ Lit := First_Literal (P_Base_Type);
+ loop
+ if Enumeration_Rep (Lit) = Expr_Value (E1) then
+ Fold_Uint (N, Enumeration_Pos (Lit), Static);
+ exit;
+ end if;
+
+ Next_Literal (Lit);
+
+ if No (Lit) then
+ Apply_Compile_Time_Constraint_Error
+ (N, "no representation value matches",
+ CE_Range_Check_Failed,
+ Warn => not Static);
+ exit;
+ end if;
+ end loop;
+ end Enum_Val;
+
-------------
-- Epsilon --
-------------
else
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
+
+ else
+ Check_Concurrent_Discriminant (Lo_Bound);
end if;
end First_Attr;
Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
+ -----------------------
+ -- Has_Tagged_Values --
+ -----------------------
+
+ when Attribute_Has_Tagged_Values =>
+ Rewrite (N, New_Occurrence_Of
+ (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc));
+ Analyze_And_Resolve (N, Standard_Boolean);
+
--------------
-- Identity --
--------------
-- Integer_Value --
-------------------
+ -- We never try to fold Integer_Value (though perhaps we could???)
+
when Attribute_Integer_Value =>
null;
+ -------------------
+ -- Invalid_Value --
+ -------------------
+
+ -- Invalid_Value is a scalar attribute that is never static, because
+ -- the value is by design out of range.
+
+ when Attribute_Invalid_Value =>
+ null;
+
-----------
-- Large --
-----------
else
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
+
+ else
+ Check_Concurrent_Discriminant (Hi_Bound);
end if;
end Last;
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.
+ -- If any index type is a formal type, or derived from one, the
+ -- bounds are not static. Treating them as static can produce
+ -- spurious warnings or improper constant folding.
Ind := First_Index (P_Type);
-
while Present (Ind) loop
- if Is_Generic_Type (Etype (Ind)) then
+ if Is_Generic_Type (Root_Type (Etype (Ind))) then
return;
end if;
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_Machine_Emax =>
- Float_Attribute_Universal_Integer (
- IEEES_Machine_Emax,
- IEEEL_Machine_Emax,
- IEEEX_Machine_Emax,
- VAXFF_Machine_Emax,
- VAXDF_Machine_Emax,
- VAXGF_Machine_Emax,
- AAMPS_Machine_Emax,
- AAMPL_Machine_Emax);
+ Fold_Uint (N, Machine_Emax_Value (P_Type), Static);
------------------
-- Machine_Emin --
------------------
when Attribute_Machine_Emin =>
- Float_Attribute_Universal_Integer (
- IEEES_Machine_Emin,
- IEEEL_Machine_Emin,
- IEEEX_Machine_Emin,
- VAXFF_Machine_Emin,
- VAXDF_Machine_Emin,
- VAXGF_Machine_Emin,
- AAMPS_Machine_Emin,
- AAMPL_Machine_Emin);
+ Fold_Uint (N, Machine_Emin_Value (P_Type), Static);
----------------------
-- Machine_Mantissa --
----------------------
when Attribute_Machine_Mantissa =>
- Float_Attribute_Universal_Integer (
- IEEES_Machine_Mantissa,
- IEEEL_Machine_Mantissa,
- IEEEX_Machine_Mantissa,
- VAXFF_Machine_Mantissa,
- VAXDF_Machine_Mantissa,
- VAXGF_Machine_Mantissa,
- AAMPS_Machine_Mantissa,
- AAMPL_Machine_Mantissa);
+ Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static);
-----------------------
-- Machine_Overflows --
-- 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
+ -- 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 =>
end Max;
----------------------------------
+ -- Max_Alignment_For_Allocation --
+ ----------------------------------
+
+ -- Max_Alignment_For_Allocation is usually the Alignment. However,
+ -- arrays are allocated with dope, so we need to take into account both
+ -- the alignment of the array, which comes from the component alignment,
+ -- and the alignment of the dope. Also, if the alignment is unknown, we
+ -- use the max (it's OK to be pessimistic).
+
+ when Attribute_Max_Alignment_For_Allocation =>
+ declare
+ A : Uint := UI_From_Int (Ttypes.Maximum_Alignment);
+ begin
+ if Known_Alignment (P_Type) and then
+ (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A)
+ then
+ A := Alignment (P_Type);
+ end if;
+
+ Fold_Uint (N, A, Static);
+ end;
+
+ ----------------------------------
-- Max_Size_In_Storage_Elements --
----------------------------------
----------------
when Attribute_Model_Emin =>
- Float_Attribute_Universal_Integer (
- IEEES_Model_Emin,
- IEEEL_Model_Emin,
- IEEEX_Model_Emin,
- VAXFF_Model_Emin,
- VAXDF_Model_Emin,
- VAXGF_Model_Emin,
- AAMPS_Model_Emin,
- AAMPL_Model_Emin);
+ Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static);
-------------------
-- Model_Epsilon --
-------------------
when Attribute_Model_Epsilon =>
- Float_Attribute_Universal_Real (
- IEEES_Model_Epsilon'Universal_Literal_String,
- IEEEL_Model_Epsilon'Universal_Literal_String,
- IEEEX_Model_Epsilon'Universal_Literal_String,
- VAXFF_Model_Epsilon'Universal_Literal_String,
- VAXDF_Model_Epsilon'Universal_Literal_String,
- VAXGF_Model_Epsilon'Universal_Literal_String,
- AAMPS_Model_Epsilon'Universal_Literal_String,
- AAMPL_Model_Epsilon'Universal_Literal_String);
+ Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static);
--------------------
-- Model_Mantissa --
--------------------
when Attribute_Model_Mantissa =>
- Float_Attribute_Universal_Integer (
- IEEES_Model_Mantissa,
- IEEEL_Model_Mantissa,
- IEEEX_Model_Mantissa,
- VAXFF_Model_Mantissa,
- VAXDF_Model_Mantissa,
- VAXGF_Model_Mantissa,
- AAMPS_Model_Mantissa,
- AAMPL_Model_Mantissa);
+ Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static);
-----------------
-- Model_Small --
-----------------
when Attribute_Model_Small =>
- Float_Attribute_Universal_Real (
- IEEES_Model_Small'Universal_Literal_String,
- IEEEL_Model_Small'Universal_Literal_String,
- IEEEX_Model_Small'Universal_Literal_String,
- VAXFF_Model_Small'Universal_Literal_String,
- VAXDF_Model_Small'Universal_Literal_String,
- VAXGF_Model_Small'Universal_Literal_String,
- AAMPS_Model_Small'Universal_Literal_String,
- AAMPL_Model_Small'Universal_Literal_String);
+ Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static);
-------------
-- Modulus --
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;
+
+ ---------
+ -- Ref --
+ ---------
+
+ when Attribute_Ref =>
+ Fold_Uint (N, Expr_Value (E1), True);
+
---------------
-- Remainder --
---------------
---------------
when Attribute_Safe_Emax =>
- Float_Attribute_Universal_Integer (
- IEEES_Safe_Emax,
- IEEEL_Safe_Emax,
- IEEEX_Safe_Emax,
- VAXFF_Safe_Emax,
- VAXDF_Safe_Emax,
- VAXGF_Safe_Emax,
- AAMPS_Safe_Emax,
- AAMPL_Safe_Emax);
+ Fold_Uint (N, Safe_Emax_Value (P_Type), Static);
----------------
-- Safe_First --
----------------
when Attribute_Safe_First =>
- Float_Attribute_Universal_Real (
- IEEES_Safe_First'Universal_Literal_String,
- IEEEL_Safe_First'Universal_Literal_String,
- IEEEX_Safe_First'Universal_Literal_String,
- VAXFF_Safe_First'Universal_Literal_String,
- VAXDF_Safe_First'Universal_Literal_String,
- VAXGF_Safe_First'Universal_Literal_String,
- AAMPS_Safe_First'Universal_Literal_String,
- AAMPL_Safe_First'Universal_Literal_String);
+ Fold_Ureal (N, Safe_First_Value (P_Type), Static);
----------------
-- Safe_Large --
Fold_Ureal
(N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
else
- Float_Attribute_Universal_Real (
- IEEES_Safe_Large'Universal_Literal_String,
- IEEEL_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,
- AAMPS_Safe_Large'Universal_Literal_String,
- AAMPL_Safe_Large'Universal_Literal_String);
+ Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
end if;
---------------
---------------
when Attribute_Safe_Last =>
- Float_Attribute_Universal_Real (
- IEEES_Safe_Last'Universal_Literal_String,
- IEEEL_Safe_Last'Universal_Literal_String,
- IEEEX_Safe_Last'Universal_Literal_String,
- VAXFF_Safe_Last'Universal_Literal_String,
- VAXDF_Safe_Last'Universal_Literal_String,
- VAXGF_Safe_Last'Universal_Literal_String,
- AAMPS_Safe_Last'Universal_Literal_String,
- AAMPL_Safe_Last'Universal_Literal_String);
+ Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
----------------
-- Safe_Small --
-- Ada 83 Safe_Small for floating-point cases
else
- Float_Attribute_Universal_Real (
- IEEES_Safe_Small'Universal_Literal_String,
- IEEEL_Safe_Small'Universal_Literal_String,
- IEEEX_Safe_Small'Universal_Literal_String,
- VAXFF_Safe_Small'Universal_Literal_String,
- VAXDF_Safe_Small'Universal_Literal_String,
- VAXGF_Safe_Small'Universal_Literal_String,
- AAMPS_Safe_Small'Universal_Literal_String,
- AAMPL_Safe_Small'Universal_Literal_String);
+ Fold_Ureal (N, Model_Small_Value (P_Type), Static);
end if;
-----------
when Attribute_Small =>
- -- The floating-point case is present only for Ada 83 compatability.
+ -- The floating-point case is present only for Ada 83 compatibility.
-- 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.
-- We treat protected types like task types. It would make more
-- sense to have another enumeration value, but after all the
-- whole point of this feature is to be exactly DEC compatible,
- -- and changing the type Type_Clas would not meet this requirement.
+ -- and changing the type Type_Class would not meet this requirement.
elsif Is_Protected_Type (Typ) then
Id := RE_Type_Class_Task;
-- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
Fold_Uint
- (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True);
+ (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type),
+ True);
end if;
-- Discrete types
else
declare
R : constant Entity_Id := Root_Type (P_Type);
- Lo : constant Uint :=
- Expr_Value (Type_Low_Bound (P_Type));
- Hi : constant Uint :=
- Expr_Value (Type_High_Bound (P_Type));
+ Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
+ Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
W : Nat;
Wt : Nat;
T : Uint;
-- Width for types derived from Standard.Character
-- and Standard.Wide_[Wide_]Character.
- elsif R = Standard_Character
- or else R = Standard_Wide_Character
- or else R = Standard_Wide_Wide_Character
- then
+ elsif Is_Standard_Character_Type (P_Type) then
W := 0;
-- Set W larger if needed
-- All wide characters look like Hex_hhhhhhhh
if J > 255 then
- W := 12;
+
+ -- No need to compute this more than once!
+
+ exit;
else
C := Character'Val (J);
case C is
when Reserved_128 | Reserved_129 |
Reserved_132 | Reserved_153
-
=> Wt := 12;
when BS | HT | LF | VT | FF | CR |
SO | SI | EM | FS | GS | RS |
US | RI | MW | ST | PM
-
=> Wt := 2;
when NUL | SOH | STX | ETX | EOT |
SS2 | SS3 | DCS | PU1 | PU2 |
STS | CCH | SPA | EPA | SOS |
SCI | CSI | OSC | APC
-
=> Wt := 3;
when Space .. Tilde |
No_Break_Space .. LC_Y_Diaeresis
-
- => Wt := 3;
+ =>
+ -- Special case of soft hyphen in Ada 2005
+
+ if C = Character'Val (16#AD#)
+ and then Ada_Version >= Ada_2005
+ then
+ Wt := 11;
+ else
+ Wt := 3;
+ end if;
end case;
W := Int'Max (W, Wt);
end if;
end Width;
+ -- The following attributes denote functions 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 |
Attribute_Elab_Spec |
Attribute_Enabled |
Attribute_External_Tag |
+ Attribute_Fast_Math |
Attribute_First_Bit |
Attribute_Input |
Attribute_Last_Bit |
Attribute_Maximum_Alignment |
+ Attribute_Old |
Attribute_Output |
Attribute_Partition_ID |
Attribute_Pool_Address |
Attribute_Position |
Attribute_Priority |
Attribute_Read |
+ Attribute_Result |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |
Attribute_Target_Name |
Attribute_Terminated |
Attribute_To_Address |
+ Attribute_Type_Key |
Attribute_UET_Address |
Attribute_Unchecked_Access |
Attribute_Universal_Literal_String |
-- 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
- or else Nkind (N) = N_String_Literal
+ if Nkind_In (N, N_Integer_Literal,
+ N_Real_Literal,
+ N_Character_Literal,
+ N_String_Literal)
or else (Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Enumeration_Literal)
then
-- 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 ("?non-local pointer cannot point to local object", P);
Error_Msg_F
("\?Program_Error will be raised at run time", P);
Rewrite (N,
return;
else
- Error_Msg_F
- ("non-local pointer cannot point to local object", P);
+ 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)
+ Nkind_In (Parent (N), N_Discriminant_Association,
+ N_Index_Or_Discriminant_Constraint)
then
Indic := Parent (Parent (N));
while Present (Indic)
-- 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
- -- indices than nothing at all (see Check_Array_Type).
+ -- If error during analysis, no point in continuing, except for array
+ -- types, where we get better recovery by using unconstrained indexes
+ -- than nothing at all (see Check_Array_Type).
if Error_Posted (N)
and then Attr_Id /= Attribute_First
| Attribute_Unchecked_Access
| Attribute_Unrestricted_Access =>
- Access_Attribute : begin
+ Access_Attribute :
+ begin
if Is_Variable (P) then
- Note_Possible_Modification (P);
+ 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 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));
+
+ -- Avoid insertion of freeze actions in spec expression mode
+
+ if not In_Spec_Expression then
+ Freeze_Before (N, Entity (P));
end if;
elsif Is_Type (Entity (P)) then
-- also be accessibility checks on those, this is where the
-- checks can eventually be centralized ???
- 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
+ if Ekind_In (Btyp, E_Access_Subprogram_Type,
+ E_Anonymous_Access_Subprogram_Type,
+ E_Anonymous_Access_Protected_Subprogram_Type)
then
-- Deal with convention mismatch
-- 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);
-- 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
+
+ -- The rule also prohibits applying the attribute 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
-- when within an instance, because any violations will have
-- been caught by the compilation of the generic unit.
+ -- Note that we relax this check in CodePeer mode for
+ -- compatibility with legacy code, since CodePeer is an
+ -- Ada source code analyzer, not a strict compiler.
+ -- ??? Note that a better approach would be to have a
+ -- separate switch to relax this rule, and enable this
+ -- switch in CodePeer mode.
+
elsif Attr_Id = Attribute_Access
+ and then not CodePeer_Mode
and then not In_Instance
and then Present (Enclosing_Generic_Unit (Entity (P)))
and then Present (Enclosing_Generic_Body (N))
-- 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.
+ -- 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))
end if;
end if;
+ Des_Btyp := Designated_Type (Btyp);
+
+ if Ada_Version >= Ada_2005
+ and then Is_Incomplete_Type (Des_Btyp)
+ then
+ -- Ada 2005 (AI-412): If the (sub)type is a limited view of an
+ -- imported entity, and the non-limited view is visible, make
+ -- use of it. If it is an incomplete subtype, use the base type
+ -- in any case.
+
+ if From_With_Type (Des_Btyp)
+ and then Present (Non_Limited_View (Des_Btyp))
+ then
+ Des_Btyp := Non_Limited_View (Des_Btyp);
+
+ elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then
+ Des_Btyp := Etype (Des_Btyp);
+ end if;
+ end if;
+
if (Attr_Id = Attribute_Access
or else
Attr_Id = Attribute_Unchecked_Access)
-- components, and return objects. For a component definition
-- the level is the same of the enclosing composite type.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Is_Local_Anonymous_Access (Btyp)
and then Object_Access_Level (P) > Type_Access_Level (Btyp)
and then Attr_Id = Attribute_Access
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
-- (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)
+ elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then
+ null;
+
+ elsif Has_Discriminants (Designated_Type (Typ))
+ and then not Is_Constrained (Des_Btyp)
and then
- not (Has_Discriminants (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)))))
+ (Ada_Version < Ada_2005
+ or else
+ not Has_Constrained_Partial_View
+ (Designated_Type (Base_Type (Typ))))
then
+ null;
+
+ else
Error_Msg_F
("object subtype must statically match "
& "designated subtype", P);
end if;
end if;
- if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
- or else
- Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
+ if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Protected_Subprogram_Type)
then
if Is_Entity_Name (P)
and then not Is_Protected_Type (Scope (Entity (P)))
return;
end if;
- elsif (Ekind (Btyp) = E_Access_Subprogram_Type
- or else
- Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type)
+ elsif Ekind_In (Btyp, E_Access_Subprogram_Type,
+ E_Anonymous_Access_Subprogram_Type)
and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
then
Error_Msg_F ("context requires a non-protected subprogram", P);
-- it may be modified via this address, so note modification.
if Is_Variable (P) then
- Note_Possible_Modification (P);
+ Note_Possible_Modification (P, Sure => False);
end if;
if Nkind (P) in N_Subexpr
if Is_Entity_Name (P) then
Set_Address_Taken (Entity (P));
end if;
+
+ if Nkind (P) = N_Slice then
+
+ -- Arr (X .. Y)'address is identical to Arr (X)'address,
+ -- even if the array is packed and the slice itself is not
+ -- addressable. Transform the prefix into an indexed component.
+
+ -- Note that the transformation is safe only if we know that
+ -- the slice is non-null. That is because a null slice can have
+ -- an out of bounds index value.
+
+ -- Right now, gigi blows up if given 'Address on a slice as a
+ -- result of some incorrect freeze nodes generated by the front
+ -- end, and this covers up that bug in one case, but the bug is
+ -- likely still there in the cases not handled by this code ???
+
+ -- It's not clear what 'Address *should* return for a null
+ -- slice with out of bounds indexes, this might be worth an ARG
+ -- discussion ???
+
+ -- One approach would be to do a length check unconditionally,
+ -- and then do the transformation below unconditionally, but
+ -- analyze with checks off, avoiding the problem of the out of
+ -- bounds index. This approach would interpret the address of
+ -- an out of bounds null slice as being the address where the
+ -- array element would be if there was one, which is probably
+ -- as reasonable an interpretation as any ???
+
+ declare
+ Loc : constant Source_Ptr := Sloc (P);
+ D : constant Node_Id := Discrete_Range (P);
+ Lo : Node_Id;
+
+ begin
+ if Is_Entity_Name (D)
+ and then
+ Not_Null_Range
+ (Type_Low_Bound (Entity (D)),
+ Type_High_Bound (Entity (D)))
+ then
+ Lo :=
+ Make_Attribute_Reference (Loc,
+ Prefix => (New_Occurrence_Of (Entity (D), Loc)),
+ Attribute_Name => Name_First);
+
+ elsif Nkind (D) = N_Range
+ and then Not_Null_Range (Low_Bound (D), High_Bound (D))
+ then
+ Lo := Low_Bound (D);
+
+ else
+ Lo := Empty;
+ end if;
+
+ if Present (Lo) then
+ Rewrite (P,
+ Make_Indexed_Component (Loc,
+ Prefix => Relocate_Node (Prefix (P)),
+ Expressions => New_List (Lo)));
+
+ Analyze_And_Resolve (P);
+ end if;
+ end;
+ end if;
end Address_Attribute;
---------------
Process_Partition_Id (N);
return;
+ ------------------
+ -- Pool_Address --
+ ------------------
+
when Attribute_Pool_Address =>
Resolve (P);
-- Range --
-----------
- -- We replace the Range attribute node with a range expression
- -- whose bounds are the 'First and 'Last attributes applied to the
- -- same prefix. The reason that we do this transformation here
- -- instead of in the expander is that it simplifies other parts of
- -- the semantic analysis which assume that the Range has been
- -- replaced; thus it must be done even when in semantic-only mode
- -- (note that the RM specifically mentions this equivalence, we
- -- take care that the prefix is only evaluated once).
+ -- We replace the Range attribute node with a range expression whose
+ -- bounds are the 'First and 'Last attributes applied to the same
+ -- prefix. The reason that we do this transformation here instead of
+ -- in the expander is that it simplifies other parts of the semantic
+ -- analysis which assume that the Range has been replaced; thus it
+ -- must be done even when in semantic-only mode (note that the RM
+ -- specifically mentions this equivalence, we take care that the
+ -- prefix is only evaluated once).
when Attribute_Range => Range_Attribute :
declare
LB : Node_Id;
HB : Node_Id;
- function Check_Discriminated_Prival
- (N : Node_Id)
- return Node_Id;
- -- The range of a private component constrained by a
- -- discriminant is rewritten to make the discriminant
- -- 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
- is
- begin
- if Is_Entity_Name (N)
- and then Ekind (Entity (N)) = E_In_Parameter
- and then not Within_Init_Proc
- then
- return Make_Identifier (Sloc (N), Chars (Entity (N)));
- else
- return Duplicate_Subexpr (N);
- end if;
- end Check_Discriminated_Prival;
-
- -- Start of processing for Range_Attribute
-
begin
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
Resolve (P);
end if;
- -- Check whether prefix is (renaming of) private component
- -- of protected type.
-
- if Is_Entity_Name (P)
- and then Comes_From_Source (N)
- and then Is_Array_Type (Etype (P))
- and then Number_Dimensions (Etype (P)) = 1
- and then (Ekind (Scope (Entity (P))) = E_Protected_Type
- or else
- Ekind (Scope (Scope (Entity (P)))) =
- E_Protected_Type)
- then
- LB :=
- Check_Discriminated_Prival
- (Type_Low_Bound (Etype (First_Index (Etype (P)))));
-
- HB :=
- Check_Discriminated_Prival
- (Type_High_Bound (Etype (First_Index (Etype (P)))));
-
- else
- HB :=
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (P),
- Attribute_Name => Name_Last,
- Expressions => Expressions (N));
+ HB :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Duplicate_Subexpr (P, Name_Req => True),
+ Attribute_Name => Name_Last,
+ Expressions => Expressions (N));
- LB :=
- Make_Attribute_Reference (Loc,
- Prefix => P,
- Attribute_Name => Name_First,
- Expressions => Expressions (N));
- end if;
+ LB :=
+ Make_Attribute_Reference (Loc,
+ Prefix => P,
+ Attribute_Name => Name_First,
+ Expressions => Expressions (N));
-- If the original was marked as Must_Not_Freeze (see code
-- in Sem_Ch3.Make_Index), then make sure the rewriting
Rewrite (N, Make_Range (Loc, LB, HB));
Analyze_And_Resolve (N, Typ);
+ -- Ensure that the expanded range does not have side effects
+
+ Force_Evaluation (LB);
+ Force_Evaluation (HB);
+
-- Normally after resolving attribute nodes, Eval_Attribute
-- is called to do any possible static evaluation of the node.
-- However, here since the Range attribute has just been
return;
end Range_Attribute;
+ ------------
+ -- Result --
+ ------------
+
+ -- We will only come here during the prescan of a spec expression
+ -- containing a Result attribute. In that case the proper Etype has
+ -- already been set, and nothing more needs to be done here.
+
+ when Attribute_Result =>
+ null;
+
-----------------
-- UET_Address --
-----------------
-- 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 Ada_Version >= Ada_2005
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 Ada_Version >= Ada_2005
and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
then
return True;
end if;
end loop;
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
-- In Ada 95 mode, also consider a non-visible definition
OSDN Git Service
