| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ A T T R -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2019, 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 Atree; use Atree; |
| with Casing; use Casing; |
| with Checks; use Checks; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| 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 Sinput; use Sinput; |
| with System; |
| with Stringt; use Stringt; |
| 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 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. |
| |
| function Statically_Denotes_Object (N : Node_Id) return Boolean; |
| -- Predicate used to check the legality of the prefix to 'Loop_Entry and |
| -- 'Old, when the prefix is not an entity name. Current RM specfies that |
| -- the prefix must be a direct or expanded name, but it has been proposed |
| -- that the prefix be allowed to be a selected component that does not |
| -- depend on a discriminant, or an indexed component with static indices. |
| -- Current code for this predicate implements this more permissive |
| -- implementation. |
| |
| ----------------------- |
| -- Analyze_Attribute -- |
| ----------------------- |
| |
| procedure Analyze_Attribute (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Aname : constant Name_Id := Attribute_Name (N); |
| P : constant Node_Id := Prefix (N); |
| Exprs : constant List_Id := Expressions (N); |
| Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); |
| 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; |
| -- If the prefix type of 'Image is an enumeration type, set all its |
| -- literals as referenced, since the image function could possibly end |
| -- up referencing any of the literals indirectly. Same for Enum_Val. |
| -- Set the flag only if the reference is in the main code unit. Same |
| -- restriction when resolving 'Value; otherwise an improperly set |
| -- reference when analyzing an inlined body will lose a proper |
| -- warning on a useless with_clause. |
| |
| 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_SPARK_05_Restriction_On_Attribute; |
| -- Issue an error in formal mode because attribute N is allowed |
| |
| 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_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_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); |
| pragma No_Return (Error_Attr_P); |
| -- Like Error_Attr, but error is posted at the start of the prefix |
| |
| 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 (Ent) 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_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_Kind -- |
| -------------- |
| |
| function Get_Kind (E : Entity_Id) return Entity_Kind is |
| begin |
| if 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, 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, 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 |
| Par := Parent (N); |
| while Present (Par) |
| and then |
| (Nkind (Par) = N_Component_Association |
| or else Nkind (Par) in N_Subexpr) |
| loop |
| if Nkind_In (Par, 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 |
| Check_SPARK_05_Restriction_On_Attribute; |
| 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 (Etype (Parent (N)) = RTE (RE_Prim_Ptr) |
| or else |
| Etype (Parent (N)) = RTE (RE_Size_Ptr)) |
| and then Is_Dispatching_Operation |
| (Directly_Designated_Type (Etype (N))) |
| then |
| null; |
| |
| else |
| Kill_Current_Values; |
| end if; |
| |
| -- 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; |
| |
| if Typ = 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 not |
| Nkind_In (Parent (N), N_Discriminant_Association, |
| N_Index_Or_Discriminant_Constraint) |
| then |
| Error_Msg_N |
| ("current instance attribute must appear alone", N); |
| end if; |
| |
| if Is_CPP_Class (Root_Type (Typ)) then |
| Error_Msg_N |
| ("??current instance unsupported for derivations of " |
| & "'C'P'P types", N); |
| end if; |
| |
| -- OK if we are in initialization procedure for the type |
| -- in question, in which case the reference to the type |
| -- is rewritten as a reference to the current object. |
| |
| 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_In (PP, 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_Placemenet_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 (Nam, 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; |
| |
| -- Traverse the parent chain to find the aspect or pragma where the |
| -- attribute resides. |
| |
| Prag := N; |
| while Present (Prag) loop |
| if Nkind_In (Prag, 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_In (Prag, 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 Nam_In (Prag_Nam, Name_Depends, Name_Refined_Depends) |
| and then Aname = Name_Result |
| then |
| null; |
| |
| elsif Nam_In (Prag_Nam, 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; |
| |
| -- 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); |
| 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 not Nkind_In (Subp_Decl, 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 |
| begin |
| Check_SPARK_05_Restriction_On_Attribute; |
| |
| -- AI12-00124: 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, and there is no need for an argument in this case. |
| |
| if Attr_Id = Attribute_Img |
| or else (Ada_Version > Ada_2005 and then Is_Object_Image (P)) |
| then |
| Check_E0; |
| Set_Etype (N, Str_Typ); |
| |
| if Attr_Id = Attribute_Img and then not Is_Object_Image (P) then |
| Error_Attr_P |
| ("prefix of % attribute must be a scalar object name"); |
| end if; |
| else |
| Check_E1; |
| Set_Etype (N, Str_Typ); |
| |
| -- Check that the prefix type is scalar - much in the same way as |
| -- Check_Scalar_Type but with custom error messages to denote the |
| -- variants of 'Image attributes. |
| |
| if Is_Entity_Name (P) |
| and then Is_Type (Entity (P)) |
| and then 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; |
| |
| if not Is_Entity_Name (P) |
| or else not Is_Type (Entity (P)) |
| or else not Is_Scalar_Type (P_Type) |
| then |
| if Ada_Version > Ada_2005 then |
| Error_Attr_P |
| ("prefix of % attribute must be a scalar type or a scalar " |
| & "object name"); |
| else |
| Error_Attr_P ("prefix of % attribute must be a scalar type"); |
| end if; |
| |
| elsif Is_Protected_Self_Reference (P) then |
| Error_Attr_P |
| ("prefix of % attribute denotes current instance " |
| & "(RM 9.4(21/2))"); |
| end if; |
| |
| Resolve (E1, P_Base_Type); |
| Validate_Non_Static_Attribute_Function_Call; |
| end if; |
| |
| Check_Enum_Image; |
| |
| -- 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 |
| |
| Dims : Int; |
| 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 |
| Dims := UI_To_Int (Intval (E1)); |
| |
| for J in 1 .. Dims - 1 loop |
| Next_Index (Index); |
| end loop; |
| |
| Set_Etype (N, Base_Type (Etype (Index))); |
| Set_Etype (E1, Standard_Integer); |
| end if; |
| end if; |
| end Check_Array_Or_Scalar_Type; |
| |
| ---------------------- |
| -- Check_Array_Type -- |
| ---------------------- |
| |
| procedure Check_Array_Type is |
| D : Int; |
| -- 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 |
| |
| 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)) |
| 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 UI_To_Int (Expr_Value (E1)) > D |
| or else UI_To_Int (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); |
| |
| 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, |
| Make_Explicit_Dereference (Sloc (P), |
| Prefix => Relocate_Node (P))); |
| |
| Analyze_And_Resolve (P); |
| P_Type := Etype (P); |
| |
| 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 Nam_In (Attribute_Name (Parent (N)), 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 is |
| Lit : Entity_Id; |
| |
| begin |
| -- 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 |
| 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 |
| K : constant Entity_Kind := Ekind (Entity (P)); |
| T : constant Entity_Id := Etype (Entity (P)); |
| |
| begin |
| if K in Subprogram_Kind |
| or else K in Task_Kind |
| or else K in Protected_Kind |
| or else K = E_Package |
| or else K in Generic_Unit_Kind |
| or else (K = E_Variable |
| and then |
| (Is_Task_Type (T) |
| or else |
| Is_Protected_Type (T))) |
| 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_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_SPARK_05_Restriction_On_Attribute -- |
| ------------------------------------------ |
| |
| procedure Check_SPARK_05_Restriction_On_Attribute is |
| begin |
| Error_Msg_Name_1 := Aname; |
| Check_SPARK_05_Restriction ("attribute % is not allowed", P); |
| end Check_SPARK_05_Restriction_On_Attribute; |
| |
| --------------------------- |
| -- 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_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 not Nkind_In (Parent (N), 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; |
| |
| -- 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 Root_Type (Root_Type (Designated_Type (Etyp))) /= |
| RTE (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_In (Nod, 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) is |
| begin |
| Error_Msg_Name_1 := Aname; |
| Error_Msg_F (Msg, P); |
| 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 |
| 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' => |
| Error_Attr_P |
| ("prefix of attribute % that is potentially " |
| & "unevaluated must denote an entity"); |
| |
| 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, and |
| -- similarly for Ada 2012 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) |
| 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 not Nam_In (Aname, 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 Nam_In (Aname, 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; |
| |
| -- In SPARK, attributes of private types are only allowed if the full |
| -- type declaration is visible. |
| |
| -- Note: the check for Present (Entity (P)) defends against some error |
| -- conditions where the Entity field is not set. |
| |
| if Is_Entity_Name (P) and then Present (Entity (P)) |
| and then Is_Type (Entity (P)) |
| and then Is_Private_Type (P_Type) |
| and then not In_Open_Scopes (Scope (P_Type)) |
| and then not In_Spec_Expression |
| then |
| Check_SPARK_05_Restriction ("invisible attribute of type", N); |
| 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 => |
| 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; |
| |
| if Nkind (Parent (N)) /= N_Attribute_Reference then |
| Error_Msg_Name_1 := Aname; |
| Check_SPARK_05_Restriction |
| ("attribute% is only allowed as prefix of another attribute", P); |
| 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 for % 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 => |
| 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_In (P, 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 => |
| 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 Nam_In (Attribute_Name (P), 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 => |
| 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 of |
| -- a discriminated type. |
| |
| else |
| Check_Object_Reference (P); |
| |
| -- 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. (this may be obsolete ???) |
| |
| 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 -- |
| --------------- |
| |
| when Attribute_Copy_Sign => |
| Check_Floating_Point_Type_2; |
| Set_Etype (N, P_Base_Type); |
| Resolve (E1, P_Base_Type); |
| Resolve (E2, P_Base_Type); |
| |
| ----------- |
| -- Count -- |
| ----------- |
| |
| when Attribute_Count => Count : declare |
| Ent : Entity_Id; |
| S : Entity_Id; |
| Tsk : Entity_Id; |
| |
| begin |
| Check_E0; |
| |
| if Nkind_In (P, 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 not Ekind_In (S, 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 => |
| 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 |
| |
| ---------------- |
| -- Elaborated -- |
| ---------------- |
| |
| when Attribute_Elaborated => |
| Check_E0; |
| Check_Unit_Name (P); |
| Set_Etype (N, Standard_Boolean); |
| |
| ---------- |
| -- Emax -- |
| ---------- |
| |
| when Attribute_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, 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)) |
| 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 => |
| 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 => |
| Check_Array_Or_Scalar_Type; |
| Bad_Attribute_For_Predicate; |
| |
| --------------- |
| -- First_Bit -- |
| --------------- |
| |
| when Attribute_First_Bit => |
| Check_Component; |
| Set_Etype (N, Universal_Integer); |
| |
| ----------------- |
| -- First_Valid -- |
| ----------------- |
| |
| when Attribute_First_Valid => |
| Check_First_Last_Valid; |
| Set_Etype (N, P_Type); |
| |
| ----------------- |
| -- Fixed_Value -- |
| ----------------- |
| |
| when Attribute_Fixed_Value => |
| Check_E1; |
| Check_Fixed_Point_Type; |
| Resolve (E1, Any_Integer); |
| Set_Etype (N, P_Base_Type); |
| |
| ----------- |
| -- Floor -- |
| ----------- |
| |
| when Attribute_Floor => |
| Check_Floating_Point_Type_1; |
| Set_Etype (N, P_Base_Type); |
| Resolve (E1, P_Base_Type); |
| |
| ---------- |
| -- Fore -- |
| ---------- |
| |
| when Attribute_Fore => |
| Check_Fixed_Point_Type_0; |
| Set_Etype (N, Universal_Integer); |
| |
| -------------- |
| -- Fraction -- |
| -------------- |
| |
| when Attribute_Fraction => |
| Check_Floating_Point_Type_1; |
| Set_Etype (N, P_Base_Type); |
| Resolve (E1, P_Base_Type); |
| |
| -------------- |
| -- From_Any -- |
| -------------- |
| |
| when Attribute_From_Any => |
| Check_E1; |
| Check_PolyORB_Attribute; |
| Set_Etype (N, P_Base_Type); |
| |
| ----------------------- |
| -- Has_Access_Values -- |
| ----------------------- |
| |
| when Attribute_Has_Access_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 -- |
| ----------------------- |
| |
| when Attribute_Has_Tagged_Values => |
| Check_Type; |
| Check_E0; |
| Set_Etype (N, Standard_Boolean); |
| |
| ----------------------- |
| -- 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 |
| ("prefix of % attribute must be an exception, a task or a " |
| & "task interface class-wide object"); |
| else |
| Error_Attr_P |
| ("prefix of % attribute must be a task or an exception"); |
| end if; |
| end if; |
| |
| ----------- |
| -- Image -- |
| ----------- |
| |
| when Attribute_Image => |
| if Is_Real_Type (P_Type) then |
| if Ada_Version = Ada_83 and then Comes_From_Source (N) then |
| Error_Msg_Name_1 := Aname; |
| Error_Msg_N |
| ("(Ada 83) % attribute not allowed for real types", N); |
| end if; |
| end if; |
| |
| Analyze_Image_Attribute (Standard_String); |
| |
| --------- |
| -- Img -- |
| --------- |
| |
| when Attribute_Img => |
| Analyze_Image_Attribute (Standard_String); |
| |
| ----------- |
| -- Input -- |
| ----------- |
| |
| when Attribute_Input => |
| Check_E1; |
| Check_Stream_Attribute (TSS_Stream_Input); |
| Set_Etype (N, P_Base_Type); |
| |
| ------------------- |
| -- Integer_Value -- |
| ------------------- |
| |
| when Attribute_Integer_Value => |
| Check_E1; |
| Check_Integer_Type; |
| Resolve (E1, Any_Fixed); |
| |
| -- Signal an error if argument type is not a specific fixed-point |
| -- subtype. An error has been signalled already if the argument |
| -- was not of a fixed-point type. |
| |
| if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then |
| Error_Attr ("argument of % must be of a fixed-point type", E1); |
| end if; |
| |
| Set_Etype (N, P_Base_Type); |
| |
| ------------------- |
| -- Invalid_Value -- |
| ------------------- |
| |
| when Attribute_Invalid_Value => |
| Check_E0; |
| Check_Scalar_Type; |
| Set_Etype (N, P_Base_Type); |
| Invalid_Value_Used := True; |
| |
| ----------- |
| -- Large -- |
| ----------- |
| |
| when Attribute_Large => |
| Check_E0; |
| Check_Real_Type; |
| Set_Etype (N, Universal_Real); |
| |
| ---------- |
| -- Last -- |
| ---------- |
| |
| when Attribute_Last => |
| Check_Array_Or_Scalar_Type; |
| Bad_Attribute_For_Predicate; |
| |
| -------------- |
| -- Last_Bit -- |
| -------------- |
| |
| when Attribute_Last_Bit => |
| Check_Component; |
| Set_Etype (N, Universal_Integer); |
| |
| ---------------- |
| -- Last_Valid -- |
| ---------------- |
| |
| when Attribute_Last_Valid => |
| Check_First_Last_Valid; |
| Set_Etype (N, P_Type); |
| |
| ------------------ |
| -- Leading_Part -- |
| ------------------ |
| |
| when Attribute_Leading_Part => |
| Check_Floating_Point_Type_2; |
| Set_Etype (N, P_Base_Type); |
| Resolve (E1, P_Base_Type); |
| Resolve (E2, Any_Integer); |
| |
| ------------ |
| -- Length -- |
| ------------ |
| |
| when Attribute_Length => |
| Check_Array_Type; |
| Set_Etype (N, Universal_Integer); |
| |
| ------------------- |
| -- Library_Level -- |
| ------------------- |
| |
| when Attribute_Library_Level => |
| Check_E0; |
| |
| if not Is_Entity_Name (P) then |
| Error_Attr_P ("prefix of % attribute must be an entity name"); |
| end if; |
| |
| if not Inside_A_Generic then |
| Set_Boolean_Result (N, |
| Is_Library_Level_Entity (Entity (P))); |
| end if; |
| |
| Set_Etype (N, Standard_Boolean); |
| |
| --------------- |
| -- Lock_Free -- |
| --------------- |
| |
| when Attribute_Lock_Free => |
| Check_E0; |
| Set_Etype (N, Standard_Boolean); |
| |
| if not Is_Protected_Type (P_Type) then |
| Error_Attr_P |
| ("prefix of % attribute must be a protected object"); |
| end if; |
| |
| ---------------- |
| -- Loop_Entry -- |
| ---------------- |
| |
| when Attribute_Loop_Entry => Loop_Entry : declare |
| procedure Check_References_In_Prefix (Loop_Id : Entity_Id); |
| -- Inspect the prefix for any uses of entities declared within the |
| -- related loop. Loop_Id denotes the loop identifier. |
| |
| -------------------------------- |
| -- Check_References_In_Prefix -- |
| -------------------------------- |
| |
| procedure Check_References_In_Prefix (Loop_Id : Entity_Id) is |
| Loop_Decl : constant Node_Id := Label_Construct (Parent (Loop_Id)); |
| |
| function Check_Reference (Nod : Node_Id) return Traverse_Result; |
| -- Determine whether a reference mentions an entity declared |
| -- within the related loop. |
| |
| function Declared_Within (Nod : Node_Id) return Boolean; |
| -- Determine whether Nod appears in the subtree of Loop_Decl |
| |
| --------------------- |
| -- Check_Reference -- |
| --------------------- |
| |
| function Check_Reference (Nod : Node_Id) return Traverse_Result is |
| begin |
| if Nkind (Nod) = N_Identifier |
| and then Present (Entity (Nod)) |
| and then Declared_Within (Declaration_Node (Entity (Nod))) |
| then |
| Error_Attr |
| ("prefix of attribute % cannot reference local entities", |
| Nod); |
| return Abandon; |
| else |
| return OK; |
| end if; |
| end Check_Reference; |
| |
| procedure Check_References is new Traverse_Proc (Check_Reference); |
| |
| --------------------- |
| -- Declared_Within -- |
| --------------------- |
| |
| function Declared_Within (Nod : Node_Id) return Boolean is |
| Stmt : Node_Id; |
| |
| begin |
| Stmt := Nod; |
| while Present (Stmt) loop |
| if Stmt = Loop_Decl then |
| return True; |
| |
| -- Prevent the search from going too far |
| |
| elsif Is_Body_Or_Package_Declaration (Stmt) then |
| exit; |
| end if; |
| |
| Stmt := Parent (Stmt); |
| end loop; |
| |
| return False; |
| end Declared_Within; |
| |
| -- Start of processing for Check_Prefix_For_Local_References |
| |
| begin |
| Check_References (P); |
| end Check_References_In_Prefix; |
| |
| -- Local variables |
| |
| Context : constant Node_Id := Parent (N); |
| Attr : Node_Id; |
| Encl_Loop : Node_Id := Empty; |
| Encl_Prag : Node_Id := Empty; |
| Loop_Id : Entity_Id := Empty; |
| Scop : Entity_Id; |
| Stmt : Node_Id; |
| |
| -- Start of processing for Loop_Entry |
| |
| begin |
| Attr := N; |
| |
| -- Set the type of the attribute now to ensure the successful |
| -- continuation of analysis even if the attribute is misplaced. |
| |
| Set_Etype (Attr, P_Type); |
| |
| -- Attribute 'Loop_Entry may appear in several flavors: |
| |
|