From 033eaf8501b9611c04430e4f1bf458435fdd1171 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 12 Dec 2011 13:03:35 +0100 Subject: [PATCH] [multiple changes] 2011-12-12 Robert Dewar * exp_atag.adb, exp_atag.ads, exp_util.adb, exp_attr.adb, sem_ch13.adb: Minor reformatting. 2011-12-12 Gary Dismukes * sem_ch7.adb (Uninstall_Declarations): Don't apply check for incomplete types used as a result type for an access-to-function type when compiling for Ada 2012 or later. * sem_ch6.adb (Analyze_Subprogram_Declaration): Specialize error message for interface subprograms that are not declared abstract nor null (functions can't be declared as null). Also, remove "(Ada 2005)" from message. From-SVN: r182230 --- gcc/ada/ChangeLog | 15 +++++++++++++++ gcc/ada/exp_atag.adb | 8 +++----- gcc/ada/exp_atag.ads | 1 - gcc/ada/exp_attr.adb | 14 ++++++-------- gcc/ada/exp_util.adb | 21 +++++++++------------ gcc/ada/sem_ch13.adb | 5 ++--- gcc/ada/sem_ch6.adb | 13 ++++++++++--- gcc/ada/sem_ch7.adb | 9 ++++++--- 8 files changed, 51 insertions(+), 35 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6653a2f4ffac..dea19c8888b7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2011-12-12 Robert Dewar + + * exp_atag.adb, exp_atag.ads, exp_util.adb, exp_attr.adb, + sem_ch13.adb: Minor reformatting. + +2011-12-12 Gary Dismukes + + * sem_ch7.adb (Uninstall_Declarations): Don't + apply check for incomplete types used as a result type for an + access-to-function type when compiling for Ada 2012 or later. + * sem_ch6.adb (Analyze_Subprogram_Declaration): + Specialize error message for interface subprograms that are + not declared abstract nor null (functions can't be declared as + null). Also, remove "(Ada 2005)" from message. + 2011-12-12 Robert Dewar * sem_prag.adb (GNAT_Pragma): Check comes from source. diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index 2b0a03824cff..602014537941 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -300,12 +300,10 @@ package body Exp_Atag is begin return Make_Selected_Component (Loc, - Prefix => - Build_TSD (Loc, - Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), + Prefix => + Build_TSD (Loc, Unchecked_Convert_To (RTE (RE_Address), Tag_Node)), Selector_Name => - New_Reference_To - (RTE_Record_Component (RE_Alignment), Loc)); + New_Reference_To (RTE_Record_Component (RE_Alignment), Loc)); end Build_Get_Alignment; ------------------------------------------ diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 7544925d8a02..6551f153aa96 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -70,7 +70,6 @@ package Exp_Atag is (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id; -- Build code that retrieves the alignment of the tagged type. - -- -- Generates: TSD (Tag).Alignment procedure Build_Get_Predefined_Prim_Op_Address diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 8258f7114faa..111dc8de02be 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1119,20 +1119,18 @@ package body Exp_Attr is -- operation _Alignment applied to X. elsif Is_Class_Wide_Type (Ptyp) then - New_Node := Build_Get_Alignment (Loc, Make_Attribute_Reference (Loc, - Prefix => Pref, + Prefix => Pref, Attribute_Name => Name_Tag)); + -- Case where the context is a specific integer type with which + -- the original attribute was compatible. The function has a + -- specific type as well, so to preserve the compatibility we + -- must convert explicitly. + if Typ /= Standard_Integer then - - -- The context is a specific integer type with which the - -- original attribute was compatible. The function has a - -- specific type as well, so to preserve the compatibility - -- we must convert explicitly. - New_Node := Convert_To (Typ, New_Node); end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 3dd99e9e6f05..52541ed67ebc 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -756,9 +756,7 @@ package body Exp_Util is Append_To (Actuals, New_Reference_To (Addr_Id, Loc)); Append_To (Actuals, New_Reference_To (Size_Id, Loc)); - if Is_Allocate - or else not Is_Class_Wide_Type (Desig_Typ) - then + if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then Append_To (Actuals, New_Reference_To (Alig_Id, Loc)); -- For deallocation of class wide types we obtain the value of @@ -777,7 +775,7 @@ package body Exp_Util is Append_To (Actuals, Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, - Prefix => + Prefix => Make_Explicit_Dereference (Loc, Relocate_Node (Expr)), Attribute_Name => Name_Alignment))); end if; @@ -879,6 +877,7 @@ package body Exp_Util is else Append_To (Actuals, New_Reference_To (Standard_True, Loc)); end if; + else Append_To (Actuals, New_Reference_To (Standard_False, Loc)); end if; @@ -917,8 +916,7 @@ package body Exp_Util is -- P : Root_Storage_Pool Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Temporary (Loc, 'P'), + Defining_Identifier => Make_Temporary (Loc, 'P'), Parameter_Type => New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)), @@ -926,22 +924,22 @@ package body Exp_Util is Make_Parameter_Specification (Loc, Defining_Identifier => Addr_Id, - Out_Present => Is_Allocate, - Parameter_Type => + Out_Present => Is_Allocate, + Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), -- S : Storage_Count Make_Parameter_Specification (Loc, Defining_Identifier => Size_Id, - Parameter_Type => + Parameter_Type => New_Reference_To (RTE (RE_Storage_Count), Loc)), -- L : Storage_Count Make_Parameter_Specification (Loc, Defining_Identifier => Alig_Id, - Parameter_Type => + Parameter_Type => New_Reference_To (RTE (RE_Storage_Count), Loc)))), Declarations => No_List, @@ -950,8 +948,7 @@ package body Exp_Util is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (Proc_To_Call, Loc), + Name => New_Reference_To (Proc_To_Call, Loc), Parameter_Associations => Actuals))))); -- The newly generated Allocate / Deallocate becomes the default diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8b543a3d9b31..d06ba9388acb 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2497,6 +2497,7 @@ package body Sem_Ch13 is when Attribute_Alignment => Alignment : declare Align : constant Uint := Get_Alignment_Value (Expr); Max_Align : constant Uint := UI_From_Int (Maximum_Alignment); + begin FOnly := True; @@ -2512,9 +2513,7 @@ package body Sem_Ch13 is elsif Align /= No_Uint then Set_Has_Alignment_Clause (U_Ent); - if Is_Tagged_Type (U_Ent) - and then Align > Max_Align - then + if Is_Tagged_Type (U_Ent) and then Align > Max_Align then Error_Msg_N ("?alignment for & set to Maximum_Aligment", Nam); Set_Alignment (U_Ent, Max_Align); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2cc899e934a2..846f3a300661 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3256,9 +3256,16 @@ package body Sem_Ch6 is and then Null_Present (Specification (N))) then Error_Msg_Name_1 := Chars (Defining_Entity (N)); - Error_Msg_N - ("(Ada 2005) interface subprogram % must be abstract or null", - N); + + -- Specialize error message based on procedures vs. functions, + -- since functions can't be null subprograms. + + if Ekind (Designator) = E_Procedure then + Error_Msg_N + ("interface procedure % must be abstract or null", N); + else + Error_Msg_N ("interface function % must be abstract", N); + end if; end if; end; end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index e1453d0c1e8e..2f87cf07885c 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2474,10 +2474,13 @@ package body Sem_Ch7 is ("type& must be completed in the private part", Parent (Subp), Id); - -- The return type of an access_to_function cannot be a - -- Taft-amendment type. + -- The result type of an access-to-function type cannot be a + -- Taft-amendment type, unless the version is Ada 2012 or + -- later (see AI05-151). - elsif Ekind (Subp) = E_Subprogram_Type then + elsif Ada_Version < Ada_2012 + and then Ekind (Subp) = E_Subprogram_Type + then if Etype (Subp) = Id or else (Is_Class_Wide_Type (Etype (Subp))