OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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
This commit is contained in:
Arnaud Charlet 2011-08-01 14:31:32 +02:00
parent b6193c94eb
commit c228a06986
18 changed files with 215 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
gcc/ada/ChangeLog
View File

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

2
gcc/ada/adaint.c
View File

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

89
gcc/ada/aspects.adb
View File

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

67
gcc/ada/aspects.ads
View File

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

9
gcc/ada/exp_ch4.adb
View File

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

10
gcc/ada/mlib-tgt-specific-vms-alpha.adb
View File

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

10
gcc/ada/mlib-tgt-specific-vms-ia64.adb
View File

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

21
gcc/ada/mlib-tgt-vms_common.adb
View File

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

7
gcc/ada/mlib-tgt-vms_common.ads
View File

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

13
gcc/ada/par-ch13.adb
View File

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

8
gcc/ada/par-tchk.adb
View File

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

1
gcc/ada/par.adb
View File

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

6
gcc/ada/s-soflin.ads
View File

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

4
gcc/ada/s-tasini.ads
View File

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

3
gcc/ada/sem_attr.adb
View File

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

12
gcc/ada/sem_cat.adb
View File

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

57
gcc/ada/sem_util.adb
View File

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

4
gcc/ada/sem_util.ads
View File

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