+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
-- 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)
-- 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
-- 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
-- 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
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 --
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
Convention_Identifier
Debug_Policy
Detect_Blocking
+ Default_Storage_Pool
Discard_Names
Elaboration_Checks
Eliminate
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
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;
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;
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;
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;
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);
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));
-- 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
-- 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
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;
Pragma_Convention |
Pragma_Debug_Policy |
Pragma_Detect_Blocking |
+ Pragma_Default_Storage_Pool |
Pragma_Dimension |
Pragma_Discard_Names |
Pragma_Eliminate |
-- --
-- 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- --
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)
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));
---------------
procedure Push_Scope (S : Entity_Id) is
- E : Entity_Id;
+ E : constant Entity_Id := Scope (S);
begin
if Ekind (S) = E_Void then
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
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;
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;
---------------------
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 --
---------------
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,
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
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
-- 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:
-
- -- 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
+ -- added, it appears in these places:
+
+ -- 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
-- 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
-- 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
-- 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 --
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
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
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)
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);
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);
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
Pragma_Convention_Identifier,
Pragma_Debug_Policy,
Pragma_Detect_Blocking,
+ Pragma_Default_Storage_Pool,
Pragma_Discard_Names,
Pragma_Elaboration_Checks,
Pragma_Eliminate,
OSDN Git Service
