[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.

9 files changed, 834 insertions, 5 deletions

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 11e0aeb..ab11bfd 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 d636cb0..8dcfa85 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 45de0fb..86cb702 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 eef278f..cb18096 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 eddf314..2b61132 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 4128554..fb1be47 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 072cd3f..b5f3d4c 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 63f1d6b..85010b5 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 400adb0..8a98dee 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 + $;