Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / sem_attr.adb
blob: 33179aa2f8798dbb0bb7cddafae1edae49ed030d [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ A T T R --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Eval_Fat;
with Exp_Dist; use Exp_Dist;
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 Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with 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_Dim; use Sem_Dim;
with Sem_Dist; use Sem_Dist;
with Sem_Elab; use Sem_Elab;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with System;
with Stringt; use Stringt;
with Strub; use Strub;
with Style;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Uname; use Uname;
with Urealp; use Urealp;
with System.CRC32; use System.CRC32;
package body Sem_Attr is
True_Value : constant Uint := Uint_1;
False_Value : constant Uint := Uint_0;
-- Synonyms to be used when these constants are used as Boolean values
Bad_Attribute : exception;
-- Exception raised if an error is detected during attribute processing,
-- used so that we can abandon the processing so we don't run into
-- trouble with cascaded errors.
-- The following array is the list of attributes defined in the Ada 83 RM.
-- In Ada 83 mode, these are the only recognized attributes. In other Ada
-- modes all these attributes are recognized, even if removed in Ada 95.
Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Address |
Attribute_Aft |
Attribute_Alignment |
Attribute_Base |
Attribute_Callable |
Attribute_Constrained |
Attribute_Count |
Attribute_Delta |
Attribute_Digits |
Attribute_Emax |
Attribute_Epsilon |
Attribute_First |
Attribute_First_Bit |
Attribute_Fore |
Attribute_Image |
Attribute_Large |
Attribute_Last |
Attribute_Last_Bit |
Attribute_Leading_Part |
Attribute_Length |
Attribute_Machine_Emax |
Attribute_Machine_Emin |
Attribute_Machine_Mantissa |
Attribute_Machine_Overflows |
Attribute_Machine_Radix |
Attribute_Machine_Rounds |
Attribute_Mantissa |
Attribute_Pos |
Attribute_Position |
Attribute_Pred |
Attribute_Range |
Attribute_Safe_Emax |
Attribute_Safe_Large |
Attribute_Safe_Small |
Attribute_Size |
Attribute_Small |
Attribute_Storage_Size |
Attribute_Succ |
Attribute_Terminated |
Attribute_Val |
Attribute_Value |
Attribute_Width => True,
others => False);
-- The following array is the list of attributes defined in the Ada 2005
-- RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
-- but in Ada 95 they are considered to be implementation defined.
Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Machine_Rounding |
Attribute_Mod |
Attribute_Priority |
Attribute_Stream_Size |
Attribute_Wide_Wide_Width => True,
others => False);
-- The following array is the list of attributes defined in the Ada 2012
-- RM which are not defined in Ada 2005. These are recognized in Ada 95
-- and Ada 2005 modes, but are considered to be implementation defined.
Attribute_12 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_First_Valid |
Attribute_Has_Same_Storage |
Attribute_Last_Valid |
Attribute_Max_Alignment_For_Allocation => True,
others => False);
-- The following array is the list of attributes defined in the Ada 2022
-- RM which are not defined in Ada 2012. These are recognized in Ada
-- 95/2005/2012 modes, but are considered to be implementation defined.
Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Enum_Rep |
Attribute_Enum_Val => True,
Attribute_Preelaborable_Initialization => True,
others => False);
-- The following array contains all attributes that imply a modification
-- of their prefixes or result in an access value. Such prefixes can be
-- considered as lvalues.
Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
Attribute_Class_Array'(
Attribute_Access |
Attribute_Address |
Attribute_Input |
Attribute_Read |
Attribute_Unchecked_Access |
Attribute_Unrestricted_Access => True,
others => False);
-----------------------
-- Local_Subprograms --
-----------------------
procedure Eval_Attribute (N : Node_Id);
-- Performs compile time evaluation of attributes where possible, leaving
-- the Is_Static_Expression/Raises_Constraint_Error flags appropriately
-- set, and replacing the node with a literal node if the value can be
-- computed at compile time. All static attribute references are folded,
-- as well as a number of cases of non-static attributes that can always
-- be computed at compile time (e.g. floating-point model attributes that
-- are applied to non-static subtypes). Of course in such cases, the
-- Is_Static_Expression flag will not be set on the resulting literal.
-- Note that the only required action of this procedure is to catch the
-- static expression cases as described in the RM. Folding of other cases
-- is done where convenient, but some additional non-static folding is in
-- Expand_N_Attribute_Reference in cases where this is more convenient.
function Is_Anonymous_Tagged_Base
(Anon : Entity_Id;
Typ : Entity_Id) return Boolean;
-- For derived tagged types that constrain parent discriminants we build
-- an anonymous unconstrained base type. We need to recognize the relation
-- between the two when analyzing an access attribute for a constrained
-- component, before the full declaration for Typ has been analyzed, and
-- where therefore the prefix of the attribute does not match the enclosing
-- scope.
procedure Set_Boolean_Result (N : Node_Id; B : Boolean);
-- Rewrites node N with an occurrence of either Standard_False or
-- Standard_True, depending on the value of the parameter B. The
-- result is marked as a static expression.
-----------------------
-- Analyze_Attribute --
-----------------------
procedure Analyze_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Aname : constant Name_Id := Attribute_Name (N);
Exprs : constant List_Id := Expressions (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
P_Old : constant Node_Id := Prefix (N);
P : Node_Id := P_Old;
E1 : Node_Id;
E2 : Node_Id;
P_Type : Entity_Id := Empty;
-- Type of prefix after analysis
P_Base_Type : Entity_Id := Empty;
-- Base type of prefix after analysis
-----------------------
-- Local Subprograms --
-----------------------
procedure Address_Checks;
-- Semantic checks for valid use of Address attribute. This was made
-- a separate routine with the idea of using it for unrestricted access
-- which seems like it should follow the same rules, but that turned
-- out to be impractical. So now this is only used for Address.
procedure Analyze_Access_Attribute;
-- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
-- Internally, Id distinguishes which of the three cases is involved.
procedure Analyze_Attribute_Old_Result
(Legal : out Boolean;
Spec_Id : out Entity_Id);
-- Common processing for attributes 'Old and 'Result. The routine checks
-- that the attribute appears in a postcondition-like aspect or pragma
-- associated with a suitable subprogram or a body. Flag Legal is set
-- when the above criteria are met. Spec_Id denotes the entity of the
-- subprogram [body] or Empty if the attribute is illegal.
procedure Analyze_Image_Attribute (Str_Typ : Entity_Id);
-- Common processing for attributes 'Img, 'Image, 'Wide_Image, and
-- 'Wide_Wide_Image. The routine checks that the prefix is valid and
-- sets the type of the attribute to the one specified by Str_Typ (e.g.
-- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image).
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. This legality rule
-- only applies to scalar types.
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
-- of an array object, and that an argument appears only if appropriate
-- (i.e. only in the array case).
procedure Check_Array_Type;
-- Common semantic checks for all array attributes. Checks that the
-- prefix is a constrained array type or the name of an array object.
-- The error message for non-arrays is specialized appropriately.
procedure Check_Asm_Attribute;
-- Common semantic checks for Asm_Input and Asm_Output attributes
procedure Check_Component;
-- Common processing for Bit_Position, First_Bit, Last_Bit, and
-- Position. Checks prefix is an appropriate selected component.
procedure Check_Decimal_Fixed_Point_Type;
-- Check that prefix of attribute N is a decimal fixed-point type
procedure Check_Dereference;
-- If the prefix of attribute is an object of an access type, then
-- 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_E0;
-- Check that no attribute arguments are present
procedure Check_Either_E0_Or_E1;
-- Check that there are zero or one attribute arguments present
procedure Check_E1;
-- Check that exactly one attribute argument is present
procedure Check_E2;
-- Check that two attribute arguments are present
procedure Check_Enum_Image (Check_Enumeration_Maps : Boolean := False);
-- Common processing for the Image and Value family of attributes,
-- including their Wide and Wide_Wide versions, Enum_Val, Img,
-- and Valid_Value.
--
-- If the prefix type of an attribute is an enumeration type, set all
-- its literals as referenced, since the attribute function can
-- indirectly reference any of the literals. Set the referenced flag
-- only if the attribute is in the main code unit; otherwise an
-- improperly set reference when analyzing an inlined body will lose a
-- proper warning on a useless with_clause.
--
-- If Check_Enumeration_Maps is True, then the attribute expansion
-- requires enumeration maps, so check whether restriction
-- No_Enumeration_Maps is active.
procedure Check_First_Last_Valid;
-- Perform all checks for First_Valid and Last_Valid attributes
procedure Check_Fixed_Point_Type;
-- Verify that prefix of attribute N is a fixed type
procedure Check_Fixed_Point_Type_0;
-- Verify that prefix of attribute N is a fixed type and that
-- no attribute expressions are present.
procedure Check_Floating_Point_Type;
-- Verify that prefix of attribute N is a float type
procedure Check_Floating_Point_Type_0;
-- Verify that prefix of attribute N is a float type and that
-- no attribute expressions are present.
procedure Check_Floating_Point_Type_1;
-- Verify that prefix of attribute N is a float type and that
-- exactly one attribute expression is present.
procedure Check_Floating_Point_Type_2;
-- Verify that prefix of attribute N is a float type and that
-- two attribute expressions are present.
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.
procedure Check_Object_Reference (P : Node_Id);
-- Check that P is an object reference
procedure Check_PolyORB_Attribute;
-- Validity checking for PolyORB/DSA attribute
procedure Check_Program_Unit;
-- Verify that prefix of attribute N is a program unit
procedure Check_Real_Type;
-- Verify that prefix of attribute N is fixed or float type
procedure Check_Enumeration_Type;
-- Verify that prefix of attribute N is an enumeration type
procedure Check_Scalar_Type;
-- Verify that prefix of attribute N is a scalar type
procedure Check_Standard_Prefix;
-- Verify that prefix of attribute N is package Standard. Also checks
-- that there are no arguments.
procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
-- Validity checking for stream attribute. Nam is the TSS name of the
-- corresponding possible defined attribute function (e.g. for the
-- Read attribute, Nam will be TSS_Stream_Read).
procedure Check_Put_Image_Attribute;
-- Validity checking for Put_Image attribute
procedure Check_System_Prefix;
-- Verify that prefix of attribute N is package System
procedure Check_Task_Prefix;
-- Verify that prefix of attribute N is a task or task type
procedure Check_Type;
-- Verify that the prefix of attribute N is a type
procedure Check_Unit_Name (Nod : Node_Id);
-- Check that Nod is of the form of a library unit name, i.e that
-- it is an identifier, or a selected component whose prefix is
-- itself of the form of a library unit name. Note that this is
-- quite different from Check_Program_Unit, since it only checks
-- the syntactic form of the name, not the semantic identity. This
-- is because it is used with attributes (Elab_Body, Elab_Spec and
-- Elaborated) which can refer to non-visible unit.
procedure Error_Attr (Msg : String; Error_Node : Node_Id);
pragma No_Return (Error_Attr);
procedure Error_Attr;
pragma No_Return (Error_Attr);
-- Posts error using Error_Msg_N at given node, sets type of attribute
-- node to Any_Type, and then raises Bad_Attribute to avoid any further
-- semantic processing. The message typically contains a % insertion
-- character which is replaced by the attribute name. The call with
-- no arguments is used when the caller has already generated the
-- required error messages.
procedure Error_Attr_P (Msg : String; Msg_Cont : String := "");
pragma No_Return (Error_Attr_P);
-- Like Error_Attr, but error is posted at the start of the prefix. The
-- second message Msg_Cont is useful to issue a continuation message
-- before raising Bad_Attribute.
procedure Legal_Formal_Attribute;
-- Common processing for attributes Definite and Has_Discriminants.
-- Checks that prefix is generic indefinite formal type.
procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
-- Common processing for attributes Max_Alignment_For_Allocation and
-- Max_Size_In_Storage_Elements.
procedure Min_Max;
-- Common processing for attributes Max and Min
procedure Standard_Attribute (Val : Int);
-- Used to process attributes whose prefix is package Standard which
-- yield values of type Universal_Integer. The attribute reference
-- node is rewritten with an integer literal of the given value which
-- is marked as static.
procedure Uneval_Old_Msg;
-- Called when Loop_Entry or Old is used in a potentially unevaluated
-- expression. Generates appropriate message or warning depending on
-- the setting of Opt.Uneval_Old (or flags in an N_Aspect_Specification
-- node in the aspect case).
procedure Unexpected_Argument (En : Node_Id);
pragma No_Return (Unexpected_Argument);
-- Signal unexpected attribute argument (En is the argument), and then
-- raises Bad_Attribute to avoid any further semantic processing.
procedure Validate_Non_Static_Attribute_Function_Call;
-- Called when processing an attribute that is a function call to a
-- non-static function, i.e. an attribute function that either takes
-- non-scalar arguments or returns a non-scalar result. Verifies that
-- such a call does not appear in a preelaborable context.
--------------------
-- Address_Checks --
--------------------
procedure Address_Checks is
begin
-- An Address attribute created by expansion is legal even when it
-- applies to other entity-denoting expressions.
if not Comes_From_Source (N) then
return;
-- Address attribute on a protected object self reference is legal
elsif Is_Protected_Self_Reference (P) then
return;
-- Address applied to an entity
elsif Is_Entity_Name (P) then
declare
Ent : constant Entity_Id := Entity (P);
begin
if Is_Subprogram (Ent) then
Set_Address_Taken (Ent);
Kill_Current_Values (Ent);
-- An Address attribute is accepted when generated by the
-- compiler for dispatching operation, and an error is
-- issued once the subprogram is frozen (to avoid confusing
-- errors about implicit uses of Address in the dispatch
-- table initialization).
if 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_Name_1 := Aname;
Error_Msg_N
("cannot take % of intrinsic subprogram", N);
end if;
-- Issue an error if prefix denotes an eliminated subprogram
else
Check_For_Eliminated_Subprogram (P, Ent);
end if;
-- Object or label reference
elsif Is_Object_Reference (P) or else Ekind (Ent) = E_Label then
Set_Address_Taken (Ent);
-- Deal with No_Implicit_Aliasing restriction
if Restriction_Check_Required (No_Implicit_Aliasing) then
if not Is_Aliased_View (P) then
Check_Restriction (No_Implicit_Aliasing, P);
else
Check_No_Implicit_Aliasing (P);
end if;
end if;
-- If we have an address of an object, and the attribute
-- comes from source, then set the object as potentially
-- source modified. We do this because the resulting address
-- can potentially be used to modify the variable and we
-- might not detect this, leading to some junk warnings.
Set_Never_Set_In_Source (Ent, False);
-- Allow Address to be applied to task or protected type,
-- returning null address (what is that about???)
elsif (Is_Concurrent_Type (Etype (Ent))
and then Etype (Ent) = Base_Type (Ent))
or else Ekind (Ent) = E_Package
or else Is_Generic_Unit (Ent)
then
Rewrite (N,
New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
-- Anything else is illegal
else
Error_Attr ("invalid prefix for % attribute", P);
end if;
end;
-- Object is OK
elsif Is_Object_Reference (P) then
return;
-- Subprogram called using dot notation
elsif Nkind (P) = N_Selected_Component
and then Is_Subprogram (Entity (Selector_Name (P)))
then
return;
-- What exactly are we allowing here ??? and is this properly
-- documented in the sinfo documentation for this node ???
elsif Relaxed_RM_Semantics
and then Nkind (P) = N_Attribute_Reference
then
return;
-- All other non-entity name cases are illegal
else
Error_Attr ("invalid prefix for % attribute", P);
end if;
end Address_Checks;
------------------------------
-- Analyze_Access_Attribute --
------------------------------
procedure Analyze_Access_Attribute is
Acc_Type : Entity_Id;
Scop : Entity_Id;
Typ : Entity_Id;
function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
-- Build an access-to-object type whose designated type is DT,
-- and whose Ekind is appropriate to the attribute type. The
-- 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 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
-- within an aggregate, where it is obtained by expansion of
-- a defaulted aggregate. The enclosing aggregate that contains
-- the self-referenced is flagged so that the self-reference can
-- be expanded into a reference to the target object (see exp_aggr).
------------------------------
-- Build_Access_Object_Type --
------------------------------
function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
Typ : constant Entity_Id :=
New_Internal_Entity
(E_Access_Attribute_Type, Current_Scope, Loc, 'A');
begin
Set_Etype (Typ, Typ);
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, N);
Set_Directly_Designated_Type (Typ, DT);
return Typ;
end Build_Access_Object_Type;
----------------------------------
-- Build_Access_Subprogram_Type --
----------------------------------
procedure Build_Access_Subprogram_Type (P : Node_Id) is
Index : Interp_Index;
It : Interp;
procedure Check_Local_Access (E : Entity_Id);
-- Deal with possible access to local subprogram. If we have such
-- an access, we set a flag to kill all tracked values on any call
-- because this access value may be passed around, and any called
-- code might use it to access a local procedure which clobbers a
-- tracked value. If the scope is a loop or block, indicate that
-- value tracking is disabled for the enclosing subprogram.
function Get_Convention (E : Entity_Id) return Convention_Id;
function Get_Kind (E : Entity_Id) return Entity_Kind;
-- Distinguish between access to regular/protected subprograms
------------------------
-- Check_Local_Access --
------------------------
procedure Check_Local_Access (E : Entity_Id) is
begin
if not Is_Library_Level_Entity (E) then
Set_Suppress_Value_Tracking_On_Call (Current_Scope);
Set_Suppress_Value_Tracking_On_Call
(Nearest_Dynamic_Scope (Current_Scope));
end if;
end Check_Local_Access;
--------------------
-- Get_Convention --
--------------------
function Get_Convention (E : Entity_Id) return Convention_Id is
begin
-- Restrict handling by_protected_procedure access subprograms
-- to source entities; required to avoid building access to
-- subprogram types with convention protected when building
-- dispatch tables.
if Comes_From_Source (P)
and then Is_By_Protected_Procedure (E)
then
return Convention_Protected;
else
return Convention (E);
end if;
end Get_Convention;
--------------
-- Get_Kind --
--------------
function Get_Kind (E : Entity_Id) return Entity_Kind is
begin
if Get_Convention (E) = Convention_Protected then
return E_Access_Protected_Subprogram_Type;
else
return E_Access_Subprogram_Type;
end if;
end Get_Kind;
-- Start of processing for Build_Access_Subprogram_Type
begin
-- In the case of an access to subprogram, use the name of the
-- subprogram itself as the designated type. Type-checking in
-- this case compares the signatures of the designated types.
-- 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 := Create_Itype (Get_Kind (Entity (P)), N);
Set_Is_Public (Acc_Type, False);
Set_Etype (Acc_Type, Acc_Type);
Set_Convention (Acc_Type, Get_Convention (Entity (P)));
Set_Directly_Designated_Type (Acc_Type, Entity (P));
Set_Etype (N, Acc_Type);
Freeze_Before (N, Acc_Type);
end if;
else
Get_First_Interp (P, Index, It);
while Present (It.Nam) loop
Check_Local_Access (It.Nam);
if not Is_Intrinsic_Subprogram (It.Nam) then
Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
Set_Is_Public (Acc_Type, False);
Set_Etype (Acc_Type, Acc_Type);
Set_Convention (Acc_Type, Get_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);
end loop;
end if;
-- Cannot be applied to intrinsic. Looking at the tests above,
-- the only way Etype (N) can still be set to Any_Type is if
-- Is_Intrinsic_Subprogram was True for some referenced entity.
if Etype (N) = Any_Type then
Error_Attr_P ("prefix of % attribute cannot be intrinsic");
end if;
end Build_Access_Subprogram_Type;
----------------------
-- OK_Self_Reference --
----------------------
function OK_Self_Reference return Boolean is
Par : Node_Id;
begin
-- If N does not come from source, the reference is assumed to be
-- valid.
if not Comes_From_Source (N) then
return True;
end if;
Par := Parent (N);
while Present (Par)
and then
(Nkind (Par) = N_Component_Association
or else Nkind (Par) in N_Subexpr)
loop
if Nkind (Par) in N_Aggregate | N_Extension_Aggregate then
if Etype (Par) = Typ then
Set_Has_Self_Reference (Par);
-- Check the context: the aggregate must be part of the
-- initialization of a type or component, or it is the
-- resulting expansion in an initialization procedure.
if Is_Init_Proc (Current_Scope) then
return True;
else
Par := Parent (Par);
while Present (Par) loop
if Nkind (Par) = N_Full_Type_Declaration then
return True;
end if;
Par := Parent (Par);
end loop;
end if;
return False;
end if;
end if;
Par := Parent (Par);
end loop;
-- No enclosing aggregate, or not a self-reference
return False;
end OK_Self_Reference;
-- Start of processing for Analyze_Access_Attribute
begin
-- Access and Unchecked_Access are illegal in declare_expressions,
-- according to the RM. We also make the GNAT Unrestricted_Access
-- attribute illegal if it comes from source.
if In_Declare_Expr > 0
and then (Attr_Id /= Attribute_Unrestricted_Access
or else Comes_From_Source (N))
then
Error_Attr ("% attribute cannot occur in a declare_expression", N);
end if;
Check_E0;
if Nkind (P) = N_Character_Literal then
Error_Attr_P
("prefix of % attribute cannot be enumeration literal");
end if;
-- Preserve relevant elaboration-related attributes of the context
-- which are no longer available or very expensive to recompute once
-- analysis, resolution, and expansion are over.
Mark_Elaboration_Attributes
(N_Id => N,
Checks => True,
Modes => True,
Warnings => True);
-- Save the scenario for later examination by the ABE Processing
-- phase.
Record_Elaboration_Scenario (N);
-- Case of access to subprogram
if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then
if Has_Pragma_Inline_Always (Entity (P)) then
Error_Attr_P
("prefix of % attribute cannot be Inline_Always subprogram");
elsif Aname = Name_Unchecked_Access then
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);
-- For P'Access or P'Unrestricted_Access, where P is a nested
-- subprogram, we might be passing P to another subprogram (but we
-- don't check that here), which might call P. P could modify
-- local variables, so we need to kill current values. It is
-- important not to do this for library-level subprograms, because
-- Kill_Current_Values is very inefficient in the case of library
-- level packages with lots of tagged types.
if Is_Library_Level_Entity (Entity (Prefix (N))) then
null;
-- 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).
elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
and then (Is_RTE (Etype (Parent (N)), RE_Prim_Ptr)
or else
Is_RTE (Etype (Parent (N)), RE_Size_Ptr))
and then Is_Dispatching_Operation
(Directly_Designated_Type (Etype (N)))
then
null;
else
Kill_Current_Values;
end if;
-- In the static elaboration model, treat the attribute reference
-- as a subprogram call for elaboration purposes. Suppress this
-- treatment under debug flag. In any case, we are all done.
if Legacy_Elaboration_Checks
and not Dynamic_Elaboration_Checks
and not Debug_Flag_Dot_UU
then
Check_Elab_Call (N);
end if;
return;
-- Component is an operation of a protected type
elsif Nkind (P) = N_Selected_Component
and then Is_Overloadable (Entity (Selector_Name (P)))
then
if Ekind (Entity (Selector_Name (P))) = E_Entry then
Error_Attr_P ("prefix of % attribute must be subprogram");
end if;
Build_Access_Subprogram_Type (Selector_Name (P));
return;
end if;
-- Deal with incorrect reference to a type, but note that some
-- accesses are allowed: references to the current type instance,
-- or in Ada 2005 self-referential pointer in a default-initialized
-- aggregate.
if Is_Entity_Name (P) then
Typ := Entity (P);
-- The reference may appear in an aggregate that has been expanded
-- into a loop. Locate scope of type definition, if any.
Scop := Current_Scope;
while Ekind (Scop) = E_Loop loop
Scop := Scope (Scop);
end loop;
if Is_Type (Typ) then
-- OK if we are within the scope of a limited type
-- let's mark the component as having per object constraint
if Is_Anonymous_Tagged_Base (Scop, Typ) then
Typ := Scop;
Set_Entity (P, Typ);
Set_Etype (P, Typ);
end if;
-- A current instance typically appears immediately within
-- the type declaration, but may be nested within an internally
-- generated temporary scope - as for an aggregate of a
-- discriminated component.
if Typ = Scop
or else (In_Open_Scopes (Typ)
and then not Comes_From_Source (Scop))
then
declare
Q : Node_Id := Parent (N);
begin
while Present (Q)
and then Nkind (Q) /= N_Component_Declaration
loop
Q := Parent (Q);
end loop;
if Present (Q) then
Set_Has_Per_Object_Constraint
(Defining_Identifier (Q), True);
end if;
end;
if Nkind (P) = N_Expanded_Name then
Error_Msg_F
("current instance prefix must be a direct name", P);
end if;
-- 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_Spec_Expression
and then not Has_Completion (Scop)
and then
Nkind (Parent (N)) not in
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.
elsif Ekind (Scop) = E_Procedure
and then Is_Init_Proc (Scop)
and then Etype (First_Formal (Scop)) = Typ
then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Unrestricted_Access));
Analyze (N);
return;
-- OK if a task type, this test needs sharpening up ???
elsif Is_Task_Type (Typ) then
null;
-- OK if self-reference in an aggregate in Ada 2005, and
-- the reference comes from a copied default expression.
-- Note that we check legality of self-reference even if the
-- expression comes from source, e.g. when a single component
-- association in an aggregate has a box association.
elsif Ada_Version >= Ada_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
Error_Attr ("% attribute cannot be applied to type", P);
return;
end if;
end if;
end if;
-- If we fall through, we have a normal access to object case
-- Unrestricted_Access is (for now) legal wherever an allocator would
-- be legal, so its Etype is set to E_Allocator. The expected type
-- of the other attributes is a general access type, and therefore
-- we label them with E_Access_Attribute_Type.
if not Is_Overloaded (P) then
Acc_Type := Build_Access_Object_Type (P_Type);
Set_Etype (N, Acc_Type);
else
declare
Index : Interp_Index;
It : Interp;
begin
Set_Etype (N, Any_Type);
Get_First_Interp (P, Index, It);
while Present (It.Typ) loop
Acc_Type := Build_Access_Object_Type (It.Typ);
Add_One_Interp (N, Acc_Type, Acc_Type);
Get_Next_Interp (Index, It);
end loop;
end;
end if;
-- Special cases when we can find a prefix that is an entity name
declare
PP : Node_Id;
Ent : Entity_Id;
begin
PP := P;
loop
if Is_Entity_Name (PP) then
Ent := Entity (PP);
-- If we have an access to an object, and the attribute
-- comes from source, then set the object as potentially
-- source modified. We do this because the resulting access
-- pointer can be used to modify the variable, and we might
-- not detect this, leading to some junk warnings.
-- We only do this for source references, since otherwise
-- we can suppress warnings, e.g. from the unrestricted
-- access generated for validity checks in -gnatVa mode.
if Comes_From_Source (N) then
Set_Never_Set_In_Source (Ent, False);
end if;
-- Mark entity as address taken in the case of
-- 'Unrestricted_Access or subprograms, and kill current
-- values.
if Aname = Name_Unrestricted_Access
or else Is_Subprogram (Ent)
then
Set_Address_Taken (Ent);
end if;
Kill_Current_Values (Ent);
exit;
elsif Nkind (PP) in N_Selected_Component | N_Indexed_Component
then
PP := Prefix (PP);
else
exit;
end if;
end loop;
end;
end Analyze_Access_Attribute;
----------------------------------
-- Analyze_Attribute_Old_Result --
----------------------------------
procedure Analyze_Attribute_Old_Result
(Legal : out Boolean;
Spec_Id : out Entity_Id)
is
procedure Check_Placement_In_Check (Prag : Node_Id);
-- Verify that the attribute appears within pragma Check that mimics
-- a postcondition.
procedure Check_Placement_In_Contract_Cases (Prag : Node_Id);
-- Verify that the attribute appears within a consequence of aspect
-- or pragma Contract_Cases denoted by Prag.
procedure Check_Placement_In_Test_Case (Prag : Node_Id);
-- Verify that the attribute appears within the "Ensures" argument of
-- aspect or pragma Test_Case denoted by Prag.
function Is_Within
(Nod : Node_Id;
Encl_Nod : Node_Id) return Boolean;
-- Subsidiary to Check_Placement_In_XXX. Determine whether arbitrary
-- node Nod is within enclosing node Encl_Nod.
procedure Placement_Error;
pragma No_Return (Placement_Error);
-- Emit a general error when the attributes does not appear in a
-- postcondition-like aspect or pragma, and then raises Bad_Attribute
-- to avoid any further semantic processing.
------------------------------
-- Check_Placement_In_Check --
------------------------------
procedure Check_Placement_In_Check (Prag : Node_Id) is
Args : constant List_Id := Pragma_Argument_Associations (Prag);
Nam : constant Name_Id := Chars (Get_Pragma_Arg (First (Args)));
begin
-- The "Name" argument of pragma Check denotes a postcondition
if Nam in Name_Post
| Name_Post_Class
| Name_Postcondition
| Name_Refined_Post
then
null;
-- Otherwise the placement of the attribute is illegal
else
Placement_Error;
end if;
end Check_Placement_In_Check;
---------------------------------------
-- Check_Placement_In_Contract_Cases --
---------------------------------------
procedure Check_Placement_In_Contract_Cases (Prag : Node_Id) is
Arg : Node_Id;
Cases : Node_Id;
CCase : Node_Id;
begin
-- Obtain the argument of the aspect or pragma
if Nkind (Prag) = N_Aspect_Specification then
Arg := Prag;
else
Arg := First (Pragma_Argument_Associations (Prag));
end if;
Cases := Expression (Arg);
if Present (Component_Associations (Cases)) then
CCase := First (Component_Associations (Cases));
while Present (CCase) loop
-- Detect whether the attribute appears within the
-- consequence of the current contract case.
if Nkind (CCase) = N_Component_Association
and then Is_Within (N, Expression (CCase))
then
return;
end if;
Next (CCase);
end loop;
end if;
-- Otherwise aspect or pragma Contract_Cases is either malformed
-- or the attribute does not appear within a consequence.
Error_Attr
("attribute % must appear in the consequence of a contract case",
P);
end Check_Placement_In_Contract_Cases;
----------------------------------
-- Check_Placement_In_Test_Case --
----------------------------------
procedure Check_Placement_In_Test_Case (Prag : Node_Id) is
Arg : constant Node_Id :=
Test_Case_Arg
(Prag => Prag,
Arg_Nam => Name_Ensures,
From_Aspect => Nkind (Prag) = N_Aspect_Specification);
begin
-- Detect whether the attribute appears within the "Ensures"
-- expression of aspect or pragma Test_Case.
if Present (Arg) and then Is_Within (N, Arg) then
null;
else
Error_Attr
("attribute % must appear in the ensures expression of a "
& "test case", P);
end if;
end Check_Placement_In_Test_Case;
---------------
-- Is_Within --
---------------
function Is_Within
(Nod : Node_Id;
Encl_Nod : Node_Id) return Boolean
is
Par : Node_Id;
begin
Par := Nod;
while Present (Par) loop
if Par = Encl_Nod then
return True;
-- Prevent the search from going too far
elsif Is_Body_Or_Package_Declaration (Par) then
exit;
end if;
Par := Parent (Par);
end loop;
return False;
end Is_Within;
---------------------
-- Placement_Error --
---------------------
procedure Placement_Error is
begin
if Aname = Name_Old then
Error_Attr ("attribute % can only appear in postcondition", P);
-- Specialize the error message for attribute 'Result
else
Error_Attr
("attribute % can only appear in postcondition of function",
P);
end if;
end Placement_Error;
-- Local variables
Prag : Node_Id;
Prag_Nam : Name_Id;
Subp_Decl : Node_Id;
-- Start of processing for Analyze_Attribute_Old_Result
begin
-- Assume that the attribute is illegal
Legal := False;
Spec_Id := Empty;
-- Skip processing during preanalysis of class-wide preconditions and
-- postconditions since at this stage the expression is not installed
-- yet on its definite context.
if Inside_Class_Condition_Preanalysis then
Legal := True;
Spec_Id := Current_Scope;
return;
end if;
-- Traverse the parent chain to find the aspect or pragma where the
-- attribute resides.
Prag := N;
while Present (Prag) loop
if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
exit;
-- Prevent the search from going too far
elsif Is_Body_Or_Package_Declaration (Prag) then
exit;
end if;
Prag := Parent (Prag);
end loop;
-- The attribute is allowed to appear only in postcondition-like
-- aspects or pragmas.
if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
if Nkind (Prag) = N_Aspect_Specification then
Prag_Nam := Chars (Identifier (Prag));
else
Prag_Nam := Pragma_Name (Prag);
end if;
if Prag_Nam = Name_Check then
Check_Placement_In_Check (Prag);
elsif Prag_Nam = Name_Contract_Cases then
Check_Placement_In_Contract_Cases (Prag);
-- Attribute 'Result is allowed to appear in aspect or pragma
-- [Refined_]Depends (SPARK RM 6.1.5(11)).
elsif Prag_Nam in Name_Depends | Name_Refined_Depends
and then Aname = Name_Result
then
null;
-- Attribute 'Result is allowed to appear in aspect
-- Relaxed_Initialization (SPARK RM 6.10).
elsif Prag_Nam = Name_Relaxed_Initialization
and then Aname = Name_Result
then
null;
elsif Prag_Nam in Name_Post
| Name_Post_Class
| Name_Postcondition
| Name_Refined_Post
then
null;
elsif Prag_Nam = Name_Test_Case then
Check_Placement_In_Test_Case (Prag);
else
Placement_Error;
return;
end if;
-- 'Old attribute reference ok in a _Postconditions procedure
elsif Nkind (Prag) = N_Subprogram_Body
and then not Comes_From_Source (Prag)
and then Nkind (Corresponding_Spec (Prag)) = N_Defining_Identifier
and then Chars (Corresponding_Spec (Prag)) = Name_uPostconditions
then
null;
-- Otherwise the placement of the attribute is illegal
else
Placement_Error;
return;
end if;
-- Find the related subprogram subject to the aspect or pragma
if Nkind (Prag) = N_Aspect_Specification then
Subp_Decl := Parent (Prag);
elsif Nkind (Prag) = N_Subprogram_Body then
declare
Enclosing_Scope : constant Node_Id :=
Scope (Corresponding_Spec (Prag));
begin
pragma Assert (Postconditions_Proc (Enclosing_Scope)
= Corresponding_Spec (Prag));
Subp_Decl := Parent (Parent (Enclosing_Scope));
end;
else
Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
end if;
-- The aspect or pragma where the attribute resides should be
-- associated with a subprogram declaration or a body. If this is not
-- the case, then the aspect or pragma is illegal. Return as analysis
-- cannot be carried out. Note that it is legal to have the aspect
-- appear on a subprogram renaming, when the renamed entity is an
-- attribute reference.
-- Generating C code the internally built nested _postcondition
-- subprograms are inlined; after expanded, inlined aspects are
-- located in the internal block generated by the frontend.
if Nkind (Subp_Decl) = N_Block_Statement
and then Modify_Tree_For_C
and then In_Inlined_Body
then
null;
elsif Nkind (Subp_Decl) not in N_Abstract_Subprogram_Declaration
| N_Entry_Declaration
| N_Expression_Function
| N_Generic_Subprogram_Declaration
| N_Subprogram_Body
| N_Subprogram_Body_Stub
| N_Subprogram_Declaration
| N_Subprogram_Renaming_Declaration
then
return;
end if;
-- If we get here, then the attribute is legal
Legal := True;
Spec_Id := Unique_Defining_Entity (Subp_Decl);
-- When generating C code, nested _postcondition subprograms are
-- inlined by the front end to avoid problems (when unnested) with
-- referenced itypes. Handle that here, since as part of inlining the
-- expander nests subprogram within a dummy procedure named _parent
-- (see Build_Postconditions_Procedure and Build_Body_To_Inline).
-- Hence, in this context, the spec_id of _postconditions is the
-- enclosing scope.
if Modify_Tree_For_C
and then Chars (Spec_Id) = Name_uParent
and then Chars (Scope (Spec_Id)) = Name_uPostconditions
then
-- This situation occurs only when preanalyzing the inlined body
pragma Assert (not Full_Analysis);
Spec_Id := Scope (Spec_Id);
pragma Assert (Is_Inlined (Spec_Id));
end if;
end Analyze_Attribute_Old_Result;
-----------------------------
-- Analyze_Image_Attribute --
-----------------------------
procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is
procedure Check_Image_Type (Image_Type : Entity_Id);
-- Check that Image_Type is legal as the type of a prefix of 'Image.
-- Legality depends on the Ada language version.
----------------------
-- Check_Image_Type --
----------------------
procedure Check_Image_Type (Image_Type : Entity_Id) is
begin
-- Image_Type may be empty in case of another error detected,
-- or if an N_Raise_xxx_Error node is a parent of N.
if Ada_Version < Ada_2022
and then Present (Image_Type)
and then not Is_Scalar_Type (Image_Type)
then
Error_Msg_Ada_2022_Feature ("nonscalar ''Image", Sloc (P));
Error_Attr;
end if;
end Check_Image_Type;
-- Start of processing for Analyze_Image_Attribute
begin
-- AI12-0124: The ARG has adopted the GNAT semantics of 'Img for
-- scalar types, so that the prefix can be an object, a named value,
-- or a type. If the prefix is an object, there is no argument.
if Is_Object_Image (P) then
Check_E0;
Set_Etype (N, Str_Typ);
Check_Image_Type (Etype (P));
if Attr_Id /= Attribute_Img then
Error_Msg_Ada_2012_Feature ("|Object''Image", Sloc (P));
end if;
else
Check_E1;
Set_Etype (N, Str_Typ);
pragma Assert (Is_Entity_Name (P) and then Is_Type (Entity (P)));
if Ekind (Entity (P)) = E_Incomplete_Type
and then Present (Full_View (Entity (P)))
then
P_Type := Full_View (Entity (P));
P_Base_Type := Base_Type (P_Type);
Set_Entity (P, P_Type);
end if;
Check_Image_Type (P_Type);
Resolve (E1, P_Base_Type);
Validate_Non_Static_Attribute_Function_Call;
end if;
Check_Enum_Image (Check_Enumeration_Maps => True);
-- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
-- to avoid giving a duplicate message for when Image attributes
-- applied to object references get expanded into type-based Image
-- attributes.
if Restriction_Check_Required (No_Fixed_IO)
and then Comes_From_Source (N)
and then Is_Fixed_Point_Type (P_Type)
then
Check_Restriction (No_Fixed_IO, P);
end if;
end Analyze_Image_Attribute;
---------------------------------
-- Bad_Attribute_For_Predicate --
---------------------------------
procedure Bad_Attribute_For_Predicate is
begin
if Is_Scalar_Type (P_Type)
and then 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 --
--------------------------------
procedure Check_Array_Or_Scalar_Type is
function In_Aspect_Specification return Boolean;
-- A current instance of a type in an aspect specification is an
-- object and not a type, and therefore cannot be of a scalar type
-- in the prefix of one of the array attributes if the attribute
-- reference is part of an aspect expression.
-----------------------------
-- In_Aspect_Specification --
-----------------------------
function In_Aspect_Specification return Boolean is
P : Node_Id;
begin
P := Parent (N);
while Present (P) loop
if Nkind (P) = N_Aspect_Specification then
return P_Type = Entity (P);
elsif Nkind (P) in N_Declaration then
return False;
end if;
P := Parent (P);
end loop;
return False;
end In_Aspect_Specification;
-- Local variables
Index : Entity_Id;
-- Start of processing for Check_Array_Or_Scalar_Type
begin
-- Case of string literal or string literal subtype. These cases
-- cannot arise from legal Ada code, but the expander is allowed
-- to generate them. They require special handling because string
-- literal subtypes do not have standard bounds (the whole idea
-- of these subtypes is to avoid having to generate the bounds)
if Ekind (P_Type) = E_String_Literal_Subtype then
Set_Etype (N, Etype (First_Index (P_Base_Type)));
return;
-- Scalar types
elsif Is_Scalar_Type (P_Type) then
Check_Type;
if Present (E1) then
Error_Attr ("invalid argument in % attribute", E1);
elsif In_Aspect_Specification then
Error_Attr
("prefix of % attribute cannot be the current instance of a "
& "scalar type", P);
else
Set_Etype (N, P_Base_Type);
return;
end if;
-- The following is a special test to allow 'First to apply to
-- private scalar types if the attribute comes from generated
-- code. This occurs in the case of Normalize_Scalars code.
elsif Is_Private_Type (P_Type)
and then Present (Full_View (P_Type))
and then Is_Scalar_Type (Full_View (P_Type))
and then not Comes_From_Source (N)
then
Set_Etype (N, Implementation_Base_Type (P_Type));
-- Array types other than string literal subtypes handled above
else
Check_Array_Type;
-- We know prefix is an array type, or the name of an array
-- object, and that the expression, if present, is static
-- and within the range of the dimensions of the type.
pragma Assert (Is_Array_Type (P_Type));
Index := First_Index (P_Base_Type);
if No (E1) then
-- First dimension assumed
Set_Etype (N, Base_Type (Etype (Index)));
else
declare
Udims : constant Uint := Expr_Value (E1);
Dims : constant Int := UI_To_Int (Udims);
begin
for J in 1 .. Dims - 1 loop
Next_Index (Index);
end loop;
end;
Set_Etype (N, Base_Type (Etype (Index)));
end if;
end if;
end Check_Array_Or_Scalar_Type;
----------------------
-- Check_Array_Type --
----------------------
procedure Check_Array_Type is
D : Pos;
-- Dimension number for array attributes
begin
-- If the type is a string literal type, then this must be generated
-- internally, and no further check is required on its legality.
if Ekind (P_Type) = E_String_Literal_Subtype then
return;
-- If the type is a composite, it is an illegal aggregate, no point
-- in going on.
elsif P_Type = Any_Composite then
raise Bad_Attribute;
end if;
-- Normal case of array type or subtype. Note that if the
-- prefix is a current instance of a type declaration it
-- appears within an aspect specification and is legal.
Check_Either_E0_Or_E1;
Check_Dereference;
if Is_Array_Type (P_Type) then
if not Is_Constrained (P_Type)
and then Is_Entity_Name (P)
and then Is_Type (Entity (P))
and then not Is_Current_Instance (P)
then
-- Note: we do not call Error_Attr here, since we prefer to
-- continue, using the relevant index type of the array,
-- even though it is unconstrained. This gives better error
-- recovery behavior.
Error_Msg_Name_1 := Aname;
Error_Msg_F
("prefix for % attribute must be constrained array", P);
end if;
-- The attribute reference freezes the type, and thus the
-- component type, even if the attribute may not depend on the
-- component. Diagnose arrays with incomplete components now.
-- If the prefix is an access to array, this does not freeze
-- the designated type.
if Nkind (P) /= N_Explicit_Dereference then
Check_Fully_Declared (Component_Type (P_Type), P);
end if;
D := Number_Dimensions (P_Type);
else
if Is_Private_Type (P_Type) then
Error_Attr_P ("prefix for % attribute may not be private type");
elsif Is_Access_Type (P_Type)
and then Is_Array_Type (Designated_Type (P_Type))
and then Is_Entity_Name (P)
and then Is_Type (Entity (P))
then
Error_Attr_P ("prefix of % attribute cannot be access type");
elsif Attr_Id = Attribute_First
or else
Attr_Id = Attribute_Last
then
Error_Attr ("invalid prefix for % attribute", P);
else
Error_Attr_P ("prefix for % attribute must be array");
end if;
end if;
if Present (E1) then
Resolve (E1, Any_Integer);
Set_Etype (E1, Standard_Integer);
if not Is_OK_Static_Expression (E1)
or else Raises_Constraint_Error (E1)
then
Flag_Non_Static_Expr
("expression for dimension must be static!", E1);
Error_Attr;
elsif Expr_Value (E1) > D or else Expr_Value (E1) < 1 then
Error_Attr ("invalid dimension number for array type", E1);
end if;
end if;
if (Style_Check and Style_Check_Array_Attribute_Index)
and then Comes_From_Source (N)
then
Style.Check_Array_Attribute_Index (N, E1, D);
end if;
end Check_Array_Type;
-------------------------
-- Check_Asm_Attribute --
-------------------------
procedure Check_Asm_Attribute is
begin
Check_Type;
Check_E2;
-- Check first argument is static string expression
Analyze_And_Resolve (E1, Standard_String);
if Etype (E1) = Any_Type then
return;
elsif not Is_OK_Static_Expression (E1) then
Flag_Non_Static_Expr
("constraint argument must be static string expression!", E1);
Error_Attr;
end if;
-- Check second argument is right type
Analyze_And_Resolve (E2, Entity (P));
-- Note: that is all we need to do, we don't need to check
-- that it appears in a correct context. The Ada type system
-- will do that for us.
end Check_Asm_Attribute;
---------------------
-- Check_Component --
---------------------
procedure Check_Component is
begin
Check_E0;
if Nkind (P) /= N_Selected_Component
or else
(Ekind (Entity (Selector_Name (P))) /= E_Component
and then
Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
then
Error_Attr_P ("prefix for % attribute must be selected component");
end if;
end Check_Component;
------------------------------------
-- Check_Decimal_Fixed_Point_Type --
------------------------------------
procedure Check_Decimal_Fixed_Point_Type is
begin
Check_Type;
if not Is_Decimal_Fixed_Point_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be decimal type");
end if;
end Check_Decimal_Fixed_Point_Type;
-----------------------
-- Check_Dereference --
-----------------------
procedure Check_Dereference is
begin
-- Case of a subtype mark
if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
return;
end if;
-- Case of an expression
Resolve (P_Old);
if Is_Access_Type (P_Type) then
-- If there is an implicit dereference, then we must freeze the
-- designated type of the access type, since the type of the
-- referenced array is this type (see AI95-00106).
-- As done elsewhere, freezing must not happen when preanalyzing
-- 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_Old,
Make_Explicit_Dereference (Sloc (P_Old),
Prefix => Relocate_Node (P_Old)));
Analyze_And_Resolve (P_Old);
P_Type := Etype (P_Old);
if P_Type = Any_Type then
raise Bad_Attribute;
end if;
P_Base_Type := Base_Type (P_Type);
end if;
end Check_Dereference;
-------------------------
-- Check_Discrete_Type --
-------------------------
procedure Check_Discrete_Type is
begin
Check_Type;
if not Is_Discrete_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be discrete type");
end if;
end Check_Discrete_Type;
--------------
-- Check_E0 --
--------------
procedure Check_E0 is
begin
if Present (E1) then
Unexpected_Argument (E1);
end if;
end Check_E0;
--------------
-- Check_E1 --
--------------
procedure Check_E1 is
begin
Check_Either_E0_Or_E1;
if No (E1) then
-- Special-case attributes that are functions and that appear as
-- the prefix of another attribute. Error is posted on parent.
if Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) in Name_Address
| Name_Code_Address
| Name_Access
then
Error_Msg_Name_1 := Attribute_Name (Parent (N));
Error_Msg_N ("illegal prefix for % attribute", Parent (N));
Set_Etype (Parent (N), Any_Type);
Set_Entity (Parent (N), Any_Type);
raise Bad_Attribute;
else
Error_Attr ("missing argument for % attribute", N);
end if;
end if;
end Check_E1;
--------------
-- Check_E2 --
--------------
procedure Check_E2 is
begin
if No (E1) then
Error_Attr ("missing arguments for % attribute (2 required)", N);
elsif No (E2) then
Error_Attr ("missing argument for % attribute (2 required)", N);
end if;
end Check_E2;
---------------------------
-- Check_Either_E0_Or_E1 --
---------------------------
procedure Check_Either_E0_Or_E1 is
begin
if Present (E2) then
Unexpected_Argument (E2);
end if;
end Check_Either_E0_Or_E1;
----------------------
-- Check_Enum_Image --
----------------------
procedure Check_Enum_Image (Check_Enumeration_Maps : Boolean := False) is
Lit : Entity_Id;
begin
-- Ensure that Check_Enumeration_Maps parameter is set precisely for
-- attributes whose implementation requires enumeration maps.
pragma Assert
(Check_Enumeration_Maps = (Attr_Id in Attribute_Image
| Attribute_Img
| Attribute_Valid_Value
| Attribute_Value
| Attribute_Wide_Image
| Attribute_Wide_Value
| Attribute_Wide_Wide_Image
| Attribute_Wide_Wide_Value));
-- When an enumeration type appears in an attribute reference, all
-- literals of the type are marked as referenced. This must only be
-- done if the attribute reference appears in the current source.
-- Otherwise the information on references may differ between a
-- normal compilation and one that performs inlining.
if Is_Enumeration_Type (P_Base_Type)
and then In_Extended_Main_Code_Unit (N)
then
if Check_Enumeration_Maps then
Check_Restriction (No_Enumeration_Maps, N);
end if;
Lit := First_Literal (P_Base_Type);
while Present (Lit) loop
Set_Referenced (Lit);
Next_Literal (Lit);
end loop;
end if;
end Check_Enum_Image;
----------------------------
-- Check_First_Last_Valid --
----------------------------
procedure Check_First_Last_Valid is
begin
Check_Discrete_Type;
-- Freeze the subtype now, so that the following test for predicates
-- works (we set the predicates stuff up at freeze time)
Insert_Actions (N, Freeze_Entity (P_Type, P));
-- Now test for dynamic predicate
if Has_Predicates (P_Type)
and then not (Has_Static_Predicate (P_Type))
then
Error_Attr_P
("prefix of % attribute may not have dynamic predicate");
end if;
-- Check non-static subtype
if not Is_OK_Static_Subtype (P_Type) then
Error_Attr_P ("prefix of % attribute must be a static subtype");
end if;
-- Test case for no values
if Expr_Value (Type_Low_Bound (P_Type)) >
Expr_Value (Type_High_Bound (P_Type))
or else (Has_Predicates (P_Type)
and then
Is_Empty_List (Static_Discrete_Predicate (P_Type)))
then
Error_Attr_P
("prefix of % attribute must be subtype with at least one "
& "value");
end if;
end Check_First_Last_Valid;
----------------------------
-- Check_Fixed_Point_Type --
----------------------------
procedure Check_Fixed_Point_Type is
begin
Check_Type;
if not Is_Fixed_Point_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be fixed point type");
end if;
end Check_Fixed_Point_Type;
------------------------------
-- Check_Fixed_Point_Type_0 --
------------------------------
procedure Check_Fixed_Point_Type_0 is
begin
Check_Fixed_Point_Type;
Check_E0;
end Check_Fixed_Point_Type_0;
-------------------------------
-- Check_Floating_Point_Type --
-------------------------------
procedure Check_Floating_Point_Type is
begin
Check_Type;
if not Is_Floating_Point_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be float type");
end if;
end Check_Floating_Point_Type;
---------------------------------
-- Check_Floating_Point_Type_0 --
---------------------------------
procedure Check_Floating_Point_Type_0 is
begin
Check_Floating_Point_Type;
Check_E0;
end Check_Floating_Point_Type_0;
---------------------------------
-- Check_Floating_Point_Type_1 --
---------------------------------
procedure Check_Floating_Point_Type_1 is
begin
Check_Floating_Point_Type;
Check_E1;
end Check_Floating_Point_Type_1;
---------------------------------
-- Check_Floating_Point_Type_2 --
---------------------------------
procedure Check_Floating_Point_Type_2 is
begin
Check_Floating_Point_Type;
Check_E2;
end Check_Floating_Point_Type_2;
------------------------
-- Check_Integer_Type --
------------------------
procedure Check_Integer_Type is
begin
Check_Type;
if not Is_Integer_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be integer type");
end if;
end Check_Integer_Type;
--------------------------------
-- Check_Modular_Integer_Type --
--------------------------------
procedure Check_Modular_Integer_Type is
begin
Check_Type;
if not Is_Modular_Integer_Type (P_Type) then
Error_Attr_P
("prefix of % attribute must be modular integer type");
end if;
end Check_Modular_Integer_Type;
------------------------
-- Check_Not_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 --
-------------------------------
procedure Check_Not_Incomplete_Type is
E : Entity_Id;
Typ : Entity_Id;
begin
-- Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
-- dereference we have to check wrong uses of incomplete types
-- (other wrong uses are checked at their freezing point).
-- In Ada 2012, incomplete types can appear in subprogram
-- profiles, but formals with incomplete types cannot be the
-- prefix of attributes.
-- Example 1: Limited-with
-- limited with Pkg;
-- package P is
-- type Acc is access Pkg.T;
-- X : Acc;
-- S : Integer := X.all'Size; -- ERROR
-- end P;
-- Example 2: Tagged incomplete
-- type T is tagged;
-- type Acc is access all T;
-- X : Acc;
-- S : constant Integer := X.all'Size; -- ERROR
-- procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
if Ada_Version >= Ada_2005
and then Nkind (P) = N_Explicit_Dereference
then
E := P;
while Nkind (E) = N_Explicit_Dereference loop
E := Prefix (E);
end loop;
Typ := Etype (E);
if From_Limited_With (Typ) then
Error_Attr_P
("prefix of % attribute cannot be an incomplete type");
-- If the prefix is an access type check the designated type
elsif Is_Access_Type (Typ)
and then Nkind (P) = N_Explicit_Dereference
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_Limited_With (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 still incomplete, it can be a local incomplete type, or a
-- limited view whose scope is also a limited view.
if Ekind (Typ) = E_Incomplete_Type then
if not From_Limited_With (Typ)
and then No (Full_View (Typ))
then
Error_Attr_P
("prefix of % attribute cannot be an incomplete type");
-- The limited view may be available indirectly through
-- an intermediate unit. If the non-limited view is available
-- the attribute reference is legal.
elsif From_Limited_With (Typ)
and then
(No (Non_Limited_View (Typ))
or else Is_Incomplete_Type (Non_Limited_View (Typ)))
then
Error_Attr_P
("prefix of % attribute cannot be an incomplete type");
end if;
end if;
-- Ada 2012 : formals in bodies may be incomplete, but no attribute
-- legally applies.
elsif Is_Entity_Name (P)
and then Is_Formal (Entity (P))
and then Is_Incomplete_Type (Etype (Etype (P)))
then
Error_Attr_P
("prefix of % attribute cannot be an incomplete type");
end if;
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
or else In_Spec_Expression
then
return;
else
Check_Fully_Declared (P_Type, P);
end if;
end Check_Not_Incomplete_Type;
----------------------------
-- Check_Object_Reference --
----------------------------
procedure Check_Object_Reference (P : Node_Id) is
Rtyp : Entity_Id;
begin
-- If we need an object, and we have a prefix that is the name of a
-- function entity, convert it into a function call.
if Is_Entity_Name (P)
and then Ekind (Entity (P)) = E_Function
then
Rtyp := Etype (Entity (P));
Rewrite (P,
Make_Function_Call (Sloc (P),
Name => Relocate_Node (P)));
Analyze_And_Resolve (P, Rtyp);
-- Otherwise we must have an object reference
elsif not Is_Object_Reference (P) then
Error_Attr_P ("prefix of % attribute must be object");
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 --
------------------------
procedure Check_Program_Unit is
begin
if Is_Entity_Name (P) then
declare
E : constant Entity_Id := Entity (P);
begin
if Ekind (E) in E_Protected_Type
| E_Task_Type
| Entry_Kind
| Generic_Unit_Kind
| Subprogram_Kind
| E_Package
or else Is_Single_Concurrent_Object (E)
then
return;
end if;
end;
end if;
Error_Attr_P ("prefix of % attribute must be program unit");
end Check_Program_Unit;
---------------------
-- Check_Real_Type --
---------------------
procedure Check_Real_Type is
begin
Check_Type;
if not Is_Real_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be real type");
end if;
end Check_Real_Type;
----------------------------
-- Check_Enumeration_Type --
----------------------------
procedure Check_Enumeration_Type is
begin
Check_Type;
if not Is_Enumeration_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be enumeration type");
end if;
end Check_Enumeration_Type;
-----------------------
-- Check_Scalar_Type --
-----------------------
procedure Check_Scalar_Type is
begin
Check_Type;
if not Is_Scalar_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be scalar type");
end if;
end Check_Scalar_Type;
---------------------------
-- Check_Standard_Prefix --
---------------------------
procedure Check_Standard_Prefix is
begin
Check_E0;
if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then
Error_Attr ("only allowed prefix for % attribute is Standard", P);
end if;
end Check_Standard_Prefix;
-------------------------------
-- Check_Put_Image_Attribute --
-------------------------------
procedure Check_Put_Image_Attribute is
begin
-- Put_Image is a procedure, and can only appear at the position of a
-- procedure call. If it's a list member and it's parent is a
-- procedure call or aggregate, then this is appearing as an actual
-- parameter or component association, which is wrong.
if Is_List_Member (N)
and then Nkind (Parent (N)) not in
N_Procedure_Call_Statement | N_Aggregate
then
null;
else
Error_Attr
("invalid context for attribute%, which is a procedure", N);
end if;
Check_Type;
Analyze_And_Resolve (E1);
-- Check that the first argument is
-- Ada.Strings.Text_Buffers.Root_Buffer_Type'Class.
-- Note: the double call to Root_Type here is needed because the
-- root type of a class-wide type is the corresponding type (e.g.
-- X for X'Class, and we really want to go to the root.)
if not Is_RTE (Root_Type (Root_Type (Etype (E1))),
RE_Root_Buffer_Type)
then
Error_Attr
("expected Ada.Strings.Text_Buffers.Root_Buffer_Type''Class",
E1);
end if;
-- Check that the second argument is of the right type
Analyze (E2);
Resolve (E2, P_Type);
end Check_Put_Image_Attribute;
----------------------------
-- Check_Stream_Attribute --
----------------------------
procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
Etyp : Entity_Id;
Btyp : Entity_Id;
In_Shared_Var_Procs : Boolean;
-- True when compiling System.Shared_Storage.Shared_Var_Procs body.
-- 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;
-- With the exception of 'Input, Stream attributes are procedures,
-- and can only appear at the position of procedure calls. We check
-- for this here, before they are rewritten, to give a more precise
-- diagnostic.
if Nam = TSS_Stream_Input then
null;
elsif Is_List_Member (N)
and then Nkind (Parent (N)) not in
N_Procedure_Call_Statement | N_Aggregate
then
null;
else
Error_Attr
("invalid context for attribute%, which is a procedure", N);
end if;
Check_Type;
Btyp := Implementation_Base_Type (P_Type);
-- Stream attributes not allowed on limited types unless the
-- attribute reference was generated by the expander (in which
-- case the underlying type will be used, as described in Sinfo),
-- or the attribute was specified explicitly for the type itself
-- or one of its ancestors (taking visibility rules into account if
-- in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
-- (with no visibility restriction).
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
Error_Msg_Name_1 := Aname;
if Is_Limited_Type (P_Type) then
Error_Msg_NE
("limited type& has no% attribute", P, P_Type);
Explain_Limited_Type (P_Type, P);
else
Error_Msg_NE
("attribute% for type& is not available", P, P_Type);
end if;
end if;
-- Check for no stream operations allowed from No_Tagged_Streams
if Is_Tagged_Type (P_Type)
and then Present (No_Tagged_Streams_Pragma (P_Type))
then
Error_Msg_Sloc := Sloc (No_Tagged_Streams_Pragma (P_Type));
Error_Msg_NE
("no stream operations for & (No_Tagged_Streams #)", N, P_Type);
return;
end if;
-- 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;
-- AI05-0057: if restriction No_Default_Stream_Attributes is active,
-- it is illegal to use a predefined elementary type stream attribute
-- either by itself, or more importantly as part of the attribute
-- subprogram for a composite type. However, if the broader
-- restriction No_Streams is active, stream operations are not
-- generated, and there is no error.
if Restriction_Active (No_Default_Stream_Attributes)
and then not Restriction_Active (No_Streams)
then
declare
T : Entity_Id;
begin
if Nam = TSS_Stream_Input
or else
Nam = TSS_Stream_Read
then
T :=
Type_Without_Stream_Operation (P_Type, TSS_Stream_Read);
else
T :=
Type_Without_Stream_Operation (P_Type, TSS_Stream_Write);
end if;
if Present (T) then
Check_Restriction (No_Default_Stream_Attributes, N);
Error_Msg_NE
("missing user-defined Stream Read or Write for type&",
N, T);
if not Is_Elementary_Type (P_Type) then
Error_Msg_NE
("\which is a component of type&", N, P_Type);
end if;
end if;
end;
end if;
-- Check special case of Exception_Id and Exception_Occurrence which
-- are not allowed for restriction No_Exception_Registration.
if Restriction_Check_Required (No_Exception_Registration)
and then (Is_RTE (P_Type, RE_Exception_Id)
or else
Is_RTE (P_Type, RE_Exception_Occurrence))
then
Check_Restriction (No_Exception_Registration, P);
end if;
-- If the No_Tagged_Type_Registration restriction is active, then
-- class-wide streaming attributes are not allowed.
if Restriction_Check_Required (No_Tagged_Type_Registration)
and then Is_Class_Wide_Type (P_Type)
then
Check_Restriction (No_Tagged_Type_Registration, P);
end if;
-- Here we must check that the first argument is an access type
-- that is compatible with Ada.Streams.Root_Stream_Type'Class.
Analyze_And_Resolve (E1);
Etyp := Etype (E1);
-- Note: the double call to Root_Type here is needed because the
-- root type of a class-wide type is the corresponding type (e.g.
-- X for X'Class, and we really want to go to the root.)
if not Is_Access_Type (Etyp)
or else not Is_RTE (Root_Type (Root_Type (Designated_Type (Etyp))),
RE_Root_Stream_Type)
then
Error_Attr
("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
end if;
-- Check that the second argument is of the right type if there is
-- one (the Input attribute has only one argument so this is skipped)
if Present (E2) then
Analyze (E2);
if Nam = TSS_Stream_Read
and then not Is_OK_Variable_For_Out_Formal (E2)
then
Error_Attr
("second argument of % attribute must be a variable", E2);
end if;
Resolve (E2, P_Type);
end if;
Check_Not_CPP_Type;
end Check_Stream_Attribute;
-------------------------
-- Check_System_Prefix --
-------------------------
procedure Check_System_Prefix is
begin
if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
Error_Attr ("only allowed prefix for % attribute is System", P);
end if;
end Check_System_Prefix;
-----------------------
-- Check_Task_Prefix --
-----------------------
procedure Check_Task_Prefix is
begin
Analyze (P);
-- Ada 2005 (AI-345): Attribute 'Terminated can be applied to
-- task interface class-wide types.
if Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
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)))
then
Resolve (P);
else
if Ada_Version >= Ada_2005 then
Error_Attr_P
("prefix of % attribute must be a task or a task " &
"interface class-wide object");
else
Error_Attr_P ("prefix of % attribute must be a task");
end if;
end if;
end Check_Task_Prefix;
----------------
-- Check_Type --
----------------
-- The possibilities are an entity name denoting a type, or an
-- attribute reference that denotes a type (Base or Class). If
-- the type is incomplete, replace it with its full view.
procedure Check_Type is
begin
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
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
P_Type := Full_View (Entity (P));
Set_Entity (P, P_Type);
end if;
end Check_Type;
---------------------
-- Check_Unit_Name --
---------------------
procedure Check_Unit_Name (Nod : Node_Id) is
begin
if Nkind (Nod) = N_Identifier then
return;
elsif Nkind (Nod) in N_Selected_Component | N_Expanded_Name then
Check_Unit_Name (Prefix (Nod));
if Nkind (Selector_Name (Nod)) = N_Identifier then
return;
end if;
end if;
Error_Attr ("argument for % attribute must be unit name", P);
end Check_Unit_Name;
----------------
-- Error_Attr --
----------------
procedure Error_Attr is
begin
Set_Etype (N, Any_Type);
Set_Entity (N, Any_Type);
raise Bad_Attribute;
end Error_Attr;
procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
begin
Error_Msg_Name_1 := Aname;
Error_Msg_N (Msg, Error_Node);
Error_Attr;
end Error_Attr;
------------------
-- Error_Attr_P --
------------------
procedure Error_Attr_P (Msg : String; Msg_Cont : String := "") is
begin
Error_Msg_Name_1 := Aname;
Error_Msg_F (Msg, P);
if Msg_Cont /= "" then
Error_Msg_F (Msg_Cont, P);
end if;
Error_Attr;
end Error_Attr_P;
----------------------------
-- Legal_Formal_Attribute --
----------------------------
procedure Legal_Formal_Attribute is
begin
Check_E0;
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
then
Error_Attr_P ("prefix of % attribute must be generic type");
elsif Is_Generic_Actual_Type (Entity (P))
or else In_Instance
or else In_Inlined_Body
then
null;
elsif Is_Generic_Type (Entity (P)) then
if Is_Definite_Subtype (Entity (P)) then
Error_Attr_P
("prefix of % attribute must be indefinite generic type");
end if;
else
Error_Attr_P
("prefix of % attribute must be indefinite generic type");
end if;
Set_Etype (N, Standard_Boolean);
end Legal_Formal_Attribute;
---------------------------------------------------------------
-- Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements --
---------------------------------------------------------------
procedure Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements is
begin
Check_E0;
Check_Type;
Check_Not_Incomplete_Type;
Set_Etype (N, Universal_Integer);
end Max_Alignment_For_Allocation_Max_Size_In_Storage_Elements;
-------------
-- Min_Max --
-------------
procedure Min_Max is
begin
-- Attribute can appear as function name in a reduction.
-- Semantic checks are performed later.
if Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Reduce
then
Set_Etype (N, P_Base_Type);
return;
end if;
Check_E2;
Check_Scalar_Type;
Resolve (E1, P_Base_Type);
Resolve (E2, P_Base_Type);
Set_Etype (N, P_Base_Type);
-- Check for comparison on unordered enumeration type
if Bad_Unordered_Enumeration_Reference (N, P_Base_Type) then
Error_Msg_Sloc := Sloc (P_Base_Type);
Error_Msg_NE
("comparison on unordered enumeration type& declared#?.u?",
N, P_Base_Type);
end if;
end Min_Max;
------------------------
-- Standard_Attribute --
------------------------
procedure Standard_Attribute (Val : Int) is
begin
Check_Standard_Prefix;
Rewrite (N, Make_Integer_Literal (Loc, Val));
Analyze (N);
Set_Is_Static_Expression (N, True);
end Standard_Attribute;
--------------------
-- Uneval_Old_Msg --
--------------------
procedure Uneval_Old_Msg is
Uneval_Old_Setting : Character;
Prag : Node_Id;
begin
-- If from aspect, then Uneval_Old_Setting comes from flags in the
-- N_Aspect_Specification node that corresponds to the attribute.
-- First find the pragma in which we appear (note that at this stage,
-- even if we appeared originally within an aspect specification, we
-- are now within the corresponding pragma).
Prag := N;
loop
Prag := Parent (Prag);
exit when No (Prag) or else Nkind (Prag) = N_Pragma;
end loop;
if Present (Prag) then
if Uneval_Old_Accept (Prag) then
Uneval_Old_Setting := 'A';
elsif Uneval_Old_Warn (Prag) then
Uneval_Old_Setting := 'W';
else
Uneval_Old_Setting := 'E';
end if;
-- If we did not find the pragma, that's odd, just use the setting
-- from Opt.Uneval_Old. Perhaps this is due to a previous error?
else
Uneval_Old_Setting := Opt.Uneval_Old;
end if;
-- Processing depends on the setting of Uneval_Old
case Uneval_Old_Setting is
when 'E' =>
-- ??? In the case where Ada_Version is < Ada_2022 and
-- an illegal 'Old prefix would be legal in Ada_2022,
-- we'd like to call Error_Msg_Ada_2022_Feature.
-- Identifying that case involves some work.
Error_Attr_P
("prefix of attribute % that is potentially "
& "unevaluated must statically name an entity"
-- further text needed for accuracy if Ada_2022
& (if Ada_Version >= Ada_2022
and then Attr_Id = Attribute_Old
then " or be eligible for conditional evaluation"
& " (RM 6.1.1 (27))"
else ""),
Msg_Cont =>
"\using pragma Unevaluated_Use_Of_Old (Allow) will make "
& "this legal");
when 'W' =>
Error_Msg_Name_1 := Aname;
Error_Msg_F
("??prefix of attribute % appears in potentially "
& "unevaluated context, exception may be raised", P);
when 'A' =>
null;
when others =>
raise Program_Error;
end case;
end Uneval_Old_Msg;
-------------------------
-- Unexpected Argument --
-------------------------
procedure Unexpected_Argument (En : Node_Id) is
begin
Error_Attr ("unexpected argument for % attribute", En);
end Unexpected_Argument;
-------------------------------------------------
-- Validate_Non_Static_Attribute_Function_Call --
-------------------------------------------------
-- This function should be moved to Sem_Dist ???
procedure Validate_Non_Static_Attribute_Function_Call is
begin
if In_Preelaborated_Unit
and then not In_Subprogram_Or_Concurrent_Unit
then
Flag_Non_Static_Expr
("non-static function call in preelaborated unit!", N);
end if;
end Validate_Non_Static_Attribute_Function_Call;
-- Start of processing for Analyze_Attribute
begin
-- Immediate return if unrecognized attribute (already diagnosed by
-- parser, so there is nothing more that we need to do).
if not Is_Attribute_Name (Aname) then
raise Bad_Attribute;
end if;
Check_Restriction_No_Use_Of_Attribute (N);
-- Deal with Ada 83 issues
if Comes_From_Source (N) then
if not Attribute_83 (Attr_Id) then
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
Error_Msg_N ("(Ada 83) attribute% is not standard??", N);
end if;
if Attribute_Impl_Def (Attr_Id) then
Check_Restriction (No_Implementation_Attributes, N);
end if;
end if;
end if;
-- Deal with Ada 2005 attributes that are implementation attributes
-- because they appear in a version of Ada before Ada 2005, ditto for
-- Ada 2012 and Ada 2022 attributes appearing in an earlier version.
if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005)
or else
(Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012)
or else
(Attribute_22 (Attr_Id) and then Ada_Version < Ada_2022)
then
Check_Restriction (No_Implementation_Attributes, N);
end if;
-- Remote access to subprogram type access attribute reference needs
-- unanalyzed copy for tree transformation. The analyzed copy is used
-- for its semantic information (whether prefix is a remote subprogram
-- name), the unanalyzed copy is used to construct new subtree rooted
-- with N_Aggregate which represents a fat pointer aggregate.
if Aname = Name_Access then
Discard_Node (Copy_Separate_Tree (N));
end if;
-- Analyze prefix and exit if error in analysis. If the prefix is an
-- incomplete type, use full view if available. Note that there are
-- some attributes for which we do not analyze the prefix, since the
-- prefix is not a normal name, or else needs special handling.
if Aname /= Name_Elab_Body and then
Aname /= Name_Elab_Spec and then
Aname /= Name_Elab_Subp_Body and then
Aname /= Name_Enabled and then
Aname /= Name_Old
then
Analyze (P);
P_Type := Etype (P);
if Is_Entity_Name (P)
and then Present (Entity (P))
and then Is_Type (Entity (P))
then
if Ekind (Entity (P)) = E_Incomplete_Type then
P_Type := Get_Full_View (P_Type);
Set_Entity (P, P_Type);
Set_Etype (P, P_Type);
elsif Entity (P) = Current_Scope
and then Is_Record_Type (Entity (P))
then
-- Use of current instance within the type. Verify that if the
-- attribute appears within a constraint, it yields an access
-- type, other uses are illegal.
declare
Par : Node_Id;
begin
Par := Parent (N);
while Present (Par)
and then Nkind (Parent (Par)) /= N_Component_Definition
loop
Par := Parent (Par);
end loop;
if Present (Par)
and then Nkind (Par) = N_Subtype_Indication
then
if Attr_Id /= Attribute_Access
and then Attr_Id /= Attribute_Unchecked_Access
and then Attr_Id /= Attribute_Unrestricted_Access
then
Error_Msg_N
("in a constraint the current instance can only "
& "be used with an access attribute", N);
end if;
end if;
end;
end if;
end if;
if P_Type = Any_Type then
raise Bad_Attribute;
end if;
P_Base_Type := Base_Type (P_Type);
end if;
-- Analyze expressions that may be present, exiting if an error occurs
if No (Exprs) then
E1 := Empty;
E2 := Empty;
else
E1 := First (Exprs);
-- Skip analysis for case of Restriction_Set, we do not expect
-- the argument to be analyzed in this case.
if Aname /= Name_Restriction_Set then
Analyze (E1);
-- Check for missing/bad expression (result of previous error)
if No (E1) or else Etype (E1) = Any_Type then
raise Bad_Attribute;
end if;
end if;
E2 := Next (E1);
if Present (E2) then
Analyze (E2);
if Etype (E2) = Any_Type then
raise Bad_Attribute;
end if;
if Present (Next (E2)) then
Unexpected_Argument (Next (E2));
end if;
end if;
end if;
-- Cases where prefix must be resolvable by itself
if 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
-- The prefix must be resolvable by itself, without reference to the
-- attribute. One case that requires special handling is a prefix
-- that is a function name, where one interpretation may be a
-- parameterless call. Entry attributes are handled specially below.
if Is_Entity_Name (P)
and then Aname not in Name_Count | Name_Caller
then
Check_Parameterless_Call (P);
end if;
if Is_Overloaded (P) then
-- Ada 2005 (AI-345): Since protected and task types have
-- primitive entry wrappers, the attributes Count, and Caller
-- require a context check
if Aname in Name_Count | Name_Caller then
declare
Count : Natural := 0;
I : Interp_Index;
It : Interp;
begin
Get_First_Interp (P, I, It);
while Present (It.Nam) loop
if Comes_From_Source (It.Nam) then
Count := Count + 1;
else
Remove_Interp (I);
end if;
Get_Next_Interp (I, It);
end loop;
if Count > 1 then
Error_Attr ("ambiguous prefix for % attribute", P);
else
Set_Is_Overloaded (P, False);
end if;
end;
else
Error_Attr ("ambiguous prefix for % attribute", P);
end if;
end if;
end if;
-- If the prefix was rewritten as a raise node, then rewrite N as a
-- raise node, to avoid creating inconsistent trees. We still need to
-- perform legality checks on the original tree.
if Nkind (P) in N_Raise_xxx_Error then
Rewrite (N, Relocate_Node (P));
P := Original_Node (P_Old);
end if;
-- Remaining processing depends on attribute
case Attr_Id is
-- Attributes related to Ada 2012 iterators. Attribute specifications
-- exist for these, but they cannot be queried.
when Attribute_Constant_Indexing
| Attribute_Default_Iterator
| Attribute_Implicit_Dereference
| Attribute_Iterator_Element
| Attribute_Iterable
| Attribute_Variable_Indexing
=>
Error_Msg_N ("illegal attribute", N);
-- Internal attributes used to deal with Ada 2012 delayed aspects. These
-- were already rejected by the parser. Thus they shouldn't appear here.
when Internal_Attribute_Id =>
raise Program_Error;
------------------
-- Abort_Signal --
------------------
when Attribute_Abort_Signal =>
Check_Standard_Prefix;
Rewrite (N, New_Occurrence_Of (Stand.Abort_Signal, Loc));
Analyze (N);
------------
-- Access --
------------
when Attribute_Access =>
Analyze_Access_Attribute;
Check_Not_Incomplete_Type;
-------------
-- Address --
-------------
when Attribute_Address =>
Check_E0;
Address_Checks;
Check_Not_Incomplete_Type;
Set_Etype (N, RTE (RE_Address));
------------------
-- Address_Size --
------------------
when Attribute_Address_Size =>
Standard_Attribute (System_Address_Size);
--------------
-- Adjacent --
--------------
when Attribute_Adjacent
| Attribute_Copy_Sign
| Attribute_Remainder
=>
Check_Floating_Point_Type_2;
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
Resolve (E2, P_Base_Type);
---------
-- Aft --
---------
when Attribute_Aft =>
Check_Fixed_Point_Type_0;
Set_Etype (N, Universal_Integer);
---------------
-- Alignment --
---------------
when Attribute_Alignment =>
-- Don't we need more checking here, cf Size ???
Check_E0;
Check_Not_Incomplete_Type;
Check_Not_CPP_Type;
Set_Etype (N, Universal_Integer);
---------------
-- Asm_Input --
---------------
when Attribute_Asm_Input =>
Check_Asm_Attribute;
-- The back end may need to take the address of E2
if Is_Entity_Name (E2) then
Set_Address_Taken (Entity (E2));
end if;
Set_Etype (N, RTE (RE_Asm_Input_Operand));
----------------
-- Asm_Output --
----------------
when Attribute_Asm_Output =>
Check_Asm_Attribute;
if Etype (E2) = Any_Type then
return;
elsif Aname = Name_Asm_Output then
if not Is_Variable (E2) then
Error_Attr
("second argument for Asm_Output is not variable", E2);
end if;
end if;
Note_Possible_Modification (E2, Sure => True);
-- The back end may need to take the address of E2
if Is_Entity_Name (E2) then
Set_Address_Taken (Entity (E2));
end if;
Set_Etype (N, RTE (RE_Asm_Output_Operand));
-----------------------------
-- Atomic_Always_Lock_Free --
-----------------------------
when Attribute_Atomic_Always_Lock_Free =>
Check_E0;
Check_Type;
Set_Etype (N, Standard_Boolean);
----------
-- Base --
----------
-- Note: when the base attribute appears in the context of a subtype
-- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
-- the following circuit.
when Attribute_Base => Base : declare
Typ : Entity_Id;
begin
Check_E0;
Find_Type (P);
Typ := Entity (P);
if Ada_Version >= Ada_95
and then not Is_Scalar_Type (Typ)
and then not Is_Generic_Type (Typ)
then
Error_Attr_P ("prefix of Base attribute must be scalar type");
elsif Sloc (Typ) = Standard_Location
and then Base_Type (Typ) = Typ
and then Warn_On_Redundant_Constructs
then
Error_Msg_NE -- CODEFIX
("?r?redundant attribute, & is its own base type", N, Typ);
end if;
Set_Etype (N, Base_Type (Entity (P)));
Set_Entity (N, Base_Type (Entity (P)));
Rewrite (N, New_Occurrence_Of (Entity (N), Loc));
Analyze (N);
end Base;
---------
-- Bit --
---------
when Attribute_Bit =>
Check_E0;
if not Is_Object_Reference (P) then
Error_Attr_P ("prefix of % attribute must be object");
-- What about the access object cases ???
else
null;
end if;
Set_Etype (N, Universal_Integer);
---------------
-- Bit_Order --
---------------
when Attribute_Bit_Order =>
Check_E0;
Check_Type;
if not Is_Record_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be record type");
end if;
if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
Rewrite (N,
New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
else
Rewrite (N,
New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
end if;
Set_Etype (N, RTE (RE_Bit_Order));
Resolve (N);
-- Reset incorrect indication of staticness
Set_Is_Static_Expression (N, False);
------------------
-- Bit_Position --
------------------
-- Note: in generated code, we can have a Bit_Position attribute
-- applied to a (naked) record component (i.e. the prefix is an
-- identifier that references an E_Component or E_Discriminant
-- entity directly, and this is interpreted as expected by Gigi.
-- The following code will not tolerate such usage, but when the
-- expander creates this special case, it marks it as analyzed
-- immediately and sets an appropriate type.
when Attribute_Bit_Position =>
if Comes_From_Source (N) then
Check_Component;
end if;
Set_Etype (N, Universal_Integer);
------------------
-- Body_Version --
------------------
when Attribute_Body_Version =>
Check_E0;
Check_Program_Unit;
Set_Etype (N, RTE (RE_Version_String));
--------------
-- Callable --
--------------
when Attribute_Callable
| Attribute_Terminated
=>
Check_E0;
Set_Etype (N, Standard_Boolean);
Check_Task_Prefix;
------------
-- Caller --
------------
when Attribute_Caller => Caller : declare
Ent : Entity_Id;
S : Entity_Id;
begin
Check_E0;
if Nkind (P) in N_Identifier | N_Expanded_Name then
Ent := Entity (P);
if not Is_Entry (Ent) then
Error_Attr ("invalid entry name", N);
end if;
else
Error_Attr ("invalid entry name", N);
return;
end if;
for J in reverse 0 .. Scope_Stack.Last loop
S := Scope_Stack.Table (J).Entity;
if S = Scope (Ent) then
Error_Attr ("Caller must appear in matching accept or body", N);
elsif S = Ent then
exit;
end if;
end loop;
Set_Etype (N, RTE (RO_AT_Task_Id));
end Caller;
-------------
-- Ceiling --
-------------
when Attribute_Ceiling
| Attribute_Floor
| Attribute_Fraction
| Attribute_Machine
| Attribute_Machine_Rounding
| Attribute_Model
| Attribute_Rounding
| Attribute_Truncation
| Attribute_Unbiased_Rounding
=>
Check_Floating_Point_Type_1;
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
-----------
-- Class --
-----------
when Attribute_Class =>
Check_Restriction (No_Dispatch, N);
Check_E0;
Find_Type (N);
-- 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.
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;
------------------
-- Code_Address --
------------------
when Attribute_Code_Address =>
Check_E0;
if Nkind (P) = N_Attribute_Reference
and then Attribute_Name (P) in Name_Elab_Body | Name_Elab_Spec
then
null;
elsif not Is_Entity_Name (P)
or else (Ekind (Entity (P)) /= E_Function
and then
Ekind (Entity (P)) /= E_Procedure)
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);
Set_Is_Static_Expression (N, True);
--------------------
-- Component_Size --
--------------------
when Attribute_Component_Size =>
Check_E0;
Set_Etype (N, Universal_Integer);
-- Note: unlike other array attributes, unconstrained arrays are OK
if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
null;
else
Check_Array_Type;
end if;
-------------
-- Compose --
-------------
when Attribute_Compose
| Attribute_Leading_Part
| Attribute_Scaling
=>
Check_Floating_Point_Type_2;
Set_Etype (N, P_Base_Type);
Resolve (E1, P_Base_Type);
Resolve (E2, Any_Integer);
-----------------
-- Constrained --
-----------------
when Attribute_Constrained =>
Check_E0;
Set_Etype (N, Standard_Boolean);
-- 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, P);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("constrained for private type is an obsolescent feature "
& "(RM J.4)?j?", N);
end if;
-- If we are within an instance, the attribute must be legal
-- because it was valid in the generic unit. Ditto if this is
-- an inlining of a function declared in an instance.
if In_Instance or else In_Inlined_Body then
return;
-- For sure OK if we have a real private type itself, but must
-- be completed, cannot apply Constrained to incomplete type.
elsif Is_Private_Type (Entity (P)) then
-- Note: this is one of the Annex J features that does not
-- generate a warning from -gnatwj, since in fact it seems
-- very useful, and is used in the GNAT runtime.
Check_Not_Incomplete_Type;
return;
end if;
-- Normal (non-obsolescent case) of application to object or value of
-- a discriminated type.
else
-- AI12-0068: In a type or subtype aspect, a prefix denoting the
-- current instance of the (sub)type is defined to be a value,
-- not an object, so the Constrained attribute is always True
-- (see RM 8.6(18/5) and RM 3.7.2(3/5)). We issue a warning about
-- this unintuitive result, to help avoid confusion.
if Is_Current_Instance_Reference_In_Type_Aspect (P) then
Error_Msg_Name_1 := Aname;
Error_Msg_N
("current instance attribute % in subtype aspect always " &
"true??", N);
else
Check_Object_Reference (P);
end if;
-- If N does not come from source, then we allow the
-- the attribute prefix to be of a private type whose
-- full type has discriminants. This occurs in cases
-- involving expanded calls to stream attributes.
if not Comes_From_Source (N) then
P_Type := Underlying_Type (P_Type);
end if;
-- Must have discriminants or be an access type designating a type
-- with discriminants. If it is a class-wide type it has unknown
-- discriminants.
if Has_Discriminants (P_Type)
or else Has_Unknown_Discriminants (P_Type)
or else
(Is_Access_Type (P_Type)
and then Has_Discriminants (Designated_Type (P_Type)))
then
return;
-- The rule given in 3.7.2 is part of static semantics, but the
-- intent is clearly that it be treated as a legality rule, and
-- rechecked in the visible part of an instance. Nevertheless
-- the intent also seems to be it should legally apply to the
-- actual of a formal with unknown discriminants, regardless of
-- whether the actual has discriminants, in which case the value
-- of the attribute is determined using the J.4 rules. This choice
-- seems the most useful, and is compatible with existing tests.
elsif In_Instance then
return;
-- Also allow an object of a generic type if extensions allowed
-- and allow this for any type at all.
elsif (Is_Generic_Type (P_Type)
or else Is_Generic_Actual_Type (P_Type))
and then Extensions_Allowed
then
return;
end if;
end if;
-- Fall through if bad prefix
Error_Attr_P
("prefix of % attribute must be object of discriminated type");
---------------
-- Copy_Sign --
---------------
-- Shares processing with Adjacent attribute
-----------
-- Count --
-----------
when Attribute_Count => Count : declare
Ent : Entity_Id;
S : Entity_Id;
Tsk : Entity_Id;
begin
Check_E0;
if Nkind (P) in N_Identifier | N_Expanded_Name then
Ent := Entity (P);
if Ekind (Ent) /= E_Entry then
Error_Attr ("invalid entry name", N);
end if;
elsif Nkind (P) = N_Indexed_Component then
if not Is_Entity_Name (Prefix (P))
or else No (Entity (Prefix (P)))
or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
then
if Nkind (Prefix (P)) = N_Selected_Component
and then Present (Entity (Selector_Name (Prefix (P))))
and then Ekind (Entity (Selector_Name (Prefix (P)))) =
E_Entry_Family
then
Error_Attr
("attribute % must apply to entry of current task", P);
else
Error_Attr ("invalid entry family name", P);
end if;
return;
else
Ent := Entity (Prefix (P));
end if;
elsif Nkind (P) = N_Selected_Component
and then Present (Entity (Selector_Name (P)))
and then Ekind (Entity (Selector_Name (P))) = E_Entry
then
Error_Attr
("attribute % must apply to entry of current task", P);
else
Error_Attr ("invalid entry name", N);
return;
end if;
for J in reverse 0 .. Scope_Stack.Last loop
S := Scope_Stack.Table (J).Entity;
if S = Scope (Ent) then
if Nkind (P) = N_Expanded_Name then
Tsk := Entity (Prefix (P));
-- The prefix denotes either the task type, or else a
-- single task whose task type is being analyzed.
if (Is_Type (Tsk) and then Tsk = S)
or else (not Is_Type (Tsk)
and then Etype (Tsk) = S
and then not (Comes_From_Source (S)))
then
null;
else
Error_Attr
("attribute % must apply to entry of current task", N);
end if;
end if;
exit;
elsif Ekind (Scope (Ent)) in Task_Kind
and then Ekind (S) not in E_Block
| E_Entry
| E_Entry_Family
| E_Loop
then
Error_Attr ("attribute % cannot appear in inner unit", N);
elsif Ekind (Scope (Ent)) = E_Protected_Type
and then not Has_Completion (Scope (Ent))
then
Error_Attr ("attribute % can only be used inside body", N);
end if;
end loop;
if Is_Overloaded (P) then
declare
Index : Interp_Index;
It : Interp;
begin
Get_First_Interp (P, Index, It);
while Present (It.Nam) loop
if It.Nam = Ent then
null;
-- Ada 2005 (AI-345): Do not consider primitive entry
-- wrappers generated for task or protected types.
elsif Ada_Version >= Ada_2005
and then not Comes_From_Source (It.Nam)
then
null;
else
Error_Attr ("ambiguous entry name", N);
end if;
Get_Next_Interp (Index, It);
end loop;
end;
end if;
Set_Etype (N, Universal_Integer);
end Count;
-----------------------
-- Default_Bit_Order --
-----------------------
when Attribute_Default_Bit_Order => Default_Bit_Order : declare
Target_Default_Bit_Order : System.Bit_Order;
begin
Check_Standard_Prefix;
if Bytes_Big_Endian then
Target_Default_Bit_Order := System.High_Order_First;
else
Target_Default_Bit_Order := System.Low_Order_First;
end if;
Rewrite (N,
Make_Integer_Literal (Loc,
UI_From_Int (System.Bit_Order'Pos (Target_Default_Bit_Order))));
Set_Etype (N, Universal_Integer);
Set_Is_Static_Expression (N);
end Default_Bit_Order;
----------------------------------
-- Default_Scalar_Storage_Order --
----------------------------------
when Attribute_Default_Scalar_Storage_Order => Default_SSO : declare
RE_Default_SSO : RE_Id;
begin
Check_Standard_Prefix;
case Opt.Default_SSO is
when ' ' =>
if Bytes_Big_Endian then
RE_Default_SSO := RE_High_Order_First;
else
RE_Default_SSO := RE_Low_Order_First;
end if;
when 'H' =>
RE_Default_SSO := RE_High_Order_First;
when 'L' =>
RE_Default_SSO := RE_Low_Order_First;
when others =>
raise Program_Error;
end case;
Rewrite (N, New_Occurrence_Of (RTE (RE_Default_SSO), Loc));
end Default_SSO;
--------------
-- Definite --
--------------
when Attribute_Definite =>
Legal_Formal_Attribute;
-----------
-- Delta --
-----------
when Attribute_Delta =>
Check_Fixed_Point_Type_0;
Set_Etype (N, Universal_Real);
------------
-- Denorm --
------------
when Attribute_Denorm
| Attribute_Signed_Zeros
=>
Check_Floating_Point_Type_0;
Set_Etype (N, Standard_Boolean);
-----------
-- Deref --
-----------
when Attribute_Deref =>
Check_Type;
Check_E1;
Resolve (E1, RTE (RE_Address));
Set_Etype (N, P_Type);
---------------------
-- Descriptor_Size --
---------------------
when Attribute_Descriptor_Size =>
Check_E0;
if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
Error_Attr_P ("prefix of attribute % must denote a type");
end if;
Set_Etype (N, Universal_Integer);
------------
-- Digits --
------------
when Attribute_Digits =>
Check_E0;
Check_Type;
if not Is_Floating_Point_Type (P_Type)
and then not Is_Decimal_Fixed_Point_Type (P_Type)
then
Error_Attr_P
("prefix of % attribute must be float or decimal type");
end if;
Set_Etype (N, Universal_Integer);
---------------
-- Elab_Body --
---------------
-- Also handles processing for Elab_Spec and Elab_Subp_Body
when Attribute_Elab_Body
| Attribute_Elab_Spec
| Attribute_Elab_Subp_Body
=>
Check_E0;
Check_Unit_Name (P);
Set_Etype (N, Standard_Void_Type);
-- We have to manually call the expander in this case to get
-- the necessary expansion (normally attributes that return
-- entities are not expanded).
Expand (N);
---------------
-- Elab_Spec --
---------------
-- Shares processing with Elab_Body attribute
----------------
-- Elaborated --
----------------
when Attribute_Elaborated =>
Check_E0;
Check_Unit_Name (P);
Set_Etype (N, Standard_Boolean);
----------
-- Emax --
----------
when Attribute_Emax
| Attribute_Machine_Emax
| Attribute_Machine_Emin
| Attribute_Machine_Mantissa
| Attribute_Model_Emin
| Attribute_Model_Mantissa
| Attribute_Safe_Emax
=>
Check_Floating_Point_Type_0;
Set_Etype (N, Universal_Integer);
-------------
-- Enabled --
-------------
when Attribute_Enabled =>
Check_Either_E0_Or_E1;
if Present (E1) then
if not Is_Entity_Name (E1) or else No (Entity (E1)) then
Error_Msg_N ("entity name expected for Enabled attribute", E1);
E1 := Empty;
end if;
end if;
if Nkind (P) /= N_Identifier then
Error_Msg_N ("identifier expected (check name)", P);
elsif Get_Check_Id (Chars (P)) = No_Check_Id then
Error_Msg_N ("& is not a recognized check name", P);
end if;
Set_Etype (N, Standard_Boolean);
--------------
-- Enum_Rep --
--------------
when Attribute_Enum_Rep =>
-- T'Enum_Rep (X) case
if Present (E1) then
Check_E1;
Check_Discrete_Type;
Resolve (E1, P_Base_Type);
-- X'Enum_Rep case. X must be an object or enumeration literal
-- (including an attribute reference), and it must be of a
-- discrete type.
elsif not
((Is_Object_Reference (P)
or else
(Is_Entity_Name (P)
and then Ekind (Entity (P)) = E_Enumeration_Literal)
or else Nkind (P) = N_Attribute_Reference)
and then Is_Discrete_Type (Etype (P)))
then
Error_Attr_P ("prefix of % attribute must be discrete object");
end if;
Set_Etype (N, Universal_Integer);
--------------
-- Enum_Val --
--------------
when Attribute_Enum_Val =>
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;
-------------
-- Epsilon --
-------------
when Attribute_Epsilon
| Attribute_Model_Epsilon
| Attribute_Model_Small
| Attribute_Safe_First
| Attribute_Safe_Last
=>
Check_Floating_Point_Type_0;
Set_Etype (N, Universal_Real);
--------------
-- Exponent --
--------------
when Attribute_Exponent =>
Check_Floating_Point_Type_1;
Set_Etype (N, Universal_Integer);
Resolve (E1, P_Base_Type);
------------------
-- External_Tag --
------------------
when Attribute_External_Tag =>
Check_E0;
Check_Type;
Set_Etype (N, Standard_String);
if not Is_Tagged_Type (P_Type) then
Error_Attr_P ("prefix of % attribute must be tagged");
end if;
---------------
-- Fast_Math --
---------------
when Attribute_Fast_Math =>
Check_Standard_Prefix;
Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc));
-----------------------
-- Finalization_Size --
-----------------------
when Attribute_Finalization_Size =>
Check_E0;
-- The prefix denotes an object
if Is_Object_Reference (P) then
Check_Object_Reference (P);
-- The prefix denotes a type
elsif Is_Entity_Name (P) and then Is_Type (Entity (P)) then
Check_Type;
Check_Not_Incomplete_Type;
-- Attribute 'Finalization_Size is not defined for class-wide
-- types because it is not possible to know statically whether
-- a definite type will have controlled components or not.
if Is_Class_Wide_Type (Etype (P)) then
Error_Attr_P
("prefix of % attribute cannot denote a class-wide type");
end if;
-- The prefix denotes an illegal construct
else
Error_Attr_P
("prefix of % attribute must be a definite type or an object");
end if;
Set_Etype (N, Universal_Integer);
-----------
-- First --
-----------
when Attribute_First
| Attribute_Last
=>
Check_Array_Or_Scalar_Type;
Bad_Attribute_For_Predicate;
---------------
-- First_Bit --
---------------
when Attribute_First_Bit
| Attribute_Last_Bit
| Attribute_Position
=>
Check_Component;
Set_Etype (N, Universal_Integer);
-----------------
-- First_Valid --
-----------------
when Attribute_First_Valid
| Attribute_Last_Valid
=>
Check_First_Last_Valid;
Set_Etype (N, P_Type);
-----------------
-- Fixed_Value --
-----------------
when Attribute_Fixed_Value =>
Check_Fixed_Point_Type;
Check_E1;
Resolve (E1, Any_Integer);
Set_Etype (N, P_Base_Type);
-----------
-- Floor --
-----------
-- Shares processing with Ceiling attribute
----------
-- Fore --
----------
when Attribute_Fore =>
Check_Fixed_Point_Type_0;
Set_Etype (N, Universal_Integer);
--------------
-- Fraction --
--------------
-- Shares processing with Ceiling attribute
--------------
-- From_Any --
--------------
when Attribute_From_Any =>
Check_E1;
Check_PolyORB_Attribute;
Set_Etype (N, P_Base_Type);
-----------------------
-- Has_Access_Values --
-----------------------
when Attribute_Has_Access_Values
| Attribute_Has_Tagged_Values
=>
Check_Type;
Check_E0;
Set_Etype (N, Standard_Boolean);
----------------------
-- Has_Same_Storage --
----------------------
when Attribute_Has_Same_Storage =>
Check_E1;
-- The arguments must be objects of any type
Analyze_And_Resolve (P);
Analyze_And_Resolve (E1);
Check_Object_Reference (P);
Check_Object_Reference (E1);
Set_Etype (N, Standard_Boolean);
-----------------------
-- Has_Tagged_Values --
-----------------------
-- Shares processing with Has_Access_Values attribute
-----------------------
-- Has_Discriminants --
-----------------------
when Attribute_Has_Discriminants =>
Legal_Formal_Attribute;
--------------
-- Identity --
--------------
when Attribute_Identity =>
Check_E0;
Analyze (P);
if Etype (P) = Standard_Exception_Type then
Set_Etype (N, RTE (RE_Exception_Id));
-- Ada 2005 (AI-345): Attribute 'Identity may be applied to task
-- interface class-wide types.
elsif Is_Task_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
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)))
then
Resolve (P);
Set_Etype (N, RTE (RO_AT_Task_Id));
else
if Ada_Version >= Ada_2005 then
Error_Attr_P