Merge branch 'master' into devel/sphinx

20 files changed, 1082 insertions, 93 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index be8371d..fc3bc97 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,150 @@
+2022-10-06  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/ada-tree.def (LOAD_EXPR): New expression code.
+	* gcc-interface/gigi.h (build_storage_model_load): Declare.
+	(build_storage_model_store): Likewise.
+	(instantiate_load_in_expr): Likewise.
+	(INSTANTIATE_LOAD_IN_EXPR): New macro.
+	(instantiate_load_in_array_ref): Declare.
+	* gcc-interface/decl.cc (gnat_to_gnu_entity) <E_Record_Type>: Set a
+	fake discriminant number on the fields of the template type.
+	(gnat_to_gnu_field): Use integer for DECL_DISCRIMINANT_NUMBER.
+	* gcc-interface/misc.cc (gnat_init_ts): Mark LOAD_EXPR as typed.
+	* gcc-interface/trans.cc (fold_constant_decl_in_expr) <ARRAY_REF>:
+	Also preserve the 4th operand.
+	(Attribute_to_gnu): Deal with LOAD_EXPR of unconstrained array type.
+	<Attr_Size>: Call INSTANTIATE_LOAD_IN_EXPR for a storage model.
+	<Attr_Length>: Likewise.
+	<Attr_Bit_Position>: Likewise.
+	(get_storage_model): New function.
+	(get_storage_model_access): Likewise.
+	(storage_model_access_required_p): Likewise.
+	(Call_to_gnu): Add GNAT_STORAGE_MODEL parameter and deal with it.
+	Also deal with actual parameters that have a storage model.
+	(gnat_to_gnu) <N_Object_Declaratio>: Adjust call to Call_to_gnu.
+	<N_Explicit_Dereference>: Deal with a storage model access.
+	<N_Indexed_Component>: Likewise.
+	<N_Slice>: Likewise.
+	<N_Selected_Component>: Likewise.
+	<N_Assignment_Statement>: Adjust call to Call_to_gnu.  Deal with a
+	storage model access either on the LHS, on the RHS or on both.
+	<N_Function_Cal>: Adjust call to Call_to_gnu.
+	<N_Free_Statement>: Deal with a pool that is a storage model.
+	Replace test for UNCONSTRAINED_ARRAY_REF with test on the type.
+	(gnat_gimplify_expr) <CALL_EXPR>: Tidy up.
+	<LOAD_EXPR>: New case.
+	<UNCONSTRAINED_ARRAY_REF>: Move down.
+	* gcc-interface/utils.cc (maybe_unconstrained_array): Deal with a
+	LOAD_EXPR by recursing on its first operand.
+	* gcc-interface/utils2.cc (build_allocator): Deal with a pool that
+	is a storage model.
+	(build_storage_model_copy): New function.
+	(build_storage_model_load): Likewise.
+	(build_storage_model_store): Likewise.
+	(instantiate_load_in_expr): Likewise.
+	(instantiate_load_in_array_ref): Likewise.
+	(gnat_rewrite_reference) <ARRAY_REF>: Also preserve the 4th operand.
+	(get_inner_constant_reference) <ARRAY_REF>: Remove useless test.
+	(gnat_invariant_expr) <ARRAY_REF>: Rewrite test.
+
+2022-10-06  Steve Baird  <baird@adacore.com>
+
+	* sem_ch6.adb
+	(Analyze_Procedure_Call): Replace "return;" with "goto Leave;", as
+	per comment preceding body of Analyze_Procedure_Call.
+
+2022-10-06  Piotr Trojanek  <trojanek@adacore.com>
+
+	* sem_ch9.adb (Allows_Lock_Free_Implementation): Reject
+	conditional goto statements.
+
+2022-10-06  Piotr Trojanek  <trojanek@adacore.com>
+
+	* doc/gnat_rm/implementation_defined_pragmas.rst
+	(Lock_Free): Remove inconsistent periods that end item
+	descriptions.
+	* sem_ch9.adb
+	(Allows_Lock_Free_Implementation): Remove unnecessary guard
+	against an empty list of parameters; replace low-level entity kind
+	membership test with a high-level query; refill error message.
+	* gnat_rm.texi: Regenerate.
+
+2022-10-06  Alexandre Oliva  <oliva@adacore.com>
+
+	* doc/gnat_rm/security_hardening_features.rst: Add examples of
+	codegen changes in hardened conditionals.
+	* gnat_rm.texi: Regenerate.
+
+2022-10-06  Alexandre Oliva  <oliva@adacore.com>
+
+	* doc/gnat_rm/security_hardening_features.rst: Add examples of
+	codegen changes in hardened booleans. Mention that C traps where
+	Ada raises exceptions.
+	* gnat_rm.texi: Regenerate.
+
+2022-10-06  Alexandre Oliva  <oliva@adacore.com>
+
+	* doc/gnat_rm/security_hardening_features.rst: Add examples of
+	codegen changes in stack scrubbing.
+	* gnat_rm.texi: Regenerate.
+
+2022-10-06  Piotr Trojanek  <trojanek@adacore.com>
+
+	* exp_ch9.adb (Build_Lock_Free_Protected_Subprogram_Body): Replace
+	shallow copy of protected statements with a deep copy.
+
+2022-10-06  Marc Poulhiès  <poulhies@adacore.com>
+
+	* fe.h (Has_Storage_Model_Type_Aspect)
+	(Has_Designated_Storage_Model_Aspect, Storage_Model_Object)
+	(Storage_Model_Copy_From, Storage_Model_Copy_To): Add
+	declarations.
+	* sem_util.ads: Add WARNING markers for functions for which a new
+	C declaration has been added in fe.h
+
+2022-10-06  Steve Baird  <baird@adacore.com>
+
+	* exp_util.adb
+	(Get_Current_Value_Condition): Treat references occurring within
+	the condition of an if statement, an elsif, or a while loop in the
+	same way as references that occur before the start of that
+	enclosing construct.
+
+2022-10-06  Gary Dismukes  <dismukes@adacore.com>
+
+	* sem_ch4.adb (Analyze_Call): Add test of Comes_From_Source on the
+	enclosing subprogram's Entity_Id for determining whether to
+	perform the compile-time accessibility check on actuals passed to
+	aliased formals in a function call occurring within a return
+	statement. That test excludes cases where the call occurs within
+	the return statement of a Pre'Class wrapper function.
+
+2022-10-06  Bob Duff  <duff@adacore.com>
+
+	* exp_ch5.adb
+	(Expand_Assign_Array_Loop_Or_Bitfield): Minor cleanups.
+
+2022-10-06  Yannick Moy  <moy@adacore.com>
+
+	* sem_prag.adb (Analyze_Pragma): Ignore one variant of pragma
+	Warnings in GNATprove mode.
+
+2022-10-06  Bob Duff  <duff@adacore.com>
+
+	* exp_ch5.adb
+	(Expand_Assign_Array_Loop_Or_Bitfield): Disable the
+	Fast_Copy_Bitfield optimization in certain cases.
+
+2022-10-06  Piotr Trojanek  <trojanek@adacore.com>
+
+	* sem_prag.adb
+	(Sig_Pragma): Change flag for pragma Refined_State to mean "not
+	significant"; this is primarily for documentation, because the
+	exact value of the flag is not really taken into account for
+	Refined_State.
+	(Is_Non_Significant_Pragma_Reference): Add special handling for
+	pragma Refined_State.
+
 2022-09-29  Ronan Desplanques  <desplanques@adacore.com>
 
 	* einfo.ads: remove documentation duplicate
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 53836c9..6752d48 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -3744,10 +3744,10 @@ In addition, each protected subprogram body must satisfy:
 
 * May reference only one protected component
 * May not reference nonconstant entities outside the protected subprogram
-  scope.
+  scope
 * May not contain address representation items, allocators, or quantified
-  expressions.
-* May not contain delay, goto, loop, or procedure-call statements.
+  expressions
+* May not contain delay, goto, loop, or procedure-call statements
 * May not contain exported and imported entities
 * May not dereferenced access values
 * Function calls and attribute references must be static
diff --git a/gcc/ada/doc/gnat_rm/security_hardening_features.rst b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
index f5fdc8e..d7c02b9 100644
--- a/gcc/ada/doc/gnat_rm/security_hardening_features.rst
+++ b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
@@ -74,6 +74,58 @@ or a variable.)
      --  scrubbing of the stack space used by that subprogram.
 
 
+Given these declarations, Foo has its type and body modified as
+follows:
+
+.. code-block:: ada
+
+     function Foo (<WaterMark> : in out System.Address) returns Integer
+     is
+       --  ...
+     begin
+       <__strub_update> (<WaterMark>);  --  Updates the stack WaterMark.
+       --  ...
+     end;
+
+
+whereas its callers are modified from:
+
+.. code-block:: ada
+
+     X := Foo;
+
+to:
+
+.. code-block:: ada
+
+     declare
+       <WaterMark> : System.Address;
+     begin
+       <__strub_enter> (<WaterMark>);  -- Initialize <WaterMark>.
+       X := Foo (<WaterMark>);
+       <__strub_leave> (<WaterMark>);  -- Scrubs stack up to <WaterMark>.
+     end;
+
+
+As for Bar, because it is strubbed in internal mode, its callers are
+not modified.  Its definition is modified roughly as follows:
+
+.. code-block:: ada
+
+     procedure Bar is
+       <WaterMark> : System.Address;
+       procedure Strubbed_Bar (<WaterMark> : in out System.Address) is
+       begin
+         <__strub_update> (<WaterMark>);  --  Updates the stack WaterMark.
+         -- original Bar body.
+       end Strubbed_Bar;
+     begin
+       <__strub_enter> (<WaterMark>);  -- Initialize <WaterMark>.
+       Strubbed_Bar (<WaterMark>);
+       <__strub_leave> (<WaterMark>);  -- Scrubs stack up to <WaterMark>.
+     end Bar;
+
+
 There are also :switch:`-fstrub={choice}` command-line options to
 control default settings.  For usage and more details on the
 command-line options, on the ``strub`` attribute, and their use with
