[multiple changes]

2010-10-18  Bob Duff  <duff@adacore.com>

	* sinfo.ads, sinfo.adb: Modify comment about adding fields to be more
	correct, and to be in a more convenient order.
	(Default_Storage_Pool): New field of N_Compilation_Unit_Aux, for
	recording the Default_Storage_Pool for a parent library unit.
	* einfo.ads (Etype): Document the case in which Etype can be Empty.
	* sem_prag.adb (Pragma_Default_Storage_Pool): Analyze the new
	Default_Storage_Pool pragma.
	* sem.ads (Save_Default_Storage_Pool): Save area for push/pop scopes.
	* gnat_ugn.texi: Document Default_Storage_Pool as a new configuration
	pragma.
	* freeze.adb (Freeze_Entity): When freezing an access type, take into
	account any Default_Storage_Pool pragma that applies. We have to do
	this at the freezing point, because up until that point, a Storage_Pool
	or Storage_Size clause could occur, which should override the
	Default_Storage_Pool.
	* par-prag.adb: Add this pragma to the list of pragmas handled entirely
	during semantics.
	* sem_ch8.adb (Push_Scope, Pop_Scope): Save and restore the
	Default_Storage_Pool information.
	* opt.ads (Default_Pool, Default_Pool_Config): New globals for recording
	currently-applicable Default_Storage_Pool pragmas.
	* opt.adb: Save/restore the globals as appropriate.
	* snames.ads-tmpl (Name_Default_Storage_Pool,
	Pragma_Default_Storage_Pool): New pragma name.

2010-10-18  Vincent Celier  <celier@adacore.com>

	* make.adb (Switches_Of): Put the spec and body suffix in canonical
	case.

From-SVN: r165637
This commit is contained in:
Arnaud Charlet 2010-10-18 16:05:56 +02:00
parent 6191e21252
commit fab2daeb32
14 changed files with 240 additions and 38 deletions

View File

@ -1,3 +1,35 @@
2010-10-18 Bob Duff <duff@adacore.com>
* sinfo.ads, sinfo.adb: Modify comment about adding fields to be more
correct, and to be in a more convenient order.
(Default_Storage_Pool): New field of N_Compilation_Unit_Aux, for
recording the Default_Storage_Pool for a parent library unit.
* einfo.ads (Etype): Document the case in which Etype can be Empty.
* sem_prag.adb (Pragma_Default_Storage_Pool): Analyze the new
Default_Storage_Pool pragma.
* sem.ads (Save_Default_Storage_Pool): Save area for push/pop scopes.
* gnat_ugn.texi: Document Default_Storage_Pool as a new configuration
pragma.
* freeze.adb (Freeze_Entity): When freezing an access type, take into
account any Default_Storage_Pool pragma that applies. We have to do
this at the freezing point, because up until that point, a Storage_Pool
or Storage_Size clause could occur, which should override the
Default_Storage_Pool.
* par-prag.adb: Add this pragma to the list of pragmas handled entirely
during semantics.
* sem_ch8.adb (Push_Scope, Pop_Scope): Save and restore the
Default_Storage_Pool information.
* opt.ads (Default_Pool, Default_Pool_Config): New globals for recording
currently-applicable Default_Storage_Pool pragmas.
* opt.adb: Save/restore the globals as appropriate.
* snames.ads-tmpl (Name_Default_Storage_Pool,
Pragma_Default_Storage_Pool): New pragma name.
2010-10-18 Vincent Celier <celier@adacore.com>
* make.adb (Switches_Of): Put the spec and body suffix in canonical
case.
2010-10-18 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): If subprogram is at the

View File

