The pragma Simple_Storage_Pool is provided for designating a library-level
limited private or limited record type as a simple storage pool type.
This provides an alternative to Ada's standard Storage_Pools, where
the pool type is not required to be tagged or have associated finalization
actions, eliminating the need for run-time support. A simple storage pool type
is defined with an Allocate operation, and optionally can have Deallocate
and Storage_Size operations (as well as other user-defined operations).
An access type can be associated with a pool object by setting the
attribute (or aspect) Simple_Storage_Pool. Allocators for the type will
invoke the pool's Allocate procedure, and unchecked deallocation invokes
the Deallocate operation (if defined).
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-02-08 Gary Dismukes <dismu...@adacore.com>
* aspects.ads (type Aspect_Id): Add Aspect_Simple_Storage_Pool.
(Impl_Defined_Aspects): Add entry for Aspect_Simple_Storage_Pool.
(Aspect_Argument): Add Name entry for Aspect_Simple_Storage_Pool.
(Aspect_Names): Add entry for Aspect_Simple_Storage_Pool.
* aspects.adb (Canonical_Aspect): Add entry for
Aspect_Simple_Storage_Pool.
* exp_attr.adb (Expand_N_Attribute_Reference): Handle case of
Attribute_Simple_Storage_Pool in the same way as Storage_Pool
(add conversion, analyze/resolve). For the Storage_Size attribute,
for the simple pool case, locate and use the simple pool type's
Storage_Size function (if any), otherwise evaluate to zero.
* exp_ch4.adb (Expand_N_Allocator): In the case of an allocator
for an access type with an associated simple storage pool,
locate and use the pool type's Allocate.
* exp_intr.adb (Expand_Unc_Deallocation): In the case where the
access type has a simple storage pool, locate the pool type's
Deallocate procedure (if present) and use it as the procedure
to call on the Free operation.
* freeze.adb (Freeze_Entity): In the case of a full type for
a private type defined with pragma Simple_Storage_Pool, check
that the full type is also appropriate for the pragma. For
a simple storage pool type, validate that the operations
Allocate, Deallocate (if present), and Storage_Size
(if present) are defined with appropriate expected profiles.
(Validate_Simple_Pool_Op_Formal): New procedure
(Validate_Simple_Pool_Operation): New procedure Add with and
use of Rtsfind.
* par-prag.adb: Add Pragma_Simple_Storage_Pool to case statement
(no action required).
* sem_attr.adb (Analyze_Attribute): For the case of the
Storage_Pool attribute, give a warning if the prefix type has an
associated simple storage pool, and rewrite the attribute as a
raise of Program_Error. In the case of the Simple_Storage_Pool
attribute, check that the prefix type has an associated simple
storage pool, and set the attribute type to the pool's type.
* sem_ch13.adb (Analyze_Aspect_Specifications): Add
Aspect_Simple_Storage_Pool case choice.
(Analyze_Attribute_Definition_Clause): Add
Aspect_Simple_Storage_Pool to case for Ignore_Rep_Clauses
(no action). Add handling for Simple_Storage_Pool attribute
definition, requiring the name to denote a simple storage pool
object.
(Check_Aspect_At_Freeze_Point): For a simple storage pool
aspect, set the type to that of the name specified for the aspect.
* sem_prag.adb (Analyze_Pragma): Add handling for pragma
Simple_Storage_Pool, requiring that it applies to a library-level
type declared in a package declaration that is a limited private
or limited record type.
* sem_res.adb (Resolve_Allocator): Flag an attempt to call a
build-in-place function in an allocator for an access type with
a simple storage pool as unsupported.
* snames.ads-tmpl: Add Name_Simple_Storage_Pool.
(type Attribute_Id): Add Attribute_Simple_Storage_Pool.
(type Pragma_Id): Add Pragma_Simple_Storage_Pool.
* snames.adb-tmpl (Get_Pragma_Id): Handle case of
Name_Simple_Storage_Pool.
(Is_Pragma_Name): Return True for Name_Simple_Storage_Pool.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 183996)
+++ exp_attr.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
@@ -4217,6 +4217,17 @@
when Attribute_Scaling =>
Expand_Fpt_Attribute_RI (N);
+ -------------------------
+ -- Simple_Storage_Pool --
+ -------------------------
+
+ when Attribute_Simple_Storage_Pool =>
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Reference_To (Etype (N), Loc),
+ Expression => New_Reference_To (Entity (N), Loc)));
+ Analyze_And_Resolve (N, Typ);
+
----------
-- Size --
----------
@@ -4475,8 +4486,11 @@
-- Storage_Size --
------------------
- when Attribute_Storage_Size => Storage_Size : begin
+ when Attribute_Storage_Size => Storage_Size : declare
+ Alloc_Op : Entity_Id := Empty;
+ begin
+
-- Access type case, always go to the root type
-- The case of access types results in a value of zero for the case
@@ -4497,20 +4511,65 @@
(Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
- Rewrite (N,
- OK_Convert_To (Typ,
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To
- (Find_Prim_Op
- (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
- Attribute_Name (N)),
- Loc),
- Parameter_Associations => New_List (
- New_Reference_To
- (Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
+ -- If the access type is associated with a simple storage pool
+ -- object, then attempt to locate the optional Storage_Size
+ -- function of the simple storage pool type. If not found,
+ -- then the result will default to zero.
+ if Present (Get_Rep_Pragma (Root_Type (Ptyp),
+ Name_Simple_Storage_Pool))
+ then
+ declare
+ Pool_Type : constant Entity_Id :=
+ Base_Type (Etype (Entity (N)));
+
+ begin
+ Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
+ while Present (Alloc_Op) loop
+ if Scope (Alloc_Op) = Scope (Pool_Type)
+ and then Present (First_Formal (Alloc_Op))
+ and then Etype (First_Formal (Alloc_Op)) = Pool_Type
+ then
+ exit;
+ end if;
+
+ Alloc_Op := Homonym (Alloc_Op);
+ end loop;
+ end;
+
+ -- In the normal Storage_Pool case, retrieve the primitive
+ -- function associated with the pool type.
+
+ else
+ Alloc_Op :=
+ Find_Prim_Op
+ (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
+ Attribute_Name (N));
+ end if;
+
+ -- If Storage_Size wasn't found (can only occur in the simple
+ -- storage pool case), then simply use zero for the result.
+
+ if not Present (Alloc_Op) then
+ Rewrite (N, Make_Integer_Literal (Loc, 0));
+
+ -- Otherwise, rewrite the allocator as a call to pool type's
+ -- Storage_Size function.
+
+ else
+ Rewrite (N,
+ OK_Convert_To (Typ,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (Alloc_Op, Loc),
+
+ Parameter_Associations => New_List (
+ New_Reference_To
+ (Associated_Storage_Pool
+ (Root_Type (Ptyp)), Loc)))));
+ end if;
+
else
Rewrite (N, Make_Integer_Literal (Loc, 0));
end if;
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 183996)
+++ sem_prag.adb (working copy)
@@ -13150,6 +13150,65 @@
Check_Valid_Configuration_Pragma;
Short_Descriptors := True;
+ -------------------------
+ -- Simple_Storage_Pool --
+ -------------------------
+
+ -- pragma Simple_Storage_Pool (type_LOCAL_NAME);
+
+ when Pragma_Simple_Storage_Pool => Simple_Storage_Pool : declare
+ Type_Id : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Library_Level_Local_Name (Arg1);
+
+ Type_Id := Get_Pragma_Arg (Arg1);
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type then
+ return;
+ end if;
+
+ -- We require the pragma to apply to a type declared in a package
+ -- declaration, but not (immediately) within a package body.
+
+ if Ekind (Current_Scope) /= E_Package
+ or else In_Package_Body (Current_Scope)
+ then
+ Error_Pragma
+ ("pragma% can only apply to type declared immediately " &
+ "within a package declaration");
+ end if;
+
+ -- A simple storage pool type must be an immutably limited record
+ -- or private type. If the pragma is given for a private type,
+ -- the full type is similarly restricted (which is checked later
+ -- in Freeze_Entity).
+
+ if Is_Record_Type (Typ)
+ and then not Is_Immutably_Limited_Type (Typ)
+ then
+ Error_Pragma
+ ("pragma% can only apply to explicitly limited record type");
+
+ elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
+ Error_Pragma
+ ("pragma% can only apply to a private type that is limited");
+
+ elsif not Is_Record_Type (Typ)
+ and then not Is_Private_Type (Typ)
+ then
+ Error_Pragma
+ ("pragma% can only apply to limited record or private type");
+ end if;
+
+ Record_Rep_Item (Typ, N);
+ end Simple_Storage_Pool;
+
----------------------
-- Source_File_Name --
----------------------
@@ -15117,6 +15176,7 @@
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Short_Descriptors => 0,
+ Pragma_Simple_Storage_Pool => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
Index: freeze.adb
===================================================================
--- freeze.adb (revision 183996)
+++ freeze.adb (working copy)
@@ -42,6 +42,7 @@
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
@@ -4103,6 +4104,281 @@
end loop;
end;
end if;
+
+ -- If the type is a simple storage pool type, then this is where
+ -- we attempt to locate and validate its Allocate, Deallocate, and
+ -- Storage_Size operations (the first is required, and the latter
+ -- two are optional). We also verify that the full type for a
+ -- private type is allowed to be a simple storage pool type.
+
+ if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool))
+ and then (Is_Base_Type (E) or else Has_Private_Declaration (E))
+ then
+
+ -- If the type is marked Has_Private_Declaration, then this is
+ -- a full type for a private type that was specified with the
+ -- pragma Simple_Storage_Pool, and here we ensure that the
+ -- pragma is allowed for the full type (for example, it can't
+ -- be an array type, or a nonlimited record type).
+
+ if Has_Private_Declaration (E) then
+ if (not Is_Record_Type (E)
+ or else not Is_Immutably_Limited_Type (E))
+ and then not Is_Private_Type (E)
+ then
+ Error_Msg_Name_1 := Name_Simple_Storage_Pool;
+
+ Error_Msg_N
+ ("pragma% can only apply to full type that is an " &
+ "explicitly limited type", E);
+ end if;
+ end if;
+
+ Validate_Simple_Pool_Ops : declare
+ Pool_Type : Entity_Id renames E;
+ Address_Type : constant Entity_Id := RTE (RE_Address);
+ Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count);
+
+ procedure Validate_Simple_Pool_Op_Formal
+ (Pool_Op : Entity_Id;
+ Pool_Op_Formal : in out Entity_Id;
+ Expected_Mode : Formal_Kind;
+ Expected_Type : Entity_Id;
+ Formal_Name : String;
+ OK_Formal : in out Boolean);
+ -- Validate one formal Pool_Op_Formal of the candidate pool
+ -- operation Pool_Op. The formal must be of Expected_Type
+ -- and have mode Expected_Mode. OK_Formal will be set to
+ -- False if the formal doesn't match. If OK_Formal is False
+ -- on entry, then the formal will effectively be ignored
+ -- (because validation of the pool op has already failed).
+ -- Upon return, Pool_Op_Formal will be updated to the next
+ -- formal, if any.
+
+ procedure Validate_Simple_Pool_Operation (Op_Name : Name_Id);
+ -- Search for and validate a simple pool operation with the
+ -- name Op_Name. If the name is Allocate, then there must be
+ -- exactly one such primitive operation for the simple pool
+ -- type. If the name is Deallocate or Storage_Size, then
+ -- there can be at most one such primitive operation. The
+ -- profile of the located primitive must conform to what
+ -- is expected for each operation.
+
+ ------------------------------------
+ -- Validate_Simple_Pool_Op_Formal --
+ ------------------------------------
+
+ procedure Validate_Simple_Pool_Op_Formal
+ (Pool_Op : Entity_Id;
+ Pool_Op_Formal : in out Entity_Id;
+ Expected_Mode : Formal_Kind;
+ Expected_Type : Entity_Id;
+ Formal_Name : String;
+ OK_Formal : in out Boolean)
+ is
+ begin
+ -- If OK_Formal is False on entry, then simply ignore
+ -- the formal, because an earlier formal has already
+ -- been flagged.
+
+ if not OK_Formal then
+ return;
+
+ -- If no formal is passed in, then issue an error for a
+ -- missing formal.
+
+ elsif not Present (Pool_Op_Formal) then
+ Error_Msg_NE
+ ("simple storage pool op missing formal " &
+ Formal_Name & " of type&", Pool_Op, Expected_Type);
+ OK_Formal := False;
+
+ return;
+ end if;
+
+ if Etype (Pool_Op_Formal) /= Expected_Type then
+ -- If the pool type was expected for this formal, then
+ -- this will not be considered a candidate operation
+ -- for the simple pool, so we unset OK_Formal so that
+ -- the op and any later formals will be ignored.
+
+ if Expected_Type = Pool_Type then
+ OK_Formal := False;
+
+ return;
+
+ else
+ Error_Msg_NE
+ ("wrong type for formal " & Formal_Name &
+ " of simple storage pool op; expected type&",
+ Pool_Op_Formal, Expected_Type);
+ end if;
+ end if;
+
+ -- Issue error if formal's mode is not the expected one
+
+ if Ekind (Pool_Op_Formal) /= Expected_Mode then
+ Error_Msg_N
+ ("wrong mode for formal of simple storage pool op",
+ Pool_Op_Formal);
+ end if;
+
+ -- Advance to the next formal
+
+ Next_Formal (Pool_Op_Formal);
+ end Validate_Simple_Pool_Op_Formal;
+
+ ------------------------------------
+ -- Validate_Simple_Pool_Operation --
+ ------------------------------------
+
+ procedure Validate_Simple_Pool_Operation
+ (Op_Name : Name_Id)
+ is
+ Op : Entity_Id;
+ Found_Op : Entity_Id := Empty;
+ Formal : Entity_Id;
+ Is_OK : Boolean;
+
+ begin
+ pragma Assert
+ (Op_Name = Name_Allocate
+ or else Op_Name = Name_Deallocate
+ or else Op_Name = Name_Storage_Size);
+
+ Error_Msg_Name_1 := Op_Name;
+
+ -- For each homonym declared immediately in the scope
+ -- of the simple storage pool type, determine whether
+ -- the homonym is an operation of the pool type, and,
+ -- if so, check that its profile is as expected for
+ -- a simple pool operation of that name.
+
+ Op := Get_Name_Entity_Id (Op_Name);
+ while Present (Op) loop
+ if Ekind_In (Op, E_Function, E_Procedure)
+ and then Scope (Op) = Current_Scope
+ then
+ Formal := First_Entity (Op);
+
+ Is_OK := True;
+
+ -- The first parameter must be of the pool type
+ -- in order for the operation to qualify.
+
+ if Op_Name = Name_Storage_Size then
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Parameter, Pool_Type,
+ "Pool", Is_OK);
+
+ else
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Out_Parameter, Pool_Type,
+ "Pool", Is_OK);
+ end if;
+
+ -- If another operation with this name has already
+ -- been located for the type, then flag an error,
+ -- since we only allow the type to have a single
+ -- such primitive.
+
+ if Present (Found_Op) and then Is_OK then
+ Error_Msg_NE
+ ("only one % operation allowed for " &
+ "simple storage pool type&", Op, Pool_Type);
+ end if;
+
+ -- In the case of Allocate and Deallocate, a formal
+ -- of type System.Address is required.
+
+ if Op_Name = Name_Allocate then
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_Out_Parameter,
+ Address_Type, "Storage_Address", Is_OK);
+
+ elsif Op_Name = Name_Deallocate then
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Parameter,
+ Address_Type, "Storage_Address", Is_OK);
+ end if;
+
+ -- In the case of Allocate and Deallocate, formals
+ -- of type Storage_Count are required as the third
+ -- and fourth parameters.
+
+ if Op_Name /= Name_Storage_Size then
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Parameter,
+ Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK);
+
+ Validate_Simple_Pool_Op_Formal
+ (Op, Formal, E_In_Parameter,
+ Stg_Cnt_Type, "Alignment", Is_OK);
+ end if;
+
+ -- If no mismatched formals have been found (Is_OK)
+ -- and no excess formals are present, then this
+ -- operation has been validated, so record it.
+
+ if not Present (Formal) and then Is_OK then
+ Found_Op := Op;
+ end if;
+ end if;
+
+ Op := Homonym (Op);
+ end loop;
+
+ -- There must be a valid Allocate operation for the type,
+ -- so issue an error if none was found.
+
+ if Op_Name = Name_Allocate
+ and then not Present (Found_Op)
+ then
+ Error_Msg_N ("missing % operation for simple " &
+ "storage pool type", Pool_Type);
+
+ elsif Present (Found_Op) then
+ -- Simple pool operations can't be abstract
+
+ if Is_Abstract_Subprogram (Found_Op) then
+ Error_Msg_N
+ ("simple storage pool operation must not be " &
+ "abstract", Found_Op);
+ end if;
+
+ -- The Storage_Size operation must be a function with
+ -- Storage_Count as its result type.
+
+ if Op_Name = Name_Storage_Size then
+ if Ekind (Found_Op) = E_Procedure then
+ Error_Msg_N
+ ("% operation must be a function", Found_Op);
+
+ elsif Etype (Found_Op) /= Stg_Cnt_Type then
+ Error_Msg_NE
+ ("wrong result type for%, expected type&",
+ Found_Op, Stg_Cnt_Type);
+ end if;
+
+ -- Allocate and Deallocate must be procedures
+
+ elsif Ekind (Found_Op) = E_Function then
+ Error_Msg_N
+ ("% operation must be a procedure", Found_Op);
+ end if;
+ end if;
+ end Validate_Simple_Pool_Operation;
+
+ -- Start of processing for Validate_Simple_Pool_Ops
+
+ begin
+ Validate_Simple_Pool_Operation (Name_Allocate);
+
+ Validate_Simple_Pool_Operation (Name_Deallocate);
+
+ Validate_Simple_Pool_Operation (Name_Storage_Size);
+ end Validate_Simple_Pool_Ops;
+ end if;
end if;
-- Now that all types from which E may depend are frozen, see if the
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 183996)
+++ sem_res.adb (working copy)
@@ -4228,6 +4228,31 @@
Wrong_Type (Expression (E), Etype (E));
end if;
+ -- Calls to build-in-place functions are not currently supported in
+ -- allocators for access types associated with a simple storage pool.
+ -- Supporting such allocators may require passing additional implicit
+ -- parameters to build-in-place functions (or a significant revision
+ -- of the current b-i-p implementation to unify the handling for
+ -- multiple kinds of storage pools). ???
+
+ if Is_Immutably_Limited_Type (Desig_T)
+ and then Nkind (Expression (E)) = N_Function_Call
+ then
+ declare
+ Pool : constant Entity_Id
+ := Associated_Storage_Pool (Root_Type (Typ));
+ begin
+ if Present (Pool)
+ and then Present (Get_Rep_Pragma
+ (Etype (Pool), Name_Simple_Storage_Pool))
+ then
+ Error_Msg_N
+ ("limited function calls not yet supported in simple " &
+ "storage pool allocators", Expression (E));
+ end if;
+ end;
+ end if;
+
-- A special accessibility check is needed for allocators that
-- constrain access discriminants. The level of the type of the
-- expression used to constrain an access discriminant cannot be
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 183996)
+++ sem_attr.adb (working copy)
@@ -4528,7 +4528,8 @@
-- Storage_Pool --
------------------
- when Attribute_Storage_Pool => Storage_Pool :
+ when Attribute_Storage_Pool |
+ Attribute_Simple_Storage_Pool => Storage_Pool :
begin
Check_E0;
@@ -4546,8 +4547,39 @@
Set_Entity (N, RTE (RE_Global_Pool_Object));
end if;
- Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+ if Attr_Id = Attribute_Storage_Pool then
+ if Present (Get_Rep_Pragma (Etype (Entity (N)),
+ Name_Simple_Storage_Pool))
+ then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N ("cannot use % attribute for type with simple " &
+ "storage pool?", N);
+ Error_Msg_N
+ ("\Program_Error will be raised at run time?", N);
+ Rewrite
+ (N, Make_Raise_Program_Error
+ (Sloc (N), Reason => PE_Explicit_Raise));
+ end if;
+
+ Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+ -- In the Simple_Storage_Pool case, verify that the pool entity is
+ -- actually of a simple storage pool type, and set the attribute's
+ -- type to the pool object's type.
+
+ else
+ if not Present (Get_Rep_Pragma (Etype (Entity (N)),
+ Name_Simple_Storage_Pool))
+ then
+ Error_Attr_P
+ ("cannot use % attribute for type without simple " &
+ "storage pool");
+ end if;
+
+ Set_Etype (N, Etype (Entity (N)));
+ end if;
+
-- Validate_Remote_Access_To_Class_Wide_Type for attribute
-- Storage_Pool since this attribute is not defined for such
-- types (RM E.2.3(22)).
@@ -7931,6 +7963,7 @@
Attribute_Priority |
Attribute_Read |
Attribute_Result |
+ Attribute_Simple_Storage_Pool |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 183996)
+++ exp_ch4.adb (working copy)
@@ -3565,6 +3565,31 @@
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
+ -- In the case of an allocator for a simple storage pool, locate
+ -- and save a reference to the pool type's Allocate routine.
+
+ elsif Present (Get_Rep_Pragma
+ (Etype (Pool), Name_Simple_Storage_Pool))
+ then
+ declare
+ Alloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Allocate);
+ Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
+
+ begin
+ while Present (Alloc_Op) loop
+ if Scope (Alloc_Op) = Scope (Pool_Type)
+ and then Present (First_Formal (Alloc_Op))
+ and then Etype (First_Formal (Alloc_Op)) = Pool_Type
+ then
+ Set_Procedure_To_Call (N, Alloc_Op);
+
+ exit;
+ end if;
+
+ Alloc_Op := Homonym (Alloc_Op);
+ end loop;
+ end;
+
elsif Is_Class_Wide_Type (Etype (Pool)) then
Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
Index: aspects.adb
===================================================================
--- aspects.adb (revision 183996)
+++ aspects.adb (working copy)
@@ -298,6 +298,7 @@
Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,
Aspect_Read => Aspect_Read,
Aspect_Shared => Aspect_Atomic,
+ Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
Aspect_Size => Aspect_Size,
Aspect_Small => Aspect_Small,
Aspect_Static_Predicate => Aspect_Predicate,
Index: aspects.ads
===================================================================
--- aspects.ads (revision 183996)
+++ aspects.ads (working copy)
@@ -74,6 +74,7 @@
Aspect_Predicate, -- GNAT
Aspect_Priority,
Aspect_Read,
+ Aspect_Simple_Storage_Pool, -- GNAT
Aspect_Size,
Aspect_Small,
Aspect_Static_Predicate,
@@ -186,6 +187,7 @@
Aspect_Pure_Function => True,
Aspect_Remote_Access_Type => True,
Aspect_Shared => True,
+ Aspect_Simple_Storage_Pool => True,
Aspect_Suppress_Debug_Info => True,
Aspect_Test_Case => True,
Aspect_Universal_Data => True,
@@ -277,6 +279,7 @@
Aspect_Predicate => Expression,
Aspect_Priority => Expression,
Aspect_Read => Name,
+ Aspect_Simple_Storage_Pool => Name,
Aspect_Size => Expression,
Aspect_Small => Expression,
Aspect_Static_Predicate => Expression,
@@ -364,6 +367,7 @@
Aspect_Remote_Types => Name_Remote_Types,
Aspect_Shared => Name_Shared,
Aspect_Shared_Passive => Name_Shared_Passive,
+ Aspect_Simple_Storage_Pool => Name_Simple_Storage_Pool,
Aspect_Size => Name_Size,
Aspect_Small => Name_Small,
Aspect_Static_Predicate => Name_Static_Predicate,
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 183996)
+++ par-prag.adb (working copy)
@@ -1230,6 +1230,7 @@
Pragma_Shared_Passive |
Pragma_Short_Circuit_And_Or |
Pragma_Short_Descriptors |
+ Pragma_Simple_Storage_Pool |
Pragma_Storage_Size |
Pragma_Storage_Unit |
Pragma_Static_Elaboration_Desired |
Index: snames.adb-tmpl
===================================================================
--- snames.adb-tmpl (revision 183996)
+++ snames.adb-tmpl (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
@@ -217,6 +217,8 @@
return Pragma_Priority;
elsif N = Name_Relative_Deadline then
return Pragma_Relative_Deadline;
+ elsif N = Name_Simple_Storage_Pool then
+ return Pragma_Simple_Storage_Pool;
elsif N = Name_Storage_Size then
return Pragma_Storage_Size;
elsif N = Name_Storage_Unit then
@@ -414,6 +416,7 @@
or else N = Name_Interface
or else N = Name_Relative_Deadline
or else N = Name_Priority
+ or else N = Name_Simple_Storage_Pool
or else N = Name_Storage_Size
or else N = Name_Storage_Unit;
end Is_Pragma_Name;
Index: exp_intr.adb
===================================================================
--- exp_intr.adb (revision 183996)
+++ exp_intr.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
@@ -1084,6 +1084,34 @@
if Is_RTE (Pool, RE_SS_Pool) then
null;
+ -- If the pool object is of a simple storage pool type, then attempt
+ -- to locate the type's Deallocate procedure, if any, and set the
+ -- free operation's procedure to call. If the type doesn't have a
+ -- Deallocate (which is allowed), then the actual will simply be set
+ -- to null.
+
+ elsif Present (Get_Rep_Pragma
+ (Etype (Pool), Name_Simple_Storage_Pool))
+ then
+ declare
+ Dealloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Deallocate);
+ Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
+
+ begin
+ while Present (Dealloc_Op) loop
+ if Scope (Dealloc_Op) = Scope (Pool_Type)
+ and then Present (First_Formal (Dealloc_Op))
+ and then Etype (First_Formal (Dealloc_Op)) = Pool_Type
+ then
+ Set_Procedure_To_Call (Free_Node, Dealloc_Op);
+
+ exit;
+ end if;
+
+ Dealloc_Op := Homonym (Dealloc_Op);
+ end loop;
+ end;
+
-- Case of a class-wide pool type: make a dispatching call to
-- Deallocate through the class-wide Deallocate_Any.
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 183996)
+++ sem_ch13.adb (working copy)
@@ -1064,23 +1064,24 @@
-- Aspects corresponding to attribute definition clauses
- when Aspect_Address |
- Aspect_Alignment |
- Aspect_Bit_Order |
- Aspect_Component_Size |
- Aspect_External_Tag |
- Aspect_Input |
- Aspect_Machine_Radix |
- Aspect_Object_Size |
- Aspect_Output |
- Aspect_Read |
- Aspect_Size |
- Aspect_Small |
- Aspect_Storage_Pool |
- Aspect_Storage_Size |
- Aspect_Stream_Size |
- Aspect_Value_Size |
- Aspect_Write =>
+ when Aspect_Address |
+ Aspect_Alignment |
+ Aspect_Bit_Order |
+ Aspect_Component_Size |
+ Aspect_External_Tag |
+ Aspect_Input |
+ Aspect_Machine_Radix |
+ Aspect_Object_Size |
+ Aspect_Output |
+ Aspect_Read |
+ Aspect_Size |
+ Aspect_Small |
+ Aspect_Simple_Storage_Pool |
+ Aspect_Storage_Pool |
+ Aspect_Storage_Size |
+ Aspect_Stream_Size |
+ Aspect_Value_Size |
+ Aspect_Write =>
-- Construct the attribute definition clause
@@ -2210,13 +2211,14 @@
-- legality, e.g. failing to provide a stream attribute for a
-- type may make a program illegal.
- when Attribute_External_Tag |
- Attribute_Input |
- Attribute_Output |
- Attribute_Read |
- Attribute_Storage_Pool |
- Attribute_Storage_Size |
- Attribute_Write =>
+ when Attribute_External_Tag |
+ Attribute_Input |
+ Attribute_Output |
+ Attribute_Read |
+ Attribute_Simple_Storage_Pool |
+ Attribute_Storage_Pool |
+ Attribute_Storage_Size |
+ Attribute_Write =>
null;
-- Other cases are errors ("attribute& cannot be set with
@@ -3163,7 +3165,7 @@
-- Storage_Pool attribute definition clause
- when Attribute_Storage_Pool => Storage_Pool : declare
+ when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare
Pool : Entity_Id;
T : Entity_Id;
@@ -3194,9 +3196,25 @@
return;
end if;
- Analyze_And_Resolve
- (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+ if Id = Attribute_Storage_Pool then
+ Analyze_And_Resolve
+ (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+ -- In the Simple_Storage_Pool case, we allow a variable of any
+ -- Simple_Storage_Pool type, so we Resolve without imposing an
+ -- expected type.
+
+ else
+ Analyze_And_Resolve (Expr);
+
+ if not Present (Get_Rep_Pragma
+ (Etype (Expr), Name_Simple_Storage_Pool))
+ then
+ Error_Msg_N
+ ("expression must be of a simple storage pool type", Expr);
+ end if;
+ end if;
+
if not Denotes_Variable (Expr) then
Error_Msg_N ("storage pool must be a variable", Expr);
return;
@@ -3280,7 +3298,7 @@
Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
return;
end if;
- end Storage_Pool;
+ end;
------------------
-- Storage_Size --
@@ -6147,6 +6165,13 @@
when Aspect_Small =>
T := Universal_Real;
+ -- For a simple storage pool, we have to retrieve the type of the
+ -- pool object associated with the aspect's corresponding attribute
+ -- definition clause.
+
+ when Aspect_Simple_Storage_Pool =>
+ T := Etype (Expression (Aspect_Rep_Item (ASN)));
+
when Aspect_Storage_Pool =>
T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 183996)
+++ snames.ads-tmpl (working copy)
@@ -909,6 +909,7 @@
Name_Elab_Body : constant Name_Id := N + $; -- GNAT
Name_Elab_Spec : constant Name_Id := N + $; -- GNAT
Name_Elab_Subp_Body : constant Name_Id := N + $; -- GNAT
+ Name_Simple_Storage_Pool : constant Name_Id := N + $; -- GNAT
Name_Storage_Pool : constant Name_Id := N + $;
-- These attributes are the ones that return types
@@ -1459,6 +1460,7 @@
Attribute_Elab_Body,
Attribute_Elab_Spec,
Attribute_Elab_Subp_Body,
+ Attribute_Simple_Storage_Pool,
Attribute_Storage_Pool,
-- Type attributes
@@ -1730,6 +1732,7 @@
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Priority,
+ Pragma_Simple_Storage_Pool,
Pragma_Storage_Size,
Pragma_Storage_Unit,