@@ -151,11 +203,58 @@ activated by a separate command-line option.
 
 The option :switch:`-fharden-compares` enables hardening of compares
 that compute results stored in variables, adding verification that the
-reversed compare yields the opposite result.
+reversed compare yields the opposite result, turning:
+
+.. code-block:: ada
+
+    B := X = Y;
+
+
+into:
+
+.. code-block:: ada
+
+    B := X = Y;
+    declare
+      NotB : Boolean := X /= Y; -- Computed independently of B.
+    begin
+      if B = NotB then
+        <__builtin_trap>;
+      end if;
+    end;
+
 
 The option :switch:`-fharden-conditional-branches` enables hardening
 of compares that guard conditional branches, adding verification of
-the reversed compare to both execution paths.
+the reversed compare to both execution paths, turning:
+
+.. code-block:: ada
+
+    if X = Y then
+      X := Z + 1;
+    else
+      Y := Z - 1;
+    end if;
+
+
+into:
+
+.. code-block:: ada
+
+    if X = Y then
+      if X /= Y then -- Computed independently of X = Y.
+        <__builtin_trap>;
+      end if;
+      X := Z + 1;
+    else
+      if X /= Y then -- Computed independently of X = Y.
+        null;
+      else
+        <__builtin_trap>;
+      end if;
+      Y := Z - 1;
+    end if;
+
 
 These transformations are introduced late in the compilation pipeline,
 long after boolean expressions are decomposed into separate compares,
@@ -213,19 +312,40 @@ further remove checks found to be redundant.
 For additional hardening, the ``hardbool`` :samp:`Machine_Attribute`
 pragma can be used to annotate boolean types with representation
 clauses, so that expressions of such types used as conditions are
-checked even when compiling with :switch:`-gnatVT`.
+checked even when compiling with :switch:`-gnatVT`:
 
 .. code-block:: ada
 
    pragma Machine_Attribute (HBool, "hardbool");
 
+   function To_Boolean (X : HBool) returns Boolean is (Boolean (X));
+
+
+is compiled roughly like:
+
+.. code-block:: ada
+
+   function To_Boolean (X : HBool) returns Boolean is
+   begin
+     if X not in True | False then
+       raise Constraint_Error;
+     elsif X in True then
+       return True;
+     else
+       return False;
+     end if;
+   end To_Boolean;
+
 
 Note that :switch:`-gnatVn` will disable even ``hardbool`` testing.
 
 Analogous behavior is available as a GCC extension to the C and
-Objective C programming languages, through the ``hardbool`` attribute.
-For usage and more details on that attribute, see :title:`Using the
-GNU Compiler Collection (GCC)`.
+Objective C programming languages, through the ``hardbool`` attribute,
+with the difference that, instead of raising a Constraint_Error
+exception, when a hardened boolean variable is found to hold a value
+that stands for neither True nor False, the program traps.  For usage
+and more details on that attribute, see :title:`Using the GNU Compiler
+Collection (GCC)`.
 
 
 .. Control Flow Redundancy:
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 209741c..d5d66d9 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -1632,7 +1632,10 @@ package body Exp_Ch5 is
          end if;
 
          if Is_Array_Type (Typ) then
-            return Volatile_Or_Independent (Empty, Component_Type (Typ));
+            if Volatile_Or_Independent (Empty, Component_Type (Typ)) then
+               return True;
+            end if;
+
          elsif Is_Record_Type (Typ) then
             declare
                Comp : Entity_Id := First_Component (Typ);
@@ -1660,6 +1663,15 @@ package body Exp_Ch5 is
          return False;
       end Volatile_Or_Independent;
 
+      function Slice_Of_Packed_Component (L : Node_Id) return Boolean is
+        (Nkind (L) = N_Slice
+         and then Nkind (Prefix (L)) = N_Indexed_Component
+         and then Is_Bit_Packed_Array (Etype (Prefix (Prefix (L)))));
+      --  L is the left-hand side Name. Returns True if L is a slice of a
+      --  component of a bit-packed array. The optimization is disabled in
+      --  that case, because Expand_Assign_Array_Bitfield_Fast cannot
+      --  currently handle that case correctly.
+
       L : constant Node_Id := Name (N);
       R : constant Node_Id := Expression (N);
       --  Left- and right-hand sides of the assignment statement
@@ -1679,8 +1691,8 @@ package body Exp_Ch5 is
         and then Is_Bit_Packed_Array (R_Type)
         and then not Reverse_Storage_Order (L_Type)
         and then not Reverse_Storage_Order (R_Type)
-        and then Ndim = 1
         and then Slices
+        and then not Slice_Of_Packed_Component (L)
         and then not Volatile_Or_Independent (L, L_Type)
         and then not Volatile_Or_Independent (R, R_Type)
       then
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 8abff55..decf617 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -2797,7 +2797,7 @@ package body Exp_Ch9 is
             Expected_Comp : Entity_Id;
             Stmt          : Node_Id;
             Stmts         : List_Id :=
-                              New_Copy_List (Statements (Hand_Stmt_Seq));
+                              New_Copy_List_Tree (Statements (Hand_Stmt_Seq));
             Typ_Size      : Int;
             Unsigned      : Entity_Id;
 
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 61395ad..f569d2e 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6923,6 +6923,11 @@ package body Exp_Util is
             if Loc < Sloc (CV) then
                return;
 
+            --  In condition of IF statement
+
+            elsif In_Subtree (N => Var, Root => Condition (CV)) then
+               return;
+
             --  After end of IF statement
 
             elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
@@ -7009,7 +7014,12 @@ package body Exp_Util is
             if Loc < Sloc (CV) then
                return;
 
-               --  After end of IF statement
+            --  In condition of ELSIF part
+
+            elsif In_Subtree (N => Var, Root => Condition (CV)) then
+               return;
+
+            --  After end of IF statement
 
             elsif Loc >= Sloc (Stm) +
               Text_Ptr (UI_To_Int (End_Span (Stm)))
@@ -7066,6 +7076,11 @@ package body Exp_Util is
                if Loc < Sloc (Loop_Stmt) then
                   return;
 
+               --  In condition of while loop
+
+               elsif In_Subtree (N => Var, Root => Condition (CV)) then
+                  return;
+
                --  After end of LOOP statement
 
                elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index 02cf105..79a1b58 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -304,17 +304,27 @@ extern Boolean Compile_Time_Known_Value	(Node_Id);
 
 #define Defining_Entity			sem_util__defining_entity
 #define First_Actual			sem_util__first_actual
+#define Has_Storage_Model_Type_Aspect	sem_util__storage_model_support__has_storage_model_type_aspect
+#define Has_Designated_Storage_Model_Aspect sem_util__storage_model_support__has_designated_storage_model_aspect
 #define Is_Expression_Function		sem_util__is_expression_function
 #define Is_Variable_Size_Record 	sem_util__is_variable_size_record
 #define Needs_Secondary_Stack		sem_util__needs_secondary_stack
 #define Next_Actual			sem_util__next_actual
+#define Storage_Model_Object 		sem_util__storage_model_support__storage_model_object
+#define Storage_Model_Copy_From 	sem_util__storage_model_support__storage_model_copy_from
+#define Storage_Model_Copy_To 		sem_util__storage_model_support__storage_model_copy_to
 
 extern Entity_Id Defining_Entity		(Node_Id);
 extern Node_Id First_Actual			(Node_Id);
+extern Boolean Has_Storage_Model_Type_Aspect	(Entity_Id);
+extern Boolean Has_Designated_Storage_Model_Aspect (Entity_Id);
 extern Boolean Is_Expression_Function		(Entity_Id);
 extern Boolean Is_Variable_Size_Record 		(Entity_Id);
 extern Boolean Needs_Secondary_Stack		(Entity_Id);
 extern Node_Id Next_Actual			(Node_Id);
+extern Entity_Id Storage_Model_Object		(Entity_Id);
+extern Entity_Id Storage_Model_Copy_From	(Entity_Id);
+extern Entity_Id Storage_Model_Copy_To 		(Entity_Id);
 
 /* sinfo: */
 
diff --git a/gcc/ada/gcc-interface/ada-tree.def b/gcc/ada/gcc-interface/ada-tree.def
index 8eb4688..7fc95cb 100644
--- a/gcc/ada/gcc-interface/ada-tree.def
+++ b/gcc/ada/gcc-interface/ada-tree.def
@@ -35,6 +35,10 @@ DEFTREECODE (UNCONSTRAINED_ARRAY_TYPE, "unconstrained_array_type", tcc_type, 0)
 DEFTREECODE (UNCONSTRAINED_ARRAY_REF, "unconstrained_array_ref",
 	     tcc_reference, 1)
 
