From: Arnaud Charlet Date: Mon, 1 Aug 2011 12:31:32 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c228a0698654628c25704330a123c58c4a5380b4;p=gcc.git [multiple changes] 2011-08-01 Robert Dewar * aspects.ads, aspects.adb (Aspect_Names): Moved from body to spec. * par-ch13.adb (P_Aspect_Specifications): Check misspelled aspect name. * par.adb: Add with for Namet.Sp. * par-tchk.adb: Minor reformatting. 2011-08-01 Vincent Celier * mlib-tgt-specific-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb (Build_Dynamic_Library): Use new function Init_Proc_Name to get the name of the init procedure of a SAL. * mlib-tgt-vms_common.ads, mlib-tgt-vms_common.adb (Init_Proc_Name): New procedure. 2011-08-01 Thomas Quinot * exp_ch4.adb, s-tasini.ads, sem_attr.adb, s-soflin.ads: Minor reformatting. 2011-08-01 Richard Kenner * adaint.c (__gnat_file_time_name_attr): Get rid of warning. 2011-08-01 Thomas Quinot * sem_util.adb, sem_util.ads (Has_Overriding_Initialize): Make function conformant with its spec (return True only for types that have an overriding Initialize primitive operation that prevents them from having preelaborable initialization). * sem_cat.adb (Validate_Object_Declaration): Fix test for preelaborable initialization for controlled types in Ada 2005 or later mode. From-SVN: r177021 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f050e328cfc..100a2980779 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2011-08-01 Robert Dewar + + * aspects.ads, aspects.adb (Aspect_Names): Moved from body to spec. + * par-ch13.adb (P_Aspect_Specifications): Check misspelled aspect name. + * par.adb: Add with for Namet.Sp. + * par-tchk.adb: Minor reformatting. + +2011-08-01 Vincent Celier + + * mlib-tgt-specific-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb + (Build_Dynamic_Library): Use new function Init_Proc_Name to get the name + of the init procedure of a SAL. + * mlib-tgt-vms_common.ads, mlib-tgt-vms_common.adb (Init_Proc_Name): + New procedure. + +2011-08-01 Thomas Quinot + + * exp_ch4.adb, s-tasini.ads, sem_attr.adb, s-soflin.ads: Minor + reformatting. + +2011-08-01 Richard Kenner + + * adaint.c (__gnat_file_time_name_attr): Get rid of warning. + +2011-08-01 Thomas Quinot + + * sem_util.adb, sem_util.ads (Has_Overriding_Initialize): Make function + conformant with its spec (return True only for types that have + an overriding Initialize primitive operation that prevents them from + having preelaborable initialization). + * sem_cat.adb (Validate_Object_Declaration): Fix test for preelaborable + initialization for controlled types in Ada 2005 or later mode. + 2011-08-01 Robert Dewar * aspects.ads, aspects.adb: Add aspect Type_Invariant, Precondition, diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index c1e97c64b40..66c27788557 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -1370,7 +1370,7 @@ __gnat_file_time_name_attr (char* name, struct file_attributes* attr) TCHAR wname[GNAT_MAX_PATH_LEN]; S2WSC (wname, name, GNAT_MAX_PATH_LEN); - if (res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad)) + if ((res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad))) f2t (&fad.ftLastWriteTime, &ret); attr->timestamp = (OS_Time) ret; #else diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index b92891c512b..ca87c6c2c1d 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -29,13 +29,12 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Nlists; use Nlists; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Tree_IO; use Tree_IO; +with Atree; use Atree; +with Nlists; use Nlists; +with Sinfo; use Sinfo; +with Tree_IO; use Tree_IO; -with GNAT.HTable; use GNAT.HTable; +with GNAT.HTable; use GNAT.HTable; package body Aspects is @@ -63,66 +62,6 @@ package body Aspects is Hash => AS_Hash, Equal => "="); - ----------------------------------------- - -- Table Linking Names and Aspect_Id's -- - ----------------------------------------- - - type Aspect_Entry is record - Nam : Name_Id; - Asp : Aspect_Id; - end record; - - Aspect_Names : constant array (Integer range <>) of Aspect_Entry := - ((Name_Ada_2005, Aspect_Ada_2005), - (Name_Ada_2012, Aspect_Ada_2012), - (Name_Address, Aspect_Address), - (Name_Alignment, Aspect_Alignment), - (Name_Atomic, Aspect_Atomic), - (Name_Atomic_Components, Aspect_Atomic_Components), - (Name_Bit_Order, Aspect_Bit_Order), - (Name_Component_Size, Aspect_Component_Size), - (Name_Dynamic_Predicate, Aspect_Dynamic_Predicate), - (Name_Discard_Names, Aspect_Discard_Names), - (Name_External_Tag, Aspect_External_Tag), - (Name_Favor_Top_Level, Aspect_Favor_Top_Level), - (Name_Inline, Aspect_Inline), - (Name_Inline_Always, Aspect_Inline_Always), - (Name_Input, Aspect_Input), - (Name_Invariant, Aspect_Invariant), - (Name_Machine_Radix, Aspect_Machine_Radix), - (Name_Object_Size, Aspect_Object_Size), - (Name_Output, Aspect_Output), - (Name_Pack, Aspect_Pack), - (Name_Persistent_BSS, Aspect_Persistent_BSS), - (Name_Post, Aspect_Post), - (Name_Postcondition, Aspect_Postcondition), - (Name_Pre, Aspect_Pre), - (Name_Precondition, Aspect_Precondition), - (Name_Predicate, Aspect_Predicate), - (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization), - (Name_Pure_Function, Aspect_Pure_Function), - (Name_Read, Aspect_Read), - (Name_Shared, Aspect_Shared), - (Name_Size, Aspect_Size), - (Name_Static_Predicate, Aspect_Static_Predicate), - (Name_Storage_Pool, Aspect_Storage_Pool), - (Name_Storage_Size, Aspect_Storage_Size), - (Name_Stream_Size, Aspect_Stream_Size), - (Name_Suppress, Aspect_Suppress), - (Name_Suppress_Debug_Info, Aspect_Suppress_Debug_Info), - (Name_Type_Invariant, Aspect_Type_Invariant), - (Name_Unchecked_Union, Aspect_Unchecked_Union), - (Name_Universal_Aliasing, Aspect_Universal_Aliasing), - (Name_Unmodified, Aspect_Unmodified), - (Name_Unreferenced, Aspect_Unreferenced), - (Name_Unreferenced_Objects, Aspect_Unreferenced_Objects), - (Name_Unsuppress, Aspect_Unsuppress), - (Name_Value_Size, Aspect_Value_Size), - (Name_Volatile, Aspect_Volatile), - (Name_Volatile_Components, Aspect_Volatile_Components), - (Name_Warnings, Aspect_Warnings), - (Name_Write, Aspect_Write)); - ------------------------------------- -- Hash Table for Aspect Id Values -- ------------------------------------- @@ -147,15 +86,6 @@ package body Aspects is Hash => AI_Hash, Equal => "="); - ------------------- - -- Get_Aspect_Id -- - ------------------- - - function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is - begin - return Aspect_Id_Hash_Table.Get (Name); - end Get_Aspect_Id; - --------------------------- -- Aspect_Specifications -- --------------------------- @@ -169,6 +99,15 @@ package body Aspects is end if; end Aspect_Specifications; + ------------------- + -- Get_Aspect_Id -- + ------------------- + + function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is + begin + return Aspect_Id_Hash_Table.Get (Name); + end Get_Aspect_Id; + ------------------ -- Move_Aspects -- ------------------ diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index dc117e1aa20..ed391f03a07 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -34,8 +34,9 @@ -- aspect specifications from the tree. The semantic processing for aspect -- specifications is found in Sem_Ch13.Analyze_Aspect_Specifications. -with Namet; use Namet; -with Types; use Types; +with Namet; use Namet; +with Snames; use Snames; +with Types; use Types; package Aspects is @@ -159,6 +160,68 @@ package Aspects is Aspect_Write => Name, Boolean_Aspects => Optional); + ----------------------------------------- + -- Table Linking Names and Aspect_Id's -- + ----------------------------------------- + + type Aspect_Entry is record + Nam : Name_Id; + Asp : Aspect_Id; + end record; + + -- Table linking aspect names and id's + + Aspect_Names : constant array (Integer range <>) of Aspect_Entry := + ((Name_Ada_2005, Aspect_Ada_2005), + (Name_Ada_2012, Aspect_Ada_2012), + (Name_Address, Aspect_Address), + (Name_Alignment, Aspect_Alignment), + (Name_Atomic, Aspect_Atomic), + (Name_Atomic_Components, Aspect_Atomic_Components), + (Name_Bit_Order, Aspect_Bit_Order), + (Name_Component_Size, Aspect_Component_Size), + (Name_Dynamic_Predicate, Aspect_Dynamic_Predicate), + (Name_Discard_Names, Aspect_Discard_Names), + (Name_External_Tag, Aspect_External_Tag), + (Name_Favor_Top_Level, Aspect_Favor_Top_Level), + (Name_Inline, Aspect_Inline), + (Name_Inline_Always, Aspect_Inline_Always), + (Name_Input, Aspect_Input), + (Name_Invariant, Aspect_Invariant), + (Name_Machine_Radix, Aspect_Machine_Radix), + (Name_Object_Size, Aspect_Object_Size), + (Name_Output, Aspect_Output), + (Name_Pack, Aspect_Pack), + (Name_Persistent_BSS, Aspect_Persistent_BSS), + (Name_Post, Aspect_Post), + (Name_Postcondition, Aspect_Postcondition), + (Name_Pre, Aspect_Pre), + (Name_Precondition, Aspect_Precondition), + (Name_Predicate, Aspect_Predicate), + (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization), + (Name_Pure_Function, Aspect_Pure_Function), + (Name_Read, Aspect_Read), + (Name_Shared, Aspect_Shared), + (Name_Size, Aspect_Size), + (Name_Static_Predicate, Aspect_Static_Predicate), + (Name_Storage_Pool, Aspect_Storage_Pool), + (Name_Storage_Size, Aspect_Storage_Size), + (Name_Stream_Size, Aspect_Stream_Size), + (Name_Suppress, Aspect_Suppress), + (Name_Suppress_Debug_Info, Aspect_Suppress_Debug_Info), + (Name_Type_Invariant, Aspect_Type_Invariant), + (Name_Unchecked_Union, Aspect_Unchecked_Union), + (Name_Universal_Aliasing, Aspect_Universal_Aliasing), + (Name_Unmodified, Aspect_Unmodified), + (Name_Unreferenced, Aspect_Unreferenced), + (Name_Unreferenced_Objects, Aspect_Unreferenced_Objects), + (Name_Unsuppress, Aspect_Unsuppress), + (Name_Value_Size, Aspect_Value_Size), + (Name_Volatile, Aspect_Volatile), + (Name_Volatile_Components, Aspect_Volatile_Components), + (Name_Warnings, Aspect_Warnings), + (Name_Write, Aspect_Write)); + function Get_Aspect_Id (Name : Name_Id) return Aspect_Id; pragma Inline (Get_Aspect_Id); -- Given a name Nam, returns the corresponding aspect id value. If the name diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 480422b3638..3256cc4d779 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7693,7 +7693,8 @@ package body Exp_Ch4 is -- copy. We don't want to copy complex expressions, and -- indeed to do so can cause trouble (before we put in -- this guard, a discriminant expression containing an - -- AND THEN was copied, cause coverage problems + -- AND THEN was copied, causing problems to coverage + -- analysis tools). if Disc = Entity (Selector_Name (N)) and then (Is_Entity_Name (Dval) @@ -7723,7 +7724,7 @@ package body Exp_Ch4 is elsif Is_Entity_Name (Dval) and then Nkind (Parent (Entity (Dval))) - = N_Object_Declaration + = N_Object_Declaration and then Present (Expression (Parent (Entity (Dval)))) and then not Is_Static_Expression @@ -7774,8 +7775,8 @@ package body Exp_Ch4 is -- Note: the above loop should always find a matching -- discriminant, but if it does not, we just missed an - -- optimization due to some glitch (perhaps a previous error), - -- so ignore. + -- optimization due to some glitch (perhaps a previous + -- error), so ignore. end if; end if; diff --git a/gcc/ada/mlib-tgt-specific-vms-alpha.adb b/gcc/ada/mlib-tgt-specific-vms-alpha.adb index c9ffa0d837e..c8e248b13eb 100644 --- a/gcc/ada/mlib-tgt-specific-vms-alpha.adb +++ b/gcc/ada/mlib-tgt-specific-vms-alpha.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, 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- -- @@ -31,9 +31,7 @@ with Ada.Characters.Handling; use Ada.Characters.Handling; with MLib.Fil; with MLib.Utl; -with MLib.Tgt.VMS_Common; -pragma Warnings (Off, MLib.Tgt.VMS_Common); --- MLib.Tgt.VMS_Common is with'ed only for elaboration purposes +with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common; with Opt; use Opt; with Output; use Output; @@ -251,7 +249,7 @@ package body MLib.Tgt.Specific is declare Macro_File_Name : constant String := Lib_Filename & "__init.asm"; Macro_File : File_Descriptor; - Init_Proc : String := Lib_Filename & "INIT"; + Init_Proc : constant String := Init_Proc_Name (Lib_Filename); Popen_Result : System.Address; Pclose_Result : Integer; Len : Natural; @@ -266,8 +264,6 @@ package body MLib.Tgt.Specific is -- The mode for the invocation of Popen begin - To_Upper (Init_Proc); - if Verbose_Mode then Write_Str ("Creating auto-init assembly file """); Write_Str (Macro_File_Name); diff --git a/gcc/ada/mlib-tgt-specific-vms-ia64.adb b/gcc/ada/mlib-tgt-specific-vms-ia64.adb index 247b2eb304b..6c6c7ae37ce 100644 --- a/gcc/ada/mlib-tgt-specific-vms-ia64.adb +++ b/gcc/ada/mlib-tgt-specific-vms-ia64.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, 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- -- @@ -31,9 +31,7 @@ with Ada.Characters.Handling; use Ada.Characters.Handling; with MLib.Fil; with MLib.Utl; -with MLib.Tgt.VMS_Common; -pragma Warnings (Off, MLib.Tgt.VMS_Common); --- MLib.Tgt.VMS_Common is with'ed only for elaboration purposes +with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common; with Opt; use Opt; with Output; use Output; @@ -248,7 +246,7 @@ package body MLib.Tgt.Specific is declare Macro_File_Name : constant String := Lib_Filename & "__init.asm"; Macro_File : File_Descriptor; - Init_Proc : String := Lib_Filename & "INIT"; + Init_Proc : constant String := Init_Proc_Name (Lib_Filename); Popen_Result : System.Address; Pclose_Result : Integer; Len : Natural; @@ -265,8 +263,6 @@ package body MLib.Tgt.Specific is -- Why odd lower case name ??? begin - To_Upper (Init_Proc); - if Verbose_Mode then Write_Str ("Creating auto-init assembly file """); Write_Str (Macro_File_Name); diff --git a/gcc/ada/mlib-tgt-vms_common.adb b/gcc/ada/mlib-tgt-vms_common.adb index 6d79cd7e947..9855afb84ac 100644 --- a/gcc/ada/mlib-tgt-vms_common.adb +++ b/gcc/ada/mlib-tgt-vms_common.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, 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- -- @@ -25,6 +25,8 @@ -- This is the part of MLib.Tgt.Specific common to both VMS versions +with System.Case_Util; use System.Case_Util; + package body MLib.Tgt.VMS_Common is -- Non default subprograms. See comments in mlib-tgt.ads @@ -74,6 +76,23 @@ package body MLib.Tgt.VMS_Common is return "exe"; end DLL_Ext; + -------------------- + -- Init_Proc_Name -- + -------------------- + + function Init_Proc_Name (Library_Name : String) return String is + Result : String := Library_Name & "INIT"; + begin + To_Upper (Result); + + if Result = "ADAINIT" then + return "ADA_INIT"; + + else + return Result; + end if; + end Init_Proc_Name; + ------------------- -- Is_Object_Ext -- ------------------- diff --git a/gcc/ada/mlib-tgt-vms_common.ads b/gcc/ada/mlib-tgt-vms_common.ads index 8429b773123..cdba6134ee9 100644 --- a/gcc/ada/mlib-tgt-vms_common.ads +++ b/gcc/ada/mlib-tgt-vms_common.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2010, 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- -- @@ -27,4 +27,9 @@ package MLib.Tgt.VMS_Common is pragma Elaborate_Body; + + function Init_Proc_Name (Library_Name : String) return String; + -- Returns, in upper case, Library_Name & "INIT", except when Library_Name + -- is "ada" (case insensitive), returns "ADA_INIT". + end MLib.Tgt.VMS_Common; diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 2e237e6631c..215174e6fbd 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -427,6 +427,19 @@ package body Ch13 is if A_Id = No_Aspect then Error_Msg_SC ("aspect identifier expected"); + -- Check bad spelling + + for J in Aspect_Names'Range loop + if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J).Nam) then + Error_Msg_Name_1 := Aspect_Names (J).Nam; + Error_Msg_SC -- CODEFIX + ("\possible misspelling of%"); + exit; + end if; + end loop; + + Scan; -- past incorrect identifier + if Token = Tok_Apostrophe then Scan; -- past ' Scan; -- past presumably CLASS diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index c92b20fbfe2..6efb1e96697 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -43,10 +43,10 @@ package body Tchk is -- position of the error message if the token is missing (see Wrong_Token) procedure Wrong_Token (T : Token_Type; P : Position); - -- Called when scanning a reserved keyword when the keyword is not - -- present. T is the token type for the keyword, and P indicates the - -- position to be used to place a message relative to the current - -- token if the keyword is not located nearby. + -- Called when scanning a reserved keyword when the keyword is not present. + -- T is the token type for the keyword, and P indicates the position to be + -- used to place a message relative to the current token if the keyword is + -- not located nearby. ----------------- -- Check_Token -- diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 776e6bd757f..ee05d9c60d2 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -32,6 +32,7 @@ with Errout; use Errout; with Fname; use Fname; with Lib; use Lib; with Namet; use Namet; +with Namet.Sp; use Namet.Sp; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads index 783fd8878eb..5a2c556f5a8 100644 --- a/gcc/ada/s-soflin.ads +++ b/gcc/ada/s-soflin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -146,7 +146,7 @@ package System.Soft_Links is function Check_Abort_Status_NT return Integer; -- Returns Boolean'Pos (True) iff abort signal should raise - -- Standard.Abort_Signal. + -- Standard'Abort_Signal. procedure Task_Lock_NT; -- Lock out other tasks (non-tasking case, does nothing) @@ -180,7 +180,7 @@ package System.Soft_Links is Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; -- Called when Abort_Signal is delivered to the process. Checks to - -- see if signal should result in raising Standard.Abort_Signal. + -- see if signal should result in raising Standard'Abort_Signal. Lock_Task : No_Param_Proc := Task_Lock_NT'Access; -- Locks out other tasks. Preceding a section of code by Task_Lock and diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads index 0b2f4509203..1bf82cceb26 100644 --- a/gcc/ada/s-tasini.ads +++ b/gcc/ada/s-tasini.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -127,7 +127,7 @@ package System.Tasking.Initialization is function Check_Abort_Status return Integer; -- Returns Boolean'Pos (True) iff abort signal should raise - -- Standard.Abort_Signal. Only used by IRIX currently. + -- Standard'Abort_Signal. Only used by IRIX currently. -------------------------- -- Change Base Priority -- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index ea00352ec6f..33a40b3ba36 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -2065,8 +2065,7 @@ package body Sem_Attr is 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); ------------ diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 9311beb99db..e262dc71835 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -1268,7 +1268,17 @@ package body Sem_Cat is end if; end if; - if Has_Overriding_Initialize (ET) then + -- For controlled type or type with controlled component, check + -- preelaboration flag, as there may be a non-null Initialize + -- primitive. For language versions earlier than Ada 2005, + -- there is no notion of preelaborable initialization, and the + -- rules for controlled objects are enforced in + -- Validate_Controlled_Object. + + if (Is_Controlled (ET) or else Has_Controlled_Component (ET)) + and then Ada_Version >= Ada_2005 + and then not Has_Preelaborable_Initialization (ET) + then Error_Msg_NE ("controlled type& does not have" & " preelaborable initialization", N, ET); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3a6ca5f3456..c21003efc97 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4889,51 +4889,48 @@ package body Sem_Util is function Has_Overriding_Initialize (T : Entity_Id) return Boolean is BT : constant Entity_Id := Base_Type (T); - Comp : Entity_Id; P : Elmt_Id; begin if Is_Controlled (BT) then - - -- For derived types, check immediate ancestor, excluding - -- Controlled itself. - - if Is_Derived_Type (BT) - and then not In_Predefined_Unit (Etype (BT)) - and then Has_Overriding_Initialize (Etype (BT)) - then - return True; + if Is_RTU (Scope (BT), Ada_Finalization) then + return False; elsif Present (Primitive_Operations (BT)) then P := First_Elmt (Primitive_Operations (BT)); while Present (P) loop - if Chars (Node (P)) = Name_Initialize - and then Comes_From_Source (Node (P)) - then - return True; - end if; + declare + Init : constant Entity_Id := Node (P); + Formal : constant Entity_Id := First_Formal (Init); + begin + if Ekind (Init) = E_Procedure + and then Chars (Init) = Name_Initialize + and then Comes_From_Source (Init) + and then Present (Formal) + and then Etype (Formal) = BT + and then No (Next_Formal (Formal)) + and then (Ada_Version < Ada_2012 + or else not Null_Present (Parent (Init))) + then + return True; + end if; + end; Next_Elmt (P); end loop; end if; - return False; + -- Here if type itself does not have a non-null Initialize operation: + -- check immediate ancestor. - elsif Has_Controlled_Component (BT) then - Comp := First_Component (BT); - while Present (Comp) loop - if Has_Overriding_Initialize (Etype (Comp)) then - return True; - end if; - - Next_Component (Comp); - end loop; - - return False; - - else - return False; + if Is_Derived_Type (BT) + and then Has_Overriding_Initialize (Etype (BT)) + then + return True; + end if; end if; + + return False; end Has_Overriding_Initialize; -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 40a3df32cc7..2b7d2d060e4 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -587,7 +587,9 @@ package Sem_Util is function Has_Overriding_Initialize (T : Entity_Id) return Boolean; -- Predicate to determine whether a controlled type has a user-defined - -- Initialize primitive, which makes the type not preelaborable. + -- Initialize primitive (and, in Ada 2012, whether that primitive is + -- non-null), which causes the type to not have preelaborable + -- initialization. function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; -- Return True iff type E has preelaborable initialization as defined in