The functions in subpackage Storage_Model_Support (apart from the
Has_*_Aspect functions) are revised to have assertions that will fail
when passed a parameter that doesn't specify the appropriate aspect
(either aspect Storage_Model_Type or Designated_Storage_Model), instead
of returning Empty for bad arguments. Also, various of the functions now
allow either a type with aspect Storage_Model_Type or an object of such
a type.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* sem_util.ads (Storage_Model_Support): Revise comments on most
operations within this nested package to reflect that they can
now be passed either a type that has aspect Storage_Model_Type
or an object of such a type. Change the names of the relevant
formals to SM_Obj_Or_Type. Also, add more precise semantic
descriptions in some cases, and declare the subprograms in a
more logical order.
* sem_util.adb (Storage_Model_Support.Storage_Model_Object): Add
an assertion that the type must specify aspect
Designated_Storage_Model, rather than returning Empty when it
doesn't specify that aspect.
(Storage_Model_Support.Storage_Model_Type): Add an assertion
that formal must be an object whose type specifies aspect
Storage_Model_Type, rather than returning Empty for when it
doesn't have such a type (and test Has_Storage_Model_Type_Aspect
rather than Find_Value_Of_Aspect).
(Storage_Model_Support.Get_Storage_Model_Type_Entity): Allow
both objects and types, and add an assertion that the type (or
the type of the object) has a value for aspect
Storage_Model_Type.diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -32302,47 +32302,6 @@ package body Sem_Util is
package body Storage_Model_Support is
- -----------------------------------
- -- Get_Storage_Model_Type_Entity --
- -----------------------------------
-
- function Get_Storage_Model_Type_Entity
- (Typ : Entity_Id;
- Nam : Name_Id) return Entity_Id
- is
- pragma Assert
- (Is_Type (Typ)
- and then
- Nam in Name_Address_Type
- | Name_Null_Address
- | Name_Allocate
- | Name_Deallocate
- | Name_Copy_From
- | Name_Copy_To
- | Name_Storage_Size);
-
- SMT_Aspect_Value : constant Node_Id :=
- Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type);
- Assoc : Node_Id;
-
- begin
- if No (SMT_Aspect_Value) then
- return Empty;
-
- else
- Assoc := First (Component_Associations (SMT_Aspect_Value));
- while Present (Assoc) loop
- if Chars (First (Choices (Assoc))) = Nam then
- return Entity (Expression (Assoc));
- end if;
-
- Next (Assoc);
- end loop;
-
- return Empty;
- end if;
- end Get_Storage_Model_Type_Entity;
-
-----------------------------------------
-- Has_Designated_Storage_Model_Aspect --
-----------------------------------------
@@ -32370,13 +32329,11 @@ package body Sem_Util is
function Storage_Model_Object (Typ : Entity_Id) return Entity_Id is
begin
- if Has_Designated_Storage_Model_Aspect (Typ) then
- return
- Entity
- (Find_Value_Of_Aspect (Typ, Aspect_Designated_Storage_Model));
- else
- return Empty;
- end if;
+ pragma Assert (Has_Designated_Storage_Model_Aspect (Typ));
+
+ return
+ Entity
+ (Find_Value_Of_Aspect (Typ, Aspect_Designated_Storage_Model));
end Storage_Model_Object;
------------------------
@@ -32385,76 +32342,132 @@ package body Sem_Util is
function Storage_Model_Type (Obj : Entity_Id) return Entity_Id is
begin
- if Present
- (Find_Value_Of_Aspect (Etype (Obj), Aspect_Storage_Model_Type))
- then
- return Etype (Obj);
- else
- return Empty;
- end if;
+ pragma Assert (Has_Storage_Model_Type_Aspect (Etype (Obj)));
+
+ return Etype (Obj);
end Storage_Model_Type;
+ -----------------------------------
+ -- Get_Storage_Model_Type_Entity --
+ -----------------------------------
+
+ function Get_Storage_Model_Type_Entity
+ (SM_Obj_Or_Type : Entity_Id;
+ Nam : Name_Id) return Entity_Id
+ is
+ Typ : constant Entity_Id := (if Is_Object (SM_Obj_Or_Type) then
+ Storage_Model_Type (SM_Obj_Or_Type)
+ else
+ SM_Obj_Or_Type);
+ pragma Assert
+ (Is_Type (Typ)
+ and then
+ Nam in Name_Address_Type
+ | Name_Null_Address
+ | Name_Allocate
+ | Name_Deallocate
+ | Name_Copy_From
+ | Name_Copy_To
+ | Name_Storage_Size);
+
+ Assoc : Node_Id;
+ SMT_Aspect_Value : constant Node_Id :=
+ Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type);
+
+ begin
+ pragma Assert (Present (SMT_Aspect_Value));
+
+ Assoc := First (Component_Associations (SMT_Aspect_Value));
+ while Present (Assoc) loop
+ if Chars (First (Choices (Assoc))) = Nam then
+ return Entity (Expression (Assoc));
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ return Empty;
+ end Get_Storage_Model_Type_Entity;
+
--------------------------------
-- Storage_Model_Address_Type --
--------------------------------
- function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id is
+ function Storage_Model_Address_Type
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id
+ is
begin
- return Get_Storage_Model_Type_Entity (Typ, Name_Address_Type);
+ return
+ Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Address_Type);
end Storage_Model_Address_Type;
--------------------------------
-- Storage_Model_Null_Address --
--------------------------------
- function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id is
+ function Storage_Model_Null_Address
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id
+ is
begin
- return Get_Storage_Model_Type_Entity (Typ, Name_Null_Address);
+ return
+ Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Null_Address);
end Storage_Model_Null_Address;
----------------------------
-- Storage_Model_Allocate --
----------------------------
- function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id is
+ function Storage_Model_Allocate
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id
+ is
begin
- return Get_Storage_Model_Type_Entity (Typ, Name_Allocate);
+ return Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Allocate);
end Storage_Model_Allocate;
------------------------------
-- Storage_Model_Deallocate --
------------------------------
- function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id is
+ function Storage_Model_Deallocate
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id
+ is
begin
- return Get_Storage_Model_Type_Entity (Typ, Name_Deallocate);
+ return
+ Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Deallocate);
end Storage_Model_Deallocate;
-----------------------------
-- Storage_Model_Copy_From --
-----------------------------
- function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id is
+ function Storage_Model_Copy_From
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id
+ is
begin
- return Get_Storage_Model_Type_Entity (Typ, Name_Copy_From);
+ return Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Copy_From);
end Storage_Model_Copy_From;
---------------------------
-- Storage_Model_Copy_To --
---------------------------
- function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id is
+ function Storage_Model_Copy_To
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id
+ is
begin
- return Get_Storage_Model_Type_Entity (Typ, Name_Copy_To);
+ return Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Copy_To);
end Storage_Model_Copy_To;
--------------------------------
-- Storage_Model_Storage_Size --
--------------------------------
- function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id is
+ function Storage_Model_Storage_Size
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id
+ is
begin
- return Get_Storage_Model_Type_Entity (Typ, Name_Storage_Size);
+ return
+ Get_Storage_Model_Type_Entity (SM_Obj_Or_Type, Name_Storage_Size);
end Storage_Model_Storage_Size;
end Storage_Model_Support;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -3591,68 +3591,78 @@ package Sem_Util is
-- for the Storage_Model feature. These functions provide an interface
-- that the compiler (in particular back-end phases such as gigi and
-- GNAT-LLVM) can use to easily obtain entities and operations that
- -- are specified for types in the aspects Storage_Model_Type and
+ -- are specified for types that have aspects Storage_Model_Type or
-- Designated_Storage_Model.
- function Get_Storage_Model_Type_Entity
- (Typ : Entity_Id;
- Nam : Name_Id) return Entity_Id;
- -- Given type Typ with aspect Storage_Model_Type, returns the Entity_Id
- -- corresponding to the entity associated with Nam in the aspect. If the
- -- type does not specify the aspect, or such an entity is not present,
- -- then returns Empty. (Note: This function is modeled on function
- -- Get_Iterable_Type_Primitive.)
+ function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean;
+ -- Returns True iff Typ specifies aspect Storage_Model_Type
function Has_Designated_Storage_Model_Aspect
(Typ : Entity_Id) return Boolean;
-- Returns True iff Typ specifies aspect Designated_Storage_Model
- function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean;
- -- Returns True iff Typ specifies aspect Storage_Model_Type
-
function Storage_Model_Object (Typ : Entity_Id) return Entity_Id;
- -- Given an access type with aspect Designated_Storage_Model, returns
- -- the storage-model object associated with that type; returns Empty
- -- if there is no associated object.
+ -- Given an access type Typ with aspect Designated_Storage_Model,
+ -- returns the storage-model object associated with that type.
+ -- The object Entity_Ids returned by this function can be passed
+ -- other functions declared in this interface to retrieve operations
+ -- associated with Storage_Model_Type aspect of the object's type.
function Storage_Model_Type (Obj : Entity_Id) return Entity_Id;
-- Given an object Obj of a type specifying aspect Storage_Model_Type,
- -- returns that type; otherwise returns Empty.
-
- function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id;
- -- Given a type Typ that specifies aspect Storage_Model_Type, returns
- -- the type specified for the Address_Type choice in that aspect;
- -- returns Empty if the aspect or the type isn't specified.
-
- function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id;
- -- Given a type Typ that specifies aspect Storage_Model_Type, returns
- -- constant specified for Null_Address choice in that aspect; returns
- -- Empty if the aspect or the constant object isn't specified.
-
- function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id;
- -- Given a type Typ that specifies aspect Storage_Model_Type, returns
- -- procedure specified for the Allocate choice in that aspect; returns
- -- Empty if the aspect or the procedure isn't specified.
-
- function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id;
- -- Given a type Typ that specifies aspect Storage_Model_Type, returns
- -- procedure specified for the Deallocate choice in that aspect; returns
- -- Empty if the aspect or the procedure isn't specified.
-
- function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id;
- -- Given a type Typ that specifies aspect Storage_Model_Type, returns
- -- procedure specified for the Copy_From choice in that aspect; returns
- -- Empty if the aspect or the procedure isn't specified.
-
- function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id;
- -- Given a type Typ that specifies aspect Storage_Model_Type, returns
- -- procedure specified for the Copy_To choice in that aspect; returns
- -- Empty if the aspect or the procedure isn't specified.
-
- function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id;
- -- Given a type Typ that specifies aspect Storage_Model_Type, returns
- -- function specified for Storage_Size choice in that aspect; returns
- -- Empty if the aspect or the procedure isn't specified.
+ -- returns that type.
+
+ function Get_Storage_Model_Type_Entity
+ (SM_Obj_Or_Type : Entity_Id;
+ Nam : Name_Id) return Entity_Id;
+ -- Given a type with aspect Storage_Model_Type or an object of such a
+ -- type, and Nam denoting the name of one of the argument kinds allowed
+ -- for that aspect, returns the Entity_Id corresponding to the entity
+ -- associated with Nam in the aspect. If such an entity is not present,
+ -- then returns Empty. (Note: This function is modeled on function
+ -- Get_Iterable_Type_Primitive.)
+
+ function Storage_Model_Address_Type
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id;
+ -- Given a type with aspect Storage_Model_Type or an object of such a
+ -- type, returns the type specified for the Address_Type choice in that
+ -- aspect; returns Empty if the type isn't specified.
+
+ function Storage_Model_Null_Address
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id;
+ -- Given a type with aspect Storage_Model_Type or an object of such a
+ -- type, returns the constant specified for the Null_Address choice in
+ -- that aspect; returns Empty if the constant object isn't specified.
+
+ function Storage_Model_Allocate
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id;
+ -- Given a type with aspect Storage_Model_Type or an object of such a
+ -- type, returns the procedure specified for the Allocate choice in that
+ -- aspect; returns Empty if the procedure isn't specified.
+
+ function Storage_Model_Deallocate
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id;
+ -- Given a type with aspect Storage_Model_Type or an object of such a
+ -- type, returns the procedure specified for the Deallocate choice in
+ -- that aspect; returns Empty if the procedure isn't specified.
+
+ function Storage_Model_Copy_From
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id;
+ -- Given a type with aspect Storage_Model_Type or an object of such a
+ -- type, returns the procedure specified for the Copy_From choice in
+ -- that aspect; returns Empty if the procedure isn't specified.
+
+ function Storage_Model_Copy_To
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id;
+ -- Given a type with aspect Storage_Model_Type or an object of such a
+ -- type, returns the procedure specified for the Copy_To choice in that
+ -- aspect; returns Empty if the procedure isn't specified.
+
+ function Storage_Model_Storage_Size
+ (SM_Obj_Or_Type : Entity_Id) return Entity_Id;
+ -- Given a type with aspect Storage_Model_Type or an object of such a
+ -- type, returns the function specified for the Storage_Size choice in
+ -- that aspect; returns Empty if the procedure isn't specified.
end Storage_Model_Support;