+/* Same as SAVE_EXPR, but operand 1 contains the statement used to initialize
+   the temporary instead of using the value of operand 0 directly.  */
+DEFTREECODE (LOAD_EXPR, "load_expr", tcc_expression, 2)
+
 /* An expression that returns an RTL suitable for its type.  Operand 0
    is an expression to be evaluated for side effects only.  */
 DEFTREECODE (NULL_EXPR, "null_expr", tcc_expression, 1)
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index c5a93fb..f8c7698 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -2279,6 +2279,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 					      gnu_index_type,
 					      gnu_template_type, NULL_TREE,
 					      NULL_TREE, 0, 0);
+	    /* Mark the field specifically for INSTANTIATE_LOAD_IN_EXPR.  */
+	    DECL_DISCRIMINANT_NUMBER (gnu_lb_field) = integer_minus_one_node;
 	    Sloc_to_locus (Sloc (gnat_entity),
 			   &DECL_SOURCE_LOCATION (gnu_lb_field));
 
@@ -2287,6 +2289,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
 					      gnu_index_type,
 					      gnu_template_type, NULL_TREE,
 					      NULL_TREE, 0, 0);
+	    /* Mark the field specifically for INSTANTIATE_LOAD_IN_EXPR.  */
+	    DECL_DISCRIMINANT_NUMBER (gnu_hb_field) = integer_minus_one_node;
 	    Sloc_to_locus (Sloc (gnat_entity),
 			   &DECL_SOURCE_LOCATION (gnu_hb_field));
 
@@ -7694,7 +7698,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
   if (Ekind (gnat_field) == E_Discriminant)
     {
       DECL_DISCRIMINANT_NUMBER (gnu_field)
-	= UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
+	= UI_To_gnu (Discriminant_Number (gnat_field), integer_type_node);
       DECL_INVARIANT_P (gnu_field)
 	= No (Discriminant_Default_Value (gnat_field));
       DECL_NONADDRESSABLE_P (gnu_field) = 0;
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 1c1397a..82e2403 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -912,6 +912,34 @@ extern tree build_allocator (tree type, tree init, tree result_type,
                              Entity_Id gnat_proc, Entity_Id gnat_pool,
                              Node_Id gnat_node, bool);
 
+/* Build a load of SRC using the storage model of GNAT_SMO.  */
+extern tree build_storage_model_load (Entity_Id gnat_smo, tree src);
+
+/* Build a load of SRC into DEST using the storage model of GNAT_SMO.
+   If SIZE is specified, use it, otherwise use the size of SRC.  */
+extern tree build_storage_model_load (Entity_Id gnat_smo, tree dest, tree src,
+				      tree size = NULL_TREE);
+
+/* Build a store of SRC into DEST using the storage model of GNAT_SMO.
+   If SIZE is specified, use it, otherwise use the size of DEST.  */
+extern tree build_storage_model_store (Entity_Id gnat_smo, tree dest, tree src,
+				       tree size = NULL_TREE);
+
+/* Given a tree EXP, instantiate occurrences of LOAD_EXPR in it and associate
+   them with the storage model of GNAT_SMO.  */
+extern tree instantiate_load_in_expr (tree exp, Entity_Id gnat_smo);
+
+/* This macro calls the above function but short-circuits the common
+   case of a constant to save time and also checks for NULL.  */
+
+#define INSTANTIATE_LOAD_IN_EXPR(EXP, GNAT_SMO) \
+  ((EXP) == NULL_TREE || TREE_CONSTANT (EXP) ? (EXP)	\
+   : instantiate_load_in_expr (EXP, GNAT_SMO))
+
+/* Given an array or slice reference, instantiate occurrences of LOAD_EXPR in
+   it and associate them with the storage model of GNAT_SMO.  */
+extern void instantiate_load_in_array_ref (tree ref, Entity_Id gnat_smo);
+
 /* Indicate that we need to take the address of T and that it therefore
    should not be allocated in a register.  Returns true if successful.  */
 extern bool gnat_mark_addressable (tree t);
diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc
index f0ca197..e1b5a43 100644
--- a/gcc/ada/gcc-interface/misc.cc
+++ b/gcc/ada/gcc-interface/misc.cc
@@ -1309,6 +1309,7 @@ gnat_init_ts (void)
   MARK_TS_COMMON (UNCONSTRAINED_ARRAY_TYPE);
 
   MARK_TS_TYPED (UNCONSTRAINED_ARRAY_REF);
+  MARK_TS_TYPED (LOAD_EXPR);
   MARK_TS_TYPED (NULL_EXPR);
   MARK_TS_TYPED (PLUS_NOMOD_EXPR);
   MARK_TS_TYPED (MINUS_NOMOD_EXPR);
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index 2d93947..d0ff741 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -1033,7 +1033,7 @@ fold_constant_decl_in_expr (tree exp)
 	return exp;
 
       return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
-			   TREE_OPERAND (exp, 2), NULL_TREE));
+			   TREE_OPERAND (exp, 2), TREE_OPERAND (exp, 3)));
 
     case REALPART_EXPR:
     case IMAGPART_EXPR:
@@ -1671,6 +1671,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
   tree gnu_type = TREE_TYPE (gnu_prefix);
   tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
   bool prefix_unused = false;
+  Entity_Id gnat_smo;
 
   /* If the input is a NULL_EXPR, make a new one.  */
   if (TREE_CODE (gnu_prefix) == NULL_EXPR)
@@ -1680,6 +1681,14 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
       return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
     }
 
+  /* If the input is a LOAD_EXPR of an unconstrained array type, the second
+     operand contains the storage model object.  */
+  if (TREE_CODE (gnu_prefix) == LOAD_EXPR
+      && TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
+    gnat_smo = tree_to_shwi (TREE_OPERAND (gnu_prefix, 1));
+  else
+    gnat_smo = Empty;
+
   switch (attribute)
     {
     case Attr_Pred:
@@ -1960,7 +1969,11 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
       /* Deal with a self-referential size by qualifying the size with the
 	 object or returning the maximum size for a type.  */
       if (TREE_CODE (gnu_prefix) != TYPE_DECL)
-	gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
+	{
+	  gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
+	  if (Present (gnat_smo))
+	    gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
+	}
       else if (CONTAINS_PLACEHOLDER_P (gnu_result))
 	gnu_result = max_size (gnu_result, true);
 
@@ -2191,6 +2204,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	   handling.  Note that these attributes could not have been used on
 	   an unconstrained array type.  */
 	gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
+	if (Present (gnat_smo))
+	  gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
 
 	/* Cache the expression we have just computed.  Since we want to do it
 	   at run time, we force the use of a SAVE_EXPR and let the gimplifier
@@ -2351,6 +2366,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	/* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
 	   handling.  */
 	gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
+	if (Present (gnat_smo))
+	  gnu_result = INSTANTIATE_LOAD_IN_EXPR (gnu_result, gnat_smo);
 	break;
       }
 
@@ -4356,6 +4373,49 @@ simple_atomic_access_required_p (Node_Id gnat_node, bool *sync)
   return type == SIMPLE_ATOMIC;
 }
 
+/* Return the storage model specified by GNAT_NODE, or else Empty.  */
+
+static Entity_Id
+get_storage_model (Node_Id gnat_node)
+{
+  if (Nkind (gnat_node) == N_Explicit_Dereference
+      && Has_Designated_Storage_Model_Aspect (Etype (Prefix (gnat_node))))
+    return Storage_Model_Object (Etype (Prefix (gnat_node)));
+  else
+    return Empty;
+}
+
+/* Compute whether GNAT_NODE requires storage model access and set GNAT_SMO to
+   the storage model object to be used for it if it does, or else Empty.  */
+
+static void
+get_storage_model_access (Node_Id gnat_node, Entity_Id *gnat_smo)
+{
+  const Node_Id gnat_parent = Parent (gnat_node);
+
+  /* If we are the prefix of the parent, then the access is above us.  */
+  if (node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_node)
+    {
+      *gnat_smo = Empty;
+      return;
+    }
+
+  while (node_is_component (gnat_node))
+    gnat_node = Prefix (gnat_node);
+
+  *gnat_smo = get_storage_model (gnat_node);
+}
+
+/* Return true if GNAT_NODE requires storage model access and, if so, set
+   GNAT_SMO to the storage model object to be used for it.  */
+
+static bool
+storage_model_access_required_p (Node_Id gnat_node, Entity_Id *gnat_smo)
+{
+  get_storage_model_access (gnat_node, gnat_smo);
+  return Present (*gnat_smo);
+}
+
 /* Create a temporary variable with PREFIX and TYPE, and return it.  */
 
 static tree
@@ -4471,11 +4531,14 @@ elaborate_profile (Entity_Id first_formal, Entity_Id result_type)
    N_Assignment_Statement and the result is to be placed into that object.
    ATOMIC_ACCESS is the type of atomic access to be used for the assignment
    to GNU_TARGET.  If, in addition, ATOMIC_SYNC is true, then the assignment
-   to GNU_TARGET requires atomic synchronization.  */
+   to GNU_TARGET requires atomic synchronization.  GNAT_STORAGE_MODEL is the
+   storage model object to be used for the assignment to GNU_TARGET or Empty
+   if there is none.  */
 
 static tree
 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
