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,
Postcondition.
(Same_Aspect): New function.
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
-- --
------------------------------------------------------------------------------
-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
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 --
-------------------------------------
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 --
---------------------------
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 --
------------------
-- 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
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
-- 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)
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
-- 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;
-- --
-- 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- --
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;
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;
-- 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);
-- --
-- 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- --
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;
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;
-- 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);
-- --
-- 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- --
-- 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
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 --
-------------------
-- --
-- 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- --
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;
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
-- 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 --
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;
-- --
-- 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- --
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)
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
-- --
-- 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- --
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 --
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);
------------
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);
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;
--------------------------------------
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
projects / platform / upstream / linaro-gcc.git / commitdiff