X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_attr.adb;h=210e49c0a01c30853e5541b7fe7cba4bbcbdc2be;hb=c0a208a52ba10b65d217c635ddddf7a07ea51ebd;hp=e62e55cde09c6c1b8bde31d849f131d68b82db58;hpb=e8548746a5f859f185985d092e08839492f70f21;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e62e55cde09..210e49c0a01 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -52,6 +52,7 @@ with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; +with Sem_Dim; use Sem_Dim; with Sem_Dist; use Sem_Dist; with Sem_Elim; use Sem_Elim; with Sem_Eval; use Sem_Eval; @@ -85,61 +86,61 @@ package body Sem_Attr is -- that are not included in Ada 95, but still get recognized in GNAT. Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Address | - Attribute_Aft | - Attribute_Alignment | - Attribute_Base | - Attribute_Callable | - Attribute_Constrained | - Attribute_Count | - Attribute_Delta | - Attribute_Digits | - Attribute_Emax | - Attribute_Epsilon | - Attribute_First | - Attribute_First_Bit | - Attribute_Fore | - Attribute_Image | - Attribute_Large | - Attribute_Last | - Attribute_Last_Bit | - Attribute_Leading_Part | - Attribute_Length | - Attribute_Machine_Emax | - Attribute_Machine_Emin | - Attribute_Machine_Mantissa | - Attribute_Machine_Overflows | - Attribute_Machine_Radix | - Attribute_Machine_Rounds | - Attribute_Mantissa | - Attribute_Pos | - Attribute_Position | - Attribute_Pred | - Attribute_Range | - Attribute_Safe_Emax | - Attribute_Safe_Large | - Attribute_Safe_Small | - Attribute_Size | - Attribute_Small | - Attribute_Storage_Size | - Attribute_Succ | - Attribute_Terminated | - Attribute_Val | - Attribute_Value | - Attribute_Width => True, - others => False); + Attribute_Address | + Attribute_Aft | + Attribute_Alignment | + Attribute_Base | + Attribute_Callable | + Attribute_Constrained | + Attribute_Count | + Attribute_Delta | + Attribute_Digits | + Attribute_Emax | + Attribute_Epsilon | + Attribute_First | + Attribute_First_Bit | + Attribute_Fore | + Attribute_Image | + Attribute_Large | + Attribute_Last | + Attribute_Last_Bit | + Attribute_Leading_Part | + Attribute_Length | + Attribute_Machine_Emax | + Attribute_Machine_Emin | + Attribute_Machine_Mantissa | + Attribute_Machine_Overflows | + Attribute_Machine_Radix | + Attribute_Machine_Rounds | + Attribute_Mantissa | + Attribute_Pos | + Attribute_Position | + Attribute_Pred | + Attribute_Range | + Attribute_Safe_Emax | + Attribute_Safe_Large | + Attribute_Safe_Small | + Attribute_Size | + Attribute_Small | + Attribute_Storage_Size | + Attribute_Succ | + Attribute_Terminated | + Attribute_Val | + Attribute_Value | + Attribute_Width => True, + others => False); -- The following array is the list of attributes defined in the Ada 2005 -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode, -- but in Ada 95 they are considered to be implementation defined. Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Machine_Rounding | - Attribute_Mod | - Attribute_Priority | - Attribute_Stream_Size | - Attribute_Wide_Wide_Width => True, - others => False); + Attribute_Machine_Rounding | + Attribute_Mod | + Attribute_Priority | + Attribute_Stream_Size | + Attribute_Wide_Wide_Width => True, + others => False); -- The following array contains all attributes that imply a modification -- of their prefixes or result in an access value. Such prefixes can be @@ -147,13 +148,13 @@ package body Sem_Attr is Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Access | - Attribute_Address | - Attribute_Input | - Attribute_Read | - Attribute_Unchecked_Access | - Attribute_Unrestricted_Access => True, - others => False); + Attribute_Access | + Attribute_Address | + Attribute_Input | + Attribute_Read | + Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => True, + others => False); ----------------------- -- Local_Subprograms -- @@ -211,6 +212,15 @@ package body Sem_Attr is -- Used for Access, Unchecked_Access, Unrestricted_Access attributes. -- Internally, Id distinguishes which of the three cases is involved. + procedure Bad_Attribute_For_Predicate; + -- Output error message for use of a predicate (First, Last, Range) not + -- allowed with a type that has predicates. If the type is a generic + -- actual, then the message is a warning, and we generate code to raise + -- program error with an appropriate reason. No error message is given + -- for internally generated uses of the attributes. + -- The legality rule only applies to scalar types, even though the + -- current AI mentions all subtypes. + 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 @@ -255,6 +265,10 @@ package body Sem_Attr is -- If the prefix type is an enumeration type, set all its literals -- as referenced, since the image function could possibly end up -- referencing any of the literals indirectly. Same for Enum_Val. + -- Set the flag only if the reference is in the main code unit. Same + -- restriction when resolving 'Value; otherwise an improperly set + -- reference when analyzing an inlined body will lose a proper warning + -- on a useless with_clause. procedure Check_Fixed_Point_Type; -- Verify that prefix of attribute N is a fixed type @@ -282,12 +296,12 @@ package body Sem_Attr is -- Common processing for attributes Definite and Has_Discriminants. -- Checks that prefix is generic indefinite formal type. + procedure Check_SPARK_Restriction_On_Attribute; + -- Issue an error in formal mode because attribute N is allowed + procedure Check_Integer_Type; -- Verify that prefix of attribute N is an integer type - procedure Check_Library_Unit; - -- Verify that prefix of attribute N is a library unit - procedure Check_Modular_Integer_Type; -- Verify that prefix of attribute N is a modular integer type @@ -334,8 +348,8 @@ package body Sem_Attr is -- itself of the form of a library unit name. Note that this is -- quite different from Check_Program_Unit, since it only checks -- the syntactic form of the name, not the semantic identity. This - -- is because it is used with attributes (Elab_Body, Elab_Spec, and - -- UET_Address) which can refer to non-visible unit. + -- is because it is used with attributes (Elab_Body, Elab_Spec, + -- UET_Address and Elaborated) which can refer to non-visible unit. procedure Error_Attr (Msg : String; Error_Node : Node_Id); pragma No_Return (Error_Attr); @@ -558,6 +572,7 @@ package body Sem_Attr is -- Start of processing for Analyze_Access_Attribute begin + Check_SPARK_Restriction_On_Attribute; Check_E0; if Nkind (P) = N_Character_Literal then @@ -591,30 +606,35 @@ package body Sem_Attr is Build_Access_Subprogram_Type (P); - -- For unrestricted access, kill current values, since this - -- attribute allows a reference to a local subprogram that - -- could modify local variables to be passed out of scope - - if Aname = Name_Unrestricted_Access then - - -- Do not kill values on nodes initializing dispatch tables - -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) - -- is currently generated by the expander only for this - -- purpose. Done to keep the quality of warnings currently - -- generated by the compiler (otherwise any declaration of - -- a tagged type cleans constant indications from its scope). - - if Nkind (Parent (N)) = N_Unchecked_Type_Conversion - and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) - or else - Etype (Parent (N)) = RTE (RE_Size_Ptr)) - and then Is_Dispatching_Operation - (Directly_Designated_Type (Etype (N))) - then - null; - else - Kill_Current_Values; - end if; + -- For P'Access or P'Unrestricted_Access, where P is a nested + -- subprogram, we might be passing P to another subprogram (but we + -- don't check that here), which might call P. P could modify + -- local variables, so we need to kill current values. It is + -- important not to do this for library-level subprograms, because + -- Kill_Current_Values is very inefficient in the case of library + -- level packages with lots of tagged types. + + if Is_Library_Level_Entity (Entity (Prefix (N))) then + null; + + -- Do not kill values on nodes initializing dispatch tables + -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access) + -- is currently generated by the expander only for this + -- purpose. Done to keep the quality of warnings currently + -- generated by the compiler (otherwise any declaration of + -- a tagged type cleans constant indications from its scope). + + elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion + and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr) + or else + Etype (Parent (N)) = RTE (RE_Size_Ptr)) + and then Is_Dispatching_Operation + (Directly_Designated_Type (Etype (N))) + then + null; + + else + Kill_Current_Values; end if; return; @@ -823,9 +843,25 @@ package body Sem_Attr is and then not In_Inlined_Body then Error_Attr_P ("prefix of % attribute must be aliased"); + Check_No_Implicit_Aliasing (P); end if; end Analyze_Access_Attribute; + --------------------------------- + -- Bad_Attribute_For_Predicate -- + --------------------------------- + + procedure Bad_Attribute_For_Predicate is + begin + if Is_Scalar_Type (P_Type) + and then Comes_From_Source (N) + then + Error_Msg_Name_1 := Aname; + Bad_Predicated_Subtype_Use + ("type& has predicates, attribute % not allowed", N, P_Type); + end if; + end Bad_Attribute_For_Predicate; + -------------------------------- -- Check_Array_Or_Scalar_Type -- -------------------------------- @@ -1189,8 +1225,17 @@ package body Sem_Attr is procedure Check_Enum_Image is Lit : Entity_Id; + begin - if Is_Enumeration_Type (P_Base_Type) then + -- When an enumeration type appears in an attribute reference, all + -- literals of the type are marked as referenced. This must only be + -- done if the attribute reference appears in the current source. + -- Otherwise the information on references may differ between a + -- normal compilation and one that performs inlining. + + if Is_Enumeration_Type (P_Base_Type) + and then In_Extended_Main_Code_Unit (N) + then Lit := First_Literal (P_Base_Type); while Present (Lit) loop Set_Referenced (Lit); @@ -1278,17 +1323,6 @@ package body Sem_Attr is end if; end Check_Integer_Type; - ------------------------ - -- Check_Library_Unit -- - ------------------------ - - procedure Check_Library_Unit is - begin - if not Is_Compilation_Unit (Entity (P)) then - Error_Attr_P ("prefix of % attribute must be library unit"); - end if; - end Check_Library_Unit; - -------------------------------- -- Check_Modular_Integer_Type -- -------------------------------- @@ -1506,6 +1540,16 @@ package body Sem_Attr is end if; end Check_Scalar_Type; + ------------------------------------------ + -- Check_SPARK_Restriction_On_Attribute -- + ------------------------------------------ + + procedure Check_SPARK_Restriction_On_Attribute is + begin + Error_Msg_Name_1 := Aname; + Check_SPARK_Restriction ("attribute % is not allowed", P); + end Check_SPARK_Restriction_On_Attribute; + --------------------------- -- Check_Standard_Prefix -- --------------------------- @@ -1609,12 +1653,48 @@ package body Sem_Attr is Check_Restriction (No_Streams, P); end if; + -- AI05-0057: if restriction No_Default_Stream_Attributes is active, + -- it is illegal to use a predefined elementary type stream attribute + -- either by itself, or more importantly as part of the attribute + -- subprogram for a composite type. + + if Restriction_Active (No_Default_Stream_Attributes) then + declare + T : Entity_Id; + + begin + if Nam = TSS_Stream_Input + or else + Nam = TSS_Stream_Read + then + T := + Type_Without_Stream_Operation (P_Type, TSS_Stream_Read); + else + T := + Type_Without_Stream_Operation (P_Type, TSS_Stream_Write); + end if; + + if Present (T) then + Check_Restriction (No_Default_Stream_Attributes, N); + + Error_Msg_NE + ("missing user-defined Stream Read or Write for type&", + N, T); + if not Is_Elementary_Type (P_Type) then + Error_Msg_NE + ("\which is a component of type&", N, P_Type); + end if; + end if; + end; + end if; + -- Check special case of Exception_Id and Exception_Occurrence which - -- are not allowed for restriction No_Exception_Regstriation. + -- are not allowed for restriction No_Exception_Registration. - if Is_RTE (P_Type, RE_Exception_Id) - or else - Is_RTE (P_Type, RE_Exception_Occurrence) + if Restriction_Check_Required (No_Exception_Registration) + and then (Is_RTE (P_Type, RE_Exception_Id) + or else + Is_RTE (P_Type, RE_Exception_Occurrence)) then Check_Restriction (No_Exception_Registration, P); end if; @@ -1726,7 +1806,7 @@ package body Sem_Attr is if Nkind (Nod) = N_Identifier then return; - elsif Nkind (Nod) = N_Selected_Component then + elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then Check_Unit_Name (Prefix (Nod)); if Nkind (Selector_Name (Nod)) = N_Identifier then @@ -1835,9 +1915,7 @@ package body Sem_Attr is end if; end Validate_Non_Static_Attribute_Function_Call; - ----------------------------------------------- - -- Start of Processing for Analyze_Attribute -- - ----------------------------------------------- + -- Start of processing for Analyze_Attribute begin -- Immediate return if unrecognized attribute (already diagnosed @@ -1862,9 +1940,9 @@ package body Sem_Attr is end if; end if; - -- Deal with Ada 2005 issues + -- Deal with Ada 2005 attributes that are - if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then + if Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005 then Check_Restriction (No_Implementation_Attributes, N); end if; @@ -1881,15 +1959,19 @@ package body Sem_Attr is -- Analyze prefix and exit if error in analysis. If the prefix is an -- incomplete type, use full view if available. Note that there are -- some attributes for which we do not analyze the prefix, since the - -- prefix is not a normal name. + -- prefix is not a normal name, or else needs special handling. if Aname /= Name_Elab_Body and then Aname /= Name_Elab_Spec and then + Aname /= Name_Elab_Subp_Body + and then Aname /= Name_UET_Address and then Aname /= Name_Enabled + and then + Aname /= Name_Old then Analyze (P); P_Type := Etype (P); @@ -2035,18 +2117,40 @@ package body Sem_Attr is end if; end if; + -- In SPARK, attributes of private types are only allowed if the full + -- type declaration is visible. + + if Is_Entity_Name (P) + and then Present (Entity (P)) -- needed in some cases + and then Is_Type (Entity (P)) + and then Is_Private_Type (P_Type) + and then not In_Open_Scopes (Scope (P_Type)) + and then not In_Spec_Expression + then + Check_SPARK_Restriction ("invisible attribute of type", N); + end if; + -- Remaining processing depends on attribute case Attr_Id is + -- Attributes related to Ada 2012 iterators. Attribute specifications + -- exist for these, but they cannot be queried. + + when Attribute_Constant_Indexing | + Attribute_Default_Iterator | + Attribute_Implicit_Dereference | + Attribute_Iterator_Element | + Attribute_Variable_Indexing => + Error_Msg_N ("illegal attribute", N); + ------------------ -- Abort_Signal -- ------------------ when Attribute_Abort_Signal => Check_Standard_Prefix; - Rewrite (N, - New_Reference_To (Stand.Abort_Signal, Loc)); + Rewrite (N, New_Reference_To (Stand.Abort_Signal, Loc)); Analyze (N); ------------ @@ -2132,11 +2236,21 @@ package body Sem_Attr is then Set_Address_Taken (Ent); - -- If we have an address of an object, and the attribute - -- comes from source, then set the object as potentially - -- source modified. We do this because the resulting address - -- can potentially be used to modify the variable and we - -- might not detect this, leading to some junk warnings. + -- Deal with No_Implicit_Aliasing restriction + + if Restriction_Check_Required (No_Implicit_Aliasing) then + if not Is_Aliased_View (P) then + Check_Restriction (No_Implicit_Aliasing, P); + else + Check_No_Implicit_Aliasing (P); + end if; + end if; + + -- If we have an address of an object, and the attribute + -- comes from source, then set the object as potentially + -- source modified. We do this because the resulting address + -- can potentially be used to modify the variable and we + -- might not detect this, leading to some junk warnings. Set_Never_Set_In_Source (Ent, False); @@ -2223,6 +2337,13 @@ package body Sem_Attr is when Attribute_Asm_Input => Check_Asm_Attribute; + + -- The back-end may need to take the address of E2 + + if Is_Entity_Name (E2) then + Set_Address_Taken (Entity (E2)); + end if; + Set_Etype (N, RTE (RE_Asm_Input_Operand)); ---------------- @@ -2243,6 +2364,13 @@ package body Sem_Attr is end if; Note_Possible_Modification (E2, Sure => True); + + -- The back-end may need to take the address of E2 + + if Is_Entity_Name (E2) then + Set_Address_Taken (Entity (E2)); + end if; + Set_Etype (N, RTE (RE_Asm_Output_Operand)); --------------- @@ -2398,6 +2526,12 @@ package body Sem_Attr is ("?redundant attribute, & is its own base type", N, Typ); end if; + if Nkind (Parent (N)) /= N_Attribute_Reference then + Error_Msg_Name_1 := Aname; + Check_SPARK_Restriction + ("attribute% is only allowed as prefix of another attribute", P); + end if; + Set_Etype (N, Base_Type (Entity (P))); Set_Entity (N, Base_Type (Entity (P))); Rewrite (N, New_Reference_To (Entity (N), Loc)); @@ -2891,6 +3025,21 @@ package body Sem_Attr is Check_Floating_Point_Type_0; Set_Etype (N, Standard_Boolean); + --------------------- + -- Descriptor_Size -- + --------------------- + + when Attribute_Descriptor_Size => + Check_E0; + + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + then + Error_Attr_P ("prefix of attribute % must denote a type"); + end if; + + Set_Etype (N, Universal_Integer); + ------------ -- Digits -- ------------ @@ -2912,9 +3061,12 @@ package body Sem_Attr is -- Elab_Body -- --------------- - -- Also handles processing for Elab_Spec + -- Also handles processing for Elab_Spec and Elab_Subp_Body + + when Attribute_Elab_Body | + Attribute_Elab_Spec | + Attribute_Elab_Subp_Body => - when Attribute_Elab_Body | Attribute_Elab_Spec => Check_E0; Check_Unit_Name (P); Set_Etype (N, Standard_Void_Type); @@ -2937,7 +3089,7 @@ package body Sem_Attr is when Attribute_Elaborated => Check_E0; - Check_Library_Unit; + Check_Unit_Name (P); Set_Etype (N, Standard_Boolean); ---------- @@ -3078,6 +3230,7 @@ package body Sem_Attr is when Attribute_First => Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; --------------- -- First_Bit -- @@ -3199,8 +3352,9 @@ package body Sem_Attr is when Attribute_Image => Image : begin - Set_Etype (N, Standard_String); + Check_SPARK_Restriction_On_Attribute; Check_Scalar_Type; + Set_Etype (N, Standard_String); if Is_Real_Type (P_Type) then if Ada_Version = Ada_83 and then Comes_From_Source (N) then @@ -3292,6 +3446,7 @@ package body Sem_Attr is when Attribute_Last => Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; -------------- -- Last_Bit -- @@ -3645,7 +3800,31 @@ package body Sem_Attr is --------- when Attribute_Old => + + -- The attribute reference is a primary. If expressions follow, the + -- attribute reference is an indexable object, so rewrite the node + -- accordingly. + + if Present (E1) then + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (N)), + Attribute_Name => Name_Old), + Expressions => Expressions (N))); + + Analyze (N); + return; + end if; + Check_E0; + + -- Prefix has not been analyzed yet, and its full analysis will take + -- place during expansion (see below). + + Preanalyze_And_Resolve (P); + P_Type := Etype (P); Set_Etype (N, P_Type); if No (Current_Subprogram) then @@ -3669,8 +3848,8 @@ package body Sem_Attr is Subp : Entity_Id := Current_Subprogram; function Process (N : Node_Id) return Traverse_Result; - -- Check that N does not contain references to local variables - -- or other local entities of Subp. + -- Check that N does not contain references to local variables or + -- other local entities of Subp. ------------- -- Process -- @@ -3706,10 +3885,10 @@ package body Sem_Attr is if Present (Enclosing_Subprogram (Current_Subprogram)) then -- Check that there is no reference to the enclosing - -- subprogram local variables. Otherwise, we might end - -- up being called from the enclosing subprogram and thus - -- using 'Old on a local variable which is not defined - -- at entry time. + -- subprogram local variables. Otherwise, we might end up + -- being called from the enclosing subprogram and thus using + -- 'Old on a local variable which is not defined at entry + -- time. Subp := Enclosing_Subprogram (Current_Subprogram); Check_No_Local (P); @@ -3726,6 +3905,45 @@ package body Sem_Attr is end if; end Check_Local; + -- The attribute appears within a pre/postcondition, but refers to + -- an entity in the enclosing subprogram. If it is a component of a + -- formal its expansion might generate actual subtypes that may be + -- referenced in an inner context, and which must be elaborated + -- within the subprogram itself. As a result we create a declaration + -- for it and insert it at the start of the enclosing subprogram + -- This is properly an expansion activity but it has to be performed + -- now to prevent out-of-order issues. + + if Nkind (P) = N_Selected_Component + and then Has_Discriminants (Etype (Prefix (P))) + then + P_Type := Base_Type (P_Type); + Set_Etype (N, P_Type); + Set_Etype (P, P_Type); + Expand (N); + end if; + + ---------------------- + -- Overlaps_Storage -- + ---------------------- + + when Attribute_Overlaps_Storage => + if Ada_Version < Ada_2012 then + Error_Msg_N + ("attribute Overlaps_Storage is an Ada 2012 feature", N); + Error_Msg_N + ("\unit must be compiled with -gnat2012 switch", N); + end if; + Check_E1; + + -- Both arguments must be objects of any type + + Analyze_And_Resolve (P); + Analyze_And_Resolve (E1); + Check_Object_Reference (P); + Check_Object_Reference (E1); + Set_Etype (N, Standard_Boolean); + ------------ -- Output -- ------------ @@ -3755,8 +3973,7 @@ package body Sem_Attr is elsif Is_Entity_Name (P) and then Is_Pure (Entity (P)) then - Error_Attr_P - ("prefix of % attribute must not be declared pure"); + Error_Attr_P ("prefix of% attribute must not be declared pure"); end if; end if; @@ -3787,6 +4004,14 @@ package body Sem_Attr is when Attribute_Pos => Check_Discrete_Type; Check_E1; + + if Is_Boolean_Type (P_Type) then + Error_Msg_Name_1 := Aname; + Error_Msg_Name_2 := Chars (P_Type); + Check_SPARK_Restriction + ("attribute% is not allowed for type%", P); + end if; + Resolve (E1, P_Base_Type); Set_Etype (N, Universal_Integer); @@ -3805,6 +4030,14 @@ package body Sem_Attr is when Attribute_Pred => Check_Scalar_Type; Check_E1; + + if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then + Error_Msg_Name_1 := Aname; + Error_Msg_Name_2 := Chars (P_Type); + Check_SPARK_Restriction + ("attribute% is not allowed for type%", P); + end if; + Resolve (E1, P_Base_Type); Set_Etype (N, P_Base_Type); @@ -3879,6 +4112,7 @@ package body Sem_Attr is when Attribute_Range => Check_Array_Or_Scalar_Type; + Bad_Attribute_For_Predicate; if Ada_Version = Ada_83 and then Is_Scalar_Type (P_Type) @@ -3893,14 +4127,32 @@ package body Sem_Attr is ------------ when Attribute_Result => Result : declare - CS : Entity_Id := Current_Scope; - PS : Entity_Id := Scope (CS); + CS : Entity_Id; + -- The enclosing scope, excluding loops for quantified expressions + + PS : Entity_Id; + -- During analysis, CS is the postcondition subprogram and PS the + -- source subprogram to which the postcondition applies. During + -- pre-analysis, CS is the scope of the subprogram declaration. + + Prag : Node_Id; + -- During pre-analysis, Prag is the enclosing pragma node if any begin + -- Find enclosing scopes, excluding loops + + CS := Current_Scope; + while Ekind (CS) = E_Loop loop + CS := Scope (CS); + end loop; + + PS := Scope (CS); + -- If the enclosing subprogram is always inlined, the enclosing -- postcondition will not be propagated to the expanded call. - if Has_Pragma_Inline_Always (PS) + if not In_Spec_Expression + and then Has_Pragma_Inline_Always (PS) and then Warn_On_Redundant_Constructs then Error_Msg_N @@ -3918,11 +4170,67 @@ package body Sem_Attr is -- Check OK prefix if Chars (CS) /= Chars (P) then + Error_Msg_Name_1 := Name_Result; + Error_Msg_NE ("incorrect prefix for % attribute, expected &", P, CS); Error_Attr; end if; + -- Check in postcondition of function + + Prag := N; + while not Nkind_In (Prag, N_Pragma, + N_Function_Specification, + N_Subprogram_Body) + loop + Prag := Parent (Prag); + end loop; + + if Nkind (Prag) /= N_Pragma then + Error_Attr + ("% attribute can only appear in postcondition of function", + P); + + elsif Get_Pragma_Id (Prag) = Pragma_Test_Case then + declare + Arg_Ens : constant Node_Id := + Get_Ensures_From_Test_Case_Pragma (Prag); + Arg : Node_Id; + + begin + Arg := N; + while Arg /= Prag and Arg /= Arg_Ens loop + Arg := Parent (Arg); + end loop; + + if Arg /= Arg_Ens then + Error_Attr ("% attribute misplaced inside Test_Case", P); + end if; + end; + + elsif Get_Pragma_Id (Prag) /= Pragma_Postcondition then + Error_Attr + ("% attribute can only appear in postcondition of function", + P); + end if; + + -- The attribute reference is a primary. If expressions follow, + -- the attribute reference is really an indexable object, so + -- rewrite and analyze as an indexed component. + + if Present (E1) then + Rewrite (N, + Make_Indexed_Component (Loc, + Prefix => + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Prefix (N)), + Attribute_Name => Name_Result), + Expressions => Expressions (N))); + Analyze (N); + return; + end if; + Set_Etype (N, Etype (CS)); -- If several functions with that name are visible, @@ -3940,9 +4248,7 @@ package body Sem_Attr is -- current one. else - while Present (CS) - and then CS /= Standard_Standard - loop + while Present (CS) and then CS /= Standard_Standard loop if Chars (CS) = Name_uPostconditions then exit; else @@ -3978,15 +4284,13 @@ package body Sem_Attr is Error_Attr; end if; - Rewrite (N, - Make_Identifier (Sloc (N), - Chars => Name_uResult)); + Rewrite (N, Make_Identifier (Sloc (N), Name_uResult)); Analyze_And_Resolve (N, Etype (PS)); else Error_Attr - ("% attribute can only appear" & - " in function Postcondition pragma", P); + ("% attribute can only appear in postcondition of function", + P); end if; end if; end Result; @@ -4116,6 +4420,28 @@ package body Sem_Attr is Check_Real_Type; Set_Etype (N, Universal_Real); + ------------------ + -- Same_Storage -- + ------------------ + + when Attribute_Same_Storage => + if Ada_Version < Ada_2012 then + Error_Msg_N + ("attribute Same_Storage is an Ada 2012 feature", N); + Error_Msg_N + ("\unit must be compiled with -gnat2012 switch", N); + end if; + + Check_E1; + + -- The arguments must be objects of any type + + Analyze_And_Resolve (P); + Analyze_And_Resolve (E1); + Check_Object_Reference (P); + Check_Object_Reference (E1); + Set_Etype (N, Standard_Boolean); + ----------- -- Scale -- ----------- @@ -4202,7 +4528,8 @@ package body Sem_Attr is -- Storage_Pool -- ------------------ - when Attribute_Storage_Pool => Storage_Pool : + when Attribute_Storage_Pool | + Attribute_Simple_Storage_Pool => Storage_Pool : begin Check_E0; @@ -4220,7 +4547,38 @@ package body Sem_Attr is Set_Entity (N, RTE (RE_Global_Pool_Object)); end if; - Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + if Attr_Id = Attribute_Storage_Pool then + if Present (Get_Rep_Pragma (Etype (Entity (N)), + Name_Simple_Storage_Pool_Type)) + then + Error_Msg_Name_1 := Aname; + Error_Msg_N ("cannot use % attribute for type with simple " & + "storage pool?", N); + Error_Msg_N + ("\Program_Error will be raised at run time?", N); + + Rewrite + (N, Make_Raise_Program_Error + (Sloc (N), Reason => PE_Explicit_Raise)); + end if; + + Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + + -- In the Simple_Storage_Pool case, verify that the pool entity is + -- actually of a simple storage pool type, and set the attribute's + -- type to the pool object's type. + + else + if not Present (Get_Rep_Pragma (Etype (Entity (N)), + Name_Simple_Storage_Pool_Type)) + then + Error_Attr_P + ("cannot use % attribute for type without simple " & + "storage pool"); + end if; + + Set_Etype (N, Etype (Entity (N))); + end if; -- Validate_Remote_Access_To_Class_Wide_Type for attribute -- Storage_Pool since this attribute is not defined for such @@ -4310,9 +4668,29 @@ package body Sem_Attr is Check_Type; Check_E0; - if Is_Remote_Access_To_Class_Wide_Type (P_Type) then - Rewrite (N, - New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc)); + if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then + + -- For a real RACW [sub]type, use corresponding stub type + + if not Is_Generic_Type (P_Type) then + Rewrite (N, + New_Occurrence_Of + (Corresponding_Stub_Type (Base_Type (P_Type)), Loc)); + + -- For a generic type (that has been marked as an RACW using the + -- Remote_Access_Type aspect or pragma), use a generic RACW stub + -- type. Note that if the actual is not a remote access type, the + -- instantiation will fail. + + else + -- Note: we go to the underlying type here because the view + -- returned by RTE (RE_RACW_Stub_Type) might be incomplete. + + Rewrite (N, + New_Occurrence_Of + (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc)); + end if; + else Error_Attr_P ("prefix of% attribute must be remote access to classwide"); @@ -4325,6 +4703,14 @@ package body Sem_Attr is when Attribute_Succ => Check_Scalar_Type; Check_E1; + + if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then + Error_Msg_Name_1 := Aname; + Error_Msg_Name_2 := Chars (P_Type); + Check_SPARK_Restriction + ("attribute% is not allowed for type%", P); + end if; + Resolve (E1, P_Base_Type); Set_Etype (N, P_Base_Type); @@ -4343,6 +4729,13 @@ package body Sem_Attr is end if; end if; + -------------------------------- + -- System_Allocator_Alignment -- + -------------------------------- + + when Attribute_System_Allocator_Alignment => + Standard_Attribute (Ttypes.System_Allocator_Alignment); + --------- -- Tag -- --------- @@ -4624,8 +5017,18 @@ package body Sem_Attr is -- all scope checks and checks for aliased views are omitted. when Attribute_Unrestricted_Access => + + -- If from source, deal with relevant restrictions + if Comes_From_Source (N) then Check_Restriction (No_Unchecked_Access, N); + + if Nkind (P) in N_Has_Entity + and then Present (Entity (P)) + and then Is_Object (Entity (P)) + then + Check_Restriction (No_Implicit_Aliasing, N); + end if; end if; if Is_Entity_Name (P) then @@ -4642,6 +5045,14 @@ package body Sem_Attr is begin Check_E1; Check_Discrete_Type; + + if Is_Boolean_Type (P_Type) then + Error_Msg_Name_1 := Aname; + Error_Msg_Name_2 := Chars (P_Type); + Check_SPARK_Restriction + ("attribute% is not allowed for type%", P); + end if; + Resolve (E1, Any_Integer); Set_Etype (N, P_Base_Type); @@ -4677,12 +5088,21 @@ package body Sem_Attr is when Attribute_Value => Value : begin + Check_SPARK_Restriction_On_Attribute; Check_E1; Check_Scalar_Type; -- Case of enumeration type - if Is_Enumeration_Type (P_Type) then + -- When an enumeration type appears in an attribute reference, all + -- literals of the type are marked as referenced. This must only be + -- done if the attribute reference appears in the current source. + -- Otherwise the information on references may differ between a + -- normal compilation and one that performs inlining. + + if Is_Enumeration_Type (P_Type) + and then In_Extended_Main_Code_Unit (N) + then Check_Restriction (No_Enumeration_Maps, N); -- Mark all enumeration literals as referenced, since the use of @@ -4739,6 +5159,7 @@ package body Sem_Attr is when Attribute_Wide_Image => Wide_Image : begin + Check_SPARK_Restriction_On_Attribute; Check_Scalar_Type; Set_Etype (N, Standard_Wide_String); Check_E1; @@ -4765,6 +5186,7 @@ package body Sem_Attr is when Attribute_Wide_Value => Wide_Value : begin + Check_SPARK_Restriction_On_Attribute; Check_E1; Check_Scalar_Type; @@ -4805,6 +5227,7 @@ package body Sem_Attr is ---------------- when Attribute_Wide_Width => + Check_SPARK_Restriction_On_Attribute; Check_E0; Check_Scalar_Type; Set_Etype (N, Universal_Integer); @@ -4814,6 +5237,7 @@ package body Sem_Attr is ----------- when Attribute_Width => + Check_SPARK_Restriction_On_Attribute; Check_E0; Check_Scalar_Type; Set_Etype (N, Universal_Integer); @@ -4925,6 +5349,9 @@ package body Sem_Attr is -- Computes the Fore value for the current attribute prefix, which is -- known to be a static fixed-point type. Used by Fore and Width. + function Is_VAX_Float (Typ : Entity_Id) return Boolean; + -- Determine whether Typ denotes a VAX floating point type + function Mantissa return Uint; -- Returns the Mantissa value for the prefix type @@ -5055,6 +5482,19 @@ package body Sem_Attr is return R; end Fore_Value; + ------------------ + -- Is_VAX_Float -- + ------------------ + + function Is_VAX_Float (Typ : Entity_Id) return Boolean is + begin + return + Is_Floating_Point_Type (Typ) + and then + (Float_Format = 'V' + or else Float_Rep (Typ) = VAX_Native); + end Is_VAX_Float; + -------------- -- Mantissa -- -------------- @@ -5231,40 +5671,6 @@ package body Sem_Attr is -- Start of processing for Eval_Attribute begin - -- No folding in spec expression that comes from source where the prefix - -- is an unfrozen entity. This avoids premature folding in cases like: - - -- procedure DefExprAnal is - -- type R is new Integer; - -- procedure P (Arg : Integer := R'Size); - -- for R'Size use 64; - -- procedure P (Arg : Integer := R'Size) is - -- begin - -- Put_Line (Arg'Img); - -- end P; - -- begin - -- P; - -- end; - - -- which should print 64 rather than 32. The exclusion of non-source - -- constructs from this test comes from some internal usage in packed - -- arrays, which otherwise fails, could use more analysis perhaps??? - - -- We do however go ahead with generic actual types, otherwise we get - -- some regressions, probably these types should be frozen anyway??? - - if In_Spec_Expression - and then Comes_From_Source (N) - and then not (Is_Entity_Name (P) - and then - (Is_Frozen (Entity (P)) - or else (Is_Type (Entity (P)) - and then - Is_Generic_Actual_Type (Entity (P))))) - then - return; - end if; - -- Acquire first two expressions (at the moment, no attributes take more -- than two expressions in any case). @@ -5741,16 +6147,24 @@ package body Sem_Attr is -- test Static as required in cases where it makes a difference. -- In the case where Static is not set, we do know that all the - -- expressions present are at least known at compile time (we - -- assumed above that if this was not the case, then there was - -- no hope of static evaluation). However, we did not require - -- that the bounds of the prefix type be compile time known, - -- let alone static). That's because there are many attributes - -- that can be computed at compile time on non-static subtypes, - -- even though such references are not static expressions. + -- expressions present are at least known at compile time (we assumed + -- above that if this was not the case, then there was no hope of static + -- evaluation). However, we did not require that the bounds of the + -- prefix type be compile time known, let alone static). That's because + -- there are many attributes that can be computed at compile time on + -- non-static subtypes, even though such references are not static + -- expressions. case Id is + -- Attributes related to Ada 2012 iterators (placeholder ???) + + when Attribute_Constant_Indexing => null; + when Attribute_Default_Iterator => null; + when Attribute_Implicit_Dereference => null; + when Attribute_Iterator_Element => null; + when Attribute_Variable_Indexing => null; + -------------- -- Adjacent -- -------------- @@ -5860,13 +6274,6 @@ package body Sem_Attr is Eval_Fat.Copy_Sign (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static); - ----------- - -- Delta -- - ----------- - - when Attribute_Delta => - Fold_Ureal (N, Delta_Value (P_Type), True); - -------------- -- Definite -- -------------- @@ -5876,6 +6283,13 @@ package body Sem_Attr is Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc)); Analyze_And_Resolve (N, Standard_Boolean); + ----------- + -- Delta -- + ----------- + + when Attribute_Delta => + Fold_Ureal (N, Delta_Value (P_Type), True); + ------------ -- Denorm -- ------------ @@ -5884,6 +6298,13 @@ package body Sem_Attr is Fold_Uint (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True); + --------------------- + -- Descriptor_Size -- + --------------------- + + when Attribute_Descriptor_Size => + null; + ------------ -- Digits -- ------------ @@ -5994,6 +6415,16 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (Lo_Bound), Static); end if; + -- Replace VAX Float_Type'First with a reference to the temporary + -- which represents the low bound of the type. This transformation + -- is needed since the back end cannot evaluate 'First on VAX. + + elsif Is_VAX_Float (P_Type) + and then Nkind (Lo_Bound) = N_Identifier + then + Rewrite (N, New_Reference_To (Entity (Lo_Bound), Sloc (N))); + Analyze (N); + else Check_Concurrent_Discriminant (Lo_Bound); end if; @@ -6185,6 +6616,16 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (Hi_Bound), Static); end if; + -- Replace VAX Float_Type'Last with a reference to the temporary + -- which represents the high bound of the type. This transformation + -- is needed since the back end cannot evaluate 'Last on VAX. + + elsif Is_VAX_Float (P_Type) + and then Nkind (Hi_Bound) = N_Identifier + then + Rewrite (N, New_Reference_To (Entity (Hi_Bound), Sloc (N))); + Analyze (N); + else Check_Concurrent_Discriminant (Hi_Bound); end if; @@ -6637,6 +7078,13 @@ package body Sem_Attr is end if; end Object_Size; + ---------------------- + -- Overlaps_Storage -- + ---------------------- + + when Attribute_Overlaps_Storage => + null; + ------------------------- -- Passed_By_Reference -- ------------------------- @@ -6866,6 +7314,13 @@ package body Sem_Attr is Fold_Ureal (N, Model_Small_Value (P_Type), Static); end if; + ------------------ + -- Same_Storage -- + ------------------ + + when Attribute_Same_Storage => + null; + ----------- -- Scale -- ----------- @@ -7385,14 +7840,30 @@ package body Sem_Attr is T := T / 10; end loop; + -- User declared enum type with discard names + + elsif Discard_Names (R) then + + -- If range is null, result is zero, that has already + -- been dealt with, so what we need is the power of ten + -- that accomodates the Pos of the largest value, which + -- is the high bound of the range + one for the space. + + W := 1; + T := Hi; + while T /= 0 loop + T := T / 10; + W := W + 1; + end loop; + -- Only remaining possibility is user declared enum type + -- with normal case of Discard_Names not active. 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 @@ -7457,60 +7928,63 @@ package body Sem_Attr is -- 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_Asm_Input | - Attribute_Asm_Output | - Attribute_Base | - Attribute_Bit_Order | - Attribute_Bit_Position | - Attribute_Callable | - Attribute_Caller | - Attribute_Class | - Attribute_Code_Address | - Attribute_Compiler_Version | - Attribute_Count | - Attribute_Default_Bit_Order | - Attribute_Elaborated | - Attribute_Elab_Body | - Attribute_Elab_Spec | - Attribute_Enabled | - Attribute_External_Tag | - Attribute_Fast_Math | - Attribute_First_Bit | - Attribute_Input | - Attribute_Last_Bit | - Attribute_Maximum_Alignment | - Attribute_Old | - Attribute_Output | - Attribute_Partition_ID | - Attribute_Pool_Address | - Attribute_Position | - Attribute_Priority | - Attribute_Read | - Attribute_Result | - Attribute_Storage_Pool | - Attribute_Storage_Size | - Attribute_Storage_Unit | - Attribute_Stub_Type | - Attribute_Tag | - Attribute_Target_Name | - Attribute_Terminated | - Attribute_To_Address | - Attribute_Type_Key | - Attribute_UET_Address | - Attribute_Unchecked_Access | - Attribute_Universal_Literal_String | - Attribute_Unrestricted_Access | - Attribute_Valid | - Attribute_Value | - Attribute_Wchar_T_Size | - Attribute_Wide_Value | - Attribute_Wide_Wide_Value | - Attribute_Word_Size | - Attribute_Write => + when Attribute_Abort_Signal | + Attribute_Access | + Attribute_Address | + Attribute_Address_Size | + Attribute_Asm_Input | + Attribute_Asm_Output | + Attribute_Base | + Attribute_Bit_Order | + Attribute_Bit_Position | + Attribute_Callable | + Attribute_Caller | + Attribute_Class | + Attribute_Code_Address | + Attribute_Compiler_Version | + Attribute_Count | + Attribute_Default_Bit_Order | + Attribute_Elaborated | + Attribute_Elab_Body | + Attribute_Elab_Spec | + Attribute_Elab_Subp_Body | + Attribute_Enabled | + Attribute_External_Tag | + Attribute_Fast_Math | + Attribute_First_Bit | + Attribute_Input | + Attribute_Last_Bit | + Attribute_Maximum_Alignment | + Attribute_Old | + Attribute_Output | + Attribute_Partition_ID | + Attribute_Pool_Address | + Attribute_Position | + Attribute_Priority | + Attribute_Read | + Attribute_Result | + Attribute_Simple_Storage_Pool | + Attribute_Storage_Pool | + Attribute_Storage_Size | + Attribute_Storage_Unit | + Attribute_Stub_Type | + Attribute_System_Allocator_Alignment | + Attribute_Tag | + Attribute_Target_Name | + Attribute_Terminated | + Attribute_To_Address | + Attribute_Type_Key | + Attribute_UET_Address | + Attribute_Unchecked_Access | + Attribute_Universal_Literal_String | + Attribute_Unrestricted_Access | + Attribute_Valid | + Attribute_Value | + Attribute_Wchar_T_Size | + Attribute_Wide_Value | + Attribute_Wide_Wide_Value | + Attribute_Word_Size | + Attribute_Write => raise Program_Error; end case; @@ -7772,14 +8246,16 @@ package body Sem_Attr is if Ekind_In (Btyp, E_Access_Subprogram_Type, E_Anonymous_Access_Subprogram_Type, + E_Access_Protected_Subprogram_Type, E_Anonymous_Access_Protected_Subprogram_Type) then -- Deal with convention mismatch - if Convention (Btyp) /= Convention (Entity (P)) then + if Convention (Designated_Type (Btyp)) /= + Convention (Entity (P)) + then Error_Msg_FE ("subprogram & has wrong convention", P, Entity (P)); - Error_Msg_FE ("\does not match convention of access type &", P, Btyp); @@ -8060,8 +8536,16 @@ package body Sem_Attr is -- the level is the same of the enclosing composite type. if Ada_Version >= Ada_2005 - and then Is_Local_Anonymous_Access (Btyp) - and then Object_Access_Level (P) > Type_Access_Level (Btyp) + and then (Is_Local_Anonymous_Access (Btyp) + + -- Handle cases where Btyp is the + -- anonymous access type of an Ada 2012 + -- stand-alone object. + + or else Nkind (Associated_Node_For_Itype (Btyp)) = + N_Object_Declaration) + and then Object_Access_Level (P) + > Deepest_Type_Access_Level (Btyp) and then Attr_Id = Attribute_Access then -- In an instance, this is a runtime check, but one we @@ -8168,8 +8652,9 @@ package body Sem_Attr is and then (Ada_Version < Ada_2005 or else - not Has_Constrained_Partial_View - (Designated_Type (Base_Type (Typ)))) + not Effectively_Has_Constrained_Partial_View + (Typ => Designated_Type (Base_Type (Typ)), + Scop => Current_Scope)) then null; @@ -8183,7 +8668,6 @@ package body Sem_Attr is then declare D : constant Node_Id := Declaration_Node (Entity (P)); - begin Error_Msg_N ("aliased object has explicit bounds?", D); @@ -8194,13 +8678,14 @@ package body Sem_Attr is end if; 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. + -- 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 Attr_Id /= Attribute_Unchecked_Access - and then Object_Access_Level (P) > Type_Access_Level (Btyp) + and then + Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) and then Ekind (Btyp) = E_General_Access_Type then Accessibility_Message; @@ -8222,7 +8707,7 @@ package body Sem_Attr is -- anonymous_access_to_protected, there are no accessibility -- checks either. Omit check entirely for Unrestricted_Access. - elsif Object_Access_Level (P) > Type_Access_Level (Btyp) + elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) and then Comes_From_Source (N) and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type and then Attr_Id /= Attribute_Unrestricted_Access @@ -8523,6 +9008,7 @@ package body Sem_Attr is declare LB : Node_Id; HB : Node_Id; + Dims : List_Id; begin if not Is_Entity_Name (P) @@ -8531,18 +9017,30 @@ package body Sem_Attr is Resolve (P); end if; + Dims := Expressions (N); + HB := Make_Attribute_Reference (Loc, Prefix => Duplicate_Subexpr (P, Name_Req => True), Attribute_Name => Name_Last, - Expressions => Expressions (N)); + Expressions => Dims); LB := Make_Attribute_Reference (Loc, - Prefix => P, - Attribute_Name => Name_First, - Expressions => Expressions (N)); + Prefix => P, + Attribute_Name => Name_First, + Expressions => (Dims)); + + -- Do not share the dimension indicator, if present. Even + -- though it is a static constant, its source location + -- may be modified when printing expanded code and node + -- sharing will lead to chaos in Sprint. + + if Present (Dims) then + Set_Expressions (LB, + New_List (New_Copy_Tree (First (Dims)))); + end if; -- If the original was marked as Must_Not_Freeze (see code -- in Sem_Ch3.Make_Index), then make sure the rewriting @@ -8721,6 +9219,7 @@ package body Sem_Attr is -- Finally perform static evaluation on the attribute reference + Analyze_Dimension (N); Eval_Attribute (N); end Resolve_Attribute;