From b741083a31b79945bb754418ed14883a1c7b50d2 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 12 May 2015 08:25:39 +0000 Subject: [PATCH] sem_ch3.adb (Analyze_Object_Declaration): New function Has_Delayed_Aspect... 2015-05-12 Ed Schonberg * sem_ch3.adb (Analyze_Object_Declaration): New function Has_Delayed_Aspect, used to defer resolution of an aggregate expression when the object declaration carries aspects Address and/or Alignment. * freeze.adb (Freeze_Object_Declaration): New subsidiary procedure to Freeze_Entity. In addition to the previous processing steps at the freeze point of an object, this procedure also handles aggregates in object declarations, when the declaration carries delayed aspects that require that the initialization of the object be attached to its freeze actions. 2015-05-12 Ed Schonberg * sem_ch6.adb (Analyze_Subprogram_Declaration): Following AI12-0147, null procedures and expression functions are allowed in protected bodies. From-SVN: r223041 --- gcc/ada/ChangeLog | 19 +++ gcc/ada/freeze.adb | 380 ++++++++++++++++++++++++-------------------- gcc/ada/sem_ch3.adb | 41 ++++- gcc/ada/sem_ch6.adb | 7 +- 4 files changed, 275 insertions(+), 172 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 29ee945b67a..661b4b005b6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2015-05-12 Ed Schonberg + + * sem_ch3.adb (Analyze_Object_Declaration): New function + Has_Delayed_Aspect, used to defer resolution of an aggregate + expression when the object declaration carries aspects Address + and/or Alignment. + * freeze.adb (Freeze_Object_Declaration): New subsidiary procedure + to Freeze_Entity. In addition to the previous processing steps + at the freeze point of an object, this procedure also handles + aggregates in object declarations, when the declaration carries + delayed aspects that require that the initialization of the + object be attached to its freeze actions. + +2015-05-12 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Declaration): Following + AI12-0147, null procedures and expression functions are allowed + in protected bodies. + 2015-05-12 Tristan Gingold * i-cpoint.adb (Copy_Terminated_Array): Copy nothing if Length is 0. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8c1681526cf..0b9d2b73e56 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1894,6 +1894,10 @@ package body Freeze is procedure Freeze_Array_Type (Arr : Entity_Id); -- Freeze array type, including freezing index and component types + procedure Freeze_Object_Declaration (E : Entity_Id); + -- Perfom checks and generate freeze node if needed for a constant + -- or variable declared by an object declaration. + function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id; -- Create Freeze_Generic_Entity nodes for types declared in a generic -- package. Recurse on inner generic packages. @@ -2782,6 +2786,211 @@ package body Freeze is end if; end Freeze_Array_Type; + ------------------------------- + -- Freeze_Object_Declaration -- + ------------------------------- + + procedure Freeze_Object_Declaration (E : Entity_Id) is + begin + -- Abstract type allowed only for C++ imported variables or + -- constants. + + -- Note: we inhibit this check for objects that do not come + -- from source because there is at least one case (the + -- expansion of x'Class'Input where x is abstract) where we + -- legitimately generate an abstract object. + + if Is_Abstract_Type (Etype (E)) + and then Comes_From_Source (Parent (E)) + and then not (Is_Imported (E) and then Is_CPP_Class (Etype (E))) + then + Error_Msg_N ("type of object cannot be abstract", + Object_Definition (Parent (E))); + + if Is_CPP_Class (Etype (E)) then + Error_Msg_NE ("\} may need a cpp_constructor", + Object_Definition (Parent (E)), Etype (E)); + + elsif Present (Expression (Parent (E))) then + Error_Msg_N -- CODEFIX + ("\maybe a class-wide type was meant", + Object_Definition (Parent (E))); + end if; + end if; + + -- For object created by object declaration, perform required + -- categorization (preelaborate and pure) checks. Defer these + -- checks to freeze time since pragma Import inhibits default + -- initialization and thus pragma Import affects these checks. + + Validate_Object_Declaration (Declaration_Node (E)); + + -- If there is an address clause, check that it is valid + -- and if need be move initialization to the freeze node. + + Check_Address_Clause (E); + + -- Similar processing is needed for aspects that may affect + -- object layout, like Alignment, if there is an initialization + -- expression. + + if Has_Delayed_Aspects (E) + and then Expander_Active + and then Is_Array_Type (Etype (E)) + and then Present (Expression (Parent (E))) + then + declare + Decl : constant Node_Id := Parent (E); + Lhs : constant Node_Id := New_Occurrence_Of (E, Loc); + begin + + -- Capture initialization value at point of declaration, + -- and make explicit assignment legal, because object may + -- be a constant. + + Remove_Side_Effects (Expression (Decl)); + Set_Assignment_OK (Lhs); + + -- Move initialization to freeze actions. + + Append_Freeze_Action (E, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Expression (Decl))); + + Set_No_Initialization (Decl); + -- Set_Is_Frozen (E, False); + end; + end if; + + -- Reset Is_True_Constant for non-constant aliased object. We + -- consider that the fact that a non-constant object is aliased + -- may indicate that some funny business is going on, e.g. an + -- aliased object is passed by reference to a procedure which + -- captures the address of the object, which is later used to + -- assign a new value, even though the compiler thinks that it + -- is not modified. Such code is highly dubious, but we choose + -- to make it "work" for non-constant aliased objects. + -- Note that we used to do this for all aliased objects, whether + -- or not constant, but this caused anomalies down the line + -- because we ended up with static objects that were not + -- Is_True_Constant. Not resetting Is_True_Constant for (aliased) + -- constant objects ensures that this anomaly never occurs. + + -- However, we don't do that for internal entities. We figure + -- that if we deliberately set Is_True_Constant for an internal + -- entity, e.g. a dispatch table entry, then we mean it. + + if Ekind (E) /= E_Constant + and then (Is_Aliased (E) or else Is_Aliased (Etype (E))) + and then not Is_Internal_Name (Chars (E)) + then + Set_Is_True_Constant (E, False); + end if; + + -- If the object needs any kind of default initialization, an + -- error must be issued if No_Default_Initialization applies. + -- The check doesn't apply to imported objects, which are not + -- ever default initialized, and is why the check is deferred + -- until freezing, at which point we know if Import applies. + -- Deferred constants are also exempted from this test because + -- their completion is explicit, or through an import pragma. + + if Ekind (E) = E_Constant + and then Present (Full_View (E)) + then + null; + + elsif Comes_From_Source (E) + and then not Is_Imported (E) + and then not Has_Init_Expression (Declaration_Node (E)) + and then + ((Has_Non_Null_Base_Init_Proc (Etype (E)) + and then not No_Initialization (Declaration_Node (E)) + and then not Is_Value_Type (Etype (E)) + and then not Initialization_Suppressed (Etype (E))) + or else + (Needs_Simple_Initialization (Etype (E)) + and then not Is_Internal (E))) + then + Has_Default_Initialization := True; + Check_Restriction + (No_Default_Initialization, Declaration_Node (E)); + end if; + + -- Check that a Thread_Local_Storage variable does not have + -- default initialization, and any explicit initialization must + -- either be the null constant or a static constant. + + if Has_Pragma_Thread_Local_Storage (E) then + declare + Decl : constant Node_Id := Declaration_Node (E); + begin + if Has_Default_Initialization + or else + (Has_Init_Expression (Decl) + and then + (No (Expression (Decl)) + or else not + (Is_OK_Static_Expression (Expression (Decl)) + or else Nkind (Expression (Decl)) = N_Null))) + then + Error_Msg_NE + ("Thread_Local_Storage variable& is " + & "improperly initialized", Decl, E); + Error_Msg_NE + ("\only allowed initialization is explicit " + & "NULL or static expression", Decl, E); + end if; + end; + end if; + + -- For imported objects, set Is_Public unless there is also an + -- address clause, which means that there is no external symbol + -- needed for the Import (Is_Public may still be set for other + -- unrelated reasons). Note that we delayed this processing + -- till freeze time so that we can be sure not to set the flag + -- if there is an address clause. If there is such a clause, + -- then the only purpose of the Import pragma is to suppress + -- implicit initialization. + + if Is_Imported (E) and then No (Address_Clause (E)) then + Set_Is_Public (E); + end if; + + -- For source objects that are not Imported and are library + -- level, if no linker section pragma was given inherit the + -- appropriate linker section from the corresponding type. + + if Comes_From_Source (E) + and then not Is_Imported (E) + and then Is_Library_Level_Entity (E) + and then No (Linker_Section_Pragma (E)) + then + Set_Linker_Section_Pragma + (E, Linker_Section_Pragma (Etype (E))); + end if; + + -- For convention C objects of an enumeration type, warn if the + -- size is not integer size and no explicit size given. Skip + -- warning for Boolean, and Character, assume programmer expects + -- 8-bit sizes for these cases. + + if (Convention (E) = Convention_C + or else Convention (E) = Convention_CPP) + and then Is_Enumeration_Type (Etype (E)) + and then not Is_Character_Type (Etype (E)) + and then not Is_Boolean_Type (Etype (E)) + and then Esize (Etype (E)) < Standard_Integer_Size + and then not Has_Size_Clause (E) + then + Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size); + Error_Msg_N + ("??convention C enumeration object has size less than ^", E); + Error_Msg_N ("\??use explicit size clause to set size", E); + end if; + end Freeze_Object_Declaration; + ----------------------------- -- Freeze_Generic_Entities -- ----------------------------- @@ -4690,176 +4899,7 @@ package body Freeze is -- Special processing for objects created by object declaration if Nkind (Declaration_Node (E)) = N_Object_Declaration then - - -- Abstract type allowed only for C++ imported variables or - -- constants. - - -- Note: we inhibit this check for objects that do not come - -- from source because there is at least one case (the - -- expansion of x'Class'Input where x is abstract) where we - -- legitimately generate an abstract object. - - if Is_Abstract_Type (Etype (E)) - and then Comes_From_Source (Parent (E)) - and then not (Is_Imported (E) - and then Is_CPP_Class (Etype (E))) - then - Error_Msg_N ("type of object cannot be abstract", - Object_Definition (Parent (E))); - - if Is_CPP_Class (Etype (E)) then - Error_Msg_NE - ("\} may need a cpp_constructor", - Object_Definition (Parent (E)), Etype (E)); - - elsif Present (Expression (Parent (E))) then - Error_Msg_N -- CODEFIX - ("\maybe a class-wide type was meant", - Object_Definition (Parent (E))); - end if; - end if; - - -- For object created by object declaration, perform required - -- categorization (preelaborate and pure) checks. Defer these - -- checks to freeze time since pragma Import inhibits default - -- initialization and thus pragma Import affects these checks. - - Validate_Object_Declaration (Declaration_Node (E)); - - -- If there is an address clause, check that it is valid - - Check_Address_Clause (E); - - -- Reset Is_True_Constant for non-constant aliased object. We - -- consider that the fact that a non-constant object is aliased - -- may indicate that some funny business is going on, e.g. an - -- aliased object is passed by reference to a procedure which - -- captures the address of the object, which is later used to - -- assign a new value, even though the compiler thinks that - -- it is not modified. Such code is highly dubious, but we - -- choose to make it "work" for non-constant aliased objects. - -- Note that we used to do this for all aliased objects, - -- whether or not constant, but this caused anomalies down - -- the line because we ended up with static objects that - -- were not Is_True_Constant. Not resetting Is_True_Constant - -- for (aliased) constant objects ensures that this anomaly - -- never occurs. - - -- However, we don't do that for internal entities. We figure - -- that if we deliberately set Is_True_Constant for an internal - -- entity, e.g. a dispatch table entry, then we mean it. - - if Ekind (E) /= E_Constant - and then (Is_Aliased (E) or else Is_Aliased (Etype (E))) - and then not Is_Internal_Name (Chars (E)) - then - Set_Is_True_Constant (E, False); - end if; - - -- If the object needs any kind of default initialization, an - -- error must be issued if No_Default_Initialization applies. - -- The check doesn't apply to imported objects, which are not - -- ever default initialized, and is why the check is deferred - -- until freezing, at which point we know if Import applies. - -- Deferred constants are also exempted from this test because - -- their completion is explicit, or through an import pragma. - - if Ekind (E) = E_Constant - and then Present (Full_View (E)) - then - null; - - elsif Comes_From_Source (E) - and then not Is_Imported (E) - and then not Has_Init_Expression (Declaration_Node (E)) - and then - ((Has_Non_Null_Base_Init_Proc (Etype (E)) - and then not No_Initialization (Declaration_Node (E)) - and then not Is_Value_Type (Etype (E)) - and then not Initialization_Suppressed (Etype (E))) - or else - (Needs_Simple_Initialization (Etype (E)) - and then not Is_Internal (E))) - then - Has_Default_Initialization := True; - Check_Restriction - (No_Default_Initialization, Declaration_Node (E)); - end if; - - -- Check that a Thread_Local_Storage variable does not have - -- default initialization, and any explicit initialization must - -- either be the null constant or a static constant. - - if Has_Pragma_Thread_Local_Storage (E) then - declare - Decl : constant Node_Id := Declaration_Node (E); - begin - if Has_Default_Initialization - or else - (Has_Init_Expression (Decl) - and then - (No (Expression (Decl)) - or else not - (Is_OK_Static_Expression (Expression (Decl)) - or else - Nkind (Expression (Decl)) = N_Null))) - then - Error_Msg_NE - ("Thread_Local_Storage variable& is " - & "improperly initialized", Decl, E); - Error_Msg_NE - ("\only allowed initialization is explicit " - & "NULL or static expression", Decl, E); - end if; - end; - end if; - - -- For imported objects, set Is_Public unless there is also an - -- address clause, which means that there is no external symbol - -- needed for the Import (Is_Public may still be set for other - -- unrelated reasons). Note that we delayed this processing - -- till freeze time so that we can be sure not to set the flag - -- if there is an address clause. If there is such a clause, - -- then the only purpose of the Import pragma is to suppress - -- implicit initialization. - - if Is_Imported (E) and then No (Address_Clause (E)) then - Set_Is_Public (E); - end if; - - -- For source objects that are not Imported and are library - -- level, if no linker section pragma was given inherit the - -- appropriate linker section from the corresponding type. - - if Comes_From_Source (E) - and then not Is_Imported (E) - and then Is_Library_Level_Entity (E) - and then No (Linker_Section_Pragma (E)) - then - Set_Linker_Section_Pragma - (E, Linker_Section_Pragma (Etype (E))); - end if; - - -- For convention C objects of an enumeration type, warn if - -- the size is not integer size and no explicit size given. - -- Skip warning for Boolean, and Character, assume programmer - -- expects 8-bit sizes for these cases. - - if (Convention (E) = Convention_C - or else - Convention (E) = Convention_CPP) - and then Is_Enumeration_Type (Etype (E)) - and then not Is_Character_Type (Etype (E)) - and then not Is_Boolean_Type (Etype (E)) - and then Esize (Etype (E)) < Standard_Integer_Size - and then not Has_Size_Clause (E) - then - Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size); - Error_Msg_N - ("??convention C enumeration object has size less than ^", - E); - Error_Msg_N ("\??use explicit size clause to set size", E); - end if; + Freeze_Object_Declaration (E); end if; -- Check that a constant which has a pragma Volatile[_Components] diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index b8a74d12273..8047b464615 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3336,6 +3336,18 @@ package body Sem_Ch3 is -- or a variant record type is encountered, Check_Restrictions is called -- indicating the count is unknown. + function Delayed_Aspect_Present return Boolean; + -- If the declaration has an expression that is an aggregate, and it + -- has aspects that require delayed analysis, the resolution of the + -- aggregate must be deferred to the freeze point of the objet. This + -- special processing was created for address clauses, but it must + -- also apply to Alignment. + -- This must be done before the aspect specifications are analyzed + -- because we must handle the aggregate before the analysis of the + -- object declaration is complete. + + -- any other relevant delayed aspects on object declarations ??? + ----------------- -- Count_Tasks -- ----------------- @@ -3390,6 +3402,32 @@ package body Sem_Ch3 is end if; end Count_Tasks; + ---------------------------- + -- Delayed_Aspect_Present -- + ---------------------------- + + function Delayed_Aspect_Present return Boolean is + A : Node_Id; + A_Id : Aspect_Id; + + begin + if Present (Aspect_Specifications (N)) then + A := First (Aspect_Specifications (N)); + A_Id := Get_Aspect_Id (Chars (Identifier (A))); + while Present (A) loop + if + A_Id = Aspect_Alignment or else A_Id = Aspect_Address + then + return True; + end if; + + Next (A); + end loop; + end if; + + return False; + end Delayed_Aspect_Present; + -- Start of processing for Analyze_Object_Declaration begin @@ -3705,7 +3743,8 @@ package body Sem_Ch3 is if Comes_From_Source (N) and then Expander_Active and then Nkind (E) = N_Aggregate - and then Present (Following_Address_Clause (N)) + and then (Present (Following_Address_Clause (N)) + or else Delayed_Aspect_Present) then Set_Etype (E, T); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7d6c7069761..77a812335ed 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4346,7 +4346,12 @@ package body Sem_Ch6 is then Check_SPARK_05_Restriction ("null procedure is not allowed", N); - if Is_Protected_Type (Current_Scope) then + -- Null procedures are allowed in protected types, following + -- the recent AI12-0147. + + if Is_Protected_Type (Current_Scope) + and then Ada_Version < Ada_2012 + then Error_Msg_N ("protected operation cannot be a null procedure", N); end if; -- 2.30.2