[gcc r12-4161] [Ada] Front-end support for Storage_Model feature
Pierre-Marie de Rodat
pmderodat@gcc.gnu.org
Tue Oct 5 08:23:31 GMT 2021
https://gcc.gnu.org/g:b479c0f7d7c45f9d99292ca2aa71d7845c7769bc
commit r12-4161-gb479c0f7d7c45f9d99292ca2aa71d7845c7769bc
Author: Gary Dismukes <dismukes@adacore.com>
Date: Mon Sep 13 17:40:34 2021 -0400
[Ada] Front-end support for Storage_Model feature
gcc/ada/
* aspects.ads (type Aspect_Id): Add
Aspect_Designated_Storage_Model and Aspect_Storage_Model_Type.
(Aspect_Argument): Add associations for the above new aspects.
(Is_Representation_Aspect): Likewise.
(Aspect_Names, Aspect_Delay): Likewise.
* exp_ch4.adb (Expand_N_Allocator): Call Find_Storage_Op rather
than Find_Prim_Op.
* exp_intr.adb (Expand_Unc_Deallocation): Likewise.
* exp_util.ads (Find_Storage_Op): New function that locates
either a primitive operation of a storage pool or an operation
of a storage-model type specified in its Storage_Model_Type
aspect.
* exp_util.adb (Find_Storage_Op): New function that calls either
Find_Prim_Op or Get_Storage_Model_Type_Entity to locate a
storage-related operation that is associated with a type.
* sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Analyzes,
resolves, and validates the arguments of aspect
Designated_Storage_Model_Type.
(Analyze_Aspect_Specifications): Sets delay-related flags on
storage-model aspects when Delay_Required. Checks that aspect
Designated_Storage_Model is only specified for an access type
and that aspect Storage_Model_Type is only specified on an
immutably limited type. Also records such aspects for their
associated types.
(Check_Aspect_At_Freeze_Point): Resolve each of the argument
associations given for a Storage_Model_Type aspect.
(Resolve_Storage_Model_Type_Argument): New procedure that
resolves an argument given in the association for a given entity
name associated with a type with aspect Storage_Model_Type,
ensuring that it has the proper kind or profile.
(Validate_Storage_Model_Type_Aspect): New procedure that checks
the legality and completeness of the entity associations given
in a Storage_Model_Type aspect.
* sem_util.ads (package Storage_Model_Support): New nested
package that encapsulates a set of convenient utility functions
for retrieving entities, etc. associated with
storage-model-related types and objects.
(Get_Storage_Model_Type_Entity): New function to return a
specified entity associated with a type that has aspect
Storage_Model_Type.
(Has_Designated_Storage_Model_Aspect): New function that returns
whether a type has aspect Designated_Storage_Model.
(Has_Storage_Model_Type_Aspect): New function that returns
whether a type has aspect Storage_Model_Type.
(Storage_Model_Object): New function that returns the object
Entity_Id associated with a type's Designated_Storage_Model
aspect.
(Storage_Model_Type): New function that returns the type
associated with a storage-model object (when the object's type
specifies Storage_Model_Type).
(Storage_Model_Address_Type): New function that returns the
Address_Type associated with a type that has aspect
Storage_Model_Type.
(Storage_Model_Null_Address): New function that returns the
Null_Address constant associated with a type that has aspect
Storage_Model_Type.
(Storage_Model_Allocate): New function that returns the Allocate
procedure associated with a type that has aspect
Storage_Model_Type.
(Storage_Model_Deallocate): New function that returns the
Deallocate procedure associated with a type that has aspect
Storage_Model_Type.
(Storage_Model_Copy_From): New function that returns the
Copy_From procedure associated with a type that has aspect
Storage_Model_Type.
(Storage_Model_Copy_To): New function that returns the Copy_To
procedure associated with a type that has aspect
Storage_Model_Type.
(Storage_Model_Storage_Size): New function that returns the
Storage_Size function associated with a type that has aspect
Storage_Model_Type.
* sem_util.adb (package Storage_Model_Support): Body of new
nested package that contains the implementations the utility
functions declared in the spec of this package.
* snames.ads-tmpl: Add new names Name_Designated_Storage_Pool,
Name_Storage_Model, Name_Storage_Model_Type, Name_Address_Type,
Name_Copy_From, Name_Copy_To, and Name_Null_Address for the new
aspects and associated aspect arguments.
Diff:
---
gcc/ada/aspects.ads | 10 +
gcc/ada/exp_ch4.adb | 2 +-
gcc/ada/exp_intr.adb | 2 +-
gcc/ada/exp_util.adb | 26 +++
gcc/ada/exp_util.ads | 10 +
gcc/ada/sem_ch13.adb | 550 +++++++++++++++++++++++++++++++++++++++++++++++-
gcc/ada/sem_util.adb | 160 ++++++++++++++
gcc/ada/sem_util.ads | 72 +++++++
gcc/ada/snames.ads-tmpl | 7 +
9 files changed, 834 insertions(+), 5 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 11e0aebfeeb..ab11bfda2f9 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -89,6 +89,7 @@ package Aspects is
Aspect_Default_Storage_Pool,
Aspect_Default_Value,
Aspect_Depends, -- GNAT
+ Aspect_Designated_Storage_Model, -- GNAT
Aspect_Dimension, -- GNAT
Aspect_Dimension_System, -- GNAT
Aspect_Dispatching_Domain,
@@ -147,6 +148,7 @@ package Aspects is
Aspect_SPARK_Mode, -- GNAT
Aspect_Stable_Properties,
Aspect_Static_Predicate,
+ Aspect_Storage_Model_Type, -- GNAT
Aspect_Storage_Pool,
Aspect_Storage_Size,
Aspect_Stream_Size,
@@ -380,6 +382,7 @@ package Aspects is
Aspect_Default_Storage_Pool => Expression,
Aspect_Default_Value => Expression,
Aspect_Depends => Expression,
+ Aspect_Designated_Storage_Model => Name,
Aspect_Dimension => Expression,
Aspect_Dimension_System => Expression,
Aspect_Dispatching_Domain => Expression,
@@ -438,6 +441,7 @@ package Aspects is
Aspect_SPARK_Mode => Optional_Name,
Aspect_Stable_Properties => Expression,
Aspect_Static_Predicate => Expression,
+ Aspect_Storage_Model_Type => Expression,
Aspect_Storage_Pool => Name,
Aspect_Storage_Size => Expression,
Aspect_Stream_Size => Expression,
@@ -485,6 +489,7 @@ package Aspects is
Aspect_Default_Storage_Pool => True,
Aspect_Default_Value => True,
Aspect_Depends => False,
+ Aspect_Designated_Storage_Model => True,
Aspect_Dimension => False,
Aspect_Dimension_System => False,
Aspect_Dispatching_Domain => False,
@@ -544,6 +549,7 @@ package Aspects is
Aspect_SPARK_Mode => False,
Aspect_Stable_Properties => False,
Aspect_Static_Predicate => False,
+ Aspect_Storage_Model_Type => False,
Aspect_Storage_Pool => True,
Aspect_Storage_Size => True,
Aspect_Stream_Size => True,
@@ -637,6 +643,7 @@ package Aspects is
Aspect_Default_Storage_Pool => Name_Default_Storage_Pool,
Aspect_Default_Value => Name_Default_Value,
Aspect_Depends => Name_Depends,
+ Aspect_Designated_Storage_Model => Name_Designated_Storage_Model,
Aspect_Dimension => Name_Dimension,
Aspect_Dimension_System => Name_Dimension_System,
Aspect_Disable_Controlled => Name_Disable_Controlled,
@@ -726,6 +733,7 @@ package Aspects is
Aspect_Stable_Properties => Name_Stable_Properties,
Aspect_Static => Name_Static,
Aspect_Static_Predicate => Name_Static_Predicate,
+ Aspect_Storage_Model_Type => Name_Storage_Model_Type,
Aspect_Storage_Pool => Name_Storage_Pool,
Aspect_Storage_Size => Name_Storage_Size,
Aspect_Stream_Size => Name_Stream_Size,
@@ -881,6 +889,7 @@ package Aspects is
Aspect_Default_Storage_Pool => Always_Delay,
Aspect_Default_Value => Always_Delay,
Aspect_Default_Component_Value => Always_Delay,
+ Aspect_Designated_Storage_Model => Always_Delay,
Aspect_Discard_Names => Always_Delay,
Aspect_Dispatching_Domain => Always_Delay,
Aspect_Dynamic_Predicate => Always_Delay,
@@ -932,6 +941,7 @@ package Aspects is
Aspect_Simple_Storage_Pool => Always_Delay,
Aspect_Simple_Storage_Pool_Type => Always_Delay,
Aspect_Static_Predicate => Always_Delay,
+ Aspect_Storage_Model_Type => Always_Delay,
Aspect_Storage_Pool => Always_Delay,
Aspect_Stream_Size => Always_Delay,
Aspect_String_Literal => Always_Delay,
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index d636cb0f613..8dcfa85e756 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -4704,7 +4704,7 @@ package body Exp_Ch4 is
else
Set_Procedure_To_Call (N,
- Find_Prim_Op (Etype (Pool), Name_Allocate));
+ Find_Storage_Op (Etype (Pool), Name_Allocate));
end if;
end if;
end if;
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 45de0fb4e51..86cb70234e6 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -1151,7 +1151,7 @@ package body Exp_Intr is
else
Set_Procedure_To_Call
- (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate));
+ (Free_Nod, Find_Storage_Op (Etype (Pool), Name_Deallocate));
end if;
end if;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index eef278fb391..cb180967d67 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6256,6 +6256,32 @@ package body Exp_Util is
raise Program_Error;
end Find_Protection_Type;
+ function Find_Storage_Op
+ (Typ : Entity_Id;
+ Nam : Name_Id) return Entity_Id
+ is
+ use Sem_Util.Storage_Model_Support;
+
+ begin
+ if Has_Storage_Model_Type_Aspect (Typ) then
+ declare
+ SMT_Op : constant Entity_Id :=
+ Get_Storage_Model_Type_Entity (Typ, Nam);
+ begin
+ if not Present (SMT_Op) then
+ raise Program_Error;
+ else
+ return SMT_Op;
+ end if;
+ end;
+
+ -- Otherwise we assume that Typ is a descendant of Root_Storage_Pool
+
+ else
+ return Find_Prim_Op (Typ, Nam);
+ end if;
+ end Find_Storage_Op;
+
-----------------------
-- Find_Hook_Context --
-----------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index eddf314c932..2b61132107c 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -628,6 +628,16 @@ package Exp_Util is
-- Given a protected type or its corresponding record, find the type of
-- field _object.
+ function Find_Storage_Op
+ (Typ : Entity_Id;
+ Nam : Name_Id) return Entity_Id;
+ -- Given type Typ that's either a descendant of Root_Storage_Pool or else
+ -- specifies aspect Storage_Model_Type, returns the Entity_Id of the
+ -- subprogram associated with Nam, which must either be a primitive op of
+ -- the type in the case of a storage pool, or the operation corresponding
+ -- to Nam as specified in the aspect Storage_Model_Type. It is an error if
+ -- no operation corresponding to the given name is found.
+
function Find_Hook_Context (N : Node_Id) return Node_Id;
-- Determine a suitable node on which to attach actions related to N that
-- need to be elaborated unconditionally. In general this is the topmost
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 412855490d3..fb1be479de1 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -262,6 +262,19 @@ package body Sem_Ch13 is
-- Check legality of functions given in the Ada 2022 Stable_Properties
-- (or Stable_Properties'Class) aspect.
+ procedure Validate_Storage_Model_Type_Aspect
+ (Typ : Entity_Id; ASN : Node_Id);
+ -- Check legality and completeness of the aggregate associations given in
+ -- the Storage_Model_Type aspect associated with Typ.
+
+ procedure Resolve_Storage_Model_Type_Argument
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Addr_Type : in out Entity_Id;
+ Nam : Name_Id);
+ -- Resolve argument N to be of the proper kind (when a type or constant)
+ -- or to have the proper profile (when a subprogram).
+
procedure Resolve_Aspect_Stable_Properties
(Typ_Or_Subp : Entity_Id;
Expr : Node_Id;
@@ -1517,6 +1530,32 @@ package body Sem_Ch13 is
when Aspect_Iterable =>
Validate_Iterable_Aspect (E, ASN);
+ when Aspect_Designated_Storage_Model =>
+ Analyze_And_Resolve (Expression (ASN));
+
+ if not Is_Entity_Name (Expression (ASN))
+ or else not Is_Object (Entity (Expression (ASN)))
+ or else
+ not Present (Find_Aspect (Etype (Expression (ASN)),
+ Aspect_Storage_Model_Type))
+ then
+ Error_Msg_N
+ ("must specify name of stand-alone object of type "
+ & "with aspect Storage_Model_Type",
+ Expression (ASN));
+
+ -- Set access type's Associated_Storage_Pool to denote
+ -- the Storage_Model_Type object given for the aspect
+ -- (even though that isn't actually an Ada storage pool).
+
+ else
+ Set_Associated_Storage_Pool
+ (E, Entity (Expression (ASN)));
+ end if;
+
+ when Aspect_Storage_Model_Type =>
+ Validate_Storage_Model_Type_Aspect (E, ASN);
+
when Aspect_Aggregate =>
null;
@@ -3065,10 +3104,11 @@ package body Sem_Ch13 is
if Delay_Required
- and then A_Id = Aspect_Stable_Properties
+ and then (A_Id = Aspect_Stable_Properties
+ or else A_Id = Aspect_Designated_Storage_Model
+ or else A_Id = Aspect_Storage_Model_Type)
-- ??? It seems like we should do this for all aspects, not
- -- just Stable_Properties, but that causes as-yet-undiagnosed
- -- regressions.
+ -- just these, but that causes as-yet-undiagnosed regressions.
then
Set_Has_Delayed_Aspects (E);
@@ -4368,6 +4408,44 @@ package body Sem_Ch13 is
Record_Rep_Item (E, Aspect);
goto Continue;
+ when Aspect_Designated_Storage_Model =>
+ if not Extensions_Allowed then
+ Error_Msg_N
+ ("aspect only allowed if extensions enabled",
+ Aspect);
+ Error_Msg_N
+ ("\unit must be compiled with -gnatX switch", Aspect);
+
+ elsif not Is_Type (E)
+ or else Ekind (E) /= E_Access_Type
+ then
+ Error_Msg_N
+ ("can only be specified for pool-specific access type",
+ Aspect);
+ end if;
+
+ Record_Rep_Item (E, Aspect);
+ goto Continue;
+
+ when Aspect_Storage_Model_Type =>
+ if not Extensions_Allowed then
+ Error_Msg_N
+ ("aspect only allowed if extensions enabled",
+ Aspect);
+ Error_Msg_N
+ ("\unit must be compiled with -gnatX switch", Aspect);
+
+ elsif not Is_Type (E)
+ or else not Is_Immutably_Limited_Type (E)
+ then
+ Error_Msg_N
+ ("can only be specified for immutably limited type",
+ Aspect);
+ end if;
+
+ Record_Rep_Item (E, Aspect);
+ goto Continue;
+
when Aspect_Integer_Literal
| Aspect_Real_Literal
| Aspect_String_Literal
@@ -11229,6 +11307,34 @@ package body Sem_Ch13 is
-- Here is the list of aspects that don't require delay analysis
+ when Aspect_Designated_Storage_Model =>
+ return;
+
+ when Aspect_Storage_Model_Type =>
+ T := Entity (ASN);
+
+ declare
+ Assoc : Node_Id;
+ Expr : Node_Id;
+ Addr_Type : Entity_Id := Empty;
+
+ begin
+ Assoc := First (Component_Associations (Expression (ASN)));
+ while Present (Assoc) loop
+ Expr := Expression (Assoc);
+ Analyze (Expr);
+
+ if not Error_Posted (Expr) then
+ Resolve_Storage_Model_Type_Argument
+ (Expr, T, Addr_Type, Chars (First (Choices (Assoc))));
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end;
+
+ return;
+
when Aspect_Abstract_State
| Aspect_Annotate
| Aspect_Async_Readers
@@ -16199,6 +16305,334 @@ package body Sem_Ch13 is
Set_Analyzed (Expr);
end Resolve_Aspect_Stable_Properties;
+ -----------------------------------------
+ -- Resolve_Storage_Model_Type_Argument --
+ -----------------------------------------
+
+ procedure Resolve_Storage_Model_Type_Argument
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Addr_Type : in out Entity_Id;
+ Nam : Name_Id)
+ is
+
+ type Formal_Profile is record
+ Subt : Entity_Id;
+ Mode : Formal_Kind;
+ end record;
+
+ type Formal_Profiles is array (Positive range <>) of Formal_Profile;
+
+ function Aspect_Argument_Profile_Matches
+ (Subp : Entity_Id;
+ Profiles : Formal_Profiles;
+ Result_Subt : Entity_Id;
+ Err_On_Mismatch : Boolean) return Boolean;
+ -- Checks that the formal parameters of subprogram Subp conform to the
+ -- subtypes and modes specified by Profiles, as well as to the result
+ -- subtype Result_Subt when that is nonempty.
+
+ function Aspect_Argument_Profile_Matches
+ (Subp : Entity_Id;
+ Profiles : Formal_Profiles;
+ Result_Subt : Entity_Id;
+ Err_On_Mismatch : Boolean) return Boolean
+ is
+
+ procedure Report_Argument_Error
+ (Msg : String;
+ Formal : Entity_Id := Empty;
+ Subt : Entity_Id := Empty);
+ -- If Err_On_Mismatch is True, reports an argument error given by Msg
+ -- associated with Formal and/or Subt.
+
+ procedure Report_Argument_Error
+ (Msg : String;
+ Formal : Entity_Id := Empty;
+ Subt : Entity_Id := Empty)
+ is
+ begin
+ if Err_On_Mismatch then
+ if Present (Formal) then
+ if Present (Subt) then
+ Error_Msg_Node_2 := Subt;
+ end if;
+ Error_Msg_NE (Msg, N, Formal);
+
+ elsif Present (Subt) then
+ Error_Msg_NE (Msg, N, Subt);
+
+ else
+ Error_Msg_N (Msg, N);
+ end if;
+ end if;
+ end Report_Argument_Error;
+
+ -- Local variables
+
+ Formal : Entity_Id := First_Formal (Subp);
+ Is_Error : Boolean := False;
+
+ -- Start of processing for Aspect_Argument_Profile_Matches
+
+ begin
+ for FP of Profiles loop
+ if not Present (Formal) then
+ Is_Error := True;
+ Report_Argument_Error ("missing formal of }", Subt => FP.Subt);
+ exit;
+
+ elsif not Subtypes_Statically_Match
+ (Etype (Formal), FP.Subt)
+ then
+ Is_Error := True;
+ Report_Argument_Error
+ ("formal& must be of subtype&",
+ Formal => Formal, Subt => FP.Subt);
+ exit;
+
+ elsif Ekind (Formal) /= FP.Mode then
+ Is_Error := True;
+ Report_Argument_Error
+ ("formal& has wrong mode", Formal => Formal);
+ exit;
+ end if;
+
+ Formal := Next_Formal (Formal);
+ end loop;
+
+ if not Is_Error
+ and then Present (Formal)
+ then
+ Is_Error := True;
+ Report_Argument_Error
+ ("too many formals for subprogram in aspect");
+ end if;
+
+ if not Is_Error
+ and then Present (Result_Subt)
+ and then not Subtypes_Statically_Match (Etype (Subp), Result_Subt)
+ then
+ Is_Error := True;
+ Report_Argument_Error
+ ("subprogram must have result}", Subt => Result_Subt);
+ end if;
+
+ return not Is_Error;
+ end Aspect_Argument_Profile_Matches;
+
+ -- Local variables
+
+ Ent : Entity_Id;
+
+ Storage_Count_Type : constant Entity_Id := RTE (RE_Storage_Count);
+ System_Address_Type : constant Entity_Id := RTE (RE_Address);
+
+ -- Start of processing for Resolve_Storage_Model_Type_Argument
+
+ begin
+ if Nam = Name_Address_Type then
+ if not Is_Entity_Name (N)
+ or else not Is_Type (Entity (N))
+ or else (Root_Type (Entity (N)) /= System_Address_Type
+ and then not Is_Integer_Type (Entity (N)))
+ then
+ Error_Msg_N ("named entity must be a descendant of System.Address "
+ & "or an integer type", N);
+ end if;
+
+ Addr_Type := Entity (N);
+
+ return;
+
+ elsif not Present (Addr_Type) then
+ Error_Msg_N ("argument association for Address_Type missing; "
+ & "must be specified as first aspect argument", N);
+ return;
+
+ elsif Nam = Name_Null_Address then
+ if not Is_Entity_Name (N)
+ or else not Is_Constant_Object (Entity (N))
+ or else
+ not Subtypes_Statically_Match (Etype (Entity (N)), Addr_Type)
+ then
+ Error_Msg_NE
+ ("named entity must be constant of subtype}", N, Addr_Type);
+ end if;
+
+ return;
+
+ elsif not Is_Overloaded (N) then
+ if not Is_Entity_Name (N)
+ or else Ekind (Entity (N)) not in E_Function | E_Procedure
+ or else Scope (Entity (N)) /= Scope (Typ)
+ then
+ Error_Msg_N ("argument must be local subprogram name", N);
+ return;
+ end if;
+
+ Ent := Entity (N);
+
+ if Nam = Name_Allocate then
+ if not Aspect_Argument_Profile_Matches
+ (Ent,
+ Profiles =>
+ ((Typ, E_In_Out_Parameter),
+ (Addr_Type, E_Out_Parameter),
+ (Storage_Count_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter)),
+ Result_Subt => Empty,
+ Err_On_Mismatch => True)
+ then
+ Error_Msg_N ("no match for Allocate operation", N);
+ end if;
+
+ elsif Nam = Name_Deallocate then
+ if not Aspect_Argument_Profile_Matches
+ (Ent,
+ Profiles =>
+ ((Typ, E_In_Out_Parameter),
+ (Addr_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter)),
+ Result_Subt => Empty,
+ Err_On_Mismatch => True)
+ then
+ Error_Msg_N ("no match for Deallocate operation", N);
+ end if;
+
+ elsif Nam = Name_Copy_From then
+ if not Aspect_Argument_Profile_Matches
+ (Ent,
+ Profiles =>
+ ((Typ, E_In_Out_Parameter),
+ (System_Address_Type, E_In_Parameter),
+ (Addr_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter)),
+ Result_Subt => Empty,
+ Err_On_Mismatch => True)
+ then
+ Error_Msg_N ("no match for Copy_From operation", N);
+ end if;
+
+ elsif Nam = Name_Copy_To then
+ if not Aspect_Argument_Profile_Matches
+ (Ent,
+ Profiles =>
+ ((Typ, E_In_Out_Parameter),
+ (Addr_Type, E_In_Parameter),
+ (System_Address_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter)),
+ Result_Subt => Empty,
+ Err_On_Mismatch => True)
+ then
+ Error_Msg_N ("no match for Copy_To operation", N);
+ end if;
+
+ elsif Nam = Name_Storage_Size then
+ if not Aspect_Argument_Profile_Matches
+ (Ent,
+ Profiles => (1 => (Typ, E_In_Parameter)),
+ Result_Subt => Storage_Count_Type,
+ Err_On_Mismatch => True)
+ then
+ Error_Msg_N ("no match for Storage_Size operation", N);
+ end if;
+
+ else
+ null; -- Error will be caught in Validate_Storage_Model_Type_Aspect
+ end if;
+
+ else
+ -- Overloaded case: find subprogram with proper signature
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Found_Match : Boolean := False;
+
+ begin
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Ekind (It.Nam) in E_Function | E_Procedure
+ and then Scope (It.Nam) = Scope (Typ)
+ then
+ if Nam = Name_Allocate then
+ Found_Match :=
+ Aspect_Argument_Profile_Matches
+ (It.Nam,
+ Profiles =>
+ ((Typ, E_In_Out_Parameter),
+ (Addr_Type, E_Out_Parameter),
+ (Storage_Count_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter)),
+ Result_Subt => Empty,
+ Err_On_Mismatch => False);
+
+ elsif Nam = Name_Deallocate then
+ Found_Match :=
+ Aspect_Argument_Profile_Matches
+ (It.Nam,
+ Profiles =>
+ ((Typ, E_In_Out_Parameter),
+ (Addr_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter)),
+ Result_Subt => Empty,
+ Err_On_Mismatch => False);
+
+ elsif Nam = Name_Copy_From then
+ Found_Match :=
+ Aspect_Argument_Profile_Matches
+ (It.Nam,
+ Profiles =>
+ ((Typ, E_In_Out_Parameter),
+ (System_Address_Type, E_In_Parameter),
+ (Addr_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter)),
+ Result_Subt => Empty,
+ Err_On_Mismatch => False);
+
+ elsif Nam = Name_Copy_To then
+ Found_Match :=
+ Aspect_Argument_Profile_Matches
+ (It.Nam,
+ Profiles =>
+ ((Typ, E_In_Out_Parameter),
+ (Addr_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter),
+ (System_Address_Type, E_In_Parameter),
+ (Storage_Count_Type, E_In_Parameter)),
+ Result_Subt => Empty,
+ Err_On_Mismatch => False);
+
+ elsif Nam = Name_Storage_Size then
+ Found_Match :=
+ Aspect_Argument_Profile_Matches
+ (It.Nam,
+ Profiles => (1 => (Typ, E_In_Parameter)),
+ Result_Subt => Storage_Count_Type,
+ Err_On_Mismatch => False);
+ end if;
+
+ if Found_Match then
+ Set_Entity (N, It.Nam);
+ exit;
+ end if;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if not Found_Match then
+ Error_Msg_N
+ ("no match found for Storage_Model_Type operation", N);
+ end if;
+ end;
+ end if;
+ end Resolve_Storage_Model_Type_Argument;
+
----------------
-- Set_Biased --
----------------
@@ -16781,6 +17215,116 @@ package body Sem_Ch13 is
end if;
end Validate_Literal_Aspect;
+ ----------------------------------------
+ -- Validate_Storage_Model_Type_Aspect --
+ ----------------------------------------
+
+ procedure Validate_Storage_Model_Type_Aspect
+ (Typ : Entity_Id; ASN : Node_Id)
+ is
+ Assoc : Node_Id;
+ Choice : Entity_Id;
+ Expr : Node_Id;
+
+ Address_Type_Id : Entity_Id := Empty;
+ Null_Address_Id : Entity_Id := Empty;
+ Allocate_Id : Entity_Id := Empty;
+ Deallocate_Id : Entity_Id := Empty;
+ Copy_From_Id : Entity_Id := Empty;
+ Copy_To_Id : Entity_Id := Empty;
+ Storage_Size_Id : Entity_Id := Empty;
+
+ begin
+ -- Each expression must resolve to an entity of the right kind or proper
+ -- profile.
+
+ Assoc := First (Component_Associations (Expression (ASN)));
+ while Present (Assoc) loop
+ Expr := Expression (Assoc);
+ Analyze (Expr);
+
+ Choice := First (Choices (Assoc));
+
+ if Nkind (Choice) /= N_Identifier or else Present (Next (Choice)) then
+ Error_Msg_N ("illegal name in association", Choice);
+
+ elsif Chars (Choice) = Name_Address_Type then
+ if Assoc /= First (Component_Associations (Expression (ASN))) then
+ Error_Msg_N ("Address_Type must be first association", Choice);
+ end if;
+
+ Resolve_Storage_Model_Type_Argument
+ (Expr, Typ, Address_Type_Id, Name_Address_Type);
+ Address_Type_Id := Entity (Expr);
+
+ -- Shouldn't we check for duplicates of the same subaspect name,
+ -- and issue an error in such cases???
+
+ elsif not Present (Address_Type_Id) then
+ Error_Msg_N
+ ("Address_Type missing, must be first association", Choice);
+
+ elsif Chars (Choice) = Name_Null_Address then
+ Resolve_Storage_Model_Type_Argument
+ (Expr, Typ, Address_Type_Id, Name_Null_Address);
+ Null_Address_Id := Entity (Expr);
+
+ elsif Chars (Choice) = Name_Allocate then
+ Resolve_Storage_Model_Type_Argument
+ (Expr, Typ, Address_Type_Id, Name_Allocate);
+ Allocate_Id := Entity (Expr);
+
+ elsif Chars (Choice) = Name_Deallocate then
+ Resolve_Storage_Model_Type_Argument
+ (Expr, Typ, Address_Type_Id, Name_Deallocate);
+ Deallocate_Id := Entity (Expr);
+
+ elsif Chars (Choice) = Name_Copy_From then
+ Resolve_Storage_Model_Type_Argument
+ (Expr, Typ, Address_Type_Id, Name_Copy_From);
+ Copy_From_Id := Entity (Expr);
+
+ elsif Chars (Choice) = Name_Copy_To then
+ Resolve_Storage_Model_Type_Argument
+ (Expr, Typ, Address_Type_Id, Name_Copy_To);
+ Copy_To_Id := Entity (Expr);
+
+ elsif Chars (Choice) = Name_Storage_Size then
+ Resolve_Storage_Model_Type_Argument
+ (Expr, Typ, Address_Type_Id, Name_Storage_Size);
+ Storage_Size_Id := Entity (Expr);
+
+ else
+ Error_Msg_N
+ ("invalid name for Storage_Model_Type argument", Choice);
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ if No (Address_Type_Id) then
+ Error_Msg_N ("match for Address_Type not found", ASN);
+
+ elsif No (Null_Address_Id) then
+ Error_Msg_N ("match for Null_Address primitive not found", ASN);
+
+ elsif No (Allocate_Id) then
+ Error_Msg_N ("match for Allocate primitive not found", ASN);
+
+ elsif No (Deallocate_Id) then
+ Error_Msg_N ("match for Deallocate primitive not found", ASN);
+
+ elsif No (Copy_From_Id) then
+ Error_Msg_N ("match for Copy_From primitive not found", ASN);
+
+ elsif No (Copy_To_Id) then
+ Error_Msg_N ("match for Copy_To primitive not found", ASN);
+
+ elsif No (Storage_Size_Id) then
+ Error_Msg_N ("match for Storage_Size primitive not found", ASN);
+ end if;
+ end Validate_Storage_Model_Type_Aspect;
+
-----------------------------------
-- Validate_Unchecked_Conversion --
-----------------------------------
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 072cd3f6745..b5f3d4cce03 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -32153,6 +32153,166 @@ package body Sem_Util is
end Indirect_Temps;
end Old_Attr_Util;
+
+ 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 --
+ -----------------------------------------
+
+ function Has_Designated_Storage_Model_Aspect
+ (Typ : Entity_Id) return Boolean
+ is
+ begin
+ return Present (Find_Aspect (Typ, Aspect_Designated_Storage_Model));
+ end Has_Designated_Storage_Model_Aspect;
+
+ -----------------------------------
+ -- Has_Storage_Model_Type_Aspect --
+ -----------------------------------
+
+ function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean
+ is
+ begin
+ return Present (Find_Aspect (Typ, Aspect_Storage_Model_Type));
+ end Has_Storage_Model_Type_Aspect;
+
+ --------------------------
+ -- Storage_Model_Object --
+ --------------------------
+
+ 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;
+ end Storage_Model_Object;
+
+ ------------------------
+ -- Storage_Model_Type --
+ ------------------------
+
+ 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;
+ end Storage_Model_Type;
+
+ --------------------------------
+ -- Storage_Model_Address_Type --
+ --------------------------------
+
+ function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id is
+ begin
+ return Get_Storage_Model_Type_Entity (Typ, Name_Address_Type);
+ end Storage_Model_Address_Type;
+
+ --------------------------------
+ -- Storage_Model_Null_Address --
+ --------------------------------
+
+ function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id is
+ begin
+ return Get_Storage_Model_Type_Entity (Typ, Name_Null_Address);
+ end Storage_Model_Null_Address;
+
+ ----------------------------
+ -- Storage_Model_Allocate --
+ ----------------------------
+
+ function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id is
+ begin
+ return Get_Storage_Model_Type_Entity (Typ, Name_Allocate);
+ end Storage_Model_Allocate;
+
+ ------------------------------
+ -- Storage_Model_Deallocate --
+ ------------------------------
+
+ function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id is
+ begin
+ return Get_Storage_Model_Type_Entity (Typ, Name_Deallocate);
+ end Storage_Model_Deallocate;
+
+ -----------------------------
+ -- Storage_Model_Copy_From --
+ -----------------------------
+
+ function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id is
+ begin
+ return Get_Storage_Model_Type_Entity (Typ, Name_Copy_From);
+ end Storage_Model_Copy_From;
+
+ ---------------------------
+ -- Storage_Model_Copy_To --
+ ---------------------------
+
+ function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id is
+ begin
+ return Get_Storage_Model_Type_Entity (Typ, Name_Copy_To);
+ end Storage_Model_Copy_To;
+
+ --------------------------------
+ -- Storage_Model_Storage_Size --
+ --------------------------------
+
+ function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id is
+ begin
+ return Get_Storage_Model_Type_Entity (Typ, Name_Storage_Size);
+ end Storage_Model_Storage_Size;
+
+ end Storage_Model_Support;
+
begin
Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access;
end Sem_Util;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 63f1d6bb10e..85010b57130 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -3550,4 +3550,76 @@ package Sem_Util is
end Indirect_Temps;
end Old_Attr_Util;
+
+ package Storage_Model_Support is
+
+ -- This package provides a set of utility functions related to support
+ -- 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
+ -- 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_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.
+
+ 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.
+
+ end Storage_Model_Support;
+
end Sem_Util;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 400adb03bae..8a98deef386 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -149,6 +149,7 @@ package Snames is
Name_Default_Value : constant Name_Id := N + $;
Name_Default_Component_Value : constant Name_Id := N + $;
+ Name_Designated_Storage_Model : constant Name_Id := N + $;
Name_Dimension : constant Name_Id := N + $;
Name_Dimension_System : constant Name_Id := N + $;
Name_Disable_Controlled : constant Name_Id := N + $;
@@ -162,6 +163,8 @@ package Snames is
Name_Relaxed_Initialization : constant Name_Id := N + $;
Name_Stable_Properties : constant Name_Id := N + $;
Name_Static_Predicate : constant Name_Id := N + $;
+ Name_Storage_Model : constant Name_Id := N + $;
+ Name_Storage_Model_Type : constant Name_Id := N + $;
Name_String_Literal : constant Name_Id := N + $;
Name_Synchronization : constant Name_Id := N + $;
Name_Unimplemented : constant Name_Id := N + $;
@@ -779,6 +782,7 @@ package Snames is
-- Other special names used in processing attributes, aspects, and pragmas
+ Name_Address_Type : constant Name_Id := N + $;
Name_Aggregate : constant Name_Id := N + $;
Name_Allow : constant Name_Id := N + $;
Name_Amount : constant Name_Id := N + $;
@@ -798,6 +802,8 @@ package Snames is
Name_Component : constant Name_Id := N + $;
Name_Component_Size_4 : constant Name_Id := N + $;
Name_Copy : constant Name_Id := N + $;
+ Name_Copy_From : constant Name_Id := N + $;
+ Name_Copy_To : constant Name_Id := N + $;
Name_D_Float : constant Name_Id := N + $;
Name_Decreases : constant Name_Id := N + $;
Name_Disable : constant Name_Id := N + $;
@@ -867,6 +873,7 @@ package Snames is
Name_Nominal : constant Name_Id := N + $;
Name_Non_Volatile : constant Name_Id := N + $;
Name_None : constant Name_Id := N + $;
+ Name_Null_Address : constant Name_Id := N + $;
Name_On : constant Name_Id := N + $;
Name_Optional : constant Name_Id := N + $;
Name_Policy : constant Name_Id := N + $;
More information about the Gcc-cvs
mailing list