[multiple changes]

2011-08-01  Robert Dewar  <dewar@adacore.com>

	* 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  <celier@adacore.com>

	* 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  <quinot@adacore.com>

	* exp_ch4.adb, s-tasini.ads, sem_attr.adb, s-soflin.ads: Minor
	reformatting.

2011-08-01  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	* adaint.c (__gnat_file_time_name_attr): Get rid of warning.

2011-08-01  Thomas Quinot  <quinot@adacore.com>

	* 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

gcc/ada/ChangeLog

@@ -1,3 +1,36 @@
+2011-08-01  Robert Dewar  <dewar@adacore.com>
+
+	* 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  <celier@adacore.com>
+
+	* 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  <quinot@adacore.com>
+
+	* exp_ch4.adb, s-tasini.ads, sem_attr.adb, s-soflin.ads: Minor
+	reformatting.
+
+2011-08-01  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>
+
+	* adaint.c (__gnat_file_time_name_attr): Get rid of warning.
+
+2011-08-01  Thomas Quinot  <quinot@adacore.com>
+
+	* 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  <dewar@adacore.com>
 
 	* aspects.ads, aspects.adb: Add aspect Type_Invariant, Precondition,

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

gcc/ada/aspects.adb

@@ -29,13 +29,12 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Atree;   use Atree;
+with Atree;    use Atree;
-with Nlists;  use Nlists;
+with Nlists;   use Nlists;
-with Sinfo;   use Sinfo;
+with Sinfo;    use Sinfo;
-with Snames;  use Snames;
+with Tree_IO;  use Tree_IO;
-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 --
    ------------------

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 Namet;  use Namet;
-with Types; use Types;
+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

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),
+               --  optimization due to some glitch (perhaps a previous
-               --  so ignore.
+               --  error), so ignore.
 
             end if;
          end if;

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;
+with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common;
-pragma Warnings (Off, MLib.Tgt.VMS_Common);
---  MLib.Tgt.VMS_Common is with'ed only for elaboration purposes
 
 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);

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;
+with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common;
-pragma Warnings (Off, MLib.Tgt.VMS_Common);
---  MLib.Tgt.VMS_Common is with'ed only for elaboration purposes
 
 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);

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 --
    -------------------

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;

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

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
+   --  Called when scanning a reserved keyword when the keyword is not present.
-   --  present. T is the token type for the keyword, and P indicates the
+   --  T is the token type for the keyword, and P indicates the position to be
-   --  position to be used to place a message relative to the current
+   --  used to place a message relative to the current token if the keyword is
-   --  token if the keyword is not located nearby.
+   --  not located nearby.
 
    -----------------
    -- Check_Token --

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;

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

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 --

gcc/ada/sem_attr.adb

@@ -2065,8 +2065,7 @@ package body Sem_Attr is
 
       when Attribute_Abort_Signal =>
          Check_Standard_Prefix;
-         Rewrite (N,
+         Rewrite (N, New_Reference_To (Stand.Abort_Signal, Loc));
-           New_Reference_To (Stand.Abort_Signal, Loc));
          Analyze (N);
 
       ------------

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);

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
-
+         if Is_RTU (Scope (BT), Ada_Finalization) then
-         --  For derived types, check immediate ancestor, excluding
+            return False;
-         --  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;
 
          elsif Present (Primitive_Operations (BT)) then
             P := First_Elmt (Primitive_Operations (BT));
             while Present (P) loop
-               if Chars (Node (P)) = Name_Initialize
+               declare
-                 and then Comes_From_Source (Node (P))
+                  Init : constant Entity_Id := Node (P);
-               then
+                  Formal : constant Entity_Id := First_Formal (Init);
-                  return True;
+               begin
-               end if;
+                  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
+         if Is_Derived_Type (BT)
-         Comp := First_Component (BT);
+           and then Has_Overriding_Initialize (Etype (BT))
-         while Present (Comp) loop
+         then
-            if Has_Overriding_Initialize (Etype (Comp)) then
+            return True;
-               return True;
+         end if;
-            end if;
-
-            Next_Component (Comp);
-         end loop;
-
-         return False;
-
-      else
-         return False;
       end if;
+
+      return False;
    end Has_Overriding_Initialize;
 
    --------------------------------------

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