-	     atomic_acces_t atomic_access, bool atomic_sync)
+	     atomic_acces_t atomic_access, bool atomic_sync,
+	     Entity_Id gnat_storage_model)
 {
   const bool function_call = (Nkind (gnat_node) == N_Function_Call);
   const bool returning_value = (function_call && !gnu_target);
@@ -4507,6 +4570,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
   Node_Id gnat_actual;
   atomic_acces_t aa_type;
   bool aa_sync;
+  Entity_Id gnat_smo;
 
   /* The only way we can make a call via an access type is if GNAT_NAME is an
      explicit dereference.  In that case, get the list of formal args from the
@@ -4624,7 +4688,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	  unconstrained record type with default discriminant, because the
 	  return may copy more data than the bit-field can contain.
 
-       5. There is no target and we have misaligned In Out or Out parameters
+       5. There is a target which needs to be accessed with a storage model.
+
+       6. There is no target and we have misaligned In Out or Out parameters
 	  passed by reference, because we need to preserve the return value
 	  before copying back the parameters.  However, in this case, we'll
 	  defer creating the temporary, see below.
@@ -4654,7 +4720,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	      && DECL_BIT_FIELD (TREE_OPERAND (gnu_target, 1))
 	      && DECL_SIZE (TREE_OPERAND (gnu_target, 1))
 		 != TYPE_SIZE (TREE_TYPE (gnu_target))
-	      && type_is_padding_self_referential (gnu_result_type))))
+	      && type_is_padding_self_referential (gnu_result_type))
+	  || (gnu_target
+	      && Present (gnat_storage_model)
+	      && Present (Storage_Model_Copy_To (gnat_storage_model)))))
     {
       gnu_retval = create_temporary ("R", gnu_result_type);
       DECL_RETURN_VALUE_P (gnu_retval) = 1;
@@ -4725,12 +4794,19 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	      = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
 	}
 
-      /* If we are passing a non-addressable parameter by reference, pass the
-	 address of a copy.  In the In Out or Out case, set up to copy back
-	 out after the call.  */
+      get_storage_model_access (gnat_actual, &gnat_smo);
+
+      /* If we are passing a non-addressable actual parameter by reference,
+	 pass the address of a copy.  Likewise if it needs to be accessed with
+	 a storage model.  In the In Out or Out case, set up to copy back out
+	 after the call.  */
       if (is_by_ref_formal_parm
 	  && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
-	  && !addressable_p (gnu_name, gnu_name_type))
+	  && (!addressable_p (gnu_name, gnu_name_type)
+	      || (Present (gnat_smo)
+		  && (Present (Storage_Model_Copy_From (gnat_smo))
+		      || (!in_param
+			  && Present (Storage_Model_Copy_To (gnat_smo)))))))
 	{
 	  tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
 
@@ -4801,20 +4877,40 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	    }
 
 	  /* Create an explicit temporary holding the copy.  */
+	  tree gnu_temp_type;
+	  if (Nkind (gnat_actual) == N_Explicit_Dereference
+	      && Present (Actual_Designated_Subtype (gnat_actual)))
+	    gnu_temp_type
+	      = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_actual));
+	  else
+	    gnu_temp_type = TREE_TYPE (gnu_name);
+
 	  /* Do not initialize it for the _Init parameter of an initialization
 	     procedure since no data is meant to be passed in.  */
 	  if (Ekind (gnat_formal) == E_Out_Parameter
 	      && Is_Entity_Name (gnat_subprog)
 	      && Is_Init_Proc (Entity (gnat_subprog)))
-	    gnu_name = gnu_temp = create_temporary ("A", TREE_TYPE (gnu_name));
+	    gnu_name = gnu_temp = create_temporary ("A", gnu_temp_type);
 
 	  /* Initialize it on the fly like for an implicit temporary in the
 	     other cases, as we don't necessarily have a statement list.  */
 	  else
 	    {
-	      gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt,
-						gnat_actual);
-	      gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
+	      if (Present (gnat_smo)
+		  && Present (Storage_Model_Copy_From (gnat_smo)))
+		{
+		  gnu_temp = create_temporary ("A", gnu_temp_type);
+		  gnu_stmt
+		    = build_storage_model_load (gnat_smo, gnu_temp,
+						gnu_name,
+						TYPE_SIZE_UNIT (gnu_temp_type));
+		  set_expr_location_from_node (gnu_stmt, gnat_actual);
+		}
+	      else
+		gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt,
+						  gnat_actual);
+
+	      gnu_name = build_compound_expr (gnu_temp_type, gnu_stmt,
 					      gnu_temp);
 	    }
 
@@ -4830,8 +4926,16 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 		     (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
 		gnu_orig = TREE_OPERAND (gnu_orig, 2);
 
-	      gnu_stmt
-		= build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
+	      if (Present (gnat_smo)
+		  && Present (Storage_Model_Copy_To (gnat_smo)))
+		gnu_stmt
+		  = build_storage_model_store (gnat_smo, gnu_orig,
+					       gnu_temp,
+					       TYPE_SIZE_UNIT (gnu_temp_type));
+	      else
+		gnu_stmt
+		  = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig,
+				     gnu_temp);
 	      set_expr_location_from_node (gnu_stmt, gnat_node);
 
 	      append_to_statement_list (gnu_stmt, &gnu_after_list);
@@ -4842,12 +4946,19 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
       tree gnu_actual = gnu_name;
 
       /* If atomic access is required for an In or In Out actual parameter,
-	 build the atomic load.  */
+	 build the atomic load.  Or else, if storage model access is required,
+	 build the special load.  */
       if (is_true_formal_parm
 	  && !is_by_ref_formal_parm
-	  && Ekind (gnat_formal) != E_Out_Parameter
-	  && simple_atomic_access_required_p (gnat_actual, &aa_sync))
-	gnu_actual = build_atomic_load (gnu_actual, aa_sync);
+	  && Ekind (gnat_formal) != E_Out_Parameter)
+	{
+	  if (simple_atomic_access_required_p (gnat_actual, &aa_sync))
+	    gnu_actual = build_atomic_load (gnu_actual, aa_sync);
+
+	  else if (Present (gnat_smo)
+		   && Present (Storage_Model_Copy_From (gnat_smo)))
+	    gnu_actual = build_storage_model_load (gnat_smo, gnu_actual);
+	}
 
       /* If this was a procedure call, we may not have removed any padding.
 	 So do it here for the part we will use as an input, if any.  */
@@ -5211,6 +5322,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	      }
 
 	    get_atomic_access (gnat_actual, &aa_type, &aa_sync);
+	    get_storage_model_access (gnat_actual, &gnat_smo);
 
 	    /* If an outer atomic access is required for an actual parameter,
 	       build the load-modify-store sequence.  */
@@ -5224,6 +5336,13 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	      gnu_result
 		= build_atomic_store (gnu_actual, gnu_result, aa_sync);
 
+	    /* Or else, if a storage model access is required, build the special
+	       store.  */
+	    else if (Present (gnat_smo)
+		     && Present (Storage_Model_Copy_To (gnat_smo)))
+	      gnu_result
+		= build_storage_model_store (gnat_smo, gnu_actual, gnu_result);
+
 	    /* Otherwise build a regular assignment.  */
 	    else
 	      gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
@@ -5298,6 +5417,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	      = build_load_modify_store (gnu_target, gnu_call, gnat_node);
 	  else if (atomic_access == SIMPLE_ATOMIC)
 	    gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
+	  else if (Present (gnat_storage_model)
+		   && Present (Storage_Model_Copy_To (gnat_storage_model)))
+	    gnu_call
+	      = build_storage_model_store (gnat_storage_model, gnu_target,
+					   gnu_call);
 	  else
 	    gnu_call
 	      = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
@@ -6104,6 +6228,7 @@ gnat_to_gnu (Node_Id gnat_node)
   atomic_acces_t aa_type;
   bool went_into_elab_proc;
   bool aa_sync;
+  Entity_Id gnat_smo;
 
   /* Save node number for error message and set location information.  */
   if (Sloc (gnat_node) > No_Location)
@@ -6376,7 +6501,7 @@ gnat_to_gnu (Node_Id gnat_node)
 	  gnu_result
 	    = Call_to_gnu (Prefix (Expression (gnat_node)),
 			   &gnu_result_type, gnu_result,
-			   NOT_ATOMIC, false);
+			   NOT_ATOMIC, false, Empty);
 	  break;
 	}
 
@@ -6522,15 +6647,25 @@ gnat_to_gnu (Node_Id gnat_node)
       if (simple_atomic_access_required_p (gnat_node, &aa_sync)
 	  && !present_in_lhs_or_actual_p (gnat_node))
 	gnu_result = build_atomic_load (gnu_result, aa_sync);
+
+      /* If storage model access is required on the RHS, build the load.  */
+      else if (storage_model_access_required_p (gnat_node, &gnat_smo)
+	       && Present (Storage_Model_Copy_From (gnat_smo))
+	       && !present_in_lhs_or_actual_p (gnat_node))
+	gnu_result = build_storage_model_load (gnat_smo, gnu_result);
       break;
 
     case N_Indexed_Component:
       {
-	tree gnu_array_object = gnat_to_gnu ((Prefix (gnat_node)));
+	const Entity_Id gnat_array_object = Prefix (gnat_node);
+	tree gnu_array_object = gnat_to_gnu (gnat_array_object);
 	tree gnu_type;
 	int ndim, i;
 	Node_Id *gnat_expr_array;
 
+	/* Get the storage model of the array.  */
+	gnat_smo = get_storage_model (gnat_array_object);
+
 	gnu_array_object = maybe_padded_object (gnu_array_object);
 	gnu_array_object = maybe_unconstrained_array (gnu_array_object);
 
@@ -6582,6 +6717,9 @@ gnat_to_gnu (Node_Id gnat_node)
 
 	    gnu_result
 	      = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
+
+	    if (Present (gnat_smo))
+	      instantiate_load_in_array_ref (gnu_result, gnat_smo);
 	  }
 
 	gnu_result_type = get_unpadded_type (Etype (gnat_node));