@ -770,13 +770,12 @@ package Einfo is
-- subtypes. Contains the Digits value specified in the declaration.
-- Direct_Primitive_Operations (Elist15)
-- Present in tagged record types and subtypes, in tagged private types
-- and in tagged incomplete types. Points to an element list of entities
-- for primitive operations for the tagged type. Not present in untagged
-- types (it is an error to reference the primitive operations field of a
-- type that is not tagged). In order to fulfill the C++ ABI, entities of
-- primitives that come from source must be stored in this list following
-- their order of occurrence in the sources. For incomplete types the
-- Present in tagged types and subtypes (including synchronized types),
-- in tagged private types and in tagged incomplete types. Element list
-- of entities for primitive operations of the tagged type. Not present
-- in untagged types. In order to follow the C++ ABI, entities of
-- primitives that come from source must be stored in this list in the
-- order of their occurrence in the sources. For incomplete types the
-- list is always empty.
-- Directly_Designated_Type (Node20)
@ -1048,6 +1047,9 @@ package Einfo is
-- a class wide type, points to the parent type. For a subprogram or
-- subprogram type, Etype has the return type of a function or is set
-- to Standard_Void_Type to represent a procedure.
--
-- Note one obscure case: for pragma Default_Storage_Pool (null), the
-- Etype of the N_Null node is Empty.
-- Exception_Code (Uint22)
-- Present in exception entitites. Set to zero unless either an
@ -1663,7 +1665,7 @@ package Einfo is
-- of a private type declaration or its corresponding full declaration.
-- This flag is thus preserved when the full and the partial views are
-- exchanged, to indicate if a full type declaration is a completion.
-- Used for semantic checks in E.4 (18), and elsewhere.
-- Used for semantic checks in E.4(18) and elsewhere.
-- Has_Qualified_Name (Flag161)
-- Present in all entities. Set True if the name in the Chars field
@ -3221,10 +3223,10 @@ package Einfo is
-- Primitive_Operations (synthesized)
-- Present in concurrent types, tagged record types and subtypes, tagged
-- private types and tagged incomplete types. For concurrent types that
-- have available their Corresponding_Record_Type (CRT) returns the list
-- of Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
-- For all the other types returns its Direct_Primitive_Operations.
-- private types and tagged incomplete types. For concurrent types whose
-- Corresponding_Record_Type (CRT) is available, returns the list of
-- Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
-- For all the other types returns the Direct_Primitive_Operations.
-- Prival (Node17)
-- Present in private components of protected types. Refers to the entity
@ -3817,11 +3819,11 @@ package Einfo is
type Entity_Kind is (
E_Void,
-- The initial Ekind value for a newly created entity. Also used as
-- the Ekind for Standard_Void_Type, a type entity in Standard used
-- as a dummy type for the return type of a procedure (the reason we
-- create this type is to share the circuits for performing overload
-- resolution on calls).
-- The initial Ekind value for a newly created entity. Also used as the
-- Ekind for Standard_Void_Type, a type entity in Standard used as a
-- dummy type for the return type of a procedure (the reason we create
-- this type is to share the circuits for performing overload resolution
-- on calls).
-------------
-- Objects --

View File

@ -3846,6 +3846,28 @@ package body Freeze is
elsif Is_Access_Type (E) then
-- If a pragma Default_Storage_Pool applies, and this type has no
-- Storage_Pool or Storage_Size clause (which must have occurred
-- before the freezing point), then use the default. This applies
-- only to base types.
if Present (Default_Pool)
and then E = Base_Type (E)
and then not Has_Storage_Size_Clause (E)
and then No (Associated_Storage_Pool (E))
then
-- Case of pragma Default_Storage_Pool (null)
if Nkind (Default_Pool) = N_Null then
Set_No_Pool_Assigned (E);
-- Case of pragma Default_Storage_Pool (storage_pool_NAME)
else
Set_Associated_Storage_Pool (E, Entity (Default_Pool));
end if;
end if;
-- Check restriction for standard storage pool
if No (Associated_Storage_Pool (E)) then

View File

@ -11541,6 +11541,7 @@ recognized by GNAT:
Convention_Identifier
Debug_Policy
Detect_Blocking
Default_Storage_Pool
Discard_Names
Elaboration_Checks
Eliminate

View File

@ -8464,13 +8464,13 @@ package body Make is
Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
Name : String (1 .. Source_File_Name'Length + 3);
Last : Positive := Source_File_Name'Length;
Spec_Suffix : constant String :=
Get_Name_String (Naming.Spec_Suffix);
Body_Suffix : constant String :=
Get_Name_String (Naming.Body_Suffix);
Truncated : Boolean := False;
Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix);
Body_Suffix : String := Get_Name_String (Naming.Body_Suffix);
Truncated : Boolean := False;
begin
Canonical_Case_File_Name (Spec_Suffix);
Canonical_Case_File_Name (Body_Suffix);
Name (1 .. Last) := Source_File_Name;
if Last > Body_Suffix'Length

View File

@ -50,6 +50,7 @@ package body Opt is
Assume_No_Invalid_Values_Config := Assume_No_Invalid_Values;
Check_Policy_List_Config := Check_Policy_List;
Debug_Pragmas_Enabled_Config := Debug_Pragmas_Enabled;
Default_Pool_Config := Default_Pool;
Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed;
Extensions_Allowed_Config := Extensions_Allowed;
@ -83,6 +84,7 @@ package body Opt is
Assume_No_Invalid_Values := Save.Assume_No_Invalid_Values;
Check_Policy_List := Save.Check_Policy_List;
Debug_Pragmas_Enabled := Save.Debug_Pragmas_Enabled;
Default_Pool := Save.Default_Pool;
Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed;
Extensions_Allowed := Save.Extensions_Allowed;
@ -111,6 +113,7 @@ package body Opt is
Save.Assume_No_Invalid_Values := Assume_No_Invalid_Values;
Save.Check_Policy_List := Check_Policy_List;
Save.Debug_Pragmas_Enabled := Debug_Pragmas_Enabled;
Save.Default_Pool := Default_Pool;
Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks;
Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed;
Save.Extensions_Allowed := Extensions_Allowed;
@ -192,6 +195,7 @@ package body Opt is
Use_VADS_Size := Use_VADS_Size_Config;
end if;
Default_Pool := Default_Pool_Config;
Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config;
Fast_Math := Fast_Math_Config;
Optimize_Alignment := Optimize_Alignment_Config;
@ -227,6 +231,7 @@ package body Opt is
Tree_Read_Bool (Assertions_Enabled);
Tree_Read_Int (Int (Check_Policy_List));
Tree_Read_Bool (Debug_Pragmas_Enabled);
Tree_Read_Int (Int (Default_Pool));
Tree_Read_Bool (Enable_Overflow_Checks);
Tree_Read_Bool (Full_List);
@ -292,6 +297,7 @@ package body Opt is
Tree_Write_Bool (Assertions_Enabled);
Tree_Write_Int (Int (Check_Policy_List));
Tree_Write_Bool (Debug_Pragmas_Enabled);
Tree_Write_Int (Int (Default_Pool));
Tree_Write_Bool (Enable_Overflow_Checks);
Tree_Write_Bool (Full_List);
Tree_Write_Int (Int (Version_String'Length));

View File

@ -359,6 +359,16 @@ package Opt is
-- default was set by the binder, and that the default should be the
-- initial value of System.Secondary_Stack.Default_Secondary_Stack_Size.
Default_Pool : Node_Id := Empty;
-- GNAT
-- Used to record the storage pool name (or null literal) that is the
-- argument of an applicable pragma Default_Storage_Pool.
-- Empty: No pragma Default_Storage_Pool applies.
-- N_Null node: "pragma Default_Storage_Pool (null);" applies.
-- otherwise: "pragma Default_Storage_Pool (X);" applies, and
-- this points to the name X.
-- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this.
Detect_Blocking : Boolean := False;
-- GNAT
-- Set True to force the run time to raise Program_Error if calls to
@ -1585,6 +1595,11 @@ package Opt is
-- mode, as possibly set by the command line switch -gnata and possibly
-- modified by the use of the configuration pragma Debug_Policy.
Default_Pool_Config : Node_Id := Empty;
-- GNAT
-- Same as Default_Pool above, except this is only for Default_Storage_Pool
-- pragmas that are configuration pragmas.
Dynamic_Elaboration_Checks_Config : Boolean := False;
-- GNAT
-- Set True for dynamic elaboration checking mode, as set by the -gnatE
@ -1793,6 +1808,7 @@ private
Assume_No_Invalid_Values : Boolean;
Check_Policy_List : Node_Id;
Debug_Pragmas_Enabled : Boolean;
Default_Pool : Node_Id;
Dynamic_Elaboration_Checks : Boolean;
Exception_Locations_Suppressed : Boolean;
Extensions_Allowed : Boolean;

View File

@ -1129,6 +1129,7 @@ begin
Pragma_Convention |
Pragma_Debug_Policy |
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
Pragma_Dimension |
Pragma_Discard_Names |
Pragma_Eliminate |

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- --
@ -462,6 +462,9 @@ package Sem is
Save_Check_Policy_List : Node_Id;
-- Save contents of Check_Policy_List on entry to restore on exit
Save_Default_Storage_Pool : Node_Id;
-- Save contents of Default_Storage_Pool on entry to restore on exit
Is_Transient : Boolean;
-- Marks transient scopes (see Exp_Ch7 body for details)

View File

@ -6636,18 +6636,36 @@ package body Sem_Ch8 is
procedure Pop_Scope is
SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
S : constant Entity_Id := SST.Entity;
begin
if Debug_Flag_E then
Write_Info;
end if;
-- Set Default_Storage_Pool field of the library unit if necessary
if Ekind_In (S, E_Package, E_Generic_Package)
and then
Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit
then
declare
Aux : constant Node_Id :=
Aux_Decls_Node (Parent (Unit_Declaration_Node (S)));
begin
if No (Default_Storage_Pool (Aux)) then
Set_Default_Storage_Pool (Aux, Default_Pool);
end if;
end;
end if;
Scope_Suppress := SST.Save_Scope_Suppress;
Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top;
Check_Policy_List := SST.Save_Check_Policy_List;
Default_Pool := SST.Save_Default_Storage_Pool;
if Debug_Flag_W then
Write_Str ("--> exiting scope: ");
Write_Str ("<-- exiting scope: ");
Write_Name (Chars (Current_Scope));
Write_Str (", Depth=");
Write_Int (Int (Scope_Stack.Last));
@ -6679,7 +6697,7 @@ package body Sem_Ch8 is
---------------
procedure Push_Scope (S : Entity_Id) is
E : Entity_Id;
E : constant Entity_Id := Scope (S);
begin
if Ekind (S) = E_Void then
@ -6717,6 +6735,7 @@ package body Sem_Ch8 is
SST.Save_Scope_Suppress := Scope_Suppress;
SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top;
SST.Save_Check_Policy_List := Check_Policy_List;
SST.Save_Default_Storage_Pool := Default_Pool;
if Scope_Stack.Last > Scope_Stack.First then
SST.Component_Alignment_Default := Scope_Stack.Table
@ -6753,8 +6772,6 @@ package body Sem_Ch8 is
and then Scope (S) /= Standard_Standard
and then not Is_Child_Unit (S)
then
E := Scope (S);
if Nkind (E) not in N_Entity then
return;
end if;
@ -6776,6 +6793,22 @@ package body Sem_Ch8 is
Set_Categorization_From_Scope (E => S, Scop => E);
end if;
end if;
if Is_Child_Unit (S)
and then Present (E)
and then Ekind_In (E, E_Package, E_Generic_Package)
and then
Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
then
declare
Aux : constant Node_Id :=
Aux_Decls_Node (Parent (Unit_Declaration_Node (E)));
begin
if Present (Default_Storage_Pool (Aux)) then
Default_Pool := Default_Storage_Pool (Aux);
end if;
end;
end if;
end Push_Scope;
---------------------

View File

@ -7112,6 +7112,54 @@ package body Sem_Prag is
Check_Valid_Configuration_Pragma;
Detect_Blocking := True;
--------------------------
-- Default_Storage_Pool --
--------------------------
-- pragma Default_Storage_Pool (storage_pool_NAME | null);
when Pragma_Default_Storage_Pool =>
Ada_2012_Pragma;
Check_Arg_Count (1);
-- Default_Storage_Pool can appear as a configuration pragma, or
-- in a declarative part or a package spec.
if not Is_Configuration_Pragma then
Check_Is_In_Decl_Part_Or_Package_Spec;
end if;
-- Case of Default_Storage_Pool (null);
if Nkind (Expression (Arg1)) = N_Null then
Analyze (Expression (Arg1));
Set_Etype (Expression (Arg1), Empty);
-- It's not really an expression, and we have no type for it
-- Case of Default_Storage_Pool (storage_pool_NAME);
else
-- If it's a configuration pragma, then the only allowed
-- argument is "null".
if Is_Configuration_Pragma then
Error_Pragma_Arg ("NULL expected", Arg1);
end if;
-- The expected type for a non-"null" argument is
-- Root_Storage_Pool'Class.
Analyze_And_Resolve
(Get_Pragma_Arg (Arg1),
Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
end if;
-- Finally, record the pool name (or null). Freeze.Freeze_Entity
-- for an access type will use this information to set the
-- appropriate attributes of the access type.
Default_Pool := Expression (Arg1);
---------------
-- Dimension --
---------------
@ -13615,6 +13663,7 @@ package body Sem_Prag is
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
Pragma_Discard_Names => 0,
Pragma_Elaborate => -1,

View File

@ -707,6 +707,14 @@ package body Sinfo is
return Node5 (N);
end Default_Expression;
function Default_Storage_Pool
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Compilation_Unit_Aux);
return Node3 (N);
end Default_Storage_Pool;
function Default_Name
(N : Node_Id) return Node_Id is
begin
@ -3694,6 +3702,14 @@ package body Sinfo is
Set_Node5 (N, Val); -- semantic field, no parent set
end Set_Default_Expression;
procedure Set_Default_Storage_Pool
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Compilation_Unit_Aux);
Set_Node3 (N, Val); -- semantic field, no parent set
end Set_Default_Storage_Pool;
procedure Set_Default_Name
(N : Node_Id; Val : Node_Id) is
begin

View File

@ -59,15 +59,19 @@ package Sinfo is
-- If changes are made to this file, a number of related steps must be
-- carried out to ensure consistency. First, if a field access function is
-- added, it appears in seven places:
-- added, it appears in these places:
-- The documentation associated with the node
-- The spec of the access function in sinfo.ads
-- The body of the access function in sinfo.adb
-- The pragma Inline at the end of sinfo.ads for the access function
-- The spec of the set procedure in sinfo.ads
-- The body of the set procedure in sinfo.adb
-- The pragma Inline at the end of sinfo.ads for the set procedure
-- In sinfo.ads:
-- The documentation associated with the field (if semantic)
-- The documentation associated with the node
-- The spec of the access function
-- The spec of the set procedure
-- The entries in Is_Syntactic_Field
-- The pragma Inline for the access function
-- The pragma Inline for the set procedure
-- In sinfo.adb:
-- The body of the access function
-- The body of the set procedure
-- The field chosen must be consistent in all places, and, for a node that
-- is a subexpression, must not overlap any of the standard expression
@ -805,6 +809,12 @@ package Sinfo is
-- for the default expression). Default_Expression is used for
-- conformance checking.
-- Default_Storage_Pool (Node3-Sem)
-- This field is present in N_Compilation_Unit_Aux nodes. It is set to a
-- copy of Opt.Default_Pool at the end of the compilation unit. See
-- package Opt for details. This is used for inheriting the
-- Default_Storage_Pool in child units.
-- Discr_Check_Funcs_Built (Flag11-Sem)
-- This flag is present in N_Full_Type_Declaration nodes. It is set when
-- discriminant checking functions are constructed. The purpose is to
@ -5557,8 +5567,8 @@ package Sinfo is
-- the library item.
-- To deal with all these problems, we create an auxiliary node for
-- a compilation unit, referenced from the N_Compilation_Unit node
-- that contains these three items.
-- a compilation unit, referenced from the N_Compilation_Unit node,
-- that contains these items.
-- N_Compilation_Unit
-- Sloc points to first token of defining unit name
@ -5580,6 +5590,7 @@ package Sinfo is
-- Actions (List1) (set to No_List if no actions)
-- Pragmas_After (List5) pragmas after unit (set to No_List if none)
-- Config_Pragmas (List4) config pragmas (set to Empty_List if none)
-- Default_Storage_Pool (Node3-Sem)
--------------------------
-- 10.1.1 Library Item --
@ -8095,6 +8106,9 @@ package Sinfo is
function Default_Expression
(N : Node_Id) return Node_Id; -- Node5
function Default_Storage_Pool
(N : Node_Id) return Node_Id; -- Node3
function Default_Name
(N : Node_Id) return Node_Id; -- Node2
@ -9049,6 +9063,9 @@ package Sinfo is
procedure Set_Default_Expression
(N : Node_Id; Val : Node_Id); -- Node5
procedure Set_Default_Storage_Pool
(N : Node_Id; Val : Node_Id); -- Node3
procedure Set_Default_Name
(N : Node_Id; Val : Node_Id); -- Node2
@ -10984,7 +11001,7 @@ package Sinfo is
N_Compilation_Unit_Aux =>
(1 => True, -- Actions (List1)
2 => True, -- Declarations (List2)
3 => False, -- unused
3 => False, -- Default_Storage_Pool (Node3)
4 => True, -- Config_Pragmas (List4)
5 => True), -- Pragmas_After (List5)
@ -11566,6 +11583,7 @@ package Sinfo is
pragma Inline (Debug_Statement);
pragma Inline (Declarations);
pragma Inline (Default_Expression);
pragma Inline (Default_Storage_Pool);
pragma Inline (Default_Name);
pragma Inline (Defining_Identifier);
pragma Inline (Defining_Unit_Name);
@ -11881,6 +11899,7 @@ package Sinfo is
pragma Inline (Set_Debug_Statement);
pragma Inline (Set_Declarations);
pragma Inline (Set_Default_Expression);
pragma Inline (Set_Default_Storage_Pool);
pragma Inline (Set_Default_Name);
pragma Inline (Set_Defining_Identifier);
pragma Inline (Set_Defining_Unit_Name);

View File

@ -361,6 +361,7 @@ package Snames is
Name_Convention_Identifier : constant Name_Id := N + $; -- GNAT
Name_Debug_Policy : constant Name_Id := N + $; -- GNAT
Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05
Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12
Name_Discard_Names : constant Name_Id := N + $;
Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT
Name_Eliminate : constant Name_Id := N + $; -- GNAT
@ -1463,6 +1464,7 @@ package Snames is
Pragma_Convention_Identifier,
Pragma_Debug_Policy,
Pragma_Detect_Blocking,
Pragma_Default_Storage_Pool,
Pragma_Discard_Names,
Pragma_Elaboration_Checks,
Pragma_Eliminate,