Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_attr.adb < prev next >

Wrap

Text File | 1996-09-28 | 136KB | 4,572 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ A T T R -- -- -- -- B o d y -- -- -- -- $Revision: 1.259 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Errout; use Errout; with Eval_Fat; with Exp_TSS; use Exp_TSS; with Exp_Util; use Exp_Util; with Features; use Features; with Fname; use Fname; with Freeze; use Freeze; with Lib; use Lib; with Lib.Load; use Lib.Load; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; with Stringt; use Stringt; with Table; with Ttypes; use Ttypes; with Ttypef; use Ttypef; with Tbuild; use Tbuild; with Uintp; use Uintp; with Uname; use Uname; with Urealp; use Urealp; with Widechar; use Widechar; package body Sem_Attr is 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 Attribute_83 : 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); function In_Generic_Unit return Boolean; -- Utility do determine whether we are within a generic unit. Used to -- validate and evaluate 'Definite. ----------------------- -- 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; -- Type of prefix after analysis P_Base_Type : Entity_Id; -- Base type of prefix after analysis P_Root_Type : Entity_Id; -- Root type of prefix after analysis Unanalyzed : Node_Id; ----------------------- -- Local Subprograms -- ----------------------- procedure Access_Attribute; -- Used for Access, Unchecked_Access, Unrestricted_Access attributes. -- Internally, Id distinguishes which of the three cases is involved. 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. procedure Check_Component; -- Common processing for First_Bit, Last_Bit and Position. Checks that -- the 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_Discrete_Attribute; -- Common processing for attributes operating on discrete types 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_E0_Or_E1; -- Check that at most one attribute argument is present procedure Check_E1; -- Check that exactly one attribute argument is present procedure Check_E2; -- Check that two attribute arguments are present procedure Check_Enumeration_Type; -- Verify that prefix of attribute N is an enumeration type procedure Check_Fixed_Point_Type; -- Verify that prefix of attribute N is a fixed type procedure Check_Fixed_Point_Type_0; -- Verify that prefix of attribute N is a fixed type and that -- no attribute expressions are present procedure Check_Floating_Point_Type; -- Verify that prefix of attribute N is a float type procedure Check_Floating_Point_Type_0; -- Verify that prefix of attribute N is a float type and that -- no attribute expressions are present procedure Check_Floating_Point_Type_1; -- Verify that prefix of attribute N is a float type and that -- exactly one attribute expression is present procedure Check_Floating_Point_Type_2; -- Verify that prefix of attribute N is a float type and that -- two attribute expressions are present procedure Check_Integer_Type; -- Verify that prefix of attribute N is an integer type procedure Check_Library_Unit; -- Verify that prefix of attribute N is a library unit procedure Check_Object_Reference; -- Verify that prefix of attribute N is an object reference 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 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 Error_Attr (Msg : String; Error_Node : Node_Id); -- 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. 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. procedure Unexpected_Argument (En : Node_Id); -- Signal unexpected attribute argument (En is the argument) procedure Unimplemented_Attribute; -- Give error message for unimplemented attribute 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. ---------------------- -- Access_Attribute -- ---------------------- procedure Access_Attribute is Index : Interp_Index; It : Interp; Acc_Type : Entity_Id; function Valid_Aliased_View (Obj : Node_Id) return Boolean; -- Determine if Obj is a valid aliased view, i.e. an appropriate -- object to which 'Access or 'Unchecked_Access can apply. function Valid_Aliased_View (Obj : Node_Id) return Boolean is E : Entity_Id; begin if Is_Entity_Name (Obj) then E := Entity (Obj); return Is_Aliased (E) or else (Present (Renamed_Object (E)) and then Valid_Aliased_View (Renamed_Object (E))) or else ((Ekind (E) = E_In_Out_Parameter or else Ekind (E) = E_Out_Parameter or else Ekind (E) = E_Generic_In_Out_Parameter) and then Is_Tagged_Type (Etype (E))) -- Note: The above should really be as follows, but -- mode in parameters are disallowed until constant -- access rules are properly checked???: -- -- or else ((Ekind (E) in Formal_Kind -- or else Ekind (E) = E_Generic_In_Out_Parameter -- or else Ekind (E) = E_Generic_In_Parameter) -- and then Is_Tagged_Type (Etype (E))) or else ((Ekind (E) = E_Task_Type or else Ekind (E) = E_Protected_Type) and then In_Open_Scopes (E)) -- Access discriminant constraint or else (Is_Type (E) and then E = Current_Scope) or else (Is_Incomplete_Or_Private_Type (E) and then Full_View (E) = Current_Scope); elsif Nkind (Obj) = N_Selected_Component then return Is_Aliased (Entity (Selector_Name (Obj))); elsif Nkind (Obj) = N_Indexed_Component then return (Is_Aliased (Etype (Prefix (Obj))) or else Is_Access_Type (Etype (Prefix (Obj)))); elsif Nkind (Obj) = N_Unchecked_Type_Conversion or else Nkind (Obj) = N_Type_Conversion then return Is_Tagged_Type (Etype (Obj)); elsif Nkind (Obj) = N_Explicit_Dereference then return True; -- more precise test needed??? elsif Nkind (Obj) = N_Expression_Actions then return Valid_Aliased_View (Expression (Obj)); else return False; end if; end Valid_Aliased_View; -- Start of processing for Access_Attribute begin Check_E0; -- 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. if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then if not Is_Overloaded (P) then Acc_Type := New_Internal_Entity (E_Access_Subprogram_Type, Current_Scope, Loc, 'A'); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Entity (P)); Set_Etype (N, Acc_Type); else Get_First_Interp (P, Index, It); Set_Etype (N, Any_Type); while Present (It.Nam) loop Acc_Type := New_Internal_Entity (E_Access_Subprogram_Type, Current_Scope, Loc, 'A'); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, It.Nam); Add_One_Interp (N, Acc_Type, Acc_Type); Get_Next_Interp (Index, It); end loop; end if; -- Rewrite the access attribute subtree to qualified -- expression in case prefix is a remote subprogram Process_Remote_AST_Attribute (N, Unanalyzed); elsif (Nkind (P) = N_Selected_Component and then Is_Overloadable (Entity (Selector_Name (P)))) then Unimplemented (N, "access to protected operations"); -- Case of access to object else Acc_Type := New_Internal_Entity (E_Anonymous_Access_Type, Current_Scope, Loc, 'A'); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, P_Type); Set_Etype (N, Acc_Type); -- Check for aliased view unless unrestricted case if Aname /= Name_Unrestricted_Access and then not Valid_Aliased_View (P) then Error_Attr ("prefix of % attribute must be aliased", P); end if; end if; end Access_Attribute; -------------------------------- -- Check_Array_Or_Scalar_Type -- -------------------------------- procedure Check_Array_Or_Scalar_Type is Index_Type : Entity_Id; D : Int; -- Dimension number for array attributes. begin if Is_Scalar_Type (P_Type) then Check_Type; if Present (E1) then Error_Attr ("invalid argument in % attribute", E1); else Set_Etype (N, P_Base_Type); return; end if; 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. if Is_Array_Type (P_Type) then Index_Type := First_Index (P_Type); elsif Is_Access_Type (P_Type) then Index_Type := First_Index (Designated_Type (P_Type)); end if; if No (E1) then -- First dimension assumed Set_Etype (N, Etype (Index_Type)); else D := UI_To_Int (Intval (E1)); for I in 1 .. D - 1 loop Index_Type := Next_Index (Index_Type); end loop; Set_Etype (N, Etype (Index_Type)); 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 Check_E0_Or_E1; 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 Error_Attr ("prefix for % attribute must be constrained array", P); end if; D := Number_Dimensions (P_Type); elsif Is_Access_Type (P_Type) and then Is_Array_Type (Designated_Type (P_Type)) then if Is_Entity_Name (P) and then Is_Type (Entity (P)) then Error_Attr ("prefix of % attribute cannot be access type", P); end if; D := Number_Dimensions (Designated_Type (P_Type)); else Error_Attr ("prefix for % attribute must be array", P); end if; if Present (E1) then Resolve (E1, Any_Integer); Set_Etype (E1, Standard_Integer); if not Is_Static_Expression (E1) then Error_Attr ("expression for dimension must be static", E1); elsif UI_To_Int (Intval (E1)) > D or else UI_To_Int (Intval (E1)) < 1 then Error_Attr ("invalid dimension number for array type", E1); end if; end if; end Check_Array_Type; --------------------- -- 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 ("prefix for % attribute must be selected component", P); 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 ("prefix of % attribute must be decimal type", P); end if; end Check_Decimal_Fixed_Point_Type; ------------------------------ -- Check_Discrete_Attribute -- ------------------------------ procedure Check_Discrete_Attribute is begin Check_Discrete_Type; Check_E1; Resolve (E1, P_Type); end Check_Discrete_Attribute; ------------------------- -- Check_Discrete_Type -- ------------------------- procedure Check_Discrete_Type is begin Check_Type; if not Is_Discrete_Type (P_Type) then Error_Attr ("prefix of % attribute must be discrete type", P); 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_E0_Or_E1 -- -------------------- procedure Check_E0_Or_E1 is begin if Present (E2) then Unexpected_Argument (E2); end if; end Check_E0_Or_E1; -------------- -- Check_E1 -- -------------- procedure Check_E1 is begin Check_E0_Or_E1; if No (E1) then Error_Attr ("missing argument for % attribute", N); 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_Enumeration_Type -- ---------------------------- procedure Check_Enumeration_Type is begin Check_Type; if not Is_Enumeration_Type (P_Type) then Error_Attr ("prefix of % attribute must be enumeration type", P); end if; end Check_Enumeration_Type; ---------------------------- -- Check_Fixed_Point_Type -- ---------------------------- procedure Check_Fixed_Point_Type is begin Check_Type; if not Is_Fixed_Point_Type (P_Type) then Error_Attr ("prefix of % attribute must be fixed point type", P); 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 ("prefix of % attribute must be float type", P); 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 ("prefix of % attribute must be integer type", P); end if; end Check_Integer_Type; ------------------------ -- Check_Library_Unit -- ------------------------ procedure Check_Library_Unit is begin if not Is_Entity_Name (P) or else (Ekind (Entity (P)) /= E_Function and then Ekind (Entity (P)) /= E_Procedure and then Ekind (Entity (P)) /= E_Package) or else Scope (Entity (P)) /= Standard_Standard then Error_Attr ("prefix of % attribute must be library unit", P); end if; end Check_Library_Unit; ---------------------------- -- Check_Object_Reference -- ---------------------------- procedure Check_Object_Reference is begin if Is_Entity_Name (P) then if Is_Object (Entity (P)) then return; end if; elsif Nkind (P) = N_Indexed_Component and then Is_Array_Type (Etype (Prefix (P))) then return; elsif Nkind (P) = N_Selected_Component then return; elsif Nkind (P) = N_Explicit_Dereference then return; else Error_Attr ("prefix of % attribute must be object", P); end if; end Check_Object_Reference; --------------------- -- Check_Real_Type -- --------------------- procedure Check_Real_Type is begin Check_Type; if not Is_Real_Type (P_Type) then Error_Attr ("prefix of % attribute must be real type", P); 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 ("prefix of % attribute must be scalar type", P); end if; end Check_Scalar_Type; --------------------------- -- Check_Standard_Prefix -- --------------------------- procedure Check_Standard_Prefix is begin Check_E0; if Nkind (P) /= N_Identifier or else Chars (P) /= Name_Standard then Error_Attr ("only allowed prefix for % attribute is Standard", P); end if; end Check_Standard_Prefix; ----------------------- -- Check_Task_Prefix -- ----------------------- procedure Check_Task_Prefix is begin Analyze (P); if Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) and then Is_Task_Type (Designated_Type (Etype (P)))) then Resolve (P, Etype (P)); else Error_Attr ("prefix of % attribute must be a task", P); 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 ("prefix of % attribute must be a type", P); 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; ---------------- -- Error_Attr -- ---------------- procedure Error_Attr (Msg : String; Error_Node : Node_Id) is begin Error_Msg_Name_1 := Aname; Error_Msg_N (Msg, Error_Node); Set_Etype (N, Any_Type); Set_Entity (N, Any_Type); raise Bad_Attribute; end Error_Attr; ------------------------ -- Standard_Attribute -- ------------------------ procedure Standard_Attribute (Val : Int) is begin Check_Standard_Prefix; Rewrite_Substitute_Tree (N, Make_Integer_Literal (Loc, UI_From_Int (Val))); Analyze (N); end Standard_Attribute; ------------------------- -- Unexpected Argument -- ------------------------- procedure Unexpected_Argument (En : Node_Id) is begin Error_Attr ("unexpected argument for % attribute", En); end Unexpected_Argument; ----------------------------- -- Unimplemented_Attribute -- ----------------------------- procedure Unimplemented_Attribute is begin Error_Attr ("% attribute not implemented yet", N); end Unimplemented_Attribute; ------------------------------------------------- -- Validate_Non_Static_Attribute_Function_Call -- ------------------------------------------------- -- This function should be moved to Sem_Dist ??? procedure Validate_Non_Static_Attribute_Function_Call is begin if Inside_Preelaborated_Unit and then not Inside_Subprogram_Unit then Error_Msg_N ("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; -- Deal with Ada 83 and Featues issues if not Attribute_83 (Attr_Id) then if Ada_83 and then Comes_From_Source (N) then Error_Msg_Name_1 := Aname; Error_Msg_N ("(Ada 83) attribute% is not recognized", N); end if; if Attribute_Impl_Def (Attr_Id) then Note_Feature (Implementation_Dependent_Attributes, Loc); else Note_Feature (New_Attributes, Loc); end if; 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 Unanalyzed := 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. Analyze (P); P_Type := Etype (P); if Is_Entity_Name (P) and then Is_Type (Entity (P)) and then Ekind (Entity (P)) = E_Incomplete_Type then P_Type := Get_Full_View (P_Type); Set_Entity (P, P_Type); Set_Etype (P, P_Type); end if; if P_Type = Any_Type then raise Bad_Attribute; end if; P_Base_Type := Base_Type (P_Type); P_Root_Type := Root_Type (P_Base_Type); -- Freeze the prefix unless this is a type attribute (a reference -- such as X'Base or X'Class definitely must not freeze X). if not Is_Type_Attribute_Name (Aname) then Freeze_Expression (P); 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); Analyze (E1); if Etype (E1) = Any_Type then raise Bad_Attribute; 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; if Is_Overloaded (P) and then Aname /= Name_Access and then Aname /= Name_Address and then Aname /= Name_Count and then Aname /= Name_Unchecked_Access then Error_Attr ("ambiguous prefix for % attribute", P); end if; -- Remaining processing depends on attribute case Attr_Id is ------------------ -- Abort_Signal -- ------------------ when Attribute_Abort_Signal => Check_Standard_Prefix; Rewrite_Substitute_Tree (N, New_Reference_To (Stand.Abort_Signal, Loc)); Analyze (N); ------------ -- Access -- ------------ when Attribute_Access => Access_Attribute; ------------- -- Address -- ------------- when Attribute_Address => Check_E0; if Is_Entity_Name (P) and then Is_Type (Entity (P)) and then not Is_Task_Type (Entity (P)) then Error_Attr ("prefix of % attribute cannot be a type", P); end if; Set_Etype (N, RTE (RE_Address)); ------------------ -- Address_Size -- ------------------ when Attribute_Address_Size => Standard_Attribute (Ttypes.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 => Check_E0; Set_Etype (N, Universal_Integer); ---------- -- Base -- ---------- when Attribute_Base => Base : begin Check_E0_Or_E1; Find_Type (P); Set_Etype (N, Base_Type (Entity (P))); if Present (Exprs) then -- Attribute is the subtype mark of a conversion. declare New_N : Node_Id; begin New_N := Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Etype (N), Loc), Expression => New_Copy (E1)); Rewrite_Substitute_Tree (N, New_N); Analyze (N); end; -- For other cases, set the proper type as the entity of the -- attribute reference, and then rewrite the node to be an -- occurrence of the referenced base type. This way, no one -- else in the compiler has to worry about the base attribute. else Set_Entity (N, Base_Type (Entity (P))); Rewrite_Substitute_Tree (N, New_Reference_To (Entity (N), Loc)); Analyze (N); end if; end Base; --------------- -- Bit_Order -- --------------- when Attribute_Bit_Order => Bit_Order : begin Check_E0; Check_Type; if not Is_Record_Type (P_Type) then Error_Attr ("prefix of % attribute must be record type", P); end if; if Bytes_Big_Endian then Rewrite_Substitute_Tree (N, New_Occurrence_Of (RTE (RE_High_Order_First), Loc)); else Rewrite_Substitute_Tree (N, New_Occurrence_Of (RTE (RE_Low_Order_First), Loc)); end if; Set_Etype (N, RTE (RE_Bit_Order)); Resolve (N, Etype (N)); -- Reset incorrect indication of staticness Set_Is_Static_Expression (N, False); end Bit_Order; ------------------ -- Body_Version -- ------------------ -- Missing check: make sure the referenced library unit has a body??? when Attribute_Body_Version => Check_E0; Check_Library_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 => Check_E0; Unimplemented_Attribute; ------------- -- Ceiling -- ------------- when Attribute_Ceiling => Check_Floating_Point_Type_1; Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); ----------- -- Class -- ----------- when Attribute_Class => Class : begin Note_Feature (Class_Wide_Types, Loc); Check_E0_Or_E1; Find_Type (N); if Present (E1) then -- This is a conversion not an attribute : T'Class (X) Rewrite_Substitute_Tree (N, Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Etype (N), Loc), Expression => New_Copy (E1))); Analyze (N); end if; end Class; -------------------- -- 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); if Is_Entity_Name (P) and then Is_Type (Entity (P)) then if Is_Private_Type (Entity (P)) and then not Is_Record_Type (Entity (P)) then return; end if; else Check_Object_Reference; if Has_Discriminants (P_Type) or else (Is_Access_Type (P_Type) and then Has_Discriminants (Designated_Type (P_Type))) then return; end if; end if; -- Fall through if bad prefix Error_Attr ("prefix of % attribute must be object of discriminated type", P); --------------- -- 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; H : Entity_Id; S : Entity_Id; begin Check_E0; if Nkind (P) = N_Identifier or else Nkind (P) = 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 Ent := Entity (Prefix (P)); if Ekind (Ent) /= E_Entry_Family then Error_Attr ("invalid entry family name", P); return; 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 exit; elsif Ekind (Scope (Ent)) in Task_Kind and then Ekind (S) /= E_Loop and then Ekind (S) /= E_Block and then Ekind (S) /= E_Entry and then Ekind (S) /= E_Entry_Family then Error_Attr ("Count cannot appear in inner unit", N); end if; end loop; H := Homonym (Ent); while Present (H) loop if Scope (H) = Scope (Ent) then Error_Attr ("ambiguous entry name", N); return; end if; H := Homonym (H); end loop; Set_Etype (N, Universal_Integer); end Count; ----------------------- -- Default_Bit_Order -- ----------------------- when Attribute_Default_Bit_Order => Default_Bit_Order : begin Check_Standard_Prefix; Check_E0; if Bytes_Big_Endian then Rewrite_Substitute_Tree (N, Make_Integer_Literal (Loc, Uint_0)); else Rewrite_Substitute_Tree (N, Make_Integer_Literal (Loc, Uint_1)); end if; Set_Etype (N, Universal_Integer); end Default_Bit_Order; -------------- -- Definite -- -------------- when Attribute_Definite => Check_E0; if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then Error_Attr (" prefix of % attribute must be generic type", N); else -- If the context is a generic unit, then the attribute must -- apply to a formal indefinite subtype. If the context is an -- instance then it applies to the corresponding actual type, -- and can be constant-folded. if In_Generic_Unit and then (not Is_Generic_Type (Entity (P)) or else not Is_Indefinite_Subtype (Entity (P))) then Error_Attr (" prefix of % attribute must be generic type", N); end if; end if; Set_Etype (N, Standard_Boolean); ----------- -- 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); ------------ -- 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 ("prefix of % attribute must be float or decimal type", P); end if; Set_Etype (N, Universal_Integer); --------------- -- Elab_Body -- --------------- when Attribute_Elab_Body => Check_E0; Check_Library_Unit; Set_Etype (N, Standard_Void_Type); --------------- -- Elab_Spec -- --------------- when Attribute_Elab_Spec => Check_E0; Check_Library_Unit; Set_Etype (N, Standard_Void_Type); ---------- -- Emax -- ---------- when Attribute_Emax => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); -------------- -- Enum_Rep -- -------------- when Attribute_Enum_Rep => Enum_Rep : declare begin Check_E1; Check_Enumeration_Type; Resolve (E1, P_Base_Type); Set_Etype (N, Universal_Integer); end Enum_Rep; ------------- -- 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, P_Base_Type); Resolve (E1, P_Base_Type); ------------------ -- External_Tag -- ------------------ when Attribute_External_Tag => Check_E0; Unimplemented_Attribute; ----------- -- First -- ----------- when Attribute_First => Check_Array_Or_Scalar_Type; --------------- -- First_Bit -- --------------- when Attribute_First_Bit => Check_Component; Set_Etype (N, Universal_Integer); ----------------- -- Fixed_Value -- ----------------- when Attribute_Fixed_Value => Check_E1; Check_Fixed_Point_Type; Resolve (E1, Any_Integer); ----------- -- 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); -------------- -- Identity -- -------------- when Attribute_Identity => Check_E0; Unimplemented_Attribute; ----------- -- Image -- ----------- when Attribute_Image => Image : begin Set_Etype (N, Standard_String); Check_Scalar_Type; if Is_Real_Type (P_Type) then Check_Type; Note_Feature (Image_Attribute_For_Real, Loc); if 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; else Check_Discrete_Attribute; end if; Validate_Non_Static_Attribute_Function_Call; end Image; --------- -- Img -- --------- when Attribute_Img => Img : begin Set_Etype (N, Standard_String); -- Must be scalar type if Is_Scalar_Type (P_Type) then -- Variable is OK if Is_Variable (P) then return; -- So is constant (or in parameter) elsif Is_Entity_Name (P) then if Ekind (Entity (P)) = E_Constant or else Ekind (Entity (P)) = E_In_Parameter then return; end if; end if; end if; -- Fall through on error Error_Attr ("prefix of % attribute must be scalar object name", N); end Img; ----------- -- Input -- ----------- when Attribute_Input => Check_E1; Validate_Non_Static_Attribute_Function_Call; if Present (TSS (P_Type, Name_uInput)) then Rewrite_Substitute_Tree (N, Make_Function_Call (Loc, Name => New_Occurrence_Of (TSS (P_Type, Name_uInput), Loc), Parameter_Associations => Exprs)); Analyze (N); else Unimplemented_Attribute; end if; ------------------- -- Integer_Value -- ------------------- when Attribute_Integer_Value => Check_E1; Check_Integer_Type; Resolve (E1, Any_Fixed); ----------- -- Large -- ----------- when Attribute_Large => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Real); ---------- -- Last -- ---------- when Attribute_Last => Check_Array_Or_Scalar_Type; -------------- -- Last_Bit -- -------------- when Attribute_Last_Bit => Check_Component; Set_Etype (N, Universal_Integer); ------------------ -- 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); ------------- -- Machine -- ------------- when Attribute_Machine => Check_Floating_Point_Type_1; Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); ------------------ -- Machine_Emax -- ------------------ when Attribute_Machine_Emax => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); ------------------ -- Machine_Emin -- ------------------ when Attribute_Machine_Emin => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); ---------------------- -- Machine_Mantissa -- ---------------------- when Attribute_Machine_Mantissa => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); ----------------------- -- Machine_Overflows -- ----------------------- when Attribute_Machine_Overflows => Check_Floating_Point_Type_0; Set_Etype (N, Standard_Boolean); ------------------- -- Machine_Radix -- ------------------- when Attribute_Machine_Radix => Check_Real_Type; Check_E0; Set_Etype (N, Universal_Integer); -------------------- -- Machine_Rounds -- -------------------- when Attribute_Machine_Rounds => Check_Floating_Point_Type_0; Set_Etype (N, Standard_Boolean); -------------- -- Mantissa -- -------------- when Attribute_Mantissa => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); --------- -- Max -- --------- when Attribute_Max => Check_E2; Check_Scalar_Type; Resolve (E1, P_Base_Type); Resolve (E2, P_Base_Type); Set_Etype (N, P_Base_Type); ---------------------------- -- Max_Interrupt_Priority -- ---------------------------- when Attribute_Max_Interrupt_Priority => Standard_Attribute (Ttypes.System_Max_Interrupt_Priority); ------------------ -- Max_Priority -- ------------------ when Attribute_Max_Priority => Standard_Attribute (Ttypes.System_Max_Priority); ---------------------------------- -- Max_Size_In_Storage_Elements -- ---------------------------------- when Attribute_Max_Size_In_Storage_Elements => Check_E0; Check_Type; Set_Etype (N, Universal_Integer); ----------------------- -- Maximum_Alignment -- ----------------------- when Attribute_Maximum_Alignment => Standard_Attribute (Ttypes.Maximum_Alignment); --------- -- Min -- --------- when Attribute_Min => Check_E2; Check_Scalar_Type; Resolve (E1, P_Base_Type); Resolve (E2, P_Base_Type); Set_Etype (N, P_Base_Type); ----------- -- Model -- ----------- when Attribute_Model => Check_Floating_Point_Type_1; Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); ---------------- -- Model_Emin -- ---------------- when Attribute_Model_Emin => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); ------------------- -- Model_Epsilon -- ------------------- when Attribute_Model_Epsilon => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Real); -------------------- -- Model_Mantissa -- -------------------- when Attribute_Model_Mantissa => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); ----------------- -- Model_Small -- ----------------- when Attribute_Model_Small => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Real); ------------- -- Modulus -- ------------- when Attribute_Modulus => Check_Type; if not Is_Modular_Integer_Type (P_Type) then Error_Attr ("prefix of % attribute must be modular type", P); end if; Set_Etype (N, Universal_Integer); ------------ -- Output -- ------------ when Attribute_Output => Check_E2; Validate_Non_Static_Attribute_Function_Call; if Present (TSS (P_Type, Name_uOutput)) then declare Proc_Call : Node_Id := Parent (N); begin Set_Parameter_Associations (Proc_Call, Exprs); Rewrite_Substitute_Tree (N, New_Occurrence_Of (TSS (P_Type, Name_uOutput), Loc)); Analyze (N); end; else Unimplemented_Attribute; end if; ------------------ -- Partition_ID -- ------------------ -- Probably this should be moved to Sem_Dist ??? when Attribute_Partition_ID => Partition_ID : declare Ety : Entity_Id; Nd : Node_Id; Get_Pt_Id : Node_Id; Get_Pt_Id_Call : Node_Id; Prefix_String : String_Id; Interface_Name : Name_Id; procedure Add_Interface_To (C_Unit : Node_Id); -- Load, analyze and add the package System.Rpc.Partition_Interface -- to the context clauses of the enclosing library unit function Find_Lib_Unit_Entity (Lib_Unit : Node_Id) return Entity_Id; -- Retrieve the entity for various kinds of library unit nodes -- that have different structure. procedure Add_Interface_To (C_Unit : Node_Id) is Contexts : List_Id := Context_Items (C_Unit); Lib_Unit : Node_Id; Withn : Node_Id; Uname : Unit_Name_Type; Unum : Unit_Number_Type; UEntity : Entity_Id; Withed : Boolean := False; Context : Node_Id; procedure Failure (S : String); -- Internal procedure called if an error occurs. The parameter -- is a detailed error message that is to be given ------------- -- Failure -- ------------- procedure Failure (S : String) is begin Set_Standard_Error; Write_Str ("fatal error: runtime library configuration error"); Write_Eol; Write_Char ('"'); Write_Name (Get_File_Name (Uname)); Write_Str (""" ("); Write_Str (S); Write_Char (')'); Write_Eol; Set_Standard_Output; raise Unrecoverable_Error; end Failure; -- Start of processing for Add_Interface_To begin Name_Buffer (1 .. 32) := "system.rpc.partition_interface%s"; Name_Len := 32; Uname := Name_Find; Unum := Load_Unit (Uname, False, Empty); if Unum = No_Unit then Failure ("unit not found"); elsif Fatal_Error (Unum) then Failure ("parser errors"); end if; -- Make sure that the unit is analyzed if not Analyzed (Cunit (Unum)) then Semantics (Cunit (Unum)); if Fatal_Error (Unum) then Failure ("semantic errors"); end if; end if; Lib_Unit := Unit (Cunit (Unum)); UEntity := Defining_Unit_Simple_Name (Specification (Lib_Unit)); -- Add to the context clause if Contexts /= No_List then Context := First (Contexts); while Present (Context) and not Withed loop Withed := Nkind (Context) = N_With_Clause and then Find_Lib_Unit_Entity (Unit (Library_Unit (Context))) = UEntity; Context := Next (Context); end loop; end if; if not Withed then Withn := Make_With_Clause (Standard_Location, Name => New_Reference_To (UEntity, Standard_Location)); Set_Library_Unit (Withn, Cunit (Unum)); Set_Corresponding_Spec (Withn, UEntity); Set_First_Name (Withn, True); Set_Implicit_With (Withn, True); Mark_Rewrite_Insertion (Withn); Prepend (Withn, Contexts); end if; end Add_Interface_To; -------------------------- -- Find_Lib_Unit_Entity -- -------------------------- function Find_Lib_Unit_Entity (Lib_Unit : Node_Id) return Entity_Id is begin if Nkind (Lib_Unit) in N_Generic_Instantiation or else Nkind (Lib_Unit) = N_Package_Renaming_Declaration or else Nkind (Lib_Unit) in N_Generic_Renaming_Declaration then return Defining_Unit_Simple_Name (Lib_Unit); else return Defining_Unit_Simple_Name (Specification (Lib_Unit)); end if; end Find_Lib_Unit_Entity; -- Processing for Partition_ID begin Check_E0; if P_Type /= Any_Type then if not Is_Library_Level_Entity (Entity (P)) then Error_Attr ("prefix of % attribute must be library-level entity", P); -- The defining entity of prefix should not be declared inside -- a Pure unit. RM E.1(8). -- The Is_Pure flag has been set during declaration. elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) then Error_Attr ("prefix of % attribute must not be declared pure", P); end if; end if; Ety := Entity (P); -- In case prefix is not a library unit entity, get the entity -- of library unit. while (Present (Scope (Ety)) and then Scope (Ety) /= Standard_Standard) and not Is_Child_Unit (Ety) loop Ety := Scope (Ety); end loop; Nd := Enclosing_Lib_Unit_Node (N); -- Add System.Rpc.Partition_Interface to the context clauses of the -- enclosing library unit in which the attribute is used Add_Interface_To (Nd); -- Build a node for System.RPC.Partition_Interface.Get_Partition_Id Name_Len := 19; Name_Buffer (1 .. Name_Len) := "partition_interface"; Interface_Name := Name_Find; -- Set the right function to call if Is_Remote_Call_Interface (Ety) then Name_Len := 23; Name_Buffer (1 .. Name_Len) := "get_active_partition_id"; elsif Is_Shared_Passive (Ety) then Name_Len := 24; Name_Buffer (1 .. Name_Len) := "get_passive_partition_id"; else Name_Len := 22; Name_Buffer (1 .. Name_Len) := "get_local_partition_id"; end if; Get_Pt_Id := Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Interface_Name)), Selector_Name => Make_Identifier (Loc, Name_Find)); -- Get and store the String_Id corresponding to the name of the -- library unit whose Partition_ID is needed Get_Unit_Name_String (Get_Unit_Name (Get_Declaration_Node (Ety))); Name_Len := Name_Len - 7; -- Remove seven last character ("(spec)" or " (body)"). Start_String; Store_String_Chars (Name_Buffer (1 .. Name_Len)); Prefix_String := End_String; -- Build the function call which will replace the attribute if Is_Remote_Call_Interface (Ety) or Is_Shared_Passive (Ety) then Get_Pt_Id_Call := Make_Function_Call (Loc, Name => Get_Pt_Id, Parameter_Associations => New_List (Make_String_Literal (Loc, Prefix_String))); else Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id); end if; -- Replace the attribute node by the function call Rewrite_Substitute_Tree (N, Get_Pt_Id_Call); Analyze (N); end Partition_ID; ------------------------- -- Passed_By_Reference -- ------------------------- when Attribute_Passed_By_Reference => Check_E0; Check_Type; Set_Etype (N, Standard_Boolean); --------- -- Pos -- --------- when Attribute_Pos => Check_Discrete_Attribute; Set_Etype (N, Universal_Integer); -------------- -- Position -- -------------- when Attribute_Position => Check_Component; Set_Etype (N, Universal_Integer); ---------- -- Pred -- ---------- when Attribute_Pred => Check_Scalar_Type; Check_E1; Resolve (E1, P_Type); Set_Etype (N, P_Base_Type); if Is_Real_Type (P_Type) then Note_Feature (Pred_Succ_Attribute_For_Real, Loc); -- If not real type, test for overflow check required. else if not Range_Checks_Suppressed (P_Base_Type) then Set_Do_Range_Check (E1); end if; end if; ----------- -- Range -- ----------- when Attribute_Range => Check_Array_Or_Scalar_Type; if Ada_83 and then Is_Scalar_Type (P_Type) and then Comes_From_Source (N) then Error_Attr ("(Ada 83) % attribute not allowed for scalar type", P); end if; ------------------ -- Range_Length -- ------------------ when Attribute_Range_Length => Check_Discrete_Type; Set_Etype (N, Universal_Integer); ---------- -- Read -- ---------- when Attribute_Read => Check_E2; Validate_Non_Static_Attribute_Function_Call; if Present (TSS (P_Type, Name_uRead)) then declare Proc_Call : Node_Id := Parent (N); begin Set_Parameter_Associations (Proc_Call, Exprs); Rewrite_Substitute_Tree (N, New_Occurrence_Of (TSS (P_Type, Name_uRead), Loc)); Analyze (N); end; else Unimplemented_Attribute; end if; --------------- -- Remainder -- --------------- when Attribute_Remainder => Check_Floating_Point_Type_2; Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); Resolve (E2, P_Base_Type); ----------- -- Round -- ----------- when Attribute_Round => Check_E1; Check_Decimal_Fixed_Point_Type; Resolve (E1, Any_Real); -------------- -- Rounding -- -------------- when Attribute_Rounding => Check_Floating_Point_Type_1; Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); --------------- -- Safe_Emax -- --------------- when Attribute_Safe_Emax => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Integer); ---------------- -- Safe_First -- ---------------- when Attribute_Safe_First => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Real); ---------------- -- Safe_Large -- ---------------- when Attribute_Safe_Large => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Real); --------------- -- Safe_Last -- --------------- when Attribute_Safe_Last => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Real); ---------------- -- Safe_Small -- ---------------- when Attribute_Safe_Small => Check_Floating_Point_Type_0; Set_Etype (N, Universal_Real); ----------- -- Scale -- ----------- when Attribute_Scale => Check_E0; Check_Decimal_Fixed_Point_Type; Set_Etype (N, Universal_Integer); ------------- -- Scaling -- ------------- when Attribute_Scaling => Check_Floating_Point_Type_2; Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); ------------------ -- Signed_Zeros -- ------------------ when Attribute_Signed_Zeros => Check_Floating_Point_Type_0; Set_Etype (N, Standard_Boolean); ---------- -- Size -- ---------- when Attribute_Size => Check_E0; Set_Etype (N, Universal_Integer); ----------- -- Small -- ----------- when Attribute_Small => Check_Fixed_Point_Type_0; Set_Etype (N, Universal_Real); ------------------ -- Storage_Pool -- ------------------ when Attribute_Storage_Pool => if Is_Access_Type (P_Type) then Check_E0; Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); -- Validate_Remote_Access_To_Class_Wide_Type for attribute -- Storage_Pool since this attribute is not defined for such -- types (RM E.2.3(22)). Validate_Remote_Access_To_Class_Wide_Type (N); else Error_Attr ("prefix of % attribute must be access type", P); end if; ------------------ -- Storage_Size -- ------------------ when Attribute_Storage_Size => if Is_Task_Type (P_Type) then Check_E0; Set_Etype (N, Universal_Integer); elsif Is_Access_Type (P_Type) then Check_E0; Check_Type; Set_Etype (N, Universal_Integer); -- Validate_Remote_Access_To_Class_Wide_Type for attribute -- Storage_Size since this attribute is not defined for -- such types (RM E.2.3(22)). Validate_Remote_Access_To_Class_Wide_Type (N); else Error_Attr ("prefix of % attribute must be access or task type", P); end if; ------------------ -- Storage_Unit -- ------------------ when Attribute_Storage_Unit => Standard_Attribute (Ttypes.System_Storage_Unit); ---------- -- Succ -- ---------- when Attribute_Succ => Check_Scalar_Type; Check_E1; Resolve (E1, P_Type); Set_Etype (N, P_Base_Type); if Is_Real_Type (P_Type) then Note_Feature (Pred_Succ_Attribute_For_Real, Loc); -- If not real type, test for overflow check required. else if not Range_Checks_Suppressed (P_Base_Type) then Set_Do_Range_Check (E1); end if; end if; --------- -- Tag -- --------- when Attribute_Tag => Check_E0; if not Is_Tagged_Type (P_Type) then Error_Attr ("prefix of % attribute must be tagged", P); end if; Set_Etype (N, RTE (RE_Tag)); ---------------- -- Terminated -- ---------------- when Attribute_Terminated => Check_E0; Set_Etype (N, Standard_Boolean); Check_Task_Prefix; ---------- -- Tick -- ---------- when Attribute_Tick => Check_Standard_Prefix; Rewrite_Substitute_Tree (N, Make_Real_Literal (Loc, UR_From_Components ( Num => UI_From_Int (Ttypes.System_Tick_Nanoseconds), Den => UI_From_Int (9), Rbase => 10))); Analyze (N); ---------------- -- Truncation -- ---------------- when Attribute_Truncation => Check_Floating_Point_Type_1; Resolve (E1, P_Base_Type); Set_Etype (N, P_Base_Type); ----------------------- -- Unbiased_Rounding -- ----------------------- when Attribute_Unbiased_Rounding => Check_Floating_Point_Type_1; Set_Etype (N, P_Base_Type); Resolve (E1, P_Base_Type); ---------------------- -- Unchecked_Access -- ---------------------- when Attribute_Unchecked_Access => Access_Attribute; ------------------------------ -- Universal_Literal_String -- ------------------------------ -- This is a GNAT specific attribute whose prefix must be a named -- number where the expression is either a single numeric literal, -- or a numeric literal immediately preceded by a minus sign. The -- result is equivalent to a string literal containing the text of -- the literal as it appeared in the source program with a possible -- leading minus sign. when Attribute_Universal_Literal_String => Universal_Literal_String : begin Check_E0; if not Is_Entity_Name (P) or else Ekind (Entity (P)) not in Named_Kind then Error_Attr ("prefix for % attribute must be named number", P); else declare Expr : Node_Id; Negative : Boolean; S : Source_Ptr; Src : Source_Buffer_Ptr; begin Expr := Original_Node (Expression (Parent (Entity (P)))); if Nkind (Expr) = N_Op_Minus then Negative := True; Expr := Original_Node (Right_Opnd (Expr)); else Negative := False; end if; if Nkind (Expr) /= N_Integer_Literal and then Nkind (Expr) /= N_Real_Literal then Error_Attr ("named number for % attribute must be simple literal", N); end if; -- Build string literal corresponding to source literal text Start_String; if Negative then Store_String_Char (Get_Char_Code ('-')); end if; S := Sloc (Expr); Src := Source_Text (Get_Source_File_Index (S)); while Src (S) /= ';' and then Src (S) /= ' ' loop Store_String_Char (Get_Char_Code (Src (S))); S := S + 1; end loop; -- Now we rewrite the attribute with the string literal Rewrite_Substitute_Tree (N, Make_String_Literal (Loc, End_String)); Analyze (N); end; end if; end Universal_Literal_String; ------------------------- -- Unrestricted_Access -- ------------------------- -- This is a GNAT specific attribute which is like Access except that -- all scope checks and checks for aliased views are omitted. when Attribute_Unrestricted_Access => Access_Attribute; --------- -- Val -- --------- when Attribute_Val => Val : declare begin Check_E1; Check_Discrete_Type; if not Is_Integer_Type (Etype (E1)) then Error_Attr ("argument of % attribute is not integer type", N); else Resolve (E1, Etype (E1)); end if; Set_Etype (N, P_Base_Type); if not Range_Checks_Suppressed (P_Base_Type) then Set_Do_Range_Check (E1); end if; end Val; ----------- -- Valid -- ----------- when Attribute_Valid => Check_E0; Check_Object_Reference; if not Is_Scalar_Type (P_Type) then Error_Attr ("object for % attribute must be of scalar type", P); end if; Set_Etype (N, Standard_Boolean); ----------- -- Value -- ----------- when Attribute_Value => Value : begin Check_E1; Check_Scalar_Type; if Is_Floating_Point_Type (P_Type) then Note_Feature (Value_Attribute_For_Real, Loc); end if; -- Set Etype before resolving expression because expansion -- of expression may require enclosing type. Set_Etype (N, P_Type); Resolve (E1, Standard_String); Validate_Non_Static_Attribute_Function_Call; end Value; ------------- -- Version -- ------------- when Attribute_Version => Check_E0; Check_Library_Unit; Set_Etype (N, RTE (RE_Version_String)); ---------------- -- Wide_Image -- ---------------- when Attribute_Wide_Image => Wide_Image : begin Check_Scalar_Type; Set_Etype (N, Standard_Wide_String); if not Is_Real_Type (P_Type) then Check_Discrete_Attribute; end if; Validate_Non_Static_Attribute_Function_Call; end Wide_Image; ---------------- -- Wide_Value -- ---------------- when Attribute_Wide_Value => Wide_Value : begin Check_E1; Check_Discrete_Type; Resolve (E1, Standard_Wide_String); Set_Etype (N, P_Type); if Is_Modular_Integer_Type (P_Type) or else Is_Real_Type (P_Type) then Unimplemented_Attribute; end if; Validate_Non_Static_Attribute_Function_Call; end Wide_Value; ---------------- -- Wide_Width -- ---------------- when Attribute_Wide_Width => Check_E0; Check_Scalar_Type; Set_Etype (N, Universal_Integer); ----------- -- Width -- ----------- when Attribute_Width => Check_E0; Check_Scalar_Type; Set_Etype (N, Universal_Integer); --------------- -- Word_Size -- --------------- when Attribute_Word_Size => Standard_Attribute (System_Word_Size); ----------- -- Write -- ----------- when Attribute_Write => Check_E2; Validate_Non_Static_Attribute_Function_Call; if Present (TSS (P_Type, Name_uWrite)) then declare Proc_Call : constant Node_Id := Parent (N); begin Set_Parameter_Associations (Proc_Call, Exprs); Rewrite_Substitute_Tree (N, New_Occurrence_Of (TSS (P_Type, Name_uWrite), Loc)); Analyze (N); end; else Unimplemented_Attribute; end if; end case; -- All errors raise Bad_Attribute, so that we get out before any further -- damage occurs when an error is detected (for example, if we check for -- one attribute expression, and the check succeeds, we want to be able -- to proceed securely assuming that an expression is in fact present. exception when Bad_Attribute => Set_Etype (N, Any_Type); return; end Analyze_Attribute; -------------------- -- Eval_Attribute -- -------------------- procedure Eval_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Aname : constant Name_Id := Attribute_Name (N); Id : constant Attribute_Id := Get_Attribute_Id (Aname); P : constant Node_Id := Prefix (N); C_Type : constant Entity_Id := Etype (N); -- The type imposed by the context. E1 : Node_Id; -- First expression, or Empty if none E2 : Node_Id; -- Second expression, or Empty if none P_Entity : Entity_Id; -- Entity denoted by prefix P_Type : Entity_Id; -- The type of the prefix P_Root_Type : Entity_Id; -- The root type of type of the prefix Static : Boolean; -- True if prefix type is static Lo_Bound, Hi_Bound : Node_Id; -- Expressions for low and high bounds of type or array index referenced -- by First, Last, or Length attribute for array, set by Set_Bounds. CE_Node : Node_Id; -- Used to remember identity of expression raising constraint error function Aft_Value return Nat; -- Computes Aft value for current attribute prefix (used by Aft itself -- and also by Width for computing the Width of a fixed point type). procedure Check_Expressions; -- In case where the attribute is not foldable, the expressions, if -- any, of the attribute, are in a non-static context. This procedure -- performs the required additional checks. procedure Float_Attribute_Boolean (Short_Float_Val : Boolean; Float_Val : Boolean; Long_Float_Val : Boolean; Long_Long_Float_Val : Boolean); -- This procedure evaluates a float attribute with no arguments that -- returns a Boolean result. The four parameters are the Boolean result -- values for the four possible floating-point root types. The prefix -- type is a floating-point type (and is thus not a generic type). procedure Float_Attribute_Universal_Integer (Short_Float_Val : Int; Float_Val : Int; Long_Float_Val : Int; Long_Long_Float_Val : Int); -- This procedure evaluates a float attribute with no arguments that -- returns a universal integer result. All such results are easily -- within Int range, and the four parameters are the result values -- for the four possible floating-point root types. The prefix type -- is a floating-point type (and is thus not a generic type). procedure Float_Attribute_Universal_Real (Short_Float_Val : String; Float_Val : String; Long_Float_Val : String; Long_Long_Float_Val : String); -- This procedure evaluates a float attribute with no arguments that -- returns a universal real result. The four parameters are strings -- that contain representations of the values required in normal -- real literal format with a possible leading minus sign. The prefix -- type is a floating-point type (and is thus not a generic type) function Fore_Value return Nat; -- Computes the Fore value for the current attribute prefix, which is -- known to be a static fixed-point type. Used by Fore and Width. procedure Set_Bounds; -- Used for First, Last and Length attributes applied to an array or -- array subtype. Sets the variables Index_Lo and Index_Hi to the low -- and high bound expressions for the index referenced by the attribute -- designator (i.e. the first index if no expression is present, and -- the N'th index if the value N is present as an expression). --------------- -- Aft_Value -- --------------- function Aft_Value return Nat is Result : Nat; Delta_Val : Ureal; begin Result := 1; Delta_Val := Delta_Value (P_Type); while Delta_Val < Ureal_Tenth loop Delta_Val := Delta_Val * Ureal_10; Result := Result + 1; end loop; return Result; end Aft_Value; ----------------------- -- Check_Expressions -- ----------------------- procedure Check_Expressions is E : Node_Id := E1; begin while Present (E) loop Check_Non_Static_Context (E); E := Next (E); end loop; end Check_Expressions; ----------------------------- -- Float_Attribute_Boolean -- ----------------------------- procedure Float_Attribute_Boolean (Short_Float_Val : Boolean; Float_Val : Boolean; Long_Float_Val : Boolean; Long_Long_Float_Val : Boolean) is Val : Boolean; begin if P_Root_Type = Standard_Short_Float then Val := Short_Float_Val; elsif P_Root_Type = Standard_Float then Val := Float_Val; elsif P_Root_Type = Standard_Long_Float then Val := Long_Float_Val; else pragma Assert (P_Root_Type = Standard_Long_Long_Float); Val := Long_Long_Float_Val; end if; if Val then Fold_Uint (N, Uint_1); else Fold_Uint (N, Uint_0); end if; end Float_Attribute_Boolean; --------------------------------------- -- Float_Attribute_Universal_Integer -- --------------------------------------- procedure Float_Attribute_Universal_Integer (Short_Float_Val : Int; Float_Val : Int; Long_Float_Val : Int; Long_Long_Float_Val : Int) is Val : Int; begin if P_Root_Type = Standard_Short_Float then Val := Short_Float_Val; elsif P_Root_Type = Standard_Float then Val := Float_Val; elsif P_Root_Type = Standard_Long_Float then Val := Long_Float_Val; else pragma Assert (P_Root_Type = Standard_Long_Long_Float); Val := Long_Long_Float_Val; end if; Fold_Uint (N, UI_From_Int (Val)); end Float_Attribute_Universal_Integer; ------------------------------------ -- Float_Attribute_Universal_Real -- ------------------------------------ procedure Float_Attribute_Universal_Real (Short_Float_Val : String; Float_Val : String; Long_Float_Val : String; Long_Long_Float_Val : String) is Result : Node_Id; begin if P_Root_Type = Standard_Short_Float then Result := Real_Convert (Short_Float_Val); elsif P_Root_Type = Standard_Float then Result := Real_Convert (Float_Val); elsif P_Root_Type = Standard_Long_Float then Result := Real_Convert (Long_Float_Val); else pragma Assert (P_Root_Type = Standard_Long_Long_Float); Result := Real_Convert (Long_Long_Float_Val); end if; Rewrite_Substitute_Tree (N, Result); Analyze (N); Resolve (N, C_Type); end Float_Attribute_Universal_Real; ---------------- -- Fore_Value -- ---------------- -- Note that the Fore calculation is based on the actual values -- of the bounds, and does not take into account possible rounding. function Fore_Value return Nat is Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); Small : constant Ureal := Small_Value (P_Type); Lo_Real : constant Ureal := Lo * Small; Hi_Real : constant Ureal := Hi * Small; T : Ureal; R : Nat; begin -- Bounds are given in terms of small units, so first compute -- proper values as reals. T := UR_Max (abs Lo_Real, abs Hi_Real); R := 2; -- Loop to compute proper value if more than one digit required while T >= Ureal_10 loop R := R + 1; T := T / Ureal_10; end loop; return R; end Fore_Value; ---------------- -- Set_Bounds -- ---------------- procedure Set_Bounds is N : Nat; Indx : Node_Id; Ityp : Entity_Id; begin -- For non-array case, just get bounds of scalar type if Is_Scalar_Type (P_Type) then Ityp := P_Type; -- For array case, get type of proper index else if No (E1) then N := 1; else N := UI_To_Int (Expr_Value (E1)); end if; Indx := First_Index (P_Type); while N > 1 loop Indx := Next_Index (Indx); N := N - 1; end loop; Ityp := Etype (Indx); end if; Lo_Bound := Type_Low_Bound (Ityp); Hi_Bound := Type_High_Bound (Ityp); end Set_Bounds; -------------------- -- Eval_Attribute -- -------------------- begin -- Acquire first two expressions (at the moment, no attributes -- take more than two expressions in any case). if Present (Expressions (N)) then E1 := First (Expressions (N)); E2 := Next (E1); else E1 := Empty; E2 := Empty; end if; -- Attribute definitely is not foldable if prefix is not an entity if not Is_Entity_Name (P) then Check_Expressions; return; else P_Entity := Entity (P); end if; -- First foldable possibility is a scalar or array type (RM 4.9(7)) -- that is not generic (generic types are eliminated by RM 4.9(25)). -- Note we allow non-static non-generic types at this stage as further -- described below. if Is_Type (P_Entity) and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity)) and then (not Is_Generic_Type (P_Entity)) then P_Type := P_Entity; -- Second foldable possibility is an array object (RM 4.9(8)) elsif (Ekind (P_Entity) = E_Variable or else Ekind (P_Entity) = E_Constant) and then Is_Array_Type (Etype (P_Entity)) and then (not Is_Generic_Type (P_Entity)) then P_Type := Etype (P_Entity); -- 'Definite must be folded if the prefix is not a generic type, -- that is to say if we are within an instantiation. elsif Id = Attribute_Definite and then not In_Generic_Unit then P_Type := P_Entity; -- No other cases are foldable (they certainly aren't static, and at -- the moment we don't try to fold any cases other than the two above) else Check_Expressions; return; end if; -- If either attribute or the prefix is Any_Type, then propagate -- Any_Type to the result and don't do anything else at all. if P_Type = Any_Type or else (Present (E1) and then Etype (E1) = Any_Type) or else (Present (E2) and then Etype (E2) = Any_Type) then Set_Etype (N, Any_Type); return; end if; -- Scalar subtype case. We have not yet enforced the static requirement -- of (RM 4.9(7)) and we don't intend to just yet, since there are cases -- of non-static attribute references (e.g. S'Digits for a non-static -- floating-point type, which we can compute at compile time). -- Note: this folding of non-static attributes is not simply a case of -- optimization. For many of the attributes affected, Gigi cannot handle -- the attribute and depends on the front end having folded them away. -- Note: although we don't require staticness at this stage, we do set -- the Static variable to record the staticness, for easy reference by -- those attributes where it matters (e.g. Succ and Pred), and also to -- be used to ensure that non-static folded things are not marked as -- being static (a check that is done right at the end). P_Root_Type := Root_Type (P_Type); if Is_Scalar_Type (P_Type) then Static := Is_Static_Subtype (P_Type); -- Array case. We enforce the constrained requirement of (RM 4.9(7-8)) -- since we can't do anything with unconstrained arrays. In addition, -- only the First, Last and Length attributes are foldable. -- 'Definite is again an exception, because it applies as well to -- unconstrained types. elsif Id = Attribute_Definite then null; else if not Is_Constrained (P_Type) or else (Id /= Attribute_First and then Id /= Attribute_Last and then Id /= Attribute_Length) then Check_Expressions; return; end if; -- The rules in (RM 4.9(7,8)) require a static array, but as in the -- scalar case, we hold off on enforcing staticness, since there are -- cases which we can fold at compile time even though they are not -- static (e.g. 'Length applied to a static index, even though other -- non-static indexes make the array type non-static). This is only -- ab optimization, but it falls out essentially free, so why not. -- Again we compute the variable Static for easy reference later -- (note that no array attributes are static in Ada 83). Static := Ada_95; declare N : Node_Id; begin N := First_Index (P_Type); while Present (N) loop Static := Static and Is_Static_Subtype (Etype (N)); N := Next_Index (N); end loop; end; end if; -- Check any expressions that are present. Note that these expressions, -- depending on the particular attribute type, are either part of the -- attribute designator, or they are arguments in a case where the -- attribute reference returns a function. In the latter case, the -- rule in (RM 4.9(22)) applies and in particular requires the type -- of the expressions to be scalar in order for the attribute to be -- considered to be static. declare E : Node_Id; begin E := E1; while Present (E) loop -- If expression is not static, then the attribute reference -- certainly is neither foldable nor static, so we can quit -- immediately. We can also quit if the expression is not of -- a scalar type as noted above. if not Is_Static_Expression (E) or else not Is_Scalar_Type (Etype (E)) then Check_Expressions; return; -- If the expression raises a constraint error, then so does -- the attribute reference. We keep going in this case because -- we are still interested in whether the attribute reference -- is static even if it is not static. elsif Raises_Constraint_Error (E) then Set_Raises_Constraint_Error (N); CE_Node := E; end if; E := Next (E); end loop; end; -- Deal with the case of a static attribute reference that raises -- constraint error. The Raises_Constraint_Error flag will already -- have been set, and the Static flag shows whether the attribute -- reference is static. In any case we certainly can't fold such an -- attribute reference. -- Note that the rewriting of the attribute node with the constraint -- error node is essential in this case, because otherwise Gigi might -- blow up on one of the attributes it never expects to see. if Raises_Constraint_Error (N) then Check_Expressions; Rewrite_Substitute_Tree (N, Relocate_Node (CE_Node)); Set_Is_Static_Expression (N, Static); return; end if; -- At this point we have a potentially foldable attribute reference. -- If Static is set, then the attribute reference definitely obeys -- the requirements in (RM 4.9(7,8,22)), and it definitely can be -- folded. If Static is not set, then the attribute may or may not -- be foldable, and the individual attribute processing routines -- test Static as required in cases where it makes a difference. case Id is -------------- -- Adjacent -- -------------- when Attribute_Adjacent => if Static then Fold_Ureal (N, Eval_Fat.Adjacent (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2))); end if; --------- -- Aft -- --------- when Attribute_Aft => Fold_Uint (N, UI_From_Int (Aft_Value)); --------------- -- Alignment -- --------------- when Attribute_Alignment => -- If alignment clause given, get value from clause if Has_Alignment_Clause (P_Type) then Fold_Uint (N, Expr_Value (Expression (Alignment_Clause (P_Type)))); -- For all non-scalar types, return maximum alignment. This is a -- temporary kludge, really Gigi should handle alignment here. ??? elsif not (Is_Scalar_Type (P_Type)) then Fold_Uint (N, UI_From_Int (Ttypes.Maximum_Alignment)); -- For scalar types, we calculate the alignmnent as the largest power -- of two multiple of System.Storage_Unit that does not exceed either -- the actual size of the type, or the maximum required alignment else declare S : constant Int := UI_To_Int (Esize (P_Type)) / Ttypes.System_Storage_Unit; A : Int; begin A := 1; while 2 * A <= Ttypes.Maximum_Alignment and then 2 * A <= S loop A := 2 * A; end loop; Fold_Uint (N, UI_From_Int (A)); end; end if; ------------------ -- Body_Version -- ------------------ -- Body_version can never be static when Attribute_Body_Version => null; ------------- -- Ceiling -- ------------- when Attribute_Ceiling => if Static then Fold_Ureal (N, Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1))); end if; ------------- -- Compose -- ------------- when Attribute_Compose => if Static then Fold_Ureal (N, Eval_Fat.Compose (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2))); end if; --------------- -- Copy_Sign -- --------------- when Attribute_Copy_Sign => if Static then Fold_Ureal (N, Eval_Fat.Copy_Sign (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2))); end if; ----------- -- Delta -- ----------- when Attribute_Delta => Fold_Ureal (N, Delta_Value (P_Type)); -------------- -- Definite -- -------------- when Attribute_Definite => declare Result : Node_Id; begin if Is_Indefinite_Subtype (P_Entity) then Result := New_Occurrence_Of (Standard_False, Loc); else Result := New_Occurrence_Of (Standard_True, Loc); end if; Rewrite_Substitute_Tree (N, Result); Analyze (N); Resolve (N, Standard_Boolean); end; ------------ -- Denorm -- ------------ when Attribute_Denorm => Float_Attribute_Boolean ( Short_Float_Attr_Denorm, Float_Attr_Denorm, Long_Float_Attr_Denorm, Long_Long_Float_Attr_Denorm); ------------ -- Digits -- ------------ when Attribute_Digits => Fold_Uint (N, Digits_Value (P_Type)); ---------- -- Emax -- ---------- when Attribute_Emax => Float_Attribute_Universal_Integer ( Short_Float_Attr_Emax, Float_Attr_Emax, Long_Float_Attr_Emax, Long_Long_Float_Attr_Emax); -------------- -- Enum_Rep -- -------------- when Attribute_Enum_Rep => if Static then Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1))); end if; ------------- -- Epsilon -- ------------- when Attribute_Epsilon => Float_Attribute_Universal_Real ( Short_Float_Attr_Epsilon'Universal_Literal_String, Float_Attr_Epsilon'Universal_Literal_String, Long_Float_Attr_Epsilon'Universal_Literal_String, Long_Long_Float_Attr_Epsilon'Universal_Literal_String); -------------- -- Exponent -- -------------- when Attribute_Exponent => if Static then Fold_Uint (N, Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1))); end if; ----------- -- First -- ----------- when Attribute_First => First_Attr : begin Set_Bounds; if Static and Is_OK_Static_Expression (Lo_Bound) then if Is_Real_Type (P_Type) then Fold_Ureal (N, Expr_Value_R (Lo_Bound)); else Fold_Uint (N, Expr_Value (Lo_Bound)); end if; end if; end First_Attr; ----------------- -- Fixed_Value -- ----------------- when Attribute_Fixed_Value => if Static then Fold_Ureal (N, UR_From_Uint (Expr_Value (E1)) * Small_Value (P_Type)); end if; ----------- -- Floor -- ----------- when Attribute_Floor => if Static then Fold_Ureal (N, Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1))); end if; ---------- -- Fore -- ---------- when Attribute_Fore => if Static then Fold_Uint (N, UI_From_Int (Fore_Value)); end if; -------------- -- Fraction -- -------------- when Attribute_Fraction => if Static then Fold_Ureal (N, Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1))); end if; ----------- -- Image -- ----------- -- Image is a scalar attribute, but is never static, because it is -- not a static function (having a non-scalar argument (RM 4.9(22)) when Attribute_Image => null; --------- -- Img -- --------- -- Img is a scalar attribute, but is never static, because it is -- not a static function (having a non-scalar argument (RM 4.9(22)) when Attribute_Img => null; ------------------- -- Integer_Value -- ------------------- when Attribute_Integer_Value => if Static then Fold_Uint (N, Expr_Value (E1)); end if; ----------- -- Large -- ----------- when Attribute_Large => Float_Attribute_Universal_Real ( Short_Float_Attr_Large'Universal_Literal_String, Float_Attr_Large'Universal_Literal_String, Long_Float_Attr_Large'Universal_Literal_String, Long_Long_Float_Attr_Large'Universal_Literal_String); ---------- -- Last -- ---------- when Attribute_Last => Last : begin Set_Bounds; if Static and Is_OK_Static_Expression (Hi_Bound) then if Is_Real_Type (P_Type) then Fold_Ureal (N, Expr_Value_R (Hi_Bound)); else Fold_Uint (N, Expr_Value (Hi_Bound)); end if; end if; end Last; ------------------ -- Leading_Part -- ------------------ when Attribute_Leading_Part => if Static then Fold_Ureal (N, Eval_Fat.Leading_Part (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2))); end if; ------------ -- Length -- ------------ when Attribute_Length => Length : begin Set_Bounds; if Is_OK_Static_Expression (Lo_Bound) and then Is_OK_Static_Expression (Hi_Bound) then Fold_Uint (N, UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound)))); end if; end Length; ------------- -- Machine -- ------------- when Attribute_Machine => if Static then Fold_Ureal (N, Eval_Fat.Machine (P_Root_Type, Expr_Value_R (E1))); end if; ------------------ -- Machine_Emax -- ------------------ when Attribute_Machine_Emax => Float_Attribute_Universal_Integer ( Short_Float_Attr_Machine_Emax, Float_Attr_Machine_Emax, Long_Float_Attr_Machine_Emax, Long_Long_Float_Attr_Machine_Emax); ------------------ -- Machine_Emin -- ------------------ when Attribute_Machine_Emin => Float_Attribute_Universal_Integer ( Short_Float_Attr_Machine_Emin, Float_Attr_Machine_Emin, Long_Float_Attr_Machine_Emin, Long_Long_Float_Attr_Machine_Emin); ---------------------- -- Machine_Mantissa -- ---------------------- when Attribute_Machine_Mantissa => Float_Attribute_Universal_Integer ( Short_Float_Attr_Machine_Mantissa, Float_Attr_Machine_Mantissa, Long_Float_Attr_Machine_Mantissa, Long_Long_Float_Attr_Machine_Mantissa); ----------------------- -- Machine_Overflows -- ----------------------- when Attribute_Machine_Overflows => Float_Attribute_Boolean ( Short_Float_Attr_Machine_Overflows, Float_Attr_Machine_Overflows, Long_Float_Attr_Machine_Overflows, Long_Long_Float_Attr_Machine_Overflows); ------------------- -- Machine_Radix -- ------------------- when Attribute_Machine_Radix => if Is_Fixed_Point_Type (P_Type) then if Is_Decimal_Fixed_Point_Type (P_Type) and then Machine_Radix_10 (P_Type) then Fold_Uint (N, Uint_10); else Fold_Uint (N, Uint_2); end if; else Float_Attribute_Universal_Integer ( Short_Float_Attr_Machine_Radix, Float_Attr_Machine_Radix, Long_Float_Attr_Machine_Radix, Long_Long_Float_Attr_Machine_Radix); end if; -------------------- -- Machine_Rounds -- -------------------- when Attribute_Machine_Rounds => Float_Attribute_Boolean ( Short_Float_Attr_Machine_Rounds, Float_Attr_Machine_Rounds, Long_Float_Attr_Machine_Rounds, Long_Long_Float_Attr_Machine_Rounds); -------------- -- Mantissa -- -------------- when Attribute_Mantissa => Float_Attribute_Universal_Integer ( Short_Float_Attr_Mantissa, Float_Attr_Mantissa, Long_Float_Attr_Mantissa, Long_Long_Float_Attr_Mantissa); --------- -- Max -- --------- when Attribute_Max => Max : begin if Is_Real_Type (P_Type) then Fold_Ureal (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2))); else Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2))); end if; end Max; ---------------------------------- -- Max_Size_In_Storage_Elements -- ---------------------------------- -- Max_Size_In_Storage_Elements is simply the Size rounded up to a -- Storage_Unit boundary. We can fold any cases for which the size -- is known by the front end. when Attribute_Max_Size_In_Storage_Elements => if Esize (P_Type) /= 0 then Fold_Uint (N, (Esize (P_Type) + System_Storage_Unit - 1) / System_Storage_Unit); end if; --------- -- Min -- --------- when Attribute_Min => Min : begin if Is_Real_Type (P_Type) then Fold_Ureal (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2))); else Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2))); end if; end Min; ----------- -- Model -- ----------- when Attribute_Model => if Static then Fold_Ureal (N, Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1))); end if; ---------------- -- Model_Emin -- ---------------- when Attribute_Model_Emin => Float_Attribute_Universal_Integer ( Short_Float_Attr_Model_Emin, Float_Attr_Model_Emin, Long_Float_Attr_Model_Emin, Long_Long_Float_Attr_Model_Emin); ------------------- -- Model_Epsilon -- ------------------- when Attribute_Model_Epsilon => Float_Attribute_Universal_Real ( Short_Float_Attr_Model_Epsilon'Universal_Literal_String, Float_Attr_Model_Epsilon'Universal_Literal_String, Long_Float_Attr_Model_Epsilon'Universal_Literal_String, Long_Long_Float_Attr_Model_Epsilon'Universal_Literal_String); -------------------- -- Model_Mantissa -- -------------------- when Attribute_Model_Mantissa => Float_Attribute_Universal_Integer ( Short_Float_Attr_Model_Mantissa, Float_Attr_Model_Mantissa, Long_Float_Attr_Model_Mantissa, Long_Long_Float_Attr_Model_Mantissa); ----------------- -- Model_Small -- ----------------- when Attribute_Model_Small => Float_Attribute_Universal_Real ( Short_Float_Attr_Model_Small'Universal_Literal_String, Float_Attr_Model_Small'Universal_Literal_String, Long_Float_Attr_Model_Small'Universal_Literal_String, Long_Long_Float_Attr_Model_Small'Universal_Literal_String); ------------- -- Modulus -- ------------- when Attribute_Modulus => Fold_Uint (N, Modulus (P_Type)); ------------------------- -- Passed_By_Reference -- ------------------------- -- Scalar types are never passed by reference when Attribute_Passed_By_Reference => Fold_Uint (N, Uint_0); --------- -- Pos -- --------- when Attribute_Pos => Fold_Uint (N, Expr_Value (E1)); ---------- -- Pred -- ---------- when Attribute_Pred => Pred : begin if Static then -- Floating-point case if Is_Floating_Point_Type (P_Type) then Fold_Ureal (N, Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1))); -- Fixed-point case elsif Is_Fixed_Point_Type (P_Type) then Fold_Ureal (N, Expr_Value_R (E1) + Small_Value (P_Type)); -- Scalar case else pragma Assert (Is_Scalar_Type (P_Type)); if Expr_Value (E1) = Expr_Value (Type_Low_Bound (P_Type)) then Compile_Time_Constraint_Error (N, "Pred of type''First"); Check_Expressions; return; else Fold_Uint (N, Expr_Value (E1) - 1); end if; end if; end if; end Pred; ----------- -- Range -- ----------- -- No processing required, because by this stage, Range has been -- replaced by First .. Last, so this branch can never be taken. when Attribute_Range => pragma Assert (False); null; ------------------ -- Range_Length -- ------------------ when Attribute_Range_Length => Set_Bounds; if Is_OK_Static_Expression (Hi_Bound) and then Is_OK_Static_Expression (Lo_Bound) then Fold_Uint (N, UI_Max (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1)); end if; --------------- -- Remainder -- --------------- when Attribute_Remainder => if Static then Fold_Ureal (N, Eval_Fat.Remainder (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2))); end if; ----------- -- Round -- ----------- when Attribute_Round => Round : declare Sr : Ureal; Si : Uint; begin if Static then -- First we get the (exact result) in units of small Sr := Expr_Value_R (E1) / Small_Value (C_Type); -- Now round that exactly to an integer Si := UR_To_Uint (Sr); -- Finally the result is obtained by converting back to real Fold_Ureal (N, Si * Small_Value (C_Type)); end if; end Round; -------------- -- Rounding -- -------------- when Attribute_Rounding => if Static then Fold_Ureal (N, Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1))); end if; --------------- -- Safe_Emax -- --------------- when Attribute_Safe_Emax => Float_Attribute_Universal_Integer ( Short_Float_Attr_Safe_Emax, Float_Attr_Safe_Emax, Long_Float_Attr_Safe_Emax, Long_Long_Float_Attr_Safe_Emax); ---------------- -- Safe_First -- ---------------- when Attribute_Safe_First => Float_Attribute_Universal_Real ( Short_Float_Attr_Safe_First'Universal_Literal_String, Float_Attr_Safe_First'Universal_Literal_String, Long_Float_Attr_Safe_First'Universal_Literal_String, Long_Long_Float_Attr_Safe_First'Universal_Literal_String); ---------------- -- Safe_Large -- ---------------- when Attribute_Safe_Large => Float_Attribute_Universal_Real ( Short_Float_Attr_Safe_Large'Universal_Literal_String, Float_Attr_Safe_Large'Universal_Literal_String, Long_Float_Attr_Safe_Large'Universal_Literal_String, Long_Long_Float_Attr_Safe_Large'Universal_Literal_String); --------------- -- Safe_Last -- --------------- when Attribute_Safe_Last => Float_Attribute_Universal_Real ( Short_Float_Attr_Safe_Last'Universal_Literal_String, Float_Attr_Safe_Last'Universal_Literal_String, Long_Float_Attr_Safe_Last'Universal_Literal_String, Long_Long_Float_Attr_Safe_Last'Universal_Literal_String); ---------------- -- Safe_Small -- ---------------- when Attribute_Safe_Small => Float_Attribute_Universal_Real ( Short_Float_Attr_Safe_Small'Universal_Literal_String, Float_Attr_Safe_Small'Universal_Literal_String, Long_Float_Attr_Safe_Small'Universal_Literal_String, Long_Long_Float_Attr_Safe_Small'Universal_Literal_String); ----------- -- Scale -- ----------- when Attribute_Scale => Fold_Uint (N, Scale_Value (P_Type)); ------------- -- Scaling -- ------------- when Attribute_Scaling => if Static then Fold_Ureal (N, Eval_Fat.Scaling (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2))); end if; ------------------ -- Signed_Zeros -- ------------------ when Attribute_Signed_Zeros => Float_Attribute_Boolean ( Short_Float_Attr_Signed_Zeros, Float_Attr_Signed_Zeros, Long_Float_Attr_Signed_Zeros, Long_Long_Float_Attr_Signed_Zeros); ---------- -- Size -- ---------- -- Size attribute returns the size. All scalar types can be folded, -- as well as any types for which the size is known by the front end, -- including any type for which a size attribute is specified. when Attribute_Size => if Esize (P_Type) /= 0 then Fold_Uint (N, Esize (P_Type)); end if; ----------- -- Small -- ----------- when Attribute_Small => Fold_Ureal (N, Small_Value (P_Type)); ---------- -- Succ -- ---------- when Attribute_Succ => Succ : begin if Static then -- Floating-point case if Is_Floating_Point_Type (P_Type) then Fold_Ureal (N, Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1))); -- Fixed-point case elsif Is_Fixed_Point_Type (P_Type) then Fold_Ureal (N, Expr_Value_R (E1) + Small_Value (P_Type)); -- Scalar case else pragma Assert (Is_Scalar_Type (P_Type)); if Expr_Value (E1) = Expr_Value (Type_High_Bound (P_Type)) then Compile_Time_Constraint_Error (N, "Succ of type''Last"); Check_Expressions; return; else Fold_Uint (N, Expr_Value (E1) + 1); end if; end if; end if; end Succ; ---------------- -- Truncation -- ---------------- when Attribute_Truncation => if Static then Fold_Ureal (N, Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1))); end if; ----------------------- -- Unbiased_Rounding -- ----------------------- when Attribute_Unbiased_Rounding => if Static then Fold_Ureal (N, Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1))); end if; --------- -- Val -- --------- when Attribute_Val => Val : begin if Static then if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Type)) or else Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Type)) then Compile_Time_Constraint_Error (N, "Pos out of range"); Check_Expressions; return; else Fold_Uint (N, Expr_Value (E1)); end if; end if; end Val; ------------- -- Version -- ------------- -- Version can never be static when Attribute_Version => null; ---------------- -- Wide_Image -- ---------------- -- Wide_Image is a scalar attribute, but is never static, because it -- is not a static function (having a non-scalar argument (RM 4.9(22)) when Attribute_Wide_Image => null; ---------------- -- Wide_Width -- ---------------- -- Processing for Wide_Width is combined with Width ----------- -- Width -- ----------- -- This processing also handles the case of Wide_Width when Attribute_Width | Attribute_Wide_Width => Width : begin if Static then -- Floating-point types if Is_Floating_Point_Type (P_Type) then -- Width is zero for a null range (RM 3.5 (38)) if Expr_Value_R (Type_High_Bound (P_Type)) < Expr_Value_R (Type_Low_Bound (P_Type)) then Fold_Uint (N, Uint_0); else -- For floating-point, we have +N.dddE+nnn where length -- of ddd is determined by type'Digits - 1 (but is one -- if Digits is one (RM 3.5 (33)) Fold_Uint (N, UI_From_Int (7 + Int'Max (2, UI_To_Int (Digits_Value (P_Type))))); end if; -- Fixed-point types elsif Is_Fixed_Point_Type (P_Type) then -- Width is zero for a null range (RM 3.5 (38)) if Expr_Value (Type_High_Bound (P_Type)) < Expr_Value (Type_Low_Bound (P_Type)) then Fold_Uint (N, Uint_0); -- The non-null case depends on the specific real type else -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) Fold_Uint (N, UI_From_Int (Fore_Value + 1 + Aft_Value)); end if; -- Discrete types else declare R : constant Entity_Id := Root_Type (P_Type); Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type)); Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type)); W : Nat; Wt : Nat; T : Uint; L : Node_Id; C : Character; begin -- Empty ranges if Lo > Hi then W := 0; -- Width for types derived from Standard.Character -- and Standard.Wide_Character. elsif R = Standard_Character or else R = Standard_Wide_Character then W := 0; -- Set W larger if needed for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop -- Assume all wide-character escape sequences are -- same length, so we can quit when we reach one. if J > 255 then if Id = Attribute_Wide_Width then W := Int'Max (W, 3); exit; else W := Int'Max (W, Length_Wide); exit; end if; else C := Character'Val (J); -- Test for all cases where Character'Image -- yields an image that is longer than three -- characters. First the cases of Reserved_xxx -- names (length = 12). case C is when Reserved_128 | Reserved_129 | Reserved_132 | Reserved_153 => Wt := 12; when BS | HT | LF | VT | FF | CR | SO | SI | EM | FS | GS | RS | US | RI | MW | ST | PM => Wt := 2; when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | SUB | ESC | DEL | BPH | NBH | NEL | SSA | ESA | HTS | HTJ | VTS | PLD | PLU | SS2 | SS3 | DCS | PU1 | PU2 | STS | CCH | SPA | EPA | SOS | SCI | CSI | OSC | APC => Wt := 3; when Space .. Tilde | No_Break_Space .. LC_Y_Diaeresis => Wt := 3; end case; W := Int'Max (W, Wt); end if; end loop; -- Width for types derived from Standard.Boolean elsif R = Standard_Boolean then if Lo = 0 then W := 5; -- FALSE else W := 4; -- TRUE end if; -- Width for integer types elsif Is_Integer_Type (P_Type) then T := UI_Max (abs Lo, abs Hi); W := 2; while T >= 10 loop W := W + 1; T := T / 10; end loop; -- Only remaining possibility is user declared enum type else pragma Assert (Is_Enumeration_Type (P_Type)); W := 0; L := First_Literal (P_Type); while Present (L) loop -- Only pay attention to in range characters if Lo <= Enumeration_Pos (L) and then Enumeration_Pos (L) <= Hi then -- For Width case, use decoded name if Id = Attribute_Width then Get_Decoded_Name_String (Chars (L)); Wt := Nat (Name_Len); -- For Wide_Width, use encoded name, and then -- adjust for the encoding. else Get_Name_String (Chars (L)); -- Character literals are always of length 3 if Name_Buffer (1) = 'Q' then Wt := 3; -- Otherwise loop to adjust for upper/wide chars else Wt := Nat (Name_Len); for J in 1 .. Name_Len loop if Name_Buffer (J) = 'U' then Wt := Wt - 2; elsif Name_Buffer (J) = 'W' then Wt := Wt - 4; end if; end loop; end if; end if; W := Int'Max (W, Wt); end if; L := Next_Literal (L); end loop; end if; Fold_Uint (N, UI_From_Int (W)); end; end if; end if; end Width; -- The following attributes can never be folded, and furthermore we -- should not even have entered the case statement for any of these. -- Note that in some cases, the values have already been folded as -- a result of the processing in Analyze_Attribute. when Attribute_Abort_Signal | Attribute_Access | Attribute_Address | Attribute_Address_Size | Attribute_Base | Attribute_Bit_Order | Attribute_Callable | Attribute_Caller | Attribute_Class | Attribute_Component_Size | Attribute_Constrained | Attribute_Count | Attribute_Default_Bit_Order | Attribute_Elab_Body | Attribute_Elab_Spec | Attribute_External_Tag | Attribute_First_Bit | Attribute_Identity | Attribute_Input | Attribute_Last_Bit | Attribute_Max_Interrupt_Priority | Attribute_Max_Priority | Attribute_Maximum_Alignment | Attribute_Output | Attribute_Partition_ID | Attribute_Position | Attribute_Read | Attribute_Storage_Pool | Attribute_Storage_Size | Attribute_Storage_Unit | Attribute_Tag | Attribute_Terminated | Attribute_Tick | Attribute_Unchecked_Access | Attribute_Universal_Literal_String | Attribute_Unrestricted_Access | Attribute_Valid | Attribute_Value | Attribute_Wide_Value | Attribute_Word_Size | Attribute_Write => pragma Assert (False); null; end case; -- At the end of the case, one more check. If we did a static evaluation -- so that the result is now an integer or real constant, then set the -- Is_Static_Expression flag in this literal only if the prefix type is -- a static subtype. For non-static subtypes, the replacement is still -- OK, but cannot be considered to be static. if Nkind (N) /= N_Attribute_Reference then Set_Is_Static_Expression (N, Static); -- If this is still an attribute reference, then it has not been folded -- and that means that its expressions are in a non-static context. else Check_Expressions; end if; end Eval_Attribute; ----------------------- -- Resolve_Attribute -- ----------------------- procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); P : constant Node_Id := Prefix (N); Aname : constant Name_Id := Attribute_Name (N); Index : Interp_Index; It : Interp; Btyp : Entity_Id := Base_Type (Typ); begin -- If attribute was universal type, reset to actual type if Etype (N) = Universal_Integer or else Etype (N) = Universal_Real then Set_Etype (N, Typ); end if; -- Remaining processing depends on attribute case Get_Attribute_Id (Aname) is ------------ -- Access -- ------------ -- For access attributes, if the prefix denotes an entity, it is -- interpreted as a name, never as a call. It may be overloaded, -- in which case resolution uses the profile of the context type. -- Otherwise prefix must be resolved. when Attribute_Access | Attribute_Unchecked_Access | Attribute_Unrestricted_Access => if Is_Entity_Name (P) then if Is_Overloaded (P) then Get_First_Interp (P, Index, It); while Present (It.Nam) loop if Type_Conformant (Designated_Type (Typ), It.Nam) then Set_Entity (P, It.Nam); exit; end if; Get_Next_Interp (Index, It); end loop; elsif not Is_Overloadable (Entity (P)) and then not Is_Type (Entity (P)) then Resolve (P, Etype (P)); end if; if not Is_Entity_Name (P) then null; elsif Is_Abstract (Entity (P)) then Error_Msg_Name_1 := Aname; Error_Msg_N ("prefix of % attribute cannot be abstract", P); Set_Etype (N, Any_Type); elsif Convention (Entity (P)) = Convention_Intrinsic then Error_Msg_Name_1 := Aname; Error_Msg_N ("prefix of % attribute cannot be intrinsic", P); Set_Etype (N, Any_Type); end if; -- Assignments, return statements, components of aggregates, -- generic instantiations will require convention checks if -- the type is an access to subprogram. Given that there will -- also be accessibility checks on those, this is where the -- checks can eventually be centralized ??? if Ekind (Btyp) = E_Access_Subprogram_Type then if Convention (Btyp) /= Convention (Entity (P)) then Error_Msg_N ("conventions must match", P); end if; if Get_Attribute_Id (Aname) = Attribute_Unchecked_Access then Error_Msg_Name_1 := Aname; Error_Msg_N ("prefix of % attribute must aliased object", P); -- Check the static accessibility rule of 3.10.2(32) elsif Get_Attribute_Id (Aname) = Attribute_Access and then Subprogram_Access_Level (Entity (P)) > Type_Access_Level (Btyp) then Error_Msg_N ("subprogram must not be deeper than access type?", P); Temporary_Msg_N ("this will be a fatal error in the next release?!", P); Temporary_Msg_N ("see gnatinfo.txt for details?!", P); end if; end if; else Resolve (P, Etype (P)); end if; -- Check the static accessibility rule of 3.10.2(28). -- Note that this check is not performed for the -- case of an anonymous access type, since the access -- attribute is always legal in such a context. if Ekind (Btyp) = E_General_Access_Type and then Get_Attribute_Id (Aname) = Attribute_Access then if Object_Access_Level (P) > Type_Access_Level (Btyp) then Error_Msg_N ("object must not be deeper than the access type?", P); Temporary_Msg_N ("this will be a fatal error in 2.06, see gnatinfo.txt?", P); end if; end if; Set_Etype (N, Typ); ------------- -- Address -- ------------- -- Deal with resolving the type for Address attribute, overloading -- is not permitted here, since there is no context to resolve it. when Attribute_Address => if not Is_Entity_Name (P) or else not Is_Overloadable (Entity (P)) then if not Is_Task_Type (Etype (P)) then Resolve (P, Etype (P)); end if; elsif Is_Overloaded (P) then Get_First_Interp (P, Index, It); Get_Next_Interp (Index, It); if Present (It.Nam) then Error_Msg_Name_1 := Aname; Error_Msg_N ("prefix of % attribute cannot be overloaded", N); end if; end if; ----------- -- Count -- ----------- -- Prefix of the Count attribute is an entry name, which should -- not be resolved, lest is appears as a call. when Attribute_Count => null; ----------- -- Range -- ----------- -- We replace the Range attribute node with a range expression -- whose bounds are the 'First and 'Last attributes applied to the -- same prefix. The reason that we do this transformation here -- instead of in the expander is that it simplifies other parts of -- the semantic analysis which assume that the Range has been -- replaced; thus it must be done even when in semantic-only mode -- (note that the RM specifically mentions this equivalence, we -- take care that the prefix is only evaluated once). when Attribute_Range => declare LB : Node_Id; HB : Node_Id; begin if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then Resolve (P, Etype (P)); end if; HB := Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (P), Attribute_Name => Name_Last, Expressions => Expressions (N)); LB := Make_Attribute_Reference (Loc, Prefix => P, Attribute_Name => Name_First, Expressions => Expressions (N)); Rewrite_Substitute_Tree (N, Make_Range (Loc, LB, HB)); Analyze (N); Resolve (N, Typ); -- Normally after resolving attribute nodes, Eval_Attribute -- is called to do any possible static evaluation of the node. -- However, here since the Range attribute has just been -- transformed into a range expression it is no longer an -- attribute node and therefore the call needs to be avoided -- and is accomplished by simply returning from the procedure. return; end; ---------------------- -- Unchecked_Access -- ---------------------- -- Processing is shared with Access ------------------------- -- Unrestricted_Access -- ------------------------- -- Processing is shared with Access ---------------------- -- Other Attributes -- ---------------------- -- For other attributes, resolve prefix unless it is a type. If -- the attribute reference itself is a type name ('Base and 'Class) -- then this is only legal within a task or protected record. when others => if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then Resolve (P, Etype (P)); elsif Is_Entity_Name (N) then if Is_Concurrent_Type (Entity (P)) and then In_Open_Scopes (Entity (P)) then null; else Error_Msg_N ("Invalid use of subtype name in expression or call", N); end if; end if; end case; -- Normally the Freezing is done by Resolve but sometimes the Prefix is -- not resolved, in which case the freezing must be done. Freeze_Expression (P); Eval_Attribute (N); end Resolve_Attribute; --------------------- -- In_Generic_Unit -- --------------------- function In_Generic_Unit return Boolean is S : Entity_Id := Current_Scope; begin while Present (S) and then S /= Standard_Standard loop if Ekind (S) = E_Generic_Function or else Ekind (S) = E_Generic_Package or else Ekind (S) = E_Generic_Procedure then return True; end if; S := Scope (S); end loop; return False; end In_Generic_Unit; end Sem_Attr;