@@ -6590,18 +6728,28 @@ gnat_to_gnu (Node_Id gnat_node)
 	if (simple_atomic_access_required_p (gnat_node, &aa_sync)
 	    && !present_in_lhs_or_actual_p (gnat_node))
 	  gnu_result = build_atomic_load (gnu_result, aa_sync);
+
+	/* If storage model access is required on the RHS, build the load.  */
+	else if (storage_model_access_required_p (gnat_node, &gnat_smo)
+		 && Present (Storage_Model_Copy_From (gnat_smo))
+		 && !present_in_lhs_or_actual_p (gnat_node))
+	  gnu_result = build_storage_model_load (gnat_smo, gnu_result);
       }
       break;
 
     case N_Slice:
       {
-	tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
+	const Entity_Id gnat_array_object = Prefix (gnat_node);
+	tree gnu_array_object = gnat_to_gnu (gnat_array_object);
 
-	gnu_result_type = get_unpadded_type (Etype (gnat_node));
+	/* Get the storage model of the array.  */
+	gnat_smo = get_storage_model (gnat_array_object);
 
 	gnu_array_object = maybe_padded_object (gnu_array_object);
 	gnu_array_object = maybe_unconstrained_array (gnu_array_object);
 
+	gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
 	gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
 	gnu_expr = maybe_character_value (gnu_expr);
 
@@ -6614,6 +6762,15 @@ gnat_to_gnu (Node_Id gnat_node)
 
 	gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
 				      gnu_array_object, gnu_expr);
+
+	if (Present (gnat_smo))
+	  instantiate_load_in_array_ref (gnu_result, gnat_smo);
+
+	/* If storage model access is required on the RHS, build the load.  */
+	if (storage_model_access_required_p (gnat_node, &gnat_smo)
+	    && Present (Storage_Model_Copy_From (gnat_smo))
+	    && !present_in_lhs_or_actual_p (gnat_node))
+	  gnu_result = build_storage_model_load (gnat_smo, gnu_result);
       }
       break;
 
@@ -6691,6 +6848,12 @@ gnat_to_gnu (Node_Id gnat_node)
 	if (simple_atomic_access_required_p (gnat_node, &aa_sync)
 	    && !present_in_lhs_or_actual_p (gnat_node))
 	  gnu_result = build_atomic_load (gnu_result, aa_sync);
+
+	/* If storage model access is required on the RHS, build the load.  */
+	else if (storage_model_access_required_p (gnat_node, &gnat_smo)
+		 && Present (Storage_Model_Copy_From (gnat_smo))
+		 && !present_in_lhs_or_actual_p (gnat_node))
+	  gnu_result = build_storage_model_load (gnat_smo, gnu_result);
       }
       break;
 
@@ -7224,9 +7387,10 @@ gnat_to_gnu (Node_Id gnat_node)
       else if (Nkind (Expression (gnat_node)) == N_Function_Call)
 	{
 	  get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
+	  get_storage_model_access (Name (gnat_node), &gnat_smo);
 	  gnu_result
 	    = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
-			   aa_type, aa_sync);
+			   aa_type, aa_sync, gnat_smo);
 	}
 
       /* Otherwise we need to build the assignment statement manually.  */
@@ -7264,6 +7428,7 @@ gnat_to_gnu (Node_Id gnat_node)
 	  gigi_checking_assert (!Do_Range_Check (gnat_expr));
 
 	  get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
+	  get_storage_model_access (Name (gnat_node), &gnat_smo);
 
 	  /* If an outer atomic access is required on the LHS, build the load-
 	     modify-store sequence.  */
@@ -7275,6 +7440,43 @@ gnat_to_gnu (Node_Id gnat_node)
 	  else if (aa_type == SIMPLE_ATOMIC)
 	    gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, aa_sync);
 
+	  /* Or else, if a storage model access is required, build the special
+	     store.  */
+	  else if (Present (gnat_smo)
+		   && Present (Storage_Model_Copy_To (gnat_smo)))
+	    {
+	      tree t = remove_conversions (gnu_rhs, false);
+
+	      /* If a storage model load is present on the RHS then instantiate
+		 the temporary associated with it now, lest it be of variable
+		 size and thus could not be instantiated by gimplification.  */
+	      if (TREE_CODE (t) == LOAD_EXPR)
+		{
+		  t = TREE_OPERAND (t, 1);
+		  gcc_assert (TREE_CODE (t) == CALL_EXPR);
+
+		  tree elem
+		    = build_nonstandard_integer_type (BITS_PER_UNIT, 1);
+		  tree size = fold_convert (sizetype, CALL_EXPR_ARG (t, 3));
+		  tree index = build_index_type (size);
+		  tree temp
+		    = create_temporary ("L", build_array_type (elem, index));
+		  tree arg = CALL_EXPR_ARG (t, 1);
+		  CALL_EXPR_ARG (t, 1)
+		    = build_unary_op (ADDR_EXPR, TREE_TYPE (arg), temp);
+
+		  start_stmt_group ();
+		  add_stmt (t);
+		  t = build_storage_model_store (gnat_smo, gnu_lhs, temp);
+		  add_stmt (t);
+		  gnu_result = end_stmt_group ();
+		}
+
+	      else
+		gnu_result
+		  = build_storage_model_store (gnat_smo, gnu_lhs, gnu_rhs);
+	    }
+
 	  /* Or else, use memset when the conditions are met.  This has already
 	     been validated by Aggr_Assignment_OK_For_Backend in the front-end
 	     and the RHS is thus guaranteed to be of the appropriate form.  */
@@ -7307,10 +7509,27 @@ gnat_to_gnu (Node_Id gnat_node)
 							 gnat_node);
 	    }
 
-	  /* Otherwise build a regular assignment.  */
 	  else
-	    gnu_result
-	      = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
+	    {
+	      tree t = remove_conversions (gnu_rhs, false);
+
+	      /* If a storage model load is present on the RHS, then elide the
+		 temporary associated with it.  */
+	      if (TREE_CODE (t) == LOAD_EXPR)
+		{
+		  gnu_result = TREE_OPERAND (t, 1);
+		  gcc_assert (TREE_CODE (gnu_result) == CALL_EXPR);
+
+		  tree arg = CALL_EXPR_ARG (gnu_result, 1);
+		  CALL_EXPR_ARG (gnu_result, 1)
+		    = build_unary_op (ADDR_EXPR, TREE_TYPE (arg), gnu_lhs);
+		}
+
+	      /* Otherwise build a regular assignment.  */
+	      else
+		gnu_result
+		  = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
+	    }
 
 	  /* If the assignment type is a regular array and the two sides are
 	     not completely disjoint, play safe and use memmove.  But don't do
@@ -7624,7 +7843,7 @@ gnat_to_gnu (Node_Id gnat_node)
     case N_Function_Call:
     case N_Procedure_Call_Statement:
       gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
-				NOT_ATOMIC, false);
+				NOT_ATOMIC, false, Empty);
       break;
 
     /************************/
@@ -8023,10 +8242,14 @@ gnat_to_gnu (Node_Id gnat_node)
 
       if (!type_annotate_only)
 	{
-	  tree gnu_ptr, gnu_ptr_type, gnu_obj_type, gnu_actual_obj_type;
-
 	  const Entity_Id gnat_desig_type
 	    = Designated_Type (Underlying_Type (Etype (gnat_temp)));
+	  const Entity_Id gnat_pool = Storage_Pool (gnat_node);
+	  const bool pool_is_storage_model
+	    = Present (gnat_pool)
+	      && Has_Storage_Model_Type_Aspect (Etype (gnat_pool))
+	      && Present (Storage_Model_Copy_From (gnat_pool));
+	  tree gnu_ptr, gnu_ptr_type, gnu_obj_type, gnu_actual_obj_type;
 
 	  /* Make sure the designated type is complete before dereferencing,
 	     in case it is a Taft Amendment type.  */
@@ -8087,12 +8310,13 @@ gnat_to_gnu (Node_Id gnat_node)
 
 	  tree gnu_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
 	  gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_ptr);
+	  if (pool_is_storage_model)
+	    gnu_size = INSTANTIATE_LOAD_IN_EXPR (gnu_size, gnat_pool);
 
 	  gnu_result
 	      = build_call_alloc_dealloc (gnu_ptr, gnu_size, gnu_obj_type,
 					  Procedure_To_Call (gnat_node),
-					  Storage_Pool (gnat_node),
-					  gnat_node);
+					  gnat_pool, gnat_node);
 	}
       break;
 
@@ -8300,7 +8524,7 @@ gnat_to_gnu (Node_Id gnat_node)
 	   && return_type_with_variable_size_p (TREE_TYPE (gnu_result)))
     ;
 
-  else if (TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF
+  else if (TREE_CODE (TREE_TYPE (gnu_result)) == UNCONSTRAINED_ARRAY_TYPE
 	   && Present (Parent (gnat_node))
 	   && Nkind (Parent (gnat_node)) == N_Attribute_Reference
 	   && lvalue_required_for_attribute_p (Parent (gnat_node)))
@@ -8739,7 +8963,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
 	 avoid blocking concatenation in the caller when it is inlined.  */
       for (int i = 0; i < call_expr_nargs (expr); i++)
 	{
-	  tree arg = *(CALL_EXPR_ARGP (expr) + i);
+	  tree arg = CALL_EXPR_ARG (expr, i);
 
 	  if (TREE_CODE (arg) == CONSTRUCTOR
 	      && TREE_CONSTANT (arg)
@@ -8751,7 +8975,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
 	      if (TREE_CODE (t) == ADDR_EXPR)
 		t = TREE_OPERAND (t, 0);
 	      if (TREE_CODE (t) != STRING_CST)
-		*(CALL_EXPR_ARGP (expr) + i) = tree_output_constant_def (arg);
+		CALL_EXPR_ARG (expr, i) = tree_output_constant_def (arg);
 	    }
 	}
       break;
@@ -8816,11 +9040,21 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
 	TREE_NO_WARNING (expr) = TREE_NO_WARNING (op);
       break;
 
-    case UNCONSTRAINED_ARRAY_REF:
-      /* We should only do this if we are just elaborating for side effects,
-	 but we can't know that yet.  */
-      *expr_p = TREE_OPERAND (*expr_p, 0);
-      return GS_OK;
+    case LOAD_EXPR:
+      {
+	tree new_var = create_tmp_var (type, "L");
+	TREE_ADDRESSABLE (new_var) = 1;
+
+	tree init = TREE_OPERAND (expr, 1);
+	gcc_assert (TREE_CODE (init) == CALL_EXPR);
+	tree arg = CALL_EXPR_ARG (init, 1);
+	CALL_EXPR_ARG (init, 1)
+	  = build_unary_op (ADDR_EXPR, TREE_TYPE (arg), new_var);
+	gimplify_and_add (init, pre_p);
+
+	*expr_p = new_var;
+	return GS_OK;
+      }
 
     case VIEW_CONVERT_EXPR:
       op = TREE_OPERAND (expr, 0);
@@ -8832,10 +9066,10 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
 	  && AGGREGATE_TYPE_P (TREE_TYPE (op))
 	  && !AGGREGATE_TYPE_P (type))
 	{
-	  tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
+	  tree new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
 	  gimple_add_tmp_var (new_var);
 
-	  mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
+	  tree mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
 	  gimplify_and_add (mod, pre_p);
 
 	  TREE_OPERAND (expr, 0) = new_var;
@@ -8843,6 +9077,12 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
 	}
       break;
 
+    case UNCONSTRAINED_ARRAY_REF:
+      /* We should only do this if we are just elaborating for side effects,
+	 but we can't know that yet.  */
+      *expr_p = TREE_OPERAND (expr, 0);
+      return GS_OK;
+
     default:
       break;
     }
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index 3d4c1c1..5942de1 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -5256,6 +5256,13 @@ maybe_unconstrained_array (tree exp)
 	    }
 	}
 
+      else if (code == LOAD_EXPR)
+	{
+	  const Entity_Id gnat_smo = tree_to_shwi (TREE_OPERAND (exp, 1));
+	  tree t = maybe_unconstrained_array (TREE_OPERAND (exp, 0));
+	  exp = build_storage_model_load (gnat_smo, t);
+	}
+
       else if (code == NULL_EXPR)
 	exp = build1 (NULL_EXPR,
 		      TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))),
diff --git a/gcc/ada/gcc-interface/utils2.cc b/gcc/ada/gcc-interface/utils2.cc
index 4c66a93..ef81f8d 100644
--- a/gcc/ada/gcc-interface/utils2.cc
+++ b/gcc/ada/gcc-interface/utils2.cc
@@ -2401,6 +2401,10 @@ tree
 build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
                  Entity_Id gnat_pool, Node_Id gnat_node, bool ignore_init_type)
 {
+  const bool pool_is_storage_model
+    = Present (gnat_pool)
+      && Has_Storage_Model_Type_Aspect (Etype (gnat_pool))
+      && Present (Storage_Model_Copy_To (gnat_pool));
   tree size, storage, storage_deref, storage_init;
 
   /* If the initializer, if present, is a NULL_EXPR, just return a new one.  */
@@ -2433,6 +2437,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
 					  get_identifier ("ALLOC"), false);
       tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
       tree storage_ptr_type = build_pointer_type (storage_type);
+      tree lhs, rhs;
 
       size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
 					     init);
@@ -2459,17 +2464,21 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
 				  build_template (template_type, type, init));
 	  CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (storage_type)),
 				  init);
-	  storage_init
-	    = build_binary_op (INIT_EXPR, NULL_TREE, storage_deref,
-			       gnat_build_constructor (storage_type, v));
+
+	  lhs = storage_deref;
+	  rhs = gnat_build_constructor (storage_type, v);
 	}
       else
-	storage_init
-	  = build_binary_op (INIT_EXPR, NULL_TREE,
-			     build_component_ref (storage_deref,
-						  TYPE_FIELDS (storage_type),
-						  false),
-			     build_template (template_type, type, NULL_TREE));
+	{
+	  lhs = build_component_ref (storage_deref, TYPE_FIELDS (storage_type),
+				     false);
+	  rhs = build_template (template_type, type, NULL_TREE);
+	}
+
+      if (pool_is_storage_model)
+	storage_init = build_storage_model_store (gnat_pool, lhs, rhs);
+      else
+	storage_init = build_binary_op (INIT_EXPR, NULL_TREE, lhs, rhs);
 
       return build2 (COMPOUND_EXPR, result_type,
 		     storage_init, convert (result_type, storage));
@@ -2509,14 +2518,263 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
       storage = gnat_protect_expr (storage);
       storage_deref = build_unary_op (INDIRECT_REF, NULL_TREE, storage);
       TREE_THIS_NOTRAP (storage_deref) = 1;
-      storage_init
-	= build_binary_op (INIT_EXPR, NULL_TREE, storage_deref, init);
+      if (pool_is_storage_model)
+	storage_init
+	  = build_storage_model_store (gnat_pool, storage_deref, init);
+      else
+	storage_init
+	  = build_binary_op (INIT_EXPR, NULL_TREE, storage_deref, init);
       return build2 (COMPOUND_EXPR, result_type, storage_init, storage);
     }
 
   return storage;
 }
 
+/* Build a call to a copy procedure of a storage model given by an object.
+   DEST, SRC and SIZE are as for a call to memcpy.  GNAT_SMO is the entity
+   for the storage model object and COPY_TO says which procedure to use.  */
+
+static tree
+build_storage_model_copy (Entity_Id gnat_smo, tree dest, tree src, tree size,
+			  bool copy_to)
+{
+  const Entity_Id gnat_copy_proc
+    = copy_to
+      ? Storage_Model_Copy_To (gnat_smo)
+      : Storage_Model_Copy_From (gnat_smo);
+  tree gnu_copy_proc = gnat_to_gnu (gnat_copy_proc);
+  tree gnu_param_type_list = TYPE_ARG_TYPES (TREE_TYPE (gnu_copy_proc));
+  tree t1 = TREE_VALUE (gnu_param_type_list);
+  tree t2 = TREE_VALUE (TREE_CHAIN (gnu_param_type_list));
+  tree t3 = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (gnu_param_type_list)));
+  tree t4
+    = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (gnu_param_type_list))));
+
+  return
+    build_call_n_expr (gnu_copy_proc,
+		       4,
+		       build_unary_op (ADDR_EXPR, t1, gnat_to_gnu (gnat_smo)),
+		       build_unary_op (ADDR_EXPR, t2, dest),
+		       build_unary_op (ADDR_EXPR, t3, src),
+		       convert (t4, size));
+}
+
+/* Build a load of SRC using the storage model of GNAT_SMO.  */
+
+tree
+build_storage_model_load (Entity_Id gnat_smo, tree src)
+{
+  tree ret = build2 (LOAD_EXPR, TREE_TYPE (src), src, NULL_TREE);
+
+  /* Unconstrained array references have no size so we need to store the
+     storage object model for future processing by the machinery.  */
+  if (TREE_CODE (src) == UNCONSTRAINED_ARRAY_REF)
+    TREE_OPERAND (ret, 1) = build_int_cst (integer_type_node, gnat_smo);
+  else
+    TREE_OPERAND (ret, 1) = build_storage_model_load (gnat_smo, src, src);
+
+  return ret;
+}
+
+/* Build a load of SRC into DEST using the storage model of GNAT_SMO.
+   If SIZE is specified, use it, otherwise use the size of SRC.  */
+
+tree
+build_storage_model_load (Entity_Id gnat_smo, tree dest, tree src, tree size)
+{
+  gcc_assert (TREE_CODE (src) != LOAD_EXPR);
+
+  if (!size)
+    {
+      size = TYPE_SIZE_UNIT (TREE_TYPE (src));
+      size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, src);
+      size = INSTANTIATE_LOAD_IN_EXPR (size, gnat_smo);
+    }
+
+  return build_storage_model_copy (gnat_smo, dest, src, size, false);
+}
+
+/* Build a store of SRC into DEST using the storage model of GNAT_SMO.
+   If SIZE is specified, use it, otherwise use the size of DEST.  */
+
+tree
+build_storage_model_store (Entity_Id gnat_smo, tree dest, tree src, tree size)
+{
+  gcc_assert (TREE_CODE (src) != LOAD_EXPR);
+
+  if (!size)
+    {
+      size = TYPE_SIZE_UNIT (TREE_TYPE (dest));
+      size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, dest);
+      size = INSTANTIATE_LOAD_IN_EXPR (size, gnat_smo);
+    }
+
+  return build_storage_model_copy (gnat_smo, dest, src, size, true);
+}
+
+/* Given a tree EXP, instantiate occurrences of LOAD_EXPR in it and associate
+   them with the storage model of GNAT_SMO.  */
+
+tree
+instantiate_load_in_expr (tree exp, Entity_Id gnat_smo)
+{
+  const enum tree_code code = TREE_CODE (exp);
+  tree type = TREE_TYPE (exp);
+  tree op0, op1, op2, op3;
+  tree new_tree;
+
+  /* We handle TREE_LIST and COMPONENT_REF separately.  */
+  if (code == TREE_LIST)
+    {
+      op0 = INSTANTIATE_LOAD_IN_EXPR (TREE_CHAIN (exp), gnat_smo);
+      op1 = INSTANTIATE_LOAD_IN_EXPR (TREE_VALUE (exp), gnat_smo);
+      if (op0 == TREE_CHAIN (exp) && op1 == TREE_VALUE (exp))
+	return exp;
+
+      return tree_cons (TREE_PURPOSE (exp), op1, op0);
+    }
+  else if (code == COMPONENT_REF)
+    {
+      /* The field.  */
+      op1 = TREE_OPERAND (exp, 1);
+
+      /* If it is a discriminant or equivalent, a LOAD_EXPR is needed.  */
+      if (DECL_DISCRIMINANT_NUMBER (op1))
+	return build_storage_model_load (gnat_smo, exp);
+
+      op0 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 0), gnat_smo);
+      if (op0 == TREE_OPERAND (exp, 0))
+	return exp;
+
+      new_tree = fold_build3 (COMPONENT_REF, type, op0, op1, NULL_TREE);
+   }
+  else
+    switch (TREE_CODE_CLASS (code))
+      {
+      case tcc_constant:
+      case tcc_declaration:
+	  return exp;
+
+      case tcc_expression:
+	if (code == LOAD_EXPR)
+	  return exp;
+
+	/* Fall through.  */
+
+      case tcc_exceptional:
+      case tcc_unary:
+      case tcc_binary:
+      case tcc_comparison:
+      case tcc_reference:
+	switch (TREE_CODE_LENGTH (code))
+	  {
+	  case 0:
+	    return exp;
+
+	  case 1:
+	    op0 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 0), gnat_smo);
+	    if (op0 == TREE_OPERAND (exp, 0))
+	      return exp;
+
+	    new_tree = fold_build1 (code, type, op0);
+	    break;
+
+	  case 2:
+	    op0 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 0), gnat_smo);
+	    op1 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 1), gnat_smo);
+
+	    if (op0 == TREE_OPERAND (exp, 0) && op1 == TREE_OPERAND (exp, 1))
+	      return exp;
+
+	    new_tree = fold_build2 (code, type, op0, op1);
+	    break;
+
+	  case 3:
+	    op0 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 0), gnat_smo);
+	    op1 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 1), gnat_smo);
+	    op2 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 2), gnat_smo);
+
+	    if (op0 == TREE_OPERAND (exp, 0)
+		&& op1 == TREE_OPERAND (exp, 1)
+		&& op2 == TREE_OPERAND (exp, 2))
+	      return exp;
+
+	    new_tree = fold_build3 (code, type, op0, op1, op2);
+	    break;
+
+	  case 4:
+	    op0 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 0), gnat_smo);
+	    op1 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 1), gnat_smo);
+	    op2 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 2), gnat_smo);
+	    op3 = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (exp, 3), gnat_smo);
+
+	    if (op0 == TREE_OPERAND (exp, 0)
+		&& op1 == TREE_OPERAND (exp, 1)
+		&& op2 == TREE_OPERAND (exp, 2)
+		&& op3 == TREE_OPERAND (exp, 3))
+	      return exp;
+
+	    new_tree = fold (build4 (code, type, op0, op1, op2, op3));
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+	  }
+	break;
+
+      case tcc_vl_exp:
+	{
+	  gcc_assert (code == CALL_EXPR);
+
+	  const int n = call_expr_nargs (exp);
+	  gcc_assert (n > 0);
+	  tree *argarray = XALLOCAVEC (tree, n);
+	  for (int i = 0; i < n; i++)
+	    argarray[i]
+	      = INSTANTIATE_LOAD_IN_EXPR (CALL_EXPR_ARG (exp, i), gnat_smo);
+
+	  for (int i = 0; i < n; i++)
+	    if (argarray[i] != CALL_EXPR_ARG (exp, i))
+	      return build_call_array (type, CALL_EXPR_FN (exp), n, argarray);
+
+	  return exp;
+	}
+
+      default:
+	gcc_unreachable ();
+      }
+
+  TREE_READONLY (new_tree) |= TREE_READONLY (exp);
+
+  if (code == INDIRECT_REF || code == ARRAY_REF || code == ARRAY_RANGE_REF)
+    TREE_THIS_NOTRAP (new_tree) |= TREE_THIS_NOTRAP (exp);
+
+  return new_tree;
+}
+
+/* Given an array or slice reference, instantiate occurrences of LOAD_EXPR in
+   it and associate them with the storage model of GNAT_SMO.  */
+
+void
+instantiate_load_in_array_ref (tree ref, Entity_Id gnat_smo)
+{
+  tree domain_type = TYPE_DOMAIN (TREE_TYPE (TREE_OPERAND (ref, 0)));
+  tree elem_type = TREE_TYPE (TREE_TYPE (TREE_OPERAND (ref, 0)));
+
+  TREE_OPERAND (ref, 2)
+    = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_MIN_VALUE (domain_type), ref);
+  TREE_OPERAND (ref, 2)
+    = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (ref, 2), gnat_smo);
+
+  TREE_OPERAND (ref, 3)
+    = size_binop (EXACT_DIV_EXPR,
+		  SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (elem_type),
+						  ref),
+		  size_int (TYPE_ALIGN_UNIT (elem_type)));
+  TREE_OPERAND (ref, 3)
+    = INSTANTIATE_LOAD_IN_EXPR (TREE_OPERAND (ref, 3), gnat_smo);
+}
+
 /* Indicate that we need to take the address of T and that it therefore
    should not be allocated in a register.  Return true if successful.  */
 
@@ -2816,7 +3074,7 @@ gnat_rewrite_reference (tree ref, rewrite_fn func, void *data, tree *init)
 		  gnat_rewrite_reference (TREE_OPERAND (ref, 0), func, data,
 					  init),
 		  func (TREE_OPERAND (ref, 1), data),
-		  TREE_OPERAND (ref, 2), NULL_TREE);
+		  TREE_OPERAND (ref, 2), TREE_OPERAND (ref, 3));
       break;
 
     case COMPOUND_EXPR:
@@ -2901,9 +3159,6 @@ get_inner_constant_reference (tree exp)
 	case ARRAY_REF:
 	case ARRAY_RANGE_REF:
 	  {
-	    if (TREE_OPERAND (exp, 2))
-	      return NULL_TREE;
-
 	    tree array_type = TREE_TYPE (TREE_OPERAND (exp, 0));
 	    if (!TREE_CONSTANT (TREE_OPERAND (exp, 1))
 	        || !TREE_CONSTANT (TYPE_MIN_VALUE (TYPE_DOMAIN (array_type)))
@@ -3044,8 +3299,13 @@ gnat_invariant_expr (tree expr)
 
 	case ARRAY_REF:
 	case ARRAY_RANGE_REF:
-	  if (!TREE_CONSTANT (TREE_OPERAND (t, 1)) || TREE_OPERAND (t, 2))
-	    return NULL_TREE;
+	  {
+	    tree array_type = TREE_TYPE (TREE_OPERAND (t, 0));
+	    if (!TREE_CONSTANT (TREE_OPERAND (t, 1))
+	        || !TREE_CONSTANT (TYPE_MIN_VALUE (TYPE_DOMAIN (array_type)))
+	        || !TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (array_type))))
+	      return NULL_TREE;
+	  }
 	  break;
 
 	case BIT_FIELD_REF:
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 64f2e79..e79cdee 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -3,7 +3,7 @@
 @setfilename gnat_rm.info
 @documentencoding UTF-8
 @ifinfo
-@*Generated by Sphinx 5.1.1.@*
+@*Generated by Sphinx 5.2.3.@*
 @end ifinfo
 @settitle GNAT Reference Manual
 @defindex ge
@@ -19,7 +19,7 @@
 
 @copying
 @quotation
-GNAT Reference Manual , Sep 23, 2022
+GNAT Reference Manual , Oct 04, 2022
 
 AdaCore
 
@@ -5243,14 +5243,14 @@ May reference only one protected component
 
 @item 
 May not reference nonconstant entities outside the protected subprogram
-scope.
+scope
 
 @item 
 May not contain address representation items, allocators, or quantified
-expressions.
+expressions
 
 @item 
-May not contain delay, goto, loop, or procedure-call statements.
+May not contain delay, goto, loop, or procedure-call statements
 
 @item 
 May not contain exported and imported entities
@@ -28734,6 +28734,55 @@ pragma Machine_Attribute (Var, "strub");
 --  scrubbing of the stack space used by that subprogram.
 @end example
 
+Given these declarations, Foo has its type and body modified as
+follows:
+
+@example
+function Foo (<WaterMark> : in out System.Address) returns Integer
+is
+  --  ...
+begin
+  <__strub_update> (<WaterMark>);  --  Updates the stack WaterMark.
+  --  ...
+end;
+@end example
+
+whereas its callers are modified from:
+
+@example
+X := Foo;
+@end example
+
+to:
+
+@example
+declare
+  <WaterMark> : System.Address;
+begin
+  <__strub_enter> (<WaterMark>);  -- Initialize <WaterMark>.
+  X := Foo (<WaterMark>);
+  <__strub_leave> (<WaterMark>);  -- Scrubs stack up to <WaterMark>.
+end;
+@end example
+
+As for Bar, because it is strubbed in internal mode, its callers are
+not modified.  Its definition is modified roughly as follows:
+
+@example
+procedure Bar is
+  <WaterMark> : System.Address;
+  procedure Strubbed_Bar (<WaterMark> : in out System.Address) is
+  begin
+    <__strub_update> (<WaterMark>);  --  Updates the stack WaterMark.
+    -- original Bar body.
+  end Strubbed_Bar;
+begin
+  <__strub_enter> (<WaterMark>);  -- Initialize <WaterMark>.
+  Strubbed_Bar (<WaterMark>);
+  <__strub_leave> (<WaterMark>);  -- Scrubs stack up to <WaterMark>.
+end Bar;
+@end example
+
 There are also @code{-fstrub=`choice'} command-line options to
 control default settings.  For usage and more details on the
 command-line options, on the @code{strub} attribute, and their use with
@@ -28809,11 +28858,54 @@ activated by a separate command-line option.
 
 The option @code{-fharden-compares} enables hardening of compares
 that compute results stored in variables, adding verification that the
-reversed compare yields the opposite result.
+reversed compare yields the opposite result, turning:
+
+@example
+B := X = Y;
+@end example
+
+into:
+
+@example
+B := X = Y;
+declare
+  NotB : Boolean := X /= Y; -- Computed independently of B.
+begin
+  if B = NotB then
+    <__builtin_trap>;
+  end if;
+end;
+@end example
 
 The option @code{-fharden-conditional-branches} enables hardening
 of compares that guard conditional branches, adding verification of
-the reversed compare to both execution paths.
+the reversed compare to both execution paths, turning:
+
+@example
+if X = Y then
+  X := Z + 1;
+else
+  Y := Z - 1;
+end if;
+@end example
+
+into:
+
+@example
+if X = Y then
+  if X /= Y then -- Computed independently of X = Y.
+    <__builtin_trap>;
+  end if;
+  X := Z + 1;
+else
+  if X /= Y then -- Computed independently of X = Y.
+    null;
+  else
+    <__builtin_trap>;
+  end if;
+  Y := Z - 1;
+end if;
+@end example
 
 These transformations are introduced late in the compilation pipeline,
 long after boolean expressions are decomposed into separate compares,
@@ -28871,17 +28963,37 @@ further remove checks found to be redundant.
 For additional hardening, the @code{hardbool} @code{Machine_Attribute}
 pragma can be used to annotate boolean types with representation
 clauses, so that expressions of such types used as conditions are
-checked even when compiling with @code{-gnatVT}.
+checked even when compiling with @code{-gnatVT}:
 
 @example
 pragma Machine_Attribute (HBool, "hardbool");
+
+function To_Boolean (X : HBool) returns Boolean is (Boolean (X));
+@end example
+
+is compiled roughly like:
+
+@example
+function To_Boolean (X : HBool) returns Boolean is
+begin
+  if X not in True | False then
+    raise Constraint_Error;
+  elsif X in True then
+    return True;
+  else
+    return False;
+  end if;
+end To_Boolean;
 @end example
 
 Note that @code{-gnatVn} will disable even @code{hardbool} testing.
 
 Analogous behavior is available as a GCC extension to the C and
-Objective C programming languages, through the @code{hardbool} attribute.
-For usage and more details on that attribute, see @cite{Using the GNU Compiler Collection (GCC)}.
+Objective C programming languages, through the @code{hardbool} attribute,
+with the difference that, instead of raising a Constraint_Error
+exception, when a hardened boolean variable is found to hold a value
+that stands for neither True nor False, the program traps.  For usage
+and more details on that attribute, see @cite{Using the GNU Compiler Collection (GCC)}.
 
 @c Control Flow Redundancy:
 
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index ceaf66b..6824941 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -1467,12 +1467,17 @@ package body Sem_Ch4 is
       end if;
 
       --  Check the accessibility level for actuals for explicitly aliased
-      --  formals.
+      --  formals when a function call appears within a return statement.
+      --  This is only checked if the enclosing subprogram Comes_From_Source,
+      --  to avoid issuing errors on calls occurring in wrapper subprograms
+      --  (for example, where the call is part of an expression of an aspect
+      --  associated with a wrapper, such as Pre'Class).
 
       if Nkind (N) = N_Function_Call
         and then Comes_From_Source (N)
         and then Present (Nam_Ent)
         and then In_Return_Value (N)
+        and then Comes_From_Source (Current_Subprogram)
       then
          declare
             Form : Node_Id;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 7db0cb7..7ad6408 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -2398,7 +2398,7 @@ package body Sem_Ch6 is
                            Class_Wide_Type (Etype (First_Formal (Subp))) = Typ)
                  and then Try_Object_Operation (P)
                then
-                  return;
+                  goto Leave;
 
                else
                   Analyze_Call_And_Resolve;
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index cae0f23..f2a5901 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -178,8 +178,6 @@ package body Sem_Ch9 is
                elsif Nkind (Decl) = N_Subprogram_Declaration
                  and then
                    Nkind (Specification (Decl)) = N_Procedure_Specification
-                 and then
-                   Present (Parameter_Specifications (Specification (Decl)))
                then
                   declare
                      Par_Specs : constant List_Id   :=
@@ -455,7 +453,7 @@ package body Sem_Ch9 is
 
                   --  Goto statements restricted
 
-                  elsif Kind = N_Goto_Statement then
+                  elsif Kind in N_Goto_Statement | N_Goto_When_Statement then
                      if Lock_Free_Given then
                         Error_Msg_N ("goto statement not allowed", N);
                         return Skip;
@@ -477,7 +475,7 @@ package body Sem_Ch9 is
                         --  Prohibit references to non-constant entities
                         --  outside the protected subprogram scope.
 
-                        if Ekind (Id) in Assignable_Kind
+                        if Is_Assignable (Id)
                           and then not
                             Scope_Within_Or_Same (Scope (Id), Sub_Id)
                           and then not
@@ -487,8 +485,8 @@ package body Sem_Ch9 is
                         then
                            if Lock_Free_Given then
                               Error_Msg_NE
-                                ("reference to global variable& not " &
-                                 "allowed", N, Id);
+                                ("reference to global variable& not allowed",
+                                 N, Id);
                               return Skip;
                            end if;
 
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 77ff68e..f85d091 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -25731,6 +25731,13 @@ package body Sem_Prag is
                        ("argument of pragma% must be On/Off or static string "
                         & "expression", Arg1);
 
+                  --  Use of pragma Warnings to set warning switches is
+                  --  ignored in GNATprove mode, as these switches apply to
+                  --  the compiler only.
+
+                  elsif GNATprove_Mode then
+                     null;
+
                   --  One argument string expression case
 
                   else
@@ -31608,7 +31615,7 @@ package body Sem_Prag is
       Pragma_Refined_Depends                => -1,
       Pragma_Refined_Global                 => -1,
       Pragma_Refined_Post                   => -1,
-      Pragma_Refined_State                  => -1,
+      Pragma_Refined_State                  =>  0,
       Pragma_Relative_Deadline              =>  0,
       Pragma_Remote_Access_Type             => -1,
       Pragma_Remote_Call_Interface          => -1,
@@ -31713,6 +31720,15 @@ package body Sem_Prag is
       P := Parent (N);
 
       if Nkind (P) /= N_Pragma_Argument_Association then
+
+         --  References within pragma Refined_State are not significant. They
+         --  can't be recognized using pragma argument number, because they
+         --  appear inside refinement clauses that rely on aggregate syntax.
+
+         if In_Pragma_Expression (N, Name_Refined_State) then
+            return True;
+         end if;
+
          return False;
 
       else
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 132c2b8..c23d358 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -3655,10 +3655,14 @@ package Sem_Util is
       function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean;
       --  Returns True iff Typ specifies aspect Storage_Model_Type
 
+      --  WARNING: There is a matching C declaration of this subprogram in fe.h
+
       function Has_Designated_Storage_Model_Aspect
         (Typ : Entity_Id) return Boolean;
       --  Returns True iff Typ specifies aspect Designated_Storage_Model
 
+      --  WARNING: There is a matching C declaration of this subprogram in fe.h
+
       function Storage_Model_Object (Typ : Entity_Id) return Entity_Id;
       --  Given an access type Typ with aspect Designated_Storage_Model,
       --  returns the storage-model object associated with that type.
@@ -3666,6 +3670,8 @@ package Sem_Util is
       --  other functions declared in this interface to retrieve operations
       --  associated with Storage_Model_Type aspect of the object's type.
 
+      --  WARNING: There is a matching C declaration of this subprogram in fe.h
+
       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.
@@ -3715,12 +3721,16 @@ package Sem_Util is
       --  type, returns the procedure specified for the Copy_From choice in
       --  that aspect; returns Empty if the procedure isn't specified.
 
+      --  WARNING: There is a matching C declaration of this subprogram in fe.h
+
       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.
 
+      --  WARNING: There is a matching C declaration of this subprogram in fe.h
+
       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